├── .gitignore ├── README.md ├── exercises ├── CS410-Categories.agda ├── CS410-Prelude.agda ├── Ex1.agda ├── Ex2.agda └── Ex3.agda ├── lectures ├── ANSIEscapes.hs ├── Ex2.agda ├── HaskellSetup.hs ├── Lec1.agda ├── Lec1Done.agda ├── Lec1Start.agda ├── Lec2.agda ├── Lec2Done.agda ├── Lec2Start.agda ├── Lec3.agda ├── Lec3Done.agda ├── Lec3Start.agda ├── Lec4.agda ├── Lec4Done.agda ├── Lec4HS.hs ├── Lec5.agda ├── Lec6.agda ├── Lec6Done.agda ├── Lec7.agda ├── cheat-sheet.txt └── comedy.el └── nowyoutry ├── Lec1Start.agda ├── Lec2Start.agda └── Lec3Start.agda /.gitignore: -------------------------------------------------------------------------------- 1 | *.agdai 2 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # CS410-17 2 | being the lecture materials and exercises for the 2017/18 session of CS410 Advanced Functional Programming at the University of Strathclyde 3 | 4 | Strathclyders only: one minute papers and lecture videos will appear on our [Marx site](https://personal.cis.strath.ac.uk/conor.mcbride/Marx/?page=CS410). 5 | 6 | ## Installation instructions 7 | 0. Check if you're using bash 8 | $ echo $0 9 | 1. If using bash: Add "export PATH=$HOME/.cabal/bin:$PATH" to the bottom of your .profile file if it isn't already there. 10 | Else if using tcsh: Add "set path = ($home/.cabal/bin $path)" to the bottom of your .cshrc file if it isn't already there. 11 | 12 | 2. $ cabal update 13 | 3. $ cabal install alex 14 | 4. $ cabal install cpphs 15 | 5. $ cabal install happy 16 | 6. $ cabal install Agda 17 | 7. $ agda-mode setup 18 | 8. $ emacs test.agda -- You should see an Agda menu and (Agda) in the mode line. 19 | 9. $ git clone https://github.com/pigworker/CS410-17 20 | 21 | ## Lecture videos on YouTube 22 | 23 | 1. [Tuesday 19 September](https://www.youtube.com/watch?v=O4oczQry9Jw) Programs and Proofs 24 | 2. [Friday 22 September](https://www.youtube.com/watch?v=qcVZxQTouDk) more Programs and Proofs, Introducing "with" 25 | 3. [Tuesday 26 September](https://www.youtube.com/watch?v=8xFT9FPlm18) Proof by Induction 26 | 4. [Friday 29 September](https://www.youtube.com/watch?v=OZeDRtRmgkw) Sigma, Difference, Vector Take 27 | 5. [Tuesday 3 October](https://www.youtube.com/watch?v=b5salYMZoyM) How Rewrite Works 28 | 6. [Friday 6 October](https://www.youtube.com/watch?v=RW4aC_6n0yQ) A Comedy of (Entirely Non-Deliberate) Errors 29 | 7. [Tuesday 10 October](https://www.youtube.com/watch?v=2LxtHeZlaVw) "Dominoes", no really, this time 30 | 8. [Friday 13 October](https://www.youtube.com/watch?v=RCRddhYegzI) Functors 31 | 9. [Tuesday 17 October](https://www.youtube.com/watch?v=vTmYvoDrBlc) From Functors to Monads 32 | 10. [Friday 20 October](https://www.youtube.com/watch?v=2sykXdidZVA) Natural Transformations and Monads 33 | 11. [Tuesday 24 October](https://www.youtube.com/watch?v=iYegg8Rzhr4) From Monads to Input/Output 34 | 12. [Friday 27 October](https://www.youtube.com/watch?v=8WUz2HmXBqI) How to Run a Program (and come a-cropper) [bug report](https://github.com/agda/agda/issues/2821) 35 | 13. [Tuesday 31 October](https://www.youtube.com/watch?v=MwtWdiyFJtA) Monads on Indexed Sets (Ex2) 36 | 14. [Friday 3 November](https://www.youtube.com/watch?v=kX3mvyFHDDU) What is an Application? 37 | 15. [Tuesday 7 November](https://www.youtube.com/watch?v=ZCdYIEwcna0) Coinduction and Coalgebras 38 | 16. [Friday 10 November](https://www.youtube.com/watch?v=AjyUNakYHRs) Polynomial Data and Codata 39 | 17. [Tuesday 14 November](https://www.youtube.com/watch?v=E8xIJolKEAI) A Polynomial Universe 40 | 18. [Friday 17 November](https://www.youtube.com/watch?v=-3MiZ80WldY) The Zipper (Differentiating Polynomial Types) 41 | 42 | ## Other useful stuff 43 | 44 | 1. [SpaceMonads!](https://www.youtube.com/watch?v=QojLQY5H0RI) my keynote from CodeMesh 2016, on which Ex2 is based 45 | -------------------------------------------------------------------------------- /exercises/CS410-Categories.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | module CS410-Categories where 3 | 4 | open import CS410-Prelude 5 | 6 | postulate 7 | extensionality : {S : Set}{T : S -> Set} 8 | {f g : (x : S) -> T x} -> 9 | ((x : S) -> f x == g x) -> 10 | f == g 11 | 12 | imp : {S : Set}{T : S -> Set}(f : (x : S) -> T x){x : S} -> T x 13 | imp f {x} = f x 14 | 15 | extensionality' : {S : Set}{T : S -> Set} 16 | {f g : {x : S} -> T x} -> 17 | ((x : S) -> f {x} == g {x}) -> 18 | _==_ {forall {x : S} -> T x} f g 19 | extensionality' {f = f}{g = g} q = 20 | refl imp =$= extensionality {f = \ x -> f {x}}{g = \ x -> g {x}} 21 | q 22 | 23 | _=$'_ : {S : Set}{T : S -> Set} 24 | {f g : {x : S} -> T x} -> 25 | _==_ {forall {x : S} -> T x} f g -> 26 | (x : S) -> f {x} == g {x} 27 | refl f =$' x = refl (f {x}) 28 | 29 | infixl 2 _=$'_ 30 | 31 | record Category : Set where 32 | field 33 | 34 | -- two types of thing 35 | Obj : Set -- "objects" 36 | _~>_ : Obj -> Obj -> Set -- "arrows" or "morphisms" 37 | -- or "homomorphisms" 38 | 39 | -- two operations 40 | id~> : {T : Obj} -> T ~> T 41 | _>~>_ : {R S T : Obj} -> R ~> S -> S ~> T -> R ~> T 42 | 43 | -- three laws 44 | law-id~>>~> : {S T : Obj} (f : S ~> T) -> 45 | (id~> >~> f) == f 46 | law->~>id~> : {S T : Obj} (f : S ~> T) -> 47 | (f >~> id~>) == f 48 | law->~>>~> : {Q R S T : Obj} (f : Q ~> R)(g : R ~> S)(h : S ~> T) -> 49 | ((f >~> g) >~> h) == (f >~> (g >~> h)) 50 | 51 | assocn : {Q R R' S T : Obj} 52 | {f : Q ~> R} {g : R ~> S} 53 | {f' : Q ~> R'}{g' : R' ~> S} 54 | {h : S ~> T} -> 55 | (f >~> g) == (f' >~> g') -> 56 | (f >~> g >~> h) == (f' >~> g' >~> h) 57 | assocn {f = f} {g = g} {f' = f'} {g' = g'} {h = h} q = 58 | f >~> g >~> h 59 | =< law->~>>~> _ _ _ ]= 60 | (f >~> g) >~> h 61 | =[ refl _>~>_ =$= q =$= refl h >= 62 | (f' >~> g') >~> h 63 | =[ law->~>>~> _ _ _ >= 64 | f' >~> g' >~> h 65 | [QED] 66 | 67 | infixr 3 _>~>_ 68 | 69 | -- Sets and functions are the classic example of a category. 70 | SET : Category 71 | SET = record 72 | { Obj = Set 73 | ; _~>_ = \ S T -> S -> T 74 | ; id~> = id 75 | ; _>~>_ = _>>_ 76 | ; law-id~>>~> = \ f -> refl f 77 | ; law->~>id~> = \ f -> refl f 78 | ; law->~>>~> = \ f g h -> refl (f >> (g >> h)) 79 | } 80 | 81 | module FUNCTOR where 82 | open Category 83 | 84 | record _=>_ (C D : Category) : Set where -- "Functor from C to D" 85 | field 86 | -- two actions 87 | F-Obj : Obj C -> Obj D 88 | F-map : {S T : Obj C} -> _~>_ C S T -> _~>_ D (F-Obj S) (F-Obj T) 89 | 90 | -- two laws 91 | F-map-id~> : {T : Obj C} -> F-map (id~> C {T}) == id~> D {F-Obj T} 92 | F-map->~> : {R S T : Obj C}(f : _~>_ C R S)(g : _~>_ C S T) -> 93 | F-map (_>~>_ C f g) == _>~>_ D (F-map f) (F-map g) 94 | 95 | open FUNCTOR public 96 | 97 | ID : {C : Category} -> C => C 98 | ID = record 99 | { F-Obj = id 100 | ; F-map = id 101 | ; F-map-id~> = refl _ 102 | ; F-map->~> = \ f g -> refl _ 103 | } 104 | 105 | module FUNCTOR-CP {C D E : Category} where 106 | open _=>_ 107 | open Category 108 | 109 | _>=>_ : C => D -> D => E -> C => E 110 | 111 | F-Obj (F >=> G) = F-Obj F >> F-Obj G 112 | 113 | F-map (F >=> G) = F-map F >> F-map G 114 | 115 | F-map-id~> (F >=> G) = 116 | F-map G (F-map F (id~> C)) 117 | =[ refl (F-map G) =$= F-map-id~> F >= 118 | F-map G (id~> D) 119 | =[ F-map-id~> G >= 120 | id~> E 121 | [QED] 122 | 123 | F-map->~> (F >=> G) f g = 124 | F-map G (F-map F (_>~>_ C f g)) 125 | =[ refl (F-map G) =$= F-map->~> F f g >= 126 | F-map G (_>~>_ D (F-map F f) (F-map F g)) 127 | =[ F-map->~> G (F-map F f) (F-map F g) >= 128 | _>~>_ E (F-map G (F-map F f)) (F-map G (F-map F g)) 129 | [QED] 130 | 131 | open FUNCTOR-CP public 132 | 133 | module NATURAL-TRANSFORMATION {C D : Category} where 134 | open Category 135 | open _=>_ 136 | 137 | record _~~>_ (F G : C => D) : Set where 138 | field 139 | -- one operation 140 | xf : {X : Obj C} -> _~>_ D (F-Obj F X) (F-Obj G X) 141 | -- one law 142 | naturality : {X Y : Obj C}(f : _~>_ C X Y) -> 143 | _>~>_ D (F-map F f) (xf {Y}) 144 | == 145 | _>~>_ D (xf {X}) (F-map G f) 146 | 147 | open NATURAL-TRANSFORMATION public 148 | open _~~>_ public 149 | 150 | 151 | module MONAD {C : Category}(M : C => C) where 152 | open Category C 153 | open _=>_ M 154 | 155 | record Monad : Set where 156 | field 157 | unit : ID ~~> M 158 | mult : (M >=> M) ~~> M 159 | 160 | unitMult : {X : Obj} -> (xf unit >~> xf mult) == id~> {F-Obj X} 161 | multUnit : {X : Obj} -> (F-map (xf unit) >~> xf mult) == id~> {F-Obj X} 162 | multMult : {X : Obj} -> (xf mult >~> xf mult) == (F-map (xf mult) >~> xf mult {X}) 163 | 164 | KLEISLI : Category 165 | KLEISLI = record 166 | { Obj = Obj 167 | ; _~>_ = \ S T -> S ~> F-Obj T 168 | ; id~> = xf unit 169 | ; _>~>_ = \ f g -> f >~> F-map g >~> xf mult 170 | ; law-id~>>~> = \ f -> 171 | xf unit >~> F-map f >~> xf mult 172 | =< law->~>>~> _ _ _ ]= 173 | (xf unit >~> F-map f) >~> xf mult 174 | =< refl (_>~> xf mult) =$= naturality unit f ]= 175 | (f >~> xf unit) >~> xf mult 176 | =[ law->~>>~> _ _ _ >= 177 | f >~> (xf unit >~> xf mult) 178 | =[ refl (f >~>_) =$= unitMult >= 179 | f >~> id~> 180 | =[ law->~>id~> f >= 181 | f [QED] 182 | ; law->~>id~> = \ f -> 183 | f >~> (F-map (xf unit) >~> xf mult) 184 | =[ refl (f >~>_) =$= multUnit >= 185 | f >~> id~> 186 | =[ law->~>id~> f >= 187 | f [QED] 188 | ; law->~>>~> = \ f g h -> 189 | (f >~> F-map g >~> xf mult) >~> F-map h >~> xf mult 190 | =[ law->~>>~> _ _ _ >= 191 | f >~> (F-map g >~> xf mult) >~> (F-map h >~> xf mult) 192 | =[ refl (\ x -> _ >~> x) =$= law->~>>~> _ _ _ >= 193 | f >~> F-map g >~> xf mult >~> F-map h >~> xf mult 194 | =< refl (\ x -> _ >~> _ >~> x) =$= assocn (naturality mult _) ]= 195 | f >~> F-map g >~> F-map (F-map h) >~> xf mult >~> xf mult 196 | =[ refl (\ x -> _ >~> _ >~> _ >~> x) =$= multMult >= 197 | f >~> F-map g >~> F-map (F-map h) >~> F-map (xf mult) >~> xf mult 198 | =< refl (\ x -> _ >~> _ >~> x) =$= law->~>>~> _ _ _ ]= 199 | f >~> F-map g >~> (F-map (F-map h) >~> F-map (xf mult)) >~> xf mult 200 | =< refl (\ x -> _ >~> _ >~> x >~> _) =$= F-map->~> _ _ ]= 201 | f >~> F-map g >~> F-map (F-map h >~> xf mult) >~> xf mult 202 | =< refl (\ x -> _ >~> x) =$= law->~>>~> _ _ _ ]= 203 | f >~> (F-map g >~> F-map (F-map h >~> xf mult)) >~> xf mult 204 | =< refl (\ x -> _ >~> x >~> _) =$= F-map->~> _ _ ]= 205 | f >~> F-map (g >~> F-map h >~> xf mult) >~> xf mult 206 | [QED] 207 | } 208 | 209 | 210 | -------------------------------------------------------------------------------- /exercises/CS410-Prelude.agda: -------------------------------------------------------------------------------- 1 | module CS410-Prelude where 2 | 3 | 4 | ------------------------------------------------------------------------------ 5 | ------------------------------------------------------------------------------ 6 | -- Standard Equipment for use in Exercises 7 | ------------------------------------------------------------------------------ 8 | ------------------------------------------------------------------------------ 9 | 10 | 11 | ------------------------------------------------------------------------------ 12 | -- functional equipment (types may be generalized later) 13 | ------------------------------------------------------------------------------ 14 | 15 | -- the polymorphic identity function 16 | id : {X : Set} -> X -> X 17 | id x = x 18 | 19 | -- standard composition: f << g is "f after g" 20 | _<<_ : {X Y Z : Set} -> (Y -> Z) -> (X -> Y) -> (X -> Z) 21 | (f << g) x = f (g x) 22 | 23 | -- diagrammatic composition: f >> g is "f then g" 24 | _>>_ : {X Y Z : Set} -> (X -> Y) -> (Y -> Z) -> (X -> Z) 25 | -- ^^^^^^^^ dominoes! 26 | (f >> g) x = g (f x) 27 | infixr 5 _>>_ 28 | 29 | -- infix application 30 | _$_ : {S : Set}{T : S -> Set}(f : (x : S) -> T x)(s : S) -> T s 31 | f $ s = f s 32 | infixl 2 _$_ 33 | 34 | 35 | ------------------------------------------------------------------------------ 36 | -- some basic "logical" types 37 | ------------------------------------------------------------------------------ 38 | 39 | data Zero : Set where 40 | -- to give a value in a data, choose one constructor 41 | -- there are no constructors 42 | -- so that's impossible 43 | 44 | record One : Set where 45 | -- to give a value in a record type, fill all its fields 46 | -- there are no fields 47 | -- so that's trivial 48 | -- (can we have a constructor, for convenience?) 49 | constructor <> 50 | 51 | data _+_ (S : Set)(T : Set) : Set where -- "where" wants an indented block 52 | -- to offer a choice of constructors, list them with their types 53 | inl : S -> S + T -- constructors can pack up stuff 54 | inr : T -> S + T 55 | -- in Haskell, this was called "Either S T" 56 | 57 | record Sg (S : Set)(T : S -> Set) : Set where -- Sg is short for "Sigma" 58 | constructor _,_ 59 | field -- introduces a bunch of fields, listed with their types 60 | fst : S 61 | snd : T fst 62 | -- make _*_ from Sg ? 63 | open Sg public 64 | 65 | _*_ : Set -> Set -> Set 66 | S * T = Sg S \ _ -> T 67 | 68 | infixr 4 _,_ _*_ 69 | 70 | 71 | ------------------------------------------------------------------------------ 72 | -- natural numbers and addition 73 | ------------------------------------------------------------------------------ 74 | 75 | data Nat : Set where 76 | zero : Nat 77 | suc : Nat -> Nat -- recursive data type 78 | 79 | {-# BUILTIN NATURAL Nat #-} 80 | -- ^^^^^^^^^^^^^^^^^^^ this pragma lets us use decimal notation 81 | 82 | _+N_ : Nat -> Nat -> Nat 83 | zero +N y = y 84 | suc x +N y = suc (x +N y) -- there are other choices 85 | 86 | 87 | ------------------------------------------------------------------------------ 88 | -- equality 89 | ------------------------------------------------------------------------------ 90 | 91 | data _==_ {X : Set} : X -> X -> Set where 92 | refl : (x : X) -> x == x -- the relation that's "only reflexive" 93 | 94 | {-# BUILTIN EQUALITY _==_ #-} -- we'll see what that's for, later 95 | 96 | _=$=_ : {X Y : Set}{f f' : X -> Y}{x x' : X} -> 97 | f == f' -> x == x' -> f x == f' x' 98 | refl f =$= refl x = refl (f x) 99 | 100 | _=$_ : {S : Set}{T : S -> Set}{f g : (x : S) -> T x} -> (f == g) -> (x : S) -> f x == g x 101 | refl f =$ x = refl (f x) 102 | 103 | infixl 2 _=$=_ _=$_ 104 | 105 | sym : {X : Set}{x y : X} -> x == y -> y == x 106 | sym (refl x) = refl x 107 | 108 | _[QED] : {X : Set}(x : X) -> x == x 109 | x [QED] = refl x 110 | _=[_>=_ : {X : Set}(x : X){y z : X} -> x == y -> y == z -> x == z 111 | x =[ refl .x >= q = q 112 | _=<_]=_ : {X : Set}(x : X){y z : X} -> y == x -> y == z -> x == z 113 | x =< refl .x ]= q = q 114 | infixr 1 _=[_>=_ _=<_]=_ 115 | infixr 2 _[QED] 116 | 117 | 118 | ------------------------------------------------------------------------------ 119 | -- greater-than-or-equals 120 | ------------------------------------------------------------------------------ 121 | 122 | _>=_ : Nat -> Nat -> Set 123 | x >= zero = One 124 | zero >= suc y = Zero 125 | suc x >= suc y = x >= y 126 | 127 | refl->= : (n : Nat) -> n >= n 128 | refl->= zero = record {} 129 | refl->= (suc n) = refl->= n 130 | 131 | trans->= : (x y z : Nat) -> x >= y -> y >= z -> x >= z 132 | trans->= x y zero x>=y y>=z = record {} 133 | trans->= x zero (suc z) x>=y () 134 | trans->= zero (suc y) (suc z) () y>=z 135 | trans->= (suc x) (suc y) (suc z) x>=y y>=z = trans->= x y z x>=y y>=z 136 | 137 | suc->= : (x : Nat) -> suc x >= x 138 | suc->= zero = <> 139 | suc->= (suc x) = suc->= x 140 | 141 | 142 | ---------------------------------------------------------------------------- 143 | -- Two -- the type of Boolean values 144 | ---------------------------------------------------------------------------- 145 | 146 | data Two : Set where tt ff : Two 147 | {-# BUILTIN BOOL Two #-} 148 | {-# BUILTIN TRUE tt #-} 149 | {-# BUILTIN FALSE ff #-} 150 | 151 | -- nondependent conditional with traditional syntax 152 | if_then_else_ : forall {l}{X : Set l} -> Two -> X -> X -> X 153 | if tt then t else e = t 154 | if ff then t else e = e 155 | 156 | -- dependent conditional cooked for partial application 157 | caseTwo : forall {l}{P : Two -> Set l} -> P tt -> P ff -> (b : Two) -> P b 158 | caseTwo t f tt = t 159 | caseTwo t f ff = f 160 | 161 | 162 | ---------------------------------------------------------------------------- 163 | -- lists 164 | ---------------------------------------------------------------------------- 165 | 166 | data List (X : Set) : Set where 167 | [] : List X 168 | _,-_ : (x : X)(xs : List X) -> List X 169 | infixr 4 _,-_ 170 | {-# COMPILE GHC List = data [] ([] | (:)) #-} 171 | {-# BUILTIN LIST List #-} 172 | {-# BUILTIN NIL [] #-} 173 | {-# BUILTIN CONS _,-_ #-} 174 | 175 | 176 | ---------------------------------------------------------------------------- 177 | -- chars and strings 178 | ---------------------------------------------------------------------------- 179 | 180 | postulate -- this means that we just suppose the following things exist... 181 | Char : Set 182 | String : Set 183 | {-# BUILTIN CHAR Char #-} 184 | {-# BUILTIN STRING String #-} 185 | 186 | primitive -- these are baked in; they even work! 187 | primCharEquality : Char -> Char -> Two 188 | primStringAppend : String -> String -> String 189 | primStringToList : String -> List Char 190 | primStringFromList : List Char -> String 191 | 192 | 193 | -------------------------------------------------------------------------------- /exercises/Ex1.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --allow-unsolved-metas #-} 2 | ------------------------------------------------------------------------------ 3 | ------------------------------------------------------------------------------ 4 | -- CS410 2017/18 Exercise 1 VECTORS AND FRIENDS (worth 25%) 5 | ------------------------------------------------------------------------------ 6 | ------------------------------------------------------------------------------ 7 | 8 | -- NOTE (19/9/17) This file is currently incomplete: more will arrive on 9 | -- GitHub. 10 | 11 | -- MARK SCHEME (transcribed from paper): the (m) numbers add up to slightly 12 | -- more than 25, so should be taken as the maximum number of marks losable on 13 | -- the exercise. In fact, I did mark it negatively, but mostly because it was 14 | -- done so well (with Agda's help) that it was easier to find the errors. 15 | 16 | 17 | ------------------------------------------------------------------------------ 18 | -- Dependencies 19 | ------------------------------------------------------------------------------ 20 | 21 | open import CS410-Prelude 22 | 23 | 24 | ------------------------------------------------------------------------------ 25 | -- Vectors 26 | ------------------------------------------------------------------------------ 27 | 28 | data Vec (X : Set) : Nat -> Set where -- like lists, but length-indexed 29 | [] : Vec X zero 30 | _,-_ : {n : Nat} -> X -> Vec X n -> Vec X (suc n) 31 | infixr 4 _,-_ -- the "cons" operator associates to the right 32 | 33 | -- I like to use the asymmetric ,- to remind myself that the element is to 34 | -- the left and the rest of the list is to the right. 35 | 36 | -- Vectors are useful when there are important length-related safety 37 | -- properties. 38 | 39 | 40 | ------------------------------------------------------------------------------ 41 | -- Heads and Tails 42 | ------------------------------------------------------------------------------ 43 | 44 | -- We can rule out nasty head and tail errors by insisting on nonemptiness! 45 | 46 | --??--1.1-(2)----------------------------------------------------------------- 47 | 48 | vHead : {X : Set}{n : Nat} -> Vec X (suc n) -> X 49 | vHead xs = {!!} 50 | 51 | vTail : {X : Set}{n : Nat} -> Vec X (suc n) -> Vec X n 52 | vTail xs = {!!} 53 | 54 | vHeadTailFact : {X : Set}{n : Nat}(xs : Vec X (suc n)) -> 55 | (vHead xs ,- vTail xs) == xs 56 | vHeadTailFact xs = {!!} 57 | 58 | --??-------------------------------------------------------------------------- 59 | 60 | 61 | ------------------------------------------------------------------------------ 62 | -- Concatenation and its Inverse 63 | ------------------------------------------------------------------------------ 64 | 65 | --??--1.2-(2)----------------------------------------------------------------- 66 | 67 | _+V_ : {X : Set}{m n : Nat} -> Vec X m -> Vec X n -> Vec X (m +N n) 68 | xs +V ys = {!!} 69 | infixr 4 _+V_ 70 | 71 | vChop : {X : Set}(m : Nat){n : Nat} -> Vec X (m +N n) -> Vec X m * Vec X n 72 | vChop m xs = {!!} 73 | 74 | vChopAppendFact : {X : Set}{m n : Nat}(xs : Vec X m)(ys : Vec X n) -> 75 | vChop m (xs +V ys) == (xs , ys) 76 | vChopAppendFact xs ys = {!!} 77 | 78 | --??-------------------------------------------------------------------------- 79 | 80 | 81 | ------------------------------------------------------------------------------ 82 | -- Map, take I 83 | ------------------------------------------------------------------------------ 84 | 85 | -- Implement the higher-order function that takes an operation on 86 | -- elements and does it to each element of a vector. Use recursion 87 | -- on the vector. 88 | -- Note that the type tells you the size remains the same. 89 | 90 | -- Show that if the elementwise function "does nothing", neither does 91 | -- its vMap. "map of identity is identity" 92 | 93 | -- Show that two vMaps in a row can be collapsed to just one, or 94 | -- "composition of maps is map of compositions" 95 | 96 | --??--1.3-(2)----------------------------------------------------------------- 97 | 98 | vMap : {X Y : Set} -> (X -> Y) -> {n : Nat} -> Vec X n -> Vec Y n 99 | vMap f xs = {!!} 100 | 101 | vMapIdFact : {X : Set}{f : X -> X}(feq : (x : X) -> f x == x) -> 102 | {n : Nat}(xs : Vec X n) -> vMap f xs == xs 103 | vMapIdFact feq xs = {!!} 104 | 105 | vMapCpFact : {X Y Z : Set}{f : Y -> Z}{g : X -> Y}{h : X -> Z} 106 | (heq : (x : X) -> f (g x) == h x) -> 107 | {n : Nat}(xs : Vec X n) -> 108 | vMap f (vMap g xs) == vMap h xs 109 | vMapCpFact heq xs = {!!} 110 | 111 | --??-------------------------------------------------------------------------- 112 | 113 | 114 | ------------------------------------------------------------------------------ 115 | -- vMap and +V 116 | ------------------------------------------------------------------------------ 117 | 118 | -- Show that if you've got two vectors of Xs and a function from X to Y, 119 | -- and you want to concatenate and map, it doesn't matter which you do 120 | -- first. 121 | 122 | --??--1.4-(1)----------------------------------------------------------------- 123 | 124 | vMap+VFact : {X Y : Set}(f : X -> Y) -> 125 | {m n : Nat}(xs : Vec X m)(xs' : Vec X n) -> 126 | vMap f (xs +V xs') == (vMap f xs +V vMap f xs') 127 | vMap+VFact f xs xs' = {!!} 128 | 129 | --??-------------------------------------------------------------------------- 130 | 131 | -- Think about what you could prove, relating vMap with vHead, vTail, vChop... 132 | -- Now google "Philip Wadler" "Theorems for Free" 133 | 134 | 135 | ------------------------------------------------------------------------------ 136 | -- Applicative Structure (giving mapping and zipping cheaply) 137 | ------------------------------------------------------------------------------ 138 | 139 | --??--1.5-(2)----------------------------------------------------------------- 140 | 141 | -- HINT: you will need to override the default invisibility of n to do this. 142 | vPure : {X : Set} -> X -> {n : Nat} -> Vec X n 143 | vPure x {n} = {!!} 144 | 145 | _$V_ : {X Y : Set}{n : Nat} -> Vec (X -> Y) n -> Vec X n -> Vec Y n 146 | fs $V xs = {!!} 147 | infixl 3 _$V_ -- "Application associates to the left, 148 | -- rather as we all did in the sixties." (Roger Hindley) 149 | 150 | -- Pattern matching and recursion are forbidden for the next two tasks. 151 | 152 | -- implement vMap again, but as a one-liner 153 | vec : {X Y : Set} -> (X -> Y) -> {n : Nat} -> Vec X n -> Vec Y n 154 | vec f xs = {!!} 155 | 156 | -- implement the operation which pairs up corresponding elements 157 | vZip : {X Y : Set}{n : Nat} -> Vec X n -> Vec Y n -> Vec (X * Y) n 158 | vZip xs ys = {!!} 159 | 160 | --??-------------------------------------------------------------------------- 161 | 162 | 163 | ------------------------------------------------------------------------------ 164 | -- Applicative Laws 165 | ------------------------------------------------------------------------------ 166 | 167 | -- According to "Applicative programming with effects" by 168 | -- Conor McBride and Ross Paterson 169 | -- some laws should hold for applicative functors. 170 | -- Check that this is the case. 171 | 172 | --??--1.6-(2)----------------------------------------------------------------- 173 | 174 | vIdentity : {X : Set}{f : X -> X}(feq : (x : X) -> f x == x) -> 175 | {n : Nat}(xs : Vec X n) -> (vPure f $V xs) == xs 176 | vIdentity feq xs = {!!} 177 | 178 | vHomomorphism : {X Y : Set}(f : X -> Y)(x : X) -> 179 | {n : Nat} -> (vPure f $V vPure x) == vPure (f x) {n} 180 | vHomomorphism f x {n} = {!!} 181 | 182 | vInterchange : {X Y : Set}{n : Nat}(fs : Vec (X -> Y) n)(x : X) -> 183 | (fs $V vPure x) == (vPure (_$ x) $V fs) 184 | vInterchange fs x = {!!} 185 | 186 | vComposition : {X Y Z : Set}{n : Nat} 187 | (fs : Vec (Y -> Z) n)(gs : Vec (X -> Y) n)(xs : Vec X n) -> 188 | (vPure _<<_ $V fs $V gs $V xs) == (fs $V (gs $V xs)) 189 | vComposition fs gs xs = {!!} 190 | 191 | --??-------------------------------------------------------------------------- 192 | 193 | 194 | ------------------------------------------------------------------------------ 195 | -- Order-Preserving Embeddings (also known in the business as "thinnings") 196 | ------------------------------------------------------------------------------ 197 | 198 | -- What have these to do with Pascal's Triangle? 199 | 200 | data _<=_ : Nat -> Nat -> Set where 201 | oz : zero <= zero 202 | os : {n m : Nat} -> n <= m -> suc n <= suc m 203 | o' : {n m : Nat} -> n <= m -> n <= suc m 204 | 205 | -- Find all the values in each of the following <= types. 206 | -- This is a good opportunity to learn to use C-c C-a with the -l option 207 | -- (a.k.a. "google the type" without "I feel lucky") 208 | -- The -s n option also helps. 209 | 210 | --??--1.7-(1)----------------------------------------------------------------- 211 | 212 | all0<=4 : Vec (0 <= 4) {!!} 213 | all0<=4 = {!!} 214 | 215 | all1<=4 : Vec (1 <= 4) {!!} 216 | all1<=4 = {!!} 217 | 218 | all2<=4 : Vec (2 <= 4) {!!} 219 | all2<=4 = {!!} 220 | 221 | all3<=4 : Vec (3 <= 4) {!!} 222 | all3<=4 = {!!} 223 | 224 | all4<=4 : Vec (4 <= 4) {!!} 225 | all4<=4 = {!!} 226 | 227 | -- Prove the following. A massive case analysis "rant" is fine. 228 | 229 | no5<=4 : 5 <= 4 -> Zero 230 | no5<=4 th = {!!} 231 | 232 | --??-------------------------------------------------------------------------- 233 | 234 | 235 | ------------------------------------------------------------------------------ 236 | -- Order-Preserving Embeddings Select From Vectors 237 | ------------------------------------------------------------------------------ 238 | 239 | -- Use n <= m to encode the choice of n elements from an m-Vector. 240 | -- The os constructor tells you to take the next element of the vector; 241 | -- the o' constructor tells you to omit the next element of the vector. 242 | 243 | --??--1.8-(2)----------------------------------------------------------------- 244 | 245 | _ n <= m -> Vec X m 246 | -> Vec X n 247 | th Y) 252 | {n m : Nat}(th : n <= m)(xs : Vec X m) -> 253 | vMap f (th n <= n 268 | oi {n} = {!!} 269 | 270 | oe : {n : Nat} -> 0 <= n 271 | oe {n} = {!!} 272 | 273 | --??-------------------------------------------------------------------------- 274 | 275 | 276 | -- Show that all empty thinnings are equal to yours. 277 | 278 | --??--1.10-(1)---------------------------------------------------------------- 279 | 280 | oeUnique : {n : Nat}(th : 0 <= n) -> th == oe 281 | oeUnique i = {!!} 282 | 283 | --??-------------------------------------------------------------------------- 284 | 285 | 286 | -- Show that there are no thinnings of form big <= small (TRICKY) 287 | -- Then show that all the identity thinnings are equal to yours. 288 | -- Note that you can try the second even if you haven't finished the first. 289 | -- HINT: you WILL need to expose the invisible numbers. 290 | -- HINT: check CS410-Prelude for a reminder of >= 291 | 292 | --??--1.11-(3)---------------------------------------------------------------- 293 | 294 | oTooBig : {n m : Nat} -> n >= m -> suc n <= m -> Zero 295 | oTooBig {n} {m} n>=m th = {!!} 296 | 297 | oiUnique : {n : Nat}(th : n <= n) -> th == oi 298 | oiUnique th = {!!} 299 | 300 | --??-------------------------------------------------------------------------- 301 | 302 | 303 | -- Show that the identity thinning selects the whole vector 304 | 305 | --??--1.12-(1)---------------------------------------------------------------- 306 | 307 | id- (oi >_ : {p n m : Nat} -> p <= n -> n <= m -> p <= m 326 | th o>> th' = {!!} 327 | 328 | cp- 329 | {X : Set}(xs : Vec X m) -> 330 | ((th o>> th') > : {n m : Nat}(th : n <= m) -> (oi o>> th) == th 343 | idThen-o>> th = {!!} 344 | 345 | idAfter-o>> : {n m : Nat}(th : n <= m) -> (th o>> oi) == th 346 | idAfter-o>> th = {!!} 347 | 348 | assoc-o>> : {q p n m : Nat}(th0 : q <= p)(th1 : p <= n)(th2 : n <= m) -> 349 | ((th0 o>> th1) o>> th2) == (th0 o>> (th1 o>> th2)) 350 | assoc-o>> th0 th1 th2 = {!!} 351 | 352 | --??-------------------------------------------------------------------------- 353 | 354 | 355 | ------------------------------------------------------------------------------ 356 | -- Vectors as Arrays 357 | ------------------------------------------------------------------------------ 358 | 359 | -- We can use 1 <= n as the type of bounded indices into a vector and do 360 | -- a kind of "array projection". First we select a 1-element vector from 361 | -- the n-element vector, then we take its head to get the element out. 362 | 363 | vProject : {n : Nat}{X : Set} -> Vec X n -> 1 <= n -> X 364 | vProject xs i = vHead (i (1 <= n -> X) -> Vec X n 373 | vTabulate {n} f = {!!} 374 | 375 | -- This should be easy if vTabulate is correct. 376 | vTabulateProjections : {n : Nat}{X : Set}(xs : Vec X n) -> 377 | vTabulate (vProject xs) == xs 378 | vTabulateProjections xs = {!!} 379 | 380 | -- HINT: oeUnique 381 | vProjectFromTable : {n : Nat}{X : Set}(f : 1 <= n -> X)(i : 1 <= n) -> 382 | vProject (vTabulate f) i == f i 383 | vProjectFromTable f i = {!!} 384 | 385 | --??-------------------------------------------------------------------------- 386 | -------------------------------------------------------------------------------- /exercises/Ex2.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} -- yes, I will let you cheat in this exercise 2 | {-# OPTIONS --allow-unsolved-metas #-} -- allows import, unfinished 3 | 4 | ------------------------------------------------------------------------------ 5 | ------------------------------------------------------------------------------ 6 | -- CS410 2017/18 Exercise 2 CATEGORIES AND MONADS (worth 50%) 7 | ------------------------------------------------------------------------------ 8 | ------------------------------------------------------------------------------ 9 | 10 | -- NOTE (19/10/17) This file is currently incomplete: more will arrive on 11 | -- GitHub. 12 | 13 | -- NOTE (29/10/17) All components are now present. 14 | 15 | -- REFLECTION: When I started setting this exercise, I intended it as a 16 | -- normal size 25% exercise, but it grew and grew, as did the struggles of 17 | -- the students. I accepted that I had basically set two exercises in one 18 | -- file and revalued it as such. 19 | 20 | 21 | ------------------------------------------------------------------------------ 22 | -- Dependencies 23 | ------------------------------------------------------------------------------ 24 | 25 | open import CS410-Prelude 26 | open import CS410-Categories 27 | open import Ex1 28 | 29 | 30 | ------------------------------------------------------------------------------ 31 | -- Categorical Jigsaws (based on Ex1) 32 | ------------------------------------------------------------------------------ 33 | 34 | -- In this section, most of the work has already happened. All you have to do 35 | -- is assemble the collection of things you did into Ex1 into neat categorical 36 | -- packaging. 37 | 38 | --??--2.1-(4)----------------------------------------------------------------- 39 | 40 | OPE : Category -- The category of order-preserving embeddings... 41 | OPE = record 42 | { Obj = Nat -- ...has numbers as objects... 43 | ; _~>_ = _<=_ -- ...and "thinnings" as arrows. 44 | -- Now, assemble the rest of the components. 45 | ; id~> = {!!} 46 | ; _>~>_ = {!!} 47 | ; law-id~>>~> = {!!} 48 | ; law->~>id~> = {!!} 49 | ; law->~>>~> = {!!} 50 | } 51 | 52 | VEC : Nat -> SET => SET -- Vectors of length n... 53 | VEC n = record 54 | { F-Obj = \ X -> Vec X n -- ...give a functor from SET to SET... 55 | ; F-map = \ f xs -> vMap f xs -- ...doing vMap to arrows. 56 | -- Now prove the laws. 57 | ; F-map-id~> = extensionality \ xs -> {!!} 58 | ; F-map->~> = \ f g -> extensionality \ xs -> {!!} 59 | } 60 | 61 | Op : Category -> Category -- Every category has an opposite... 62 | Op C = record 63 | { Obj = Obj -- ...with the same objects, but... 64 | ; _~>_ = \ S T -> T ~> S -- ...arrows that go backwards! 65 | -- Now, find the rest! 66 | ; id~> = {!!} 67 | ; _>~>_ = {!!} 68 | ; law-id~>>~> = {!!} 69 | ; law->~>id~> = {!!} 70 | ; law->~>>~> = {!!} 71 | } where open Category C 72 | 73 | CHOOSE : Set -> OPE => Op SET -- Show that thinnings from n to m... 74 | CHOOSE X = record -- ...act by selection... 75 | { F-Obj = Vec X -- ...to cut vectors down from m to n. 76 | ; F-map = {!!} 77 | ; F-map-id~> = extensionality {!!} 78 | ; F-map->~> = \ f g -> extensionality {!!} 79 | } 80 | 81 | --??-------------------------------------------------------------------------- 82 | 83 | 84 | ------------------------------------------------------------------------------ 85 | -- The List Monad (a warm-up) 86 | ------------------------------------------------------------------------------ 87 | 88 | -- The declaration of List has been added to the CS410-Prelude file: 89 | 90 | -- data List (X : Set) : Set where 91 | -- [] : List X 92 | -- _,-_ : (x : X)(xs : List X) -> List X 93 | -- infixr 4 _,-_ 94 | 95 | -- Appending two lists is rather well known, so I'll not ask you to write it. 96 | 97 | _+L_ : {X : Set} -> List X -> List X -> List X 98 | [] +L ys = ys 99 | (x ,- xs) +L ys = x ,- (xs +L ys) 100 | infixr 4 _+L_ 101 | 102 | -- But I will ask you to find some structure for it. 103 | 104 | 105 | --??--2.2-(3)----------------------------------------------------------------- 106 | 107 | LIST-MONOID : Set -> Category 108 | LIST-MONOID X = -- Show that _+L_ is the operation of a monoid,... 109 | record 110 | { Obj = One -- ... i.e., a category with one object. 111 | ; _~>_ = {!!} 112 | ; id~> = {!!} 113 | ; _>~>_ = {!!} 114 | ; law-id~>>~> = {!!} 115 | ; law->~>id~> = {!!} 116 | ; law->~>>~> = {!!} 117 | } where 118 | -- useful helper proofs (lemmas) go here 119 | 120 | --??-------------------------------------------------------------------------- 121 | 122 | -- Next, functoriality of lists. Given a function on elements, show how to 123 | -- apply that function to all the elements of a list. (Haskell calls this 124 | -- operation "map".) 125 | 126 | --??--2.3-(3)----------------------------------------------------------------- 127 | 128 | list : {X Y : Set} -> (X -> Y) -> List X -> List Y 129 | list f xs = {!!} 130 | 131 | LIST : SET => SET 132 | LIST = record 133 | { F-Obj = List 134 | ; F-map = list 135 | ; F-map-id~> = extensionality {!!} 136 | ; F-map->~> = \ f g -> extensionality {!!} 137 | } where 138 | -- useful helper proofs (lemmas) go here 139 | 140 | --??-------------------------------------------------------------------------- 141 | 142 | 143 | -- Moreover, applying a function elementwise should respect appending. 144 | 145 | --??--2.4-(3)----------------------------------------------------------------- 146 | 147 | LIST+L : {X Y : Set}(f : X -> Y) -> LIST-MONOID X => LIST-MONOID Y 148 | LIST+L {X}{Y} f = record 149 | { F-Obj = id 150 | ; F-map = list f -- this yellow will go once LIST-MONOID has arrows! 151 | ; F-map-id~> = {!!} 152 | ; F-map->~> = {!!} 153 | } where 154 | -- useful helper proofs (lemmas) go here 155 | 156 | 157 | --??-------------------------------------------------------------------------- 158 | 159 | 160 | -- Next, we have two very important "natural transformations". 161 | 162 | --??--2.5-(1)----------------------------------------------------------------- 163 | 164 | SINGLE : ID ~~> LIST 165 | SINGLE = record 166 | { xf = \ x -> x ,- [] -- turn a value into a singleton list 167 | ; naturality = \ f -> {!!} 168 | } 169 | 170 | --??-------------------------------------------------------------------------- 171 | 172 | -- Here, naturality means that it doesn't matter 173 | -- whether you apply a function f, then make a singleton list 174 | -- or you make a singleton list, then apply f to all (one of) its elements. 175 | 176 | 177 | -- Now, define the operation that concatenates a whole list of lists, and 178 | -- show that it, too, is natural. That is, it doesn't matter whether you 179 | -- transform the elements (two layers inside) then concatenate, or you 180 | -- concatenate, then transform the elements. 181 | 182 | --??--2.6-(3)----------------------------------------------------------------- 183 | 184 | concat : {X : Set} -> List (List X) -> List X 185 | concat xss = {!!} 186 | 187 | CONCAT : (LIST >=> LIST) ~~> LIST 188 | CONCAT = record 189 | { xf = concat 190 | ; naturality = {!!} 191 | } where 192 | -- useful helper proofs (lemmas) go here 193 | 194 | --??-------------------------------------------------------------------------- 195 | 196 | 197 | -- You've nearly built your first monad! You just need to prove that 198 | -- single and concat play nicely with each other. 199 | 200 | --??--2.7-(4)----------------------------------------------------------------- 201 | 202 | module LIST-MONAD where 203 | open MONAD LIST public 204 | ListMonad : Monad 205 | ListMonad = record 206 | { unit = SINGLE 207 | ; mult = CONCAT 208 | ; unitMult = {!!} 209 | ; multUnit = {!!} 210 | ; multMult = {!!} 211 | } where 212 | -- useful helper proofs (lemmas) go here 213 | 214 | -- open LIST-MONAD 215 | 216 | --??-------------------------------------------------------------------------- 217 | 218 | -- More monads to come... 219 | 220 | 221 | ------------------------------------------------------------------------------ 222 | -- Categories of Indexed Sets 223 | ------------------------------------------------------------------------------ 224 | 225 | -- We can think of some 226 | -- P : I -> Set 227 | -- as a collection of sets indexed by I, such that 228 | -- P i 229 | -- means "exactly the P-things which fit with i". 230 | 231 | -- You've met 232 | -- Vec X : Nat -> Set 233 | -- where 234 | -- Vec X n 235 | -- means "exactly the vectors which fit with n". 236 | 237 | -- Now, given two such collections, S and T, we can make a collection 238 | -- of function types: the functions which fit with i map the 239 | -- S-things which fit with i to the T-things which fit with i. 240 | 241 | _-:>_ : {I : Set} -> (I -> Set) -> (I -> Set) -> (I -> Set) 242 | (S -:> T) i = S i -> T i 243 | 244 | -- So, (Vec X -:> Vec Y) n contains the functions which turn 245 | -- n Xs into n Ys. 246 | 247 | -- Next, if we know such a collection of sets, we can claim to have 248 | -- one for each index. 249 | 250 | [_] : {I : Set} -> (I -> Set) -> Set 251 | [ P ] = forall i -> P i -- [_] {I} P = (i : I) -> P i 252 | 253 | -- E.g., [ Vec X -:> Vec Y ] is the type of functions from X-vectors 254 | -- to Y-vectors which preserve length. 255 | 256 | -- For any such I, we get a category of indexed sets with index-preserving 257 | -- functions. 258 | 259 | _->SET : Set -> Category 260 | I ->SET = record 261 | { Obj = I -> Set -- I-indexed sets 262 | ; _~>_ = \ S T -> [ S -:> T ] -- index-respecting functions 263 | ; id~> = \ i -> id -- the identity at every index 264 | ; _>~>_ = \ f g i -> f i >> g i -- composition at every index 265 | ; law-id~>>~> = refl -- and the laws are very boring 266 | ; law->~>id~> = refl 267 | ; law->~>>~> = \ f g h -> refl _ 268 | } 269 | 270 | -- In fact, we didn't need to choose SET here. We could do this construction 271 | -- for any category: index the objects; index the morphisms. 272 | -- But SET is plenty to be getting on with. 273 | 274 | -- Now, let me define an operation that makes types from lists. 275 | 276 | All : {X : Set} -> (X -> Set) -> (List X -> Set) 277 | All P [] = One 278 | All P (x ,- xs) = P x * All P xs 279 | 280 | -- The idea is that we get a tuple of P-things: one for each list element. 281 | -- So 282 | -- All P (1 ,- 2 ,- 3 ,- []) 283 | -- = P 1 * P 2 * P 3 * One 284 | 285 | -- Note that if you think of List One as a version of Nat, 286 | -- All becomes a lot like Vec. 287 | 288 | copy : Nat -> List One 289 | copy zero = [] 290 | copy (suc n) = <> ,- copy n 291 | 292 | VecCopy : Set -> Nat -> Set 293 | VecCopy X n = All (\ _ -> X) (copy n) 294 | 295 | -- Now, your turn... 296 | 297 | --??--2.8-(4)----------------------------------------------------------------- 298 | 299 | -- Show that, for any X, All induces a functor 300 | -- from (X ->SET) to (List X ->SET) 301 | 302 | all : {X : Set}{S T : X -> Set} -> 303 | [ S -:> T ] -> [ All S -:> All T ] 304 | all f xs ss = {!!} 305 | 306 | ALL : (X : Set) -> (X ->SET) => (List X ->SET) 307 | ALL X = record 308 | { F-Obj = All 309 | ; F-map = all 310 | ; F-map-id~> = {!!} 311 | ; F-map->~> = {!!} 312 | } where 313 | -- useful helper facts go here 314 | 315 | --??-------------------------------------------------------------------------- 316 | 317 | 318 | -- ABOVE THIS LINE, 25% 319 | -- BELOW THIS LINE, 25% 320 | 321 | 322 | ------------------------------------------------------------------------------ 323 | -- Cutting Things Up 324 | ------------------------------------------------------------------------------ 325 | 326 | -- Next, we're going to develop a very general technique for building 327 | -- data structures. 328 | 329 | -- We may think of an I |> O as a way to "cut O-shapes into I-shaped pieces". 330 | -- The pointy end points to the type being cut; the flat end to the type of 331 | -- pieces. 332 | 333 | record _|>_ (I O : Set) : Set where 334 | field 335 | Cuts : O -> Set -- given o : O, how may we cut it? 336 | inners : {o : O} -> Cuts o -> List I -- given how we cut it, what are 337 | -- the shapes of its pieces? 338 | 339 | -- Let us have some examples right away! 340 | 341 | VecCut : One |> Nat -- cut numbers into boring pieces 342 | VecCut = record 343 | { Cuts = \ n -> One -- there is one way to cut n 344 | ; inners = \ {n} _ -> copy n -- and you get n pieces 345 | } 346 | 347 | -- Here's a less boring example. You can cut a number into *two* pieces 348 | -- by finding two numbers that add to it. 349 | 350 | NatCut : Nat |> Nat 351 | NatCut = record 352 | { Cuts = \ mn -> Sg Nat \ m -> Sg Nat \ n -> (m +N n) == mn 353 | ; inners = \ { (m , n , _) -> m ,- n ,- [] } 354 | } 355 | 356 | -- The point is that we can make data structures that record how we 357 | -- built an O-shaped thing from I-shaped pieces. 358 | 359 | record Cutting {I O}(C : I |> O)(P : I -> Set)(o : O) : Set where 360 | constructor _8><_ -- "scissors" 361 | open _|>_ C 362 | field 363 | cut : Cuts o -- we decide how to cut o 364 | pieces : All P (inners cut) -- then we give all the pieces. 365 | infixr 3 _8><_ 366 | 367 | -- For example... 368 | 369 | VecCutting : Set -> Nat -> Set 370 | VecCutting X = Cutting VecCut (\ _ -> X) 371 | 372 | myVecCutting : VecCutting Char 5 373 | myVecCutting = <> 8>< 'h' , 'e' , 'l' , 'l' , 'o' , <> 374 | 375 | -- Or, if you let me fiddle about with strings for a moment,... 376 | length : {X : Set} -> List X -> Nat 377 | length [] = zero 378 | length (x ,- xs) = suc (length xs) 379 | 380 | listVec : {X : Set}(xs : List X) -> Vec X (length xs) 381 | listVec [] = [] 382 | listVec (x ,- xs) = x ,- listVec xs 383 | 384 | strVec : (s : String) -> Vec Char (length (primStringToList s)) 385 | strVec s = listVec (primStringToList s) 386 | 387 | -- ...an example of cutting a number in two, with vector pieces. 388 | 389 | footprints : Cutting NatCut (Vec Char) 10 390 | footprints = (4 , 6 , refl 10) 8>< strVec "foot" 391 | , strVec "prints" 392 | , <> 393 | 394 | -- Now, let me direct you to the =$ operator, now in CS410-Prelude.agda, 395 | -- which you may find helps with the proofs in the following. 396 | 397 | --??--2.9-(3)----------------------------------------------------------------- 398 | 399 | -- Using what you already built for ALL, show that every Cutting C gives us 400 | -- a functor between categories of indexed sets. 401 | 402 | CUTTING : {I O : Set}(C : I |> O) -> (I ->SET) => (O ->SET) 403 | CUTTING {I}{O} C = record 404 | { F-Obj = Cutting C 405 | ; F-map = {!!} 406 | ; F-map-id~> = extensionality \ o -> extensionality \ { (c 8>< ps) -> 407 | {!!} } 408 | ; F-map->~> = \ f g -> 409 | extensionality \ o -> extensionality \ { (c 8>< ps) -> 410 | {!!} } 411 | } where 412 | open _|>_ C 413 | open _=>_ (ALL I) 414 | 415 | --??-------------------------------------------------------------------------- 416 | 417 | 418 | ------------------------------------------------------------------------------ 419 | -- Interiors 420 | ------------------------------------------------------------------------------ 421 | 422 | -- Next, let me define the notion of an algebra for a given functor in C => C 423 | 424 | module ALGEBRA {C : Category}(F : C => C) where 425 | open Category C 426 | open _=>_ F 427 | 428 | Algebra : (X : Obj) -> Set -- we call X the "carrier" of the algebra... 429 | Algebra X = F-Obj X ~> X -- ...and we explain how to turn a bunch of Xs 430 | -- into one 431 | open ALGEBRA 432 | 433 | -- Some week, we'll build categories whose objects are algebras. Not this week. 434 | 435 | -- Instead, let's work with them a bit. 436 | 437 | -- If we know a way to cut I-shapes into I-shaped pieces, we can build the 438 | -- ways to "tile" an I with I-shaped T-tiles. 439 | 440 | data Interior {I}(C : I |> I)(T : I -> Set)(i : I) : Set where 441 | -- either... 442 | tile : T i -> Interior C T i -- we have a tile that fits, or... 443 | <_> : Cutting C (Interior C T) i -> -- ...we cut, then tile the pieces. 444 | Interior C T i 445 | 446 | -- Let me give you an example of an interior. 447 | 448 | subbookkeeper : Interior NatCut (Vec Char) 13 449 | subbookkeeper = < (3 , 10 , refl _) 450 | 8>< tile (strVec "sub") 451 | , < (4 , 6 , refl _) 452 | 8>< tile (strVec "book") 453 | , tile (strVec "keeper") 454 | , <> > 455 | , <> > 456 | 457 | -- We make a 13-interior from 458 | -- a 3-tile and a 10-interior made from a 4-tile and a 6-tile. 459 | 460 | -- Guess what? Interior C is always a Monad! We'll get there. 461 | 462 | module INTERIOR {I : Set}{C : I |> I} where -- fix some C... 463 | 464 | open _|>_ C -- ...and open it 465 | 466 | open module I->SET {I : Set} = Category (I ->SET) -- work in I ->SET 467 | 468 | -- tile gives us an arrow from T into Interior C T 469 | 470 | tile' : {T : I -> Set} -> [ T -:> Interior C T ] 471 | tile' i = tile 472 | 473 | -- <_> gives us an algebra! 474 | 475 | cut' : {T : I -> Set} -> Algebra (CUTTING C) (Interior C T) 476 | cut' i = <_> 477 | 478 | -- Now, other (CUTTING C) algebras give us operators on interiors. 479 | 480 | module INTERIORFOLD {P Q : I -> Set} where 481 | 482 | interiorFold : 483 | [ P -:> Q ] -> -- if we can turn a P into a Q... 484 | Algebra (CUTTING C) Q -> -- ...and a bunch of Qs into a Q... 485 | [ Interior C P -:> Q ] -- ...we can turn an interior of Ps into a Q 486 | 487 | allInteriorFold : -- annoyingly, we'll need a specialized "all" 488 | [ P -:> Q ] -> 489 | Algebra (CUTTING C) Q -> 490 | [ All (Interior C P) -:> All Q ] 491 | 492 | interiorFold pq qalg i (tile p) = pq i p 493 | interiorFold pq qalg i < c 8>< pis > = 494 | qalg i (c 8>< allInteriorFold pq qalg (inners c) pis) 495 | 496 | -- recursively turn all the sub-interiors into Qs 497 | allInteriorFold pq qalg [] <> = <> 498 | allInteriorFold pq qalg (i ,- is) (pi , pis) = 499 | interiorFold pq qalg i pi , allInteriorFold pq qalg is pis 500 | 501 | -- The trouble is that if you use 502 | -- all (interiorFold pq qalg) 503 | -- to process the sub-interiors, the termination checker complains. 504 | 505 | -- But if you've built "all" correctly, you should be able to prove this: 506 | 507 | --??--2.10-(2)---------------------------------------------------------------- 508 | 509 | allInteriorFoldLaw : (pq : [ P -:> Q ])(qalg : Algebra (CUTTING C) Q) -> 510 | allInteriorFold pq qalg == all (interiorFold pq qalg) 511 | allInteriorFoldLaw pq qalg = extensionality \ is -> extensionality \ ps -> 512 | {!!} 513 | where 514 | -- helper lemmas go here 515 | 516 | --??-------------------------------------------------------------------------- 517 | 518 | -- Now, do me a favour and prove this extremely useful fact. 519 | -- Its purpose is to bottle the inductive proof method for functions 520 | -- built with interiorFold. 521 | 522 | --??--2.11-(3)---------------------------------------------------------------- 523 | 524 | interiorFoldLemma : 525 | (pq : [ P -:> Q ])(qalg : Algebra (CUTTING C) Q) 526 | (f : [ Interior C P -:> Q ]) -> 527 | ((i : I)(p : P i) -> pq i p == f i (tile p)) -> 528 | ((i : I)(c : Cuts i)(ps : All (Interior C P) (inners c)) -> 529 | qalg i (c 8>< all f (inners c) ps) == f i < c 8>< ps >) -> 530 | (i : I)(pi : Interior C P i) -> interiorFold pq qalg i pi == f i pi 531 | 532 | interiorFoldLemma pq qalg f base step i pi = {!!} 533 | 534 | --??-------------------------------------------------------------------------- 535 | 536 | -- We'll use it in this form: 537 | 538 | interiorFoldLaw : (pq : [ P -:> Q ])(qalg : Algebra (CUTTING C) Q) 539 | (f : [ Interior C P -:> Q ]) -> 540 | ((i : I)(p : P i) -> pq i p == f i (tile p)) -> 541 | ((i : I)(c : Cuts i)(ps : All (Interior C P) (inners c)) -> 542 | qalg i (c 8>< all f (inners c) ps) == f i < c 8>< ps >) -> 543 | interiorFold pq qalg == f 544 | 545 | interiorFoldLaw pq qalg f base step = 546 | extensionality \ i -> extensionality \ pi -> 547 | interiorFoldLemma pq qalg f base step i pi 548 | 549 | open INTERIORFOLD 550 | 551 | -- Let me pay you back immediately! 552 | -- An interiorBind is an interiorFold which computes an Interior, 553 | -- rewrapping each layer with < ... > 554 | 555 | interiorBind : {X Y : I -> Set} -> 556 | [ X -:> Interior C Y ] -> [ Interior C X -:> Interior C Y ] 557 | interiorBind f = interiorFold f (\ i -> <_>) 558 | 559 | -- Because an interiorBind *makes* an interior, we can say something useful 560 | -- about what happens if we follow it with an interiorFold. 561 | 562 | interiorBindFusion : {X Y Z : I -> Set} -> 563 | (f : [ X -:> Interior C Y ]) 564 | (yz : [ Y -:> Z ])(zalg : Algebra (CUTTING C) Z) -> 565 | (interiorBind f >~> interiorFold yz zalg) == 566 | interiorFold (f >~> interiorFold yz zalg) zalg 567 | 568 | -- That is, we can "fuse" the two together, making one interiorFold. 569 | 570 | -- I'll do the proof as it's a bit hairy. You've given me all I need. 571 | -- Note that I don't use extensionality, just laws that relate functions. 572 | 573 | interiorBindFusion f yz zalg = 574 | (interiorBind f >~> interiorFold yz zalg) 575 | =< interiorFoldLaw 576 | (f >~> interiorFold yz zalg) zalg 577 | (interiorBind f >~> interiorFold yz zalg) 578 | (\ i p -> refl (interiorFold yz zalg i (f i p))) 579 | (\ i c ps -> refl (zalg i) =$= (refl (c 8><_) =$= ( 580 | ((all (interiorBind f >~> interiorFold yz zalg) 581 | =[ F-map->~> (interiorBind f) (interiorFold yz zalg) >= 582 | (all (interiorBind f) >~> all (interiorFold yz zalg)) 583 | =< refl _>~>_ 584 | =$= allInteriorFoldLaw f cut' 585 | =$= allInteriorFoldLaw yz zalg ]= 586 | allInteriorFold f (\ i -> <_>) >~> allInteriorFold yz zalg [QED]) 587 | =$ inners c =$= refl ps)))) 588 | ]= 589 | interiorFold (f >~> interiorFold yz zalg) zalg [QED] 590 | where open _=>_ (ALL I) 591 | 592 | -- You should find that a very useful piece of kit. In fact, you should 593 | -- not need extensionality, either. 594 | 595 | -- We need Interior C to be a functor. 596 | 597 | --??--2.12-(5)---------------------------------------------------------------- 598 | 599 | -- using interiorBind, implement the "F-map" for Interiors as a one-liner 600 | 601 | interior : {X Y : I -> Set} -> 602 | [ X -:> Y ] -> [ Interior C X -:> Interior C Y ] 603 | interior f = {!!} 604 | 605 | -- using interiorBindFusion, prove the following law for "fold after map" 606 | 607 | interiorFoldFusion : {P Q R : I -> Set} 608 | (pq : [ P -:> Q ])(qr : [ Q -:> R ])(ralg : Algebra (CUTTING C) R) -> 609 | (interior pq >~> interiorFold qr ralg) == interiorFold (pq >~> qr) ralg 610 | interiorFoldFusion pq qr ralg = 611 | interior pq >~> interiorFold qr ralg 612 | =[ {!!} >= 613 | interiorFold (pq >~> qr) ralg [QED] 614 | where open _=>_ (ALL I) 615 | 616 | -- and now, using interiorFoldFusion if it helps, 617 | -- complete the functor construction 618 | 619 | INTERIOR : (I ->SET) => (I ->SET) 620 | INTERIOR = record 621 | { F-Obj = Interior C 622 | ; F-map = interior 623 | ; F-map-id~> = {!!} 624 | ; F-map->~> = {!!} 625 | } where open _=>_ (ALL I) 626 | 627 | --??-------------------------------------------------------------------------- 628 | 629 | -- Now let's build the Monad. 630 | -- You should find that all the laws you have to prove follow from the 631 | -- fusion laws you already have. 632 | 633 | open MONAD INTERIOR 634 | 635 | --??--2.13-(5)---------------------------------------------------------------- 636 | 637 | WRAP : ID ~~> INTERIOR 638 | WRAP = record 639 | { xf = {!!} 640 | ; naturality = {!!} 641 | } 642 | 643 | -- use interiorBind to define the following 644 | FLATTEN : (INTERIOR >=> INTERIOR) ~~> INTERIOR 645 | FLATTEN = record 646 | { xf = {!!} 647 | ; naturality = {!!} 648 | } 649 | 650 | INTERIOR-Monad : Monad 651 | INTERIOR-Monad = record 652 | { unit = WRAP 653 | ; mult = FLATTEN 654 | ; unitMult = {!!} 655 | ; multUnit = {!!} 656 | ; multMult = {!!} 657 | } where 658 | open _=>_ INTERIOR 659 | 660 | --??-------------------------------------------------------------------------- 661 | 662 | open INTERIOR 663 | open INTERIORFOLD 664 | 665 | 666 | -- You should be able to define an algebra on vectors for NatCut, using +V 667 | 668 | --??--2.14-(2)---------------------------------------------------------------- 669 | 670 | NatCutVecAlg : {X : Set} -> Algebra (CUTTING NatCut) (Vec X) 671 | NatCutVecAlg n xsc = {!!} 672 | 673 | --??-------------------------------------------------------------------------- 674 | 675 | -- Check that it puts things together suitably when you evaluate this: 676 | 677 | test1 : Vec Char 13 678 | test1 = interiorFold (\ _ -> id) NatCutVecAlg 13 subbookkeeper 679 | 680 | 681 | ------------------------------------------------------------------------------ 682 | -- Cutting Up Pairs 683 | ------------------------------------------------------------------------------ 684 | 685 | module CHOICE where 686 | open _|>_ 687 | 688 | --??--2.15-(2)---------------------------------------------------------------- 689 | 690 | -- Show that if you can cut up I and cut up J, then you can cut up I * J. 691 | -- You now have two dimensions (I and J). The idea is that you choose one 692 | -- dimension in which to make a cut, and keep everything in the other 693 | -- dimension the same. 694 | 695 | _+C_ : {I J : Set} -> I |> I -> J |> J -> (I * J) |> (I * J) 696 | Cuts (P +C Q) (i , j) = Cuts P i + Cuts Q j 697 | inners (P +C Q) = {!!} 698 | 699 | --??-------------------------------------------------------------------------- 700 | 701 | open CHOICE 702 | 703 | -- That should get us the ability to cut up *rectangules* by cutting either 704 | -- vertically or horizontally. 705 | 706 | NatCut2D : (Nat * Nat) |> (Nat * Nat) 707 | NatCut2D = NatCut +C NatCut 708 | 709 | Matrix : Set -> Nat * Nat -> Set 710 | Matrix X (w , h) = Vec (Vec X w) h 711 | 712 | -- If you've done it right, you should find that the following typechecks. 713 | -- It's the interior of a rectangle, tiled with matrices of characters. 714 | 715 | rectangle : Interior NatCut2D (Matrix Char) (15 , 6) 716 | rectangle = < inr (4 , 2 , refl _) 717 | 8>< < inl (7 , 8 , refl _) 718 | 8>< tile (strVec "seventy" 719 | ,- strVec "kitchen" 720 | ,- strVec "program" 721 | ,- strVec "mistake" 722 | ,- []) 723 | , tile (strVec "thousand" 724 | ,- strVec "soldiers" 725 | ,- strVec "probably" 726 | ,- strVec "undefine" 727 | ,- []) 728 | , <> > 729 | , tile (strVec "acknowledgement" 730 | ,- strVec "procrastination" 731 | ,- []) 732 | , <> > 733 | 734 | -- Later, we'll use rectangular interiors as the underlying data structure 735 | -- for a window manager. 736 | 737 | -- But for now, one last thing. 738 | 739 | --??--2.16-(4)---------------------------------------------------------------- 740 | 741 | -- Show that if you have a vector of n Ps for every element of a list, 742 | -- then you can make a vector of n (All P)s . 743 | -- Hint: Ex1 provides some useful equipment for this job. 744 | 745 | vecAll : {I : Set}{P : I -> Set}{is : List I}{n : Nat} -> 746 | All (\ i -> Vec (P i) n) is -> Vec (All P is) n 747 | vecAll {is = is} pss = {!!} 748 | 749 | -- Given vecAll, show that algebra for any cutting can be lifted 750 | -- to an algebra on vectors. 751 | 752 | VecLiftAlg : {I : Set}(C : I |> I){X : I -> Set} 753 | (alg : Algebra (CUTTING C) X){n : Nat} -> 754 | Algebra (CUTTING C) (\ i -> Vec (X i) n) 755 | VecLiftAlg C alg i (c 8>< pss) = {!!} 756 | 757 | -- Now show that you can build an algebra for matrices 758 | -- which handles cuts in either dimension, 759 | -- combining them either horizontally or vertically! 760 | 761 | NatCut2DMatAlg : {X : Set} -> Algebra (CUTTING NatCut2D) (Matrix X) 762 | NatCut2DMatAlg _ (inl c 8>< ms) = {!!} 763 | NatCut2DMatAlg _ (inr c 8>< ms) = {!!} 764 | 765 | --??-------------------------------------------------------------------------- 766 | 767 | -- And that should give you a way to glue pictures together from interiors. 768 | 769 | picture : [ Interior NatCut2D (Matrix Char) -:> Matrix Char ] 770 | picture = interiorFold (\ _ -> id) NatCut2DMatAlg 771 | 772 | -- You should be able to check that the following gives you something 773 | -- sensible: 774 | 775 | test2 = picture _ rectangle 776 | 777 | -------------------------------------------------------------------------------- /exercises/Ex3.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} -- yes, I will let you cheat in this exercise 2 | {-# OPTIONS --allow-unsolved-metas #-} -- allows import, unfinished 3 | 4 | ------------------------------------------------------------------------------ 5 | ------------------------------------------------------------------------------ 6 | -- CS410 2017/18 Exercise 3 WINDOWS AND OTHER STORIES (worth 25%) 7 | ------------------------------------------------------------------------------ 8 | ------------------------------------------------------------------------------ 9 | 10 | ------------------------------------------------------------------------------ 11 | -- Dependencies 12 | ------------------------------------------------------------------------------ 13 | 14 | open import CS410-Prelude 15 | open import CS410-Categories 16 | open import Ex2 17 | 18 | 19 | ------------------------------------------------------------------------------ 20 | -- PART I: Splittings 21 | ------------------------------------------------------------------------------ 22 | 23 | -- The type ls <[ ms ]> rs 24 | -- is similar to that found in Lec2.agda, but it works on lists, not numbers. 25 | -- It provides the evidence that a list ms can be split into a left sublist ls 26 | -- and a right sublist rs. In effect, it's a vector of bits that say which 27 | -- elements of ms go left and which go right. 28 | 29 | data _<[_]>_ {X : Set} : List X -> List X -> List X -> Set where 30 | sz : [] <[ [] ]> [] 31 | sl : forall {l ls ms rs} -> ls <[ ms ]> rs -> (l ,- ls) <[ l ,- ms ]> rs 32 | sr : forall {r ls ms rs} -> ls <[ ms ]> rs -> ls <[ r ,- ms ]> (r ,- rs) 33 | 34 | 35 | --??--3.1-(4)----------------------------------------------------------------- 36 | 37 | -- Adapt _>[_]<_ from Lec2 to work for All. Given a P for each element of 38 | -- ls and rs, riffle them together to get Ps for all the ms. 39 | 40 | _>[_]<_ : {X : Set}{ls ms rs : List X} -> {P : X -> Set} -> 41 | All P ls -> ls <[ ms ]> rs -> All P rs -> 42 | All P ms 43 | pl >[ s ]< pr = {!!} 44 | 45 | -- Now, buikd the view that shows riffling can be inverted, using a splitting 46 | -- as the instructions to discover how to split an All in two. 47 | 48 | data IsRiffle {X : Set}{ls ms rs : List X}(s : ls <[ ms ]> rs){P : X -> Set} 49 | : All P ms -> Set where 50 | mkRiffle : (pl : All P ls)(pr : All P rs) -> IsRiffle s (pl >[ s ]< pr) 51 | 52 | isRiffle : {X : Set}{ls ms rs : List X}(s : ls <[ ms ]> rs) 53 | {P : X -> Set}(pm : All P ms) -> IsRiffle s pm 54 | isRiffle s pm = {!!} 55 | 56 | --??-------------------------------------------------------------------------- 57 | 58 | 59 | --??--3.2-(4)----------------------------------------------------------------- 60 | 61 | -- Construct the "all on the right" splitting. 62 | 63 | srs : forall {X : Set}{xs : List X} -> [] <[ xs ]> xs 64 | srs = {!!} 65 | 66 | -- Construct a view to show that any "none on the left" splitting is 67 | -- "all on the right". Come up with the type yourself. 68 | 69 | 70 | -- Construct the splitting that corresponds to concatenation. 71 | 72 | slrs : forall {X : Set}(xs ys : List X) -> xs <[ xs +L ys ]> ys 73 | slrs xs ys = {!!} 74 | 75 | --??-------------------------------------------------------------------------- 76 | 77 | --??--3.3-(4)----------------------------------------------------------------- 78 | 79 | -- Invent other useful operations which transform splittings. 80 | -- You will need some to do later parts of the exercise, so maybe 81 | -- wait until you see what you need. 82 | 83 | -- I expect you will need at least something that takes a pair of splittings 84 | -- that make a tree, like 85 | -- 86 | -- ms 87 | -- <[ ]> 88 | -- ls rs 89 | -- <[ ]> 90 | -- lrs rrs 91 | -- 92 | -- and compute a "rotated" pair of splittings like 93 | -- 94 | -- ms 95 | -- <[ ]> 96 | -- ?? rrs 97 | -- <[ ]> 98 | -- ls lrs 99 | 100 | -- HINT: Sg is your friend 101 | 102 | -- You'll probably need some other stuff, too. 103 | 104 | --??-------------------------------------------------------------------------- 105 | 106 | 107 | ------------------------------------------------------------------------------ 108 | -- PART II: Permutations 109 | ------------------------------------------------------------------------------ 110 | 111 | -- When is one list a permutation of another? 112 | 113 | data _~_ {X : Set} : List X -> List X -> Set where 114 | 115 | -- [] is a permutation of [] 116 | [] : [] ~ [] 117 | 118 | -- if xs ~ ys, then (x ,- xs) is a permutation of any list made by 119 | -- shoving x somewhere into ys 120 | _,-_ : forall {x xs ys' ys} -> 121 | (x ,- []) <[ ys' ]> ys -> 122 | xs ~ ys -> 123 | (x ,- xs) ~ ys' 124 | 125 | 126 | --??--3.4-(1)----------------------------------------------------------------- 127 | 128 | -- Show that every list is a permutation of itself. 129 | 130 | reflP : {X : Set}{xs : List X} -> xs ~ xs 131 | reflP = {!!} 132 | 133 | --??-------------------------------------------------------------------------- 134 | 135 | 136 | --??--3.5-(5)----------------------------------------------------------------- 137 | 138 | -- Construct an "unbiased" insertion operator which lets you grow a 139 | -- permutation by inserting a new element anywhere, left and right 140 | 141 | insP : forall {X : Set}{z : X}{xs xs' ys ys'} -> 142 | (z ,- []) <[ xs' ]> xs -> 143 | (z ,- []) <[ ys' ]> ys -> 144 | xs ~ ys -> xs' ~ ys' 145 | insP l r p = {!!} 146 | 147 | -- Now show that, given a permutation, and any element on the left, 148 | -- you can find out where it ended up on the right, and why the 149 | -- remaining elements form a permutation. 150 | 151 | findLonR : forall {X : Set}{z : X}{xs xs' ys'} -> 152 | (z ,- []) <[ xs' ]> xs -> 153 | xs' ~ ys' -> 154 | {!!} 155 | findLonR l p = {!!} 156 | 157 | -- HINT: again, you may need Sg to give a sensible return type. 158 | 159 | --??-------------------------------------------------------------------------- 160 | 161 | 162 | --??--3.6-(5)----------------------------------------------------------------- 163 | 164 | -- Show that permutation is transitive. 165 | 166 | transP : {X : Set}{xs ys zs : List X} -> xs ~ ys -> ys ~ zs -> xs ~ zs 167 | transP p q = {!!} 168 | 169 | -- HINT: you will need to define some useful operations on splittings to 170 | -- get this to work. 171 | 172 | -- HINT: this may help you figure out what you need for findLonR 173 | 174 | -- For a small bonus, show that permutations are the morphisms of a 175 | -- Category. 176 | 177 | -- Show that permutation is symmetric. 178 | 179 | symP : {X : Set}{xs ys : List X} -> xs ~ ys -> ys ~ xs 180 | symP p = {!!} 181 | 182 | -- A category where all morphisms are invertible is called a "groupoid". 183 | 184 | --??-------------------------------------------------------------------------- 185 | 186 | 187 | --??--3.7-(2)----------------------------------------------------------------- 188 | 189 | -- Make permutations act on All. 190 | 191 | permute : {X : Set}{xs ys : List X} -> xs ~ ys -> 192 | {Q : X -> Set} -> All Q xs -> All Q ys 193 | 194 | permute p qs = {!!} 195 | 196 | --??-------------------------------------------------------------------------- 197 | 198 | 199 | 200 | -- MORE TO FOLLOW 201 | 202 | -- AGAIN, "MORE" BECAME CLEARLY SURPLUS TO REQUIREMENTS 203 | -------------------------------------------------------------------------------- /lectures/ANSIEscapes.hs: -------------------------------------------------------------------------------- 1 | module ANSIEscapes where 2 | 3 | data Dir = DU | DD | DL | DR 4 | 5 | instance Show Dir where 6 | show DU = "A" 7 | show DD = "B" 8 | show DR = "C" 9 | show DL = "D" 10 | 11 | upLine = putStr "\ESC[1A" 12 | downLine = putStr "\ESC[1B" 13 | 14 | up = moveCursor DU 15 | down = moveCursor DD 16 | backward = moveCursor DL 17 | forward = moveCursor DR 18 | 19 | moveCursor :: Dir -> Int -> IO () 20 | moveCursor dir 0 = return () 21 | moveCursor dir n = putStr $ "\ESC[" ++ show n ++ show dir 22 | 23 | killLine = escape "K" 24 | restoreCursor = escape "u" 25 | saveCursor = escape "s" 26 | clearScreen = escape "2J" 27 | initTermSize = (escape "[=3h") 28 | 29 | resetCursor = escape "0;0H" 30 | 31 | escape e = putStr $ "\ESC[" ++ e 32 | 33 | yellow str = "\ESC[1;33m" ++ str ++ "\ESC[0m" 34 | brown str = "\ESC[0;33m" ++ str ++ "\ESC[0m" 35 | blue str = "\ESC[1;34m" ++ str ++ "\ESC[0m" 36 | red str = "\ESC[1;31m" ++ str ++ "\ESC[0m" 37 | green str = "\ESC[1;32m" ++ str ++ "\ESC[0m" 38 | purple str = "\ESC[1;35m" ++ str ++ "\ESC[0m" 39 | white str = "\ESC[37m" ++ str ++ "\ESC[0m" 40 | 41 | 42 | 43 | --Be careful, these assume someone else will reset the background colour 44 | yellowOnGrey str = "\ESC[1;33m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 45 | brownOnGrey str = "\ESC[0;33m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 46 | blueOnGrey str = "\ESC[1;34m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 47 | redOnGrey str = "\ESC[1;31m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 48 | greenOnGrey str = "\ESC[1;32m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 49 | purpleOnGrey str = "\ESC[1;35m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 50 | whiteOnGrey str = "\ESC[37m" ++ str ++ "\ESC[0m" 51 | 52 | onBlack str = "\ESC[40m" ++ str ++ "\ESC[0m" 53 | onGrey str = onGreyEsc ++ str ++ onWhiteEsc 54 | onGreyEsc = "\ESC[47m" 55 | onWhiteEsc = "\ESC[0m" 56 | orange str = str -------------------------------------------------------------------------------- /lectures/Ex2.agda: -------------------------------------------------------------------------------- 1 | module Ex2 where 2 | 3 | open import Ex1 4 | 5 | -------------------------------------------------------------------------------- /lectures/HaskellSetup.hs: -------------------------------------------------------------------------------- 1 | module HaskellSetup where 2 | 3 | {- This is the low-level stuff that hooks into the ncurses library, together 4 | with the Haskell versions of the Agda types. You should not need to bother 5 | reading or modifying this file. -} 6 | 7 | import Debug.Trace 8 | import Foreign 9 | import Foreign.C (CInt(..)) 10 | import ANSIEscapes 11 | import System.IO 12 | import System.Environment 13 | import Control.Applicative 14 | import Control.Concurrent 15 | 16 | foreign import ccall 17 | initscr :: IO () 18 | 19 | foreign import ccall "endwin" 20 | endwin :: IO CInt 21 | 22 | foreign import ccall "refresh" 23 | refresh :: IO CInt 24 | 25 | foreign import ccall "&LINES" 26 | linesPtr :: Ptr CInt 27 | 28 | foreign import ccall "&COLS" 29 | colsPtr :: Ptr CInt 30 | 31 | scrSize :: IO (Int, Int) 32 | scrSize = do 33 | lnes <- peek linesPtr 34 | cols <- peek colsPtr 35 | return (fromIntegral cols, fromIntegral lnes) 36 | 37 | data Modifier = Normal | Shift | Control deriving Show 38 | data Key = Char Char | Arrow Modifier Dir | Enter | Backspace | Delete | Escape | Tab deriving Show 39 | data Event = Key Key | Resize Integer Integer 40 | 41 | {- 42 | data Nat = Zero | Suc Nat 43 | toNat :: Int -> Nat 44 | toNat 0 = Zero 45 | toNat n = Suc (toNat (n - 1)) 46 | fromNat :: Nat -> Int 47 | fromNat Zero = 0 48 | fromNat (Suc n) = 1 + fromNat n 49 | -} 50 | 51 | data EQ a b c = Refl 52 | 53 | data Change = AllQuiet | CursorMove | LineEdit | BigChange 54 | 55 | data Colour 56 | = Black | Red | Green | Yellow 57 | | Blue | Magenta | Cyan | White 58 | 59 | data Action 60 | = GoRowCol Integer Integer 61 | | SendText [Char] 62 | | Move Dir Integer 63 | | FgText Colour 64 | | BgText Colour 65 | 66 | act :: Action -> IO () 67 | act (GoRowCol y x) = do 68 | resetCursor 69 | forward (fromIntegral x) 70 | down (fromIntegral y) 71 | act (SendText s) = putStr s 72 | act (Move d n) = moveCursor d (fromIntegral n) 73 | act (FgText Black) = escape "0;30m" 74 | act (FgText Red) = escape "1;31m" 75 | act (FgText Green) = escape "1;32m" 76 | act (FgText Yellow) = escape "1;33m" 77 | act (FgText Blue) = escape "1;34m" 78 | act (FgText Magenta) = escape "1;35m" 79 | act (FgText Cyan) = escape "1;36m" 80 | act (FgText White) = escape "1;37m" 81 | act (BgText Black) = escape "40m" 82 | act (BgText Red) = escape "41m" 83 | act (BgText Green) = escape "42m" 84 | act (BgText Yellow) = escape "43m" 85 | act (BgText Blue) = escape "44m" 86 | act (BgText Magenta) = escape "45m" 87 | act (BgText Cyan) = escape "46m" 88 | act (BgText White) = escape "47m" 89 | 90 | getEscapeKey :: [(String, Key)] -> IO (Maybe Key) 91 | getEscapeKey [] = return Nothing 92 | getEscapeKey sks = case lookup "" sks of 93 | Just k -> return (Just k) 94 | _ -> do 95 | c <- getChar 96 | getEscapeKey [(cs, k) | (d : cs, k) <- sks, d == c] 97 | 98 | directions :: [(Char, Dir)] 99 | directions = [('A', DU), ('B', DD), 100 | ('C', DR), ('D', DL)] 101 | 102 | escapeKeys :: [(String, Key)] 103 | escapeKeys = 104 | [([c], Arrow Normal d) | (c, d) <- directions] ++ 105 | [("1;2" ++ [c], Arrow Shift d) | (c, d) <- directions] ++ 106 | [("1;5" ++ [c], Arrow Control d) | (c, d) <- directions] ++ 107 | [("3~", Delete)] 108 | 109 | keyReady :: IO (Maybe Key) 110 | keyReady = do 111 | b <- hReady stdin 112 | if not b then return Nothing else do 113 | c <- getChar 114 | case c of 115 | '\n' -> return $ Just Enter 116 | '\r' -> return $ Just Enter 117 | '\b' -> return $ Just Backspace 118 | '\DEL' -> return $ Just Backspace 119 | '\t' -> return $ Just Tab 120 | _ | c >= ' ' -> return $ Just (Char c) 121 | '\ESC' -> do 122 | b <- hReady stdin 123 | if not b then return $ Just Escape else do 124 | c <- getChar 125 | case c of 126 | '[' -> getEscapeKey escapeKeys 127 | _ -> return $ Just Escape 128 | _ -> return $ Nothing 129 | 130 | pni :: (Int, Int) -> (Integer, Integer) 131 | pni (y, x) = (toInteger y, toInteger x) 132 | 133 | mainLoop :: 134 | ([[Char]] -> b) -> 135 | (Key -> b -> (Change, b)) -> 136 | ((Integer, Integer) -> (Integer, Integer) -> (Change, b) -> ([Action], (Integer, Integer))) -> 137 | IO () 138 | mainLoop initBuf keystroke render = do 139 | hSetBuffering stdout NoBuffering 140 | hSetBuffering stdin NoBuffering 141 | xs <- getArgs 142 | buf <- case xs of 143 | [] -> return (initBuf []) 144 | (x : _) -> (initBuf . lines) <$> readFile x 145 | initscr 146 | innerLoop (0, 0) (0, 0) (BigChange, buf) 147 | endwin 148 | return () 149 | where 150 | innerLoop oldSize topLeft (c, b) = do 151 | refresh 152 | size <- scrSize 153 | (acts, topLeft) <- return $ 154 | if size /= oldSize 155 | then render (pni size) topLeft (BigChange, b) 156 | else render (pni size) topLeft (c, b) 157 | mapM_ act acts 158 | mc <- keyReady 159 | case mc of 160 | Nothing -> threadDelay 100 >> innerLoop size topLeft (AllQuiet, b) 161 | Just k -> innerLoop size topLeft (keystroke k b) 162 | 163 | 164 | mainAppLoop :: 165 | s -> (Event -> s -> (s, [Action])) -> 166 | IO () 167 | mainAppLoop start reactor = do 168 | hSetBuffering stdout NoBuffering 169 | hSetBuffering stdin NoBuffering 170 | initscr 171 | innerLoop (0, 0) start 172 | endwin 173 | return () 174 | where 175 | innerLoop oldSize state0 = do 176 | refresh 177 | size@(w, h) <- scrSize 178 | let (state1, acts) = if size /= oldSize 179 | then reactor (Resize (toInteger w) (toInteger h)) state0 180 | else (state0, []) 181 | mapM_ act acts 182 | mc <- keyReady 183 | case mc of 184 | Nothing -> threadDelay 100 >> innerLoop size state1 185 | Just k -> do 186 | let (state2, acts) = reactor (Key k) state1 187 | mapM_ act acts 188 | innerLoop size state2 189 | -------------------------------------------------------------------------------- /lectures/Lec1.agda: -------------------------------------------------------------------------------- 1 | module Lec1 where 2 | 3 | -- the -- mark introduces a "comment to end of line" 4 | 5 | 6 | ------------------------------------------------------------------------------ 7 | -- some basic "logical" types 8 | ------------------------------------------------------------------------------ 9 | 10 | data Zero : Set where 11 | -- to give a value in a data, choose one constructor 12 | -- there are no constructors 13 | -- so that's impossible 14 | 15 | record One : Set where 16 | constructor <> 17 | -- to give a value in a record type, fill all its fields 18 | -- there are no fields 19 | -- so that's trivial 20 | -- (can we have a constructor, for convenience?) 21 | 22 | data _+_ (S : Set)(T : Set) : Set where -- "where" wants an indented block 23 | -- to offer a choice of constructors, list them with their types 24 | inl : S -> S + T -- constructors can pack up stuff 25 | inr : T -> S + T 26 | -- in Haskell, this was called "Either S T" 27 | 28 | record Sg (S : Set)(T : S -> Set) : Set where -- Sg is short for "Sigma" 29 | constructor _,_ 30 | field -- introduces a bunch of fields, listed with their types 31 | fst : S 32 | snd : T fst 33 | -- make _*_ from Sg ? 34 | 35 | _*_ : (S : Set)(T : Set) -> Set 36 | S * T = Sg S \ _ -> T 37 | 38 | ------------------------------------------------------------------------------ 39 | -- some simple proofs 40 | ------------------------------------------------------------------------------ 41 | 42 | {-(-} 43 | comm-* : {A : Set}{B : Set} -> A * B -> B * A 44 | comm-* record { fst = a ; snd = b } = record { fst = b ; snd = a } 45 | {-)-} 46 | 47 | {-(-} 48 | assocLR-+ : {A B C : Set} -> (A + B) + C -> A + (B + C) 49 | assocLR-+ (inl (inl a)) = inl a 50 | assocLR-+ (inl (inr b)) = inr (inl b) 51 | assocLR-+ (inr c) = inr (inr c) 52 | {-)-} 53 | 54 | {-(-} 55 | _$*_ : {A A' B B' : Set} -> (A -> A') -> (B -> B') -> A * B -> A' * B' 56 | (f $* g) (a , b) = f a , g b 57 | {-)-} 58 | 59 | -- record syntax is rather ugly for small stuff; can we have constructors? 60 | 61 | {-(-} 62 | _$+_ : {A A' B B' : Set} -> (A -> A') -> (B -> B') -> A + B -> A' + B' 63 | (f $+ g) (inl a) = inl (f a) 64 | (f $+ g) (inr b) = inr (g b) 65 | {-)-} 66 | 67 | {-(-} 68 | combinatorK : {A E : Set} -> A -> (E -> A) 69 | combinatorK = \ a e -> a 70 | 71 | combinatorS : {S T E : Set} -> (E -> (S -> T)) -> (E -> S) -> E -> T 72 | combinatorS = \ est es e -> est e (es e) 73 | {-)-} 74 | 75 | {-(-} 76 | id : {X : Set} -> X -> X 77 | -- id x = x -- is the easy way; let's do it a funny way to make a point 78 | id = (combinatorS combinatorK) (combinatorK {_} {Zero}) 79 | {-)-} 80 | 81 | {-(-} 82 | naughtE : {X : Set} -> Zero -> X 83 | naughtE {X} () 84 | {-)-} 85 | 86 | 87 | ------------------------------------------------------------------------------ 88 | -- from logic to data 89 | ------------------------------------------------------------------------------ 90 | 91 | data Nat : Set where 92 | zero : Nat 93 | suc : Nat -> Nat -- recursive data type 94 | 95 | {-# BUILTIN NATURAL Nat #-} 96 | -- ^^^^^^^^^^^^^^^^^^^ this pragma lets us use decimal notation 97 | 98 | {-(-} 99 | _+N_ : Nat -> Nat -> Nat 100 | zero +N y = y 101 | suc x +N y = suc (x +N y) 102 | 103 | four : Nat 104 | four = 2 +N 2 105 | {-)-} 106 | 107 | 108 | ------------------------------------------------------------------------------ 109 | -- and back to logic 110 | ------------------------------------------------------------------------------ 111 | 112 | {-(-} 113 | data _==_ {X : Set} : X -> X -> Set where 114 | refl : (x : X) -> x == x -- the relation that's "only reflexive" 115 | 116 | {-# BUILTIN EQUALITY _==_ #-} -- we'll see what that's for, later 117 | 118 | see4 : (2 +N 2) == 4 119 | see4 = refl 4 120 | 121 | 122 | _=$=_ : {X Y : Set}{f f' : X -> Y}{x x' : X} -> 123 | f == f' -> x == x' -> f x == f' x' 124 | refl f =$= refl x = refl (f x) 125 | {-)-} 126 | 127 | {-(-} 128 | zero-+N : (n : Nat) -> (zero +N n) == n 129 | zero-+N n = refl n 130 | 131 | +N-zero : (n : Nat) -> (n +N zero) == n 132 | +N-zero zero = refl zero 133 | +N-zero (suc n) = refl suc =$= +N-zero n 134 | 135 | 136 | assocLR-+N : (x y z : Nat) -> ((x +N y) +N z) == (x +N (y +N z)) 137 | assocLR-+N zero y z = refl (y +N z) 138 | assocLR-+N (suc x) y z rewrite assocLR-+N x y z = refl (suc (x +N (y +N z))) 139 | {-)-} 140 | 141 | ------------------------------------------------------------------------------ 142 | -- computing types 143 | ------------------------------------------------------------------------------ 144 | 145 | {-(-} 146 | _>=_ : Nat -> Nat -> Set 147 | x >= zero = One 148 | zero >= suc y = Zero 149 | suc x >= suc y = x >= y 150 | 151 | {- 152 | a0 : 2 >= 4 153 | a0 = {!!} 154 | -} 155 | 156 | a1 : 4 >= 2 157 | a1 = <> 158 | 159 | 160 | 161 | refl->= : (n : Nat) -> n >= n 162 | refl->= zero = <> 163 | refl->= (suc n) = refl->= n 164 | 165 | trans->= : (x y z : Nat) -> x >= y -> y >= z -> x >= z 166 | trans->= x y zero x>=y y>=z = <> 167 | trans->= zero zero (suc z) x>=y () 168 | trans->= zero (suc y) (suc z) () y>=z 169 | trans->= (suc x) zero (suc z) x>=y () 170 | trans->= (suc x) (suc y) (suc z) x>=y y>=z = trans->= x y z x>=y y>=z 171 | {-)-} 172 | 173 | 174 | ------------------------------------------------------------------------------ 175 | -- construction by proof 176 | ------------------------------------------------------------------------------ 177 | 178 | {-(-} 179 | 180 | difference : (m n : Nat) -> m >= n -> Sg Nat \ d -> m == (n +N d) 181 | -- ( ) 182 | difference m zero p = m , refl m 183 | difference zero (suc n) () 184 | difference (suc m) (suc n) p with difference m n p 185 | {-difference (suc .(n +N d)) (suc n) p 186 | | d , refl .(n +N d) = d , refl (suc (n +N d)) 187 | -} 188 | difference (suc m) (suc n) p | d , q rewrite q = {!!} -- d , refl (suc (n +N d)) 189 | --difference (suc m) (suc n) p | d , q = d , (refl suc =$= q) 190 | 191 | tryMe = difference 42 37 _ 192 | don'tTryMe = difference 37 42 {!!} 193 | {-)-} 194 | 195 | ------------------------------------------------------------------------------ 196 | -- things to remember to say 197 | ------------------------------------------------------------------------------ 198 | 199 | -- why the single colon? 200 | 201 | -- what's with all the spaces? 202 | 203 | -- what's with identifiers mixing letters and symbols? 204 | 205 | -- what's with all the braces? 206 | 207 | -- what is Set? 208 | 209 | -- are there any lowercase/uppercase conventions? 210 | 211 | -- what's with all the underscores? 212 | -- (i) placeholders in mixfix operators 213 | -- (ii) don't care (on the left) 214 | -- (iii) go figure (on the right) 215 | 216 | -- why use arithmetic operators for types? 217 | 218 | -- what's the difference between = and == ? 219 | 220 | -- can't we leave out cases? 221 | 222 | -- can't we loop? 223 | 224 | {- 225 | brexit : {A : Set} -> A 226 | brexit = brexit 227 | -} 228 | 229 | -- the function type is both implication and universal quantification, 230 | -- but why is it called Pi? 231 | 232 | -- why is Sigma called Sigma? 233 | 234 | -- B or nor B? 235 | 236 | {- 237 | exMid : {B : Set} -> B + (B -> Zero) 238 | exMid = {!!} 239 | 240 | deMorgan : {A B : Set} -> ((A * B) -> Zero) -> (A -> Zero) + (B -> Zero) 241 | deMorgan notAandB = {!!} 242 | -} 243 | -------------------------------------------------------------------------------- /lectures/Lec1Done.agda: -------------------------------------------------------------------------------- 1 | module Lec1Done where 2 | 3 | -- the -- mark introduces a "comment to end of line" 4 | 5 | 6 | ------------------------------------------------------------------------------ 7 | -- some basic "logical" types 8 | ------------------------------------------------------------------------------ 9 | 10 | data Zero : Set where 11 | -- to give a value in a data, choose one constructor 12 | -- there are no constructors 13 | -- so that's impossible 14 | 15 | record One : Set where 16 | -- to give a value in a record type, fill all its fields 17 | -- there are no fields 18 | -- so that's trivial 19 | -- (can we have a constructor, for convenience?) 20 | constructor <> 21 | 22 | {-# COMPILE GHC One = data () (()) #-} 23 | 24 | 25 | data _+_ (S : Set)(T : Set) : Set where -- "where" wants an indented block 26 | -- to offer a choice of constructors, list them with their types 27 | inl : S -> S + T -- constructors can pack up stuff 28 | inr : T -> S + T 29 | -- in Haskell, this was called "Either S T" 30 | 31 | {- 32 | record _*_ (S : Set)(T : Set) : Set where 33 | field -- introduces a bunch of fields, listed with their types 34 | fst : S 35 | snd : T 36 | -- in Haskell, this was called "(S, T)" 37 | -} 38 | 39 | -- _*_ IS GENERALIZED BY SIGMA 40 | 41 | record Sg (S : Set)(T : S -> Set) : Set where -- Sg is short for "Sigma" 42 | constructor _,_ 43 | field -- introduces a bunch of fields, listed with their types 44 | fst : S 45 | snd : T fst 46 | open Sg public -- brings fst and snd into scope hereafter unto all inheritors 47 | -- make _*_ from Sg ? 48 | _*_ : Set -> Set -> Set 49 | S * T = Sg S \ _ -> T 50 | infixr 4 _*_ _,_ 51 | 52 | 53 | 54 | ------------------------------------------------------------------------------ 55 | -- some simple proofs 56 | ------------------------------------------------------------------------------ 57 | 58 | comm-* : {A : Set}{B : Set} -> A * B -> B * A 59 | comm-* record { fst = a ; snd = b } = record { fst = b ; snd = a } 60 | 61 | assocLR-+ : {A B C : Set} -> (A + B) + C -> A + (B + C) 62 | assocLR-+ (inl (inl a)) = inl a 63 | assocLR-+ (inl (inr b)) = inr (inl b) 64 | assocLR-+ (inr c) = inr (inr c) 65 | 66 | _$*_ : {A A' B B' : Set} -> (A -> A') -> (B -> B') -> A * B -> A' * B' 67 | (f $* g) record { fst = a ; snd = b } = record { fst = f a ; snd = g b } 68 | 69 | -- record syntax is rather ugly for small stuff; can we have constructors? 70 | 71 | _$+_ : {A A' B B' : Set} -> (A -> A') -> (B -> B') -> A + B -> A' + B' 72 | (f $+ g) (inl a) = inl (f a) 73 | (f $+ g) (inr b) = inr (g b) 74 | 75 | combinatorK : {A E : Set} -> A -> E -> A 76 | combinatorK = \ a _ -> a 77 | 78 | combinatorS : {S T E : Set} -> (E -> S -> T) -> (E -> S) -> E -> T 79 | combinatorS = \ f s e -> (f e) (s e) 80 | 81 | id : {X : Set} -> X -> X 82 | -- id x = x -- is the easy way; let's do it a funny way to make a point 83 | id = combinatorS combinatorK (combinatorK {_} {Zero}) 84 | -- no choice for -^ ^^^^- could be anything 85 | 86 | naughtE : {X : Set} -> Zero -> X 87 | naughtE () 88 | 89 | -- standard composition: f << g is "f after g" 90 | _<<_ : {X Y Z : Set} -> (Y -> Z) -> (X -> Y) -> (X -> Z) 91 | (f << g) x = f (g x) 92 | 93 | -- diagrammatic composition: f >> g is "f then g" 94 | _>>_ : {X Y Z : Set} -> (X -> Y) -> (Y -> Z) -> (X -> Z) 95 | -- ^^^^^^^^ dominoes! 96 | (f >> g) x = g (f x) 97 | 98 | -- infix application 99 | _$_ : {S : Set}{T : S -> Set}(f : (x : S) -> T x)(s : S) -> T s 100 | f $ s = f s 101 | infixl 2 _$_ 102 | 103 | 104 | ------------------------------------------------------------------------------ 105 | -- from logic to data 106 | ------------------------------------------------------------------------------ 107 | 108 | data Nat : Set where 109 | zero : Nat 110 | suc : Nat -> Nat -- recursive data type 111 | 112 | {-# BUILTIN NATURAL Nat #-} 113 | -- ^^^^^^^^^^^^^^^^^^^ this pragma lets us use decimal notation 114 | 115 | _+N_ : Nat -> Nat -> Nat 116 | zero +N y = y 117 | suc x +N y = suc (x +N y) -- there are other choices 118 | 119 | four : Nat 120 | four = 2 +N 2 121 | 122 | 123 | ------------------------------------------------------------------------------ 124 | -- and back to logic 125 | ------------------------------------------------------------------------------ 126 | 127 | data _==_ {X : Set} : X -> X -> Set where 128 | refl : (x : X) -> x == x -- the relation that's "only reflexive" 129 | 130 | {-# BUILTIN EQUALITY _==_ #-} -- we'll see what that's for, later 131 | 132 | _=$=_ : {X Y : Set}{f f' : X -> Y}{x x' : X} -> 133 | f == f' -> x == x' -> f x == f' x' 134 | refl f =$= refl x = refl (f x) 135 | infixl 2 _=$=_ 136 | 137 | zero-+N : (n : Nat) -> (zero +N n) == n 138 | zero-+N n = refl n 139 | 140 | +N-zero : (n : Nat) -> (n +N zero) == n 141 | +N-zero zero = refl zero 142 | +N-zero (suc n) = refl suc =$= +N-zero n 143 | 144 | assocLR-+N : (x y z : Nat) -> ((x +N y) +N z) == (x +N (y +N z)) 145 | assocLR-+N zero y z = refl (y +N z) 146 | assocLR-+N (suc x) y z = refl suc =$= assocLR-+N x y z 147 | 148 | 149 | ------------------------------------------------------------------------------ 150 | -- computing types 151 | ------------------------------------------------------------------------------ 152 | 153 | _>=_ : Nat -> Nat -> Set 154 | x >= zero = One 155 | zero >= suc y = Zero 156 | suc x >= suc y = x >= y 157 | 158 | refl->= : (n : Nat) -> n >= n 159 | refl->= zero = record {} 160 | refl->= (suc n) = refl->= n 161 | 162 | trans->= : (x y z : Nat) -> x >= y -> y >= z -> x >= z 163 | trans->= x y zero x>=y y>=z = record {} 164 | trans->= x zero (suc z) x>=y () 165 | trans->= zero (suc y) (suc z) () y>=z 166 | trans->= (suc x) (suc y) (suc z) x>=y y>=z = trans->= x y z x>=y y>=z 167 | 168 | 169 | ------------------------------------------------------------------------------ 170 | -- construction by proof 171 | ------------------------------------------------------------------------------ 172 | 173 | {- -- MOVED UP TO REPLACE _*_ 174 | record Sg (S : Set)(T : S -> Set) : Set where -- Sg is short for "Sigma" 175 | constructor _,_ 176 | field -- introduces a bunch of fields, listed with their types 177 | fst : S 178 | snd : T fst 179 | -- make _*_ from Sg ? 180 | _*_ : Set -> Set -> Set 181 | S * T = Sg S \ _ -> T 182 | -} 183 | 184 | difference : (m n : Nat) -> m >= n -> Sg Nat \ d -> m == (n +N d) 185 | -- ( ) 186 | difference m zero m>=n = m , refl m 187 | difference zero (suc n) () 188 | difference (suc m) (suc n) m>=n with difference m n m>=n 189 | difference (suc m) (suc n) m>=n | d , q = d , (refl suc =$= q) 190 | 191 | tryMe = difference 42 37 _ 192 | -- don'tTryMe = difference 37 42 {!!} 193 | 194 | 195 | ------------------------------------------------------------------------------ 196 | -- things to remember to say 197 | ------------------------------------------------------------------------------ 198 | 199 | -- why the single colon? 200 | 201 | -- what's with all the spaces? 202 | 203 | -- what's with identifiers mixing letters and symbols? 204 | 205 | -- what's with all the braces? 206 | 207 | -- what is Set? 208 | 209 | -- are there any lowercase/uppercase conventions? 210 | 211 | -- what's with all the underscores? 212 | -- (i) placeholders in mixfix operators 213 | -- (ii) don't care (on the left) 214 | -- (iii) go figure (on the right) 215 | 216 | -- why use arithmetic operators for types? 217 | 218 | -- what's the difference between = and == ? 219 | 220 | -- can't we leave out cases? 221 | 222 | -- can't we loop? 223 | 224 | -- the function type is both implication and universal quantification, 225 | -- but why is it called Pi? 226 | 227 | -- why is Sigma called Sigma? 228 | 229 | -- B or nor B? 230 | -------------------------------------------------------------------------------- /lectures/Lec1Start.agda: -------------------------------------------------------------------------------- 1 | module Lec1Start where 2 | 3 | -- the -- mark introduces a "comment to end of line" 4 | 5 | 6 | ------------------------------------------------------------------------------ 7 | -- some basic "logical" types 8 | ------------------------------------------------------------------------------ 9 | 10 | data Zero : Set where 11 | -- to give a value in a data, choose one constructor 12 | -- there are no constructors 13 | -- so that's impossible 14 | 15 | record One : Set where 16 | -- to give a value in a record type, fill all its fields 17 | -- there are no fields 18 | -- so that's trivial 19 | -- (can we have a constructor, for convenience?) 20 | 21 | data _+_ (S : Set)(T : Set) : Set where -- "where" wants an indented block 22 | -- to offer a choice of constructors, list them with their types 23 | inl : S -> S + T -- constructors can pack up stuff 24 | inr : T -> S + T 25 | -- in Haskell, this was called "Either S T" 26 | 27 | record _*_ (S : Set)(T : Set) : Set where 28 | field -- introduces a bunch of fields, listed with their types 29 | fst : S 30 | snd : T 31 | -- in Haskell, this was called "(S, T)" 32 | 33 | ------------------------------------------------------------------------------ 34 | -- some simple proofs 35 | ------------------------------------------------------------------------------ 36 | 37 | {-+} 38 | comm-* : {A : Set}{B : Set} -> A * B -> B * A 39 | comm-* x = ? 40 | {+-} 41 | 42 | {-+} 43 | assocLR-+ : {A B C : Set} -> (A + B) + C -> A + (B + C) 44 | assocLR-+ x = ? 45 | {+-} 46 | 47 | {-+} 48 | _$*_ : {A A' B B' : Set} -> (A -> A') -> (B -> B') -> A * B -> A' * B' 49 | (f $* g) x = r? 50 | {+-} 51 | 52 | -- record syntax is rather ugly for small stuff; can we have constructors? 53 | 54 | {-+} 55 | _$+_ : {A A' B B' : Set} -> (A -> A') -> (B -> B') -> A + B -> A' + B' 56 | (f $+ g) x = ? 57 | {+-} 58 | 59 | {-+} 60 | combinatorK : {A E : Set} -> A -> E -> A 61 | combinatorK = ? 62 | 63 | combinatorS : {S T E : Set} -> (E -> S -> T) -> (E -> S) -> E -> T 64 | combinatorS = ? 65 | {+-} 66 | 67 | {-+} 68 | id : {X : Set} -> X -> X 69 | -- id x = x -- is the easy way; let's do it a funny way to make a point 70 | id = ? 71 | {+-} 72 | 73 | {-+} 74 | naughtE : {X : Set} -> Zero -> X 75 | naughtE x = ? 76 | {+-} 77 | 78 | 79 | ------------------------------------------------------------------------------ 80 | -- from logic to data 81 | ------------------------------------------------------------------------------ 82 | 83 | data Nat : Set where 84 | zero : Nat 85 | suc : Nat -> Nat -- recursive data type 86 | 87 | {-# BUILTIN NATURAL Nat #-} 88 | -- ^^^^^^^^^^^^^^^^^^^ this pragma lets us use decimal notation 89 | 90 | {-+} 91 | _+N_ : Nat -> Nat -> Nat 92 | x +N y = ? 93 | 94 | four : Nat 95 | four = 2 +N 2 96 | {+-} 97 | 98 | 99 | ------------------------------------------------------------------------------ 100 | -- and back to logic 101 | ------------------------------------------------------------------------------ 102 | 103 | {-+} 104 | data _==_ {X : Set} : X -> X -> Set where 105 | refl : (x : X) -> x == x -- the relation that's "only reflexive" 106 | 107 | {-# BUILTIN EQUALITY _==_ #-} -- we'll see what that's for, later 108 | 109 | _=$=_ : {X Y : Set}{f f' : X -> Y}{x x' : X} -> 110 | f == f' -> x == x' -> f x == f' x' 111 | fq =$= xq = ? 112 | {+-} 113 | 114 | {-+} 115 | zero-+N : (n : Nat) -> (zero +N n) == n 116 | zero-+N n = ? 117 | 118 | +N-zero : (n : Nat) -> (n +N zero) == n 119 | +N-zero n = ? 120 | 121 | assocLR-+N : (x y z : Nat) -> ((x +N y) +N z) == (x +N (y +N z)) 122 | assocLR-+N x y z = ? 123 | {+-} 124 | 125 | ------------------------------------------------------------------------------ 126 | -- computing types 127 | ------------------------------------------------------------------------------ 128 | 129 | {-+} 130 | _>=_ : Nat -> Nat -> Set 131 | x >= zero = One 132 | zero >= suc y = Zero 133 | suc x >= suc y = x >= y 134 | 135 | refl->= : (n : Nat) -> n >= n 136 | refl->= n = {!!} 137 | 138 | trans->= : (x y z : Nat) -> x >= y -> y >= z -> x >= z 139 | trans->= x y z x>=y y>=z = {!!} 140 | {+-} 141 | 142 | 143 | ------------------------------------------------------------------------------ 144 | -- construction by proof 145 | ------------------------------------------------------------------------------ 146 | 147 | {-+} 148 | record Sg (S : Set)(T : S -> Set) : Set where -- Sg is short for "Sigma" 149 | constructor _,_ 150 | field -- introduces a bunch of fields, listed with their types 151 | fst : S 152 | snd : T fst 153 | -- make _*_ from Sg ? 154 | 155 | difference : (m n : Nat) -> m >= n -> Sg Nat \ d -> m == (n +N d) 156 | -- ( ) 157 | difference m zero m>=n = m , refl m 158 | difference zero (suc n) () 159 | difference (suc m) (suc n) m>=n with difference m n m>=n 160 | difference (suc m) (suc n) m>=n | d , q = d , (refl suc =$= q) 161 | 162 | tryMe = difference 42 37 _ 163 | don'tTryMe = difference 37 42 {!!} 164 | {+-} 165 | 166 | ------------------------------------------------------------------------------ 167 | -- things to remember to say 168 | ------------------------------------------------------------------------------ 169 | 170 | -- why the single colon? 171 | 172 | -- what's with all the spaces? 173 | 174 | -- what's with identifiers mixing letters and symbols? 175 | 176 | -- what's with all the braces? 177 | 178 | -- what is Set? 179 | 180 | -- are there any lowercase/uppercase conventions? 181 | 182 | -- what's with all the underscores? 183 | -- (i) placeholders in mixfix operators 184 | -- (ii) don't care (on the left) 185 | -- (iii) go figure (on the right) 186 | 187 | -- why use arithmetic operators for types? 188 | 189 | -- what's the difference between = and == ? 190 | 191 | -- can't we leave out cases? 192 | 193 | -- can't we loop? 194 | 195 | -- the function type is both implication and universal quantification, 196 | -- but why is it called Pi? 197 | 198 | -- why is Sigma called Sigma? 199 | 200 | -- B or nor B? 201 | -------------------------------------------------------------------------------- /lectures/Lec2.agda: -------------------------------------------------------------------------------- 1 | module Lec2 where 2 | 3 | open import Lec1Done 4 | 5 | 6 | ------------------------------------------------------------------------------ 7 | -- Vectors -- the star of exercise 1 8 | ------------------------------------------------------------------------------ 9 | 10 | data Vec (X : Set) : Nat -> Set where -- like lists, but length-indexed 11 | [] : Vec X zero 12 | _,-_ : {n : Nat} -> X -> Vec X n -> Vec X (suc n) 13 | infixr 4 _,-_ -- the "cons" operator associates to the right 14 | 15 | 16 | ------------------------------------------------------------------------------ 17 | -- Taking a Prefix of a Vector 18 | ------------------------------------------------------------------------------ 19 | 20 | {-(-} 21 | vTake : (m n : Nat) -> m >= n -> {X : Set} -> Vec X m -> Vec X n 22 | vTake m zero m>=n xs = [] 23 | vTake zero (suc n) () xs 24 | vTake (suc m) (suc n) m>=n (x ,- xs) = x ,- vTake m n m>=n xs 25 | {-)-} 26 | 27 | example : Vec Nat 3 28 | example = vTake _ _ _ (1 ,- 2 ,- 3 ,- 4 ,- 5 ,- []) 29 | 30 | 31 | ------------------------------------------------------------------------------ 32 | -- Things to Prove 33 | ------------------------------------------------------------------------------ 34 | 35 | {-(-} 36 | vTakeIdFact : (n : Nat){X : Set}(xs : Vec X n) -> 37 | vTake n n (refl->= n) xs == xs 38 | vTakeIdFact zero [] = refl [] 39 | vTakeIdFact (suc n) (x ,- xs) with vTake n n (refl->= n) xs | vTakeIdFact n xs 40 | vTakeIdFact (suc n) (x ,- xs) | .xs | refl .xs = refl (x ,- xs) 41 | 42 | vTakeCpFact : (m n p : Nat)(m>=n : m >= n)(n>=p : n >= p) 43 | {X : Set}(xs : Vec X m) -> 44 | vTake m p (trans->= m n p m>=n n>=p) xs == 45 | vTake n p n>=p (vTake m n m>=n xs) 46 | {- hit p first: why? -} 47 | vTakeCpFact m n p m>=n n>=p xs = {!!} 48 | {-)-} 49 | 50 | ------------------------------------------------------------------------------ 51 | -- Splittings (which bear some relationship to <= from ex1) 52 | ------------------------------------------------------------------------------ 53 | 54 | data _<[_]>_ : Nat -> Nat -> Nat -> Set where 55 | zzz : zero <[ zero ]> zero 56 | lll : {l m r : Nat} -> l <[ m ]> r 57 | -> suc l <[ suc m ]> r 58 | rrr : {l m r : Nat} -> l <[ m ]> r 59 | -> l <[ suc m ]> suc r 60 | 61 | {-(-} 62 | _>[_]<_ : {X : Set}{l m r : Nat} -> 63 | Vec X l -> l <[ m ]> r -> Vec X r -> 64 | Vec X m 65 | 66 | xl >[ rrr nnn ]< (x ,- xr) = x ,- (xl >[ nnn ]< xr) 67 | 68 | (x ,- xl) >[ lll nnn ]< xr = x ,- (xl >[ nnn ]< xr) 69 | 70 | [] >[ zzz ]< [] = [] 71 | 72 | {-)-} 73 | 74 | {-(-} 75 | data FindSplit {X : Set}{l m r : Nat}(nnn : l <[ m ]> r) 76 | : (xs : Vec X m) -> Set where 77 | splitBits : (xl : Vec X l)(xr : Vec X r) -> FindSplit nnn (xl >[ nnn ]< xr) 78 | {-)-} 79 | 80 | {-(-} 81 | findSplit : {X : Set}{l m r : Nat}(nnn : l <[ m ]> r)(xs : Vec X m) -> 82 | FindSplit nnn xs 83 | findSplit zzz [] = splitBits [] [] 84 | findSplit (lll nnn) (x ,- xs) with findSplit nnn xs 85 | findSplit (lll nnn) (x ,- .(xl >[ nnn ]< xr)) | splitBits xl xr = splitBits (x ,- xl) xr 86 | findSplit (rrr nnn) (x ,- xs) = help nnn x xs (findSplit nnn xs) where 87 | help : forall {m l r X} (nnn : l <[ m ]> r) (x : X) (xs : Vec X m) -> 88 | (rc : FindSplit nnn xs) -> 89 | FindSplit (rrr nnn) (x ,- xs) 90 | help nnn x .(xl >[ nnn ]< xr) (splitBits xl xr) = splitBits xl (x ,- xr) 91 | {-)-} 92 | 93 | -- Conor, show how *with* works. 94 | 95 | 96 | ------------------------------------------------------------------------------ 97 | -- what I should remember to say 98 | ------------------------------------------------------------------------------ 99 | 100 | -- What's the difference between m>=n and m >= n ? 101 | {- m>=n (without spaces) is just an identifier; it could be anything, 102 | but it has been chosen to be suggestive of its *type* which is 103 | m >= n (with spaces) which is the proposition that m is at least n. 104 | By "proposition", I mean "type with at most one inhabitant", where 105 | we care more about whether there is an inhabitant or not than which 106 | one (because there's never a choice). Finished code does not show 107 | us the types of its components, and that's not always a good thing. 108 | Here, by picking nice names, we get something of an aide-memoire. -} 109 | 110 | -- What does (x ,-_) mean? 111 | {- It's a "left section". Right sections (_,- xs) also exist sometimes. 112 | Why only sometimes? -} 113 | 114 | -- "Why is it stuck?" 115 | {- Proof by induction isn't just flailing about, you know? The trick is 116 | to pick the case analysis that provokes the "stuck" programs to do a 117 | step of computation. Then the same reasoning that justifies the 118 | termination of the program will justify the induction in a proof 119 | about it. -} 120 | 121 | -------------------------------------------------------------------------------- /lectures/Lec2Done.agda: -------------------------------------------------------------------------------- 1 | module Lec2Done where 2 | 3 | open import Lec1Done 4 | 5 | 6 | ------------------------------------------------------------------------------ 7 | -- Vectors -- the star of exercise 1 8 | ------------------------------------------------------------------------------ 9 | 10 | data Vec (X : Set) : Nat -> Set where -- like lists, but length-indexed 11 | [] : Vec X zero 12 | _,-_ : {n : Nat} -> X -> Vec X n -> Vec X (suc n) 13 | infixr 4 _,-_ -- the "cons" operator associates to the right 14 | 15 | 16 | ------------------------------------------------------------------------------ 17 | -- Taking a Prefix of a Vector 18 | ------------------------------------------------------------------------------ 19 | 20 | vTake : (m n : Nat) -> m >= n -> {X : Set} -> Vec X m -> Vec X n 21 | vTake m zero m>=n xs = [] 22 | vTake zero (suc n) () xs 23 | vTake (suc m) (suc n) m>=n (x ,- xs) = x ,- vTake m n m>=n xs 24 | 25 | 26 | ------------------------------------------------------------------------------ 27 | -- Things to Prove 28 | ------------------------------------------------------------------------------ 29 | 30 | vTakeIdFact : (n : Nat){X : Set}(xs : Vec X n) -> 31 | vTake n n (refl->= n) xs == xs 32 | vTakeIdFact zero [] = refl [] 33 | vTakeIdFact (suc n) (x ,- xs) = refl (x ,-_) =$= vTakeIdFact n xs 34 | 35 | vTakeCpFact : (m n p : Nat)(m>=n : m >= n)(n>=p : n >= p) 36 | {X : Set}(xs : Vec X m) -> 37 | vTake m p (trans->= m n p m>=n n>=p) xs == 38 | vTake n p n>=p (vTake m n m>=n xs) 39 | {- hit p first: why? -} 40 | vTakeCpFact m n zero m>=n n>=p xs = refl [] 41 | {- hit n second: why? -} 42 | vTakeCpFact m zero (suc p) m>=n () xs 43 | {- hit m third: why? -} 44 | vTakeCpFact zero (suc n) (suc p) () n>=p xs 45 | {- hit xs fourth: why? -} 46 | vTakeCpFact (suc m) (suc n) (suc p) m>=n n>=p (x ,- xs) = 47 | {- build the shared skeleton -} 48 | refl (x ,-_) =$= 49 | {- invoke the induction (preferably by C-c C-a -} 50 | vTakeCpFact m n p m>=n n>=p xs 51 | 52 | 53 | ------------------------------------------------------------------------------ 54 | -- Splittings (which bear some relationship to <= from ex1) 55 | ------------------------------------------------------------------------------ 56 | 57 | data _<[_]>_ : Nat -> Nat -> Nat -> Set where 58 | zzz : zero <[ zero ]> zero 59 | lll : {l m r : Nat} -> l <[ m ]> r 60 | -> suc l <[ suc m ]> r 61 | rrr : {l m r : Nat} -> l <[ m ]> r 62 | -> l <[ suc m ]> suc r 63 | 64 | _>[_]<_ : {X : Set}{l m r : Nat} -> 65 | Vec X l -> l <[ m ]> r -> Vec X r -> 66 | Vec X m 67 | {- why is the rrr line first? -} 68 | xl >[ rrr nnn ]< (x ,- xr) = x ,- (xl >[ nnn ]< xr) 69 | (x ,- xl) >[ lll nnn ]< xr = x ,- (xl >[ nnn ]< xr) 70 | [] >[ zzz ]< [] = [] 71 | 72 | data FindSplit {X : Set}{l m r : Nat}(nnn : l <[ m ]> r) 73 | : (xs : Vec X m) -> Set where 74 | splitBits : (xl : Vec X l)(xr : Vec X r) -> FindSplit nnn (xl >[ nnn ]< xr) 75 | 76 | findSplit : {X : Set}{l m r : Nat}(nnn : l <[ m ]> r)(xs : Vec X m) -> 77 | FindSplit nnn xs 78 | findSplit zzz [] = splitBits [] [] 79 | findSplit (lll nnn) (x ,- xs) with findSplit nnn xs 80 | findSplit (lll nnn) (x ,- .(xl >[ nnn ]< xr)) | splitBits xl xr 81 | = splitBits (x ,- xl) xr 82 | findSplit (rrr nnn) (x ,- xs) with findSplit nnn xs 83 | findSplit (rrr nnn) (x ,- .(xl >[ nnn ]< xr)) | splitBits xl xr 84 | = splitBits xl (x ,- xr) 85 | 86 | 87 | ------------------------------------------------------------------------------ 88 | -- what I should remember to say 89 | ------------------------------------------------------------------------------ 90 | 91 | -- What's the difference between m>=n and m >= n ? 92 | {- m>=n (without spaces) is just an identifier; it could be anything, 93 | but it has been chosen to be suggestive of its *type* which is 94 | m >= n (with spaces) which is the proposition that m is at least n. 95 | By "proposition", I mean "type with at most one inhabitant", where 96 | we care more about whether there is an inhabitant or not than which 97 | one (because there's never a choice). Finished code does not show 98 | us the types of its components, and that's not always a good thing. 99 | Here, by picking nice names, we get something of an aide-memoire. -} 100 | 101 | -- What does (x ,-_) mean? 102 | {- It's a "left section". Right sections (_,- xs) also exist sometimes. 103 | Why only sometimes? -} 104 | 105 | -- "Why is it stuck?" 106 | {- Proof by induction isn't just flailing about, you know? The trick is 107 | to pick the case analysis that provokes the "stuck" programs to do a 108 | step of computation. Then the same reasoning that justifies the 109 | termination of the program will justify the induction in a proof 110 | about it. -} 111 | 112 | -------------------------------------------------------------------------------- /lectures/Lec2Start.agda: -------------------------------------------------------------------------------- 1 | module Lec2Start where 2 | 3 | open import Lec1Done 4 | 5 | 6 | ------------------------------------------------------------------------------ 7 | -- Vectors -- the star of exercise 1 8 | ------------------------------------------------------------------------------ 9 | 10 | data Vec (X : Set) : Nat -> Set where -- like lists, but length-indexed 11 | [] : Vec X zero 12 | _,-_ : {n : Nat} -> X -> Vec X n -> Vec X (suc n) 13 | infixr 4 _,-_ -- the "cons" operator associates to the right 14 | 15 | 16 | ------------------------------------------------------------------------------ 17 | -- Taking a Prefix of a Vector 18 | ------------------------------------------------------------------------------ 19 | 20 | {-+} 21 | vTake : (m n : Nat) -> m >= n -> {X : Set} -> Vec X m -> Vec X n 22 | vTake m n m>=n xs = {!!} 23 | {+-} 24 | 25 | ------------------------------------------------------------------------------ 26 | -- Things to Prove 27 | ------------------------------------------------------------------------------ 28 | 29 | {-+} 30 | vTakeIdFact : (n : Nat){X : Set}(xs : Vec X n) -> 31 | vTake n n (refl->= n) xs == xs 32 | vTakeIdFact n xs = {!!} 33 | 34 | vTakeCpFact : (m n p : Nat)(m>=n : m >= n)(n>=p : n >= p) 35 | {X : Set}(xs : Vec X m) -> 36 | vTake m p (trans->= m n p m>=n n>=p) xs == 37 | vTake n p n>=p (vTake m n m>=n xs) 38 | {- hit p first: why? -} 39 | vTakeCpFact m n p m>=n n>=p xs = {!!} 40 | {+-} 41 | 42 | ------------------------------------------------------------------------------ 43 | -- Splittings (which bear some relationship to <= from ex1) 44 | ------------------------------------------------------------------------------ 45 | 46 | data _<[_]>_ : Nat -> Nat -> Nat -> Set where 47 | zzz : zero <[ zero ]> zero 48 | lll : {l m r : Nat} -> l <[ m ]> r 49 | -> suc l <[ suc m ]> r 50 | rrr : {l m r : Nat} -> l <[ m ]> r 51 | -> l <[ suc m ]> suc r 52 | 53 | {-+} 54 | _>[_]<_ : {X : Set}{l m r : Nat} -> 55 | Vec X l -> l <[ m ]> r -> Vec X r -> 56 | Vec X m 57 | xl >[ nnn ]< xr = {!!} 58 | {+-} 59 | 60 | {-+} 61 | data FindSplit {X : Set}{l m r : Nat}(nnn : l <[ m ]> r) 62 | : (xs : Vec X m) -> Set where 63 | splitBits : (xl : Vec X l)(xr : Vec X r) -> FindSplit nnn (xl >[ nnn ]< xr) 64 | {+-} 65 | 66 | {-+} 67 | findSplit : {X : Set}{l m r : Nat}(nnn : l <[ m ]> r)(xs : Vec X m) -> 68 | FindSplit nnn xs 69 | findSplit nnn xs = {!!} 70 | {+-} 71 | 72 | 73 | ------------------------------------------------------------------------------ 74 | -- what I should remember to say 75 | ------------------------------------------------------------------------------ 76 | 77 | -- What's the difference between m>=n and m >= n ? 78 | {- m>=n (without spaces) is just an identifier; it could be anything, 79 | but it has been chosen to be suggestive of its *type* which is 80 | m >= n (with spaces) which is the proposition that m is at least n. 81 | By "proposition", I mean "type with at most one inhabitant", where 82 | we care more about whether there is an inhabitant or not than which 83 | one (because there's never a choice). Finished code does not show 84 | us the types of its components, and that's not always a good thing. 85 | Here, by picking nice names, we get something of an aide-memoire. -} 86 | 87 | -- What does (x ,-_) mean? 88 | {- It's a "left section". Right sections (_,- xs) also exist sometimes. 89 | Why only sometimes? -} 90 | 91 | -- "Why is it stuck?" 92 | {- Proof by induction isn't just flailing about, you know? The trick is 93 | to pick the case analysis that provokes the "stuck" programs to do a 94 | step of computation. Then the same reasoning that justifies the 95 | termination of the program will justify the induction in a proof 96 | about it. -} 97 | 98 | -------------------------------------------------------------------------------- /lectures/Lec3.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} -- yes, there will be some cheating in this lecture 2 | 3 | module Lec3 where 4 | 5 | open import Lec1Done 6 | open import Lec2Done 7 | 8 | postulate 9 | extensionality : {S : Set}{T : S -> Set} 10 | {f g : (x : S) -> T x} -> 11 | ((x : S) -> f x == g x) -> 12 | f == g 13 | 14 | record Category : Set where 15 | field 16 | 17 | -- two types of thing 18 | Obj : Set -- "objects" 19 | _~>_ : Obj -> Obj -> Set -- "arrows" or "morphisms" 20 | -- or "homomorphisms" 21 | 22 | -- two operations 23 | id~> : {T : Obj} -> T ~> T 24 | _>~>_ : {R S T : Obj} -> R ~> S -> S ~> T -> R ~> T 25 | 26 | -- three laws 27 | law-id~>>~> : {S T : Obj} (f : S ~> T) -> 28 | (id~> >~> f) == f 29 | law->~>id~> : {S T : Obj} (f : S ~> T) -> 30 | (f >~> id~>) == f 31 | law->~>>~> : {Q R S T : Obj} (f : Q ~> R)(g : R ~> S)(h : S ~> T) -> 32 | ((f >~> g) >~> h) == (f >~> (g >~> h)) 33 | 34 | -- Sets and functions are the classic example of a category. 35 | {-(-} 36 | SET : Category 37 | SET = record 38 | { Obj = Set 39 | ; _~>_ = \ S T -> S -> T 40 | ; id~> = id 41 | ; _>~>_ = _>>_ 42 | ; law-id~>>~> = \ f -> refl f 43 | ; law->~>id~> = \ f -> refl f 44 | ; law->~>>~> = \ f g h -> refl (\ x -> h (g (f x))) 45 | } 46 | {-)-} 47 | 48 | unique->= : (m n : Nat)(p q : m >= n) -> p == q 49 | unique->= m zero p q = refl <> 50 | unique->= zero (suc n) () () 51 | unique->= (suc m) (suc n) p q = unique->= m n p q 52 | 53 | -- A PREORDER is a category where there is at most one arrow between 54 | -- any two objects. (So arrows are unique.) 55 | {-(-} 56 | NAT->= : Category 57 | NAT->= = record 58 | { Obj = Nat 59 | ; _~>_ = _>=_ 60 | ; id~> = \ {n} -> refl->= n 61 | ; _>~>_ = \ {m}{n}{p} m>=n n>=p -> trans->= m n p m>=n n>=p 62 | ; law-id~>>~> = \ {S} {T} f -> unique->= S T (trans->= S S T (refl->= S) f) f 63 | ; law->~>id~> = \ {S} {T} f -> unique->= S T (trans->= S T T f (refl->= T)) f 64 | ; law->~>>~> = \ {Q} {R} {S} {T} f g h -> 65 | unique->= Q T _ _ {-(trans->= Q S T (trans->= Q R S f g) h) 66 | (trans->= Q R T f (trans->= R S T g h)) -} 67 | } where 68 | {-)-} 69 | 70 | -- A MONOID is a category with Obj = One. 71 | -- The values in the monoid are the *arrows*. 72 | {-(-} 73 | ONE-Nat : Category 74 | ONE-Nat = record 75 | { Obj = One 76 | ; _~>_ = \ _ _ -> Nat 77 | ; id~> = zero 78 | ; _>~>_ = _+N_ 79 | ; law-id~>>~> = zero-+N 80 | ; law->~>id~> = +N-zero 81 | ; law->~>>~> = assocLR-+N 82 | } 83 | {-)-} 84 | 85 | {-(-} 86 | eqUnique : {X : Set}{x y : X}{p q : x == y} -> p == q 87 | eqUnique {p = refl x} {q = refl .x} = refl (refl x) 88 | 89 | -- A DISCRETE category is one where the only arrows are the identities. 90 | DISCRETE : (X : Set) -> Category 91 | DISCRETE X = record 92 | { Obj = X 93 | ; _~>_ = _==_ 94 | ; id~> = \ {x} -> refl x 95 | ; _>~>_ = \ { (refl x) (refl .x) -> refl x } 96 | ; law-id~>>~> = \ {S} {T} f -> 97 | eqUnique 98 | ; law->~>id~> = \ {S} {T} f -> 99 | eqUnique 100 | ; law->~>>~> = \ {Q} {R} {S} {T} f g h -> eqUnique 101 | } 102 | {-)-} 103 | 104 | 105 | 106 | module FUNCTOR where 107 | open Category 108 | 109 | record _=>_ (C D : Category) : Set where -- "Functor from C to D" 110 | field 111 | -- two actions 112 | F-Obj : Obj C -> Obj D 113 | F-map : {S T : Obj C} -> _~>_ C S T -> _~>_ D (F-Obj S) (F-Obj T) 114 | 115 | -- two laws 116 | F-map-id~> : {T : Obj C} -> F-map (id~> C {T}) == id~> D {F-Obj T} 117 | F-map->~> : {R S T : Obj C}(f : _~>_ C R S)(g : _~>_ C S T) -> 118 | F-map (_>~>_ C f g) == _>~>_ D (F-map f) (F-map g) 119 | 120 | open FUNCTOR 121 | 122 | module FOO (C : Category) where 123 | open Category C 124 | X : Set 125 | X = Obj 126 | 127 | 128 | postulate vmap : {n : Nat}{S T : Set} → (S → T) → Vec S n → Vec T n 129 | 130 | {-+} 131 | VEC : Nat -> SET => SET 132 | VEC n = record { F-Obj = \ X -> Vec X n 133 | ; F-map = vmap 134 | ; F-map-id~> = extensionality {!!} 135 | ; F-map->~> = {!!} 136 | } 137 | {+-} 138 | 139 | {-(-} 140 | VTAKE : Set -> NAT->= => SET 141 | VTAKE X = record { F-Obj = Vec X 142 | ; F-map = \ {m}{n} m>=n xs -> vTake m n m>=n xs 143 | ; F-map-id~> = \ {n} -> extensionality (vTakeIdFact n) 144 | ; F-map->~> = \ {m}{n}{p} m>=n n>=p -> 145 | extensionality (vTakeCpFact m n p m>=n n>=p) 146 | } 147 | {-)-} 148 | 149 | {-(-} 150 | ADD : Nat -> NAT->= => NAT->= 151 | ADD d = record { F-Obj = (d +N_) -- \ x -> d +N x 152 | ; F-map = \ {m}{n} -> help d m n 153 | ; F-map-id~> = \ {T} -> 154 | unique->= (d +N T) (d +N T) (help d T T (refl->= T)) 155 | (refl->= (d +N T)) 156 | ; F-map->~> = \ {R} {S} {T} f g -> 157 | unique->= (d +N R) (d +N T) (help d R T (trans->= R S T f g)) 158 | (trans->= (d +N R) (d +N S) (d +N T) (help d R S f) (help d S T g)) 159 | } where 160 | help : forall d m n -> m >= n -> (d +N m) >= (d +N n) 161 | help zero m n m>=n = m>=n 162 | help (suc d) m n m>=n = help d m n m>=n 163 | {-)-} 164 | 165 | {-(-} 166 | CATEGORY : Category 167 | CATEGORY = record 168 | { Obj = Category 169 | ; _~>_ = _=>_ 170 | ; id~> = record 171 | { F-Obj = id 172 | ; F-map = id 173 | ; F-map-id~> = {!!} 174 | ; F-map->~> = {!!} 175 | } 176 | ; _>~>_ = \ F G -> record 177 | { F-Obj = F-Obj F >> F-Obj G 178 | ; F-map = F-map F >> F-map G 179 | ; F-map-id~> = {!!} 180 | ; F-map->~> = {!!} 181 | } 182 | ; law-id~>>~> = {!!} 183 | ; law->~>id~> = {!!} 184 | ; law->~>>~> = {!!} 185 | } where open _=>_ 186 | {-)-} 187 | -------------------------------------------------------------------------------- /lectures/Lec3Done.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} -- yes, there will be some cheating in this lecture 2 | 3 | module Lec3Done where 4 | 5 | open import Lec1Done 6 | open import Lec2Done 7 | 8 | postulate 9 | extensionality : {S : Set}{T : S -> Set} 10 | {f g : (x : S) -> T x} -> 11 | ((x : S) -> f x == g x) -> 12 | f == g 13 | 14 | imp : {S : Set}{T : S -> Set}(f : (x : S) -> T x){x : S} -> T x 15 | imp f {x} = f x 16 | 17 | extensionality' : {S : Set}{T : S -> Set} 18 | {f g : {x : S} -> T x} -> 19 | ((x : S) -> f {x} == g {x}) -> 20 | _==_ {forall {x : S} -> T x} f g 21 | extensionality' {f = f}{g = g} q = 22 | refl imp =$= extensionality {f = \ x -> f {x}}{g = \ x -> g {x}} 23 | q 24 | 25 | _[QED] : {X : Set}(x : X) -> x == x 26 | x [QED] = refl x 27 | _=[_>=_ : {X : Set}(x : X){y z : X} -> x == y -> y == z -> x == z 28 | x =[ refl .x >= q = q 29 | _=<_]=_ : {X : Set}(x : X){y z : X} -> y == x -> y == z -> x == z 30 | x =< refl .x ]= q = q 31 | infixr 1 _=[_>=_ _=<_]=_ 32 | infixr 2 _[QED] 33 | 34 | record Category : Set where 35 | field 36 | 37 | -- two types of thing 38 | Obj : Set -- "objects" 39 | _~>_ : Obj -> Obj -> Set -- "arrows" or "morphisms" 40 | -- or "homomorphisms" 41 | 42 | -- two operations 43 | id~> : {T : Obj} -> T ~> T 44 | _>~>_ : {R S T : Obj} -> R ~> S -> S ~> T -> R ~> T 45 | 46 | -- three laws 47 | law-id~>>~> : {S T : Obj} (f : S ~> T) -> 48 | (id~> >~> f) == f 49 | law->~>id~> : {S T : Obj} (f : S ~> T) -> 50 | (f >~> id~>) == f 51 | law->~>>~> : {Q R S T : Obj} (f : Q ~> R)(g : R ~> S)(h : S ~> T) -> 52 | ((f >~> g) >~> h) == (f >~> (g >~> h)) 53 | 54 | assocn : {Q R R' S T : Obj} 55 | {f : Q ~> R} {g : R ~> S} 56 | {f' : Q ~> R'}{g' : R' ~> S} 57 | {h : S ~> T} -> 58 | (f >~> g) == (f' >~> g') -> 59 | (f >~> g >~> h) == (f' >~> g' >~> h) 60 | assocn {f = f} {g = g} {f' = f'} {g' = g'} {h = h} q = 61 | f >~> g >~> h 62 | =< law->~>>~> _ _ _ ]= 63 | (f >~> g) >~> h 64 | =[ refl _>~>_ =$= q =$= refl h >= 65 | (f' >~> g') >~> h 66 | =[ law->~>>~> _ _ _ >= 67 | f' >~> g' >~> h 68 | [QED] 69 | 70 | infixr 3 _>~>_ 71 | 72 | -- Sets and functions are the classic example of a category. 73 | SET : Category 74 | SET = record 75 | { Obj = Set 76 | ; _~>_ = \ S T -> S -> T 77 | ; id~> = id 78 | ; _>~>_ = _>>_ 79 | ; law-id~>>~> = \ f -> refl f 80 | ; law->~>id~> = \ f -> refl f 81 | ; law->~>>~> = \ f g h -> refl (f >> (g >> h)) 82 | } 83 | 84 | -- A PREORDER is a category where there is at most one arrow between 85 | -- any two objects. (So arrows are unique.) 86 | NAT->= : Category 87 | unique->= : (m n : Nat)(p q : m >= n) -> p == q 88 | unique->= m zero p q = refl <> 89 | unique->= zero (suc n) () q 90 | unique->= (suc m) (suc n) p q = unique->= m n p q 91 | 92 | NAT->= = record 93 | { Obj = Nat 94 | ; _~>_ = _>=_ 95 | ; id~> = \ {n} -> refl->= n 96 | ; _>~>_ = \ {m}{n}{p} m>=n n>=p -> trans->= m n p m>=n n>=p 97 | ; law-id~>>~> = \ {m}{n} m>=n -> unique->= m n _ _ 98 | ; law->~>id~> = \ {m}{n} m>=n -> unique->= m n _ _ 99 | ; law->~>>~> = \ {m}{n}{p}{q} m>n n>=p p>=q -> unique->= m q _ _ 100 | } where 101 | 102 | -- A MONOID is a category with Obj = One. 103 | -- The values in the monoid are the *arrows*. 104 | ONE-Nat : Category 105 | ONE-Nat = record 106 | { Obj = One 107 | ; _~>_ = \ _ _ -> Nat 108 | ; id~> = 0 109 | ; _>~>_ = _+N_ 110 | ; law-id~>>~> = \ n -> zero-+N n 111 | ; law->~>id~> = \ n -> +N-zero n 112 | ; law->~>>~> = \ m n p -> assocLR-+N m n p 113 | } 114 | 115 | eqUnique : {X : Set}{x y : X}(p q : x == y) -> p == q 116 | eqUnique (refl x) (refl .x) = refl (refl x) 117 | 118 | -- A DISCRETE category is one where the only arrows are the identities. 119 | DISCRETE : (X : Set) -> Category 120 | DISCRETE X = record 121 | { Obj = X 122 | ; _~>_ = _==_ 123 | ; id~> = refl _ 124 | ; _>~>_ = \ { {x} (refl .x) (refl .x) -> refl x } 125 | ; law-id~>>~> = \ _ -> eqUnique _ _ 126 | ; law->~>id~> = \ _ -> eqUnique _ _ 127 | ; law->~>>~> = \ _ _ _ -> eqUnique _ _ 128 | } 129 | 130 | module FUNCTOR where 131 | open Category 132 | 133 | record _=>_ (C D : Category) : Set where -- "Functor from C to D" 134 | field 135 | -- two actions 136 | F-Obj : Obj C -> Obj D 137 | F-map : {S T : Obj C} -> _~>_ C S T -> _~>_ D (F-Obj S) (F-Obj T) 138 | 139 | -- two laws 140 | F-map-id~> : {T : Obj C} -> F-map (id~> C {T}) == id~> D {F-Obj T} 141 | F-map->~> : {R S T : Obj C}(f : _~>_ C R S)(g : _~>_ C S T) -> 142 | F-map (_>~>_ C f g) == _>~>_ D (F-map f) (F-map g) 143 | 144 | open FUNCTOR public 145 | 146 | postulate homework : {A : Set} -> A 147 | 148 | VEC : Nat -> SET => SET 149 | VEC n = record 150 | { F-Obj = \ X -> Vec X n 151 | ; F-map = homework 152 | ; F-map-id~> = homework 153 | ; F-map->~> = homework 154 | } 155 | 156 | VTAKE : Set -> NAT->= => SET 157 | VTAKE X = record 158 | { F-Obj = Vec X 159 | ; F-map = \ {m}{n} m>=n xs -> vTake m n m>=n xs 160 | ; F-map-id~> = \ {n} -> extensionality \ xs -> vTakeIdFact n xs 161 | ; F-map->~> = \ {m}{n}{p} m>=n n>=p -> extensionality \ xs -> 162 | vTakeCpFact m n p m>=n n>=p xs 163 | } 164 | 165 | ADD : Nat -> NAT->= => NAT->= 166 | ADD d = record { F-Obj = (d +N_) 167 | ; F-map = \ {m}{n} -> help d m n 168 | ; F-map-id~> = \ {n} -> unique->= (d +N n) (d +N n) _ _ 169 | ; F-map->~> = \ {m}{n}{p} x y -> 170 | unique->= (d +N m) (d +N p) _ _ 171 | } where 172 | help : (d m n : Nat) -> m >= n -> (d +N m) >= (d +N n) 173 | help zero m n m>=n = m>=n 174 | help (suc d) m n m>=n = help d m n m>=n 175 | 176 | Thing : {C D : Category}(F G : C => D) -> Set 177 | Thing {C}{D} 178 | (record { F-Obj = F-Obj ; F-map = F-map 179 | ; F-map-id~> = F-map-id~> ; F-map->~> = F-map->~> }) 180 | (record { F-Obj = G-Obj ; F-map = G-map 181 | ; F-map-id~> = G-map-id~> ; F-map->~> = G-map->~> }) 182 | = Sg (F-Obj == G-Obj) 183 | \ { (refl _) -> 184 | Sg (_==_ {forall {S T : Category.Obj C} → 185 | (C Category.~> S) T → (D Category.~> F-Obj S) (F-Obj T)} 186 | F-map G-map) 187 | \ { (refl _) -> 188 | _==_ {forall {T : Category.Obj C} → 189 | F-map (Category.id~> C {T}) == Category.id~> D} F-map-id~> G-map-id~> 190 | * 191 | _==_ {forall {R S T : Category.Obj C} (f : (C Category.~> R) S) 192 | (g : (C Category.~> S) T) → 193 | F-map ((C Category.>~> f) g) == (D Category.>~> F-map f) (F-map g)} 194 | F-map->~> G-map->~> 195 | }} 196 | 197 | Lemma : {C D : Category}{F G : C => D} -> Thing F G -> F == G 198 | Lemma (refl _ , (refl _ , (refl _ , refl _))) = refl _ 199 | 200 | 201 | CATEGORY : Category 202 | CATEGORY = record 203 | { Obj = Category 204 | ; _~>_ = _=>_ 205 | ; id~> = record { F-Obj = \ X -> X 206 | ; F-map = \ a -> a 207 | ; F-map-id~> = refl _ 208 | ; F-map->~> = \ _ _ -> refl _ } 209 | ; _>~>_ = \ {R}{S}{T} F G -> record 210 | { F-Obj = F-Obj F >> F-Obj G 211 | ; F-map = F-map F >> F-map G 212 | ; F-map-id~> = F-map G (F-map F (Category.id~> R)) 213 | =[ refl (F-map G) =$= F-map-id~> F >= 214 | F-map G (Category.id~> S) 215 | =[ F-map-id~> G >= 216 | Category.id~> T 217 | [QED] 218 | ; F-map->~> = \ f g -> 219 | F-map G (F-map F (Category._>~>_ R f g)) 220 | =[ refl (F-map G) =$= F-map->~> F f g >= 221 | F-map G (Category._>~>_ S (F-map F f) (F-map F g)) 222 | =[ F-map->~> G (F-map F f) (F-map F g) >= 223 | Category._>~>_ T (F-map G (F-map F f)) 224 | (F-map G (F-map F g)) 225 | [QED] 226 | } 227 | ; law-id~>>~> = \ F -> Lemma 228 | ((refl _) , ((refl _) , 229 | (extensionality' (\ x -> eqUnique _ _) , 230 | extensionality' (\ x -> 231 | extensionality' \ y -> extensionality' \ z -> 232 | extensionality \ f -> extensionality \ g -> 233 | eqUnique _ _)))) 234 | ; law->~>id~> = \ F -> Lemma 235 | ((refl _) , ((refl _) , 236 | (extensionality' (\ x -> eqUnique _ _) , 237 | extensionality' (\ x -> 238 | extensionality' \ y -> extensionality' \ z -> 239 | extensionality \ f -> extensionality \ g -> 240 | eqUnique _ _)))) 241 | ; law->~>>~> = \ F G H -> Lemma 242 | ((refl _) , ((refl _) , 243 | (extensionality' (\ x -> eqUnique _ _) , 244 | extensionality' (\ x -> 245 | extensionality' \ y -> extensionality' \ z -> 246 | extensionality \ f -> extensionality \ g -> 247 | eqUnique _ _)))) 248 | } where 249 | open _=>_ 250 | 251 | -------------------------------------------------------------------------------- /lectures/Lec3Start.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} -- yes, there will be some cheating in this lecture 2 | 3 | module Lec3Start where 4 | 5 | open import Lec1Done 6 | open import Lec2Done 7 | 8 | postulate 9 | extensionality : {S : Set}{T : S -> Set} 10 | (f g : (x : S) -> T x) -> 11 | ((x : S) -> f x == g x) -> 12 | f == g 13 | 14 | record Category : Set where 15 | field 16 | 17 | -- two types of thing 18 | Obj : Set -- "objects" 19 | _~>_ : Obj -> Obj -> Set -- "arrows" or "morphisms" 20 | -- or "homomorphisms" 21 | 22 | -- two operations 23 | id~> : {T : Obj} -> T ~> T 24 | _>~>_ : {R S T : Obj} -> R ~> S -> S ~> T -> R ~> T 25 | 26 | -- three laws 27 | law-id~>>~> : {S T : Obj} (f : S ~> T) -> 28 | (id~> >~> f) == f 29 | law->~>id~> : {S T : Obj} (f : S ~> T) -> 30 | (f >~> id~>) == f 31 | law->~>>~> : {Q R S T : Obj} (f : Q ~> R)(g : R ~> S)(h : S ~> T) -> 32 | ((f >~> g) >~> h) == (f >~> (g >~> h)) 33 | 34 | -- Sets and functions are the classic example of a category. 35 | {-+} 36 | SET : Category 37 | SET = {!!} 38 | {+-} 39 | 40 | -- A PREORDER is a category where there is at most one arrow between 41 | -- any two objects. (So arrows are unique.) 42 | {-+} 43 | NAT->= : Category 44 | NAT->= = {!!} where 45 | unique : (m n : Nat)(p q : m >= n) -> p == q 46 | unique m n p q = {!!} 47 | {+-} 48 | 49 | -- A MONOID is a category with Obj = One. 50 | -- The values in the monoid are the *arrows*. 51 | {-+} 52 | ONE-Nat : Category 53 | ONE-Nat = {!!} 54 | {+-} 55 | 56 | {-+} 57 | eqUnique : {X : Set}{x y : X}(p q : x == y) -> p == q 58 | eqUnique p q = {!!} 59 | 60 | -- A DISCRETE category is one where the only arrows are the identities. 61 | DISCRETE : (X : Set) -> Category 62 | DISCRETE X = {!!} 63 | {+-} 64 | 65 | 66 | 67 | module FUNCTOR where 68 | open Category 69 | 70 | record _=>_ (C D : Category) : Set where -- "Functor from C to D" 71 | field 72 | -- two actions 73 | F-Obj : Obj C -> Obj D 74 | F-map : {S T : Obj C} -> _~>_ C S T -> _~>_ D (F-Obj S) (F-Obj T) 75 | 76 | -- two laws 77 | F-map-id~> : {T : Obj C} -> F-map (id~> C {T}) == id~> D {F-Obj T} 78 | F-map->~> : {R S T : Obj C}(f : _~>_ C R S)(g : _~>_ C S T) -> 79 | F-map (_>~>_ C f g) == _>~>_ D (F-map f) (F-map g) 80 | 81 | open FUNCTOR 82 | 83 | {-+} 84 | VEC : Nat -> SET => SET 85 | VEC n = {!!} 86 | {+-} 87 | 88 | {-+} 89 | VTAKE : Set -> NAT->= => SET 90 | VTAKE X = {!!} 91 | {+-} 92 | 93 | {-+} 94 | ADD : Nat -> NAT->= => NAT->= 95 | ADD d = {!!} 96 | {+-} 97 | 98 | {-+} 99 | CATEGORY : Category 100 | CATEGORY = {!!} 101 | {+-} 102 | -------------------------------------------------------------------------------- /lectures/Lec4.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} -- yes, there will be some cheating in this lecture 2 | 3 | module Lec4 where 4 | 5 | open import Lec1Done 6 | open import Lec2Done 7 | open import Lec3Done 8 | 9 | -- the identity functor (the identity action on objects and arrows) 10 | ID : {C : Category} -> C => C 11 | ID = id~> where open Category CATEGORY 12 | 13 | -- composition of functors (composition of actions on objects and arrows) 14 | _>F>_ : {C D E : Category} -> (C => D) -> (D => E) -> (C => E) 15 | F >F> G = F >~> G where open Category CATEGORY 16 | 17 | -- EXAMPLES 18 | 19 | data Maybe (X : Set) : Set where 20 | yes : (x : X) -> Maybe X 21 | no : Maybe X 22 | {-# COMPILE GHC Maybe = data Maybe (Just | Nothing) #-} 23 | 24 | maybe : {X Y : Set} -> (X -> Y) -> Maybe X -> Maybe Y 25 | maybe f (yes x) = yes (f x) 26 | maybe f no = no 27 | 28 | MAYBE : SET => SET 29 | MAYBE = record 30 | { F-Obj = Maybe 31 | ; F-map = maybe 32 | ; F-map-id~> = extensionality \ { (yes x) -> refl (yes x) ; no -> refl no } 33 | -- extensionality \ { (yes x) -> refl (yes x) ; no -> refl no } 34 | ; F-map->~> = \ f g -> extensionality \ { (yes x) -> refl (yes (g (f x))) ; no -> refl no } 35 | } 36 | 37 | module MAYBE-CAT where 38 | open Category SET 39 | open _=>_ MAYBE 40 | 41 | {- 42 | unMaybe : {T : Set} -> Maybe T -> T 43 | unMaybe (yes t) = t 44 | unMaybe no = {!!} 45 | -} 46 | 47 | joinMaybe : {T : Set} -> Maybe (Maybe T) -> Maybe T 48 | joinMaybe (yes mt) = mt 49 | joinMaybe no = no 50 | 51 | MAYBE-CAT : Category 52 | MAYBE-CAT = record 53 | { Obj = Set 54 | ; _~>_ = \ S T -> S -> Maybe T 55 | ; id~> = yes 56 | ; _>~>_ = \ f g -> f >> (F-map g >> joinMaybe) 57 | ; law-id~>>~> = \ f -> refl f 58 | ; law->~>id~> = \ f -> extensionality \ x -> help f x 59 | ; law->~>>~> = \ f g h -> extensionality \ x -> yelp f g h x 60 | } where 61 | help : forall {S T} (f : S -> Maybe T) 62 | (x : S) -> 63 | joinMaybe (maybe yes (f x)) == f x 64 | help f x with f x 65 | help f x | yes y = refl (yes y) 66 | help f x | no = refl no 67 | yelp : forall {Q R S T} 68 | (f : Q -> Maybe R) (g : R -> Maybe S)(h : S -> Maybe T) 69 | (x : Q) -> 70 | joinMaybe (maybe h (joinMaybe (maybe g (f x)))) == 71 | joinMaybe 72 | (maybe (\ y → joinMaybe (maybe h (g y))) (f x)) 73 | yelp f g h x with f x 74 | yelp f g h x | yes y = refl (joinMaybe (maybe h (g y))) 75 | yelp f g h x | no = refl no 76 | 77 | open MAYBE-CAT 78 | 79 | module NATURAL-TRANSFORMATION {C D : Category} where 80 | open Category 81 | open _=>_ 82 | 83 | record _~~>_ (F G : C => D) : Set where 84 | field 85 | -- one operation 86 | xf : {X : Obj C} -> _~>_ D (F-Obj F X) (F-Obj G X) 87 | -- one law 88 | naturality : {X Y : Obj C}(f : _~>_ C X Y) -> 89 | _>~>_ D (F-map F f) (xf {Y}) 90 | == 91 | _>~>_ D (xf {X}) (F-map G f) 92 | 93 | module FUNCTOR-CP {C D E : Category} where 94 | open _=>_ 95 | open Category 96 | 97 | _>=>_ : C => D -> D => E -> C => E 98 | 99 | F-Obj (F >=> G) = F-Obj F >> F-Obj G 100 | 101 | F-map (F >=> G) = F-map F >> F-map G 102 | 103 | F-map-id~> (F >=> G) = 104 | F-map G (F-map F (id~> C)) 105 | =[ refl (F-map G) =$= F-map-id~> F >= 106 | F-map G (id~> D) 107 | =[ F-map-id~> G >= 108 | id~> E 109 | [QED] 110 | 111 | F-map->~> (F >=> G) f g = 112 | F-map G (F-map F (_>~>_ C f g)) 113 | =[ refl (F-map G) =$= F-map->~> F f g >= 114 | F-map G (_>~>_ D (F-map F f) (F-map F g)) 115 | =[ F-map->~> G (F-map F f) (F-map F g) >= 116 | _>~>_ E (F-map G (F-map F f)) (F-map G (F-map F g)) 117 | [QED] 118 | 119 | open FUNCTOR-CP 120 | 121 | open NATURAL-TRANSFORMATION public 122 | open _~~>_ public 123 | 124 | UNIT-MAYBE : ID ~~> MAYBE 125 | xf UNIT-MAYBE = yes 126 | naturality UNIT-MAYBE f = refl _ 127 | 128 | MULT-MAYBE : (MAYBE >=> MAYBE) ~~> MAYBE 129 | MULT-MAYBE = record { xf = joinMaybe 130 | ; naturality = \ f -> extensionality \ { 131 | (yes x) → refl (maybe f x) 132 | ; no → refl no } } 133 | 134 | 135 | module MONAD {C : Category}(M : C => C) where 136 | open Category C 137 | open _=>_ M 138 | 139 | record Monad : Set where 140 | field 141 | unit : ID ~~> M 142 | mult : (M >=> M) ~~> M 143 | 144 | unitMult : {X : Obj} -> (xf unit >~> xf mult) == id~> {F-Obj X} 145 | multUnit : {X : Obj} -> (F-map (xf unit) >~> xf mult) == id~> {F-Obj X} 146 | multMult : {X : Obj} -> (xf mult >~> xf mult) == (F-map (xf mult) >~> xf mult {X}) 147 | 148 | KLEISLI : Category 149 | KLEISLI = record 150 | { Obj = Obj 151 | ; _~>_ = \ S T -> S ~> F-Obj T 152 | 153 | ; id~> = xf unit 154 | ; _>~>_ = \ f g -> f >~> F-map g >~> xf mult 155 | 156 | ; law-id~>>~> = \ f -> 157 | xf unit >~> F-map f >~> xf mult 158 | =< law->~>>~> _ _ _ ]= 159 | (xf unit >~> F-map f) >~> xf mult 160 | =< refl (_>~> xf mult) =$= naturality unit f ]= 161 | (f >~> xf unit) >~> xf mult 162 | =[ law->~>>~> _ _ _ >= 163 | f >~> (xf unit >~> xf mult) 164 | 165 | =[ refl (f >~>_) =$= unitMult >= 166 | 167 | f >~> id~> 168 | =[ law->~>id~> f >= 169 | f [QED] 170 | 171 | ; law->~>id~> = \ f -> 172 | f >~> (F-map (xf unit) >~> xf mult) 173 | 174 | =[ refl (f >~>_) =$= multUnit >= 175 | 176 | f >~> id~> 177 | =[ law->~>id~> f >= 178 | f [QED] 179 | 180 | ; law->~>>~> = \ f g h -> 181 | (f >~> F-map g >~> xf mult) >~> F-map h >~> xf mult 182 | =[ law->~>>~> _ _ _ >= 183 | f >~> (F-map g >~> xf mult) >~> (F-map h >~> xf mult) 184 | =[ refl (\ x -> _ >~> x) =$= law->~>>~> _ _ _ >= 185 | f >~> F-map g >~> xf mult >~> F-map h >~> xf mult 186 | =< refl (\ x -> _ >~> _ >~> x) =$= assocn (naturality mult _) ]= 187 | f >~> F-map g >~> F-map (F-map h) >~> xf mult >~> xf mult 188 | 189 | =[ refl (\ x -> _ >~> _ >~> _ >~> x) =$= multMult >= 190 | 191 | f >~> F-map g >~> F-map (F-map h) >~> F-map (xf mult) >~> xf mult 192 | =< refl (\ x -> _ >~> _ >~> x) =$= law->~>>~> _ _ _ ]= 193 | f >~> F-map g >~> (F-map (F-map h) >~> F-map (xf mult)) >~> xf mult 194 | =< refl (\ x -> _ >~> _ >~> x >~> _) =$= F-map->~> _ _ ]= 195 | f >~> F-map g >~> F-map (F-map h >~> xf mult) >~> xf mult 196 | =< refl (\ x -> _ >~> x) =$= law->~>>~> _ _ _ ]= 197 | f >~> (F-map g >~> F-map (F-map h >~> xf mult)) >~> xf mult 198 | =< refl (\ x -> _ >~> x >~> _) =$= F-map->~> _ _ ]= 199 | f >~> F-map (g >~> F-map h >~> xf mult) >~> xf mult 200 | [QED] 201 | } 202 | 203 | open MONAD public 204 | 205 | MAYBE-Monad : Monad MAYBE 206 | MAYBE-Monad = record 207 | { unit = UNIT-MAYBE 208 | ; mult = MULT-MAYBE 209 | ; unitMult = refl _ 210 | ; multUnit = extensionality \ { (yes x) -> refl _ ; no -> refl _ } 211 | ; multMult = extensionality \ { (yes mmx) -> refl _ ; no -> refl _ } 212 | } 213 | 214 | data List (X : Set) : Set where 215 | [] : List X 216 | _,-_ : (x : X)(xs : List X) -> List X 217 | {-# COMPILE GHC List = data [] ([] | (:)) #-} 218 | 219 | list : {X Y : Set} -> (X -> Y) -> List X -> List Y 220 | list f [] = [] 221 | list f (x ,- xs) = f x ,- list f xs 222 | 223 | LIST : SET => SET 224 | LIST = record 225 | { F-Obj = List 226 | ; F-map = list 227 | ; F-map-id~> = extensionality listId 228 | ; F-map->~> = \ f g -> extensionality (listCp f g) 229 | } where 230 | open Category SET 231 | listId : {T : Set}(xs : List T) -> list id xs == xs 232 | listId [] = refl [] 233 | listId (x ,- xs) = refl (_,-_ x) =$= listId xs 234 | listCp : {R S T : Set} (f : R -> S) (g : S -> T) (xs : List R) → 235 | list (f >~> g) xs == (list f >~> list g) xs 236 | listCp f g [] = refl [] 237 | listCp f g (x ,- xs) = refl (_,-_ (g (f x))) =$= listCp f g xs 238 | 239 | data Two : Set where tt ff : Two 240 | {- BUILTIN BOOL Two -} 241 | {- BUILTIN FALSE ff -} 242 | {- BUILTIN TRUE tt -} 243 | {-# COMPILE GHC Two = data Bool (True | False) #-} 244 | 245 | data BitProcess (X : Set) : Set where -- in what way is X used? 246 | stop : (x : X) -> BitProcess X -- stop with value x 247 | send : (b : Two)(k : BitProcess X) -> BitProcess X -- send b, continue as k 248 | recv : (kt kf : BitProcess X) -> BitProcess X -- receive bit, continue as 249 | -- kt if tt, kf if ff 250 | 251 | {-(-} 252 | send1 : (b : Two) -> BitProcess One 253 | send1 b = send b (stop <>) 254 | {-)-} 255 | 256 | {-(-} 257 | recv1 : BitProcess Two 258 | recv1 = recv (stop tt) (stop ff) 259 | {-)-} 260 | 261 | {-(-} 262 | bpRun : forall {X} -> BitProcess X -- a process to run 263 | -> List Two -- a list of bits waiting to be input 264 | -> List Two -- the list of bits output 265 | * Maybe -- and, if we don't run out of input 266 | ( X -- the resulting value 267 | * List Two -- and the unused input 268 | ) 269 | bpRun (stop x) bs = [] , yes (x , bs) 270 | bpRun (send b px) bs = let os , mz = bpRun px bs in (b ,- os) , mz 271 | bpRun (recv pxt pxf) [] = [] , no 272 | bpRun (recv pxt pxf) (tt ,- bs) = bpRun pxt bs 273 | bpRun (recv pxt pxf) (ff ,- bs) = bpRun pxf bs 274 | {-)-} 275 | 276 | example = bpRun recv1 (tt ,- []) 277 | 278 | bitProcess : {X Y : Set} -> (X -> Y) -> BitProcess X -> BitProcess Y 279 | bitProcess f (stop x) = stop (f x) 280 | bitProcess f (send b k) = send b (bitProcess f k) 281 | bitProcess f (recv kt kf) = recv (bitProcess f kt) (bitProcess f kf) 282 | 283 | BITPROCESS : SET => SET -- actions on *values* lift to processes 284 | BITPROCESS = record 285 | { F-Obj = BitProcess 286 | ; F-map = bitProcess 287 | ; F-map-id~> = extensionality helpId 288 | ; F-map->~> = \ f g -> extensionality (helpCp f g) 289 | } where 290 | open Category SET 291 | helpId : {T : Set} (p : BitProcess T) -> bitProcess id p == p 292 | helpId (stop x) = refl (stop x) 293 | helpId (send b k) rewrite helpId k = refl (send b k) 294 | helpId (recv kt kf) rewrite helpId kt | helpId kf = refl (recv kt kf) 295 | helpCp : {R S T : Set} (f : R -> S)(g : S -> T) (p : BitProcess R) -> 296 | bitProcess (f >~> g) p == (bitProcess f >~> bitProcess g) p 297 | helpCp f g (stop x) = refl (stop (g (f x))) 298 | helpCp f g (send b k) rewrite helpCp f g k = refl (send b (bitProcess g (bitProcess f k))) 299 | helpCp f g (recv kt kf) rewrite helpCp f g kt | helpCp f g kf 300 | = refl (recv (bitProcess g (bitProcess f kt)) (bitProcess g (bitProcess f kf))) 301 | 302 | {-(-} 303 | UNIT-BP : ID ~~> BITPROCESS 304 | UNIT-BP = record { xf = stop 305 | ; naturality = \ f -> refl _ 306 | } 307 | {-)-} 308 | 309 | join-BP : {X : Set} -> BitProcess (BitProcess X) -> BitProcess X 310 | join-BP (stop px) = px 311 | join-BP (send b ppx) = send b (join-BP ppx) 312 | join-BP (recv ppxt ppxf) = recv (join-BP ppxt) (join-BP ppxf) 313 | 314 | {-(-} 315 | MULT-BP : (BITPROCESS >=> BITPROCESS) ~~> BITPROCESS 316 | MULT-BP = record 317 | { xf = join-BP 318 | ; naturality = \ f -> extensionality (help f ) 319 | } where 320 | help : ∀ {X Y} (f : X → Y) (x : BitProcess (BitProcess X)) → 321 | join-BP (bitProcess (bitProcess f) x) == bitProcess f (join-BP x) 322 | help f (stop x) = refl (bitProcess f x) 323 | help f (send b p) rewrite help f p 324 | = refl (send b (bitProcess f (join-BP p))) 325 | help f (recv pt pf) rewrite help f pf | help f pt 326 | = refl (recv (bitProcess f (join-BP pt)) (bitProcess f (join-BP pf))) 327 | {-)-} 328 | 329 | {-(-} 330 | BITPROCESS-Monad : Monad BITPROCESS 331 | BITPROCESS-Monad = record 332 | { unit = UNIT-BP 333 | ; mult = MULT-BP 334 | ; unitMult = refl id 335 | ; multUnit = extensionality help 336 | ; multMult = extensionality yelp 337 | } where 338 | 339 | help : ∀ {X} (x : BitProcess X) → join-BP (bitProcess stop x) == x 340 | help (stop x) = refl (stop x) 341 | help (send b p) rewrite help p = refl (send b p) 342 | help (recv pt pf) rewrite help pt | help pf = refl (recv pt pf) 343 | 344 | yelp : ∀ {X} (x : BitProcess (BitProcess (BitProcess X))) → 345 | join-BP (join-BP x) == join-BP (bitProcess join-BP x) 346 | yelp (stop x) = refl _ 347 | yelp (send b p) rewrite yelp p = refl _ 348 | yelp (recv pt pf) rewrite yelp pt | yelp pf = refl _ 349 | 350 | {-)-} 351 | 352 | module BIND {F : SET => SET}(M : Monad F) where 353 | 354 | open _=>_ F public 355 | open Monad M public 356 | open Category KLEISLI public 357 | 358 | {-(-} 359 | _>>=_ : {S T : Set} -> F-Obj S -> (S -> F-Obj T) -> F-Obj T 360 | fs >>= k = (id >~> k) fs 361 | {-)-} 362 | 363 | open BIND BITPROCESS-Monad 364 | 365 | bpEcho : BitProcess One 366 | bpEcho = recv1 >>= \ b -> 367 | send1 b 368 | 369 | BP-SEM : Set -> Set 370 | BP-SEM X = List Two -- a list of bits waiting to be input 371 | -> List Two -- the list of bits output 372 | * Maybe -- and, if we don't run out of input 373 | ( X -- the resulting value 374 | * List Two -- and the unused input 375 | ) 376 | 377 | record _**_ (S T : Set) : Set where 378 | constructor _,_ 379 | field 380 | outl : S 381 | outr : T 382 | open _**_ 383 | {-# COMPILE GHC _**_ = data (,) ((,)) #-} 384 | infixr 4 _**_ _,_ 385 | 386 | postulate -- Haskell has a monad for doing IO, which we use at the top level 387 | IO : Set -> Set 388 | mainLoop : {S : Set} -> S -> (S -> Two -> (List Two ** Maybe S)) -> IO One 389 | mainOutIn : {S : Set} -> S -> (S -> (List Two ** Maybe (Two -> S))) -> IO One 390 | 391 | {-# BUILTIN IO IO #-} 392 | {-# COMPILE GHC IO = type IO #-} 393 | {-# COMPILE GHC mainLoop = (\ _ -> Lec4HS.mainLoop) #-} 394 | {-# COMPILE GHC mainOutIn = (\ _ -> Lec4HS.mainOutIn) #-} 395 | {-# FOREIGN GHC import qualified Lec4HS #-} 396 | 397 | STATE : Set 398 | STATE = Two -> BitProcess One 399 | 400 | step : STATE -> Two -> (List Two ** Maybe STATE) 401 | step s b = go (s b) 402 | where 403 | go : BitProcess One → List Two ** Maybe (Two → BitProcess One) 404 | go (stop <>) = [] , no 405 | go (send b p) with go p 406 | ... | bs , ms = (b ,- bs) , ms 407 | go (recv pt pf) = [] , yes \ { tt → pt ; ff → pf } 408 | 409 | myState : STATE 410 | myState tt = bpEcho >>= \ _ -> bpEcho 411 | myState ff = bpEcho 412 | 413 | {- 414 | main : IO One 415 | main = mainLoop myState step 416 | -} 417 | 418 | example2 = bpRun (myState ff) (tt ,- ff ,- []) 419 | 420 | outIn : BitProcess One -> List Two ** Maybe (Two -> BitProcess One) 421 | outIn (stop <>) = [] , no 422 | outIn (send b p) with outIn p 423 | ... | os , mk = (b ,- os) , mk 424 | outIn (recv pt pf) = [] , yes \ { tt → pt ; ff → pf } 425 | 426 | main : IO One 427 | main = mainOutIn (send1 ff >>= \ _ -> bpEcho >>= \ _ -> bpEcho) outIn 428 | 429 | 430 | 431 | _-:>_ : {I : Set} -> (I -> Set) -> (I -> Set) -> (I -> Set) 432 | (S -:> T) i = S i -> T i 433 | 434 | [_] : {I : Set} -> (I -> Set) -> Set 435 | [ P ] = forall i -> P i -- [_] {I} P = (i : I) -> P i 436 | 437 | _->SET : Set -> Category 438 | I ->SET = record 439 | { Obj = I -> Set -- I-indexed sets 440 | ; _~>_ = \ S T -> [ S -:> T ] -- index-respecting functions 441 | ; id~> = \ i -> id -- the identity at every index 442 | ; _>~>_ = \ f g i -> f i >> g i -- composition at every index 443 | ; law-id~>>~> = refl -- and the laws are very boring 444 | ; law->~>id~> = refl 445 | ; law->~>>~> = \ f g h -> refl _ 446 | } 447 | 448 | All : {X : Set} -> (X -> Set) -> (List X -> Set) 449 | All P [] = One 450 | All P (x ,- xs) = P x * All P xs 451 | 452 | example3 : All (Vec Two) (1 ,- 2 ,- 3 ,- []) 453 | example3 = (tt ,- []) 454 | , (tt ,- ff ,- []) 455 | , (tt ,- ff ,- tt ,- []) 456 | , <> 457 | 458 | record _|>_ (I O : Set) : Set where 459 | field 460 | Cuts : O -> Set -- given o : O, how may we cut it? 461 | inners : {o : O} -> Cuts o -> List I -- given how we cut it, what are 462 | -- the shapes of its pieces? 463 | 464 | -- Let us have some examples right away! 465 | 466 | copy : Nat -> List One 467 | copy zero = [] 468 | copy (suc n) = <> ,- copy n 469 | 470 | VecCut : One |> Nat -- cut numbers into boring pieces 471 | VecCut = record 472 | { Cuts = \ n -> One -- there is one way to cut n 473 | ; inners = \ {n} _ -> copy n -- and you get n pieces 474 | } 475 | 476 | -- Here's a less boring example. You can cut a number into *two* pieces 477 | -- by finding two numbers that add to it. 478 | 479 | NatCut : Nat |> Nat 480 | NatCut = record 481 | { Cuts = \ mn -> Sg Nat \ m -> Sg Nat \ n -> (m +N n) == mn 482 | ; inners = \ { (m , n , _) -> m ,- n ,- [] } 483 | } 484 | 485 | -- The point is that we can make data structures that record how we 486 | -- built an O-shaped thing from I-shaped pieces. 487 | 488 | record Cutting {I O}(C : I |> O)(P : I -> Set)(o : O) : Set where 489 | constructor _8><_ -- "scissors" 490 | open _|>_ C 491 | field 492 | cut : Cuts o -- we decide how to cut o 493 | pieces : All P (inners cut) -- then we give all the pieces. 494 | infixr 3 _8><_ 495 | 496 | example4 : Cutting NatCut (Vec Two) 5 497 | example4 = (3 , 2 , refl 5) 8>< ((tt ,- tt ,- tt ,- []) , (ff ,- ff ,- []) , <>) 498 | 499 | data Interior {I}(C : I |> I)(T : I -> Set)(i : I) : Set where 500 | -- either... 501 | tile : T i -> Interior C T i -- we have a tile that fits, or... 502 | <_> : Cutting C (Interior C T) i -> -- ...we cut, then tile the pieces. 503 | Interior C T i 504 | 505 | MayC : One |> One 506 | MayC = record { Cuts = \ _ -> One ; inners = \ _ -> [] } 507 | 508 | Maybe' : Set -> Set 509 | Maybe' X = Interior MayC (\ _ -> X) <> 510 | 511 | yes' : {X : Set} -> X -> Maybe' X 512 | yes' x = tile x 513 | 514 | no' : {X : Set} -> Maybe' X 515 | no' = < <> 8>< <> > 516 | 517 | BPC : One |> One 518 | BPC = record { Cuts = \ _ -> Two + One 519 | ; inners = \ { (inl x) → <> ,- [] 520 | ; (inr x) → <> ,- <> ,- [] 521 | } 522 | } 523 | 524 | data Type : Set where nat two : Type 525 | 526 | Val : Type -> Set 527 | Val nat = Nat 528 | Val two = Two 529 | 530 | data Op : Type -> Set where 531 | val : {T : Type} -> Val T -> Op T 532 | add : Op nat 533 | if : {T : Type} -> Op T 534 | 535 | Syntax : Type |> Type 536 | _|>_.Cuts Syntax T = Op T 537 | _|>_.inners Syntax {T} (val x) = [] 538 | _|>_.inners Syntax {.nat} add = nat ,- nat ,- [] 539 | _|>_.inners Syntax {T} if = two ,- T ,- T ,- [] 540 | 541 | eval : {T : Type}{X : Type -> Set} -> Interior Syntax X T -> 542 | ({T : Type} -> X T -> Val T) -> Val T 543 | eval (tile x) g = g x 544 | eval < val v 8>< <> > g = v 545 | eval < add 8>< e1 , e2 , <> > g = eval e1 g +N eval e2 g 546 | eval < if 8>< e1 , e2 , e3 , <> > g with eval e1 g 547 | eval < if 8>< e1 , e2 , e3 , <> > g | tt = eval e2 g 548 | eval < if 8>< e1 , e2 , e3 , <> > g | ff = eval e3 g 549 | -------------------------------------------------------------------------------- /lectures/Lec4Done.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} -- yes, there will be some cheating in this lecture 2 | 3 | module Lec4Done where 4 | 5 | open import Lec1Done 6 | open import Lec2Done 7 | open import Lec3Done 8 | 9 | -- the identity functor (the identity action on objects and arrows) 10 | ID : {C : Category} -> C => C 11 | ID = id~> where open Category CATEGORY 12 | 13 | -- composition of functors (composition of actions on objects and arrows) 14 | _>F>_ : {C D E : Category} -> (C => D) -> (D => E) -> (C => E) 15 | F >F> G = F >~> G where open Category CATEGORY 16 | 17 | -- EXAMPLES 18 | 19 | data Maybe (X : Set) : Set where 20 | yes : (x : X) -> Maybe X 21 | no : Maybe X 22 | 23 | maybe : {X Y : Set} -> (X -> Y) -> Maybe X -> Maybe Y 24 | maybe f (yes x) = yes (f x) 25 | maybe f no = no 26 | 27 | MAYBE : SET => SET 28 | MAYBE = record 29 | { F-Obj = Maybe 30 | ; F-map = maybe 31 | ; F-map-id~> = extensionality \ { (yes x) -> refl (yes x) ; no -> refl no } 32 | ; F-map->~> = \ f g -> extensionality \ { (yes x) -> refl (yes (g (f x))) ; no -> refl no } 33 | } 34 | 35 | module MAYBE-CAT where 36 | open Category SET 37 | open _=>_ MAYBE 38 | joinMaybe : {X : Set} -> Maybe (Maybe X) -> Maybe X 39 | joinMaybe no = no -- goes wrong sooner 40 | joinMaybe (yes mx) = mx -- maybe goes wrong later 41 | MAYBE-CAT : Category 42 | MAYBE-CAT = record 43 | { Obj = Set 44 | ; _~>_ = \ S T -> S -> Maybe T 45 | ; id~> = yes 46 | ; _>~>_ = \ f g -> f >~> maybe g >~> joinMaybe 47 | ; law-id~>>~> = \ f -> extensionality \ x -> help1 (f x) 48 | ; law->~>id~> = \ f -> extensionality \ x -> help2 (f x) 49 | ; law->~>>~> = \ f g h -> extensionality \ x -> help3 g h (f x) 50 | } where 51 | help1 : {T : Set} (w : Maybe T) -> joinMaybe (yes w) == w 52 | help1 mx = refl mx 53 | help2 : {T : Set} (w : Maybe T) -> joinMaybe (maybe yes w) == w 54 | help2 (yes x) = refl (yes x) 55 | help2 no = refl no 56 | help3 : {R S T : Set} (g : R -> Maybe S) (h : S -> Maybe T) 57 | (w : Maybe R) -> 58 | joinMaybe (maybe h (joinMaybe (maybe g w))) == 59 | joinMaybe (maybe (\ x -> joinMaybe (maybe h (g x))) w) 60 | help3 g h (yes x) with g x 61 | help3 g h (yes x) | yes y = refl (h y) 62 | help3 g h (yes x) | no = refl no 63 | help3 g h no = refl no 64 | 65 | 66 | module NATURAL-TRANSFORMATION {C D : Category} where 67 | open Category 68 | open _=>_ 69 | 70 | record _~~>_ (F G : C => D) : Set where 71 | field 72 | -- one operation 73 | xform : {X : Obj C} -> _~>_ D (F-Obj F X) (F-Obj G X) 74 | -- one law 75 | xform-natural : {X Y : Obj C}(f : _~>_ C X Y) -> 76 | _>~>_ D (F-map F f) (xform {Y}) 77 | == 78 | _>~>_ D (xform {X}) (F-map G f) 79 | 80 | module MAYBE-GADGETS where 81 | open NATURAL-TRANSFORMATION {SET}{SET} 82 | open Category SET 83 | open _=>_ MAYBE 84 | open _~~>_ 85 | 86 | unitMaybe : ID ~~> MAYBE 87 | unitMaybe = record 88 | { xform = yes 89 | ; xform-natural = \ f -> refl (f >~> yes) 90 | } 91 | 92 | multMaybe : (MAYBE >F> MAYBE) ~~> MAYBE 93 | multMaybe = record 94 | { xform = MAYBE-CAT.joinMaybe 95 | ; xform-natural = \ f -> extensionality \ 96 | { (yes (yes x)) -> refl (yes (f x)) 97 | ; (yes no) -> refl no 98 | ; no -> refl no } 99 | } 100 | 101 | law1 : {X : Set} -> (xform unitMaybe >~> xform multMaybe) == id~> {Maybe X} 102 | law1 = extensionality \ { (yes x) -> refl (yes x) ; no -> refl no } 103 | 104 | law2 : {X : Set} -> (F-map (xform unitMaybe) >~> xform multMaybe) == id~> {Maybe X} 105 | law2 = extensionality \ { (yes x) -> refl (yes x) ; no -> refl no } 106 | 107 | law3 : {X : Set} -> (xform multMaybe >~> xform multMaybe) 108 | == (F-map (xform multMaybe) >~> xform multMaybe {X}) 109 | law3 = extensionality \ { (yes (yes mx)) -> refl mx ; (yes no) -> refl no ; no -> refl no } 110 | 111 | MAYBE-CAT2 : Category 112 | MAYBE-CAT2 = record 113 | { Obj = Set 114 | ; _~>_ = \ S T -> S -> Maybe T 115 | ; id~> = xform unitMaybe 116 | ; _>~>_ = \ f g -> f >~> F-map g >~> xform multMaybe 117 | ; law-id~>>~> = \ f -> 118 | xform unitMaybe >~> F-map f >~> xform multMaybe 119 | =< law->~>>~> (xform unitMaybe) (F-map f) (xform multMaybe) ]= 120 | (xform unitMaybe >~> F-map f) >~> xform multMaybe 121 | =< refl (_>~> xform multMaybe) =$= xform-natural unitMaybe f ]= 122 | (f >~> xform unitMaybe) >~> xform multMaybe 123 | =[ law->~>>~> f (xform unitMaybe) (xform multMaybe) >= 124 | f >~> (xform unitMaybe >~> xform multMaybe) 125 | =[ refl (f >~>_) =$= law1 >= 126 | f >~> id~> 127 | =[ law->~>id~> f >= 128 | f [QED] 129 | ; law->~>id~> = \ f -> 130 | f >~> (F-map (xform unitMaybe) >~> xform multMaybe) 131 | =[ refl (f >~>_) =$= law2 >= 132 | f >~> id~> 133 | =[ law->~>id~> f >= 134 | f [QED] 135 | ; law->~>>~> = \ f g h -> 136 | (f >~> (F-map g >~> xform multMaybe)) >~> (F-map h >~> xform multMaybe) 137 | =[ law->~>>~> f (F-map g >~> xform multMaybe) (F-map h >~> xform multMaybe) >= 138 | f >~> (F-map g >~> xform multMaybe) >~> (F-map h >~> xform multMaybe) 139 | =[ refl (f >~>_) =$= ( 140 | (F-map g >~> xform multMaybe) >~> (F-map h >~> xform multMaybe) 141 | =[ law->~>>~> (F-map g) (xform multMaybe) (F-map h >~> xform multMaybe) >= 142 | F-map g >~> (xform multMaybe >~> (F-map h >~> xform multMaybe)) 143 | =[ refl (F-map g >~>_) =$= ( 144 | xform multMaybe >~> (F-map h >~> xform multMaybe) 145 | =< law->~>>~> (xform multMaybe) (F-map h) (xform multMaybe) ]= 146 | (xform multMaybe >~> F-map h) >~> xform multMaybe 147 | =< refl (_>~> xform multMaybe) =$= xform-natural multMaybe h ]= 148 | (F-map (F-map h) >~> xform multMaybe) >~> xform multMaybe 149 | =[ law->~>>~> (F-map (F-map h)) (xform multMaybe) (xform multMaybe) >= 150 | F-map (F-map h) >~> (xform multMaybe >~> xform multMaybe) 151 | =[ refl (F-map (F-map h) >~>_) =$= law3 >= 152 | F-map (F-map h) >~> (F-map (xform multMaybe) >~> xform multMaybe) 153 | =< law->~>>~> (F-map (F-map h)) (F-map (xform multMaybe)) (xform multMaybe) ]= 154 | (F-map (F-map h) >~> F-map (xform multMaybe)) >~> xform multMaybe 155 | =< refl (_>~> xform multMaybe) =$= F-map->~> (F-map h) (xform multMaybe) ]= 156 | (F-map (F-map h >~> xform multMaybe) >~> xform multMaybe) [QED] 157 | ) >= 158 | F-map g >~> (F-map (F-map h >~> xform multMaybe) >~> xform multMaybe) 159 | =< law->~>>~> (F-map g) (F-map (F-map h >~> xform multMaybe)) (xform multMaybe) ]= 160 | (F-map g >~> F-map (F-map h >~> xform multMaybe)) >~> xform multMaybe 161 | =< refl (_>~> xform multMaybe) =$= F-map->~> g (F-map h >~> xform multMaybe) ]= 162 | (F-map (g >~> F-map h >~> xform multMaybe) >~> xform multMaybe) [QED] 163 | ) >= 164 | (f >~> F-map (g >~> F-map h >~> xform multMaybe) >~> xform multMaybe) [QED] 165 | } 166 | 167 | module MONAD {C : Category}(M : C => C) where 168 | open NATURAL-TRANSFORMATION {C}{C} 169 | open Category C 170 | open _=>_ M 171 | open _~~>_ 172 | 173 | record Monad : Set where 174 | field 175 | unit : ID ~~> M 176 | mult : (M >F> M) ~~> M 177 | 178 | unitMult : {X : Obj} -> (xform unit >~> xform mult) == id~> {F-Obj X} 179 | multUnit : {X : Obj} -> (F-map (xform unit) >~> xform mult) == id~> {F-Obj X} 180 | multMult : {X : Obj} -> (xform mult >~> xform mult) == (F-map (xform mult) >~> xform mult {X}) 181 | 182 | KLEISLI : Category 183 | KLEISLI = record 184 | { Obj = Obj 185 | ; _~>_ = \ S T -> S ~> F-Obj T 186 | ; id~> = xform unit 187 | ; _>~>_ = \ f g -> f >~> F-map g >~> xform mult 188 | ; law-id~>>~> = \ f -> 189 | xform unit >~> F-map f >~> xform mult 190 | =< law->~>>~> (xform unit) (F-map f) (xform mult) ]= 191 | (xform unit >~> F-map f) >~> xform mult 192 | =< refl (_>~> xform mult) =$= xform-natural unit f ]= 193 | (f >~> xform unit) >~> xform mult 194 | =[ law->~>>~> f (xform unit) (xform mult) >= 195 | f >~> (xform unit >~> xform mult) 196 | =[ refl (f >~>_) =$= unitMult >= 197 | f >~> id~> 198 | =[ law->~>id~> f >= 199 | f [QED] 200 | ; law->~>id~> = \ f -> 201 | f >~> (F-map (xform unit) >~> xform mult) 202 | =[ refl (f >~>_) =$= multUnit >= 203 | f >~> id~> 204 | =[ law->~>id~> f >= 205 | f [QED] 206 | ; law->~>>~> = \ f g h -> 207 | (f >~> (F-map g >~> xform mult)) >~> (F-map h >~> xform mult) 208 | =[ law->~>>~> f (F-map g >~> xform mult) (F-map h >~> xform mult) >= 209 | f >~> (F-map g >~> xform mult) >~> (F-map h >~> xform mult) 210 | =[ refl (f >~>_) =$= ( 211 | (F-map g >~> xform mult) >~> (F-map h >~> xform mult) 212 | =[ law->~>>~> (F-map g) (xform mult) (F-map h >~> xform mult) >= 213 | F-map g >~> (xform mult >~> (F-map h >~> xform mult)) 214 | =[ refl (F-map g >~>_) =$= ( 215 | xform mult >~> (F-map h >~> xform mult) 216 | =< law->~>>~> (xform mult) (F-map h) (xform mult) ]= 217 | (xform mult >~> F-map h) >~> xform mult 218 | =< refl (_>~> xform mult) =$= xform-natural mult h ]= 219 | (F-map (F-map h) >~> xform mult) >~> xform mult 220 | =[ law->~>>~> (F-map (F-map h)) (xform mult) (xform mult) >= 221 | F-map (F-map h) >~> (xform mult >~> xform mult) 222 | =[ refl (F-map (F-map h) >~>_) =$= multMult >= 223 | F-map (F-map h) >~> (F-map (xform mult) >~> xform mult) 224 | =< law->~>>~> (F-map (F-map h)) (F-map (xform mult)) (xform mult) ]= 225 | (F-map (F-map h) >~> F-map (xform mult)) >~> xform mult 226 | =< refl (_>~> xform mult) =$= F-map->~> (F-map h) (xform mult) ]= 227 | (F-map (F-map h >~> xform mult) >~> xform mult) [QED] 228 | ) >= 229 | F-map g >~> (F-map (F-map h >~> xform mult) >~> xform mult) 230 | =< law->~>>~> (F-map g) (F-map (F-map h >~> xform mult)) (xform mult) ]= 231 | (F-map g >~> F-map (F-map h >~> xform mult)) >~> xform mult 232 | =< refl (_>~> xform mult) =$= F-map->~> g (F-map h >~> xform mult) ]= 233 | (F-map (g >~> F-map h >~> xform mult) >~> xform mult) [QED] 234 | ) >= 235 | (f >~> F-map (g >~> F-map h >~> xform mult) >~> xform mult) [QED] 236 | } 237 | 238 | data List (X : Set) : Set where 239 | [] : List X 240 | _,-_ : (x : X)(xs : List X) -> List X 241 | 242 | list : {X Y : Set} -> (X -> Y) -> List X -> List Y 243 | list f [] = [] 244 | list f (x ,- xs) = f x ,- list f xs 245 | 246 | LIST : SET => SET 247 | LIST = record 248 | { F-Obj = List 249 | ; F-map = list 250 | ; F-map-id~> = extensionality listId 251 | ; F-map->~> = \ f g -> extensionality (listCp f g) 252 | } where 253 | open Category SET 254 | listId : {T : Set}(xs : List T) -> list id xs == xs 255 | listId [] = refl [] 256 | listId (x ,- xs) = refl (_,-_ x) =$= listId xs 257 | listCp : {R S T : Set} (f : R -> S) (g : S -> T) (xs : List R) → 258 | list (f >~> g) xs == (list f >~> list g) xs 259 | listCp f g [] = refl [] 260 | listCp f g (x ,- xs) = refl (_,-_ (g (f x))) =$= listCp f g xs 261 | 262 | data Two : Set where tt ff : Two 263 | 264 | data BitProcess (X : Set) : Set where -- in what way is X used? 265 | stop : (x : X) -> BitProcess X -- stop with value x 266 | send : (b : Two)(k : BitProcess X) -> BitProcess X -- send b, continue as k 267 | recv : (kt kf : BitProcess X) -> BitProcess X -- receive bit, continue as 268 | -- kt if tt, kf if ff 269 | 270 | bpRun : forall {X} -> BitProcess X -- a process to run 271 | -> List Two -- a list of bits waiting to be input 272 | -> List Two -- the list of bits output 273 | * Maybe -- and, if we don't run out of input 274 | ( X -- the resulting value 275 | * List Two -- and the unused input 276 | ) 277 | bpRun (stop x) bs = [] , yes (x , bs) 278 | bpRun (send b k) bs with bpRun k bs 279 | bpRun (send b k) bs | os , yes (x , is) = (b ,- os) , yes (x , is) 280 | bpRun (send b k) bs | os , no = os , no 281 | bpRun (recv kt kf) [] = [] , no 282 | bpRun (recv kt kf) (tt ,- bs) = bpRun kt bs 283 | bpRun (recv kt kf) (ff ,- bs) = bpRun kf bs 284 | 285 | bitProcess : {X Y : Set} -> (X -> Y) -> BitProcess X -> BitProcess Y 286 | bitProcess f (stop x) = stop (f x) 287 | bitProcess f (send b k) = send b (bitProcess f k) 288 | bitProcess f (recv kt kf) = recv (bitProcess f kt) (bitProcess f kf) 289 | 290 | BITPROCESS : SET => SET -- actions on *values* lift to processes 291 | BITPROCESS = record 292 | { F-Obj = BitProcess 293 | ; F-map = bitProcess 294 | ; F-map-id~> = extensionality helpId 295 | ; F-map->~> = \ f g -> extensionality (helpCp f g) 296 | } where 297 | open Category SET 298 | helpId : {T : Set} (p : BitProcess T) -> bitProcess id p == p 299 | helpId (stop x) = refl (stop x) 300 | helpId (send b k) rewrite helpId k = refl (send b k) 301 | helpId (recv kt kf) rewrite helpId kt | helpId kf = refl (recv kt kf) 302 | helpCp : {R S T : Set} (f : R -> S)(g : S -> T) (p : BitProcess R) → 303 | bitProcess (f >~> g) p == (bitProcess f >~> bitProcess g) p 304 | helpCp f g (stop x) = refl (stop (g (f x))) 305 | helpCp f g (send b k) rewrite helpCp f g k = refl (send b (bitProcess g (bitProcess f k))) 306 | helpCp f g (recv kt kf) rewrite helpCp f g kt | helpCp f g kf 307 | = refl (recv (bitProcess g (bitProcess f kt)) (bitProcess g (bitProcess f kf))) 308 | -------------------------------------------------------------------------------- /lectures/Lec4HS.hs: -------------------------------------------------------------------------------- 1 | module Lec4HS where 2 | import System.IO 3 | 4 | mainLoop :: s -> (s -> Bool -> ([Bool], Maybe s)) -> IO () 5 | mainLoop s f = do 6 | hSetBuffering stdout NoBuffering 7 | hSetBuffering stdin NoBuffering 8 | hSetEcho stdin False 9 | innerLoop s 10 | where 11 | getBit = do 12 | c <- getChar 13 | case c of 14 | '0' -> return False 15 | '1' -> return True 16 | _ -> getBit 17 | innerLoop s = do 18 | b <- getBit 19 | let (os, ms) = f s b 20 | mapM_ (\ b -> if b then putChar '1' else putChar '0') os 21 | case ms of 22 | Just s -> innerLoop s 23 | Nothing -> return () 24 | 25 | mainOutIn :: s -> (s -> ([Bool], Maybe (Bool -> s))) -> IO () 26 | mainOutIn s f = do 27 | hSetBuffering stdout NoBuffering 28 | hSetBuffering stdin NoBuffering 29 | hSetEcho stdin False 30 | innerLoop s 31 | where 32 | getBit = do 33 | c <- getChar 34 | case c of 35 | '0' -> return False 36 | '1' -> return True 37 | _ -> getBit 38 | innerLoop s = do 39 | let (os, mk) = f s 40 | mapM_ (\ b -> if b then putChar '1' else putChar '0') os 41 | case mk of 42 | Just k -> do 43 | b <- getBit 44 | innerLoop (k b) 45 | Nothing -> return () 46 | -------------------------------------------------------------------------------- /lectures/Lec5.agda: -------------------------------------------------------------------------------- 1 | module Lec5 where 2 | 3 | 4 | open import Lec1Done 5 | open import Lec2Done 6 | open import Lec3Done 7 | 8 | 9 | data List (X : Set) : Set where -- BUILTIN insists on level polymorphism 10 | [] : List X 11 | _,-_ : (x : X)(xs : List X) -> List X 12 | {-# BUILTIN LIST List #-} 13 | {-# BUILTIN NIL [] #-} 14 | {-# BUILTIN CONS _,-_ #-} 15 | {-# COMPILE GHC List = data [] ([] | (:)) #-} 16 | 17 | list : {X Y : Set} -> (X -> Y) -> List X -> List Y 18 | list f [] = [] 19 | list f (x ,- xs) = f x ,- list f xs 20 | 21 | data Two : Set where ff tt : Two 22 | {-# BUILTIN BOOL Two #-} 23 | {-# BUILTIN FALSE ff #-} 24 | {-# BUILTIN TRUE tt #-} 25 | 26 | 27 | ---------------------------------------------------------------------------- 28 | -- chars and strings 29 | ---------------------------------------------------------------------------- 30 | 31 | postulate -- this means that we just suppose the following things exist... 32 | Char : Set 33 | String : Set 34 | {-# BUILTIN CHAR Char #-} 35 | {-# BUILTIN STRING String #-} 36 | 37 | primitive -- these are baked in; they even work! 38 | primCharEquality : Char -> Char -> Two 39 | primStringAppend : String -> String -> String 40 | primStringToList : String -> List Char 41 | primStringFromList : List Char -> String 42 | 43 | 44 | --------------------------------------------------------------------------- 45 | -- COLOURS 46 | --------------------------------------------------------------------------- 47 | 48 | -- We're going to be making displays from coloured text. 49 | 50 | data Colour : Set where 51 | black red green yellow blue magenta cyan white : Colour 52 | {-# COMPILE GHC Colour = data HaskellSetup.Colour (HaskellSetup.Black | HaskellSetup.Red | HaskellSetup.Green | HaskellSetup.Yellow | HaskellSetup.Blue | HaskellSetup.Magenta | HaskellSetup.Cyan | HaskellSetup.White) #-} 53 | 54 | record _**_ (S T : Set) : Set where 55 | constructor _,_ 56 | field 57 | outl : S 58 | outr : T 59 | open _**_ 60 | {-# COMPILE GHC _**_ = data (,) ((,)) #-} 61 | infixr 4 _**_ _,_ 62 | 63 | {- Here's the characterization of keys I give you -} 64 | data Direction : Set where up down left right : Direction 65 | data Modifier : Set where normal shift control : Modifier 66 | data Key : Set where 67 | char : Char -> Key 68 | arrow : Modifier -> Direction -> Key 69 | enter : Key 70 | backspace : Key 71 | delete : Key 72 | escape : Key 73 | tab : Key 74 | data Event : Set where 75 | key : (k : Key) -> Event 76 | resize : (w h : Nat) -> Event 77 | 78 | {- This type collects the things you're allowed to do with the text window. -} 79 | data Action : Set where 80 | goRowCol : Nat -> Nat -> Action -- send the cursor somewhere 81 | sendText : List Char -> Action -- send some text 82 | move : Direction -> Nat -> Action -- which way and how much 83 | fgText : Colour -> Action 84 | bgText : Colour -> Action 85 | 86 | {- I wire all of that stuff up to its Haskell counterpart. -} 87 | {-# FOREIGN GHC import qualified ANSIEscapes #-} 88 | {-# FOREIGN GHC import qualified HaskellSetup #-} 89 | {-# COMPILE GHC Direction = data ANSIEscapes.Dir (ANSIEscapes.DU | ANSIEscapes.DD | ANSIEscapes.DL | ANSIEscapes.DR) #-} 90 | {-# COMPILE GHC Modifier = data HaskellSetup.Modifier (HaskellSetup.Normal | HaskellSetup.Shift | HaskellSetup.Control) #-} 91 | {-# COMPILE GHC Key = data HaskellSetup.Key (HaskellSetup.Char | HaskellSetup.Arrow | HaskellSetup.Enter | HaskellSetup.Backspace | HaskellSetup.Delete | HaskellSetup.Escape | HaskellSetup.Tab) #-} 92 | {-# COMPILE GHC Event = data HaskellSetup.Event (HaskellSetup.Key | HaskellSetup.Resize) #-} 93 | {-# COMPILE GHC Action = data HaskellSetup.Action (HaskellSetup.GoRowCol | HaskellSetup.SendText | HaskellSetup.Move | HaskellSetup.FgText | HaskellSetup.BgText) #-} 94 | 95 | 96 | data ColourChar : Set where 97 | _-_/_ : (fg : Colour)(c : Char)(bg : Colour) -> ColourChar 98 | 99 | -- ... e.g. green - '*' / black for a green * on black. 100 | 101 | Matrix : Set -> Nat * Nat -> Set 102 | Matrix C (w , h) = Vec (Vec C w) h 103 | 104 | Painting : Nat * Nat -> Set 105 | Painting = Matrix ColourChar 106 | 107 | vecFoldR : {X Y : Set} -> (X -> Y -> Y) -> Y -> {n : Nat} -> Vec X n -> Y 108 | vecFoldR c n [] = n 109 | vecFoldR c n (x ,- xs) = c x (vecFoldR c n xs) 110 | 111 | paintAction : {wh : Nat * Nat} -> Matrix ColourChar wh -> List Action 112 | paintAction = vecFoldR (vecFoldR (\ {(f - c / b) k -> \ as -> 113 | fgText f ,- bgText b ,- sendText (c ,- []) ,- k as}) id) [] 114 | 115 | 116 | postulate -- Haskell has a monad for doing IO, which we use at the top level 117 | IO : Set -> Set 118 | return : {A : Set} -> A -> IO A 119 | _>>=_ : {A B : Set} -> IO A -> (A -> IO B) -> IO B 120 | infixl 1 _>>=_ 121 | {-# BUILTIN IO IO #-} 122 | {-# COMPILE GHC IO = type IO #-} 123 | {-# COMPILE GHC return = (\ _ -> return) #-} 124 | {-# COMPILE GHC _>>=_ = (\ _ _ -> (>>=)) #-} 125 | 126 | 127 | --------------------------------------------------------------------------- 128 | -- APPLICATIONS -- 129 | --------------------------------------------------------------------------- 130 | 131 | -- Here's a general idea of what it means to be an "application". 132 | -- You need to choose some sort of size-dependent state, then provide these 133 | -- bits and pieces. We need to know how the state is updated according to 134 | -- events, with resizing potentially affecting the state's type. We must 135 | -- be able to paint the state. The state should propose a cursor position. 136 | -- (Keen students may modify this definition to ensure the cursor must be 137 | -- within the bounds of the application.) 138 | 139 | record Application (wh : Nat * Nat) : Set where 140 | coinductive 141 | field 142 | handleKey : Key -> Application wh 143 | handleResize : (wh' : Nat * Nat) -> Application wh' 144 | paintMe : Painting wh 145 | cursorMe : Nat * Nat -- x,y coords 146 | open Application public 147 | 148 | -- Now your turn. Build the appropriate handler to connect these 149 | -- applications with mainAppLoop. Again, work in two stages, first 150 | -- figuring out how to do the right actions, then managing the 151 | -- state properly. (1 mark) 152 | 153 | _+L_ : {X : Set} -> List X -> List X -> List X 154 | [] +L ys = ys 155 | (x ,- xs) +L ys = x ,- (xs +L ys) 156 | infixr 3 _+L_ 157 | 158 | APP : Set 159 | APP = Sg (Nat * Nat) Application 160 | 161 | appPaint : APP -> List Action 162 | appPaint (_ , app) = 163 | goRowCol 0 0 ,- paintAction p 164 | -- must have composition here, to work around compiler bug 165 | -- paintAction (paintMatrix p) 166 | -- segfaults, because p is erased 167 | +L (goRowCol (snd xy) (fst xy) ,- []) 168 | where 169 | p = paintMe app 170 | xy = cursorMe app 171 | 172 | appHandler : Event -> APP -> APP ** List Action 173 | appHandler (key k) (wh , app) = app' , appPaint app' 174 | where 175 | app' : APP 176 | app' = _ , handleKey app k 177 | appHandler (resize w h) (wh , app) = app' , appPaint app' 178 | where 179 | app' : APP 180 | app' = _ , handleResize app (w , h) 181 | 182 | {- This is the bit of code I wrote in Haskell to animate your code. -} 183 | postulate 184 | mainAppLoop : {S : Set} -> -- program state 185 | -- INITIALIZER 186 | S -> -- initial state 187 | -- EVENT HANDLER 188 | (Event -> S -> -- event and state in 189 | S ** List Action) -> -- new state and screen actions out 190 | -- PUT 'EM TOGETHER AND YOU'VE GOT AN APPLICATION! 191 | IO One 192 | {-# COMPILE GHC mainAppLoop = (\ _ -> HaskellSetup.mainAppLoop) #-} 193 | 194 | appMain : (forall wh -> Application wh) -> IO One 195 | appMain app = mainAppLoop ((0 , 0) , app (0 , 0)) appHandler 196 | -- will get resized dynamically to size of terminal, first thing 197 | 198 | vPure : {n : Nat}{X : Set} -> X -> Vec X n 199 | vPure {zero} x = [] 200 | vPure {suc n} x = x ,- vPure x 201 | 202 | rectApp : Char -> forall wh -> Application wh 203 | handleKey (rectApp c wh) (char x) = rectApp x wh 204 | handleKey (rectApp c wh) _ = rectApp c wh 205 | handleResize (rectApp c _) wh = rectApp c wh 206 | paintMe (rectApp c wh) = vPure (vPure (green - c / black)) 207 | cursorMe (rectApp c wh) = wh 208 | 209 | main : IO One 210 | main = appMain (rectApp '*') 211 | 212 | -- agda --compile --ghc-flag "-lncurses" Lec5.agda 213 | -------------------------------------------------------------------------------- /lectures/Lec6.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | 3 | module Lec6 where 4 | 5 | open import Lec1Done 6 | 7 | ListF : Set -> Set -> Set 8 | ListF X T = One + (X * T) 9 | 10 | data List (X : Set) : Set where 11 | <_> : (ListF X) (List X) -> (List X) 12 | infixr 4 _,-_ 13 | 14 | listF : {X T U : Set} -> (T -> U) -> (ListF X) T -> (ListF X) U 15 | listF g (inl <>) = inl <> 16 | listF g (inr (x , t)) = inr (x , g t) 17 | 18 | pattern [] = < inl <> > 19 | pattern _,-_ x xs = < inr (x , xs) > 20 | 21 | {-(-} 22 | mkList : {X : Set} -> (ListF X) (List X) -> List X 23 | mkList = <_> 24 | {- 25 | mkList (inl <>) = [] 26 | mkList (inr (x , xs)) = x ,- xs 27 | -} 28 | {-)-} 29 | 30 | {-(-} 31 | foldr : {X T : Set} -> ((ListF X) T -> T) -> List X -> T 32 | foldr alg [] = alg (inl <>) 33 | foldr alg (x ,- xs) = alg (inr (x , foldr alg xs)) 34 | 35 | ex1 = foldr mkList (1 ,- 2 ,- 3 ,- []) 36 | {-)-} 37 | 38 | {-(-} 39 | length : {X : Set} -> List X -> Nat 40 | length = foldr \ { (inl <>) -> zero ; (inr (x , n)) -> suc n } 41 | {-)-} 42 | 43 | record CoList (X : Set) : Set where 44 | coinductive 45 | field 46 | force : (ListF X) (CoList X) 47 | open CoList 48 | 49 | {-(-} 50 | []~ : {X : Set} -> CoList X 51 | force []~ = inl <> 52 | 53 | _,~_ : {X : Set} -> X -> CoList X -> CoList X 54 | force (x ,~ xs) = inr (x , xs) 55 | infixr 4 _,~_ 56 | {-)-} 57 | 58 | {-(-} 59 | unfoldr : {X S : Set} -> (S -> (ListF X) S) -> S -> CoList X 60 | force (unfoldr coalg s) with coalg s 61 | force (unfoldr coalg s) | inl <> = inl <> 62 | force (unfoldr coalg s) | inr (x , s') = inr (x , unfoldr coalg s') 63 | 64 | ex2 = unfoldr force (1 ,~ 2 ,~ 3 ,~ []~) 65 | {-)-} 66 | 67 | {-(-} 68 | repeat : {X : Set} -> X -> CoList X 69 | repeat = unfoldr \ x -> inr (x , x) 70 | {-)-} 71 | 72 | {-(-} 73 | prefix : {X : Set} -> Nat -> CoList X -> List X 74 | prefix zero xs = [] 75 | prefix (suc n) xs with force xs 76 | prefix (suc n) xs | inl <> = [] 77 | prefix (suc n) xs | inr (x , xs') = x ,- prefix n xs' 78 | 79 | ex2' = prefix 3 ex2 80 | {-)-} 81 | 82 | StreamF : Set -> Set -> Set 83 | StreamF X S = X * S 84 | 85 | data Funny (X : Set) : Set where 86 | <_> : (StreamF X) (Funny X) -> Funny X 87 | 88 | funny : {X : Set} -> Funny X -> Zero 89 | funny < x , xf > = funny xf 90 | 91 | record Stream (X : Set) : Set where 92 | coinductive 93 | field 94 | hdTl : (StreamF X) (Stream X) 95 | open Stream 96 | 97 | {-(-} 98 | forever : {X : Set} -> X -> Stream X 99 | fst (hdTl (forever x)) = x 100 | snd (hdTl (forever x)) = forever x 101 | {-)-} 102 | 103 | natsFrom : Nat -> Stream Nat 104 | fst (hdTl (natsFrom n)) = n 105 | snd (hdTl (natsFrom n)) = natsFrom (suc n) 106 | 107 | sprefix : {X : Set} -> Nat -> Stream X -> List X -- could be Vec X n 108 | sprefix zero xs = [] 109 | sprefix (suc n) xs with hdTl xs 110 | sprefix (suc n) xs | x , xs' = x ,- sprefix n xs' 111 | 112 | {-(-} 113 | unfold : {X S : Set} -> (S -> X * S) -> S -> Stream X 114 | hdTl (unfold coalg s) with coalg s 115 | hdTl (unfold coalg s) | x , s' = x , unfold coalg s' 116 | {-)-} 117 | 118 | natsFrom' : Nat -> Stream Nat 119 | natsFrom' = unfold \ n -> n , suc n 120 | 121 | data Two : Set where tt ff : Two 122 | 123 | So : Two -> Set 124 | So tt = One 125 | So ff = Zero 126 | 127 | isSuc : Nat -> Two 128 | isSuc zero = ff 129 | isSuc (suc n) = tt 130 | 131 | {- 132 | div : (x y : Nat) -> So (isSuc y) -> Nat 133 | div x zero () 134 | div x (suc y) p = {!!} 135 | -} 136 | 137 | data Poly (X : Set) : Set where 138 | var' : X -> Poly X 139 | konst' : Two -> Poly X 140 | _+'_ _*'_ : Poly X -> Poly X -> Poly X 141 | 142 | Eval : {X : Set} -> (X -> Set) -> Poly X -> Set 143 | Eval var (var' x) = var x 144 | Eval var (konst' b) = So b 145 | Eval var (p +' q) = Eval var p + Eval var q 146 | Eval var (p *' q) = Eval var p * Eval var q 147 | 148 | eval : {X : Set}(u v : X -> Set)(p : Poly X) -> 149 | ((x : X) -> u x -> v x) -> 150 | Eval u p -> Eval v p 151 | eval u v (var' i) f x = f i x 152 | eval u v (konst' b) f x = x 153 | eval u v (p +' q) f (inl x) = inl (eval u v p f x) 154 | eval u v (p +' q) f (inr x) = inr (eval u v q f x) 155 | eval u v (p *' q) f (x , y) = eval u v p f x , eval u v q f y 156 | 157 | data Mu (p : Poly One) : Set where 158 | <_> : Eval (\ _ -> Mu p) p -> Mu p 159 | 160 | NatP : Poly One 161 | NatP = konst' tt +' var' <> 162 | 163 | NAT = Mu NatP 164 | 165 | ze : NAT 166 | ze = < (inl <>) > 167 | 168 | su : NAT -> NAT 169 | su n = < (inr n) > 170 | 171 | TreeP : Poly One 172 | TreeP = konst' tt +' (var' <> *' var' <>) 173 | 174 | -- What's a one-hole context in a Mu P? 175 | 176 | Diff : Poly One -> Poly One 177 | Diff (var' x) = konst' tt 178 | Diff (konst' x) = konst' ff 179 | Diff (p +' q) = Diff p +' Diff q 180 | Diff (p *' q) = (Diff p *' q) +' (p *' Diff q) 181 | 182 | plug : {X : Set}(p : Poly One) -> 183 | X -> Eval (\ _ -> X) (Diff p) -> 184 | Eval (\ _ -> X) p 185 | plug (var' <>) x <> = x 186 | plug (konst' b) x () 187 | plug (p +' q) x (inl xp') = inl (plug p x xp') 188 | plug (p +' q) x (inr xq') = inr (plug q x xq') 189 | plug (p *' q) x (inl (xp' , xq)) = plug p x xp' , xq 190 | plug (p *' q) x (inr (xp , xq')) = xp , plug q x xq' 191 | 192 | Context : Poly One -> Set 193 | Context p = List (Eval (\ _ -> Mu p) (Diff p)) 194 | 195 | plugs : (p : Poly One) -> Mu p -> Context p -> Mu p 196 | plugs p t [] = t 197 | plugs p t (t' ,- t's) = plugs p < plug p t t' > t's 198 | 199 | 200 | TernaryP : Poly One 201 | TernaryP = konst' tt +' (var' <> *' (var' <> *' var' <>)) 202 | 203 | 204 | 205 | 206 | fold : (p : Poly One){T : Set} 207 | -> (Eval (\ _ -> T) p -> T) 208 | -> Mu p -> T 209 | fold p {T} alg < x > = alg (evalFold p x) 210 | where 211 | evalFold : (q : Poly One) -> Eval (\ _ -> Mu p) q -> Eval (\ _ -> T) q 212 | evalFold (var' <>) x = fold p alg x 213 | evalFold (konst' b) x = x 214 | evalFold (q +' r) (inl y) = inl (evalFold q y) 215 | evalFold (q +' r) (inr y) = inr (evalFold r y) 216 | evalFold (q *' r) (y , z) = evalFold q y , evalFold r z 217 | 218 | record Nu (p : Poly One) : Set where 219 | coinductive 220 | field 221 | out : Eval (\ _ -> Nu p) p 222 | 223 | 224 | 225 | 226 | -- What's the connection between polynomials and containers? 227 | 228 | _-:>_ : {I : Set} -> (I -> Set) -> (I -> Set) -> (I -> Set) 229 | (S -:> T) i = S i -> T i 230 | 231 | [_] : {I : Set} -> (I -> Set) -> Set 232 | [ P ] = forall i -> P i -- [_] {I} P = (i : I) -> P i 233 | 234 | All : {X : Set} -> (X -> Set) -> (List X -> Set) 235 | All P [] = One 236 | All P (x ,- xs) = P x * All P xs 237 | 238 | record _|>_ (I O : Set) : Set where 239 | field 240 | Cuts : O -> Set -- given o : O, how may we cut it? 241 | inners : {o : O} -> Cuts o -> List I -- given how we cut it, what are 242 | -- the shapes of its pieces? 243 | 244 | record Cutting {I O}(C : I |> O)(P : I -> Set)(o : O) : Set where 245 | constructor _8><_ -- "scissors" 246 | open _|>_ C 247 | field 248 | cut : Cuts o -- we decide how to cut o 249 | pieces : All P (inners cut) -- then we give all the pieces. 250 | infixr 3 _8><_ 251 | 252 | data Interior {I}(C : I |> I)(T : I -> Set)(i : I) : Set where 253 | -- either... 254 | tile : T i -> Interior C T i -- we have a tile that fits, or... 255 | <_> : Cutting C (Interior C T) i -> -- ...we cut, then tile the pieces. 256 | Interior C T i 257 | 258 | 259 | _+L_ : {X : Set} -> List X -> List X -> List X 260 | [] +L ys = ys 261 | (x ,- xs) +L ys = x ,- (xs +L ys) 262 | 263 | polyCon : {I : Set} -> Poly I -> I |> One 264 | _|>_.Cuts (polyCon p) <> = Eval (\ _ -> One) p 265 | _|>_.inners (polyCon (var' i)) <> = i ,- [] 266 | _|>_.inners (polyCon (konst' x)) s = [] 267 | _|>_.inners (polyCon (p +' q)) (inl xp) = _|>_.inners (polyCon p) xp 268 | _|>_.inners (polyCon (p +' q)) (inr xq) = _|>_.inners (polyCon q) xq 269 | _|>_.inners (polyCon (p *' q)) (sp , sq) = 270 | _|>_.inners (polyCon p) sp +L _|>_.inners (polyCon q) sq 271 | 272 | 273 | Choose : {I J : Set} -> (I -> Set) -> (J -> Set) -> (I + J) -> Set 274 | Choose X Y (inl i) = X i 275 | Choose X Y (inr j) = Y j 276 | 277 | data MU {I -- what sorts of "elements" do we store? 278 | J -- what sorts of "nodes" do we have? 279 | : Set} 280 | (F : J -> Poly (I + J)) -- what is the structure of each sort of node? 281 | (X : I -> Set) -- what are the elements? 282 | (j : J) -- what sort is the outermost node? 283 | : Set where 284 | <_> : Eval (Choose X (MU F X)) -- subnodes in recursive positions 285 | (F j) 286 | -> MU F X j 287 | 288 | VecF : Nat -> Poly (One + Nat) 289 | VecF zero = konst' tt 290 | VecF (suc n) = (var' (inl <>)) *' (var' (inr n)) 291 | 292 | VEC : Nat -> Set -> Set 293 | VEC n X = MU VecF (\ _ -> X) n 294 | 295 | vnil : {X : Set} -> VEC zero X 296 | vnil = < <> > 297 | 298 | vcons : {X : Set}{n : Nat} -> X -> VEC n X -> VEC (suc n) X 299 | vcons x xs = < (x , xs) > 300 | 301 | gmap : {I -- what sorts of "elements" do we store? 302 | J -- what sorts of "nodes" do we have? 303 | : Set} 304 | {F : J -> Poly (I + J)} -- what is the structure of each sort of node? 305 | {X Y : I -> Set} -> -- what are the elements? 306 | ((i : I) -> X i -> Y i) -> 307 | (j : J) -> 308 | MU F X j -> MU F Y j 309 | gmapHelp : ∀ {I J} (F : J → Poly (I + J)) {X Y : I → Set} 310 | (w : Poly (I + J)) → 311 | ((i : I) → X i → Y i) → 312 | Eval (Choose X (MU F X)) w → 313 | Eval (Choose Y (MU F Y)) w 314 | gmap {F = F} f j < xt > = < gmapHelp F (F j) f xt > 315 | gmapHelp F (var' (inl i)) f x = f i x 316 | gmapHelp F (var' (inr j)) f t = gmap f j t 317 | gmapHelp F (konst' x) f v = v 318 | gmapHelp F (p +' q) f (inl xp) = inl (gmapHelp F p f xp) 319 | gmapHelp F (p +' q) f (inr xq) = inr (gmapHelp F q f xq) 320 | gmapHelp F (p *' q) f (xp , xq) = (gmapHelp F p f xp) , (gmapHelp F q f xq) 321 | -------------------------------------------------------------------------------- /lectures/Lec6Done.agda: -------------------------------------------------------------------------------- 1 | module Lec6Done where 2 | 3 | open import Lec1Done 4 | 5 | data List (X : Set) : Set where 6 | [] : List X 7 | _,-_ : X -> List X -> List X 8 | infixr 4 _,-_ 9 | 10 | -- ListF : Set -> Set -> Set 11 | -- ListF X T = One + (X * T) 12 | 13 | mkList : {X : Set} -> One + (X * List X) -> List X 14 | mkList (inl <>) = [] 15 | mkList (inr (x , xs)) = x ,- xs 16 | 17 | foldr : {X T : Set} -> ((One + (X * T)) -> T) -> List X -> T 18 | foldr alg [] = alg (inl <>) 19 | foldr alg (x ,- xs) = alg (inr (x , foldr alg xs)) 20 | 21 | ex1 = foldr mkList (1 ,- 2 ,- 3 ,- []) 22 | 23 | length : {X : Set} -> List X -> Nat 24 | length = foldr \ { (inl <>) -> zero ; (inr (x , n)) -> suc n } 25 | 26 | record CoList (X : Set) : Set where 27 | coinductive 28 | field 29 | force : One + (X * CoList X) 30 | open CoList 31 | 32 | []~ : {X : Set} -> CoList X 33 | force []~ = inl <> 34 | 35 | _,~_ : {X : Set} -> X -> CoList X -> CoList X 36 | force (x ,~ xs) = inr (x , xs) 37 | infixr 4 _,~_ 38 | 39 | unfoldr : {X S : Set} -> (S -> (One + (X * S))) -> S -> CoList X 40 | force (unfoldr coalg s) with coalg s 41 | force (unfoldr coalg s) | inl <> = inl <> 42 | force (unfoldr coalg s) | inr (x , s') = inr (x , unfoldr coalg s') 43 | 44 | ex2 = unfoldr force (1 ,~ 2 ,~ 3 ,~ []~) 45 | 46 | repeat : {X : Set} -> X -> CoList X 47 | repeat = unfoldr \ x -> inr (x , x) 48 | 49 | prefix : {X : Set} -> Nat -> CoList X -> List X 50 | prefix zero xs = [] 51 | prefix (suc n) xs with force xs 52 | prefix (suc n) xs | inl <> = [] 53 | prefix (suc n) xs | inr (x , xs') = x ,- prefix n xs' 54 | 55 | ex2' = prefix 3 ex2 56 | 57 | record Stream (X : Set) : Set where 58 | coinductive 59 | field 60 | hdTl : X * Stream X 61 | open Stream 62 | 63 | forever : {X : Set} -> X -> Stream X 64 | fst (hdTl (forever x)) = x 65 | snd (hdTl (forever x)) = forever x 66 | 67 | unfold : {X S : Set} -> (S -> X * S) -> S -> Stream X 68 | fst (hdTl (unfold coalg s)) = fst (coalg s) 69 | snd (hdTl (unfold coalg s)) = unfold coalg (snd (coalg s)) 70 | -------------------------------------------------------------------------------- /lectures/Lec7.agda: -------------------------------------------------------------------------------- 1 | module Lec7 where 2 | 3 | open import Lec1Done 4 | 5 | data List (X : Set) : Set where 6 | [] : List X 7 | _,-_ : X -> List X -> List X 8 | 9 | foldrL : {X T : Set} -> (X -> T -> T) -> T -> List X -> T 10 | foldrL c n [] = n 11 | foldrL c n (x ,- xs) = c x (foldrL c n xs) 12 | 13 | data Bwd (X : Set) : Set where 14 | [] : Bwd X 15 | _-,_ : Bwd X -> X -> Bwd X 16 | infixl 3 _-,_ 17 | 18 | data _<=_ {X : Set} : (xz yz : Bwd X) -> Set where 19 | oz : [] <= [] 20 | os : {xz yz : Bwd X}{y : X} -> xz <= yz -> (xz -, y) <= (yz -, y) 21 | o' : {xz yz : Bwd X}{y : X} -> xz <= yz -> xz <= (yz -, y) 22 | 23 | oe : {X : Set}{xz : Bwd X} -> [] <= xz 24 | oe {_} {[]} = oz 25 | oe {_} {xz -, _} = o' oe 26 | 27 | oi : {X : Set}{xz : Bwd X} -> xz <= xz 28 | oi {_} {[]} = oz 29 | oi {_} {xz -, _} = os oi -- look here... 30 | 31 | _ xz <= yz -> yz <= zz -> xz <= zz 32 | th X -> Bwd X -> Set 38 | Elem x yz = ([] -, x) <= yz 39 | 40 | data Ty : Set where 41 | one : Ty 42 | list : Ty -> Ty 43 | _=>_ : Ty -> Ty -> Ty 44 | infixr 4 _=>_ 45 | 46 | Val : Ty -> Set 47 | Val one = One 48 | Val (list T) = List (Val T) 49 | Val (S => T) = Val S -> Val T 50 | 51 | data Tm (Tz : Bwd Ty) : Ty -> Set where 52 | 53 | var : {T : Ty} -> Elem T Tz -> Tm Tz T 54 | 55 | <> : Tm Tz one 56 | 57 | [] : {T : Ty} -> Tm Tz (list T) 58 | _,-_ : {T : Ty} -> Tm Tz T -> Tm Tz (list T) -> Tm Tz (list T) 59 | foldr : {S T : Ty} -> 60 | Tm Tz (S => T => T) -> 61 | Tm Tz T -> 62 | Tm Tz (list S) 63 | -> Tm Tz T 64 | 65 | lam : {S T : Ty} -> 66 | Tm (Tz -, S) T 67 | -> Tm Tz (S => T) 68 | _$$_ : {S T : Ty} -> 69 | Tm Tz (S => T) -> 70 | Tm Tz S 71 | -> Tm Tz T 72 | 73 | infixl 3 _$$_ 74 | 75 | All : {X : Set} -> (X -> Set) -> Bwd X -> Set 76 | All P [] = One 77 | All P (xz -, x) = All P xz * P x 78 | 79 | all : {X : Set}{P Q : X -> Set}(f : (x : X) -> P x -> Q x) -> (xz : Bwd X) -> All P xz -> All Q xz 80 | all f [] <> = <> 81 | all f (xz -, x) (pz , p) = all f xz pz , f x p 82 | 83 | Env : Bwd Ty -> Set 84 | Env = All Val 85 | 86 | select : {X : Set}{P : X -> Set}{Sz Tz : Bwd X} -> Sz <= Tz -> All P Tz -> All P Sz 87 | select oz <> = <> 88 | select (os x) (vz , v) = select x vz , v 89 | select (o' x) (vz , v) = select x vz 90 | 91 | eval : {Tz : Bwd Ty}{T : Ty} -> Env Tz -> Tm Tz T -> Val T 92 | eval vz (var x) with select x vz 93 | eval vz (var x) | <> , v = v 94 | eval vz <> = <> 95 | eval vz [] = [] 96 | eval vz (t ,- ts) = eval vz t ,- eval vz ts 97 | eval vz (foldr c n ts) = foldrL (eval vz c) (eval vz n) (eval vz ts) 98 | eval vz (lam t) = \ s -> eval (vz , s) t 99 | eval vz (f $$ s) = eval vz f (eval vz s) 100 | 101 | append : {Tz : Bwd Ty}{T : Ty} -> 102 | Tm Tz (list T => list T => list T) 103 | append = lam (lam (foldr (lam (lam (var (o' (os oe)) ,- var (os oe)))) 104 | (var (os oe)) (var (o' (os oe))))) 105 | 106 | test : Val (list one) 107 | test = eval {[]} <> (append $$ (<> ,- []) $$ (<> ,- [])) 108 | 109 | thin : {Sz Tz : Bwd Ty} -> Sz <= Tz -> {S : Ty} -> Tm Sz S -> Tm Tz S 110 | thin th (var x) = var (x = <> 112 | thin th [] = [] 113 | thin th (t ,- ts) = thin th t ,- thin th ts 114 | thin th (foldr c n ts) = foldr (thin th c) (thin th n) (thin th ts) 115 | thin th (lam t) = lam (thin (os th) t) 116 | thin th (f $$ s) = thin th f $$ thin th s 117 | 118 | Subst : Bwd Ty -> Bwd Ty -> Set 119 | Subst Sz Tz = All (Tm Tz) Sz 120 | 121 | subst : {Sz Tz : Bwd Ty} -> Subst Sz Tz -> {S : Ty} -> Tm Sz S -> Tm Tz S 122 | subst tz (var x) with select x tz 123 | subst tz (var x) | <> , t = t 124 | subst tz <> = <> 125 | subst tz [] = [] 126 | subst tz (t ,- ts) = subst tz t ,- subst tz ts 127 | subst tz (foldr c n ts) = foldr (subst tz c) (subst tz n) (subst tz ts) 128 | subst tz (lam t) = lam (subst (all (\ T -> thin (o' oi)) _ tz , (var (os oe))) t) 129 | subst tz (f $$ s) = subst tz f $$ subst tz s 130 | 131 | record Action (M : Bwd Ty -> Bwd Ty -> Set) : Set where 132 | field 133 | varA : forall {S Sz Tz} -> M Sz Tz -> Elem S Sz -> Tm Tz S 134 | lamA : forall {S Sz Tz} -> M Sz Tz -> M (Sz -, S) (Tz -, S) 135 | act : {Sz Tz : Bwd Ty} -> M Sz Tz -> {S : Ty} -> Tm Sz S -> Tm Tz S 136 | act m (var x) = varA m x 137 | act m <> = <> 138 | act m [] = [] 139 | act m (t ,- ts) = act m t ,- act m ts 140 | act m (foldr c n ts) = foldr (act m c) (act m n) (act m ts) 141 | act m (lam t) = lam (act (lamA m) t) 142 | act m (f $$ s) = act m f $$ act m s 143 | 144 | THIN : Action _<=_ 145 | Action.varA THIN th x = var (x , t = t 151 | Action.lamA SUBST tz = all (\ T -> Action.act THIN (o' oi)) _ tz , (var (os oe)) 152 | 153 | -- substitution 154 | -- thinning 155 | -- abstr-action 156 | 157 | -------------------------------------------------------------------------------- /lectures/cheat-sheet.txt: -------------------------------------------------------------------------------- 1 | ------------------------ 2 | Agda / Emacs Cheat Sheet 3 | ------------------------ 4 | 5 | This document will give you an overview of commonly used Agda, as well as Emacs, commands. 6 | 7 | C- = Ctrl 8 | M- = Alt/Esc 9 | buffer = file 10 | hole = place where an expression is expected. 11 | 12 | Emacs: 13 | ------ 14 | C-x C-f : find a file to load 15 | C-x C-s : Save buffer 16 | C-x C-c : Exit emacs 17 | 18 | C-s : Search forward for some text 19 | C-r : Search backward for some text 20 | C-/ : Undo 21 | C-a : Jump to start of the line 22 | C-e : Jump to end of the line 23 | M-< : Jump to top of the buffer 24 | M-> : Jump to end of the buffer 25 | M-} : Jump forwards a paragraph (blank line after block of text) 26 | M-{ : Jump backwards a paragraph 27 | 28 | Agda: 29 | ----- 30 | C-c C-l : Load (type check) the current buffer. 31 | C-c C-f : Jump (forward) to active hole 32 | C-c C-b : Jump (backward) to active hole 33 | C-c C-, : Show goal type, and context of current hole 34 | C-c C-. : Show goal type, context, and type of expression in the hole. 35 | C-c C-spc : Fill the hole with the given expression 36 | C-c C-r : Refine the hole 37 | C-c C-a : Search for a proof and fill it in the hole if there is at least 1. 38 | -l : list the possible proofs 39 | -s 10 -l : skip the first 10 proofs 40 | C-c C-c : Case split the given variable(s) into its possible constructors 41 | C-c C-n : Evaluate an expression 42 | C-c C-d : Infer a type for an expression 43 | 44 | C-c C-x C-d : Kill Agda - useful if agda gets a bit fussy 45 | (Can use C-c C-l to start Agda again when needed) 46 | C-c C-x C-r : Kill and restart Agda 47 | -------------------------------------------------------------------------------- /lectures/comedy.el: -------------------------------------------------------------------------------- 1 | (defun next-slide-please () 2 | (interactive) 3 | (search-forward "{---") 4 | (next-line) 5 | (recenter-top-bottom 0) 6 | ) 7 | (global-set-key "§" 'next-slide-please) 8 | 9 | (defun previous-slide-please () 10 | (interactive) 11 | (search-backward "{---") 12 | (previous-line) 13 | (search-backward "{---") 14 | (next-line) 15 | (recenter-top-bottom 0) 16 | ) 17 | (global-set-key "±" 'previous-slide-please) 18 | 19 | (defun comment-in-agda () 20 | (interactive) 21 | (search-forward "{-+}") 22 | (backward-delete-char 2) 23 | (insert-string "(-}") 24 | (search-forward "{+-}") 25 | (backward-delete-char 3) 26 | (insert-string "-)-}") 27 | (search-backward "{-(-}") 28 | (next-line) 29 | (agda2-load) 30 | ) 31 | (global-set-key [?\C-§] 'comment-in-agda) 32 | 33 | (defun comment-out-agda () 34 | (interactive) 35 | (search-backward "{-(-}") 36 | (forward-char 4) 37 | (backward-delete-char 2) 38 | (insert-string "+") 39 | (search-forward "-)-}") 40 | (backward-delete-char 4) 41 | (insert-string "+-}") 42 | (next-line) 43 | (agda2-load) 44 | ) 45 | (global-set-key [?\M-§] 'comment-out-agda) 46 | 47 | -------------------------------------------------------------------------------- /nowyoutry/Lec1Start.agda: -------------------------------------------------------------------------------- 1 | module Lec1Start where 2 | 3 | -- the -- mark introduces a "comment to end of line" 4 | 5 | 6 | ------------------------------------------------------------------------------ 7 | -- some basic "logical" types 8 | ------------------------------------------------------------------------------ 9 | 10 | data Zero : Set where 11 | -- to give a value in a data, choose one constructor 12 | -- there are no constructors 13 | -- so that's impossible 14 | 15 | record One : Set where 16 | -- to give a value in a record type, fill all its fields 17 | -- there are no fields 18 | -- so that's trivial 19 | -- (can we have a constructor, for convenience?) 20 | 21 | data _+_ (S : Set)(T : Set) : Set where -- "where" wants an indented block 22 | -- to offer a choice of constructors, list them with their types 23 | inl : S -> S + T -- constructors can pack up stuff 24 | inr : T -> S + T 25 | -- in Haskell, this was called "Either S T" 26 | 27 | record _*_ (S : Set)(T : Set) : Set where 28 | field -- introduces a bunch of fields, listed with their types 29 | fst : S 30 | snd : T 31 | -- in Haskell, this was called "(S, T)" 32 | 33 | ------------------------------------------------------------------------------ 34 | -- some simple proofs 35 | ------------------------------------------------------------------------------ 36 | 37 | {-+} 38 | comm-* : {A : Set}{B : Set} -> A * B -> B * A 39 | comm-* x = ? 40 | {+-} 41 | 42 | {-+} 43 | assocLR-+ : {A B C : Set} -> (A + B) + C -> A + (B + C) 44 | assocLR-+ x = ? 45 | {+-} 46 | 47 | {-+} 48 | _$*_ : {A A' B B' : Set} -> (A -> A') -> (B -> B') -> A * B -> A' * B' 49 | (f $* g) x = r? 50 | {+-} 51 | 52 | -- record syntax is rather ugly for small stuff; can we have constructors? 53 | 54 | {-+} 55 | _$+_ : {A A' B B' : Set} -> (A -> A') -> (B -> B') -> A + B -> A' + B' 56 | (f $+ g) x = ? 57 | {+-} 58 | 59 | {-+} 60 | combinatorK : {A E : Set} -> A -> E -> A 61 | combinatorK = ? 62 | 63 | combinatorS : {S T E : Set} -> (E -> S -> T) -> (E -> S) -> E -> T 64 | combinatorS = ? 65 | {+-} 66 | 67 | {-+} 68 | id : {X : Set} -> X -> X 69 | -- id x = x -- is the easy way; let's do it a funny way to make a point 70 | id = ? 71 | {+-} 72 | 73 | {-+} 74 | naughtE : {X : Set} -> Zero -> X 75 | naughtE x = ? 76 | {+-} 77 | 78 | 79 | ------------------------------------------------------------------------------ 80 | -- from logic to data 81 | ------------------------------------------------------------------------------ 82 | 83 | data Nat : Set where 84 | zero : Nat 85 | suc : Nat -> Nat -- recursive data type 86 | 87 | {-# BUILTIN NATURAL Nat #-} 88 | -- ^^^^^^^^^^^^^^^^^^^ this pragma lets us use decimal notation 89 | 90 | {-+} 91 | _+N_ : Nat -> Nat -> Nat 92 | x +N y = ? 93 | 94 | four : Nat 95 | four = 2 +N 2 96 | {+-} 97 | 98 | 99 | ------------------------------------------------------------------------------ 100 | -- and back to logic 101 | ------------------------------------------------------------------------------ 102 | 103 | {-+} 104 | data _==_ {X : Set} : X -> X -> Set where 105 | refl : (x : X) -> x == x -- the relation that's "only reflexive" 106 | 107 | {-# BUILTIN EQUALITY _==_ #-} -- we'll see what that's for, later 108 | 109 | _=$=_ : {X Y : Set}{f f' : X -> Y}{x x' : X} -> 110 | f == f' -> x == x' -> f x == f' x' 111 | fq =$= xq = ? 112 | {+-} 113 | 114 | {-+} 115 | zero-+N : (n : Nat) -> (zero +N n) == n 116 | zero-+N n = ? 117 | 118 | +N-zero : (n : Nat) -> (n +N zero) == n 119 | +N-zero n = ? 120 | 121 | assocLR-+N : (x y z : Nat) -> ((x +N y) +N z) == (x +N (y +N z)) 122 | assocLR-+N x y z = ? 123 | {+-} 124 | 125 | ------------------------------------------------------------------------------ 126 | -- computing types 127 | ------------------------------------------------------------------------------ 128 | 129 | {-+} 130 | _>=_ : Nat -> Nat -> Set 131 | x >= zero = One 132 | zero >= suc y = Zero 133 | suc x >= suc y = x >= y 134 | 135 | refl->= : (n : Nat) -> n >= n 136 | refl->= n = {!!} 137 | 138 | trans->= : (x y z : Nat) -> x >= y -> y >= z -> x >= z 139 | trans->= x y z x>=y y>=z = {!!} 140 | {+-} 141 | 142 | 143 | ------------------------------------------------------------------------------ 144 | -- construction by proof 145 | ------------------------------------------------------------------------------ 146 | 147 | {-+} 148 | record Sg (S : Set)(T : S -> Set) : Set where -- Sg is short for "Sigma" 149 | constructor _,_ 150 | field -- introduces a bunch of fields, listed with their types 151 | fst : S 152 | snd : T fst 153 | -- make _*_ from Sg ? 154 | 155 | difference : (m n : Nat) -> m >= n -> Sg Nat \ d -> m == (n +N d) 156 | -- ( ) 157 | difference m zero m>=n = m , refl m 158 | difference zero (suc n) () 159 | difference (suc m) (suc n) m>=n with difference m n m>=n 160 | difference (suc m) (suc n) m>=n | d , q = d , (refl suc =$= q) 161 | 162 | tryMe = difference 42 37 _ 163 | don'tTryMe = difference 37 42 {!!} 164 | {+-} 165 | 166 | ------------------------------------------------------------------------------ 167 | -- things to remember to say 168 | ------------------------------------------------------------------------------ 169 | 170 | -- why the single colon? 171 | 172 | -- what's with all the spaces? 173 | 174 | -- what's with identifiers mixing letters and symbols? 175 | 176 | -- what's with all the braces? 177 | 178 | -- what is Set? 179 | 180 | -- are there any lowercase/uppercase conventions? 181 | 182 | -- what's with all the underscores? 183 | -- (i) placeholders in mixfix operators 184 | -- (ii) don't care (on the left) 185 | -- (iii) go figure (on the right) 186 | 187 | -- why use arithmetic operators for types? 188 | 189 | -- what's the difference between = and == ? 190 | 191 | -- can't we leave out cases? 192 | 193 | -- can't we loop? 194 | 195 | -- the function type is both implication and universal quantification, 196 | -- but why is it called Pi? 197 | 198 | -- why is Sigma called Sigma? 199 | 200 | -- B or nor B? 201 | -------------------------------------------------------------------------------- /nowyoutry/Lec2Start.agda: -------------------------------------------------------------------------------- 1 | module Lec2Start where 2 | 3 | open import Lec1Done 4 | 5 | 6 | ------------------------------------------------------------------------------ 7 | -- Vectors -- the star of exercise 1 8 | ------------------------------------------------------------------------------ 9 | 10 | data Vec (X : Set) : Nat -> Set where -- like lists, but length-indexed 11 | [] : Vec X zero 12 | _,-_ : {n : Nat} -> X -> Vec X n -> Vec X (suc n) 13 | infixr 4 _,-_ -- the "cons" operator associates to the right 14 | 15 | 16 | ------------------------------------------------------------------------------ 17 | -- Taking a Prefix of a Vector 18 | ------------------------------------------------------------------------------ 19 | 20 | {-+} 21 | vTake : (m n : Nat) -> m >= n -> {X : Set} -> Vec X m -> Vec X n 22 | vTake m n m>=n xs = {!!} 23 | {+-} 24 | 25 | ------------------------------------------------------------------------------ 26 | -- Things to Prove 27 | ------------------------------------------------------------------------------ 28 | 29 | {-+} 30 | vTakeIdFact : (n : Nat){X : Set}(xs : Vec X n) -> 31 | vTake n n (refl->= n) xs == xs 32 | vTakeIdFact n xs = {!!} 33 | 34 | vTakeCpFact : (m n p : Nat)(m>=n : m >= n)(n>=p : n >= p) 35 | {X : Set}(xs : Vec X m) -> 36 | vTake m p (trans->= m n p m>=n n>=p) xs == 37 | vTake n p n>=p (vTake m n m>=n xs) 38 | {- hit p first: why? -} 39 | vTakeCpFact m n p m>=n n>=p xs = {!!} 40 | {+-} 41 | 42 | ------------------------------------------------------------------------------ 43 | -- Splittings (which bear some relationship to <= from ex1) 44 | ------------------------------------------------------------------------------ 45 | 46 | data _<[_]>_ : Nat -> Nat -> Nat -> Set where 47 | zzz : zero <[ zero ]> zero 48 | lll : {l m r : Nat} -> l <[ m ]> r 49 | -> suc l <[ suc m ]> r 50 | rrr : {l m r : Nat} -> l <[ m ]> r 51 | -> l <[ suc m ]> suc r 52 | 53 | {-+} 54 | _>[_]<_ : {X : Set}{l m r : Nat} -> 55 | Vec X l -> l <[ m ]> r -> Vec X r -> 56 | Vec X m 57 | xl >[ nnn ]< xr = {!!} 58 | {+-} 59 | 60 | {-+} 61 | data FindSplit {X : Set}{l m r : Nat}(nnn : l <[ m ]> r) 62 | : (xs : Vec X m) -> Set where 63 | splitBits : (xl : Vec X l)(xr : Vec X r) -> FindSplit nnn (xl >[ nnn ]< xr) 64 | {+-} 65 | 66 | {-+} 67 | findSplit : {X : Set}{l m r : Nat}(nnn : l <[ m ]> r)(xs : Vec X m) -> 68 | FindSplit nnn xs 69 | findSplit nnn xs = {!!} 70 | {+-} 71 | 72 | 73 | ------------------------------------------------------------------------------ 74 | -- what I should remember to say 75 | ------------------------------------------------------------------------------ 76 | 77 | -- What's the difference between m>=n and m >= n ? 78 | {- m>=n (without spaces) is just an identifier; it could be anything, 79 | but it has been chosen to be suggestive of its *type* which is 80 | m >= n (with spaces) which is the proposition that m is at least n. 81 | By "proposition", I mean "type with at most one inhabitant", where 82 | we care more about whether there is an inhabitant or not than which 83 | one (because there's never a choice). Finished code does not show 84 | us the types of its components, and that's not always a good thing. 85 | Here, by picking nice names, we get something of an aide-memoire. -} 86 | 87 | -- What does (x ,-_) mean? 88 | {- It's a "left section". Right sections (_,- xs) also exist sometimes. 89 | Why only sometimes? -} 90 | 91 | -- "Why is it stuck?" 92 | {- Proof by induction isn't just flailing about, you know? The trick is 93 | to pick the case analysis that provokes the "stuck" programs to do a 94 | step of computation. Then the same reasoning that justifies the 95 | termination of the program will justify the induction in a proof 96 | about it. -} 97 | 98 | -------------------------------------------------------------------------------- /nowyoutry/Lec3Start.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} -- yes, there will be some cheating in this lecture 2 | 3 | module Lec3Start where 4 | 5 | open import Lec1Done 6 | open import Lec2Done 7 | 8 | postulate 9 | extensionality : {S : Set}{T : S -> Set} 10 | (f g : (x : S) -> T x) -> 11 | ((x : S) -> f x == g x) -> 12 | f == g 13 | 14 | record Category : Set where 15 | field 16 | 17 | -- two types of thing 18 | Obj : Set -- "objects" 19 | _~>_ : Obj -> Obj -> Set -- "arrows" or "morphisms" 20 | -- or "homomorphisms" 21 | 22 | -- two operations 23 | id~> : {T : Obj} -> T ~> T 24 | _>~>_ : {R S T : Obj} -> R ~> S -> S ~> T -> R ~> T 25 | 26 | -- three laws 27 | law-id~>>~> : {S T : Obj} (f : S ~> T) -> 28 | (id~> >~> f) == f 29 | law->~>id~> : {S T : Obj} (f : S ~> T) -> 30 | (f >~> id~>) == f 31 | law->~>>~> : {Q R S T : Obj} (f : Q ~> R)(g : R ~> S)(h : S ~> T) -> 32 | ((f >~> g) >~> h) == (f >~> (g >~> h)) 33 | 34 | -- Sets and functions are the classic example of a category. 35 | {-+} 36 | SET : Category 37 | SET = {!!} 38 | {+-} 39 | 40 | -- A PREORDER is a category where there is at most one arrow between 41 | -- any two objects. (So arrows are unique.) 42 | {-+} 43 | NAT->= : Category 44 | NAT->= = {!!} where 45 | unique : (m n : Nat)(p q : m >= n) -> p == q 46 | unique m n p q = {!!} 47 | {+-} 48 | 49 | -- A MONOID is a category with Obj = One. 50 | -- The values in the monoid are the *arrows*. 51 | {-+} 52 | ONE-Nat : Category 53 | ONE-Nat = {!!} 54 | {+-} 55 | 56 | {-+} 57 | eqUnique : {X : Set}{x y : X}(p q : x == y) -> p == q 58 | eqUnique p q = {!!} 59 | 60 | -- A DISCRETE category is one where the only arrows are the identities. 61 | DISCRETE : (X : Set) -> Category 62 | DISCRETE X = {!!} 63 | {+-} 64 | 65 | 66 | 67 | module FUNCTOR where 68 | open Category 69 | 70 | record _=>_ (C D : Category) : Set where -- "Functor from C to D" 71 | field 72 | -- two actions 73 | F-Obj : Obj C -> Obj D 74 | F-map : {S T : Obj C} -> _~>_ C S T -> _~>_ D (F-Obj S) (F-Obj T) 75 | 76 | -- two laws 77 | F-map-id~> : {T : Obj C} -> F-map (id~> C {T}) == id~> D {F-Obj T} 78 | F-map->~> : {R S T : Obj C}(f : _~>_ C R S)(g : _~>_ C S T) -> 79 | F-map (_>~>_ C f g) == _>~>_ D (F-map f) (F-map g) 80 | 81 | open FUNCTOR 82 | 83 | {-+} 84 | VEC : Nat -> SET => SET 85 | VEC n = {!!} 86 | {+-} 87 | 88 | {-+} 89 | VTAKE : Set -> NAT->= => SET 90 | VTAKE X = {!!} 91 | {+-} 92 | 93 | {-+} 94 | ADD : Nat -> NAT->= => NAT->= 95 | ADD d = {!!} 96 | {+-} 97 | 98 | {-+} 99 | CATEGORY : Category 100 | CATEGORY = {!!} 101 | {+-} 102 | --------------------------------------------------------------------------------