├── .gitignore ├── Lib ├── Indexed.agda ├── Cat │ ├── ArrowFunctor.agda │ ├── Adjunction.agda │ ├── Category.agda │ ├── ProductCat.agda │ ├── Functor.agda │ ├── NatTrans.agda │ ├── Free.agda │ ├── FreePrime.agda │ ├── Solver.agda │ └── Monad.agda ├── Vec.agda ├── Nat.agda ├── ANSIEscapes.hs ├── Basics.agda ├── HaskellSetup.hs └── Display.agda ├── Lecture ├── Six.hs ├── One.agda ├── Three.agda ├── Two.agda ├── Seven.agda ├── Five.agda ├── Eight.agda ├── SixPrime.agda ├── Six.agda └── Four.agda ├── README.md └── Exercise ├── One.agda └── Two.agda /.gitignore: -------------------------------------------------------------------------------- 1 | *.agdai 2 | -------------------------------------------------------------------------------- /Lib/Indexed.agda: -------------------------------------------------------------------------------- 1 | module Lib.Indexed where 2 | 3 | open import Lib.Basics 4 | 5 | _:*:_ : {I : Set}(S T : I -> Set) -> I -> Set 6 | (S :*: T) i = S i * T i 7 | infixr 20 _:*:_ 8 | 9 | _-:>_ : {I : Set}(S T : I -> Set) -> I -> Set 10 | (S -:> T) i = S i -> T i 11 | infixr 10 _-:>_ 12 | 13 | [_] : forall {I : Set} -> (I -> Set) -> Set 14 | [ X ] = forall i -> X i 15 | -------------------------------------------------------------------------------- /Lecture/Six.hs: -------------------------------------------------------------------------------- 1 | module Lecture.Six where 2 | 3 | type F x = x -> x 4 | 5 | data Bad = MkBad (F Bad) 6 | 7 | -- MkBad :: (Bad -> Bad) -> Bad 8 | 9 | instance Show Bad where 10 | show (MkBad f) = "MkBad..." 11 | 12 | 13 | bad :: Bad -> Bad 14 | bad (MkBad f) = f (MkBad f) 15 | 16 | app :: Bad -> Bad -> Bad 17 | app (MkBad f) x = f x 18 | 19 | omega :: Bad 20 | omega = bad (MkBad bad) -------------------------------------------------------------------------------- /Lib/Cat/ArrowFunctor.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type --no-unicode #-} 2 | {-# OPTIONS --allow-unsolved-metas #-} 3 | module Lib.Cat.ArrowFunctor where 4 | 5 | open import Lib.Basics 6 | open import Lib.Cat.Category 7 | open import Lib.Cat.Functor 8 | open import Lib.Cat.ProductCat 9 | open import Lib.Cat.Solver 10 | 11 | 12 | ARROWS : {Obj : Set}{Arr : Obj -> Obj -> Set}(C : Category Arr) -> 13 | Functor ((C ^op) *Cat C) SET \ { (X , Y) -> Arr X Y } 14 | Functor.map (ARROWS C) {A = (X , X')} {B = (Y , Y')} (f , g) h = f -arr- h -arr- g where open Category C 15 | Functor.mapidArr (ARROWS C) = ext \ h -> 16 | [=IN C ! 17 | idSyn -syn- < h > -syn- idSyn 18 | =[[ categories refl >>= 19 | < h > 20 | [[QED]] 21 | =] 22 | Functor.map-arr- (ARROWS C) (f , f') (g , g') = ext \ h -> 23 | [=IN C ! 24 | (< g > -syn- < f >) -syn- (< h > -syn- < f' > -syn- < g' >) 25 | =[[ categories refl >>= 26 | < g > -syn- (< f > -syn- < h > -syn- < f' >) -syn- < g' > 27 | [[QED]] 28 | =] 29 | 30 | 31 | {- 32 | 33 | [=IN C ! 34 | idSyn -syn- (< h > -syn- idSyn) 35 | =[[ categories refl >>= 36 | < h > 37 | [[QED]] 38 | =] 39 | -} 40 | -------------------------------------------------------------------------------- /Lib/Vec.agda: -------------------------------------------------------------------------------- 1 | module Lib.Vec where 2 | 3 | open import Lib.Basics 4 | open import Lib.Nat 5 | 6 | data Vec (X : Set) : Nat -> Set where 7 | [] : Vec X zero 8 | _,-_ : forall {n} -> X -> Vec X n -> Vec X (suc n) 9 | 10 | vPure : {n : Nat}{X : Set} -> X -> Vec X n 11 | vPure {zero} x = [] 12 | vPure {suc n} x = x ,- vPure x 13 | 14 | _<*V>_ : forall {n}{X Y : Set} -> Vec (X -> Y) n -> Vec X n -> Vec Y n 15 | [] <*V> [] = [] 16 | (f ,- fs) <*V> (x ,- xs) = f x ,- fs <*V> xs 17 | infixl 80 _<*V>_ 18 | 19 | vec : forall {n}{X Y : Set} -> (X -> Y) -> Vec X n -> Vec Y n 20 | vec = vPure - _<*V>_ 21 | 22 | _+V_ : {X : Set}{m n : Nat} -> Vec X m -> Vec X n -> Vec X (m +N n) 23 | [] +V ys = ys 24 | (x ,- xs) +V ys = x ,- (xs +V ys) 25 | 26 | data Choppable {X : Set}(m n : Nat) : Vec X (m +N n) -> Set where 27 | choppable : (xs : Vec X m) -> (ys : Vec X n) -> Choppable m n (xs +V ys) 28 | 29 | chop : {X : Set}(m n : Nat) -> (xs : Vec X (m +N n)) -> Choppable m n xs 30 | chop zero n xs = choppable [] xs 31 | chop (suc m) n (x ,- xs) with chop m n xs 32 | chop (suc m) n (x ,- .(xs +V ys)) | choppable xs ys = choppable (x ,- xs) ys 33 | 34 | Matrix : Set -> Nat * Nat -> Set 35 | Matrix C (w , h) = Vec (Vec C w) h 36 | 37 | vecFoldR : {X Y : Set} -> (X -> Y -> Y) -> Y -> {n : Nat} -> Vec X n -> Y 38 | vecFoldR c n [] = n 39 | vecFoldR c n (x ,- xs) = c x (vecFoldR c n xs) 40 | -------------------------------------------------------------------------------- /Lib/Nat.agda: -------------------------------------------------------------------------------- 1 | module Lib.Nat where 2 | 3 | open import Lib.Basics 4 | 5 | data Nat : Set where 6 | zero : Nat 7 | suc : Nat -> Nat 8 | 9 | -- data Nat = Zero | Suc Nat 10 | 11 | {-# BUILTIN NATURAL Nat #-} 12 | 13 | ------------------------------------------------------------------------------ 14 | 15 | _+N_ : Nat -> Nat -> Nat 16 | zero +N n = n 17 | suc m +N n = suc (m +N n) 18 | 19 | infixr 60 _+N_ 20 | 21 | 22 | assoc+N : (m n k : Nat) -> (m +N n) +N k == m +N (n +N k) 23 | assoc+N zero n k = 24 | (zero +N n) +N k 25 | =[ refl >= 26 | n +N k 27 | =[ refl >= 28 | n +N k 29 | =< refl ]= 30 | zero +N (n +N k) 31 | [QED] 32 | assoc+N (suc m) n k = 33 | (suc m +N n) +N k 34 | =[ suc $= assoc+N m n k >= 35 | suc m +N n +N k 36 | [QED] 37 | -- suc $= assoc+N m n k 38 | 39 | _+Nzero : ∀ n → n +N 0 == n 40 | zero +Nzero = refl 41 | suc n +Nzero = suc $= (n +Nzero) 42 | 43 | _+Nsuc_ : (n m : _) → n +N suc m == suc (n +N m) 44 | zero +Nsuc m = refl 45 | suc n +Nsuc m = suc $= (n +Nsuc m) 46 | 47 | comm+N : (m n : Nat) -> m +N n == n +N m 48 | comm+N zero n = sym (n +Nzero) 49 | comm+N (suc m) n = 50 | suc (m +N n) 51 | =[ suc $= comm+N m n >= 52 | suc (n +N m) 53 | =< n +Nsuc m ]= 54 | n +N suc m 55 | [QED] 56 | 57 | _<=_ : Nat -> Nat -> Set 58 | zero <= y = One 59 | suc x <= zero = Zero 60 | suc x <= suc y = x <= y 61 | -------------------------------------------------------------------------------- /Lib/Cat/Adjunction.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type --no-unicode #-} 2 | module Lib.Cat.Adjunction where 3 | 4 | open import Lib.Basics 5 | open import Lib.Cat.Category 6 | open import Lib.Cat.Functor 7 | open import Lib.Cat.NatTrans 8 | open import Lib.Cat.ProductCat 9 | open import Lib.Cat.ArrowFunctor 10 | 11 | record Adjunction 12 | {ObjC : Set}{ArrC : ObjC -> ObjC -> Set}{CatC : Category ArrC} 13 | {ObjD : Set}{ArrD : ObjD -> ObjD -> Set}{CatD : Category ArrD} 14 | {ObjF : ObjC -> ObjD}(F : Functor CatC CatD ObjF) 15 | {ObjG : ObjD -> ObjC}(G : Functor CatD CatC ObjG) 16 | : Set where 17 | open Functor 18 | open NaturalTransformation 19 | field 20 | down : NaturalTransformation 21 | (((F ^opFun) *Fun (ID CatD)) -Func- (ARROWS CatD)) 22 | ((((ID CatC) ^opFun) *Fun G) -Func- (ARROWS CatC)) 23 | up : NaturalTransformation 24 | ((((ID CatC) ^opFun) *Fun G) -Func- (ARROWS CatC)) 25 | (((F ^opFun) *Fun (ID CatD)) -Func- (ARROWS CatD)) 26 | updown : {X : ObjC}{B : ObjD}{h : ArrC X (ObjG B)} -> 27 | transform down _ (transform up _ h) == h 28 | downup : {A : ObjC}{Y : ObjD}{h' : ArrD (ObjF A) Y} -> 29 | transform up _ (transform down _ h') == h' 30 | 31 | -- forall X : ObjC, B : ObjD. 32 | -- 33 | -- F X --> B 34 | -- ============ 35 | -- X --> G B 36 | 37 | -- Notation: F ⊣ G, "F is left adjoint to G" or eq. "G is right adjoint to F" 38 | -------------------------------------------------------------------------------- /Lecture/One.agda: -------------------------------------------------------------------------------- 1 | module Lecture.One where 2 | 3 | data Nat : Set where 4 | zero : Nat 5 | suc : Nat -> Nat 6 | 7 | -- data Nat = Zero | Suc Nat 8 | 9 | {-# BUILTIN NATURAL Nat #-} 10 | 11 | data Two : Set where 12 | ff : Two 13 | tt : Two 14 | 15 | record One : Set where 16 | constructor <> 17 | 18 | data Zero : Set where 19 | 20 | {- 21 | _<=_ : Nat -> Nat -> Two 22 | zero <= y = tt 23 | suc x <= zero = ff 24 | suc x <= suc y = x <= y 25 | -} 26 | 27 | _<=_ : Nat -> Nat -> Set 28 | zero <= y = One 29 | suc x <= zero = Zero 30 | suc x <= suc y = x <= y 31 | 32 | foo : 5 <= 7 33 | foo = <> 34 | 35 | goo : 7 <= 5 -> {X : Set} -> X 36 | goo () 37 | 38 | data _+_ (S T : Set) : Set where 39 | inl : S -> S + T 40 | inr : T -> S + T 41 | 42 | owoto : (x : Nat) -> (y : Nat) -> (x <= y) + (y <= x) 43 | owoto zero y = inl <> 44 | owoto (suc x) zero = inr <> 45 | owoto (suc x) (suc y) = owoto x y 46 | 47 | magic : {A : Set} -> Zero -> A 48 | magic () 49 | 50 | data Bound : Set where 51 | bot : Bound 52 | val : Nat -> Bound 53 | top : Bound 54 | 55 | _ Bound -> Set 56 | bot BST l (val x) -> BST (val x) u -> BST l u 63 | leaf : l BST l u 64 | 65 | insert : {l u : Bound} -> (y : Nat) -> l val y BST l u -> BST l u 66 | insert y ly yu (node x lx xu) with owoto y x 67 | insert y ly yu (node x lx xu) | inl yx = node x (insert y ly yx lx) xu 68 | insert y ly yu (node x lx xu) | inr xy = node x lx (insert y xy yu xu) 69 | insert y ly yu (leaf p) = node y (leaf ly) (leaf yu) 70 | -------------------------------------------------------------------------------- /Lecture/Three.agda: -------------------------------------------------------------------------------- 1 | module Lecture.Three where 2 | 3 | open import Lib.Basics 4 | open import Lib.Nat 5 | 6 | -- Sigma 7 | 8 | open import Lib.Vec 9 | 10 | ex1 : Sg Nat (λ n → Vec Two n) 11 | ex1 = 2 , (ff ,- (ff ,- [])) 12 | 13 | ex2 : Nat 14 | ex2 = fst ex1 15 | 16 | ex3 : Vec Two (ex1 .fst) 17 | ex3 = snd ex1 18 | 19 | _+'_ : Set -> Set -> Set 20 | S +' T = Sg Two λ { ff → S ; tt → T } 21 | 22 | -- inl' : {S T : Set} -> S -> S +' T 23 | pattern inl' s = ff , s 24 | 25 | -- inr' : {S T : Set} -> T -> S +' T 26 | pattern inr' t = tt , t 27 | 28 | swap : {S T : Set} -> S +' T -> T +' S 29 | swap (inl' s) = inr' s 30 | swap (inr' t) = inl' t 31 | 32 | -- list2vec 33 | 34 | list2Vec : {X : Set} -> List X -> Sg Nat \ n -> Vec X n 35 | list2Vec [] = _ , [] 36 | list2Vec (x ,- xs) with list2Vec xs 37 | list2Vec (x ,- xs) | _ , xs' = _ , (x ,- xs') 38 | 39 | -- equality 40 | 41 | -- equational reasoning combinators 42 | 43 | assoc : (m n k : Nat) -> (m +N n) +N k == m +N (n +N k) 44 | assoc zero n k = 45 | (zero +N n) +N k 46 | =[ refl >= 47 | n +N k 48 | =[ refl >= 49 | n +N k 50 | =< refl ]= 51 | zero +N (n +N k) 52 | [QED] 53 | assoc (suc m) n k = 54 | (suc m +N n) +N k 55 | =[ suc $= assoc m n k >= 56 | suc m +N n +N k 57 | [QED] 58 | -- suc $= assoc m n k 59 | 60 | {- moved to Lib.nat 61 | _+Nzero : ∀ n → n +N 0 == n 62 | zero +Nzero = refl 63 | suc n +Nzero = suc $= (n +Nzero) 64 | 65 | _+Nsuc_ : (n m : _) → n +N suc m == suc (n +N m) 66 | zero +Nsuc m = refl 67 | suc n +Nsuc m = suc $= (n +Nsuc m) 68 | -} 69 | 70 | comm : (m n : Nat) -> m +N n == n +N m 71 | comm zero n = sym (n +Nzero) 72 | comm (suc m) n = 73 | suc (m +N n) 74 | =[ suc $= comm m n >= 75 | suc (n +N m) 76 | =< n +Nsuc m ]= 77 | n +N suc m 78 | [QED] 79 | -------------------------------------------------------------------------------- /Lib/Cat/Category.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type --no-unicode #-} 2 | module Lib.Cat.Category where 3 | 4 | open import Lib.Basics 5 | 6 | postulate 7 | ext : {S : Set}{T : S -> Set}{f g : (x : S) -> T x} -> 8 | ((x : S) -> f x == g x) -> f == g 9 | 10 | record Category {Obj : Set}(Arr : Obj -> Obj -> Set) : Set where 11 | field 12 | -- structure 13 | idArr : {X : Obj} -> Arr X X 14 | _-arr-_ : {R S T : Obj} -> Arr R S -> Arr S T -> Arr R T 15 | -- laws 16 | .idArr-arr- : {S T : Obj}(f : Arr S T) -> (idArr -arr- f) == f 17 | ._-arr-idArr : {S T : Obj}(f : Arr S T) -> (f -arr- idArr) == f 18 | .assoc-arr- : {R S T U : Obj} 19 | (f : Arr R S)(g : Arr S T)(h : Arr T U) -> 20 | ((f -arr- g) -arr- h) == (f -arr- (g -arr- h)) 21 | infixr 20 _-arr-_ 22 | 23 | SomeCategory : Set 24 | SomeCategory = Sg Set \ Obj -> 25 | Sg (Obj -> Obj -> Set) \ Arr -> 26 | Category Arr 27 | 28 | _^op : forall {Obj}{Arr : Obj -> Obj -> Set} -> 29 | Category Arr -> Category \ S T -> Arr T S 30 | C ^op = record 31 | { idArr = idArr 32 | ; _-arr-_ = \ g f -> f -arr- g 33 | ; idArr-arr- = \ f -> f -arr-idArr 34 | ; _-arr-idArr = \ f -> idArr-arr- f 35 | ; assoc-arr- = \ f g h -> sym (assoc-arr- h g f) 36 | } 37 | where open Category C 38 | 39 | SET : Category \ S T -> S -> T 40 | SET = record 41 | { idArr = id 42 | ; _-arr-_ = \ f g -> f - g 43 | ; idArr-arr- = \ f -> refl 44 | ; _-arr-idArr = \ f -> refl 45 | ; assoc-arr- = \ f g h -> refl 46 | } 47 | 48 | module _ where 49 | open Category 50 | 51 | DISCRETE : (X : Set) -> Category {X} _==_ 52 | idArr (DISCRETE X) = refl 53 | _-arr-_ (DISCRETE X) refl refl = refl 54 | idArr-arr- (DISCRETE X) refl = refl 55 | _-arr-idArr (DISCRETE X) refl = refl 56 | assoc-arr- (DISCRETE X) refl refl refl = refl 57 | -------------------------------------------------------------------------------- /Lib/ANSIEscapes.hs: -------------------------------------------------------------------------------- 1 | module Lib.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 -------------------------------------------------------------------------------- /Lib/Cat/ProductCat.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type --no-unicode #-} 2 | --{-# OPTIONS --irrelevant-projections #-} 3 | module Lib.Cat.ProductCat where 4 | 5 | open import Lib.Basics 6 | open import Lib.Cat.Category 7 | open import Lib.Cat.Functor 8 | 9 | _*Cat_ : {ObjS : Set}{ArrS : ObjS -> ObjS -> Set}(CatS : Category ArrS) 10 | {ObjT : Set}{ArrT : ObjT -> ObjT -> Set}(CatT : Category ArrT) -> 11 | Category {ObjS * ObjT} \ {(SS , TS) (ST , TT) -> 12 | ArrS SS ST * ArrT TS TT} 13 | CatS *Cat CatT = 14 | record 15 | { idArr = (S.idArr , T.idArr) 16 | ; _-arr-_ = \ { (fS , fT) (gS , gT) -> (fS S.-arr- gS) , (fT T.-arr- gT) } 17 | ; idArr-arr- = \ { {AS , AT} {BS , BT} (fS , fT) -> 18 | reff _,_ =$= (Category.idArr-arr- CatS fS) =$= (Category.idArr-arr- CatT fT) } 19 | ; _-arr-idArr = \ { {AS , AT} {BS , BT} (fS , fT) -> 20 | reff _,_ =$= (Category._-arr-idArr CatS fS) =$= (Category._-arr-idArr CatT fT) } 21 | ; assoc-arr- = \ { (fS , fT) (gS , gT) (hS , hT) -> reff _,_ =$= Category.assoc-arr- CatS fS gS hS =$= Category.assoc-arr- CatT fT gT hT } 22 | } 23 | where 24 | module S = Category CatS 25 | module T = Category CatT 26 | 27 | module _ 28 | {ObjS : Set}{ArrS : ObjS -> ObjS -> Set}{CatS : Category ArrS} 29 | {ObjT : Set}{ArrT : ObjT -> ObjT -> Set}{CatT : Category ArrT} 30 | {ObjF : ObjS -> ObjT}(F : Functor CatS CatT ObjF) 31 | {ObjS' : Set}{ArrS' : ObjS' -> ObjS' -> Set}{CatS' : Category ArrS'} 32 | {ObjT' : Set}{ArrT' : ObjT' -> ObjT' -> Set}{CatT' : Category ArrT'} 33 | {ObjF' : ObjS' -> ObjT'}(F' : Functor CatS' CatT' ObjF') 34 | where 35 | private 36 | module F = Functor F 37 | module F' = Functor F' 38 | open Functor 39 | 40 | _*Fun_ : 41 | Functor (CatS *Cat CatS') (CatT *Cat CatT') 42 | \ { (S , S') -> (ObjF S , ObjF' S') } 43 | map _*Fun_ (f , f') = (F.map f) , (F'.map f') 44 | mapidArr _*Fun_ = reff _,_ =$= F.mapidArr =$= F'.mapidArr 45 | map-arr- _*Fun_ (f , f') (g , g') = 46 | reff _,_ =$= F.map-arr- f g =$= F'.map-arr- f' g' 47 | -------------------------------------------------------------------------------- /Lecture/Two.agda: -------------------------------------------------------------------------------- 1 | module Lecture.Two where 2 | 3 | open import Lib.Basics 4 | 5 | open import Lib.Nat 6 | 7 | -- VECTORS 8 | 9 | open import Lib.Vec 10 | 11 | -- 2018-10-04: This definition has moved to the library 12 | -- data Vec (X : Set) : Nat -> Set where 13 | -- [] : Vec X zero 14 | -- _,-_ : forall {n} -> X -> Vec X n -> Vec X (suc n) 15 | 16 | 17 | ex : Vec Nat 2 18 | ex = 37 ,- 5 ,- [] 19 | 20 | -- head 21 | 22 | head : {X : Set}{n : Nat} -> Vec X (suc n) -> X 23 | head (x ,- xs) = x 24 | {- 25 | -- head {X} [] = {!!} 26 | head (x ,- xs) = x 27 | -} 28 | 29 | -- ex2 = head {Zero} [] 30 | 31 | -- tail 32 | tail : {X : Set}{n : Nat} -> Vec X (suc n) -> Vec X n 33 | tail (x ,- xs) = xs 34 | 35 | -- applicative structure 36 | 37 | pure : {n : Nat} -> {X : Set} -> X -> Vec X n 38 | pure {zero} x = [] 39 | pure {suc n} x = x ,- pure {n} x 40 | 41 | _<*>_ : {n : Nat}{S T : Set} -> 42 | Vec (S -> T) n -> Vec S n -> Vec T n 43 | [] <*> [] = [] 44 | (f ,- fs) <*> (s ,- ss) = f s ,- (fs <*> ss) 45 | 46 | infixl 30 _<*>_ 47 | 48 | -- map 49 | 50 | map : {n : Nat}{S T : Set} -> 51 | (S -> T) -> Vec S n -> Vec T n 52 | map f ss = pure f <*> ss 53 | 54 | -- zip 55 | 56 | zip : {n : Nat}{S T : Set} -> 57 | Vec S n -> Vec T n -> Vec (S * T) n 58 | zip ss ts = pure (_,_) <*> ss <*> ts 59 | 60 | ex3 : Nat * Nat 61 | ex3 = 6 , 7 62 | 63 | -- +V (necessitating what?) 64 | 65 | -- what should the type of vector concatenation be? 66 | 67 | -- 2018-10-04: This definition has moved to the library 68 | -- _+N_ : Nat -> Nat -> Nat 69 | -- zero +N n = n 70 | -- suc m +N n = suc (m +N n) 71 | 72 | 73 | _+V_ : {X : Set}{m n : Nat} -> Vec X m -> Vec X n -> Vec X (m +N n) 74 | [] +V ys = ys 75 | (x ,- xs) +V ys = x ,- (xs +V ys) 76 | 77 | -- +V backwards 78 | 79 | -- the graph of _+N_ (not needed for this problem) 80 | 81 | data Add : Nat -> Nat -> Nat -> Set where 82 | zero : {n : Nat} -> Add zero n n 83 | suc : {m n k : Nat} -> Add m n k -> Add (suc m) n (suc k) 84 | 85 | 86 | data Choppable {X : Set}(m n : Nat) : Vec X (m +N n) -> Set where 87 | choppable : (xs : Vec X m) -> (ys : Vec X n) -> Choppable m n (xs +V ys) 88 | 89 | chop : {X : Set}(m n : Nat) -> (xs : Vec X (m +N n)) -> Choppable m n xs 90 | chop zero n xs = choppable [] xs 91 | chop (suc m) n (x ,- xs) with chop m n xs 92 | chop (suc m) n (x ,- .(xs +V ys)) | choppable xs ys = choppable (x ,- xs) ys 93 | 94 | 95 | -- Sg and list2Vec 96 | 97 | -- zip backwards? 98 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # CS410-18 2 | being the lecture materials and exercises for the 2018/19 session of CS410 Advanced Functional Programming at the University of Strathclyde 3 | 4 | ## Installation instructions 5 | 0. Check if you're using bash 6 | $ echo $0 7 | 1. If using bash: Add "export PATH=$HOME/.cabal/bin:$PATH" to the bottom of your .profile file if it isn't already there. 8 | Else if using tcsh: Add "set path = ($home/.cabal/bin $path)" to the bottom of your .cshrc file if it isn't already there. 9 | 10 | 2. $ cabal update 11 | 3. $ cabal install alex 12 | 4. $ cabal install cpphs 13 | 5. $ cabal install happy 14 | 6. $ cabal install Agda 15 | 7. $ agda-mode setup 16 | 8. $ emacs test.agda 17 | -- You should see an Agda menu and (Agda) in the mode line. 18 | 9. $ git clone https://github.com/pigworker/CS410-18 19 | -- You should find the files from the lectures, and more as they appear. 20 | 21 | ## Exercises 22 | * [Exercise 1](Exercise/One.agda): Order-Preserving Embeddings 23 | 24 | ## Last Year's Lecture Videos on YouTube 25 | 26 | 1. [Tuesday 19 September](https://www.youtube.com/watch?v=O4oczQry9Jw) Programs and Proofs 27 | 2. [Friday 22 September](https://www.youtube.com/watch?v=qcVZxQTouDk) more Programs and Proofs, Introducing "with" 28 | 3. [Tuesday 26 September](https://www.youtube.com/watch?v=8xFT9FPlm18) Proof by Induction 29 | 4. [Friday 29 September](https://www.youtube.com/watch?v=OZeDRtRmgkw) Sigma, Difference, Vector Take 30 | 5. [Tuesday 3 October](https://www.youtube.com/watch?v=b5salYMZoyM) How Rewrite Works 31 | 6. [Friday 6 October](https://www.youtube.com/watch?v=RW4aC_6n0yQ) A Comedy of (Entirely Non-Deliberate) Errors 32 | 7. [Tuesday 10 October](https://www.youtube.com/watch?v=2LxtHeZlaVw) "Dominoes", no really, this time 33 | 8. [Friday 13 October](https://www.youtube.com/watch?v=RCRddhYegzI) Functors 34 | 9. [Tuesday 17 October](https://www.youtube.com/watch?v=vTmYvoDrBlc) From Functors to Monads 35 | 10. [Friday 20 October](https://www.youtube.com/watch?v=2sykXdidZVA) Natural Transformations and Monads 36 | 11. [Tuesday 24 October](https://www.youtube.com/watch?v=iYegg8Rzhr4) From Monads to Input/Output 37 | 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) 38 | 13. [Tuesday 31 October](https://www.youtube.com/watch?v=MwtWdiyFJtA) Monads on Indexed Sets (Ex2) 39 | 14. [Friday 3 November](https://www.youtube.com/watch?v=kX3mvyFHDDU) What is an Application? 40 | 15. [Tuesday 7 November](https://www.youtube.com/watch?v=ZCdYIEwcna0) Coinduction and Coalgebras 41 | 16. [Friday 10 November](https://www.youtube.com/watch?v=AjyUNakYHRs) Polynomial Data and Codata 42 | 17. [Tuesday 14 November](https://www.youtube.com/watch?v=E8xIJolKEAI) A Polynomial Universe 43 | 18. [Friday 17 November](https://www.youtube.com/watch?v=-3MiZ80WldY) The Zipper (Differentiating Polynomial Types) 44 | 45 | ## Other useful stuff 46 | 47 | 1. [SpaceMonads!](https://www.youtube.com/watch?v=QojLQY5H0RI) my keynote from CodeMesh 2016, on which Ex2 is based 48 | -------------------------------------------------------------------------------- /Lib/Cat/Functor.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type --no-unicode #-} 2 | --{-# OPTIONS --irrelevant-projections #-} 3 | module Lib.Cat.Functor where 4 | 5 | open import Lib.Basics 6 | open import Lib.Cat.Category 7 | 8 | record Functor 9 | {ObjS : Set}{ArrS : ObjS -> ObjS -> Set}(CatS : Category ArrS) 10 | {ObjT : Set}{ArrT : ObjT -> ObjT -> Set}(CatT : Category ArrT) 11 | (ObjF : ObjS -> ObjT) 12 | : Set where 13 | private module S = Category CatS 14 | private module T = Category CatT 15 | field 16 | map : forall {A B : ObjS} -> ArrS A B -> ArrT (ObjF A) (ObjF B) 17 | -- laws 18 | .mapidArr : forall {A} -> map (S.idArr {A}) == T.idArr {ObjF A} 19 | .map-arr- : forall {A B C}(f : ArrS A B)(g : ArrS B C) -> 20 | map (f S.-arr- g) == (map f T.-arr- map g) 21 | 22 | SomeFunctor : SomeCategory -> SomeCategory -> Set 23 | SomeFunctor (ObjS , ArrS , CatS) (ObjT , ArrT , CatT) = 24 | Sg (ObjS -> ObjT) \ ObjF -> 25 | Functor CatS CatT ObjF 26 | 27 | ID : {Obj : Set}{Arr : Obj -> Obj -> Set}(C : Category Arr) -> Functor C C \ X -> X 28 | ID C = record { map = id ; mapidArr = refl ; map-arr- = \ f g -> refl } 29 | 30 | module _ 31 | {ObjR : Set}{ArrR : ObjR -> ObjR -> Set}{CatR : Category ArrR} 32 | {ObjS : Set}{ArrS : ObjS -> ObjS -> Set}{CatS : Category ArrS} 33 | {ObjT : Set}{ArrT : ObjT -> ObjT -> Set}{CatT : Category ArrT} 34 | {ObjF : ObjR -> ObjS} 35 | {ObjG : ObjS -> ObjT} 36 | where 37 | private 38 | module R = Category CatR 39 | module S = Category CatS 40 | module T = Category CatT 41 | 42 | _-Func-_ : Functor CatR CatS ObjF 43 | -> 44 | Functor CatS CatT ObjG 45 | -> 46 | Functor CatR CatT (ObjF - ObjG) 47 | Functor.map (F -Func- G) = F.map - G.map 48 | where 49 | module F = Functor F 50 | module G = Functor G 51 | Functor.mapidArr (F -Func- G) = 52 | G.map (F.map R.idArr) 53 | =[ G.map $= F.mapidArr >= 54 | G.map S.idArr 55 | =[ G.mapidArr >= 56 | T.idArr 57 | [QED] 58 | where 59 | module F = Functor F 60 | module G = Functor G 61 | Functor.map-arr- (F -Func- G) f g = 62 | G.map (F.map (f R.-arr- g)) 63 | =[ G.map $= F.map-arr- f g >= 64 | G.map (F.map f S.-arr- F.map g) 65 | =[ G.map-arr- (F.map f) (F.map g) >= 66 | (G.map (F.map f) T.-arr- G.map (F.map g)) 67 | [QED] 68 | where 69 | module F = Functor F 70 | module G = Functor G 71 | 72 | infixr 20 _-Func-_ 73 | 74 | CATEGORY : Category SomeFunctor 75 | CATEGORY = record 76 | { idArr = _ , ID _ 77 | ; _-arr-_ = \ { (ObjF , F) (ObjG , G) -> _ , (F -Func- G) } 78 | ; idArr-arr- = \ F -> refl 79 | ; _-arr-idArr = \ F -> refl 80 | ; assoc-arr- = \ F G H -> refl 81 | } 82 | 83 | open Functor 84 | 85 | _^opFun : {ObjS : Set}{ArrS : ObjS -> ObjS -> Set}{CatS : Category ArrS} 86 | {ObjT : Set}{ArrT : ObjT -> ObjT -> Set}{CatT : Category ArrT} 87 | {ObjF : ObjS -> ObjT} -> 88 | Functor CatS CatT ObjF -> Functor (CatS ^op) (CatT ^op) ObjF 89 | map (F ^opFun) = map F 90 | mapidArr (F ^opFun) = mapidArr F 91 | map-arr- (F ^opFun) f g = map-arr- F g f 92 | -------------------------------------------------------------------------------- /Lecture/Seven.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type --no-unicode #-} 2 | --{-# OPTIONS --irrelevant-projections #-} 3 | module Lecture.Seven where 4 | 5 | open import Lib.Basics 6 | open import Lib.Nat 7 | 8 | open import Lib.Cat.Category 9 | open import Lib.Cat.Functor 10 | open import Lib.Cat.NatTrans 11 | 12 | open import Lecture.Six 13 | 14 | {- 15 | record Con{-tainer-} : Set where 16 | constructor _ Set 20 | 21 | [[_]]C : Con -> Set -> Set 22 | [[ Sh Po s -> X 23 | 24 | map {X Y : Set} -> (X -> Y) -> [[ C ]]C X -> [[ C ]]C Y 25 | map Functor SET SET [[ C ]]C 28 | map [[ C ]]CF = map Sh C' 40 | po : {s : Sh C} -> Po C' (sh s) -> Po C s 41 | 42 | 43 | module _ {C C' : Con} where 44 | 45 | open NaturalTransformation 46 | open Con 47 | open ConMor 48 | 49 | [[_]]NT : ConMor C C' -> NaturalTransformation [[ C ]]CF [[ C' ]]CF 50 | transform [[ f 54 | ConMor C C' 55 | ntConMor nt = (\ s -> fst (transform nt (Po C s) (s , id))) 56 | snd (transform nt (Po C s) (s , id)) p' 57 | 58 | .complete : (nt : NaturalTransformation [[ C ]]CF [[ C' ]]CF) -> 59 | [[ ntConMor nt ]]NT == nt 60 | complete nt = eqNatTrans _ _ \ X -> ext \ { (s , k) -> natural nt k =$ (s , id) } 61 | 62 | 63 | ConMorBis : (C C' : Con) -> Set 64 | ConMorBis (S [[ C' ]]C (P s) 65 | 66 | module _ {C C' : Con} where 67 | 68 | open NaturalTransformation 69 | open Con 70 | open ConMor 71 | 72 | [[_]]NTBis : ConMorBis C C' -> NaturalTransformation [[ C ]]CF [[ C' ]]CF 73 | transform [[ f ]]NTBis X (s , k) with f s 74 | ... | s' , g = s' , (g - k) 75 | natural [[ f ]]NTBis h = refl 76 | 77 | ntConMorBis : (nt : NaturalTransformation [[ C ]]CF [[ C' ]]CF) -> 78 | ConMorBis C C' 79 | ntConMorBis nt s = transform nt (Po C s) (s , id) 80 | 81 | .completeBis : (nt : NaturalTransformation [[ C ]]CF [[ C' ]]CF) -> 82 | [[ ntConMorBis nt ]]NTBis == nt 83 | completeBis nt = eqNatTrans _ _ \ X -> 84 | ext \ { (s , k) -> natural nt k =$ (s , id) } 85 | 86 | 87 | -- Indexed containers 88 | 89 | module _ {O I : Set} where 90 | record Hancock : Set where 91 | constructor _<[_!_] 92 | field 93 | Command : O -> Set 94 | Response : (o : O) -> Command o -> Set 95 | result : (o : O)(c : Command o) -> Response o c -> I 96 | 97 | -- What they mean 98 | 99 | [[_]]H : Hancock -> (I -> Set) -> (O -> Set) 100 | [[ Co <[ Re ! re ] ]]H P o = Sg (Co o) \ c -> (r : Re o c) -> P (re o c r) 101 | 102 | -- How they are functorial 103 | 104 | -- All our favourite things are (indexed) containers 105 | 106 | ---- vectors 107 | 108 | ---- products 109 | 110 | ---- sums 111 | 112 | -- if there's time (ha!): least fixed points 113 | -------------------------------------------------------------------------------- /Lecture/Five.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type --no-unicode #-} 2 | module Lecture.Five where 3 | 4 | open import Lib.Basics 5 | open import Lib.Cat.Category 6 | open import Lib.Cat.Functor 7 | open import Lib.Cat.NatTrans 8 | open import Lib.Cat.Adjunction 9 | 10 | open import Lecture.Four -- the PREORDER category 11 | 12 | open Functor 13 | open NaturalTransformation 14 | open Adjunction 15 | 16 | -- finishing off Lib.Cat.Solver 17 | -- the A-word: 18 | -- how did we come up with what to prove about FREE R? 19 | -- adjunctions, informally 20 | -- the ARROWS functor 21 | -- examples of adjunctions 22 | -- adjoints to forgetful functors 23 | -- curry and uncurry 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | open MonotoneMap 32 | 33 | -- forgetful functor that forgets about the order 34 | 35 | FORGETORDER : Functor PREORDER SET \ { (X , _) -> X } 36 | map FORGETORDER = mapData 37 | mapidArr FORGETORDER = refl 38 | map-arr- FORGETORDER f g = refl 39 | 40 | 41 | -- the discrete order on a set: everything is only related to itself 42 | 43 | discreteOrder : (X : Set) -> Preorder {X = X} _==_ 44 | Preorder.reflexive (discreteOrder X) = refl 45 | Preorder.transitive (discreteOrder X) p q = _ =[ p >= _ =[ q >= _ [QED] 46 | Preorder.irrelevant (discreteOrder X) {p = refl} {refl} = refl 47 | 48 | DISCRETE : Functor SET PREORDER \ X -> (X , _==_ , discreteOrder X) 49 | map DISCRETE f = record { mapData = f ; mapMonotone = \ p -> f $= p } 50 | mapidArr DISCRETE = refl 51 | map-arr- DISCRETE f g = refl 52 | 53 | -- the indiscrete ("chaotic") order on a set: everything is related everything 54 | 55 | indiscreteOrder : (X : Set) -> Preorder {X = X} (\ _ _ -> One) 56 | Preorder.reflexive (indiscreteOrder X) = <> 57 | Preorder.transitive (indiscreteOrder X) = \ _ _ -> <> 58 | Preorder.irrelevant (indiscreteOrder X) = refl 59 | 60 | INDISCRETE : Functor SET PREORDER \ X -> (X , _ , indiscreteOrder X) 61 | map INDISCRETE f = record { mapData = f ; mapMonotone = _ } 62 | mapidArr INDISCRETE = refl 63 | map-arr- INDISCRETE f g = refl 64 | 65 | -- adjunctions 66 | 67 | leftAdjoint : Adjunction DISCRETE FORGETORDER 68 | transform (down leftAdjoint) (B , (P , _<=_ , prf)) = mapData 69 | natural (down leftAdjoint) f = refl 70 | mapData (transform (up leftAdjoint) (B , P , _<=_ , prf) g) = g 71 | mapMonotone (transform (up leftAdjoint) (B , P , _<=_ , prf) g) refl = Preorder.reflexive prf 72 | natural (up leftAdjoint) f = refl 73 | updown leftAdjoint = refl 74 | downup leftAdjoint = refl 75 | 76 | rightAdjoint : Adjunction FORGETORDER INDISCRETE 77 | rightAdjoint = {!!} -- homework 78 | 79 | 80 | -- curry and uncurry 81 | 82 | TIMES : (A : Set) -> Functor SET SET \ X -> X * A 83 | map (TIMES A) f (x , a) = f x , a 84 | mapidArr (TIMES A) = refl 85 | map-arr- (TIMES A) f g = refl 86 | 87 | _TO : (A : Set) -> Functor SET SET \ X -> (A -> X) 88 | map (A TO) f = \ h -> h - f 89 | mapidArr (A TO) = refl 90 | map-arr- (A TO) f g = refl 91 | 92 | exponential : {A : Set} -> Adjunction (TIMES A) (A TO) 93 | transform (down (exponential {A})) (X , B) = curry 94 | where curry : ((X * A) -> B) -> (X -> (A -> B)) 95 | curry f x a = f (x , a) 96 | natural (down (exponential {A})) g = refl 97 | transform (up (exponential {A})) (X , B) = uncurry 98 | where uncurry : (X -> (A -> B)) -> ((X * A) -> B) 99 | uncurry g (x , a) = g x a 100 | natural (up (exponential {A})) f = refl 101 | updown (exponential {A}) = refl 102 | downup (exponential {A}) = refl 103 | -------------------------------------------------------------------------------- /Lib/Cat/NatTrans.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type --no-unicode #-} 2 | --{-# OPTIONS --irrelevant-projections #-} 3 | module Lib.Cat.NatTrans where 4 | 5 | open import Lib.Basics 6 | open import Lib.Cat.Category 7 | open import Lib.Cat.Functor 8 | open import Lib.Cat.Solver 9 | 10 | record NaturalTransformation 11 | {ObjS : Set}{ArrS : ObjS -> ObjS -> Set}{CatS : Category ArrS} 12 | {ObjT : Set}{ArrT : ObjT -> ObjT -> Set}{CatT : Category ArrT} 13 | {ObjF : ObjS -> ObjT}(F : Functor CatS CatT ObjF) 14 | {ObjG : ObjS -> ObjT}(G : Functor CatS CatT ObjG) 15 | : Set where 16 | open Category CatT 17 | open Functor 18 | field 19 | transform : (X : ObjS) -> ArrT (ObjF X) (ObjG X) 20 | .natural : {X Y : ObjS} -> (f : ArrS X Y) -> 21 | (transform X -arr- map G f) == (map F f -arr- transform Y) 22 | 23 | 24 | module _ 25 | {ObjS : Set}{ArrS : ObjS -> ObjS -> Set}{CatS : Category ArrS} 26 | {ObjT : Set}{ArrT : ObjT -> ObjT -> Set}{CatT : Category ArrT} 27 | where 28 | 29 | open Category CatT 30 | open Functor 31 | open NaturalTransformation 32 | 33 | idNT : {ObjF : ObjS -> ObjT}{F : Functor CatS CatT ObjF} -> 34 | NaturalTransformation F F 35 | transform (idNT {ObjF} {F}) X = idArr 36 | natural (idNT {ObjF} {F}) f = 37 | [=IN CatT ! 38 | (idSyn -syn- mapSyn F < f >) =[[ categories refl >>= 39 | (mapSyn F < f > -syn- idSyn) 40 | [[QED]] 41 | =] 42 | 43 | _-NT-_ : {ObjF ObjG ObjH : ObjS -> ObjT} 44 | {F : Functor CatS CatT ObjF} 45 | {G : Functor CatS CatT ObjG} 46 | {H : Functor CatS CatT ObjH} 47 | (fg : NaturalTransformation F G) 48 | (gh : NaturalTransformation G H) 49 | -> NaturalTransformation F H 50 | transform (fg -NT- gh) X = transform fg X -arr- transform gh X 51 | natural (_-NT-_ {F = F} {G} {H} fg gh) {X} {Y} f = 52 | [=IN CatT ! 53 | ((< transform fg X > -syn- < transform gh X >) -syn- mapSyn H < f >) 54 | =[[ categories refl >>= 55 | (< transform fg X > -syn- -[ < transform gh X > -syn- mapSyn H < f > ]-) 56 | =[[ reduced (rd , rq (natural gh f)) >>= 57 | (< transform fg X > -syn- -[ mapSyn G < f > -syn- < transform gh Y > ]-) 58 | =[[ categories refl >>= 59 | (-[ < transform fg X > -syn- mapSyn G < f > ]- -syn- < transform gh Y >) 60 | =[[ reduced (rq (natural fg f) , rd) >>= 61 | (-[ mapSyn F < f > -syn- < transform fg Y > ]- -syn- < transform gh Y >) 62 | =[[ categories refl >>= 63 | (mapSyn F < f > -syn- < transform fg Y > -syn- < transform gh Y >) 64 | [[QED]] 65 | =] 66 | 67 | 68 | module _ {ObjF ObjG : ObjS -> ObjT} 69 | {F : Functor CatS CatT ObjF}{G : Functor CatS CatT ObjG} 70 | where 71 | 72 | eqNatTrans : 73 | (p q : NaturalTransformation F G) -> 74 | ((X : ObjS) -> transform p X == transform q X) -> 75 | p == q 76 | eqNatTrans (record { transform = pt ; natural = _ }) 77 | (record { transform = qt ; natural = _ }) 78 | prf 79 | rewrite ext prf = refl 80 | 81 | 82 | module _ 83 | {ObjS : Set}{ArrS : ObjS -> ObjS -> Set}(CatS : Category ArrS) 84 | {ObjT : Set}{ArrT : ObjT -> ObjT -> Set}(CatT : Category ArrT) 85 | where 86 | 87 | open Category CatT 88 | 89 | FUNCTOR : Category {SomeFunctor (ObjS , ArrS , CatS) (ObjT , ArrT , CatT)} 90 | \ {(ObjF , F) (ObjG , G) -> NaturalTransformation F G } 91 | idArr FUNCTOR = idNT 92 | _-arr-_ FUNCTOR fg gh = fg -NT- gh 93 | idArr-arr- FUNCTOR f = eqNatTrans _ _ \ X -> idArr-arr- _ 94 | _-arr-idArr FUNCTOR f = eqNatTrans _ _ \ X -> _ -arr-idArr 95 | assoc-arr- FUNCTOR f g h = eqNatTrans _ _ \ X -> assoc-arr- _ _ _ 96 | -------------------------------------------------------------------------------- /Lib/Basics.agda: -------------------------------------------------------------------------------- 1 | module Lib.Basics where 2 | 3 | ------------------------------------------------------------------------------ 4 | 5 | data Zero : Set where 6 | 7 | ------------------------------------------------------------------------------ 8 | 9 | record One : Set where 10 | constructor <> 11 | 12 | {-# BUILTIN UNIT One #-} 13 | {-# COMPILE GHC One = data () (()) #-} 14 | 15 | ------------------------------------------------------------------------------ 16 | 17 | data Two : Set where 18 | ff : Two 19 | tt : Two 20 | 21 | {-# BUILTIN BOOL Two #-} 22 | {-# BUILTIN FALSE ff #-} 23 | {-# BUILTIN TRUE tt #-} 24 | 25 | ------------------------------------------------------------------------------ 26 | 27 | data List (X : Set) : Set where 28 | [] : List X 29 | _,-_ : X -> List X -> List X 30 | 31 | infixr 60 _,-_ _+L_ 32 | 33 | {-# BUILTIN LIST List #-} 34 | {-# COMPILE GHC List = data [] ([] | (:)) #-} 35 | 36 | list : forall {X Y} -> (X -> Y) -> List X -> List Y 37 | list f [] = [] 38 | list f (x ,- xs) = f x ,- list f xs 39 | 40 | _+L_ : forall {X} -> List X -> List X -> List X 41 | [] +L ys = ys 42 | (x ,- xs) +L ys = x ,- xs +L ys 43 | 44 | data All {X : Set} (P : X -> Set) : List X -> Set where 45 | [] : All P [] 46 | _,-_ : forall {x xs} -> P x -> All P xs -> All P (x ,- xs) 47 | 48 | 49 | ------------------------------------------------------------------------------ 50 | 51 | record Sg {l}(S : Set l)(T : S -> Set l) : Set l where 52 | constructor _,_ 53 | field 54 | fst : S 55 | snd : T fst 56 | open Sg public 57 | 58 | _*_ : forall {l} -> Set l -> Set l -> Set l 59 | S * T = Sg S \ _ -> T 60 | 61 | infixr 40 _,_ 62 | infixr 20 _*_ 63 | 64 | ------------------------------------------------------------------------------ 65 | 66 | id : forall {l}{X : Set l} -> X -> X 67 | id x = x 68 | 69 | _-_ : forall {i j k} 70 | {A : Set i}{B : A -> Set j}{C : (a : A) -> B a -> Set k} 71 | (f : (a : A) -> B a)(g : {a : A}(b : B a) -> C a b) -> 72 | (a : A) -> C a (f a) 73 | (f - g) a = g (f a) 74 | 75 | infixr 50 _-_ 76 | 77 | ------------------------------------------------------------------------------ 78 | 79 | data _+_ (A B : Set) : Set where 80 | inl : A -> A + B 81 | inr : B -> A + B 82 | 83 | _<+>_ : forall {A B}{P : A + B -> Set} 84 | (f : (a : A) -> P (inl a))(g : (b : B) -> P (inr b)) -> 85 | (x : A + B) -> P x 86 | (f <+> g) (inl a) = f a 87 | (f <+> g) (inr b) = g b 88 | 89 | either : forall {S T U V : Set} -> 90 | (S -> U) -> (T -> V) -> (S + T) -> (U + V) 91 | either su tv = (su - inl) <+> (tv - inr) 92 | 93 | 94 | ------------------------------------------------------------------------------ 95 | 96 | data _==_ {l}{X : Set l}(x : X) : X -> Set where 97 | refl : x == x 98 | 99 | {-# BUILTIN EQUALITY _==_ #-} 100 | 101 | infix 30 _==_ 102 | 103 | reff : {X : Set}(x : X) -> x == x 104 | reff x = refl 105 | 106 | _=$=_ : {X Y : Set}{f f' : X -> Y}{x x' : X} -> 107 | f == f' -> x == x' -> f x == f' x' 108 | refl =$= refl = refl 109 | 110 | _$=_ : {S : Set}{T : Set} 111 | (f : S -> T) -> 112 | {x y : S} -> x == y -> 113 | f x == f y 114 | f $= q = refl =$= q 115 | 116 | _=$_ : {S : Set}{T : S -> Set}{f g : (x : S) -> T x} -> 117 | (f == g) -> (x : S) -> f x == g x 118 | refl =$ x = refl 119 | 120 | _=$: : {X Y : Set}{f f' : .X -> Y}{x x' : X} -> 121 | f == f' -> f x == f' x' 122 | refl =$: = refl 123 | 124 | infixl 20 _=$=_ _$=_ _=$_ _=$: 125 | 126 | sym : {X : Set}{x y : X} -> x == y -> y == x 127 | sym refl = refl 128 | 129 | _[QED] : {X : Set}(x : X) -> x == x 130 | x [QED] = refl 131 | 132 | _=[_>=_ : {X : Set}(x : X){y z : X} -> x == y -> y == z -> x == z 133 | x =[ refl >= q = q 134 | 135 | _=<_]=_ : {X : Set}(x : X){y z : X} -> y == x -> y == z -> x == z 136 | x =< refl ]= q = q 137 | 138 | infixr 10 _=[_>=_ _=<_]=_ 139 | infixr 11 _[QED] 140 | -------------------------------------------------------------------------------- /Lib/Cat/Free.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type --no-unicode #-} 2 | --{-# OPTIONS --irrelevant-projections #-} 3 | module Lib.Cat.Free where 4 | 5 | open import Lib.Basics 6 | open import Lib.Cat.Category 7 | open import Lib.Cat.Functor 8 | 9 | -- reflexive-transitive closure of a relation R 10 | 11 | data Star {X : Set}(R : X -> X -> Set)(x : X) : X -> Set where 12 | [] : Star R x x 13 | _,-_ : forall {y z} -> R x y -> Star R y z -> Star R x z 14 | 15 | _+S_ : forall {X : Set}{R : X -> X -> Set}{x y z : X} -> 16 | Star R x y -> Star R y z -> Star R x z 17 | [] +S gs = gs 18 | (f ,- fs) +S gs = f ,- (fs +S gs) 19 | 20 | _+S[] : forall {X : Set}{R : X -> X -> Set}{x y : X} -> 21 | (fs : Star R x y) -> (fs +S []) == fs 22 | [] +S[] = refl 23 | (f ,- fs) +S[] = (f ,-_) $= (fs +S[]) 24 | 25 | assoc+S : forall {X : Set}{R : X -> X -> Set}{w x y z : X} -> 26 | (fs : Star R w x)(gs : Star R x y)(hs : Star R y z) -> 27 | ((fs +S gs) +S hs) == (fs +S (gs +S hs)) 28 | assoc+S [] gs hs = refl 29 | assoc+S (f ,- fs) gs hs = (f ,-_) $= assoc+S fs gs hs 30 | 31 | -- free category on a relation R 32 | 33 | FREE : {X : Set}(R : X -> X -> Set) -> Category (Star R) 34 | FREE R = record 35 | { idArr = [] 36 | ; _-arr-_ = _+S_ 37 | ; idArr-arr- = \ f -> refl 38 | ; _-arr-idArr = _+S[] 39 | ; assoc-arr- = assoc+S 40 | } 41 | 42 | -- to give a functor FREE R -> C, it is enough to give a function 43 | -- F : X -> Obj_C such that related elements are connected by an arrow 44 | 45 | module _ {X : Set}{R : X -> X -> Set} 46 | {Obj}{Arr : Obj -> Obj -> Set}(C : Category Arr) 47 | (F : X -> Obj)(f : {x x' : X} -> R x x' -> Arr (F x) (F x')) where 48 | open Category C 49 | 50 | hom : {x x' : X} -> Star R x x' -> Arr (F x) (F x') 51 | hom [] = idArr 52 | hom (r ,- rs) = f r -arr- hom rs 53 | 54 | FreeHom : Functor (FREE R) C F 55 | Functor.map FreeHom = hom 56 | Functor.mapidArr FreeHom = refl 57 | Functor.map-arr- FreeHom [] ss = 58 | hom ss 59 | =< idArr-arr- (hom ss) ]= 60 | (idArr -arr- hom ss) 61 | [QED] 62 | Functor.map-arr- FreeHom (r ,- rs) ss = 63 | (f r -arr- hom (rs +S ss)) 64 | =[ (f r -arr-_) $= Functor.map-arr- FreeHom rs ss >= 65 | (f r -arr- (hom rs -arr- hom ss)) 66 | =< assoc-arr- _ _ _ ]= 67 | ((f r -arr- hom rs) -arr- hom ss) 68 | [QED] 69 | 70 | -- the FREE construction is functorial: if there is an arrow between 71 | -- the relations R : X -> X -> Set and S : Y -> Y -> Set, then there 72 | -- is a functor FREE R -> FREE S 73 | 74 | star : forall {X : Set}{R : X -> X -> Set}{Y : Set}{S : Y -> Y -> Set} 75 | (F : X -> Y)(f : {x x' : X} -> R x x' -> S (F x) (F x')) -> 76 | {x x' : X} -> Star R x x' -> Star S (F x) (F x') 77 | star F f = hom (FREE _) F \ r -> f r ,- [] 78 | 79 | homStar : forall 80 | {X : Set}{R : X -> X -> Set}{Y : Set}{S : Y -> Y -> Set} 81 | (F : X -> Y)(f : {x x' : X} -> R x x' -> S (F x) (F x')) 82 | {Obj}{Arr : Obj -> Obj -> Set}(C : Category Arr) 83 | (G : Y -> Obj)(g : {y y' : Y} -> S y y' -> Arr (G y) (G y')) 84 | {x x' : X}(rs : Star R x x') -> 85 | hom C G g (star F f rs) == hom C (F - G) (f - g) rs 86 | homStar F f C G g [] = refl 87 | homStar F f C G g (r ,- rs) = (g (f r) -arr-_) $= homStar F f C G g rs 88 | where open Category C 89 | 90 | -- liftings (R -> C) -> (Free R -> C) commutes with composition 91 | 92 | module _ {X : Set}{R : X -> X -> Set} 93 | {Obj}{Arr : Obj -> Obj -> Set}{C : Category Arr} 94 | (F : X -> Obj)(f : {x x' : X} -> R x x' -> Arr (F x) (F x')) 95 | {Obj'}{Arr' : Obj' -> Obj' -> Set}{C' : Category Arr'} 96 | {ObjG : Obj -> Obj'}(G : Functor C C' ObjG) 97 | where 98 | 99 | open Functor G 100 | private module S = Category C 101 | private module T = Category C' 102 | 103 | .mapHom : forall {x x'}(rs : Star R x x') -> 104 | map (hom C F f rs) == hom C' (F - ObjG) (f - map) rs 105 | mapHom [] = mapidArr 106 | mapHom (r ,- rs) = 107 | map (f r S.-arr- hom C F f rs) 108 | =[ map-arr- _ _ >= 109 | (map (f r) T.-arr- map (hom C F f rs)) 110 | =[ (map (f r) T.-arr-_) $= mapHom rs >= 111 | (map (f r) T.-arr- hom C' _ (f - map) rs) 112 | [QED] 113 | -------------------------------------------------------------------------------- /Lib/Cat/FreePrime.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type --no-unicode #-} 2 | -- {-# OPTIONS --irrelevant-projections #-} 3 | module Lib.Cat.FreePrime where 4 | 5 | open import Lib.Basics 6 | open import Lib.Cat.Category 7 | open import Lib.Cat.Functor 8 | 9 | -- reflexive-transitive closure of a relation R 10 | 11 | data Star {X : Set}(R : X -> X -> Set)(x : X) : X -> Set where 12 | [] : Star R x x 13 | _,-_ : {y z : X} -> R x y -> Star R y z -> Star R x z 14 | 15 | List' : Set -> Set 16 | List' A = Star {One} (\ _ _ -> A) <> <> 17 | 18 | 19 | _+S_ : forall {X : Set}{R : X -> X -> Set}{x y z : X} -> 20 | Star R x y -> Star R y z -> Star R x z 21 | [] +S gs = gs 22 | (f ,- fs) +S gs = f ,- (fs +S gs) 23 | 24 | 25 | _+S[] : forall {X : Set}{R : X -> X -> Set}{x y : X} -> 26 | (fs : Star R x y) -> (fs +S []) == fs 27 | [] +S[] = refl 28 | (f ,- fs) +S[] = (f ,-_) $= (fs +S[]) 29 | 30 | assoc+S : forall {X : Set}{R : X -> X -> Set}{w x y z : X} -> 31 | (fs : Star R w x)(gs : Star R x y)(hs : Star R y z) -> 32 | ((fs +S gs) +S hs) == (fs +S (gs +S hs)) 33 | assoc+S [] gs hs = refl 34 | assoc+S (f ,- fs) gs hs = (f ,-_) $= assoc+S fs gs hs 35 | 36 | 37 | -- free category on a relation R 38 | 39 | FREE : {X : Set}(R : X -> X -> Set) -> Category (Star R) 40 | FREE R = record 41 | { idArr = [] 42 | ; _-arr-_ = _+S_ 43 | ; idArr-arr- = \ f -> refl 44 | ; _-arr-idArr = _+S[] 45 | ; assoc-arr- = assoc+S 46 | } 47 | 48 | -- to give a functor FREE R -> C, it is enough to give a function 49 | -- F : X -> Obj_C such that related elements are connected by an arrow 50 | 51 | module _ {X : Set}{R : X -> X -> Set} 52 | {Obj}{Arr : Obj -> Obj -> Set}(C : Category Arr) 53 | (ObjF : X -> Obj) 54 | (f : {x x' : X} -> R x x' -> Arr (ObjF x) (ObjF x')) where 55 | open Category C 56 | open Functor 57 | 58 | hom : {x x' : X} -> Star R x x' -> Arr (ObjF x) (ObjF x') 59 | hom [] = idArr 60 | hom (r ,- rs) = f r -arr- hom rs 61 | 62 | FreeHom : Functor (FREE R) C ObjF 63 | map FreeHom = hom 64 | mapidArr FreeHom = refl 65 | map-arr- FreeHom [] rs' = hom rs' =< idArr-arr- (hom rs') ]= (idArr -arr- hom rs') [QED] 66 | map-arr- FreeHom (r ,- rs) rs' = 67 | (f r -arr- hom (rs +S rs')) 68 | =[ (f r -arr-_) $= map-arr- FreeHom rs rs' >= 69 | (f r -arr- (hom rs -arr- hom rs')) 70 | =< assoc-arr- _ _ _ ]= 71 | ((f r -arr- hom rs) -arr- hom rs') 72 | [QED] 73 | 74 | homSpecial : {X : Set}{R : X -> X -> Set} {x x' : X} -> Star (Star R) x x' -> Star R x x' 75 | homSpecial {R = R} = hom (FREE R) id id 76 | 77 | 78 | 79 | module _ {X : Set}{R : X -> X -> Set} 80 | {Obj}{Arr : Obj -> Obj -> Set}(C : Category Arr) 81 | (ObjF : X -> Obj)(F : Functor (FREE R) C ObjF) where 82 | 83 | open Functor F 84 | 85 | Underlying : {x x' : X} -> R x x' -> Arr (ObjF x) (ObjF x') 86 | Underlying r = map (r ,- []) 87 | 88 | 89 | -- the FREE construction is functorial: if there is an arrow between 90 | -- the relations R : X -> X -> Set and S : Y -> Y -> Set, then there 91 | -- is a functor FREE R -> FREE S 92 | 93 | star : forall {X : Set}{R : X -> X -> Set}{Y : Set}{S : Y -> Y -> Set} 94 | (F : X -> Y)(f : {x x' : X} -> R x x' -> S (F x) (F x')) -> 95 | {x x' : X} -> Star R x x' -> Star S (F x) (F x') 96 | star {S = S} F f = hom (FREE S) F \ r -> f r ,- [] 97 | 98 | homStar : forall 99 | {X : Set}{R : X -> X -> Set}{Y : Set}{S : Y -> Y -> Set} 100 | (F : X -> Y)(f : {x x' : X} -> R x x' -> S (F x) (F x')) 101 | {Obj}{Arr : Obj -> Obj -> Set}(C : Category Arr) 102 | (G : Y -> Obj)(g : {y y' : Y} -> S y y' -> Arr (G y) (G y')) 103 | {x x' : X}(rs : Star R x x') -> 104 | hom C G g (star F f rs) == hom C (F - G) (f - g) rs 105 | homStar F f C G g [] = refl 106 | homStar F f C G g (r ,- rs) = (g (f r) -arr-_) $= homStar F f C G g rs 107 | where open Category C 108 | 109 | 110 | {- 111 | -- liftings (R -> C) -> (Free R -> C) commutes with composition 112 | 113 | module _ {X : Set}{R : X -> X -> Set} 114 | {Obj}{Arr : Obj -> Obj -> Set}{C : Category Arr} 115 | (F : X -> Obj)(f : {x x' : X} -> R x x' -> Arr (F x) (F x')) 116 | {Obj'}{Arr' : Obj' -> Obj' -> Set}{C' : Category Arr'} 117 | {ObjG : Obj -> Obj'}(G : Functor C C' ObjG) 118 | where 119 | 120 | open Functor G 121 | private module S = Category C 122 | private module T = Category C' 123 | 124 | .mapHom : forall {x x'}(rs : Star R x x') -> 125 | map (hom C F f rs) == hom C' (F - ObjG) (f - map) rs 126 | mapHom [] = mapidArr 127 | mapHom (r ,- rs) = 128 | map (f r S.-arr- hom C F f rs) 129 | =[ map-arr- _ _ >= 130 | (map (f r) T.-arr- map (hom C F f rs)) 131 | =[ (map (f r) T.-arr-_) $= mapHom rs >= 132 | (map (f r) T.-arr- hom C' _ (f - map) rs) 133 | [QED] 134 | -} 135 | -------------------------------------------------------------------------------- /Lib/HaskellSetup.hs: -------------------------------------------------------------------------------- 1 | module Lib.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 Lib.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 | -------------------------------------------------------------------------------- /Lib/Cat/Solver.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type --no-unicode #-} 2 | --{-# OPTIONS --irrelevant-projections #-} 3 | module Lib.Cat.Solver where 4 | 5 | open import Lib.Basics 6 | open import Lib.Cat.Category 7 | open import Lib.Cat.Functor 8 | open import Lib.Cat.Free 9 | 10 | data SynArr {Obj}{Arr : Obj -> Obj -> Set}(C : Category Arr) : Obj -> Obj -> Set 11 | where 12 | <_> : forall {S T} -> Arr S T -> SynArr C S T 13 | idSyn : forall {T} -> SynArr C T T 14 | _-syn-_ : forall {R S T} -> SynArr C R S -> SynArr C S T -> 15 | SynArr C R T 16 | mapSyn : forall 17 | {Obj'}{Arr' : Obj' -> Obj' -> Set}{C' : Category Arr'} 18 | {S' T' : Obj'} 19 | {ObjF : Obj' -> Obj} -> 20 | (F : Functor C' C ObjF) -> 21 | SynArr C' S' T' -> 22 | SynArr C (ObjF S') (ObjF T') 23 | -[_]- : forall {S T} -> SynArr C S T -> SynArr C S T 24 | 25 | infixr 20 _-syn-_ 26 | 27 | [[_]]Sy : forall {Obj}{S T}{Arr : Obj -> Obj -> Set}{C : Category Arr} -> 28 | SynArr C S T -> Arr S T 29 | [[ < f > ]]Sy = f 30 | [[_]]Sy {C = C} idSyn = idArr where open Category C 31 | [[_]]Sy {C = C} (f -syn- g) = [[ f ]]Sy -arr- [[ g ]]Sy where open Category C 32 | [[ mapSyn F f ]]Sy = map [[ f ]]Sy where open Functor F 33 | [[ -[ f ]- ]]Sy = [[ f ]]Sy 34 | 35 | record _=arr=_ 36 | {Obj}{S T : Obj}{Arr : Obj -> Obj -> Set}{C : Category Arr} 37 | (f g : SynArr C S T) 38 | : Set 39 | where 40 | constructor arrEq 41 | field 42 | eqArr : [[ f ]]Sy == [[ g ]]Sy 43 | open _=arr=_ public 44 | 45 | [=IN_!_=] : forall {Obj}{S T : Obj}{Arr : Obj -> Obj -> Set}(C : Category Arr) 46 | {d d' : SynArr C S T} -> 47 | d =arr= d' -> [[ d ]]Sy == [[ d' ]]Sy 48 | [=IN C ! q =] = eqArr q 49 | 50 | 51 | data MapPile {Obj}{Arr : Obj -> Obj -> Set}(C : Category Arr) 52 | : Obj -> Obj -> Set 53 | where 54 | <_> : forall {S T} -> Arr S T -> MapPile C S T 55 | mapSyn : forall {Obj'}{Arr' : Obj' -> Obj' -> Set}{C' : Category Arr'} 56 | {ObjF : Obj' -> Obj}(F : Functor C' C ObjF) -> 57 | {S' T' : Obj'} -> MapPile C' S' T' -> 58 | MapPile C (ObjF S') (ObjF T') 59 | 60 | module _ where 61 | [[_]]MP : forall {Obj}{S T : Obj}{Arr : Obj -> Obj -> Set}{C : Category Arr} -> 62 | MapPile C S T -> Arr S T 63 | [[ < f > ]]MP = f 64 | [[ mapSyn F m ]]MP = map [[ m ]]MP 65 | where open Functor F 66 | 67 | [[_]]MPs : forall {Obj}{S T : Obj}{Arr : Obj -> Obj -> Set}{C : Category Arr} -> 68 | Star (MapPile C) S T -> Arr S T 69 | [[_]]MPs {C = C} ms = hom C (\ X -> X) [[_]]MP ms 70 | 71 | normSyn : forall {Obj}{S T : Obj}{Arr : Obj -> Obj -> Set}{C : Category Arr} -> 72 | SynArr C S T -> Star (MapPile C) S T 73 | normSyn < f > = < f > ,- [] 74 | normSyn idSyn = [] 75 | normSyn (d -syn- d') = normSyn d +S normSyn d' 76 | normSyn (mapSyn F d) = star _ (mapSyn F) (normSyn d) 77 | normSyn -[ d ]- = normSyn d 78 | 79 | .normSynLemma : forall {Obj}{Arr : Obj -> Obj -> Set}{C : Category Arr}{S T} -> 80 | (d : SynArr C S T) -> 81 | [[ d ]]Sy == [[ normSyn d ]]MPs 82 | normSynLemma {C = C} < f > = 83 | f 84 | =< f -arr-idArr ]= 85 | (f -arr- idArr) 86 | [QED] 87 | where open Category C 88 | normSynLemma idSyn = refl 89 | normSynLemma {C = C} (d -syn- d') = 90 | ([[ d ]]Sy -arr- [[ d' ]]Sy) 91 | =[ reff _-arr-_ =$= normSynLemma d =$= normSynLemma d' >= 92 | ([[ normSyn d ]]MPs -arr- [[ normSyn d' ]]MPs) 93 | =< map-arr- (FreeHom C _ [[_]]MP) (normSyn d) (normSyn d') ]= 94 | [[ normSyn d +S normSyn d' ]]MPs 95 | [QED] 96 | where open Category C ; open Functor 97 | normSynLemma {C = C} (mapSyn F d) = 98 | map [[ d ]]Sy 99 | =[ map $= normSynLemma d >= 100 | map ([[ normSyn d ]]MPs) 101 | =[ mapHom _ [[_]]MP F (normSyn d) >= 102 | hom C _ (\ r -> [[ mapSyn F r ]]MP) (normSyn d) 103 | =< homStar _ (mapSyn F) C _ [[_]]MP (normSyn d) ]= 104 | [[ star _ (mapSyn F) (normSyn d) ]]MPs 105 | [QED] 106 | where open Functor F 107 | normSynLemma -[ d ]- = normSynLemma d 108 | 109 | .categories : 110 | forall {Obj}{S T : Obj}{Arr : Obj -> Obj -> Set}{C : Category Arr} -> 111 | {d d' : SynArr C S T} -> 112 | normSyn d == normSyn d' -> 113 | d =arr= d' 114 | eqArr (categories {d = d} {d' = d'} q) = 115 | [[ d ]]Sy 116 | =[ normSynLemma d >= 117 | [[ normSyn d ]]MPs 118 | =[ [[_]]MPs $= q >= 119 | [[ normSyn d' ]]MPs 120 | =< normSynLemma d' ]= 121 | [[ d' ]]Sy 122 | [QED] 123 | 124 | ArrEq : forall {Obj}{S T S' T' : Obj}{Arr : Obj -> Obj -> Set}{C : Category Arr} -> 125 | (d : SynArr C S T)(d' : SynArr C S' T') -> Set 126 | ArrEq {S = S}{T}{S'}{T'} d d' = 127 | Sg (S == S') \ { refl -> Sg (T == T') \ { refl -> d =arr= d' } } 128 | 129 | Reduced : forall {Obj}{S T S' T' : Obj}{Arr : Obj -> Obj -> Set}{C : Category Arr} -> 130 | (d : SynArr C S T)(d' : SynArr C S' T') -> Set 131 | Reduced (idSyn {T}) (idSyn {T'}) = T == T' 132 | Reduced (f -syn- g) (f' -syn- g') = Reduced f f' * Reduced g g' 133 | Reduced d d' = ArrEq d d' 134 | 135 | reduced' : forall {Obj}{S T S' T' : Obj}{Arr : Obj -> Obj -> Set}{C : Category Arr} -> 136 | (d : SynArr C S T)(d' : SynArr C S' T') -> 137 | Reduced d d' -> 138 | ArrEq d d' 139 | reduced' idSyn idSyn refl = refl , refl , arrEq refl 140 | reduced' (f -syn- g) (f' -syn- g') (rf , rg) with reduced' f f' rf | reduced' g g' rg 141 | reduced' {C = C} (f -syn- g) (f' -syn- g') (rf , rg) 142 | | refl , refl , arrEq qf | refl , refl , arrEq qg 143 | = refl , refl , arrEq (reff _-arr-_ =$= qf =$= qg) 144 | where open Category C 145 | reduced' (d -syn- d1) < x > r = r 146 | reduced' (d -syn- d1) idSyn r = r 147 | reduced' (d -syn- d1) (mapSyn F d') r = r 148 | reduced' (d -syn- d1) -[ d' ]- r = r 149 | reduced' idSyn < x > r = r 150 | reduced' idSyn (d' -syn- d'') r = r 151 | reduced' idSyn (mapSyn F d') r = r 152 | reduced' idSyn -[ d' ]- r = r 153 | reduced' < x > d' r = r 154 | reduced' (mapSyn F d) d' r = r 155 | reduced' -[ d ]- d' r = r 156 | 157 | reduced : forall {Obj}{S T}{Arr : Obj -> Obj -> Set}{C : Category Arr} -> 158 | {d d' : SynArr C S T} -> 159 | Reduced d d' -> 160 | d =arr= d' 161 | reduced {d = d} {d'} r with reduced' d d' r 162 | ... | refl , refl , q = q 163 | 164 | rd : forall {Obj}{S T}{Arr : Obj -> Obj -> Set}{C : Category Arr} -> 165 | {d : SynArr C S T} -> 166 | ArrEq d d 167 | rd = refl , refl , arrEq refl 168 | 169 | rq : forall {Obj}{S T}{Arr : Obj -> Obj -> Set}{C : Category Arr} -> 170 | {d d' : SynArr C S T} -> 171 | [[ d ]]Sy == [[ d' ]]Sy -> ArrEq d d' 172 | rq q = refl , refl , arrEq q 173 | 174 | 175 | _=[[_>>=_ : forall {Obj}{S T : Obj}{Arr : Obj -> Obj -> Set}{C : Category Arr} 176 | (d0 : SynArr C S T){d1 d2} -> 177 | d0 =arr= d1 -> d1 =arr= d2 -> d0 =arr= d2 178 | eqArr (d0 =[[ q1 >>= q2) = [[ d0 ]]Sy =[ eqArr q1 >= eqArr q2 179 | 180 | _=<<_]]=_ : forall {Obj}{S T : Obj}{Arr : Obj -> Obj -> Set}{C : Category Arr} 181 | (d0 : SynArr C S T){d1 d2} -> 182 | d1 =arr= d0 -> d1 =arr= d2 -> d0 =arr= d2 183 | eqArr (d0 =<< q1 ]]= q2) = [[ d0 ]]Sy =< eqArr q1 ]= eqArr q2 184 | 185 | _[[QED]] : forall {Obj}{S T : Obj}{Arr : Obj -> Obj -> Set}{C : Category Arr} 186 | (d : SynArr C S T) -> d =arr= d 187 | eqArr (d [[QED]]) = refl 188 | 189 | infixr 10 _=[[_>>=_ _=<<_]]=_ 190 | infixr 11 _[[QED]] 191 | -------------------------------------------------------------------------------- /Lib/Display.agda: -------------------------------------------------------------------------------- 1 | module Lib.Display where 2 | 3 | open import Lib.Basics 4 | open import Lib.Nat 5 | open import Lib.Vec 6 | open import Lib.Indexed 7 | 8 | ---------------------------------------------------------------------------- 9 | -- chars and strings 10 | ---------------------------------------------------------------------------- 11 | 12 | postulate -- this means that we just suppose the following things exist... 13 | Char : Set 14 | String : Set 15 | {-# BUILTIN CHAR Char #-} 16 | {-# BUILTIN STRING String #-} 17 | 18 | primitive -- these are baked in; they even work! 19 | primCharEquality : Char -> Char -> Two 20 | primStringAppend : String -> String -> String 21 | primStringToList : String -> List Char 22 | primStringFromList : List Char -> String 23 | 24 | 25 | --------------------------------------------------------------------------- 26 | -- COLOURS 27 | --------------------------------------------------------------------------- 28 | 29 | -- We're going to be making displays from coloured text. 30 | 31 | data Colour : Set where 32 | black red green yellow blue magenta cyan white : Colour 33 | {-# COMPILE GHC Colour = data HaskellSetup.Colour (HaskellSetup.Black | HaskellSetup.Red | HaskellSetup.Green | HaskellSetup.Yellow | HaskellSetup.Blue | HaskellSetup.Magenta | HaskellSetup.Cyan | HaskellSetup.White) #-} 34 | 35 | record _**_ (S T : Set) : Set where 36 | constructor _,_ 37 | field 38 | outl : S 39 | outr : T 40 | open _**_ 41 | {-# COMPILE GHC _**_ = data (,) ((,)) #-} 42 | infixr 4 _**_ 43 | 44 | {- Here's the characterization of keys I give you -} 45 | data Direction : Set where up down left right : Direction 46 | data Modifier : Set where normal shift control : Modifier 47 | data Key : Set where 48 | char : Char -> Key 49 | arrow : Modifier -> Direction -> Key 50 | enter : Key 51 | backspace : Key 52 | delete : Key 53 | escape : Key 54 | tab : Key 55 | data Event : Set where 56 | key : (k : Key) -> Event 57 | resize : (w h : Nat) -> Event 58 | 59 | {- This type collects the things you're allowed to do with the text window. -} 60 | data Action : Set where 61 | goRowCol : Nat -> Nat -> Action -- send the cursor somewhere 62 | sendText : List Char -> Action -- send some text 63 | move : Direction -> Nat -> Action -- which way and how much 64 | fgText : Colour -> Action 65 | bgText : Colour -> Action 66 | 67 | {- I wire all of that stuff up to its Haskell counterpart. -} 68 | {-# FOREIGN GHC import qualified Lib.ANSIEscapes as ANSIEscapes #-} 69 | {-# FOREIGN GHC import qualified Lib.HaskellSetup as HaskellSetup #-} 70 | {-# COMPILE GHC Direction = data ANSIEscapes.Dir (ANSIEscapes.DU | ANSIEscapes.DD | ANSIEscapes.DL | ANSIEscapes.DR) #-} 71 | {-# COMPILE GHC Modifier = data HaskellSetup.Modifier (HaskellSetup.Normal | HaskellSetup.Shift | HaskellSetup.Control) #-} 72 | {-# COMPILE GHC Key = data HaskellSetup.Key (HaskellSetup.Char | HaskellSetup.Arrow | HaskellSetup.Enter | HaskellSetup.Backspace | HaskellSetup.Delete | HaskellSetup.Escape | HaskellSetup.Tab) #-} 73 | {-# COMPILE GHC Event = data HaskellSetup.Event (HaskellSetup.Key | HaskellSetup.Resize) #-} 74 | {-# COMPILE GHC Action = data HaskellSetup.Action (HaskellSetup.GoRowCol | HaskellSetup.SendText | HaskellSetup.Move | HaskellSetup.FgText | HaskellSetup.BgText) #-} 75 | 76 | data ColourChar : Set where 77 | _-_#_ : (fg : Colour)(c : Char)(bg : Colour) -> ColourChar 78 | 79 | paintAction : {wh : Nat * Nat} -> Matrix ColourChar wh -> List Action 80 | paintAction = vecFoldR (vecFoldR (\ {(f - c # b) k -> \ as -> 81 | fgText f ,- bgText b ,- sendText (c ,- []) ,- k as}) id) [] 82 | 83 | 84 | postulate -- Haskell has a monad for doing IO, which we use at the top level 85 | IO : Set -> Set 86 | return : {A : Set} -> A -> IO A 87 | _>>=_ : {A B : Set} -> IO A -> (A -> IO B) -> IO B 88 | infixl 1 _>>=_ 89 | {-# BUILTIN IO IO #-} 90 | {-# COMPILE GHC IO = type IO #-} 91 | {-# COMPILE GHC return = (\ _ -> return) #-} 92 | {-# COMPILE GHC _>>=_ = (\ _ _ -> (>>=)) #-} 93 | 94 | 95 | --------------------------------------------------------------------------- 96 | -- APPLICATIONS -- 97 | --------------------------------------------------------------------------- 98 | 99 | -- Here's a general idea of what it means to be an "application". 100 | -- You need to choose some sort of size-dependent state, then provide these 101 | -- bits and pieces. We need to know how the state is updated according to 102 | -- events, with resizing potentially affecting the state's type. We must 103 | -- be able to paint the state. The state should propose a cursor position. 104 | -- (Keen students may modify this definition to ensure the cursor must be 105 | -- within the bounds of the application.) 106 | 107 | record Interface (Status : Set) : Set1 where 108 | constructor interface 109 | field 110 | Command : Status -> Set -- a.k.a. precondition 111 | Response : (before : Status)(command : Command before) 112 | -> Status -> Set -- a.k.a. postcondition 113 | open Interface public 114 | 115 | record Server 116 | {Status : Set} 117 | (Intf : Interface Status) 118 | (Display : Status -> Set) -- a.k.a. invariant 119 | (now : Status) 120 | : Set 121 | where 122 | coinductive 123 | field 124 | display : Display now 125 | react : (command : Command Intf now) -> 126 | Sg Status \ next -> 127 | Response Intf now command next * 128 | Server Intf Display next 129 | open Server public 130 | 131 | AppInterface : Interface (Nat * Nat) 132 | Command AppInterface wh = Event 133 | Response AppInterface whb (key k) wha = wha == whb 134 | Response AppInterface whb (resize w h) wha = wha == (w , h) 135 | 136 | CursorPosition : Nat * Nat -> Set 137 | CursorPosition wh = Nat * Nat 138 | 139 | Application : Nat * Nat -> Set 140 | Application = Server AppInterface 141 | ( Matrix ColourChar -- what's on the screen? 142 | :*: CursorPosition -- where's the cursor? 143 | ) 144 | 145 | TopLevel : Set 146 | TopLevel = Sg (Nat * Nat) Application 147 | 148 | appPaint : TopLevel -> List Action 149 | appPaint (_ , app) = 150 | goRowCol 0 0 ,- paintAction p 151 | -- must have composition here, to work around compiler bug 152 | -- paintAction (paintMatrix p) 153 | -- segfaults, because p is erased 154 | +L (goRowCol (snd xy) (fst xy) ,- []) 155 | where 156 | pxy = display app 157 | p = fst pxy 158 | xy = snd pxy 159 | 160 | appHandler : Event -> TopLevel -> TopLevel ** List Action 161 | appHandler e (wh , app) with react app e 162 | ... | wh' , _ , app' = (_ , app') , appPaint (_ , app') 163 | 164 | {- This is the bit of code I wrote in Haskell to animate your code. -} 165 | postulate 166 | mainAppLoop : {S : Set} -> -- program state 167 | -- INITIALIZER 168 | S -> -- initial state 169 | -- EVENT HANDLER 170 | (Event -> S -> -- event and state in 171 | S ** List Action) -> -- new state and screen actions out 172 | -- PUT 'EM TOGETHER AND YOU'VE GOT AN APPLICATION! 173 | IO One 174 | {-# COMPILE GHC mainAppLoop = (\ _ -> HaskellSetup.mainAppLoop) #-} 175 | 176 | appMain : (forall wh -> Application wh) -> IO One 177 | appMain app = mainAppLoop ((0 , 0) , app (0 , 0)) appHandler 178 | -- will get resized dynamically to size of terminal, first thing 179 | -------------------------------------------------------------------------------- /Lecture/Eight.agda: -------------------------------------------------------------------------------- 1 | module Lecture.Eight where 2 | 3 | open import Lib.Basics 4 | open import Lib.Nat 5 | open import Lib.Vec 6 | 7 | ---------------------------------------------------------------------------- 8 | -- coinduction for beginners 9 | ---------------------------------------------------------------------------- 10 | 11 | record Stream (X : Set) : Set where 12 | coinductive 13 | constructor _,-_ 14 | field 15 | head : X 16 | tail : Stream X 17 | open Stream 18 | 19 | repeat : {X : Set} -> X -> Stream X 20 | head (repeat x) = x 21 | tail (repeat x) = repeat x 22 | 23 | strapp : {S T : Set} -> Stream (S -> T) -> Stream S -> Stream T 24 | head (strapp fs ss) = (head fs) (head ss) 25 | tail (strapp fs ss) = strapp (tail fs) (tail ss) 26 | 27 | beginners : {X : Set}(n : Nat) -> Stream X -> Vec X n 28 | beginners zero xs = [] 29 | beginners (suc n) xs = (head xs) ,- (beginners n (tail xs)) 30 | 31 | natsFrom : Nat -> Stream Nat 32 | head (natsFrom n) = n 33 | tail (natsFrom n) = natsFrom (suc n) 34 | 35 | ---------------------------------------------------------------------------- 36 | -- chars and strings and IO (boring bits) 37 | ---------------------------------------------------------------------------- 38 | 39 | {- 40 | postulate -- needed for Agda 2.5.4 41 | Char : Set 42 | String : Set 43 | -} 44 | {-# BUILTIN CHAR Char #-} 45 | {-# BUILTIN STRING String #-} 46 | 47 | -- For compilation purposes we make _*_ into its own data type 48 | record _**_ (S T : Set) : Set where 49 | constructor _,_ 50 | field 51 | outl : S 52 | outr : T 53 | open _**_ 54 | {-# COMPILE GHC _**_ = data (,) ((,)) #-} 55 | infixr 4 _**_ 56 | 57 | postulate -- Connecting to the Haskell IO monad 58 | IO : Set -> Set 59 | return : {A : Set} -> A -> IO A 60 | _>>=_ : {A B : Set} -> IO A -> (A -> IO B) -> IO B 61 | infixl 1 _>>=_ 62 | {-# BUILTIN IO IO #-} 63 | {-# COMPILE GHC IO = type IO #-} 64 | {-# COMPILE GHC return = (\ _ -> return) #-} 65 | {-# COMPILE GHC _>>=_ = (\ _ _ -> (>>=)) #-} 66 | 67 | 68 | --------------------------------------------------------------------------- 69 | -- COLOURS 70 | --------------------------------------------------------------------------- 71 | 72 | -- We're going to be making displays from coloured text. 73 | 74 | data Colour : Set where 75 | black red green yellow blue magenta cyan white : Colour 76 | 77 | {-# COMPILE GHC Colour = data HaskellSetup.Colour (HaskellSetup.Black | HaskellSetup.Red | HaskellSetup.Green | HaskellSetup.Yellow | HaskellSetup.Blue | HaskellSetup.Magenta | HaskellSetup.Cyan | HaskellSetup.White) #-} 78 | 79 | -- Keys 80 | 81 | data Direction : Set where up down left right : Direction 82 | 83 | data Modifier : Set where normal shift control : Modifier 84 | 85 | data Key : Set where 86 | char : Char -> Key 87 | arrow : Modifier -> Direction -> Key 88 | enter : Key 89 | backspace : Key 90 | delete : Key 91 | escape : Key 92 | tab : Key 93 | 94 | -- Events 95 | 96 | data Event : Set where 97 | key : (k : Key) -> Event 98 | resize : (w h : Nat) -> Event 99 | 100 | -- The things you're allowed to do with a text window. 101 | 102 | data Action : Set where 103 | goRowCol : Nat -> Nat -> Action -- send the cursor somewhere 104 | sendText : List Char -> Action -- send some text 105 | move : Direction -> Nat -> Action -- which way and how much 106 | fgText : Colour -> Action -- change foreground colour 107 | bgText : Colour -> Action -- change background colour 108 | 109 | {- Wiring all of that stuff up to its Haskell counterpart. -} 110 | {-# FOREIGN GHC import qualified Lib.ANSIEscapes as ANSIEscapes #-} 111 | {-# FOREIGN GHC import qualified Lib.HaskellSetup as HaskellSetup #-} 112 | {-# COMPILE GHC Direction = data ANSIEscapes.Dir (ANSIEscapes.DU | ANSIEscapes.DD | ANSIEscapes.DL | ANSIEscapes.DR) #-} 113 | {-# COMPILE GHC Modifier = data HaskellSetup.Modifier (HaskellSetup.Normal | HaskellSetup.Shift | HaskellSetup.Control) #-} 114 | {-# COMPILE GHC Key = data HaskellSetup.Key (HaskellSetup.Char | HaskellSetup.Arrow | HaskellSetup.Enter | HaskellSetup.Backspace | HaskellSetup.Delete | HaskellSetup.Escape | HaskellSetup.Tab) #-} 115 | {-# COMPILE GHC Event = data HaskellSetup.Event (HaskellSetup.Key | HaskellSetup.Resize) #-} 116 | {-# COMPILE GHC Action = data HaskellSetup.Action (HaskellSetup.GoRowCol | HaskellSetup.SendText | HaskellSetup.Move | HaskellSetup.FgText | HaskellSetup.BgText) #-} 117 | 118 | 119 | data ColourChar : Set where 120 | _-_/_ : (fg : Colour)(c : Char)(bg : Colour) -> ColourChar 121 | 122 | -- ... e.g. green - '*' / black for a green * on black. 123 | 124 | Matrix : Set -> Nat * Nat -> Set 125 | Matrix C (w , h) = Vec (Vec C w) h 126 | 127 | Painting : Nat * Nat -> Set 128 | Painting = Matrix ColourChar 129 | 130 | paintAction : {wh : Nat * Nat} -> Matrix ColourChar wh -> List Action 131 | paintAction [] = [] 132 | paintAction (line ,- rest) = paintLine line +L paintAction rest 133 | where paintLine : {n : Nat} -> Vec ColourChar n -> List Action 134 | paintLine [] = [] 135 | paintLine ((fg - c / bg) ,- xs) = fgText fg ,- bgText bg ,- sendText (c ,- []) ,- paintLine xs 136 | 137 | --------------------------------------------------------------------------- 138 | -- APPLICATIONS -- 139 | --------------------------------------------------------------------------- 140 | 141 | -- Here's a general idea of what it means to be an "application". 142 | -- You need to choose some sort of size-dependent state, then provide these 143 | -- bits and pieces. We need to know how the state is updated according to 144 | -- events, with resizing potentially affecting the state's type. We must 145 | -- be able to paint the state. The state should propose a cursor position. 146 | -- (Keen students may modify this definition to ensure the cursor must be 147 | -- within the bounds of the application.) 148 | 149 | record Application (wh : Nat * Nat) : Set where 150 | coinductive 151 | field 152 | handleKey : Key -> Application wh 153 | handleResize : (wh' : Nat * Nat) -> Application wh' 154 | paintMe : Painting wh 155 | cursorMe : Nat * Nat -- x,y coords 156 | open Application public 157 | 158 | 159 | APP : Set 160 | APP = Sg (Nat * Nat) Application 161 | 162 | appPaint : APP -> List Action 163 | appPaint (_ , app) = let (x , y) = cursorMe app 164 | in goRowCol 0 0 ,- paintAction (paintMe app) +L goRowCol y x ,- [] 165 | 166 | 167 | appHandler : Event -> APP -> APP ** List Action 168 | appHandler (key k) (wh , app) = let app' = handleKey app k 169 | in (wh , app') , appPaint (wh , app') 170 | appHandler (resize w h) (wh , app) = let app' = handleResize app (w , h) 171 | in ((w , h) , app') , appPaint ((w , h) , app') 172 | 173 | -- Code on the Haskell side to make things go 174 | postulate 175 | mainAppLoop : {S : Set} -> -- program state 176 | -- INITIALIZER 177 | S -> -- initial state 178 | -- EVENT HANDLER 179 | (Event -> S -> -- event and state in 180 | S ** List Action) -> -- new state and screen actions out 181 | -- PUT 'EM TOGETHER AND YOU'VE GOT AN APPLICATION! 182 | IO One 183 | {-# COMPILE GHC mainAppLoop = (\ _ -> HaskellSetup.mainAppLoop) #-} 184 | 185 | appMain : (forall wh -> Application wh) -> IO One 186 | appMain app = mainAppLoop ((0 , 0) , app (0 , 0)) appHandler 187 | -- will get resized dynamically to size of terminal, first thing 188 | 189 | rectApp : Char -> Colour -> forall wh -> Application wh 190 | handleKey (rectApp c fg wh) (char c') = rectApp c' fg wh 191 | handleKey (rectApp c fg wh) enter = rectApp c (nextColour fg) wh 192 | where nextColour : Colour -> Colour 193 | nextColour black = red 194 | nextColour red = green 195 | nextColour green = yellow 196 | nextColour yellow = blue 197 | nextColour blue = magenta 198 | nextColour magenta = cyan 199 | nextColour cyan = white 200 | nextColour white = black 201 | handleKey (rectApp c fg wh) _ = rectApp c fg wh 202 | handleResize (rectApp c fg wh) wh' = rectApp c fg wh' 203 | paintMe (rectApp c fg (w , h)) = vPure (vPure (fg - c / black)) 204 | cursorMe (rectApp c fg (w , h)) = 0 , 0 205 | 206 | main : IO One 207 | main = appMain (rectApp '*' green) 208 | 209 | -- agda --compile --ghc-flag "-lncurses" Lecture/Eight.agda 210 | -------------------------------------------------------------------------------- /Lib/Cat/Monad.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type --no-unicode #-} 2 | --{-# OPTIONS --irrelevant-projections #-} 3 | module Lib.Cat.Monad where 4 | 5 | open import Lib.Basics 6 | open import Lib.Cat.Category 7 | open import Lib.Cat.Functor 8 | open import Lib.Cat.NatTrans 9 | open import Lib.Cat.Solver 10 | 11 | module _ {Obj : Set}{Arr : Obj -> Obj -> Set}{C : Category Arr} where 12 | 13 | record Monad {ObjM : Obj -> Obj} 14 | (M : Functor C C ObjM) : Set where 15 | open Category C 16 | open Functor M 17 | field 18 | returnNT : NaturalTransformation (ID C) M 19 | joinNT : NaturalTransformation (M -Func- M) M 20 | module R = NaturalTransformation returnNT 21 | module J = NaturalTransformation joinNT 22 | field 23 | .returnJoin : {X : Obj} -> 24 | (R.transform (ObjM X) -arr- J.transform X) == idArr 25 | .mapReturnJoin : {X : Obj} -> 26 | (map (R.transform X) -arr- J.transform X) == idArr 27 | .joinJoin : {X : Obj} -> 28 | (J.transform (ObjM X) -arr- J.transform X) 29 | == 30 | (map (J.transform X) -arr- J.transform X) 31 | KlArr : Obj -> Obj -> Set 32 | KlArr S T = Arr S (ObjM T) 33 | Kleisli : Category KlArr 34 | Kleisli = record 35 | { idArr = R.transform _ 36 | ; _-arr-_ = \ h k -> h -arr- map k -arr- J.transform _ 37 | ; idArr-arr- = \ {S} {T} f -> 38 | [=IN C ! 39 | (< R.transform S > -syn- (mapSyn M < f > -syn- < J.transform T >)) 40 | =[[ categories refl >>= 41 | (-[ < R.transform S > -syn- mapSyn M < f > ]- -syn- < J.transform T >) 42 | =[[ reduced (rq (R.natural f) , rd) >>= 43 | (-[ < f > -syn- < R.transform (ObjM T) > ]- -syn- < J.transform T >) 44 | =[[ categories refl >>= 45 | (< f > -syn- -[ < R.transform (ObjM T) > -syn- < J.transform T > ]-) 46 | =[[ reduced (rd , rq returnJoin) >>= 47 | (< f > -syn- -[ idSyn ]-) 48 | =[[ categories refl >>= 49 | < f > 50 | [[QED]] 51 | =] 52 | ; _-arr-idArr = \ {S} {T} f -> 53 | (f -arr- (map (R.transform T) -arr- J.transform T)) 54 | =[ (f -arr-_) $= mapReturnJoin >= 55 | (f -arr- idArr) 56 | =[ Category._-arr-idArr C f >= 57 | f 58 | [QED] 59 | ; assoc-arr- = \ {R}{S}{T}{U} f g h -> 60 | [=IN C ! 61 | ((< f > -syn- mapSyn M < g > -syn- < J.transform T >) -syn- mapSyn M < h > -syn- < J.transform U >) 62 | =[[ categories refl >>= 63 | (< f > -syn- mapSyn M < g > -syn- -[ < J.transform T > -syn- mapSyn M < h > ]- -syn- < J.transform U >) 64 | =[[ reduced (rd , rd , rq (J.natural h) , rd) >>= 65 | (< f > -syn- mapSyn M < g > -syn- -[ mapSyn M (mapSyn M < h >) -syn- < J.transform (ObjM U) > ]- 66 | -syn- < J.transform U >) 67 | =[[ categories refl >>= 68 | (< f > -syn- mapSyn M < g > -syn- mapSyn M (mapSyn M < h >) -syn- 69 | -[ < J.transform (ObjM U) > -syn- < J.transform U > ]-) 70 | =[[ reduced (rd , rd , rd , rq joinJoin) >>= 71 | (< f > -syn- mapSyn M < g > -syn- mapSyn M (mapSyn M < h >) -syn- 72 | -[ mapSyn M < J.transform U > -syn- < J.transform U > ]-) 73 | =[[ categories refl >>= 74 | (< f > -syn- mapSyn M (< g > -syn- mapSyn M < h > -syn- < J.transform U >) -syn- < J.transform U >) 75 | [[QED]] 76 | =] 77 | } 78 | 79 | record MonadMorphism 80 | {ObjM : Obj -> Obj}{M : Functor C C ObjM}(MonadM : Monad M) 81 | {ObjN : Obj -> Obj}{N : Functor C C ObjN}(MonadN : Monad N) 82 | : Set 83 | where 84 | open Category C 85 | open Functor 86 | open NaturalTransformation 87 | open Monad 88 | field 89 | mMorph : NaturalTransformation M N 90 | .mMorphReturn : (X : Obj) -> 91 | (transform (returnNT MonadM) X -arr- transform mMorph X) 92 | == transform (returnNT MonadN) X 93 | .mMorphJoin : (X : Obj) -> 94 | (transform (joinNT MonadM) X -arr- transform mMorph X) 95 | == 96 | (transform mMorph (ObjM X) -arr- map N (transform mMorph X) 97 | -arr- transform (joinNT MonadN) X) 98 | 99 | module _ 100 | {ObjM : Obj -> Obj}{M : Functor C C ObjM}{MonadM : Monad M} 101 | {ObjN : Obj -> Obj}{N : Functor C C ObjN}{MonadN : Monad N} 102 | where 103 | open NaturalTransformation 104 | open MonadMorphism 105 | 106 | eqMonadMorph : 107 | (p q : MonadMorphism MonadM MonadN) -> 108 | ((X : Obj) -> transform (mMorph p) X == transform (mMorph q) X) -> 109 | p == q 110 | eqMonadMorph (record { mMorph = p }) (record { mMorph = q }) prf 111 | rewrite eqNatTrans p q prf = refl 112 | 113 | SomeMonad : Set 114 | SomeMonad = Sg (Obj -> Obj) \ ObjM -> 115 | Sg (Functor C C ObjM) \ M -> 116 | Monad M 117 | 118 | module _ where 119 | open Category C 120 | open Functor 121 | open NaturalTransformation 122 | open Monad 123 | open MonadMorphism 124 | 125 | MONAD : Category {SomeMonad} \ { (ObjM , M , MonadM) (ObjN , N , MonadN) -> 126 | MonadMorphism MonadM MonadN } 127 | mMorph (Category.idArr MONAD) = idNT 128 | mMorphReturn (Category.idArr MONAD) X = _-arr-idArr _ 129 | mMorphJoin (Category.idArr MONAD {ObjM , M , MonadM}) X = 130 | [=IN C ! 131 | (< transform (joinNT MonadM) X > -syn- idSyn) 132 | =[[ categories refl >>= 133 | (idSyn -syn- mapSyn M idSyn -syn- < transform (joinNT MonadM) X >) 134 | [[QED]] 135 | =] 136 | 137 | mMorph ((MONAD Category.-arr- mn) np) = mMorph mn -NT- mMorph np 138 | mMorphReturn (Category._-arr-_ MONAD {_ , _ , MonadM} {_ , _ , MonadN} {_ , _ , MonadP} mn np) X 139 | = 140 | [=IN C ! 141 | (< transform (returnNT MonadM) X > -syn- 142 | < transform (mMorph mn) X > -syn- < transform (mMorph np) X >) 143 | =[[ categories refl >>= 144 | (-[ < transform (returnNT MonadM) X > -syn- 145 | < transform (mMorph mn) X > ]- -syn- < transform (mMorph np) X >) 146 | =[[ reduced ((rq (mMorphReturn mn X)) , rd) >>= 147 | (-[ < transform (returnNT MonadN) X > ]- -syn- < transform (mMorph np) X >) 148 | =[[ arrEq (mMorphReturn np X) >>= 149 | < transform (returnNT MonadP) X > 150 | [[QED]] 151 | =] 152 | mMorphJoin (Category._-arr-_ MONAD 153 | {ObjM , M , MonadM} {ObjN , N , MonadN} {ObjP , P , MonadP} mn np) X = 154 | [=IN C ! 155 | (< transform (joinNT MonadM) X > -syn- 156 | < transform (mMorph mn) X > -syn- < transform (mMorph np) X >) 157 | =[[ categories refl >>= 158 | (-[ < transform (joinNT MonadM) X > -syn- 159 | < transform (mMorph mn) X > ]- -syn- < transform (mMorph np) X >) 160 | =[[ reduced (rq (mMorphJoin mn X) , rd) >>= 161 | (-[ < transform (mMorph mn) (ObjM X) > -syn- 162 | mapSyn N < transform (mMorph mn) X > -syn- 163 | < transform (joinNT MonadN) X > ]- 164 | -syn- < transform (mMorph np) X >) 165 | =[[ categories refl >>= 166 | (< transform (mMorph mn) (ObjM X) > -syn- 167 | mapSyn N < transform (mMorph mn) X > -syn- 168 | -[ < transform (joinNT MonadN) X > -syn- 169 | < transform (mMorph np) X > ]-) 170 | =[[ reduced (rd , rd , rq (mMorphJoin np X)) >>= 171 | (< transform (mMorph mn) (ObjM X) > -syn- 172 | mapSyn N < transform (mMorph mn) X > -syn- 173 | -[ < transform (mMorph np) (ObjN X) > -syn- 174 | mapSyn P < transform (mMorph np) X > -syn- 175 | < transform (joinNT MonadP) X > ]-) 176 | =[[ categories refl >>= 177 | (< transform (mMorph mn) (ObjM X) > -syn- 178 | -[ mapSyn N < transform (mMorph mn) X > -syn- 179 | < transform (mMorph np) (ObjN X) > ]- -syn- 180 | mapSyn P < transform (mMorph np) X > -syn- < transform (joinNT MonadP) X >) 181 | =<< reduced (rd , rq (natural (mMorph np) (transform (mMorph mn) X)) , rd , rd) ]]= 182 | (< transform (mMorph mn) (ObjM X) > -syn- 183 | -[ < transform (mMorph np) (ObjM X) > -syn- mapSyn P < transform (mMorph mn) X > ]- -syn- 184 | mapSyn P < transform (mMorph np) X > -syn- < transform (joinNT MonadP) X >) 185 | =[[ categories refl >>= 186 | ((< transform (mMorph mn) (ObjM X) > -syn- < transform (mMorph np) (ObjM X) >) -syn- 187 | mapSyn P (< transform (mMorph mn) X > -syn- < transform (mMorph np) X >) -syn- 188 | < transform (joinNT MonadP) X >) 189 | [[QED]] 190 | =] 191 | 192 | Category.idArr-arr- MONAD f = eqMonadMorph _ _ \ X -> idArr-arr- _ 193 | Category._-arr-idArr MONAD f = eqMonadMorph _ _ \ X -> _ -arr-idArr 194 | Category.assoc-arr- MONAD f g h = eqMonadMorph _ _ \ X -> assoc-arr- _ _ _ 195 | 196 | module _ where 197 | open Functor 198 | open MonadMorphism 199 | 200 | ForgetMONAD : Functor MONAD (FUNCTOR C C) \ { (ObjM , M , _) -> ObjM , M } 201 | map ForgetMONAD = mMorph 202 | mapidArr ForgetMONAD = refl 203 | map-arr- ForgetMONAD f g = refl 204 | 205 | 206 | -------------------------------------------------------------------------------- /Exercise/One.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --allow-unsolved-metas #-} 2 | module Exercise.One where 3 | 4 | open import Lib.Basics 5 | open import Lib.Nat 6 | 7 | ------------------------------------------------------------------------------ 8 | -- ORDER-PRESERVING EMBEDDINGS (or "thinnings" for short) 9 | ------------------------------------------------------------------------------ 10 | 11 | -- The type xs <: ys represents the possible order-preserving 12 | -- embeddings from xs to ys. That means ys is generated by 13 | -- inserting more stuff anywhere in xs, i.e. "thinning" xs. 14 | 15 | data _<:_ {X : Set} : List X -> List X -> Set where 16 | o' : forall {x ys zs} -> ys <: zs -> ys <: x ,- zs -- insert new 17 | os : forall {x ys zs} -> ys <: zs -> x ,- ys <: x ,- zs -- keep old 18 | oz : [] <: [] -- done! 19 | 20 | infix 50 _<:_ 21 | 22 | -- You can also think of xs <: ys as the ways of selecting 23 | -- elements xs from ys, with 24 | -- o' meaning "drop the head", 25 | -- os meaning "take the head", 26 | -- oz meaning "end of list". 27 | 28 | -- You can also see a thinning in xs <: ys as a vector of bits 29 | -- telling whether each element position in ys is connected 30 | -- from an element position in xs. 31 | 32 | -- 2 ,- 4 ,- [] 33 | -- o' (o' (os (o' (os oz)))) 34 | -- 0 ,- 1 ,- 2 ,- 3 ,- 4 ,- [] 35 | 36 | 37 | ------------------------------------------------------------------------------ 38 | -- Exploration (for comprehension rather than credit) 39 | ------------------------------------------------------------------------------ 40 | 41 | -- Lists of elements of One are a lot like numbers 42 | 43 | num : Nat -> List One 44 | num zero = [] 45 | num (suc n) = <> ,- num n 46 | 47 | -- Using C-c C-a with -l and -s options, generate exhaustive lists of 48 | -- thinnings with the following types. 49 | 50 | pick0from4 : List (num 0 <: num 4) 51 | pick0from4 = {!!} 52 | 53 | pick1from4 : List (num 1 <: num 4) 54 | pick1from4 = {!!} 55 | 56 | pick2from4 : List (num 2 <: num 4) 57 | pick2from4 = {!!} 58 | 59 | pick3from4 : List (num 3 <: num 4) 60 | pick3from4 = {!!} 61 | 62 | pick4from4 : List (num 4 <: num 4) 63 | pick4from4 = {!!} 64 | 65 | -- But with more interesting elements, we have fewer options, sometimes. 66 | 67 | thinOdds : List (1 ,- 3 ,- 5 ,- [] <: 0 ,- 1 ,- 2 ,- 3 ,- 4 ,- 5 ,- 6 ,- []) 68 | thinOdds = {!!} 69 | 70 | 71 | ------------------------------------------------------------------------------ 72 | -- 1.1 Categorical Structure 73 | ------------------------------------------------------------------------------ 74 | 75 | -- Construct the identity thinning from any list to itself. 76 | 77 | oi : forall {X}{xs : List X} -> xs <: xs 78 | oi = {!!} 79 | 80 | -- Give composition for thinnings. Minimize the number of cases. 81 | 82 | _-<-_ : forall {X}{xs ys zs : List X} -> xs <: ys -> ys <: zs -> xs <: zs 83 | th -<- ph = {!!} 84 | 85 | infixl 40 _-<-_ 86 | 87 | -- Prove the following laws. Minimize the number of cases (which will 88 | -- depend on your definition of _-<-_). 89 | 90 | oi-<- : forall {X}{xs ys : List X}(ph : xs <: ys) -> oi -<- ph == ph 91 | oi-<- ph = {!!} 92 | 93 | _-<-oi : forall {X}{xs ys : List X}(th : xs <: ys) -> th -<- oi == th 94 | th -<-oi = {!!} 95 | 96 | assoc-<- : forall {X}{ws xs ys zs : List X} 97 | (th0 : ws <: xs)(th1 : xs <: ys)(th2 : ys <: zs) -> 98 | (th0 -<- th1) -<- th2 == th0 -<- (th1 -<- th2) 99 | assoc-<- th0 th1 th2 = {!!} 100 | 101 | 102 | ------------------------------------------------------------------------------ 103 | -- 1.2 Emptiness 104 | ------------------------------------------------------------------------------ 105 | 106 | -- Show that the empty list embeds into all lists in a unique way. 107 | 108 | oe : forall {X}{xs : List X} -> [] <: xs 109 | oe = {!!} 110 | 111 | oe-unique : forall {X}{xs : List X}(th : [] <: xs) -> th == oe 112 | oe-unique th = {!!} 113 | 114 | 115 | ------------------------------------------------------------------------------ 116 | -- 1.3 Antisymmetry 117 | ------------------------------------------------------------------------------ 118 | 119 | -- Show that if two lists are mutually embeddable, they are equal 120 | -- and the embeddings are the identity. 121 | 122 | antisym : forall {X}{xs ys : List X} 123 | (th : xs <: ys)(ph : ys <: xs) -> 124 | Sg (xs == ys) \ 125 | { refl -> th == oi * ph == oi } 126 | antisym th ph = {!!} 127 | 128 | -- Deduce that oi is unique. 129 | 130 | oi-unique : forall {X}{xs : List X}(th : xs <: xs) -> th == oi 131 | oi-unique th = {!!} 132 | 133 | 134 | ------------------------------------------------------------------------------ 135 | -- 1.4 Thinnings as selections 136 | ------------------------------------------------------------------------------ 137 | 138 | -- We can use the "selection" interpretation of thinnings to act 139 | -- on data indexed by lists. 140 | -- The type All P ys has elements of type P y for each y in ys. 141 | -- If xs <: ys, show that we can get P x for each x in xs. 142 | 143 | select : forall {X}{xs ys : List X}{P : X -> Set} -> 144 | xs <: ys -> All P ys -> All P xs 145 | select th pys = {!!} 146 | 147 | -- Now prove the following laws relating to selecting by the 148 | -- identity and composition. 149 | 150 | select-oi : forall {X}{xs : List X}{P : X -> Set} -> (pxs : All P xs) -> 151 | select oi pxs == pxs 152 | select-oi pxs = {!!} 153 | 154 | select-<- : forall {X}{xs ys zs : List X}{P : X -> Set} -> 155 | (th : xs <: ys)(ph : ys <: zs) -> (pzs : All P zs) -> 156 | select (th -<- ph) pzs == select th (select ph pzs) 157 | select-<- th ph pzs = {!!} 158 | 159 | 160 | ------------------------------------------------------------------------------ 161 | -- 1.5 Splittings 162 | ------------------------------------------------------------------------------ 163 | 164 | -- If we have two thinnings, 165 | -- th : xs <: zs 166 | -- ph : ys <: zs 167 | -- we can say what it means for th and ph to *split* zs: 168 | -- every element position in zs is connected from either 169 | -- a position in xs or from a position in ys, but *not both*. 170 | 171 | data Splitting {X : Set} : {xs ys zs : List X} 172 | (th : xs <: zs)(ph : ys <: zs) 173 | -> Set where 174 | split's : forall {w xs ys zs}{th : xs <: zs}{ph : ys <: zs} -> 175 | Splitting th ph -> 176 | Splitting {zs = w ,- _} (o' th) (os ph) 177 | splits' : forall {w xs ys zs}{th : xs <: zs}{ph : ys <: zs} -> 178 | Splitting th ph -> 179 | Splitting {zs = w ,- _} (os th) (o' ph) 180 | splitzz : Splitting oz oz 181 | 182 | -- Show that if we know how xs <: zs, we can find a splitting of zs by 183 | -- computing... 184 | 185 | thinSplit : {X : Set}{xs zs : List X}(th : xs <: zs) -> 186 | Sg (List X) \ ys -> -- ...what wasn't from xs... 187 | Sg (ys <: zs) \ ph -> -- ...but was in zs... 188 | Splitting th ph -- ...hence forms a splitting. 189 | thinSplit th = {!!} 190 | 191 | -- Given a splitting, show that we can "riffle" together a bunch 192 | -- of "All P"-s for each selection to get an "All P" for the whole. 193 | 194 | riffle : forall {X : Set}{xs ys zs : List X} 195 | {th : xs <: zs}{ph : ys <: zs} 196 | {P : X -> Set} -> 197 | All P xs -> Splitting th ph -> All P ys -> 198 | All P zs 199 | riffle pxs s pys = {!!} 200 | 201 | -- Moreover, we can use a splitting to invert "riffle", dealing 202 | -- out an "All P" for the whole list into the parts for each 203 | -- selection in the splitting, and making sure that the parts 204 | -- riffle back together to make the whole. 205 | 206 | data Deal {X : Set}{xs ys zs : List X} 207 | {th : xs <: zs}{ph : ys <: zs}(s : Splitting th ph) 208 | {P : X -> Set} : 209 | All P zs -> Set where 210 | dealt : (pxs : All P xs)(pys : All P ys) -> Deal s (riffle pxs s pys) 211 | 212 | deal : {X : Set}{xs ys zs : List X} 213 | {th : xs <: zs}{ph : ys <: zs}(s : Splitting th ph) 214 | {P : X -> Set}(pzs : All P zs) -> Deal s pzs 215 | deal s pzs = {!!} 216 | 217 | 218 | ------------------------------------------------------------------------------ 219 | -- 1.6 Composability as a relation 220 | ------------------------------------------------------------------------------ 221 | 222 | -- We have the composition *operator*, but it is sometimes more 223 | -- convenient to work with the *call graph* of the composition operator, 224 | -- giving the explanations for why an output comes from some input. 225 | 226 | -- For example, the call graph of our boolean <= operator from Lecture.One 227 | -- _<=_ : Nat -> Nat -> Two 228 | -- zero <= y = tt 229 | -- suc x <= zero = ff 230 | -- suc x <= suc y = x <= y 231 | 232 | -- would be 233 | -- data Graph<= : Nat -> Nat -> Two -> Set where 234 | -- le-z-y : forall {y} -> Graph<= zero y tt 235 | -- le-s-z : forall {x} -> Graph<= (suc x) zero ff 236 | -- le-s-s : forall {x y b} -> Graph<= x y b -> Graph<= (suc x) (suc y) b 237 | 238 | -- so that we can always show 239 | -- graph<= : (x y : Nat) -> Graph<= x y (x <= y) 240 | 241 | -- Define the inductive composability relation on three thinnings. 242 | -- This should correspond to your composition function, with one 243 | -- constructor per line of your function, and one recursive substructure 244 | -- per recursive call. We've written the type declaration, but you need 245 | -- to add the constructors. 246 | 247 | -- No defined function symbols should appear in any of the type indices, 248 | -- just variables and constructors. That means dependent pattern matching 249 | -- will play nice. 250 | 251 | data Composable-<- {X : Set} 252 | : {xs ys zs : List X} 253 | (th : xs <: ys)(ph : ys <: zs)(thph : xs <: zs) 254 | -> Set where 255 | -- your constructors here! 256 | 257 | -- Show that your definition really captures composability by 258 | -- proving the following. 259 | 260 | composable-<- : forall {X : Set}{xs ys zs : List X} 261 | (th : xs <: ys)(ph : ys <: zs) -> 262 | Composable-<- th ph (th -<- ph) 263 | -- i.e., we have *at least* composition... 264 | composable-<- th ph = {!!} 265 | 266 | composable-unique : forall {X : Set}{xs ys zs : List X} 267 | {th : xs <: ys}{ph : ys <: zs} 268 | {thph thph' : xs <: zs} -> 269 | Composable-<- th ph thph -> 270 | Composable-<- th ph thph' -> 271 | thph == thph' 272 | -- ...and nothing but composition. 273 | composable-unique c d = {!!} 274 | 275 | -- Your prize for establishing the graph representation is to have a nice time 276 | -- showing that thinnings really are *embeddings* (or "monomorphisms"). 277 | -- If you have two thinnings, th and th' that compose with some ph to get 278 | -- equal results, th and th' must have been equal in the first place. That 279 | -- tells you something important about ph, namely that it maps all its source 280 | -- positions to distinct target positions. 281 | 282 | composable-mono : forall {X}{xs ys zs : List X} 283 | {th th' : xs <: ys}{ph : ys <: zs}{ps : xs <: zs} -> 284 | Composable-<- th ph ps -> Composable-<- th' ph ps -> 285 | th == th' 286 | composable-mono c d = {!!} 287 | 288 | -- Now use composable-<- and composable-mono to get a cheap proof of the 289 | -- following. 290 | 291 | mono-<- : forall {X}{xs ys zs : List X}(th th' : xs <: ys)(ph : ys <: zs) -> 292 | th -<- ph == th' -<- ph -> 293 | th == th' 294 | mono-<- th th' ph q = {!!} 295 | 296 | 297 | ------------------------------------------------------------------------------ 298 | -- 1.7 Pullbacks (pointwise "and") 299 | ------------------------------------------------------------------------------ 300 | 301 | -- If we have a situation like this 302 | 303 | -- 304 | -- ys 305 | -- | 306 | -- | ph 307 | -- v 308 | -- xs ------> zs 309 | -- th 310 | 311 | -- we say a "BackSquare" extends the situation to a square 312 | 313 | -- side1 314 | -- corner ------> ys 315 | -- | | 316 | -- side0| | ph 317 | -- v v 318 | -- xs ------> zs 319 | -- th 320 | 321 | -- where the *same* diagonal is both side0 -<- th and side1 -<- ph, 322 | -- so either path around the square gives the same thinning. 323 | 324 | record BackSquare {X}{xs ys zs : List X} 325 | (th : xs <: zs)(ph : ys <: zs) : Set where 326 | constructor backSquare 327 | field 328 | {corner} : List X 329 | {side0} : corner <: xs 330 | {side1} : corner <: ys 331 | {diagonal} : corner <: zs 332 | triangle0 : Composable-<- side0 th diagonal 333 | triangle1 : Composable-<- side1 ph diagonal 334 | 335 | open BackSquare 336 | 337 | -- The corner of the "best" BackSquare is called a *pullback*, 338 | -- (and the square is called a "pullback square"). What's best 339 | -- about it is that the corner of every other BackSquare embeds 340 | -- in it. That is, it has all the things that both th and ph 341 | -- select from zs. 342 | 343 | -- First, construct the pullback square. 344 | 345 | pullback-<- : forall {X}{xs ys zs : List X} -> 346 | (th : xs <: zs)(ph : ys <: zs) -> 347 | BackSquare th ph 348 | pullback-<- th ph = {!!} 349 | 350 | -- Then show that every other BackSquare has a corner 351 | -- which embeds in the pullback, and that the resulting 352 | -- triangles commute. 353 | 354 | pullback-best : forall {X}{xs ys zs : List X} -> 355 | {th : xs <: zs}{ph : ys <: zs} -> 356 | let bs = pullback-<- th ph in 357 | (bs' : BackSquare th ph) -> 358 | Sg (corner bs' <: corner bs) \ ps -> 359 | Composable-<- ps (side0 bs) (side0 bs') * 360 | Composable-<- ps (side1 bs) (side1 bs') 361 | pullback-best bs' = {!!} 362 | -------------------------------------------------------------------------------- /Exercise/Two.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | {-# OPTIONS --allow-unsolved-metas #-} 3 | 4 | module Exercise.Two where 5 | 6 | open import Lib.Basics 7 | open import Lib.Indexed -- important stuff in here! 8 | open import Lib.Cat.Category 9 | open import Lib.Cat.Functor 10 | open import Lib.Cat.NatTrans 11 | open import Lib.Cat.Monad 12 | open import Lib.Cat.Adjunction 13 | open import Lib.Nat 14 | 15 | open import Exercise.One 16 | 17 | ------------------------------------------------------------------------------ 18 | -- CATEGORIES OF INDEXED OBJECTS AND ARROWS 19 | ------------------------------------------------------------------------------ 20 | 21 | -- We fix an underlying category and a set I for "index"... 22 | 23 | module _ {Obj : Set}{Arr : Obj -> Obj -> Set}(I : Set)(C : Category Arr) where 24 | 25 | open Category C 26 | 27 | -- ... and now your job is to build a new category whose 28 | -- objects are I-indexed families of underlying objects, and whose 29 | -- arrows are index-respecting families of underlying arrows 30 | 31 | _-C>_ : Category {I -> Obj} \ S T -> (i : I) -> Arr (S i) (T i) 32 | _-C>_ = {!!} 33 | 34 | 35 | -- Now we give you a function f : I -> J between two index sets. 36 | 37 | module _ {Obj : Set}{Arr : Obj -> Obj -> Set}{I J : Set} 38 | (f : I -> J)(C : Category Arr) where 39 | 40 | open Category C 41 | open Functor 42 | 43 | -- Show that you get a functor from J-indexed things to I-indexed things. 44 | 45 | Reindex : Functor (J -C> C) (I -C> C) (f -_) 46 | Reindex = {!!} 47 | 48 | 49 | ------------------------------------------------------------------------------ 50 | -- FUNCTORIALITY OF ALL 51 | ------------------------------------------------------------------------------ 52 | 53 | -- We have All in the library. Show that it is a functor from 54 | -- element-indexed sets to list-indexed sets. 55 | 56 | module _ where 57 | 58 | open Functor 59 | 60 | all : {I : Set}{P Q : I -> Set} -> 61 | [ P -:> Q ] -> 62 | [ All P -:> All Q ] 63 | all f is ps = {!!} 64 | 65 | ALL : (I : Set) -> Functor (I -C> SET) (List I -C> SET) All 66 | ALL I = {!!} 67 | 68 | 69 | ------------------------------------------------------------------------------ 70 | -- ALL BY TABULATION 71 | ------------------------------------------------------------------------------ 72 | 73 | -- The list membership relation is given by thinning from singletons. 74 | 75 | _<-_ : {I : Set} -> I -> List I -> Set 76 | i <- is = (i ,- []) <: is 77 | 78 | -- If every element of a list satisfies P, you should be able to 79 | -- collect all the Ps. 80 | 81 | tabulate : {I : Set}{P : I -> Set}(is : List I) -> 82 | [ (_<- is) -:> P ] -> All P is 83 | tabulate is f = {!!} 84 | 85 | module _ (I : Set) where -- fix an element set and open handy kit 86 | open Category (I -C> SET) 87 | open Functor 88 | open NaturalTransformation 89 | 90 | -- Show that the functional presentation of "each element is P" 91 | -- also gives you a functor. 92 | 93 | AllMem : Functor (I -C> SET) (List I -C> SET) \ P is -> [ (_<- is) -:> P ] 94 | AllMem = {!!} 95 | 96 | -- Prove that tabulate is natural. 97 | 98 | tabulateNT : NaturalTransformation AllMem (ALL I) 99 | transform tabulateNT _ = tabulate 100 | natural tabulateNT = {!!} 101 | 102 | 103 | ------------------------------------------------------------------------------ 104 | -- 26 November 2018 -- the adventure continues 105 | ------------------------------------------------------------------------------ 106 | 107 | module _ {Obj : Set}{Arr : Obj -> Obj -> Set}{I : Set}(C : Category Arr) where 108 | open Category C 109 | open Functor 110 | 111 | -- Show that you can get a functor from (I -C> C) back to C, just 112 | -- by picking an index. 113 | 114 | Point : (i : I) -> Functor (I -C> C) C \ X -> X i 115 | Point i = {!!} 116 | 117 | module _ (I : Set) where 118 | open Category (I -C> SET) 119 | open Functor 120 | open NaturalTransformation 121 | 122 | -- Prove that the "select" function from Exercise.One is natural. 123 | 124 | selectNT : {is js : List I}(th : is <: js) -> 125 | NaturalTransformation 126 | (ALL I -Func- Point SET js) 127 | (ALL I -Func- Point SET is) 128 | transform (selectNT th) X = select th 129 | natural (selectNT th) f = {!!} 130 | 131 | -- Show that tabulation fuses with selection. 132 | 133 | selectTabulate : {I : Set}{P : I -> Set}{is js : List I} 134 | (th : is <: js)(f : [ (_<- js) -:> P ]) -> 135 | select th (tabulate js f) == tabulate is \ i x -> f i (x -<- th) 136 | selectTabulate th f = {!!} 137 | 138 | -- Construct the proof that all elements of a list have the property 139 | -- of being somewhere in the list. 140 | 141 | positions : (is : List I) -> All (_<- is) is 142 | positions is = tabulate is {!!} 143 | 144 | -- Construct a natural transformation which extracts the only element 145 | -- from an All P (i ,- []) 146 | 147 | onlyNT : NaturalTransformation 148 | (ALL I -Func- Reindex (_,- []) SET) 149 | (ID (I -C> SET)) 150 | onlyNT = {!!} 151 | 152 | -- From these components, assemble the natural transformation which projects 153 | -- one element from a bunch. That is, if we have (x : i <- is) and we have 154 | -- Ps for all the is, then we should certainly have a P i. 155 | 156 | projectNT : {i : I}{is : List I}(x : i <- is) -> 157 | NaturalTransformation (ALL I -Func- Point SET is) (Point SET i) 158 | projectNT x = {!!} 159 | 160 | -- Show that tabulating projections is the identity. 161 | 162 | tabulateProject : {P : I -> Set}{is : List I}(ps : All P is) -> 163 | tabulate is (\ i x -> transform (projectNT x) P ps) == ps 164 | tabulateProject ps = {!!} 165 | 166 | -- Show that projecting from a tabulation applies the tabulated function. 167 | 168 | projectTabulate : {P : I -> Set}{is : List I} 169 | (f : (i : I) -> i <- is -> P i) 170 | {i : I}(x : i <- is) -> 171 | transform (projectNT x) P (tabulate is f) == f i x 172 | projectTabulate f x = {!!} 173 | 174 | -- A useful way to show that two "All" structures are equal is to show that 175 | -- they agree at each projection. Make it so! Hint: tabulateProject. 176 | 177 | eqAll : {P : I -> Set}{is : List I}{ps0 ps1 : All P is} -> 178 | ((i : I)(x : i <- is) -> 179 | transform (projectNT x) P ps0 == transform (projectNT x) P ps1) -> 180 | ps0 == ps1 181 | eqAll {ps0 = ps0}{ps1 = ps1} q = {!!} 182 | 183 | 184 | 185 | ------------------------------------------------------------------------------ 186 | -- HOW TO CUT THINGS UP 187 | ------------------------------------------------------------------------------ 188 | 189 | record _<|_ (O{-utside-} I{-nside-} : Set) : Set where 190 | constructor _ Set -- for every Outside, there is a set of ways to cut it 193 | pieces : {o : O} -> Cuts o -> List I 194 | -- into a bunch of pieces which are Inside 195 | 196 | -- This information amounts to giving an indexed container with finitely 197 | -- many positions. As a consequence, we can use All to collect the 198 | -- substructures which fill the pieces inside. 199 | 200 | module _ {O I : Set} where 201 | 202 | open Category 203 | open Functor 204 | open _<|_ 205 | 206 | [[_]]Cr : O <| I -> (I -> Set) -- what's filling the insides? 207 | -> (O -> Set) 208 | [[ Cu All P (ps c) -- then fill all the insides 210 | 211 | -- Extend [[_]]Cr to a Functor. 212 | 213 | [[_]]CrF : (F : O <| I) -> 214 | Functor (I -C> SET) (O -C> SET) [[ F ]]Cr 215 | [[ Cu Set 222 | Cutmorph (Cu [[ G ]]Cr (_<- ps cu) o -- choose a target cut, and say which source 225 | -- piece goes in each target position 226 | 227 | module _ (F G : O <| I) where 228 | 229 | open NaturalTransformation 230 | module GF = Functor [[ G ]]CrF 231 | 232 | -- Show that every Cutmorph induces a natural transformation. 233 | -- Proving it is natural is an opportunity to deploy eqAll. 234 | 235 | CutmorphNT : Cutmorph F G -> NaturalTransformation [[ F ]]CrF [[ G ]]CrF 236 | CutmorphNT m = {!!} 237 | 238 | -- Extract a Cutmorph from an arbitrary natural transformation by choosing 239 | -- a suitable element type. 240 | 241 | ntCutmorph : NaturalTransformation [[ F ]]CrF [[ G ]]CrF -> Cutmorph F G 242 | ntCutmorph k = {!!} 243 | 244 | -- Construct identity and composition for Cutmorphs. Hint: you've done the 245 | -- hard work already. 246 | 247 | idCutmorph : {F : O <| I} -> Cutmorph F F 248 | idCutmorph = {!!} 249 | 250 | _-Cutmorph-_ : {F G H : O <| I} -> Cutmorph F G -> Cutmorph G H -> Cutmorph F H 251 | fg -Cutmorph- gh = {!!} 252 | 253 | -- We have left the following goal commented out, because it involves more heat 254 | -- than light. 255 | -- CUTMORPH : Category Cutmorph 256 | -- CUTMORPH = ? 257 | 258 | 259 | ------------------------------------------------------------------------------ 260 | -- HOW TO CUT THINGS UP INTO LOTS OF LITTLE TINY PIECES 261 | ------------------------------------------------------------------------------ 262 | 263 | module _ {I : Set}(F : I <| I) where 264 | 265 | -- If the insides have the same index type as the outsides, we can cut and 266 | -- cut again. 267 | 268 | data Tree (X : I -> Set)(i : I) : Set where 269 | leaf : X i -> Tree X i 270 | <_> : [[ F ]]Cr (Tree X) i -> Tree X i 271 | 272 | -- The following wrap the constructors as arrows in I -C> SET. 273 | 274 | iLeaf : {X : I -> Set} -> [ X -:> Tree X ] 275 | iLeaf i = leaf 276 | iNode : {X : I -> Set} -> [ [[ F ]]Cr (Tree X) -:> Tree X ] 277 | iNode i = <_> 278 | 279 | module _ {X Y : I -> Set} -- Suppose we can turn ... 280 | (l : [ X -:> Y ]) -- ... leaves into Ys, and ... 281 | (n : [ [[ F ]]Cr Y -:> Y ]) -- ... nodes made of Ys into Ys. 282 | where 283 | 284 | -- Show that we can turn whole trees into Ys. 285 | -- You will need to inline functoriality of All to get the 286 | -- termination checker to shut up. 287 | 288 | treeIter : [ Tree X -:> Y ] 289 | allTreeIter : [ All (Tree X) -:> All Y ] 290 | treeIter i xt = {!!} 291 | allTreeIter is xts = {!!} 292 | 293 | 294 | module _ where 295 | open Category (I -C> SET) 296 | 297 | -- Use treeIter, rather than pattern matching, to construct the following 298 | -- operation which should preserve nodes and graft on more tree at the leaves. 299 | 300 | treeBind : {X Y : I -> Set} -> [ X -:> Tree Y ] -> [ Tree X -:> Tree Y ] 301 | treeBind k = {!!} 302 | 303 | -- Use treeBind to implement "map" and "join" for trees. 304 | -- They're one-liners. 305 | 306 | tree : {X Y : I -> Set} -> [ X -:> Y ] -> [ Tree X -:> Tree Y ] 307 | tree f = {!!} 308 | 309 | treeJoin : {X : I -> Set} -> [ Tree (Tree X) -:> Tree X ] 310 | treeJoin = {!!} 311 | 312 | 313 | -- Show that replacing leaves by leaves and nodes by nodes achieves little. 314 | -- This will need a proof by induction. 315 | 316 | treeIterId : {X : I -> Set} -> treeIter (iLeaf {X = X}) iNode == idArr 317 | treeIterId = {!!} 318 | 319 | 320 | -- The following result will be of considerable assistance. 321 | 322 | module _ {W X Y : I -> Set} 323 | (k : [ W -:> Tree X ]) -- how to grow more tree 324 | (l : [ X -:> Y ]) -- how to eat leaves 325 | (n : [ [[ F ]]Cr Y -:> Y ]) -- how to eat nodes 326 | where 327 | open Category (I -C> SET) 328 | 329 | -- Show that growing a tree with treeBind then eating the result 330 | -- gives the same as eating the original with more eating at the leaves. 331 | 332 | treeBindIter : (treeBind k -arr- treeIter l n) 333 | == 334 | treeIter (k -arr- treeIter l n) n 335 | treeBindIter = {!!} 336 | 337 | -- Suitably tooled up, go for the win. 338 | 339 | module _ where 340 | open Category (I -C> SET) 341 | open Functor 342 | open NaturalTransformation 343 | open Monad 344 | 345 | -- You have implemented "map" and "join". 346 | -- Prove that you have a functor and a monad. 347 | 348 | TREE : Functor (I -C> SET) (I -C> SET) Tree 349 | map TREE = tree 350 | mapidArr TREE = {!!} 351 | map-arr- TREE = {!!} 352 | 353 | treeMonad : Monad TREE 354 | transform (returnNT treeMonad) X = iLeaf 355 | natural (returnNT treeMonad) = {!!} 356 | transform (joinNT treeMonad) X = treeJoin 357 | natural (joinNT treeMonad) = {!!} 358 | returnJoin treeMonad = {!!} 359 | mapReturnJoin treeMonad = {!!} 360 | joinJoin treeMonad = {!!} 361 | 362 | 363 | ------------------------------------------------------------------------------ 364 | -- AND RELAX 365 | ------------------------------------------------------------------------------ 366 | 367 | -- If "outsides" are a numerical size z, 368 | -- we might cut them into two pieces whose sizes add up to z. 369 | 370 | NatCut : Nat <| Nat 371 | NatCut = (\ z -> Sg Nat \ x -> Sg Nat \ y -> (x +N y) == z) 372 | x ,- y ,- []}) 373 | 374 | twoToThe : Nat -> Nat 375 | twoToThe zero = 1 376 | twoToThe (suc n) = twoToThe n +N twoToThe n 377 | 378 | -- You have to make a big tree out of Xs, but you have only an X of size 1. 379 | -- There is more than one right answer. 380 | 381 | bigTree : (X : Nat -> Set) -> X 1 -> (n : Nat) -> Tree NatCut X (twoToThe n) 382 | bigTree X x n = {!!} 383 | 384 | -- We'll see more of Tree and NatCut next time... 385 | 386 | 387 | ------------------------------------------------------------------------------ 388 | -- END OF EXERCISE TWO 389 | ------------------------------------------------------------------------------ 390 | -------------------------------------------------------------------------------- /Lecture/SixPrime.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type --no-unicode #-} 2 | {-# OPTIONS --irrelevant-projections #-} 3 | module Lecture.SixPrime where 4 | 5 | open import Lib.Basics 6 | open import Lib.Cat.Category 7 | open import Lib.Cat.Functor 8 | open import Lib.Cat.NatTrans 9 | open import Lib.Cat.Adjunction 10 | open import Lib.Cat.Monad 11 | open import Lib.Cat.Solver 12 | 13 | {- 14 | module _ {ObjF : Set -> Set}(F : Functor SET SET ObjF) where 15 | 16 | open NaturalTransformation 17 | open MonadMorphism 18 | open Functor 19 | open Monad 20 | 21 | data M (X : Set) : Set where 22 | ret : X -> M X 23 | layer : ObjF (M X) -> M X 24 | 25 | -- ObjF X = X -> X would make Agda allow programs that loop 26 | 27 | -- ObjF X = (X -> Two) -> Two is a functor, but allowing this makes 28 | -- the logic inconsistent with classical logic: it claims Pow (PowX) = X 29 | 30 | funM : Functor SET SET M 31 | map funM h (ret x) = ret (h x) 32 | map funM h (layer fx) = layer {!!} 33 | mapidArr funM = {!!} 34 | map-arr- funM = {!!} 35 | 36 | retM : NaturalTransformation (ID SET) funM 37 | transform retM X = ret 38 | natural retM = {!!} 39 | 40 | joinM : NaturalTransformation (funM -Func- funM) funM 41 | transform joinM X (ret mx) = mx 42 | transform joinM X (layer fx) = layer {!!} 43 | natural joinM = {!!} 44 | 45 | MonadM : Monad funM 46 | returnNT MonadM = retM 47 | joinNT MonadM = joinM 48 | returnJoin MonadM = {!!} 49 | mapReturnJoin MonadM = {!!} 50 | joinJoin MonadM = {!!} 51 | 52 | morph : {ObjN : Set -> Set}{N : Functor SET SET ObjN}(MonadN : Monad N) 53 | (f : NaturalTransformation F N) -> 54 | MonadMorphism MonadM MonadN 55 | transform (mMorph (morph MonadN f)) X (ret x) = transform (returnNT MonadN) X x 56 | transform (mMorph (morph MonadN f)) X (layer fx) = {!!} 57 | natural (mMorph (morph MonadN f)) k = {!!} 58 | mMorphReturn (morph MonadN f) X = refl 59 | mMorphJoin (morph MonadN f) = {!!} 60 | -} 61 | 62 | record Con{-tainer-} : Set where 63 | constructor _ Set 67 | 68 | [[_]]C : Con -> Set -> Set 69 | [[ Sh Po s -> X 70 | 71 | map {X Y : Set} -> (X -> Y) -> [[ C ]]C X -> [[ C ]]C Y 72 | map Functor SET SET [[ C ]]C 75 | Functor.map [[ C ]]CF = map M C X 81 | layer : [[ C ]]C (M C X) -> M C X 82 | 83 | join : {C : Con}{X : Set} -> M C (M C X) -> M C X 84 | join (ret mx) = mx 85 | join (layer (s , f)) = layer (s , (\ p -> join (f p))) 86 | 87 | 88 | -- The category of container functors 89 | 90 | CON : Category {Con} \ { C C' -> NaturalTransformation ([[ C ]]CF) ([[ C' ]]CF) } 91 | Category.idArr CON = idNT 92 | Category._-arr-_ CON = _-NT-_ 93 | Category.idArr-arr- CON f = refl 94 | Category._-arr-idArr CON f = refl 95 | Category.assoc-arr- CON f g h = refl 96 | 97 | 98 | 99 | module _ {C : Con} where 100 | 101 | open Functor 102 | open Monad 103 | 104 | MC : Set -> Set 105 | MC = M C 106 | 107 | mapM : {X Y : Set} -> (X -> Y) -> MC X -> MC Y 108 | mapM f (ret x) = ret (f x) 109 | mapM f (layer (s , g)) = layer (s , (\ x -> mapM f (g x))) 110 | 111 | mapMid : {X : Set} -> (x : MC X) -> mapM id x == x 112 | mapMid (ret x) = refl 113 | mapMid (layer (s , g)) = (\ z → layer (s , z)) $= ext (\ x -> mapMid (g x)) 114 | 115 | mapM-arr- : {X Y Z : Set}{f : X -> Y}{g : Y -> Z} -> 116 | (x : MC X) -> mapM (f - g) x == (mapM f - mapM g) x 117 | mapM-arr- (ret x) = refl 118 | mapM-arr- (layer (s , h)) = (\ z → layer (s , z)) 119 | $= ext (\ x -> mapM-arr- (h x)) 120 | 121 | joinNatural : {X Y : Set}(f : X -> Y) -> (x : M C (M C X)) -> 122 | mapM f (join x) == (join (mapM (mapM f) x)) 123 | joinNatural f (ret x) = refl 124 | joinNatural f (layer (s , g)) = (\ z → layer (s , z)) 125 | $= ext (\ x -> joinNatural f (g x)) 126 | 127 | joinLaw2 : {X : Set}(x : M C X) -> join (mapM ret x) == x 128 | joinLaw2 (ret x) = refl 129 | joinLaw2 (layer (s , g)) = (\ z → layer (s , z)) 130 | $= ext (\ x -> joinLaw2 (g x)) 131 | 132 | joinLaw3 : {X : Set}(x : M C (M C (M C X))) -> 133 | join (join x) == join (mapM join x) 134 | joinLaw3 (ret x) = refl 135 | joinLaw3 (layer (s , g)) = (\ z → layer (s , z)) 136 | $= ext (\ x -> joinLaw3 (g x)) 137 | 138 | 139 | module _ (C : Con) where 140 | 141 | open Functor 142 | open Monad 143 | open NaturalTransformation 144 | 145 | funM : Functor SET SET (M C) 146 | map funM = mapM 147 | mapidArr funM = ext mapMid 148 | map-arr- funM f g = ext mapM-arr- 149 | 150 | 151 | monadM : Monad funM 152 | transform (returnNT monadM) X = ret 153 | natural (returnNT monadM) f = refl 154 | transform (joinNT monadM) X = join 155 | natural (joinNT monadM) f = ext (joinNatural f) 156 | returnJoin monadM = refl 157 | mapReturnJoin monadM = ext joinLaw2 158 | joinJoin monadM = ext joinLaw3 159 | 160 | 161 | module _ where 162 | 163 | open Functor 164 | open NaturalTransformation 165 | open MonadMorphism 166 | 167 | 168 | Mmap : forall {C C'} -> 169 | ((X : Set) -> [[ C ]]C X -> [[ C' ]]C X) -> 170 | (X : Set) -> M C X -> M C' X 171 | Mmap e X (ret x) = ret x 172 | Mmap e X (layer (s , g)) = layer (e _ (s , \ x -> Mmap e X (g x))) 173 | 174 | 175 | .Mmap-natural : forall {C C'} -> 176 | (e : NaturalTransformation [[ C ]]CF [[ C' ]]CF) -> 177 | {X Y : Set} (f : X -> Y) -> (x : M C X) -> 178 | mapM f (Mmap (transform e) X x) == Mmap (transform e) Y (mapM f x) 179 | Mmap-natural e f (ret x) = refl 180 | Mmap-natural {C} {C'} e {X} {Y} f (layer (s , g)) = layer $= ( 181 | (fst 182 | (transform e (M C' X) (s , (\ x -> Mmap (transform e) X (g x)))) 183 | , 184 | (snd (transform e (M C' X) 185 | (s , (\ x -> Mmap (transform e) X (g x)))) - (mapM f))) 186 | =[ refl >= 187 | (map z (s , g)) $= 189 | ([=IN SET ! 190 | mapSyn [[ C ]]CF < Mmap (transform e) X > -syn- 191 | -[ < transform e (M C' X) > -syn- 192 | mapSyn [[ C' ]]CF < mapM f > ]- 193 | =[[ reduced (rd , rq (natural e (mapM f))) >>= 194 | mapSyn [[ C ]]CF < Mmap (transform e) X > -syn- 195 | -[ mapSyn [[ C ]]CF < mapM f > -syn- 196 | < transform e (M C' Y) > ]- 197 | =[[ categories refl >>= 198 | mapSyn [[ C ]]CF (< Mmap (transform e) X > -syn- 199 | < mapM f >) -syn- < transform e (M C' Y) > [[QED]] =]) 200 | >= 201 | (map Mmap-natural e f (g x)) >= 203 | transform e (M C' Y) (s , (\ x -> Mmap (transform e) Y (mapM f (g x)))) 204 | [QED]) 205 | 206 | .mjLaw : forall {C C'} 207 | (e : NaturalTransformation [[ C ]]CF [[ C' ]]CF) {X} 208 | (x : M C (M C X)) -> 209 | Mmap (transform e) X (join x) == join (mapM (Mmap (transform e) X) (Mmap (transform e) (M C X) x)) 210 | mjLaw e (ret x) = refl 211 | mjLaw {C} {C'} e {X} (layer (s , g)) = layer $= ( 212 | (transform e (M C' X) (s , (\ x -> Mmap (transform e) X (join (g x))))) 213 | =[ (\ z -> transform e (M C' X) (s , z)) $= (ext \ x -> mjLaw e (g x)) >= 214 | (transform e (M C' X) (s , (\ x -> join (mapM (Mmap (transform e) X) (Mmap (transform e) (M C X) (g x)))))) 215 | =[ refl >= 216 | (transform e (M C' X) (map z (s , g)) $= [=IN SET ! 218 | mapSyn [[ C ]]CF < Mmap (transform e) (M C X) > -syn- -[ mapSyn [[ C ]]CF (< mapM (Mmap (transform e) X) > -syn- < join >) -syn- < transform e (M C' X) > ]- 219 | =<< reduced (rd , rq (natural e (mapM (Mmap (transform e) X) - join ))) ]]= 220 | mapSyn [[ C ]]CF < Mmap (transform e) (M C X) > -syn- -[ < transform e (M C' (M C X)) > -syn- mapSyn [[ C' ]]CF < mapM (Mmap (transform e) X) - join > ]- 221 | =[[ categories refl >>= 222 | mapSyn [[ C ]]CF < Mmap (transform e) (M C X) > -syn- < transform e (M C' (M C X)) > -syn- mapSyn [[ C' ]]CF < mapM (Mmap (transform e) X) - join > 223 | [[QED]] 224 | =] 225 | >= 226 | map= 228 | (fst (transform e (M C' (M C X)) (s , (g - Mmap (transform e) (M C X))))) 229 | , 230 | (snd (transform e (M C' (M C X)) (s , (g - Mmap (transform e) (M C X)))) -arr- (mapM (Mmap (transform e) X) -arr- join)) 231 | [QED]) where open Category SET 232 | 233 | monadMmap : forall {C C'} -> 234 | NaturalTransformation [[ C ]]CF [[ C' ]]CF -> 235 | MonadMorphism (monadM C) (monadM C') 236 | transform (mMorph (monadMmap e)) = Mmap (transform e) 237 | natural (mMorph (monadMmap e)) f = ext (Mmap-natural e f) 238 | mMorphReturn (monadMmap e) X = refl 239 | mMorphJoin (monadMmap e) X = ext (mjLaw e) 240 | 241 | Mmap-id : forall {C X} (x : M C X) -> 242 | Mmap (\ X -> id) X x == x 243 | Mmap-id (ret x) = refl 244 | Mmap-id (layer (s , g)) = (\ z -> layer (s , z)) $= ext (\ x -> Mmap-id (g x)) 245 | 246 | .Mmap-arr : forall {C C' C''} 247 | {f : NaturalTransformation [[ C ]]CF [[ C' ]]CF} 248 | {g : NaturalTransformation [[ C' ]]CF ([[ C'' ]]CF)} 249 | {X} (x : M C X) -> 250 | Mmap (\ X a -> transform g X (transform f X a)) X x 251 | == Mmap (transform g) X (Mmap (transform f) X x) 252 | Mmap-arr (ret x) = refl 253 | Mmap-arr {C} {C'} {C''} {f} {g} {X} (layer (s , h)) = ((transform g (M C'' X)) - layer) $= ( 254 | transform f (M C'' X) (s , (h - Mmap (\ X -> (transform f X) - transform g X) X)) 255 | =[ (\ z -> transform f (M C'' X) (s , z)) $= ext (\ x -> Mmap-arr {f = f} {g} (h x)) >= 256 | transform f (M C'' X) (s , (h - (Mmap (transform f) X - Mmap (transform g) X))) 257 | =[ refl >= 258 | (map z (s , h)) $= 260 | ([=IN SET ! 261 | mapSyn [[ C ]]CF (< Mmap (transform f) X > -syn- < Mmap (transform g) X >) -syn- < transform f (M C'' X) > 262 | =[[ categories refl >>= 263 | mapSyn [[ C ]]CF < Mmap (transform f) X > -syn- -[ mapSyn [[ C ]]CF < Mmap (transform g) X > -syn- < transform f (M C'' X) > ]- 264 | =<< reduced (rd , rq (natural f (Mmap (transform g) X))) ]]= 265 | mapSyn [[ C ]]CF < Mmap (transform f) X > -syn- -[ < transform f (M C' X) > -syn- mapSyn [[ C' ]]CF < Mmap (transform g) X > ]- 266 | [[QED]] 267 | =])) 268 | >= 269 | map= 271 | fst (transform f (M C' X) (s , (h - Mmap (transform f) X))) , 272 | (snd (transform f (M C' X) (s , (h - Mmap (transform f) X))) - Mmap (transform g) X) 273 | [QED]) 274 | 275 | 276 | FREE : Functor CON MONAD \ { C -> _ , _ , monadM C } 277 | FREE = record { map = monadMmap 278 | ; mapidArr = eqMonadMorph _ _ \ X -> ext Mmap-id 279 | ; map-arr- = \ f g -> eqMonadMorph _ _ \ X -> ext (Mmap-arr {f = f} {g}) 280 | } 281 | 282 | module _ {C : Con}{ObjM' : Set -> Set}{M' : Functor SET SET ObjM'}{monadM' : Monad M'} where 283 | 284 | open Functor 285 | open NaturalTransformation 286 | open MonadMorphism 287 | open Monad 288 | 289 | lift : NaturalTransformation [[ C ]]CF M' -> (X : Set) -> M C X -> ObjM' X 290 | lift e X (ret x) = transform (returnNT monadM') X x 291 | lift e X (layer (s , f)) = transform (joinNT monadM') X (transform e (ObjM' X) (s , \ x -> lift e X (f x))) 292 | 293 | .lift-natural : {X Y : Set} -> 294 | (e : NaturalTransformation [[ C ]]CF M') (f : X -> Y)(x : M C X) -> 295 | map M' f (lift e X x) == lift e Y (mapM f x) 296 | lift-natural e f (ret x) = (\ z -> z x) $= natural (returnNT monadM') f 297 | lift-natural {X} {Y} e f (layer (s , g)) = 298 | _ =[ lemma s g >= (\ z → transform (joinNT monadM') Y (transform e (ObjM' Y) (s , z))) $= ext \ x -> lift-natural e f (g x) 299 | where lemma : {X Y : Set}{f : X -> Y}(s : Con.Sh C)(g : Con.Po C s -> M C X) -> 300 | map M' f (transform (joinNT monadM') X (transform e (ObjM' X) (s , (g - lift e X)))) 301 | == 302 | transform (joinNT monadM') Y (transform e (ObjM' Y) (s , (\ a -> map M' f (lift e X (g a))))) 303 | lemma {X} {Y} {f} s g = (\ z -> z (s , g)) $= 304 | [=IN SET ! 305 | mapSyn [[ C ]]CF < lift e X > -syn- < transform e (ObjM' X) > -syn- -[ < transform (joinNT monadM') X > -syn- mapSyn M' < f > ]- 306 | =[[ reduced (rd , (rd , (rq (natural (joinNT monadM') f)))) >>= 307 | mapSyn [[ C ]]CF < lift e X > -syn- < transform e (ObjM' X) > -syn- -[ mapSyn M' (mapSyn M' < f >) -syn- < transform (joinNT monadM') Y > ]- 308 | =[[ categories refl >>= 309 | mapSyn [[ C ]]CF < lift e X > -syn- -[ < transform e (ObjM' X) > -syn- mapSyn M' (mapSyn M' < f >) ]- -syn- < transform (joinNT monadM') Y > 310 | =[[ reduced (rd , (rq (natural e (map M' f)) , rd)) >>= 311 | mapSyn [[ C ]]CF < lift e X > -syn- -[ mapSyn [[ C ]]CF (mapSyn M' < f >) -syn- < transform e (ObjM' Y) > ]- -syn- < transform (joinNT monadM') Y > 312 | =[[ categories refl >>= 313 | -[ mapSyn [[ C ]]CF < lift e X > -syn- mapSyn [[ C ]]CF (mapSyn M' < f >) ]- -syn- < transform e (ObjM' Y) > -syn- < transform (joinNT monadM') Y > 314 | [[QED]] 315 | =] 316 | 317 | .lift-morphJoin : (e : NaturalTransformation [[ C ]]CF M') {X : Set} 318 | (x : M C (M C X)) -> 319 | lift e X (join x) == 320 | transform (joinNT monadM') X (map M' (lift e X) (lift e (M C X) x)) 321 | lift-morphJoin e {X} (ret x) = (\ z -> z x) $= ([=IN SET ! 322 | < lift e X > -syn- idSyn 323 | =<< reduced (rd , rq (returnJoin monadM' {X})) ]]= 324 | < lift e X > -syn- -[ < transform (returnNT monadM') (ObjM' X) > ]- -syn- < transform (joinNT monadM') X > 325 | =[[ categories refl >>= 326 | -[ < lift e X > -syn- < transform (returnNT monadM') (ObjM' X) > ]- -syn- < transform (joinNT monadM') X > 327 | =<< reduced (rq (natural (returnNT monadM') (lift e X)) , rd) ]]= 328 | -[ < transform (returnNT monadM') (M C X) > -syn- mapSyn M' < lift e X > ]- -syn- < transform (joinNT monadM') X > 329 | [[QED]] 330 | =]) 331 | lift-morphJoin e {X} (layer (s , g)) = 332 | _ =[ (\ z -> transform (joinNT monadM') X (transform e (ObjM' X) (s , z))) $= ext (\ x -> lift-morphJoin e (g x)) >= (\ z -> z (s , g)) $= 333 | ([=IN SET ! 334 | mapSyn [[ C ]]CF (< lift e (M C X) > -syn- mapSyn M' < lift e X > -syn- < transform (joinNT monadM') X >) -syn- < transform e (ObjM' X) > -syn- < transform (joinNT monadM') X > 335 | =[[ categories refl >>= 336 | mapSyn [[ C ]]CF < lift e (M C X) > -syn- mapSyn [[ C ]]CF (mapSyn M' < lift e X > ) -syn- -[ mapSyn [[ C ]]CF (< transform (joinNT monadM') X >) -syn- < transform e (ObjM' X) > ]- -syn- < transform (joinNT monadM') X > 337 | =<< reduced (rd , rd , rq (natural e (transform (joinNT monadM') X)) , rd) ]]= 338 | mapSyn [[ C ]]CF < lift e (M C X) > -syn- mapSyn [[ C ]]CF (mapSyn M' < lift e X >) -syn- -[ < transform e (ObjM' (ObjM' X)) > -syn- mapSyn M' < transform (joinNT monadM') X > ]- -syn- < transform (joinNT monadM') X > 339 | =[[ categories refl >>= 340 | mapSyn [[ C ]]CF < lift e (M C X) > -syn- mapSyn [[ C ]]CF (mapSyn M' < lift e X >) -syn- < transform e (ObjM' (ObjM' X)) > -syn- -[ mapSyn M' < transform (joinNT monadM') X > -syn- < transform (joinNT monadM') X > ]- 341 | =<< reduced (rd , rd , rd , rq (joinJoin monadM')) ]]= 342 | mapSyn [[ C ]]CF < lift e (M C X) > -syn- mapSyn [[ C ]]CF (mapSyn M' < lift e X >) -syn- < transform e (ObjM' (ObjM' X)) > -syn- -[ < transform (joinNT monadM') (ObjM' X) > -syn- < transform (joinNT monadM') X > ]- 343 | =[[ categories refl >>= 344 | mapSyn [[ C ]]CF < lift e (M C X) > -syn- -[ mapSyn [[ C ]]CF (mapSyn M' < lift e X >) -syn- < transform e (ObjM' (ObjM' X)) > ]- -syn- < transform (joinNT monadM') (ObjM' X) > -syn- < transform (joinNT monadM') X > 345 | =<< reduced (rd , rq (natural e (map M' (lift e X))) , rd , rd) ]]= 346 | mapSyn [[ C ]]CF < lift e (M C X) > -syn- -[ < transform e (ObjM' (M C X)) > -syn- mapSyn M' (mapSyn M' < lift e X >) ]- -syn- < transform (joinNT monadM') (ObjM' X) > -syn- < transform (joinNT monadM') X > 347 | =[[ categories refl >>= 348 | mapSyn [[ C ]]CF < lift e (M C X) > -syn- < transform e (ObjM' (M C X)) > -syn- -[ mapSyn M' (mapSyn M' < lift e X >) -syn- < transform (joinNT monadM') (ObjM' X) > ]- -syn- < transform (joinNT monadM') X > 349 | =<< reduced (rd , rd , (rq (natural (joinNT monadM') (lift e X))) , rd) ]]= 350 | mapSyn [[ C ]]CF < lift e (M C X) > -syn- < transform e (ObjM' (M C X)) > -syn- -[ < transform (joinNT monadM') (M C X) > 351 | -syn- mapSyn M' < lift e X > ]- -syn- < transform (joinNT monadM') X > 352 | [[QED]] 353 | =]) 354 | 355 | liftMor : NaturalTransformation [[ C ]]CF M' -> MonadMorphism (monadM C) monadM' 356 | transform (mMorph (liftMor e)) = lift e 357 | natural (mMorph (liftMor e)) f = ext (lift-natural e f) 358 | mMorphReturn (liftMor e) X = refl 359 | mMorphJoin (liftMor e) X = ext (lift-morphJoin e) 360 | 361 | dropMor : MonadMorphism (monadM C) monadM' -> NaturalTransformation [[ C ]]CF M' 362 | transform (dropMor e) X y = transform (mMorph e) X (layer (map Y} (x : [[ C ]]C X) -> 365 | map M' f (transform (mMorph e) X (layer (fst x , (\ a -> ret (snd x a))))) 366 | == transform (mMorph e) Y (layer (fst x , (\ a -> ret (f (snd x a))))) 367 | lemma {X = X} {Y} {f} (s , g) = (\ z -> (z (s , g))) $= ( 368 | [=IN SET ! 369 | mapSyn [[ C ]]CF < ret > -syn- < layer > -syn- -[ < transform (mMorph e) X > -syn- mapSyn M' < f > ]- 370 | =[[ reduced (rd , (rd , (rq (natural (mMorph e) f)))) >>= 371 | mapSyn [[ C ]]CF < ret > -syn- < layer > -syn- -[ mapSyn (funM C) < f > -syn- < transform (mMorph e) Y > ]- 372 | =[[ categories refl >>= 373 | -[ mapSyn [[ C ]]CF < ret > -syn- < layer > -syn- mapSyn (funM C) < f > ]- -syn- < transform (mMorph e) Y > 374 | =[[ reduced (rq refl , rd) >>= 375 | -[ mapSyn [[ C ]]CF (< f > -syn- < ret >) -syn- < layer > ]- -syn- < transform (mMorph e) Y > 376 | =[[ categories refl >>= 377 | mapSyn [[ C ]]CF (< f > -syn- < ret >) -syn- < layer > -syn- < transform (mMorph e) Y > 378 | [[QED]] 379 | =]) 380 | 381 | 382 | 383 | .roundtrip1 : (e : MonadMorphism (monadM C) monadM') -> 384 | liftMor (dropMor e) == e 385 | roundtrip1 e = eqMonadMorph _ _ \ X -> ext (lemma X) 386 | where lemma : forall X -> (x : M C X) -> 387 | lift (dropMor e) X x == transform (mMorph e) X x 388 | lemma X (ret x) = sym ((\ z -> z x) $= mMorphReturn e X) 389 | lemma X (layer (s , g)) = let join' = transform (joinNT monadM') 390 | return' = transform (returnNT monadM') 391 | eta = transform (mMorph e) in 392 | join' X (eta (ObjM' X) (layer (map join' X (eta (ObjM' X) (layer (s , z)))) 394 | $= ext (\ x -> ret $= lemma X (g x)) >= 395 | join' X (eta (ObjM' X) (layer (map join' X (z (s , g))) $= sym (natural (dropMor e) (eta X)) >= 397 | join' X (map M' (eta X) (eta (M C X) (layer (map z (layer (map eta X (layer (s , z))) $= ext (\ x -> joinLaw2 (g x)) ]= 401 | eta X (join (mapM ret (layer (s , g)))) 402 | =[ (eta X) $= joinLaw2 (layer (s , g)) >= 403 | eta X (layer (s , g)) 404 | [QED] 405 | 406 | .roundtrip2 : (e : NaturalTransformation [[ C ]]CF M') -> 407 | dropMor (liftMor e) == e 408 | roundtrip2 e = eqNatTrans _ _ \ X -> ext (lemma X) 409 | where lemma : forall X y -> 410 | transform (joinNT monadM') X 411 | (transform e (ObjM' X) 412 | (map join' X (z y)) $= natural e (return' X) ]= 419 | join' X (map M' (return' X) (eta X y)) 420 | =[ (\ z -> z (eta X y)) $= (mapReturnJoin monadM') >= 421 | eta X y 422 | [QED] 423 | 424 | 425 | 426 | 427 | 428 | 429 | 430 | -- M C as a container itself: 431 | 432 | data MSh (C : Con) : Set where 433 | retS : MSh C 434 | wrapS : (s : Con.Sh C) -> (Con.Po C s -> MSh C) -> MSh C 435 | 436 | MPo : (C : Con) -> MSh C -> Set 437 | MPo C retS = One 438 | MPo C (wrapS s f) = Sg (Con.Po C s) \ p -> MPo C (f p) 439 | 440 | MCon : (C : Con) -> Set -> Set 441 | MCon C = [[ MSh C X -> MCon C X 444 | ret' x = retS , \ tt -> x 445 | 446 | layer' : {C : Con}{X : Set} -> [[ C ]]C (MCon C X) -> MCon C X 447 | layer' (s , f) = wrapS s (f - fst) , \ { (p , x) -> snd (f p) x } 448 | 449 | oneWay : {C : Con}{X : Set} -> M C X -> MCon C X 450 | oneWay (ret x) = ret' x 451 | oneWay (layer (s , g)) = layer' (s , \ x -> oneWay (g x)) 452 | 453 | otherWay : {C : Con}{X : Set} -> MCon C X -> M C X 454 | otherWay (s , f) = otherWay' s f 455 | -- making the termination checker happy by avoiding Sigma types 456 | where otherWay' : {C : Con}{X : Set} -> (s : MSh C) -> (MPo C s -> X) -> M C X 457 | otherWay' retS f = ret (f _) 458 | otherWay' (wrapS s g) f = layer (s , \ p -> otherWay' (g p) (\ z -> f (p , z))) 459 | 460 | 461 | 462 | MonadCONT : Category {Sg Con \ C -> Monad [[ C ]]CF} 463 | \ { (C , monadC) (C' , monadC') -> MonadMorphism monadC monadC' } 464 | Category.idArr MonadCONT = Category.idArr MONAD 465 | Category._-arr-_ MonadCONT = Category._-arr-_ MONAD 466 | Category.idArr-arr- MonadCONT = Category.idArr-arr- MONAD 467 | Category._-arr-idArr MonadCONT = Category._-arr-idArr MONAD 468 | Category.assoc-arr- MonadCONT = Category.assoc-arr- MONAD 469 | 470 | forgetMonad : Functor MonadCONT CON \ { (C , M) -> C } 471 | forgetMonad = record { map = MonadMorphism.mMorph 472 | ; mapidArr = refl 473 | ; map-arr- = \ f g -> refl 474 | } 475 | -------------------------------------------------------------------------------- /Lecture/Six.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type --no-unicode #-} 2 | --{-# OPTIONS --irrelevant-projections #-} 3 | module Lecture.Six where 4 | 5 | open import Lib.Basics 6 | open import Lib.Cat.Category 7 | open import Lib.Cat.Functor 8 | open import Lib.Cat.NatTrans 9 | open import Lib.Cat.Adjunction 10 | open import Lib.Cat.Monad 11 | open import Lib.Cat.Solver 12 | 13 | {- 14 | 15 | -- Given a functor F : SET --> SET, what is the least imposing way of 16 | -- turning it into a monad? 17 | 18 | -- As we have seen before, this means finding a left adjoint to the 19 | -- functor MONAD SET -> FUNCTOR SET SET which forgets the monad 20 | -- structure. 21 | 22 | -- In turn, having such an adjunction means the following bijective 23 | -- correspondence for every monad M': 24 | -- 25 | -- F ------ nat trans -------> forget M' 26 | -- ======================================== 27 | -- M F -- monad morphism ------> M' 28 | -- 29 | 30 | -- We first tried to do this for an arbitrary functor F: 31 | 32 | module _ {ObjF : Set -> Set}(F : Functor SET SET ObjF) where 33 | 34 | open NaturalTransformation 35 | open MonadMorphism 36 | open Functor 37 | open Monad 38 | 39 | data M (X : Set) : Set where 40 | ret : X -> M X 41 | layer : ObjF (M X) -> M X -- Agda does not allow this 42 | 43 | -- ObjF X = X -> X would make Agda allow programs that loop 44 | 45 | -- ObjF X = (X -> Two) -> Two is a functor, but allowing this makes 46 | -- the logic inconsistent with classical logic: it claims Pow (PowX) = X 47 | 48 | funM : Functor SET SET M 49 | map funM h (ret x) = ret (h x) 50 | map funM h (layer fx) = layer {!!} 51 | mapidArr funM = {!!} 52 | map-arr- funM = {!!} 53 | 54 | retM : NaturalTransformation (ID SET) funM 55 | transform retM X = ret 56 | natural retM = {!!} 57 | 58 | joinM : NaturalTransformation (funM -Func- funM) funM 59 | transform joinM X (ret mx) = mx 60 | transform joinM X (layer fx) = layer {!!} 61 | natural joinM = {!!} 62 | 63 | MonadM : Monad funM 64 | returnNT MonadM = retM 65 | joinNT MonadM = joinM 66 | returnJoin MonadM = {!!} 67 | mapReturnJoin MonadM = {!!} 68 | joinJoin MonadM = {!!} 69 | 70 | morph : {ObjN : Set -> Set}{N : Functor SET SET ObjN}(MonadN : Monad N) 71 | (f : NaturalTransformation F N) -> 72 | MonadMorphism MonadM MonadN 73 | transform (mMorph (morph MonadN f)) X (ret x) = transform (returnNT MonadN) X x 74 | transform (mMorph (morph MonadN f)) X (layer fx) = {!!} 75 | natural (mMorph (morph MonadN f)) k = {!!} 76 | mMorphReturn (morph MonadN f) X = refl 77 | mMorphJoin (morph MonadN f) = {!!} 78 | -} 79 | 80 | -- We have to restrict to a well-behaved class of functors that are 81 | -- strictly positive: 82 | 83 | record Con{-tainer-} : Set where 84 | constructor _ Set 88 | 89 | [[_]]C : Con -> Set -> Set 90 | [[ Sh Po s -> X 91 | 92 | map {X Y : Set} -> (X -> Y) -> [[ C ]]C X -> [[ C ]]C Y 93 | map Functor SET SET [[ C ]]C 96 | Functor.map [[ C ]]CF = map NaturalTransformation ([[ C ]]CF) ([[ C' ]]CF) 103 | Category.idArr CON = idNT 104 | Category._-arr-_ CON = _-NT-_ 105 | Category.idArr-arr- CON f = refl 106 | Category._-arr-idArr CON f = refl 107 | Category.assoc-arr- CON f g h = refl 108 | 109 | -- Now we can define how to extend [[ C ]]CF to be a monad: 110 | 111 | data M (C : Con)(X : Set) : Set where 112 | ret : X -> M C X 113 | layer : [[ C ]]C (M C X) -> M C X 114 | 115 | -- We now show that M C is a monad. It has return, and also join: 116 | 117 | join : {C : Con}{X : Set} -> M C (M C X) -> M C X 118 | join (ret mx) = mx 119 | join (layer (s , f)) = layer (s , (\ p -> join (f p))) 120 | 121 | 122 | 123 | -- But we are getting ahead of ourselves. First we need M C to be a functor 124 | 125 | module _ {C : Con} where 126 | 127 | MC : Set -> Set 128 | MC = M C 129 | 130 | mapM : {X Y : Set} -> (X -> Y) -> MC X -> MC Y 131 | mapM f (ret x) = ret (f x) 132 | mapM f (layer (s , g)) = layer (s , \ p -> mapM f (g p)) 133 | 134 | mapMid : {X : Set} -> (x : MC X) -> mapM id x == x 135 | mapMid (ret x) = refl 136 | mapMid (layer (s , g)) = (\ z -> layer (s , z)) $= ext \ p -> mapMid (g p) 137 | 138 | 139 | 140 | mapM-arr- : {X Y Z : Set}{f : X -> Y}{g : Y -> Z} -> 141 | (x : MC X) -> mapM (f - g) x == (mapM f - mapM g) x 142 | mapM-arr- (ret x) = refl 143 | mapM-arr- (layer (s , h)) = (\ z → layer (s , z)) 144 | $= ext (\ x -> mapM-arr- (h x)) 145 | 146 | 147 | 148 | funM : (C : Con) -> Functor SET SET (M C) 149 | Functor.map (funM C) = mapM 150 | Functor.mapidArr (funM C) = ext mapMid 151 | Functor.map-arr- (funM C) f g = ext mapM-arr- 152 | 153 | 154 | 155 | 156 | -- Now we can show that join and ret satisfy the monad laws 157 | 158 | module _ {C : Con} where 159 | 160 | open Monad 161 | 162 | joinNatural : {X Y : Set}(f : X -> Y) -> (x : M C (M C X)) -> 163 | mapM f (join x) == (join (mapM (mapM f) x)) 164 | joinNatural f (ret x) = refl 165 | joinNatural f (layer (s , g)) = (\ z → layer (s , z)) 166 | $= ext (\ x -> joinNatural f (g x)) 167 | 168 | joinLaw2 : {X : Set}(x : M C X) -> join (mapM ret x) == x 169 | joinLaw2 (ret x) = refl 170 | joinLaw2 (layer (s , g)) = (\ z → layer (s , z)) 171 | $= ext (\ x -> joinLaw2 (g x)) 172 | 173 | joinLaw3 : {X : Set}(x : M C (M C (M C X))) -> 174 | join (join x) == join (mapM join x) 175 | joinLaw3 (ret x) = refl 176 | joinLaw3 (layer (s , g)) = (\ z → layer (s , z)) 177 | $= ext (\ x -> joinLaw3 (g x)) 178 | 179 | 180 | 181 | -- Putting it all together, we get that M C is always a monad 182 | 183 | module _ (C : Con) where 184 | 185 | open Functor 186 | open Monad 187 | open NaturalTransformation 188 | 189 | monadM : Monad (funM C) 190 | transform (returnNT monadM) X = ret 191 | natural (returnNT monadM) f = refl 192 | transform (joinNT monadM) X = join 193 | natural (joinNT monadM) f = ext (joinNatural f) 194 | returnJoin monadM = refl 195 | mapReturnJoin monadM = ext joinLaw2 196 | joinJoin monadM = ext joinLaw3 197 | 198 | -- We want a functor FUNCTOR SET SET --> MONAD SET. 199 | -- This means that if we have an arrow C --> C', there should be 200 | -- an arrow M C --> M C' 201 | 202 | module _ where 203 | 204 | open Functor 205 | open NaturalTransformation 206 | open MonadMorphism 207 | 208 | 209 | Mmap : forall {C C'} -> 210 | ((X : Set) -> [[ C ]]C X -> [[ C' ]]C X) -> 211 | (X : Set) -> M C X -> M C' X 212 | Mmap e X (ret x) = ret x 213 | Mmap e X (layer (s , g)) = layer (e _ (s , \ p -> Mmap e X (g p))) -- layer (map 218 | (e : NaturalTransformation [[ C ]]CF [[ C' ]]CF) -> 219 | {X Y : Set} (f : X -> Y) -> (x : M C X) -> 220 | mapM f (Mmap (transform e) X x) == Mmap (transform e) Y (mapM f x) 221 | Mmap-natural e f (ret x) = refl 222 | Mmap-natural {C} {C'} e {X} {Y} f (layer (s , g)) = layer $= ( 223 | (fst 224 | (transform e (M C' X) (s , (\ x -> Mmap (transform e) X (g x)))) 225 | , 226 | (snd (transform e (M C' X) 227 | (s , (\ x -> Mmap (transform e) X (g x)))) - (mapM f))) 228 | =[ refl >= 229 | (map z (s , g)) $= 231 | ([=IN SET ! 232 | mapSyn [[ C ]]CF < Mmap (transform e) X > -syn- 233 | -[ < transform e (M C' X) > -syn- 234 | mapSyn [[ C' ]]CF < mapM f > ]- 235 | =[[ reduced (rd , rq (natural e (mapM f))) >>= 236 | mapSyn [[ C ]]CF < Mmap (transform e) X > -syn- 237 | -[ mapSyn [[ C ]]CF < mapM f > -syn- 238 | < transform e (M C' Y) > ]- 239 | =[[ categories refl >>= 240 | mapSyn [[ C ]]CF (< Mmap (transform e) X > -syn- 241 | < mapM f >) -syn- < transform e (M C' Y) > [[QED]] =]) 242 | >= 243 | (map Mmap-natural e f (g x)) >= 245 | transform e (M C' Y) (s , (\ x -> Mmap (transform e) Y (mapM f (g x)))) 246 | [QED]) 247 | 248 | -- and it preserves join (and return, by definition) 249 | 250 | .mjLaw : forall {C C'} 251 | (e : NaturalTransformation [[ C ]]CF [[ C' ]]CF) {X} 252 | (x : M C (M C X)) -> 253 | Mmap (transform e) X (join x) == join (mapM (Mmap (transform e) X) (Mmap (transform e) (M C X) x)) 254 | mjLaw e (ret x) = refl 255 | mjLaw {C} {C'} e {X} (layer (s , g)) = layer $= ( 256 | (transform e (M C' X) (s , (\ x -> Mmap (transform e) X (join (g x))))) 257 | =[ (\ z -> transform e (M C' X) (s , z)) $= (ext \ x -> mjLaw e (g x)) >= 258 | (transform e (M C' X) (s , (\ x -> join (mapM (Mmap (transform e) X) (Mmap (transform e) (M C X) (g x)))))) 259 | =[ refl >= 260 | (transform e (M C' X) (map z (s , g)) $= [=IN SET ! 262 | mapSyn [[ C ]]CF < Mmap (transform e) (M C X) > -syn- -[ mapSyn [[ C ]]CF (< mapM (Mmap (transform e) X) > -syn- < join >) -syn- < transform e (M C' X) > ]- 263 | =<< reduced (rd , rq (natural e (mapM (Mmap (transform e) X) - join ))) ]]= 264 | mapSyn [[ C ]]CF < Mmap (transform e) (M C X) > -syn- -[ < transform e (M C' (M C X)) > -syn- mapSyn [[ C' ]]CF < mapM (Mmap (transform e) X) - join > ]- 265 | =[[ categories refl >>= 266 | mapSyn [[ C ]]CF < Mmap (transform e) (M C X) > -syn- < transform e (M C' (M C X)) > -syn- mapSyn [[ C' ]]CF < mapM (Mmap (transform e) X) - join > 267 | [[QED]] 268 | =] 269 | >= 270 | map= 272 | (fst (transform e (M C' (M C X)) (s , (g - Mmap (transform e) (M C X))))) 273 | , 274 | (snd (transform e (M C' (M C X)) (s , (g - Mmap (transform e) (M C X)))) -arr- (mapM (Mmap (transform e) X) -arr- join)) 275 | [QED]) where open Category SET 276 | 277 | 278 | monadMmap : forall {C C'} -> 279 | NaturalTransformation [[ C ]]CF [[ C' ]]CF -> 280 | MonadMorphism (monadM C) (monadM C') 281 | transform (mMorph (monadMmap e)) = Mmap (transform e) 282 | natural (mMorph (monadMmap e)) f = ext (Mmap-natural e f) 283 | mMorphReturn (monadMmap e) X = refl 284 | mMorphJoin (monadMmap e) X = ext (mjLaw e) 285 | 286 | -- furthermore, MMap preserves identity NTs and composition of NTs 287 | 288 | Mmap-id : forall {C X} (x : M C X) -> 289 | Mmap (\ X -> id) X x == x 290 | Mmap-id (ret x) = refl 291 | Mmap-id (layer (s , g)) = (\ z -> layer (s , z)) $= ext (\ x -> Mmap-id (g x)) 292 | 293 | .Mmap-arr : forall {C C' C''} 294 | {f : NaturalTransformation [[ C ]]CF [[ C' ]]CF} 295 | {g : NaturalTransformation [[ C' ]]CF ([[ C'' ]]CF)} 296 | {X} (x : M C X) -> 297 | Mmap (\ X a -> transform g X (transform f X a)) X x 298 | == Mmap (transform g) X (Mmap (transform f) X x) 299 | Mmap-arr (ret x) = refl 300 | Mmap-arr {C} {C'} {C''} {f} {g} {X} (layer (s , h)) = ((transform g (M C'' X)) - layer) $= ( 301 | transform f (M C'' X) (s , (h - Mmap (\ X -> (transform f X) - transform g X) X)) 302 | =[ (\ z -> transform f (M C'' X) (s , z)) $= ext (\ x -> Mmap-arr {f = f} {g} (h x)) >= 303 | transform f (M C'' X) (s , (h - (Mmap (transform f) X - Mmap (transform g) X))) 304 | =[ refl >= 305 | (map z (s , h)) $= 307 | ([=IN SET ! 308 | mapSyn [[ C ]]CF (< Mmap (transform f) X > -syn- < Mmap (transform g) X >) -syn- < transform f (M C'' X) > 309 | =[[ categories refl >>= 310 | mapSyn [[ C ]]CF < Mmap (transform f) X > -syn- -[ mapSyn [[ C ]]CF < Mmap (transform g) X > -syn- < transform f (M C'' X) > ]- 311 | =<< reduced (rd , rq (natural f (Mmap (transform g) X))) ]]= 312 | mapSyn [[ C ]]CF < Mmap (transform f) X > -syn- -[ < transform f (M C' X) > -syn- mapSyn [[ C' ]]CF < Mmap (transform g) X > ]- 313 | [[QED]] 314 | =])) 315 | >= 316 | map= 318 | fst (transform f (M C' X) (s , (h - Mmap (transform f) X))) , 319 | (snd (transform f (M C' X) (s , (h - Mmap (transform f) X))) - Mmap (transform g) X) 320 | [QED]) 321 | 322 | -- So we get a functor! This gives the so-called free monad for any container C 323 | 324 | FREE : Functor CON MONAD \ { C -> _ , _ , monadM C } 325 | map FREE = monadMmap 326 | mapidArr FREE = eqMonadMorph _ _ \ X -> ext Mmap-id 327 | map-arr- FREE f g = eqMonadMorph _ _ \ X -> ext (Mmap-arr {f = f} {g}) 328 | 329 | -- Now, the adjunction property. 330 | 331 | -- Given another monad M', 332 | -- and a NT [[ C ]]CF --> M' (forgetting that M' is a monad), 333 | -- we can lift this to a monad morphism M C --> M' 334 | 335 | module _ {C : Con}{ObjM' : Set -> Set}{M' : Functor SET SET ObjM'}{monadM' : Monad M'} where 336 | 337 | open Functor 338 | open NaturalTransformation 339 | open MonadMorphism 340 | open Monad 341 | 342 | lift : NaturalTransformation [[ C ]]CF M' -> (X : Set) -> M C X -> ObjM' X 343 | lift e X (ret x) = transform (returnNT monadM') X x 344 | lift e X (layer (s , g)) = transform (joinNT monadM') X (transform e _ (s , \ p -> lift e X (g p))) 345 | 346 | 347 | -- This really is a natural transformation 348 | 349 | .lift-natural : {X Y : Set} -> 350 | (e : NaturalTransformation [[ C ]]CF M') (f : X -> Y)(x : M C X) -> 351 | map M' f (lift e X x) == lift e Y (mapM f x) 352 | lift-natural e f (ret x) = (\ z -> z x) $= natural (returnNT monadM') f 353 | lift-natural {X} {Y} e f (layer (s , g)) = 354 | _ =[ lemma s g >= (\ z → transform (joinNT monadM') Y (transform e (ObjM' Y) (s , z))) $= ext \ x -> lift-natural e f (g x) 355 | where lemma : {X Y : Set}{f : X -> Y}(s : Con.Sh C)(g : Con.Po C s -> M C X) -> 356 | map M' f (transform (joinNT monadM') X (transform e (ObjM' X) (s , (g - lift e X)))) 357 | == 358 | transform (joinNT monadM') Y (transform e (ObjM' Y) (s , (\ a -> map M' f (lift e X (g a))))) 359 | lemma {X} {Y} {f} s g = (\ z -> z (s , g)) $= 360 | [=IN SET ! 361 | mapSyn [[ C ]]CF < lift e X > -syn- < transform e (ObjM' X) > -syn- -[ < transform (joinNT monadM') X > -syn- mapSyn M' < f > ]- 362 | =[[ reduced (rd , (rd , (rq (natural (joinNT monadM') f)))) >>= 363 | mapSyn [[ C ]]CF < lift e X > -syn- < transform e (ObjM' X) > -syn- -[ mapSyn M' (mapSyn M' < f >) -syn- < transform (joinNT monadM') Y > ]- 364 | =[[ categories refl >>= 365 | mapSyn [[ C ]]CF < lift e X > -syn- -[ < transform e (ObjM' X) > -syn- mapSyn M' (mapSyn M' < f >) ]- -syn- < transform (joinNT monadM') Y > 366 | =[[ reduced (rd , (rq (natural e (map M' f)) , rd)) >>= 367 | mapSyn [[ C ]]CF < lift e X > -syn- -[ mapSyn [[ C ]]CF (mapSyn M' < f >) -syn- < transform e (ObjM' Y) > ]- -syn- < transform (joinNT monadM') Y > 368 | =[[ categories refl >>= 369 | -[ mapSyn [[ C ]]CF < lift e X > -syn- mapSyn [[ C ]]CF (mapSyn M' < f >) ]- -syn- < transform e (ObjM' Y) > -syn- < transform (joinNT monadM') Y > 370 | [[QED]] 371 | =] 372 | 373 | -- And it really is a monad morphism 374 | 375 | .lift-morphJoin : (e : NaturalTransformation [[ C ]]CF M') {X : Set} 376 | (x : M C (M C X)) -> 377 | lift e X (join x) == 378 | transform (joinNT monadM') X (map M' (lift e X) (lift e (M C X) x)) 379 | lift-morphJoin e {X} (ret x) = (\ z -> z x) $= ([=IN SET ! 380 | < lift e X > -syn- idSyn 381 | =<< reduced (rd , rq (returnJoin monadM' {X})) ]]= 382 | < lift e X > -syn- -[ < transform (returnNT monadM') (ObjM' X) > ]- -syn- < transform (joinNT monadM') X > 383 | =[[ categories refl >>= 384 | -[ < lift e X > -syn- < transform (returnNT monadM') (ObjM' X) > ]- -syn- < transform (joinNT monadM') X > 385 | =<< reduced (rq (natural (returnNT monadM') (lift e X)) , rd) ]]= 386 | -[ < transform (returnNT monadM') (M C X) > -syn- mapSyn M' < lift e X > ]- -syn- < transform (joinNT monadM') X > 387 | [[QED]] 388 | =]) 389 | lift-morphJoin e {X} (layer (s , g)) = 390 | _ =[ (\ z -> transform (joinNT monadM') X (transform e (ObjM' X) (s , z))) $= ext (\ x -> lift-morphJoin e (g x)) >= (\ z -> z (s , g)) $= 391 | ([=IN SET ! 392 | mapSyn [[ C ]]CF (< lift e (M C X) > -syn- mapSyn M' < lift e X > -syn- < transform (joinNT monadM') X >) -syn- < transform e (ObjM' X) > -syn- < transform (joinNT monadM') X > 393 | =[[ categories refl >>= 394 | mapSyn [[ C ]]CF < lift e (M C X) > -syn- mapSyn [[ C ]]CF (mapSyn M' < lift e X > ) -syn- -[ mapSyn [[ C ]]CF (< transform (joinNT monadM') X >) -syn- < transform e (ObjM' X) > ]- -syn- < transform (joinNT monadM') X > 395 | =<< reduced (rd , rd , rq (natural e (transform (joinNT monadM') X)) , rd) ]]= 396 | mapSyn [[ C ]]CF < lift e (M C X) > -syn- mapSyn [[ C ]]CF (mapSyn M' < lift e X >) -syn- -[ < transform e (ObjM' (ObjM' X)) > -syn- mapSyn M' < transform (joinNT monadM') X > ]- -syn- < transform (joinNT monadM') X > 397 | =[[ categories refl >>= 398 | mapSyn [[ C ]]CF < lift e (M C X) > -syn- mapSyn [[ C ]]CF (mapSyn M' < lift e X >) -syn- < transform e (ObjM' (ObjM' X)) > -syn- -[ mapSyn M' < transform (joinNT monadM') X > -syn- < transform (joinNT monadM') X > ]- 399 | =<< reduced (rd , rd , rd , rq (joinJoin monadM')) ]]= 400 | mapSyn [[ C ]]CF < lift e (M C X) > -syn- mapSyn [[ C ]]CF (mapSyn M' < lift e X >) -syn- < transform e (ObjM' (ObjM' X)) > -syn- -[ < transform (joinNT monadM') (ObjM' X) > -syn- < transform (joinNT monadM') X > ]- 401 | =[[ categories refl >>= 402 | mapSyn [[ C ]]CF < lift e (M C X) > -syn- -[ mapSyn [[ C ]]CF (mapSyn M' < lift e X >) -syn- < transform e (ObjM' (ObjM' X)) > ]- -syn- < transform (joinNT monadM') (ObjM' X) > -syn- < transform (joinNT monadM') X > 403 | =<< reduced (rd , rq (natural e (map M' (lift e X))) , rd , rd) ]]= 404 | mapSyn [[ C ]]CF < lift e (M C X) > -syn- -[ < transform e (ObjM' (M C X)) > -syn- mapSyn M' (mapSyn M' < lift e X >) ]- -syn- < transform (joinNT monadM') (ObjM' X) > -syn- < transform (joinNT monadM') X > 405 | =[[ categories refl >>= 406 | mapSyn [[ C ]]CF < lift e (M C X) > -syn- < transform e (ObjM' (M C X)) > -syn- -[ mapSyn M' (mapSyn M' < lift e X >) -syn- < transform (joinNT monadM') (ObjM' X) > ]- -syn- < transform (joinNT monadM') X > 407 | =<< reduced (rd , rd , (rq (natural (joinNT monadM') (lift e X))) , rd) ]]= 408 | mapSyn [[ C ]]CF < lift e (M C X) > -syn- < transform e (ObjM' (M C X)) > -syn- -[ < transform (joinNT monadM') (M C X) > 409 | -syn- mapSyn M' < lift e X > ]- -syn- < transform (joinNT monadM') X > 410 | [[QED]] 411 | =]) 412 | 413 | 414 | liftMor : NaturalTransformation [[ C ]]CF M' -> MonadMorphism (monadM C) monadM' 415 | transform (mMorph (liftMor e)) = lift e 416 | natural (mMorph (liftMor e)) f = ext (lift-natural e f) 417 | mMorphReturn (liftMor e) X = refl 418 | mMorphJoin (liftMor e) X = ext (lift-morphJoin e) 419 | 420 | -- We can also go the other way: every monad morphism can be dropped down 421 | -- to just a natural transformation from the original container functor 422 | 423 | dropMor : MonadMorphism (monadM C) monadM' -> NaturalTransformation [[ C ]]CF M' 424 | transform (dropMor e) X (s , g) = transform (mMorph e) X (layer (s , \ p -> ret (g p))) 425 | natural (dropMor e) f = ext lemma 426 | where lemma : {X Y : Set} {f : X -> Y} (x : [[ C ]]C X) -> 427 | map M' f (transform (mMorph e) X (layer (fst x , (\ a -> ret (snd x a))))) 428 | == transform (mMorph e) Y (layer (fst x , (\ a -> ret (f (snd x a))))) 429 | lemma {X = X} {Y} {f} (s , g) = (\ z -> (z (s , g))) $= ( 430 | [=IN SET ! 431 | mapSyn [[ C ]]CF < ret > -syn- < layer > -syn- -[ < transform (mMorph e) X > -syn- mapSyn M' < f > ]- 432 | =[[ reduced (rd , (rd , (rq (natural (mMorph e) f)))) >>= 433 | mapSyn [[ C ]]CF < ret > -syn- < layer > -syn- -[ mapSyn (funM C) < f > -syn- < transform (mMorph e) Y > ]- 434 | =[[ categories refl >>= 435 | -[ mapSyn [[ C ]]CF < ret > -syn- < layer > -syn- mapSyn (funM C) < f > ]- -syn- < transform (mMorph e) Y > 436 | =[[ reduced (rq refl , rd) >>= 437 | -[ mapSyn [[ C ]]CF (< f > -syn- < ret >) -syn- < layer > ]- -syn- < transform (mMorph e) Y > 438 | =[[ categories refl >>= 439 | mapSyn [[ C ]]CF (< f > -syn- < ret >) -syn- < layer > -syn- < transform (mMorph e) Y > 440 | [[QED]] 441 | =]) 442 | 443 | -- And these are the *only* ways to construct monad morphisms from M C 444 | 445 | .roundtrip1 : (e : MonadMorphism (monadM C) monadM') -> 446 | liftMor (dropMor e) == e 447 | roundtrip1 e = eqMonadMorph _ _ \ X -> ext (lemma X) 448 | where lemma : forall X -> (x : M C X) -> 449 | lift (dropMor e) X x == transform (mMorph e) X x 450 | lemma X (ret x) = sym ((\ z -> z x) $= mMorphReturn e X) 451 | lemma X (layer (s , g)) = let join' = transform (joinNT monadM') 452 | return' = transform (returnNT monadM') 453 | eta = transform (mMorph e) in 454 | join' X (eta (ObjM' X) (layer (map join' X (eta (ObjM' X) (layer (s , z)))) 456 | $= ext (\ x -> ret $= lemma X (g x)) >= 457 | join' X (eta (ObjM' X) (layer (map join' X (z (s , g))) $= sym (natural (dropMor e) (eta X)) >= 459 | join' X (map M' (eta X) (eta (M C X) (layer (map z (layer (map eta X (layer (s , z))) $= ext (\ x -> joinLaw2 (g x)) ]= 463 | eta X (join (mapM ret (layer (s , g)))) 464 | =[ (eta X) $= joinLaw2 (layer (s , g)) >= 465 | eta X (layer (s , g)) 466 | [QED] 467 | 468 | .roundtrip2 : (e : NaturalTransformation [[ C ]]CF M') -> 469 | dropMor (liftMor e) == e 470 | roundtrip2 e = eqNatTrans _ _ \ X -> ext (lemma X) 471 | where lemma : forall X y -> 472 | transform (joinNT monadM') X 473 | (transform e (ObjM' X) 474 | (map join' X (z y)) $= natural e (return' X) ]= 481 | join' X (map M' (return' X) (eta X y)) 482 | =[ (\ z -> z (eta X y)) $= (mapReturnJoin monadM') >= 483 | eta X y 484 | [QED] 485 | 486 | 487 | 488 | 489 | {- 490 | -- NEXT: Container morphisms 491 | 492 | record ConMor (C C' : Con) : Set where 493 | constructor _ Sh C' 497 | po : {s : Sh C} -> Po C' (sh s) -> Po C s 498 | 499 | module _ {C C' : Con} where 500 | 501 | open NaturalTransformation 502 | open ConMor 503 | 504 | [[_]]NT : ConMor C C' -> NaturalTransformation [[ C ]]CF [[ C' ]]CF 505 | [[ f 508 | Sg (ConMor C C') (\ m -> [[ m ]]NT == nt) 509 | complete nt = {!!} 510 | 511 | -} 512 | 513 | -------------------------------------------------------------------------------- /Lecture/Four.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type --no-unicode #-} 2 | {- OPTIONS --irrelevant-projections -} 3 | module Lecture.Four where 4 | 5 | open import Lib.Basics 6 | open import Lib.Nat 7 | open import Lib.Vec 8 | open import Lib.Cat.Category 9 | open import Lib.Cat.Functor 10 | open import Lib.Cat.NatTrans 11 | open import Lib.Cat.ProductCat 12 | open import Lib.Cat.Solver 13 | open import Lib.Cat.Monad 14 | 15 | 16 | -- recap (NaturalTransformation, singletonNT) -- C 17 | -- what has changed? (making equations irrelevant, ID C) -- C 18 | -- what next? 19 | -- Functor composition -- F 20 | -- Category of Categories -- F 21 | -- Definition of Monad -- C 22 | -- what is join for LIST? -- F 23 | -- concat as a natural transformation -- F 24 | -- define concat; it needs append -- F 25 | -- naturality of concat needs naturality of append -- F 26 | -- how can we state the naturality of append? 27 | -- need to work with pairs of things 28 | -- *Cat and *Fun -- C 29 | -- Delta and SETPair -- C 30 | -- construct append as a natural transformation -- F 31 | -- complete concat as a natural transformation -- F 32 | -- see what we have to prove to build the LIST monad -- F 33 | -- cliffhanger, roll credits 34 | 35 | {- moved to Lib.Cat.Category 36 | postulate 37 | ext : {S : Set}{T : S -> Set}{f g : (x : S) -> T x} -> 38 | ((x : S) -> f x == g x) -> f == g 39 | 40 | record Category {Obj : Set}(Arr : Obj -> Obj -> Set) : Set where 41 | field 42 | -- structure 43 | idArr : {X : Obj} -> Arr X X 44 | _-arr-_ : {R S T : Obj} -> Arr R S -> Arr S T -> Arr R T 45 | -- laws 46 | .idArr-arr- : {S T : Obj}(f : Arr S T) -> (idArr -arr- f) == f 47 | ._-arr-idArr : {S T : Obj}(f : Arr S T) -> (f -arr- idArr) == f 48 | .assoc-arr- : {R S T U : Obj} 49 | (f : Arr R S)(g : Arr S T)(h : Arr T U) -> 50 | ((f -arr- g) -arr- h) == (f -arr- (g -arr- h)) 51 | infixr 20 _-arr-_ 52 | 53 | SomeCategory : Set 54 | SomeCategory = Sg Set \ Obj -> 55 | Sg (Obj -> Obj -> Set) \ Arr -> 56 | Category Arr 57 | 58 | SET : Category \ S T -> S -> T 59 | SET = record 60 | { idArr = λ z → z 61 | ; _-arr-_ = λ f g → λ r → g (f r) 62 | ; idArr-arr- = λ f → refl 63 | ; _-arr-idArr = λ f → refl 64 | ; assoc-arr- = λ f g h → refl 65 | } 66 | -} 67 | 68 | refl-LE : (n : Nat) -> n <= n 69 | refl-LE zero = <> 70 | refl-LE (suc n) = refl-LE n 71 | 72 | trans-LE : (x y z : Nat) -> x <= y -> y <= z -> x <= z 73 | trans-LE zero y z xy yz = <> 74 | trans-LE (suc x) zero z () yz 75 | trans-LE (suc x) (suc y) zero xy () 76 | trans-LE (suc x) (suc y) (suc z) xy yz = trans-LE x y z xy yz 77 | 78 | irrelevant-LE : (x y : Nat) (p q : x <= y) -> p == q 79 | irrelevant-LE zero y p q = refl 80 | irrelevant-LE (suc x) zero p () 81 | irrelevant-LE (suc x) (suc y) p q = irrelevant-LE x y p q 82 | 83 | NAT-LE : Category _<=_ 84 | NAT-LE = record 85 | { idArr = \ {X} -> refl-LE X 86 | ; _-arr-_ = \ {x}{y}{z} -> trans-LE x y z 87 | ; idArr-arr- = \ {x}{y} f -> irrelevant-LE x y _ _ 88 | ; _-arr-idArr = \ {x}{y} f -> irrelevant-LE x y _ _ 89 | ; assoc-arr- = \ {x}{y}{z}{w} f g h -> irrelevant-LE x w _ _ 90 | } 91 | 92 | {- moved to Lib.Cat.Category 93 | _^op : forall {Obj}{Arr : Obj -> Obj -> Set} -> 94 | Category Arr -> Category \ S T -> Arr T S 95 | C ^op = record 96 | { idArr = idArr 97 | ; _-arr-_ = \ g f -> f -arr- g 98 | ; idArr-arr- = \ f -> f -arr-idArr 99 | ; _-arr-idArr = \ f -> idArr-arr- f 100 | ; assoc-arr- = \ f g h -> sym (assoc-arr- h g f) 101 | } 102 | where open Category C 103 | -} 104 | 105 | ADDITION : Category {One} \ _ _ -> Nat 106 | ADDITION = record 107 | { idArr = 0 108 | ; _-arr-_ = _+N_ 109 | ; idArr-arr- = \n -> refl 110 | ; _-arr-idArr = _+Nzero 111 | ; assoc-arr- = assoc+N 112 | } 113 | 114 | record Preorder {X : Set}(_ X -> Set) : Set where 115 | field 116 | reflexive : {x : X} -> x 118 | x y x p == q 120 | 121 | SomePreorder : Set1 122 | SomePreorder = 123 | Sg Set \ X -> 124 | Sg (X -> X -> Set) \ _ 125 | Preorder _ fst YP 130 | .mapMonotone : 131 | let X , _ x0 134 | mapData x0 140 | record { mapData = mapData f - mapData g 141 | ; mapMonotone = \ p -> (mapMonotone g) (mapMonotone f p) 142 | } 143 | ; idArr-arr- = \ f -> refl 144 | ; _-arr-idArr = \ f -> refl 145 | ; assoc-arr- = \ f g h -> refl 146 | } 147 | where open MonotoneMap 148 | 149 | {- moved to Lib.Cat.Functor 150 | record Functor 151 | {ObjS : Set}{ArrS : ObjS -> ObjS -> Set}(CatS : Category ArrS) 152 | {ObjT : Set}{ArrT : ObjT -> ObjT -> Set}(CatT : Category ArrT) 153 | (ObjF : ObjS -> ObjT) 154 | : Set where 155 | module S = Category CatS 156 | module T = Category CatT 157 | field 158 | map : forall {A B : ObjS} -> ArrS A B -> ArrT (ObjF A) (ObjF B) 159 | -- laws 160 | .mapidArr : forall {A} -> map (S.idArr {A}) == T.idArr {ObjF A} 161 | .map-arr- : forall {A B C}(f : ArrS A B)(g : ArrS B C) -> 162 | map (f S.-arr- g) == (map f T.-arr- map g) 163 | 164 | SomeFunctor : SomeCategory -> SomeCategory -> Set 165 | SomeFunctor (ObjS , ArrS , CatS) (ObjT , ArrT , CatT) = 166 | Sg (ObjS -> ObjT) \ ObjF -> 167 | Functor CatS CatT ObjF 168 | -} 169 | 170 | list : {A B : Set} -> (A -> B) -> List A -> List B 171 | list f [] = [] 172 | list f (a ,- as) = f a ,- list f as 173 | 174 | listId : forall {A} (as : List A) -> list (\ z -> z) as == as 175 | listId [] = refl 176 | listId (a ,- as) = (a ,-_) $= listId as -- (a ,-_) is Haskell's (a :) 177 | 178 | listComp : forall {A B C} {f : A -> B} {g : B -> C} (as : List A) -> 179 | list (\ r -> g (f r)) as == list g (list f as) 180 | listComp [] = refl 181 | listComp (a ,- as) = (_ ,-_) $= listComp as 182 | 183 | LIST : Functor SET SET List 184 | LIST = record { map = list ; mapidArr = ext listId ; map-arr- = \ f g -> ext listComp } 185 | 186 | {- moved to Lib.Cat.Functor 187 | ID : {Obj : Set}{Arr : Obj -> Obj -> Set}(C : Category Arr) -> Functor C C \ X -> X 188 | ID C = record { map = \ f -> f ; mapidArr = refl ; map-arr- = \ f g -> refl } 189 | -} 190 | 191 | {- 192 | ID : Functor SET SET \ X -> X 193 | ID = record { map = \ f -> f 194 | ; mapidArr = refl 195 | ; map-arr- = \ f g -> refl 196 | } 197 | -} 198 | 199 | {- moved to Lib.Cat.Functor 200 | module _ 201 | {ObjR : Set}{ArrR : ObjR -> ObjR -> Set}{CatR : Category ArrR} 202 | {ObjS : Set}{ArrS : ObjS -> ObjS -> Set}{CatS : Category ArrS} 203 | {ObjT : Set}{ArrT : ObjT -> ObjT -> Set}{CatT : Category ArrT} 204 | {ObjF : ObjR -> ObjS} 205 | {ObjG : ObjS -> ObjT} 206 | where 207 | private 208 | module R = Category CatR 209 | module S = Category CatS 210 | module T = Category CatT 211 | 212 | _-Func-_ : Functor CatR CatS ObjF 213 | -> 214 | Functor CatS CatT ObjG 215 | -> 216 | Functor CatR CatT \ X -> ObjG (ObjF X) 217 | Functor.map (F -Func- G) f = G.map (F.map f) 218 | where 219 | module F = Functor F 220 | module G = Functor G 221 | Functor.mapidArr (F -Func- G) = 222 | G.map (F.map R.idArr) 223 | =[ G.map $= F.mapidArr >= 224 | G.map S.idArr 225 | =[ G.mapidArr >= 226 | T.idArr 227 | [QED] 228 | where 229 | module F = Functor F 230 | module G = Functor G 231 | Functor.map-arr- (F -Func- G) f g = 232 | G.map (F.map (f R.-arr- g)) 233 | =[ G.map $= F.map-arr- f g >= 234 | G.map (F.map f S.-arr- F.map g) 235 | =[ G.map-arr- (F.map f) (F.map g) >= 236 | (G.map (F.map f) T.-arr- G.map (F.map g)) 237 | [QED] 238 | where 239 | module F = Functor F 240 | module G = Functor G 241 | 242 | infixr 20 _-Func-_ 243 | 244 | CATEGORY : Category SomeFunctor 245 | CATEGORY = record 246 | { idArr = _ , ID _ 247 | ; _-arr-_ = \ { (ObjF , F) (ObjG , G) -> _ , (F -Func- G) } 248 | ; idArr-arr- = \ F -> refl 249 | ; _-arr-idArr = \ F -> refl 250 | ; assoc-arr- = \ F G H -> refl 251 | } 252 | -} 253 | 254 | {- 255 | VEC : (n : Nat) -> Functor SET SET (\ X -> Vec X n) 256 | VEC n = record { map = {!!} ; mapidArr = {!!} ; map-arr- = {!!} } 257 | -} 258 | 259 | take : {X : Set}{A B : Nat} -> B <= A -> Vec X A -> Vec X B 260 | take {X} {m} {zero} p xs = [] 261 | take {X} {.0} {suc n} () [] 262 | take {X} {(suc m)} {suc n} p (x ,- xs) = x ,- take p xs 263 | 264 | takeAll : forall {X n} (xs : Vec X n) -> take (refl-LE n) xs == xs 265 | takeAll [] = refl 266 | takeAll (x ,- xs) = (x ,-_) $= takeAll xs 267 | 268 | takeComp : forall a b c (ba : b <= a) (cb : c <= b) {X} (xs : Vec X a) -> 269 | take {B = c} (trans-LE c b a cb ba) xs == 270 | take cb (take ba xs) 271 | takeComp a b zero ba cb xs = refl 272 | takeComp .0 zero (suc c) ba () [] 273 | takeComp .0 (suc b) (suc c) () cb [] 274 | takeComp .(suc _) zero (suc c) ba () (x ,- xs) 275 | takeComp (suc a) (suc b) (suc c) ba cb (x ,- xs) = 276 | -- takeComp .(suc a) (suc b) (suc c) ba cb (_,-_ {n = a} x xs) = 277 | (x ,-_) $= takeComp a b c ba cb xs 278 | 279 | TAKE : (X : Set) -> Functor (NAT-LE ^op) SET (Vec X) 280 | TAKE X = record 281 | { map = take 282 | ; mapidArr = ext takeAll 283 | ; map-arr- = \ {a}{b}{c} ba cb -> ext (takeComp a b c ba cb) 284 | } 285 | 286 | {- moved to Lib.Cat.NatTrans 287 | record NaturalTransformation 288 | {ObjS : Set}{ArrS : ObjS -> ObjS -> Set}{CatS : Category ArrS} 289 | {ObjT : Set}{ArrT : ObjT -> ObjT -> Set}{CatT : Category ArrT} 290 | {ObjF : ObjS -> ObjT}(F : Functor CatS CatT ObjF) 291 | {ObjG : ObjS -> ObjT}(G : Functor CatS CatT ObjG) 292 | : Set where 293 | open Category CatT 294 | open Functor 295 | field 296 | transform : (X : ObjS) -> ArrT (ObjF X) (ObjG X) 297 | .natural : {X Y : ObjS} -> (f : ArrS X Y) -> 298 | (transform X -arr- map G f) == (map F f -arr- transform Y) 299 | -} 300 | 301 | module _ where 302 | open NaturalTransformation 303 | singletonNT : NaturalTransformation (ID SET) LIST 304 | transform singletonNT X x = x ,- [] 305 | natural singletonNT f = refl 306 | 307 | {- moved to Lib.Cat.Monad 308 | record Monad {Obj : Set}{Arr : Obj -> Obj -> Set}{C : Category Arr} 309 | {ObjM : Obj -> Obj} 310 | (M : Functor C C ObjM) : Set where 311 | open Category C 312 | open Functor M 313 | field 314 | returnNT : NaturalTransformation (ID C) M 315 | joinNT : NaturalTransformation (M -Func- M) M 316 | module R = NaturalTransformation returnNT 317 | module J = NaturalTransformation joinNT 318 | field 319 | returnJoin : {X : Obj} -> 320 | (R.transform (ObjM X) -arr- J.transform X) == idArr 321 | mapReturnJoin : {X : Obj} -> 322 | (map (R.transform X) -arr- J.transform X) == idArr 323 | joinJoin : {X : Obj} -> 324 | (J.transform (ObjM X) -arr- J.transform X) 325 | == 326 | (map (J.transform X) -arr- J.transform X) 327 | KlArr : Obj -> Obj -> Set 328 | KlArr S T = Arr S (ObjM T) 329 | Kleisli : Category KlArr 330 | Kleisli = record 331 | { idArr = R.transform _ 332 | ; _-arr-_ = \ h k -> h -arr- map k -arr- J.transform _ 333 | ; idArr-arr- = \ {S} {T} f -> 334 | [=IN C ! 335 | (< R.transform S > -syn- (mapSyn M < f > -syn- < J.transform T >)) 336 | =[[ categories refl >>= 337 | (-[ < R.transform S > -syn- mapSyn M < f > ]- -syn- < J.transform T >) 338 | =[[ reduced (rq (R.natural f) , rd) >>= 339 | (-[ < f > -syn- < R.transform (ObjM T) > ]- -syn- < J.transform T >) 340 | =[[ categories refl >>= 341 | (< f > -syn- -[ < R.transform (ObjM T) > -syn- < J.transform T > ]-) 342 | =[[ reduced (rd , rq returnJoin) >>= 343 | (< f > -syn- -[ idSyn ]-) 344 | =[[ categories refl >>= 345 | < f > 346 | [[QED]] 347 | =] 348 | {- 349 | (R.transform S -arr- (map f -arr- J.transform T)) 350 | =< assoc-arr- _ _ _ ]= 351 | ((R.transform S -arr- map f) -arr- J.transform T) 352 | =[ (_-arr- J.transform T) $= R.natural f >= 353 | ((f -arr- R.transform (ObjM T)) -arr- J.transform T) 354 | =[ assoc-arr- _ _ _ >= 355 | (f -arr- R.transform (ObjM T) -arr- J.transform T) 356 | =[ (f -arr-_) $= returnJoin >= 357 | (f -arr- idArr) 358 | =[ f -arr-idArr >= 359 | f 360 | [QED] 361 | -} 362 | ; _-arr-idArr = \ {S} {T} f -> 363 | (f -arr- (map (R.transform T) -arr- J.transform T)) 364 | =[ (f -arr-_) $= mapReturnJoin >= 365 | (f -arr- idArr) 366 | =[ Category._-arr-idArr C f >= 367 | f 368 | [QED] 369 | ; assoc-arr- = \ {R}{S}{T}{U} f g h -> 370 | [=IN C ! 371 | ((< f > -syn- mapSyn M < g > -syn- < J.transform T >) -syn- mapSyn M < h > -syn- < J.transform U >) 372 | =[[ categories refl >>= 373 | (< f > -syn- mapSyn M < g > -syn- -[ < J.transform T > -syn- mapSyn M < h > ]- -syn- < J.transform U >) 374 | =[[ reduced (rd , rd , rq (J.natural h) , rd) >>= 375 | (< f > -syn- mapSyn M < g > -syn- -[ mapSyn M (mapSyn M < h >) -syn- < J.transform (ObjM U) > ]- 376 | -syn- < J.transform U >) 377 | =[[ categories refl >>= 378 | (< f > -syn- mapSyn M < g > -syn- mapSyn M (mapSyn M < h >) -syn- 379 | -[ < J.transform (ObjM U) > -syn- < J.transform U > ]-) 380 | =[[ reduced (rd , rd , rd , rq joinJoin) >>= 381 | (< f > -syn- mapSyn M < g > -syn- mapSyn M (mapSyn M < h >) -syn- 382 | -[ mapSyn M < J.transform U > -syn- < J.transform U > ]-) 383 | =[[ categories refl >>= 384 | (< f > -syn- mapSyn M (< g > -syn- mapSyn M < h > -syn- < J.transform U >) -syn- < J.transform U >) 385 | [[QED]] 386 | =] 387 | {- 388 | (f -arr- map g -arr- J.transform T) -arr- map h -arr- J.transform U 389 | =[ {!!} >= --boring assoc 390 | f -arr- map g -arr- (J.transform T -arr- map h) -arr- J.transform U 391 | =[ (\ z -> f -arr- map g -arr- z -arr- J.transform U) $= J.natural h >= 392 | f -arr- map g -arr- (map (map h) -arr- J.transform (ObjM U)) -arr- J.transform U 393 | =[ {!!} >= -- boring assoc 394 | f -arr- map g -arr- map (map h) -arr- J.transform (ObjM U) -arr- J.transform U 395 | =[ {!!} >= -- boring assoc 396 | f -arr- map g -arr- map (map h) -arr- (J.transform (ObjM U) -arr- J.transform U) 397 | =[ (\ z -> f -arr- map g -arr- map (map h) -arr- z) $= joinJoin >= 398 | f -arr- map g -arr- map (map h) -arr- (map (J.transform U) -arr- J.transform U) 399 | =[ {!!} >= -- boring functoriality + assoc 400 | f -arr- map (g -arr- map h -arr- J.transform U) -arr- J.transform U 401 | [QED] 402 | -} 403 | } 404 | -} 405 | 406 | {- moved to Lib.Cat.ProductCat 407 | _*Cat_ : {ObjS : Set}{ArrS : ObjS -> ObjS -> Set}(CatS : Category ArrS) 408 | {ObjT : Set}{ArrT : ObjT -> ObjT -> Set}(CatT : Category ArrT) -> 409 | Category {ObjS * ObjT} \ {(SS , TS) (ST , TT) -> 410 | ArrS SS ST * ArrT TS TT} 411 | CatS *Cat CatT = 412 | record 413 | { idArr = (S.idArr , T.idArr) 414 | ; _-arr-_ = \ { (fS , fT) (gS , gT) -> (fS S.-arr- gS) , (fT T.-arr- gT) } 415 | ; idArr-arr- = \ { {AS , AT} {BS , BT} (fS , fT) -> 416 | reff _,_ =$= (Category.idArr-arr- CatS fS) =$= (Category.idArr-arr- CatT fT) } 417 | ; _-arr-idArr = \ { {AS , AT} {BS , BT} (fS , fT) -> 418 | reff _,_ =$= (Category._-arr-idArr CatS fS) =$= (Category._-arr-idArr CatT fT) } 419 | ; assoc-arr- = \ { (fS , fT) (gS , gT) (hS , hT) -> reff _,_ =$= Category.assoc-arr- CatS fS gS hS =$= Category.assoc-arr- CatT fT gT hT } 420 | } 421 | where 422 | module S = Category CatS 423 | module T = Category CatT 424 | 425 | module _ 426 | {ObjS : Set}{ArrS : ObjS -> ObjS -> Set}{CatS : Category ArrS} 427 | {ObjT : Set}{ArrT : ObjT -> ObjT -> Set}{CatT : Category ArrT} 428 | {ObjF : ObjS -> ObjT}(F : Functor CatS CatT ObjF) 429 | {ObjS' : Set}{ArrS' : ObjS' -> ObjS' -> Set}{CatS' : Category ArrS'} 430 | {ObjT' : Set}{ArrT' : ObjT' -> ObjT' -> Set}{CatT' : Category ArrT'} 431 | {ObjF' : ObjS' -> ObjT'}(F' : Functor CatS' CatT' ObjF') 432 | where 433 | private 434 | module F = Functor F 435 | module F' = Functor F' 436 | open Functor 437 | 438 | _*Fun_ : 439 | Functor (CatS *Cat CatS') (CatT *Cat CatT') 440 | \ { (S , S') -> (ObjF S , ObjF' S') } 441 | map _*Fun_ (f , f') = (F.map f) , (F'.map f') 442 | mapidArr _*Fun_ = reff _,_ =$= F.mapidArr =$= F'.mapidArr 443 | map-arr- _*Fun_ (f , f') (g , g') = 444 | reff _,_ =$= F.map-arr- f g =$= F'.map-arr- f' g' 445 | -} 446 | 447 | module _ {ObjS : Set}{ArrS : ObjS -> ObjS -> Set}{CatS : Category ArrS} where 448 | open Category CatS 449 | open Functor 450 | 451 | 452 | Delta : Functor CatS (CatS *Cat CatS) \ X -> X , X 453 | Delta = record 454 | { map = \ f -> f , f 455 | ; mapidArr = refl 456 | ; map-arr- = \ f g -> refl 457 | } 458 | 459 | module _ where 460 | open Category SET 461 | open Functor 462 | 463 | SETPair : Functor (SET *Cat SET) SET \ { (S , T) -> S * T } 464 | map SETPair (f , f') (a , a') = (f a) , (f' a') 465 | mapidArr SETPair = refl 466 | map-arr- SETPair (f , f') (g , g') = refl 467 | 468 | module _ where 469 | open NaturalTransformation 470 | 471 | _+L_ : {X : Set} -> List X -> List X -> List X 472 | [] +L ys = ys 473 | (x ,- xs) +L ys = x ,- (xs +L ys) 474 | 475 | appendNatural : {X Y : Set}(f : X -> Y)(xs ys : List X) -> 476 | list f (xs +L ys) == (list f xs +L list f ys) 477 | appendNatural f [] ys = refl 478 | appendNatural f (x ,- xs) ys = (f x ,-_) $= appendNatural f xs ys 479 | 480 | appendNT : NaturalTransformation (Delta -Func- (LIST *Fun LIST) -Func- SETPair) 481 | LIST 482 | appendNT = record { transform = \ X -> \ { (xs , ys) -> xs +L ys } 483 | ; natural = \ f -> ext \ { (xs , ys) -> appendNatural f xs ys } 484 | } 485 | 486 | concat : {X : Set} -> List (List X) -> List X 487 | concat [] = [] 488 | concat (xs ,- xss) = xs +L concat xss 489 | 490 | concatNatural : forall {X Y} (f : X -> Y) (xss : List (List X)) -> 491 | list f (concat xss) == concat (list (list f) xss) 492 | concatNatural f [] = refl 493 | concatNatural f (xs ,- xss) = 494 | list f (xs +L concat xss) 495 | =[ appendNatural f xs (concat xss) >= 496 | (list f xs +L list f (concat xss)) 497 | =[ (list f xs +L_) $= concatNatural f xss >= 498 | (list f xs +L concat (list (list f) xss)) 499 | [QED] 500 | 501 | concatNT : NaturalTransformation (LIST -Func- LIST) LIST 502 | transform concatNT X = concat 503 | natural concatNT f = ext (concatNatural f) 504 | 505 | _+L[] : {X : Set} -> (xs : List X) -> (xs +L []) == xs 506 | [] +L[] = refl 507 | (x ,- xs) +L[] = (x ,-_) $= (xs +L[]) 508 | 509 | concatMapSing : {X : Set} -> (xs : List X) -> 510 | concat (list (\ x -> x ,- []) xs) == xs 511 | concatMapSing [] = refl 512 | concatMapSing (x ,- xs) = (x ,-_) $= concatMapSing xs 513 | 514 | assoc+L : {X : Set} (xs ys zs : List X) -> ((xs +L ys) +L zs) == (xs +L (ys +L zs)) 515 | assoc+L [] ys zs = refl 516 | assoc+L (x ,- xs) ys zs = (x ,-_) $= assoc+L xs ys zs 517 | 518 | concatAppend : {X : Set} -> (xss yss : List (List X)) -> 519 | concat (xss +L yss) == (concat xss +L concat yss) 520 | concatAppend [] yss = refl 521 | concatAppend (xs ,- xss) yss = 522 | (xs +L concat (xss +L yss)) 523 | =[ (xs +L_) $= concatAppend xss yss >= 524 | (xs +L (concat xss +L concat yss)) 525 | =< assoc+L xs _ _ ]= 526 | ((xs +L concat xss) +L concat yss) 527 | [QED] 528 | 529 | concatConcat : {X : Set} -> (xs : List (List (List X))) -> 530 | concat (concat xs) == concat (list concat xs) 531 | concatConcat [] = refl 532 | concatConcat (xss ,- xsss) = 533 | concat (xss +L concat xsss) 534 | =[ concatAppend xss _ >= 535 | (concat xss +L concat (concat xsss)) 536 | =[ (concat xss +L_) $= concatConcat xsss >= 537 | (concat xss +L concat (list concat xsss)) 538 | [QED] 539 | 540 | LISTMonad : Monad LIST 541 | LISTMonad = record 542 | { returnNT = singletonNT 543 | ; joinNT = concatNT 544 | ; returnJoin = ext _+L[] 545 | ; mapReturnJoin = ext concatMapSing 546 | ; joinJoin = ext concatConcat 547 | } 548 | 549 | 550 | 551 | 552 | 553 | 554 | 555 | {- here are some we made earlier 556 | 557 | Kleisli : Category KlArr 558 | Kleisli = record 559 | { idArr = R.transform _ 560 | ; _-arr-_ = \ h k -> h -arr- map k -arr- J.transform _ 561 | ; idArr-arr- = {!!} 562 | ; _-arr-idArr = {!!} 563 | ; assoc-arr- = {!!} 564 | } 565 | 566 | 567 | F -Func- G = record 568 | { map = \ ab -> G.map (F.map ab) 569 | ; mapidArr = 570 | G.map (F.map R.idArr) 571 | =[ G.map $= F.mapidArr >= 572 | G.map S.idArr 573 | =[ G.mapidArr >= 574 | T.idArr 575 | [QED] 576 | ; map-arr- = \ h k -> 577 | G.map (F.map (h R.-arr- k)) 578 | =[ G.map $= F.map-arr- h k >= 579 | G.map (F.map h S.-arr- F.map k) 580 | =[ G.map-arr- (F.map h) (F.map k) >= 581 | (G.map (F.map h) T.-arr- G.map (F.map k)) 582 | [QED] 583 | } 584 | 585 | 586 | CATEGORY = record 587 | { idArr = \ { {_ , _ , C} -> _ , ID C } 588 | ; _-arr-_ = \ { (ObjF , F) (ObjG , G) -> _ , (F -Func- G) } 589 | ; idArr-arr- = \ _ -> refl 590 | ; _-arr-idArr = \ _ -> refl 591 | ; assoc-arr- = \ _ _ _ -> refl 592 | } 593 | 594 | CatS *Cat CatT = record 595 | { idArr = S.idArr , T.idArr 596 | ; _-arr-_ = \ { (fS , fT) (gS , gT) -> (fS S.-arr- gS) , (fT T.-arr- gT) } 597 | ; idArr-arr- = \ { (fS , fT) -> reff _,_ =$= S.idArr-arr- fS =$= T.idArr-arr- fT } 598 | ; _-arr-idArr = \ { (fS , fT) -> reff _,_ =$= (fS S.-arr-idArr) =$= (fT T.-arr-idArr) } 599 | ; assoc-arr- = \ { (fS , fT) (gS , gT) (hS , hT) -> 600 | reff _,_ =$= S.assoc-arr- fS gS hS =$= T.assoc-arr- fT gT hT } 601 | } 602 | where 603 | module S = Category CatS 604 | module T = Category CatT 605 | 606 | _*Fun_ : 607 | Functor (CatS *Cat CatS') (CatT *Cat CatT') \ { (S , S') -> (ObjF S , ObjF' S') } 608 | map _*Fun_ (f , f') = F.map f , F'.map f' 609 | mapidArr _*Fun_ = reff _,_ =$= F.mapidArr =$= F'.mapidArr 610 | map-arr- _*Fun_ (f , f') (g , g') = reff _,_ =$= F.map-arr- f g =$= F'.map-arr- f' g' 611 | 612 | 613 | 614 | module _ {ObjS : Set}{ArrS : ObjS -> ObjS -> Set}{CatS : Category ArrS} where 615 | open Category CatS 616 | open Functor 617 | 618 | Delta : Functor CatS (CatS *Cat CatS) \ X -> X , X 619 | map Delta f = f , f 620 | mapidArr Delta = refl 621 | map-arr- Delta _ _ = refl 622 | 623 | module _ where 624 | open Category SET 625 | open Functor 626 | 627 | SETPair : Functor (SET *Cat SET) SET \ { (S , T) -> S * T } 628 | map SETPair (f , g) (a , b) = f a , g b 629 | mapidArr SETPair = refl 630 | map-arr- SETPair f g = refl 631 | 632 | 633 | 634 | _+L_ : {X : Set} -> List X -> List X -> List X 635 | [] +L ys = ys 636 | (x ,- xs) +L ys = x ,- (xs +L ys) 637 | 638 | concat : {X : Set} -> List (List X) -> List X 639 | concat [] = [] 640 | concat (xs ,- xss) = xs +L concat xss 641 | 642 | appendNatural : forall {X Y} (f : X -> Y) (xs ys : List X) -> 643 | list f (xs +L ys) == (list f xs +L list f ys) 644 | appendNatural f [] ys = refl 645 | appendNatural f (x ,- xs) ys = (f x ,-_) $= appendNatural f xs ys 646 | 647 | concatNatural : forall {X Y} (f : X -> Y) (xss : List (List X)) -> 648 | list f (concat xss) == concat (list (list f) xss) 649 | concatNatural f [] = refl 650 | concatNatural f (xs ,- xss) = 651 | list f (xs +L concat xss) 652 | =[ appendNatural f xs (concat xss) >= 653 | list f xs +L list f (concat xss) 654 | =[ (list f xs +L_) $= concatNatural f xss >= 655 | list f xs +L concat (list (list f) xss) 656 | [QED] 657 | 658 | 659 | 660 | appendNT : NaturalTransformation (Delta -Func- (LIST *Fun LIST) -Func- SETPair) LIST 661 | transform appendNT X (xs , ys) = xs +L ys 662 | natural appendNT f = ext \ { (xs , ys) -> appendNatural f xs ys } 663 | 664 | 665 | 666 | transform concatNT = \ _ -> concat 667 | natural concatNT = \ f -> ext (concatNatural f) 668 | 669 | -} 670 | --------------------------------------------------------------------------------