├── .gitignore ├── CS410.pdf ├── Ex6 ├── Ex6-4-Going.png ├── Makefile ├── ANSIEscapes.hs ├── ViewDemo.agda ├── README.md ├── HaskellSetup.hs ├── Ex6-1-Vec.agda ├── Ex6-1-Vec-Dummy.agda ├── Ex6-1-Vec-Sol.agda ├── Ex6-2-Box.agda ├── Ex6-3-Cut.agda ├── Ex6-Setup.agda ├── Ex6-2-Box-Sol.agda └── Ex6-5-App.agda ├── Ex5 ├── Makefile ├── ANSIEscapes.hs ├── HaskellSetup.hs ├── AgdaSetup.agda └── Edit.agda ├── Ex2Prelude.agda ├── L1.agda ├── ListSuccess.agda ├── Hello.agda ├── Makefile ├── HuttonFail.agda ├── LICENSE ├── Lambda.agda ├── Logic.lagda ├── Hutton.agda ├── Ex1Prelude.agda ├── Zipper.agda ├── IxCon.agda ├── HuttonVar.agda ├── NBE.agda ├── CS410.lagda ├── CoInd.agda ├── Ex3.agda ├── EmacsCheatSheet.lagda ├── FuncKit.agda ├── Ex3Sol.agda ├── Ex1.agda ├── Ex2.agda ├── Ex2Tut.agda ├── FunctorKit.agda ├── Ex4Lec.agda ├── Ex2Sol.agda ├── FuncLec.agda └── Ex1Sol.agda /.gitignore: -------------------------------------------------------------------------------- 1 | *.agdai 2 | -------------------------------------------------------------------------------- /CS410.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pigworker/CS410-14/HEAD/CS410.pdf -------------------------------------------------------------------------------- /Ex6/Ex6-4-Going.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pigworker/CS410-14/HEAD/Ex6/Ex6-4-Going.png -------------------------------------------------------------------------------- /Ex5/Makefile: -------------------------------------------------------------------------------- 1 | default: Edit 2 | 3 | Edit: Edit.agda ANSIEscapes.hs HaskellSetup.hs AgdaSetup.agda 4 | agda --compile --ghc-flag "-lncurses" Edit.agda 5 | -------------------------------------------------------------------------------- /Ex2Prelude.agda: -------------------------------------------------------------------------------- 1 | module Ex2Prelude where 2 | 3 | open import Ex1Prelude 4 | 5 | All : {X : Set} -- element type 6 | -> (X -> Set) -- property of elements 7 | -> List X -> Set -- property of whole lists 8 | All P [] = One 9 | All P (x :> xs) = P x /*/ All P xs 10 | 11 | {- If X = One, then List X is like a copy of Nat, and All is a bit like Vec -} 12 | -------------------------------------------------------------------------------- /L1.agda: -------------------------------------------------------------------------------- 1 | module L1 where 2 | 3 | data Nat : Set where 4 | zero : Nat 5 | suc : Nat -> Nat 6 | 7 | {-# BUILTIN NATURAL Nat #-} 8 | 9 | -- data Nat = Zero | Suc Nat 10 | 11 | _+_ : Nat -> Nat -> Nat 12 | zero + y = y 13 | suc x + y = suc (x + y) 14 | 15 | data List (X : Set) : Nat -> Set where 16 | [] : List X zero 17 | _,_ : forall {n} -> X -> List X n -> List X (suc n) 18 | 19 | _++_ : forall {X m n} -> List X m -> List X n -> List X (m + n) 20 | [] ++ ys = ys 21 | (x₁ , x₂) ++ ys = x₁ , (x₂ ++ ys) 22 | -------------------------------------------------------------------------------- /ListSuccess.agda: -------------------------------------------------------------------------------- 1 | module ListSuccess where 2 | 3 | open import Ex1Prelude 4 | 5 | 6 | _++_ : {X : Set} -> List X -> List X -> List X 7 | [] ++ ys = ys 8 | x :> xs ++ ys = x :> (xs ++ ys) 9 | 10 | infixr 3 _++_ 11 | 12 | win : {X : Set} -> X -> List X 13 | win x = x :> [] 14 | 15 | _>>=_ : {X Y : Set} -> List X -> (X -> List Y) -> List Y 16 | [] >>= x2ys = [] 17 | (x :> xs) >>= x2ys = (x2ys x) ++ xs >>= x2ys 18 | 19 | try2 : {R S T : Set} -> (R -> S -> T) -> List R -> List S -> List T 20 | try2 f rs ss = rs >>= (\ r -> ss >>= \ s -> win (f r s)) 21 | -------------------------------------------------------------------------------- /Hello.agda: -------------------------------------------------------------------------------- 1 | module Hello where 2 | 3 | -- Oh, you made it! Well done! This line is a comment. 4 | 5 | -- In the beginning, Agda knows nothing, but we can teach it about numbers. 6 | 7 | data Nat : Set where 8 | zero : Nat 9 | suc : Nat -> Nat 10 | 11 | -- Now we can say how to add numbers. 12 | 13 | _+_ : Nat -> Nat -> Nat 14 | zero + n = n 15 | suc m + n = suc (m + n) 16 | 17 | -- Now we can try adding some numbers. 18 | 19 | four : Nat 20 | four = (suc (suc zero)) + (suc (suc zero)) 21 | 22 | -- To make it go, select "Evaluate term to normal form" from the 23 | -- Agda menu, then type "four", without the quotes, and press return. 24 | 25 | -- Hopefully, you should get a response 26 | -- suc (suc (suc (suc zero))) 27 | 28 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | default : CS410.pdf 2 | 3 | CS410.tex : CS410.lagda Introduction.lagda BasicPrelude.lagda EmacsCheatSheet.lagda Logic.lagda Razor.lagda 4 | lhs2TeX --agda CS410.lagda > CS410.tex 5 | 6 | CS410.aux : CS410.tex 7 | latex CS410 8 | 9 | CS410.blg : CS410.aux CS410.bib 10 | bibtex CS410 11 | 12 | CS410.dvi : CS410.tex CS410.blg 13 | latex CS410 14 | latex CS410 15 | 16 | CS410.pdf : CS410.tex CS410.blg 17 | pdflatex CS410 18 | 19 | 20 | # Ex2 21 | 22 | EX2=Ex2 23 | REPLACE=replace 24 | 25 | ex2: $(EX2).pdf 26 | 27 | $(EX2).pdf: latex/$(EX2).tex 28 | cd latex/ && \ 29 | latexmk -pdf -use-make $(EX2).tex && \ 30 | mv $(EX2).pdf .. 31 | 32 | latex/%.tex: %.lagda 33 | agda --allow-unsolved-metas -i . --latex $< 34 | sed -f $(REPLACE).sed $@ > $@.sedded 35 | mv $@.sedded $@ -------------------------------------------------------------------------------- /HuttonFail.agda: -------------------------------------------------------------------------------- 1 | module HuttonFail where 2 | 3 | open import Ex1Prelude 4 | 5 | data HExp : Set where 6 | fail : HExp 7 | val : Nat -> HExp 8 | _+++_ : HExp -> HExp -> HExp 9 | 10 | data Maybe (X : Set) : Set where 11 | yes : X -> Maybe X 12 | no : Maybe X 13 | 14 | eval : HExp -> Maybe Nat 15 | eval fail = no 16 | eval (val x) = yes x 17 | eval (e +++ e') with eval e 18 | eval (e +++ e') | yes x with eval e' 19 | eval (e +++ e') | yes x | yes x' = yes (x + x') 20 | eval (e +++ e') | yes x | no = no 21 | eval (e +++ e') | no = no 22 | 23 | _-then-_ : {S T : Set} -> Maybe S -> (S -> Maybe T) -> Maybe T 24 | yes x -then- s2mt = s2mt x 25 | no -then- s2mt = no 26 | 27 | eval2 : HExp -> Maybe Nat 28 | eval2 fail = no 29 | eval2 (val x) = yes x 30 | eval2 (e +++ e') = 31 | eval2 e -then- \ v -> 32 | eval2 e' -then- \ v' -> 33 | yes (v + v') 34 | 35 | _-?>_ : Set -> Set -> Set 36 | S -?> T = S -> Maybe T 37 | -------------------------------------------------------------------------------- /Ex6/Makefile: -------------------------------------------------------------------------------- 1 | Ex6-4-Dis: Ex6-4-Dis.agda ANSIEscapes.hs HaskellSetup.hs Ex6-Setup.agda Ex6-1-Vec.agda Ex6-2-Box.agda Ex6-3-Cut.agda 2 | agda --compile --ghc-flag "-lncurses" Ex6-4-Dis.agda 3 | 4 | go4: Ex6-4-Dis 5 | ./Ex6-4-Dis 6 | 7 | Ex6-4-Dis-Sol: Ex6-4-Dis-Sol.agda ANSIEscapes.hs HaskellSetup.hs Ex6-Setup.agda Ex6-1-Vec-Sol.agda Ex6-2-Box-Sol.agda Ex6-3-Cut-Sol.agda 8 | agda --compile --ghc-flag "-lncurses" Ex6-4-Dis-Sol.agda 9 | 10 | go4sol: Ex6-4-Dis-Sol 11 | ./Ex6-4-Dis-Sol 12 | 13 | Ex6-5-App-Sol: Ex6-5-App-Sol.agda Ex6-4-Dis-Sol.agda ANSIEscapes.hs HaskellSetup.hs Ex6-Setup.agda Ex6-1-Vec-Sol.agda Ex6-2-Box-Sol.agda Ex6-3-Cut-Sol.agda Ex6-4-Dis-Sol.agda 14 | agda --compile --ghc-flag "-lncurses" Ex6-5-App-Sol.agda 15 | 16 | go5sol: Ex6-5-App-Sol 17 | ./Ex6-5-App-Sol 18 | 19 | Ex6-5-App: Ex6-5-App.agda Ex6-4-Dis.agda ANSIEscapes.hs HaskellSetup.hs Ex6-Setup.agda Ex6-1-Vec.agda Ex6-2-Box.agda Ex6-3-Cut.agda Ex6-4-Dis.agda 20 | agda --compile --ghc-flag "-lncurses" Ex6-5-App.agda 21 | 22 | go5: Ex6-5-App 23 | ./Ex6-5-App 24 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This is free and unencumbered software released into the public domain. 2 | 3 | Anyone is free to copy, modify, publish, use, compile, sell, or 4 | distribute this software, either in source code form or as a compiled 5 | binary, for any purpose, commercial or non-commercial, and by any 6 | means. 7 | 8 | In jurisdictions that recognize copyright laws, the author or authors 9 | of this software dedicate any and all copyright interest in the 10 | software to the public domain. We make this dedication for the benefit 11 | of the public at large and to the detriment of our heirs and 12 | successors. We intend this dedication to be an overt act of 13 | relinquishment in perpetuity of all present and future rights to this 14 | software under copyright law. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 19 | IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR 20 | OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 21 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | 24 | For more information, please refer to 25 | 26 | -------------------------------------------------------------------------------- /Lambda.agda: -------------------------------------------------------------------------------- 1 | module Lambda where 2 | 3 | open import Ex1Prelude 4 | 5 | data Ty : Set where 6 | base : Ty 7 | _>>_ : Ty -> Ty -> Ty 8 | 9 | data Cx : Set where 10 | C0 : Cx 11 | _/_ : Cx -> Ty -> Cx 12 | infixl 4 _/_ 13 | 14 | infixr 3 _<:_ 15 | data _<:_ (T : Ty) : Cx -> Set where 16 | zero : {G : Cx} -> T <: G / T 17 | suc : {G : Cx}{S : Ty} -> T <: G -> T <: G / S 18 | 19 | data Term (G : Cx) : Ty -> Set where 20 | var : {S : Ty} -> S <: G -> Term G S 21 | lam : {S T : Ty} -> Term (G / S) T -> Term G (S >> T) 22 | _$_ : {S T : Ty} -> Term G (S >> T) -> Term G S -> Term G T 23 | 24 | myTerm : Term (C0 / base) base 25 | myTerm = lam (var zero $ (var zero $ var (suc zero))) $ lam (var zero) 26 | 27 | Semantics : Ty -> Set 28 | Semantics base = Nat 29 | Semantics (S >> T) = Semantics S -> Semantics T 30 | 31 | Env : Cx -> Set 32 | Env G = {T : Ty} -> T <: G -> Semantics T 33 | 34 | _//_ : {G : Cx}{S : Ty} -> Env G -> Semantics S -> Env (G / S) 35 | (g // s) zero = s 36 | (g // s) (suc x) = g x 37 | 38 | eval : {G : Cx}{T : Ty} -> Term G T -> Env G -> Semantics T 39 | eval (var x) g = g x 40 | eval (lam t) g = \ s -> eval t (g // s) 41 | eval (f $ s) g = eval f g (eval s g) 42 | 43 | myTest : Nat 44 | myTest = eval myTerm ((\ ()) // 42) 45 | 46 | myTerm' : Term (C0 / (base >> base) / base) base 47 | myTerm' = lam (var zero $ (var zero $ var (suc zero))) $ 48 | lam (var (suc (suc zero)) $ (var (suc (suc zero)) $ var zero)) 49 | 50 | myTest' : Nat 51 | myTest' = eval myTerm' (((\ ()) // suc) // 42) 52 | -------------------------------------------------------------------------------- /Logic.lagda: -------------------------------------------------------------------------------- 1 | \chapter{Logic via Types} 2 | 3 | The inescapable honesty of Agda makes it possible for us to 4 | treat values as \emph{evidence} for something. We gain a 5 | logical interpretation of types. 6 | 7 | %format Logic = "\M{Logic}" 8 | \begin{code} 9 | module Logic where 10 | 11 | open import BasicPrelude 12 | \end{code} 13 | 14 | One way of looking at logical formulae is to consider what constitutes 15 | evidence that they hold. We can look at the connectives systematically. 16 | 17 | What constitutes `evidence for A or B'? Either `evidence for A' 18 | or `evidence for B'. If we have a type, |A|, representing `evidence for A' 19 | and another, |B| representing `evidence for B', then |A /+/ B| represents 20 | `evidence for A or B'. 21 | 22 | What constitutes `evidence for A and B'? We need both `evidence for A' 23 | and `evidence for B'. If we have a type, |A|, representing `evidence for A' 24 | and another, |B| representing `evidence for B', then |A /*/ B| represents 25 | `evidence for A and B'. 26 | 27 | What constitutes `evidence that A implies B'? We need to be sure that, 28 | given `evidence for A', we can produce `evidence for B'. If we have a 29 | type, |A|, representing `evidence for A' and another, |B| representing 30 | `evidence for B', then |A -> B| represents `evidence for A and B'. 31 | 32 | There will be more to say here, after exercise 1 is completed, but the basic 33 | message is: 34 | \begin{center} 35 | propositions are types; types are propositions\\ 36 | proofs are programs; programs are proofs 37 | \end{center} 38 | 39 | Types like |Nat| are rather boring propositions. Types like |2 + 2 == 4| are 40 | slightly more interesting. 41 | 42 | -------------------------------------------------------------------------------- /Hutton.agda: -------------------------------------------------------------------------------- 1 | module Hutton where 2 | 3 | open import Ex1Prelude 4 | open import Ex2Prelude 5 | 6 | 7 | {- 8 | data Nat : Set where 9 | zero : Nat 10 | suc : Nat -> Nat 11 | 12 | {-# BUILTIN NATURAL Nat #-} 13 | 14 | 15 | data List (X : Set) : Set where 16 | [] : List X 17 | _:>_ : X -> List X -> List X 18 | 19 | infixr 5 _:>_ 20 | 21 | _+_ : Nat -> Nat -> Nat 22 | zero + y = y 23 | suc x + y = suc (x + y) 24 | -} 25 | 26 | data HExp : Set where 27 | val : Nat -> HExp 28 | _+++_ : HExp -> HExp -> HExp 29 | 30 | {- 31 | id : {X : Set} -> X -> X 32 | id x = x 33 | -} 34 | 35 | eval : HExp -> Nat 36 | eval (val n) = id n 37 | eval (d +++ e) = eval d + eval e 38 | 39 | leaves : HExp -> List Nat 40 | leaves (val n) = n :> [] 41 | leaves (d +++ e) = {!leaves d ++ leaves e!} 42 | 43 | data HCode : List One -> List One -> Set where 44 | PUSH : {i : List One} -> Nat -> HCode i (<> :> i) 45 | ADD : {i : List One} -> HCode (<> :> <> :> i) (<> :> i) 46 | _-SEQ-_ : {i j k : List One} -> HCode i j -> HCode j k -> HCode i k 47 | infixr 3 _-SEQ-_ 48 | 49 | {- 50 | data Vec (X : Set) : Nat -> Set where 51 | [] : Vec X zero 52 | _,_ : forall {n} -> X -> Vec X n -> Vec X (suc n) 53 | -} 54 | 55 | Stk : List One -> Set 56 | Stk xs = All (\ _ -> Nat) xs 57 | 58 | 59 | exec : {i j : List One} -> HCode i j -> Stk i -> Stk j 60 | exec (PUSH x) s = x , s 61 | exec ADD (x , (y , s)) = (y + x) , s 62 | exec (h -SEQ- k) s = exec k (exec h s) 63 | 64 | 65 | exec' : (i j : List One) -> HCode i j -> Stk i -> Stk j 66 | exec' i .(<> :> i) (PUSH x) s = x , s 67 | exec' .(<> :> <> :> i) .(<> :> i) (ADD {i}) (y , (x , s)) = (x + y) , s 68 | exec' i j (c -SEQ- c') s = {!exec' _ j c' (exec' i _ c s)!} 69 | 70 | {- 71 | compile : HExp -> {i : Nat} -> HCode i (suc i) 72 | compile (val n) = PUSH n 73 | compile (d +++ e) = compile d -SEQ- compile e -SEQ- ADD 74 | -} 75 | -------------------------------------------------------------------------------- /Ex1Prelude.agda: -------------------------------------------------------------------------------- 1 | module Ex1Prelude where 2 | 3 | data Nat : Set where 4 | zero : Nat 5 | suc : Nat -> Nat 6 | 7 | {-# BUILTIN NATURAL Nat #-} 8 | 9 | _+_ : Nat -> Nat -> Nat 10 | zero + n = n 11 | suc m + n = suc (m + n) 12 | 13 | infixr 5 _+_ 14 | 15 | data Zero : Set where 16 | 17 | magic : {X : Set} -> 18 | Zero -> X 19 | magic () 20 | 21 | record One : Set where 22 | constructor <> 23 | 24 | data Two : Set where 25 | tt ff : Two 26 | 27 | if_then_else_ : {X : Set} -> Two -> X -> X -> X 28 | if tt then t else f = t 29 | if ff then t else f = f 30 | 31 | _/\_ : Two -> Two -> Two 32 | b1 /\ b2 = if b1 then b2 else ff 33 | 34 | _<=_ : Nat -> Nat -> Two 35 | zero <= y = tt 36 | suc x <= zero = ff 37 | suc x <= suc y = x <= y 38 | 39 | data List (X : Set) : Set where 40 | [] : List X 41 | _:>_ : X -> List X -> List X 42 | 43 | infixr 5 _:>_ 44 | 45 | data _==_ {l}{X : Set l}(x : X) : X -> Set l where 46 | refl : x == x 47 | infix 4 _==_ 48 | {-# BUILTIN EQUALITY _==_ #-} 49 | {-# BUILTIN REFL refl #-} 50 | 51 | infixr 1 _/+/_ 52 | 53 | data _/+/_ (S T : Set) : Set where 54 | inl : S -> S /+/ T 55 | inr : T -> S /+/ T 56 | 57 | __ : {S T X : Set} -> 58 | (S -> X) -> (T -> X) -> 59 | S /+/ T -> X 60 | (f g) (inl s) = f s 61 | (f g) (inr t) = g t 62 | 63 | infixr 2 _/*/_ 64 | 65 | record _/*/_ (S T : Set) : Set where -- (S , T) 66 | constructor _,_ 67 | field 68 | outl : S 69 | outr : T 70 | open _/*/_ public 71 | infixr 4 _,_ 72 | 73 | curry : {S T X : Set} -> 74 | (S /*/ T -> X) -> 75 | S -> T -> X 76 | curry f s t = f (s , t) 77 | 78 | uncurry : {S T X : Set} -> 79 | (S -> T -> X) -> 80 | S /*/ T -> X 81 | uncurry f (s , t) = f s t 82 | 83 | id : {X : Set} -> X -> X 84 | id x = x 85 | 86 | _o_ : {A B C : Set} -> (B -> C) -> (A -> B) -> (A -> C) 87 | (f o g) a = f (g a) 88 | 89 | infixr 2 _o_ 90 | -------------------------------------------------------------------------------- /Zipper.agda: -------------------------------------------------------------------------------- 1 | module Zipper where 2 | 3 | open import Ex1Prelude 4 | open import FuncKit 5 | 6 | 7 | data Tree (X : Set) : Set where 8 | leaf : Tree X 9 | _<[_]>_ : Tree X -> X -> Tree X -> Tree X 10 | 11 | data Context (X : Set) : Set where 12 | root : Context X 13 | lefty : Context X -> X -> Tree X -> Context X 14 | righty : Tree X -> X -> Context X -> Context X 15 | 16 | data Layer (X : Set) : Set where 17 | lefty : One -> X -> Tree X -> Layer X 18 | righty : Tree X -> X -> One -> Layer X 19 | 20 | -- take Context X = List (Layer X) 21 | 22 | TreeZipper : Set -> Set 23 | TreeZipper X = Context X /*/ Tree X 24 | 25 | getOutHelp : {X : Set} -> Context X -> Tree X -> Tree X 26 | getOutHelp root t = t 27 | getOutHelp (lefty c x r) t = getOutHelp c (t <[ x ]> r) 28 | getOutHelp (righty l x c) t = getOutHelp c (l <[ x ]> t) 29 | 30 | getOut : {X : Set} -> TreeZipper X -> Tree X 31 | getOut (c , t) = getOutHelp c t 32 | {- -- termination checker says no 33 | getOut (root , t) = t 34 | getOut (lefty c x r , t) = getOut (c , (t <[ x ]> r)) 35 | getOut (righty l x c , t) = getOut (c , (l <[ x ]> t)) 36 | -} 37 | 38 | Maybe : Set -> Set 39 | Maybe X = One /+/ X 40 | 41 | goLeft : {X : Set} -> TreeZipper X -> Maybe (TreeZipper X) 42 | goLeft (c , leaf) = inl <> 43 | goLeft (c , l <[ x ]> r) = inr (lefty c x r , l) 44 | 45 | layer : Kit -> Kit 46 | layer (kK A) = kK Zero 47 | layer kId = kK One 48 | layer (j k+ k) = layer j k+ layer k 49 | layer (j k* k) = (layer j k* k) k+ (j k* layer k) 50 | 51 | plug : (k : Kit) -> {X : Set} -> kFun (layer k) X -> X -> kFun k X 52 | plug (kK A) () x 53 | plug kId <> x = x 54 | plug (j k+ k) (inl j') x = inl (plug j j' x) 55 | plug (j k+ k) (inr k') x = inr (plug k k' x) 56 | plug (j k* k) (inl (j' , k')) x = plug j j' x , k' 57 | plug (j k* k) (inr (j' , k')) x = j' , plug k k' x 58 | 59 | KLayer : Kit -> Set 60 | KLayer k = kFun (layer k) (Data k) 61 | 62 | kOut1 : (k : Kit) -> KLayer k -> Data k -> Data k 63 | kOut1 k l d = [ plug k l d ] 64 | 65 | -------------------------------------------------------------------------------- /Ex6/ANSIEscapes.hs: -------------------------------------------------------------------------------- 1 | module ANSIEscapes where 2 | 3 | data Direction = DU | DD | DL | DR 4 | 5 | instance Show Direction 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 :: Direction -> 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 -------------------------------------------------------------------------------- /IxCon.agda: -------------------------------------------------------------------------------- 1 | module IxCon where 2 | 3 | open import Ex1Prelude 4 | 5 | record Sigma (S : Set)(T : S -> Set) : Set where 6 | constructor _,_ 7 | field 8 | fst : S 9 | snd : T fst 10 | open Sigma public 11 | 12 | record _=>_ (I J : Set) : Set1 where 13 | constructor _ Set 16 | Response : (j : J) -> Command j -> Set 17 | next : (j : J)(c : Command j) -> Response j c -> I 18 | open _=>_ public 19 | 20 | _-:>_ : {I : Set}(S T : I -> Set) -> Set 21 | S -:> T = {i : _} -> S i -> T i 22 | 23 | record FunctorIx (I J : Set) : Set1 where 24 | field 25 | FObj : (I -> Set) -> J -> Set 26 | FArr : {S T : I -> Set} -> (S -:> T) -> FObj S -:> FObj T 27 | open FunctorIx public 28 | 29 | [[_]] : {I J : Set} -> I => J -> FunctorIx I J 30 | [[ Command Sigma (Command j) \ c -> (r : Response j c) -> Goal (next j c r) 32 | ; FArr = \ { f {j} (c , k) -> c , (\ r -> f (k r)) } 33 | } 34 | 35 | data Game {I : Set}(C : I => I)(Win : I -> Set)(i : I) : Set where 36 | win : Win i -> Game C Win i 37 | <_> : FObj [[ C ]] (Game C Win) i -> Game C Win i 38 | 39 | VCon : Set -> (Nat => Nat) 40 | VCon A = (\ { zero -> Zero ; (suc n) -> A }) 41 | One) 42 | / \ { zero () _ 43 | ; (suc n) a <> -> n 44 | } 45 | 46 | Vector : Set -> Nat -> Set 47 | Vector A n = Game (VCon A) (\ { zero -> One ; (suc n) -> Zero }) n 48 | 49 | vnil : {A : Set} -> Vector A zero 50 | vnil = win <> 51 | 52 | vcons : {A : Set}{n : Nat} -> A -> Vector A n -> Vector A (suc n) 53 | vcons a as = < a , (\ { <> -> as }) > 54 | 55 | data Bound : Set where 56 | bot : Bound 57 | # : Nat -> Bound 58 | top : Bound 59 | 60 | TGame : (Bound /*/ Bound) => (Bound /*/ Bound) 61 | TGame = (\ _ -> Nat) Two) 62 | / (\ { (l , u) n tt -> (l , # n) 63 | ; (l , u) n ff -> (# n , u) 64 | }) 65 | 66 | Le : Nat -> Nat -> Set 67 | Le zero y = One 68 | Le (suc x) zero = Zero 69 | Le (suc x) (suc y) = Le x y 70 | 71 | LeB : Bound /*/ Bound -> Set 72 | LeB (bot , _) = One 73 | LeB (# x , # y) = Le x y 74 | LeB (_ , top) = One 75 | LeB _ = Zero 76 | 77 | MyTree : Set 78 | MyTree = Game TGame LeB (bot , top) 79 | 80 | leaf : {l u : Bound} -> LeB (l , u) -> Game TGame LeB (l , u) 81 | leaf = win 82 | 83 | node : {l u : Bound}(n : Nat) -> Game TGame LeB (l , # n) -> Game TGame LeB (# n , u) -> 84 | Game TGame LeB (l , u) 85 | node n ln nu = < n , (\ { tt -> ln ; ff -> nu }) > 86 | -------------------------------------------------------------------------------- /HuttonVar.agda: -------------------------------------------------------------------------------- 1 | module HuttonVar where 2 | 3 | open import Ex1Prelude 4 | 5 | data HExp (V : Set) : Set where 6 | var : V -> HExp V 7 | val : Nat -> HExp V 8 | _+++_ : HExp V -> HExp V -> HExp V 9 | 10 | eval : HExp Zero -> Nat 11 | eval (var ()) 12 | eval (val n) = id n 13 | eval (d +++ e) = eval d + eval e 14 | 15 | subst : {U V : Set} -> HExp U -> (U -> HExp V) -> HExp V 16 | subst (var x) s = s x 17 | subst (val n) s = val n 18 | subst (d +++ e) s = subst d s +++ subst e s 19 | 20 | hMap : {U V : Set} -> (U -> V) -> (HExp U -> HExp V) 21 | hMap f e = subst e (var o f) 22 | 23 | eval' : {V : Set} -> HExp V -> (V -> Nat) -> Nat 24 | eval' e g = eval (subst e (val o g)) 25 | 26 | mySubst : Two -> HExp One 27 | mySubst tt = val 5 28 | mySubst ff = var <> +++ val 3 29 | 30 | myTest : HExp One 31 | myTest = subst ((val 1 +++ var tt) +++ (var tt +++ var ff)) mySubst 32 | 33 | Subst : Set -> Set -> Set 34 | Subst U V = U -> HExp V 35 | 36 | idSubst : (V : Set) -> Subst V V 37 | idSubst V = var 38 | 39 | compSubst : {U V W : Set} -> Subst V W -> Subst U V -> Subst U W 40 | compSubst f g = \ u -> subst (g u) f 41 | 42 | Envy : Set -> Set -> Set 43 | Envy V X = (V -> Nat) -> X 44 | 45 | envyRet : {V X : Set} -> X -> Envy V X 46 | envyRet x g = x 47 | 48 | _-envyThen-_ : {V X Y : Set} -> 49 | Envy V X -> (X -> Envy V Y) -> Envy V Y 50 | evx -envyThen- x2evy = \ g -> x2evy (evx g) g 51 | 52 | gimme : {V : Set} -> V -> Envy V Nat 53 | gimme v = \ g -> g v 54 | 55 | eval2 : {V : Set} -> HExp V -> Envy V Nat 56 | eval2 (var x) = gimme x 57 | eval2 (val n) = envyRet n 58 | eval2 (e +++ e') = 59 | eval2 e -envyThen- \ v -> 60 | eval2 e' -envyThen- \ v' -> 61 | envyRet (v + v') 62 | 63 | {- 64 | leaves : HExp -> List Nat 65 | leaves (val n) = n :> [] 66 | leaves (d +++ e) = {!leaves d ++ leaves e!} 67 | 68 | data HCode : Nat -> Nat -> Set where 69 | PUSH : {i : Nat} -> Nat -> HCode i (suc i) 70 | ADD : {i : Nat} -> HCode (suc (suc i)) (suc i) 71 | _-SEQ-_ : {i j k : Nat} -> HCode i j -> HCode j k -> HCode i k 72 | infixr 3 _-SEQ-_ 73 | 74 | data Vec (X : Set) : Nat -> Set where 75 | [] : Vec X zero 76 | _,_ : forall {n} -> X -> Vec X n -> Vec X (suc n) 77 | 78 | exec : {i j : Nat} -> HCode i j -> Vec Nat i -> Vec Nat j 79 | exec (PUSH x) s = x , s 80 | exec ADD (x , (y , s)) = (y + x) , s 81 | exec (h -SEQ- k) s = exec k (exec h s) 82 | 83 | exec' : (i j : Nat) -> HCode i j -> Vec Nat i -> Vec Nat j 84 | exec' i .(suc i) (PUSH x) s = x , s 85 | exec' .(suc (suc i)) .(suc i) (ADD {i}) s = {!!} 86 | exec' i j (c -SEQ- c₁) s = {!!} 87 | 88 | compile : HExp -> {i : Nat} -> HCode i (suc i) 89 | compile (val n) = PUSH n 90 | compile (d +++ e) = compile d -SEQ- compile e -SEQ- ADD 91 | -} 92 | -------------------------------------------------------------------------------- /Ex5/ANSIEscapes.hs: -------------------------------------------------------------------------------- 1 | module ANSIEscapes 2 | (upLine, 3 | downLine, 4 | up, 5 | down, 6 | forward, 7 | backward, 8 | killLine, 9 | restoreCursor, 10 | saveCursor, 11 | clearScreen, 12 | yellow, 13 | brown, 14 | red, 15 | blue, 16 | purple, 17 | green, 18 | orange, 19 | white, 20 | yellowOnGrey, 21 | brownOnGrey, 22 | redOnGrey, 23 | blueOnGrey, 24 | purpleOnGrey, 25 | greenOnGrey, 26 | whiteOnGrey, 27 | onBlack, 28 | onGrey, 29 | onGreyEsc, 30 | onWhiteEsc, 31 | resetCursor, 32 | initTermSize) where 33 | 34 | data Dir = UpDir | DownDir | RightDir | LeftDir 35 | 36 | instance Show Dir where 37 | show UpDir = "A" 38 | show DownDir = "B" 39 | show RightDir = "C" 40 | show LeftDir = "D" 41 | 42 | upLine = putStr "\ESC[1A" 43 | downLine = putStr "\ESC[1B" 44 | 45 | up = moveCursor UpDir 46 | down = moveCursor DownDir 47 | backward = moveCursor LeftDir 48 | forward = moveCursor RightDir 49 | 50 | moveCursor :: Dir -> Int -> IO () 51 | moveCursor dir 0 = return () 52 | moveCursor dir n = putStr $ "\ESC[" ++ show n ++ show dir 53 | 54 | killLine = escape "K" 55 | restoreCursor = escape "u" 56 | saveCursor = escape "s" 57 | clearScreen = escape "2J" 58 | initTermSize = (escape "[=3h") 59 | 60 | resetCursor = escape "0;0H" 61 | 62 | escape e = putStr $ "\ESC[" ++ e 63 | 64 | yellow str = "\ESC[1;33m" ++ str ++ "\ESC[0m" 65 | brown str = "\ESC[0;33m" ++ str ++ "\ESC[0m" 66 | blue str = "\ESC[1;34m" ++ str ++ "\ESC[0m" 67 | red str = "\ESC[1;31m" ++ str ++ "\ESC[0m" 68 | green str = "\ESC[1;32m" ++ str ++ "\ESC[0m" 69 | purple str = "\ESC[1;35m" ++ str ++ "\ESC[0m" 70 | white str = "\ESC[37m" ++ str ++ "\ESC[0m" 71 | 72 | 73 | 74 | --Be careful, these assume someone else will reset the background colour 75 | yellowOnGrey str = "\ESC[1;33m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 76 | brownOnGrey str = "\ESC[0;33m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 77 | blueOnGrey str = "\ESC[1;34m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 78 | redOnGrey str = "\ESC[1;31m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 79 | greenOnGrey str = "\ESC[1;32m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 80 | purpleOnGrey str = "\ESC[1;35m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 81 | whiteOnGrey str = "\ESC[37m" ++ str ++ "\ESC[0m" 82 | 83 | onBlack str = "\ESC[40m" ++ str ++ "\ESC[0m" 84 | onGrey str = onGreyEsc ++ str ++ onWhiteEsc 85 | onGreyEsc = "\ESC[47m" 86 | onWhiteEsc = "\ESC[0m" 87 | orange str = str -------------------------------------------------------------------------------- /NBE.agda: -------------------------------------------------------------------------------- 1 | module NBE where 2 | 3 | open import Ex1Prelude 4 | 5 | data Ty : Set where 6 | base : Ty 7 | _>>_ : Ty -> Ty -> Ty 8 | 9 | data Cx : Set where 10 | C0 : Cx 11 | _/_ : Cx -> Ty -> Cx 12 | infixl 4 _/_ 13 | 14 | infixl 3 _<:_ 15 | data _<:_ (T : Ty) : Cx -> Set where 16 | zero : {G : Cx} -> T <: G / T 17 | suc : {G : Cx}{S : Ty} -> T <: G -> T <: G / S 18 | 19 | data Term (G : Cx) : Ty -> Set where 20 | lam : {S T : Ty} -> 21 | Term (G / S) T -> Term G (S >> T) 22 | var : {S : Ty} -> S <: G -> Term G S 23 | _$_ : {S T : Ty} -> Term G (S >> T) -> 24 | Term G S -> Term G T 25 | 26 | data Form : Set where normal neutral : Form 27 | 28 | data Result (G : Cx) : Form -> Ty -> Set where 29 | lam : {S T : Ty} -> 30 | Result (G / S) normal T -> Result G normal (S >> T) 31 | [_] : {T : Ty} -> Result G neutral T -> Result G normal T 32 | var : {S : Ty} -> S <: G -> Result G neutral S 33 | _$_ : {S T : Ty} -> Result G neutral (S >> T) -> 34 | Result G normal S -> Result G neutral T 35 | 36 | Renaming : Cx -> Cx -> Set 37 | Renaming G G' = {T : Ty} -> T <: G -> T <: G' 38 | 39 | pushRen : {G G' : Cx}{S : Ty} -> 40 | Renaming G G' -> Renaming (G / S) (G' / S) 41 | pushRen r zero = zero 42 | pushRen r (suc x) = suc (r x) 43 | 44 | Semantics : Cx -> Ty -> Set 45 | Computing : Cx -> Ty -> Set 46 | Semantics G T = Result G neutral T /+/ Computing G T 47 | Computing G base = Zero 48 | Computing G (S >> T) = {G' : Cx} -> Renaming G G' -> 49 | Semantics G' S -> Semantics G' T 50 | 51 | wkRes : {G G' : Cx}{f : Form} -> Renaming G G' -> {T : Ty} -> 52 | Result G f T -> Result G' f T 53 | wkRes r (lam t) = lam (wkRes (pushRen r) t) 54 | wkRes r [ t ] = [ wkRes r t ] 55 | wkRes r (var x) = var (r x) 56 | wkRes r (f $ s) = wkRes r f $ wkRes r s 57 | 58 | wkSem : {G G' : Cx} -> Renaming G G' -> (T : Ty) -> 59 | Semantics G T -> Semantics G' T 60 | wkSem r T (inl e) = inl (wkRes r e) 61 | wkSem r base (inr ()) 62 | wkSem r (S >> T) (inr f) = inr \ r' -> f (r' o r) 63 | 64 | Env : Cx -> Cx -> Set 65 | Env G G' = {T : Ty} -> T <: G -> Semantics G' T 66 | 67 | wkEnv : {G0 G1 G2 : Cx} -> Renaming G1 G2 -> Env G0 G1 -> Env G0 G2 68 | wkEnv r g x = wkSem r _ (g x) 69 | 70 | _//_ : {G G' : Cx}{T : Ty} -> Env G G' -> Semantics G' T -> 71 | Env (G / T) G' 72 | _//_ g v zero = v 73 | _//_ g v (suc x) = g x 74 | 75 | _$$_ : {G : Cx}{S T : Ty} -> Semantics G (S >> T) -> 76 | Semantics G S -> Semantics G T 77 | stop : {G : Cx}(S : Ty) -> Semantics G S -> Result G normal S 78 | 79 | inl e $$ s = inl (e $ stop _ s) 80 | inr f $$ s = f id s 81 | 82 | stop base (inl e) = [ e ] 83 | stop base (inr ()) 84 | stop (S >> T) v = lam (stop T 85 | (wkSem suc (S >> T) v $$ inl (var zero))) 86 | 87 | semantics : {G G' : Cx}{T : Ty} -> 88 | ({T : Ty} -> T <: G -> Semantics G' T) -> 89 | Term G T -> Semantics G' T 90 | semantics g (lam t) = inr \ r s -> semantics (wkEnv r g // s) t 91 | semantics g (var x) = g x 92 | semantics g (f $ s) = semantics g f $$ semantics g s 93 | 94 | value : {G : Cx}{T : Ty} -> Term G T -> Result G normal T 95 | value {G}{T} t = stop T (semantics (inl o var) t) 96 | 97 | myTerm : Term (C0 / base) base 98 | myTerm = lam (var zero $ (var zero $ var (suc zero))) $ lam (var zero) 99 | -------------------------------------------------------------------------------- /CS410.lagda: -------------------------------------------------------------------------------- 1 | \documentclass{book} 2 | \usepackage{a4} 3 | \usepackage{palatino} 4 | \usepackage{natbib} 5 | \usepackage{amsfonts} 6 | \usepackage{stmaryrd} 7 | \usepackage{upgreek} 8 | \usepackage{url} 9 | 10 | 11 | \DeclareMathAlphabet{\mathkw}{OT1}{cmss}{bx}{n} 12 | 13 | \usepackage{color} 14 | \newcommand{\redFG}[1]{\textcolor[rgb]{0.6,0,0}{#1}} 15 | \newcommand{\greenFG}[1]{\textcolor[rgb]{0,0.4,0}{#1}} 16 | \newcommand{\blueFG}[1]{\textcolor[rgb]{0,0,0.8}{#1}} 17 | \newcommand{\orangeFG}[1]{\textcolor[rgb]{0.8,0.4,0}{#1}} 18 | \newcommand{\purpleFG}[1]{\textcolor[rgb]{0.4,0,0.4}{#1}} 19 | \newcommand{\yellowFG}[1]{\textcolor{yellow}{#1}} 20 | \newcommand{\brownFG}[1]{\textcolor[rgb]{0.5,0.2,0.2}{#1}} 21 | \newcommand{\blackFG}[1]{\textcolor[rgb]{0,0,0}{#1}} 22 | \newcommand{\whiteFG}[1]{\textcolor[rgb]{1,1,1}{#1}} 23 | \newcommand{\yellowBG}[1]{\colorbox[rgb]{1,1,0.2}{#1}} 24 | \newcommand{\brownBG}[1]{\colorbox[rgb]{1.0,0.7,0.4}{#1}} 25 | \newcommand{\greenBG}[1]{\colorbox[rgb]{0.7,1.0,0.7}{#1}} 26 | 27 | \newcommand{\ColourStuff}{ 28 | \newcommand{\red}{\redFG} 29 | \newcommand{\green}{\greenFG} 30 | \newcommand{\blue}{\blueFG} 31 | \newcommand{\orange}{\orangeFG} 32 | \newcommand{\purple}{\purpleFG} 33 | \newcommand{\yellow}{\yellowFG} 34 | \newcommand{\brown}{\brownFG} 35 | \newcommand{\black}{\blackFG} 36 | \newcommand{\white}{\whiteFG} 37 | } 38 | 39 | \newcommand{\MonochromeStuff}{ 40 | \newcommand{\red}{\blackFG} 41 | \newcommand{\green}{\blackFG} 42 | \newcommand{\blue}{\blackFG} 43 | \newcommand{\orange}{\blackFG} 44 | \newcommand{\purple}{\blackFG} 45 | \newcommand{\yellow}{\blackFG} 46 | \newcommand{\brown}{\blackFG} 47 | \newcommand{\black}{\blackFG} 48 | \newcommand{\white}{\blackFG} 49 | } 50 | 51 | \ColourStuff 52 | 53 | 54 | \newcommand{\M}[1]{\mathsf{#1}} 55 | \newcommand{\D}[1]{\blue{\mathsf{#1}}} 56 | \newcommand{\C}[1]{\red{\mathsf{#1}}} 57 | \newcommand{\F}[1]{\green{\mathsf{#1}}} 58 | \newcommand{\V}[1]{\purple{\mathit{#1}}} 59 | \newcommand{\T}[1]{\raisebox{0.02in}{\tiny\green{\textsc{#1}}}} 60 | 61 | \newcommand{\us}[1]{\_\!#1\!\_} 62 | 63 | %include lhs2TeX.fmt 64 | %include lhs2TeX.sty 65 | %include polycode.fmt 66 | 67 | %subst keyword a = "\mathkw{" a "}" 68 | %subst conid a = "\V{" a "}" 69 | %subst varid a = "\V{" a "}" 70 | 71 | %format -> = "\blue{\rightarrow}" 72 | 73 | \newcommand{\nudge}[1]{\marginpar{\footnotesize #1}} 74 | \newtheorem{exe}{Exercise}[chapter] 75 | 76 | %format rewrite = "\mathkw{rewrite}" 77 | %format constructor = "\mathkw{constructor}" 78 | 79 | %format ? = "\orange{?}" 80 | 81 | \parskip 0.1in 82 | \parindent 0in 83 | 84 | \begin{document} 85 | 86 | \title{CS410\\ 87 | Advanced Functional Programming} 88 | \author{Conor McBride \\ 89 | Mathematically Structured Programming Group \\ 90 | Department of Computer and Information Sciences \\ 91 | University of Strathclyde} 92 | \maketitle 93 | 94 | 95 | 96 | %include Introduction.lagda 97 | 98 | %include BasicPrelude.lagda 99 | 100 | %include Logic.lagda 101 | 102 | %include Razor.lagda 103 | 104 | 105 | \appendix 106 | %include EmacsCheatSheet.lagda 107 | 108 | \bibliographystyle{plainnat} 109 | \bibliography{CS410.bib} 110 | 111 | 112 | \end{document} 113 | -------------------------------------------------------------------------------- /CoInd.agda: -------------------------------------------------------------------------------- 1 | module CoInd where 2 | 3 | open import Ex1Prelude 4 | open import FuncKit 5 | open import IxCon 6 | 7 | postulate 8 | Delay : {a : _} -> Set a -> Set a 9 | delay : {a : _}{A : Set a} -> A -> Delay A 10 | force : {a : _}{A : Set a} -> Delay A -> A 11 | 12 | {-# BUILTIN INFINITY Delay #-} 13 | {-# BUILTIN SHARP delay #-} 14 | {-# BUILTIN FLAT force #-} 15 | 16 | data Stream (X : Set) : Set where 17 | _:>_ : X -> Delay (Stream X) -> Stream X 18 | 19 | repeat : {X : Set} -> X -> Stream X 20 | repeat x = x :> delay (repeat x) 21 | 22 | natsFrom : Nat -> Stream Nat 23 | natsFrom n = n :> delay (natsFrom (suc n)) 24 | 25 | takeUpto : {X : Set} -> (n : Nat) -> Stream X -> Vec X n 26 | takeUpto zero xs = [] 27 | takeUpto (suc n) (x :> xs) = x , takeUpto n (force xs) 28 | 29 | data Codata (k : Kit) : Set where 30 | [_] : kFun k (Delay (Codata k)) -> Codata k 31 | 32 | unfold : {k : Kit}{S : Set} -> 33 | (S -> kFun k S) -> 34 | S -> Codata k 35 | unfold {k}{S} f s = [ mapunfoldf k (f s) ] where 36 | mapunfoldf : (j : Kit) -> kFun j S -> kFun j (Delay (Codata k)) 37 | mapunfoldf (kK A) a = a 38 | mapunfoldf kId s' = delay (unfold f s') 39 | mapunfoldf (j k+ j') (inl x) = inl (mapunfoldf j x) 40 | mapunfoldf (j k+ j') (inr x) = inr (mapunfoldf j' x) 41 | mapunfoldf (j k* j') (x , y) = mapunfoldf j x , mapunfoldf j' y 42 | 43 | STREAM : Set -> Set 44 | STREAM X = Codata (kK X k* kId) 45 | 46 | REPEAT : {X : Set} -> X -> STREAM X 47 | REPEAT x = unfold (\ _ -> x , <>) <> 48 | 49 | NATSFROM : Nat -> STREAM Nat 50 | NATSFROM n = unfold (\ k -> k , suc k) n 51 | 52 | PERHAPS : Set -> Set 53 | PERHAPS X = Codata (kK X k+ kId) 54 | 55 | never : {X : Set} -> PERHAPS X 56 | never = unfold (\ s -> inr s) <> 57 | 58 | now : {X : Set} -> X -> PERHAPS X 59 | now x = unfold (\ s -> inl x) <> 60 | 61 | wait : {X : Set} -> PERHAPS X -> PERHAPS X 62 | wait p = [ inr (delay p) ] 63 | 64 | -- PERHAPS is a monad; its bind operator combines the delays in sequence 65 | -- at each step, we're either still working on getting the X, or 66 | -- we're trying to get the Y; 67 | -- we should ensure that the delay for the whole process is the sum of 68 | -- the delays for each part 69 | bind : {X Y : Set} -> PERHAPS X -> (X -> PERHAPS Y) -> PERHAPS Y 70 | bind {X}{Y} px x2py = unfold coalgebra (inl px) where 71 | workOnY : PERHAPS Y -> Y /+/ (PERHAPS X /+/ PERHAPS Y) 72 | workOnY [ inl y ] = inl y 73 | workOnY [ inr py ] = inr (inr (force py)) 74 | workOnX : PERHAPS X -> Y /+/ (PERHAPS X /+/ PERHAPS Y) 75 | workOnX [ inl x ] = workOnY (x2py x) 76 | workOnX [ inr px ] = inr (inl (force px)) 77 | coalgebra : (PERHAPS X /+/ PERHAPS Y) -> Y /+/ (PERHAPS X /+/ PERHAPS Y) 78 | coalgebra (inl px) = workOnX px 79 | coalgebra (inr py) = workOnY py 80 | 81 | myTest : PERHAPS Nat 82 | myTest = bind (wait (now 2)) \ x -> 83 | bind (wait (now 3)) \ y -> 84 | wait (now (x + y)) 85 | 86 | -- you can test PERHAPS processes with a "boredom threshold" 87 | -- saying how long you're willing to wait; you get either the 88 | -- answer, or a process which has evolved by the indicated 89 | -- number of steps 90 | 91 | runFor : {X : Set} -> Nat -> PERHAPS X -> X /+/ PERHAPS X 92 | runFor _ [ inl x ] = inl x 93 | runFor (suc n) [ inr px ] = runFor n (force px) 94 | runFor zero px = inr px 95 | 96 | {- 97 | data Game {I : Set}(C : I => I)(Win : I -> Set)(i : I) : Set where 98 | win : Win i -> Game C Win i 99 | <_> : FObj [[ C ]] (Game C Win) i -> Game C Win i 100 | -} 101 | 102 | data Oppo {I : Set}(C : I => I)(i : I) : Set where 103 | oppo : ((c : Command C i) -> 104 | Sigma (Response C i c) \ r -> 105 | Delay (Oppo C (next C i c r))) -> 106 | Oppo C i 107 | 108 | runGame : {I : Set}{C : I => I}{Win : I -> Set}{i : I} -> 109 | Game C Win i -> Oppo C i -> 110 | Sigma I \ i' -> Win i' /*/ Oppo C i' 111 | runGame {i = i'} (win x) o = i' , (x , o) 112 | runGame < c , k > (oppo f) with f c 113 | runGame < c , k > (oppo f) | r , o = runGame (k r) (force o) 114 | -------------------------------------------------------------------------------- /Ex5/HaskellSetup.hs: -------------------------------------------------------------------------------- 1 | module HaskellSetup where 2 | 3 | {- This is the low-level stuff that hooks into the ncurses library, together 4 | with the Haskell versions of the Agda types. You should not need to bother 5 | reading or modifying this file. -} 6 | 7 | import Debug.Trace 8 | import Foreign 9 | import Foreign.C (CInt(..)) 10 | import ANSIEscapes 11 | import System.IO 12 | import System.Environment 13 | import Control.Applicative 14 | import Control.Concurrent 15 | 16 | foreign import ccall 17 | initscr :: IO () 18 | 19 | foreign import ccall "endwin" 20 | endwin :: IO CInt 21 | 22 | foreign import ccall "refresh" 23 | refresh :: IO CInt 24 | 25 | foreign import ccall "&LINES" 26 | linesPtr :: Ptr CInt 27 | 28 | foreign import ccall "&COLS" 29 | colsPtr :: Ptr CInt 30 | 31 | scrSize :: IO (Int, Int) 32 | scrSize = do 33 | lnes <- peek linesPtr 34 | cols <- peek colsPtr 35 | return (fromIntegral cols, fromIntegral lnes) 36 | 37 | data Direction = DU | DD | DL | DR deriving Show 38 | data Modifier = Normal | Shift | Control deriving Show 39 | data Key = Char Char | Arrow Modifier Direction | Enter | Backspace | Delete | Escape deriving Show 40 | 41 | data Nat = Zero | Suc Nat 42 | toNat :: Int -> Nat 43 | toNat 0 = Zero 44 | toNat n = Suc (toNat (n - 1)) 45 | fromNat :: Nat -> Int 46 | fromNat Zero = 0 47 | fromNat (Suc n) = 1 + fromNat n 48 | 49 | data EQ a b c = Refl 50 | 51 | data Change = AllQuiet | CursorMove | LineEdit | BigChange 52 | 53 | data Action = GoRowCol Nat Nat | SendText [Char] 54 | 55 | act :: Action -> IO () 56 | act (GoRowCol y x) = do 57 | resetCursor 58 | forward (fromNat x) 59 | down (fromNat y) 60 | act (SendText s) = putStr s 61 | 62 | getEscapeKey :: [(String, Key)] -> IO (Maybe Key) 63 | getEscapeKey [] = return Nothing 64 | getEscapeKey sks = case lookup "" sks of 65 | Just k -> return (Just k) 66 | _ -> do 67 | c <- getChar 68 | getEscapeKey [(cs, k) | (d : cs, k) <- sks, d == c] 69 | 70 | directions :: [(Char, Direction)] 71 | directions = [('A', DU), ('B', DD), 72 | ('C', DR), ('D', DL)] 73 | 74 | escapeKeys :: [(String, Key)] 75 | escapeKeys = 76 | [([c], Arrow Normal d) | (c, d) <- directions] ++ 77 | [("1;2" ++ [c], Arrow Shift d) | (c, d) <- directions] ++ 78 | [("1;5" ++ [c], Arrow Control d) | (c, d) <- directions] ++ 79 | [("3~", Delete)] 80 | 81 | keyReady :: IO (Maybe Key) 82 | keyReady = do 83 | b <- hReady stdin 84 | if not b then return Nothing else do 85 | c <- getChar 86 | case c of 87 | '\n' -> return $ Just Enter 88 | '\r' -> return $ Just Enter 89 | '\b' -> return $ Just Backspace 90 | '\DEL' -> return $ Just Backspace 91 | _ | c >= ' ' -> return $ Just (Char c) 92 | '\ESC' -> do 93 | b <- hReady stdin 94 | if not b then return $ Just Escape else do 95 | c <- getChar 96 | case c of 97 | '[' -> getEscapeKey escapeKeys 98 | _ -> return $ Just Escape 99 | _ -> return $ Nothing 100 | 101 | pni :: (Int, Int) -> (Nat, Nat) 102 | pni (y, x) = (toNat y, toNat x) 103 | 104 | mainLoop :: 105 | ([[Char]] -> b) -> 106 | (Key -> b -> (Change, b)) -> 107 | ((Nat, Nat) -> (Nat, Nat) -> (Change, b) -> ([Action], (Nat, Nat))) -> 108 | IO () 109 | mainLoop initBuf keystroke render = do 110 | hSetBuffering stdout NoBuffering 111 | hSetBuffering stdin NoBuffering 112 | xs <- getArgs 113 | buf <- case xs of 114 | [] -> return (initBuf []) 115 | (x : _) -> (initBuf . lines) <$> readFile x 116 | initscr 117 | innerLoop (0, 0) (Zero, Zero) (BigChange, buf) 118 | endwin 119 | return () 120 | where 121 | innerLoop oldSize topLeft (c, b) = do 122 | refresh 123 | size <- scrSize 124 | (acts, topLeft) <- return $ 125 | if size /= oldSize 126 | then render (pni size) topLeft (BigChange, b) 127 | else render (pni size) topLeft (c, b) 128 | mapM_ act acts 129 | mc <- keyReady 130 | case mc of 131 | Nothing -> threadDelay 100 >> innerLoop size topLeft (AllQuiet, b) 132 | Just k -> innerLoop size topLeft (keystroke k b) 133 | -------------------------------------------------------------------------------- /Ex3.agda: -------------------------------------------------------------------------------- 1 | module Ex3 where 2 | 3 | open import Ex1Prelude 4 | open import FuncKit 5 | 6 | {- 3.1 Numbers in the Kit -} 7 | 8 | {- We can define the type of natural numbers using the tools 9 | from the functor kit like this: -} 10 | 11 | kNat : Kit 12 | kNat = kK One k+ kId 13 | 14 | NAT : Set 15 | NAT = Data kNat 16 | 17 | -- Define the function which sends "ordinary" numbers to 18 | -- the corresponding kit-encoded numbers. 19 | 20 | Nat2NAT : Nat -> NAT 21 | Nat2NAT n = {!!} 22 | 23 | -- Use fold to define the function which sends them back. 24 | 25 | NAT2Nat : NAT -> Nat 26 | NAT2Nat = fold (kK One k+ kId) {!!} 27 | 28 | -- Show that you get the "round trip" property (by writing 29 | -- recursive functions that use rewrite. 30 | 31 | Nat2NAT2Nat : NAT2Nat o Nat2NAT =^= id 32 | Nat2NAT2Nat n = {!!} 33 | 34 | NAT2Nat2NAT : Nat2NAT o NAT2Nat =^= id 35 | NAT2Nat2NAT n = {!!} 36 | 37 | 38 | {- 3.2 Lists in the Kit -} 39 | 40 | -- find the code which gives you lists with a given element 41 | -- type (note that the kId constructor marks the place for 42 | -- recursive *sublists* not for list elements 43 | 44 | kLIST : Set -> Kit 45 | kLIST A = {!!} 46 | 47 | LIST : Set -> Set 48 | LIST A = Data (kLIST A) 49 | 50 | -- define nil and cons for your lists 51 | 52 | nil : {A : Set} -> LIST A 53 | nil = {!!} 54 | 55 | cons : {A : Set} -> A -> LIST A -> LIST A 56 | cons a as = {!!} 57 | 58 | -- use fold to define concatenation 59 | 60 | conc : {A : Set} -> LIST A -> LIST A -> LIST A 61 | conc {A} xs ys = fold (kLIST A) {!!} xs 62 | 63 | -- prove the following (the yellow bits should disappear when 64 | -- you define kLIST); 65 | -- maddeningly, "rewrite" won't do it, but this piece of kit 66 | -- (which is like a manual version of rewrite) will do it 67 | 68 | cong : {S T : Set}(f : S -> T){a b : S} -> a == b -> f a == f b 69 | cong f refl = refl 70 | 71 | concNil : {A : Set}(as : LIST A) -> conc as nil == as 72 | concNil as = {!!} 73 | 74 | concAssoc : {A : Set}(as bs cs : LIST A) -> 75 | conc (conc as bs) cs == conc as (conc bs cs) 76 | concAssoc as bs cs = {!!} 77 | 78 | 79 | {- 3.3 Trees in the Kit -} 80 | 81 | -- give a kit code for binary trees with unlabelled leaves 82 | -- and nodes labelled with elements of NAT 83 | 84 | kTREE : Kit 85 | kTREE = {!!} 86 | 87 | TREE : Set 88 | TREE = Data kTREE 89 | 90 | -- give the constructors 91 | 92 | leaf : TREE 93 | leaf = {!!} 94 | 95 | node : TREE -> NAT -> TREE -> TREE 96 | node l n r = {!!} 97 | 98 | -- implement flattening (slow flattening is ok) as a fold 99 | 100 | flatten : TREE -> LIST NAT 101 | flatten = fold kTREE {!!} 102 | 103 | 104 | {- 3.4 "rec" from "fold" -} 105 | 106 | -- The recursor is a variation on the theme of fold, but you 107 | -- get a wee bit more information at each step. In particular, 108 | -- in each recursive position, you get the original substructure 109 | -- *as well as* the value that is computed from it. 110 | 111 | rec : (k : Kit){X : Set} -> 112 | 113 | (kFun k (Data k /*/ X) -> X) -> 114 | -- ^^^^^^ ^ 115 | -- substructure value 116 | 117 | Data k -> X 118 | 119 | -- Demonstrate that rec is no more powerful than fold by constructing 120 | -- rec from fold. The trouble is that fold throws away the original 121 | -- substructures. But you can compensate by computing something extra 122 | -- as well as the value you actually want. 123 | 124 | rec k {X} f d = outr (fold k {{!!} /*/ X} {!!} d) 125 | 126 | 127 | -- use rec to implement "insList", being the function which inserts 128 | -- a number in a list, such that if the input list is in increasing 129 | -- order, so is the output list; you may assume that "lessEq" exists 130 | 131 | lessEq : NAT -> NAT -> Two 132 | 133 | insList : NAT -> LIST NAT -> LIST NAT 134 | insList n = rec (kLIST NAT) {!!} 135 | 136 | -- justify the assumption by defining "lessEq"; do not use explicit 137 | -- recursion; 138 | -- note that the thing we build for each number is its less-or-equal 139 | -- test; 140 | -- do use "rec kNat" once more to take numbers apart 141 | 142 | lessEq x y = rec kNat {NAT -> Two} {!!} x y 143 | 144 | -- implement insertion for binary search trees using "rec" 145 | 146 | insTree : NAT -> TREE -> TREE 147 | insTree n = rec kTREE {!!} 148 | -------------------------------------------------------------------------------- /EmacsCheatSheet.lagda: -------------------------------------------------------------------------------- 1 | \chapter{Agda Mode Cheat Sheet} 2 | 3 | I use standard emacs keystroke descriptions. E.g., `C-c' means control-c. 4 | I delimit keystrokes with square brackets, but don't type the brackets or the 5 | spaces between the individual key descriptions. 6 | 7 | 8 | \section{Managing the buffer} 9 | 10 | \subsection*{[C-c C-l] load buffer} 11 | 12 | This keystroke tells Agda to resynchronize with the buffer contents, typechecking 13 | everything. It will also make sure everything is displayed in the correct colour. 14 | 15 | \subsection*{[C-c C-x C-d] deactivate goals} 16 | 17 | This keystroke deactivates Agda's goal machinery. 18 | 19 | \subsection*{[C-c C-x C-r] restart Agda} 20 | 21 | This keystroke restarts Agda. 22 | 23 | \section{Working in a goal} 24 | 25 | The following apply only when the cursor is sitting inside the braces of a goal. 26 | 27 | \subsection*{[C-c C-,] what's going on?} 28 | 29 | If you select a goal and type this keystroke, the information buffer 30 | will tell you the type of the goal and the types of everything in the 31 | context. Some things in the context are not in scope, because you 32 | haven't bound them with a name anywhere. These show up with names 33 | Agda chooses, beginning with a dot: you cannot refer to these things, 34 | but they do exist. 35 | 36 | \subsection*{[C-c C-.] more on what's going on?} 37 | 38 | This is a variant of the above which in addition also shows you the type 39 | of the expression currently typed into the hole. This is useful for 40 | trying different constructions out before giving/refining them! 41 | 42 | \subsection*{[C-c C-spc] give expression} 43 | 44 | If you think you know which expression belongs in a goal, type the expression 45 | between its braces, then use this keystroke. The expression can include |?| 46 | symbols, which become subgoals. 47 | 48 | \subsection*{[C-c C-c] case split} 49 | 50 | If your goal is immediately to the right of |=|, then you're still building your 51 | program's decision tree, so you can ask for a case analysis. Type the name of 52 | a variable in the goal, then make this keystroke. Agda will try to split that 53 | variable into its possible constructor patterns. Amusingly, if you type several 54 | variables names and ask for a case analysis, you will get all the possible 55 | combinations from splitting each of the variables. 56 | 57 | \subsection*{[C-c C-r] refine} 58 | 59 | If there's only one constructor which fits in the hole, Agda deploys 60 | it. If there's a choice, Agda tells you the options. 61 | 62 | \subsection*{[C-c C-a] ask Agsy (a.k.a. I feel lucky)} 63 | 64 | If you make this keystroke, Agda will use a search mechanism called 65 | `Agsy' to try and guess something with the right type. Agsy may not 66 | succeed. Even if it does, the guess may not be the right answer. 67 | Sometimes, however, there's obviously only one sensible thing to do, 68 | and then Agsy is your bezzy mate! It can be an incentive to make your 69 | types precise! 70 | 71 | 72 | \section{Checking and Testing things} 73 | 74 | \subsection*{[C-c C-d] deduce type of expression} 75 | 76 | If you type this keystroke, you will be prompted for an expression. If 77 | the expression you supply makes sense, you will be told its type. 78 | 79 | If you are working in a goal and have typed an expression already, Agda will 80 | assume that you want the type of that expression. 81 | 82 | \subsection*{[C-c C-n] normalize expression} 83 | 84 | If you type this keystroke, you will be prompted for an expression. If 85 | the expression you supply makes sense, you will be told its value. 86 | 87 | If you are working in a goal and have typed an expression already, Agda will 88 | assume that you want to normalize (i.e. compute as far as possible) 89 | that expression. The normal form might not be a value, because there 90 | might be some variables in your expression, getting in the way of 91 | computation. When there are no free variables present, the normal form 92 | is sure to be a value. 93 | 94 | \section{Moving around} 95 | 96 | \subsection*{[C-c C-f]/[C-c C-b] move to next/previous goal} 97 | 98 | A quick way to get to where the action is to use these two keystrokes, 99 | which takes you to the next and previous goal respectively. 100 | 101 | \subsection*{[M-.] go to definition} 102 | 103 | If you find yourself wondering what the definition of some identifier 104 | is, then you can put the cursor at it and use this keystroke -- it will 105 | make Agda take you there. 106 | -------------------------------------------------------------------------------- /Ex6/ViewDemo.agda: -------------------------------------------------------------------------------- 1 | module ViewDemo where 2 | 3 | open import Ex6-Setup 4 | 5 | -- This file gives an example of the "view" method, which allows us to write 6 | -- testing operations which actually generate evidence about the things being 7 | -- tested, and in a very visual way. You get to develop more powerful ways of 8 | -- seeing. 9 | 10 | -- I recommend commenting out the example code, then redeveloping it 11 | -- interactively, which will give you a much more animated experience of 12 | -- what is going on. 13 | 14 | map : {S T : Set} -> (S -> T) -> List S -> List T 15 | map f [] = [] 16 | map f (s :: ss) = f s :: map f ss 17 | 18 | -- Note, +-+ is concatenation for lists, here, to leave ++ for vectors. 19 | 20 | -- trying to find out whether a list of choices all chooses inr 21 | 22 | allRight : {S T : Set} -> List (S /+/ T) -> One /+/ List T 23 | allRight [] = inr [] -- trivially all right 24 | allRight (inl s :: xs) = inl <> -- busted! 25 | -- Now the interesting case: 26 | {- 27 | allRight (inr t :: xs) = {!!} 28 | -} 29 | -- We need to know the situation about xs, so here's what to do 30 | -- before the = sign, do a bit of typing to get 31 | {- 32 | allRight (inr t :: xs) with allRight xs 33 | ... | r = ? 34 | -} 35 | -- What does that mean? It means we want to be able to see everything 36 | -- we had before on the left-hand side, but also the result of the 37 | -- recursive call. The next line looks like 38 | -- | = ? 39 | -- but we're allowed to write "..." when, left of |, nothing has changed 40 | -- from the line containing "with". The "r" is just a freshly named 41 | -- pattern variable. Now reload the file, and it's 42 | {- 43 | allRight (inr t :: xs) with allRight xs 44 | ... | r = {!!} 45 | -} 46 | -- Next, do case analysis on r! The "..." expands and you see the whole 47 | -- picture. 48 | allRight (inr t :: xs) with allRight xs 49 | allRight (inr t :: xs) | inl <> = inl <> 50 | allRight (inr t :: xs) | inr ts = inr (t :: ts) 51 | 52 | -- Here's a more informative way to write the same test. Instead of 53 | -- returning some bits and pieces which we *hope* tell us something 54 | -- about the input, we *demand* to know what the input looks like 55 | 56 | -- We introduce a list-dependent type which describes the possible things 57 | -- that list can be. There is one constructor for each possibility. 58 | -- Think of (AllRightable xs) as the type of "knowing whether xs is all 59 | -- right". We know if we can tell these two cases apart. 60 | -- This technique is known as declaring a "view" of some data. 61 | data AllRightable {S T : Set} : List (S /+/ T) -> Set where 62 | -- is it made from a bunch of ts, all wrapped with inr? 63 | isAllRight : (ts : List T) -> AllRightable (map inr ts) 64 | -- or does it have some ts, then a first s, then some more stuff? 65 | hasFirstLeft : (ts : List T)(s : S)(xs : List (S /+/ T)) -> 66 | AllRightable (map inr ts +-+ inl s :: xs) 67 | 68 | -- Next, show that we can always know. That is, we establish that we can 69 | -- see the data according to the declared "view". 70 | -- You write the program with exactly the same case analysis and "with" 71 | -- steps as the above, but when you come to fill in the return values, 72 | -- just use C-c C-a. There is no choice: the type is an exact specification 73 | -- of the analysis, so you can't lie and say you found an s that wasn't 74 | -- there. But there's something else. 75 | allRightable : {S T : Set}(xs : List (S /+/ T)) -> AllRightable xs 76 | allRightable [] = isAllRight [] 77 | allRightable (inl s :: xs) = hasFirstLeft [] s xs 78 | allRightable (inr t :: xs) with allRightable xs 79 | -- As before we start from this after "with" 80 | {- 81 | ... | r = {!!} 82 | -} 83 | -- but when we do a case split on r, something wonderful happens! 84 | -- In each case, we see the list for what it really is. 85 | allRightable (inr t :: .(map inr ts)) | isAllRight ts 86 | = isAllRight (t :: ts) 87 | -- In your face, it's all on the right. 88 | 89 | allRightable (inr t :: .(map inr ts +-+ inl s :: xs)) | hasFirstLeft ts s xs 90 | = hasFirstLeft (t :: ts) s xs 91 | -- In your face, it has a leftmost inl s. 92 | 93 | -- Patterns which start with . are a new thing. Normally, when you write a 94 | -- pattern, you are *asking* what is present. When you write (or rather, 95 | -- when you get Agda to write) a .-pattern, you are *telling* what is present. 96 | -- Operationally, a .-pattern means "don't bother looking at that because we 97 | -- already know what it is". They exist for code comprehension purposes, 98 | -- to show you exactly what you've got in your hand. 99 | -------------------------------------------------------------------------------- /Ex6/README.md: -------------------------------------------------------------------------------- 1 | # Exercise 6 2 | 3 | I thought I should provide an overview of both the content and the 4 | procedure. But first, strategic thinkers will need to know the 5 | **deadline**, which was 23:59.59 on Monday 25 May 2015. **DEADLINE 6 | EXTENSION:** you now have until 5pm on Wednesday 27 May 2015. That is, 7 | I am giving you as much time as I can, still leaving enough of a 8 | window to mark your stuff (not in your presence, this time) before the 9 | deadline which will be imposed on me to return your scores to the exam 10 | board. (That deadline turned out to be later than I had anticipated, 11 | so I'm passing the benefit on to you.) You're playing for the last 25 12 | of the 100 available marks. 13 | 14 | **Request.** If you think you're done with exercise 6 before the 15 | deadline, please let me know. It will significantly reduce my stress 16 | levels if I can mark as much of your work as early as possible. Note 17 | that I will still accept revised submissions up to the deadline (and 18 | git will let me know that I need to look again). I'm afraid I can't 19 | release scores early, but you'll more or less be able to tell what 20 | your solutions are worth, anyway. 21 | 22 | 23 | ## What's it about? 24 | 25 | The incremental release of this exercise rather obscures the big 26 | picture, so let me try to sketch it. What you're writing is a simple 27 | window manager, with overlapping windows. It'll be text-based and run 28 | inside a shell window, just like the editor in exercise 5. At the end 29 | of the day, you should have two windows with different stuff happening 30 | in them: you should be able to switch focus between them, move them 31 | and resize them. 32 | 33 | 34 | ## How does that break down? 35 | 36 | It's a five episode story, hopefully not with cliffhangers. 37 | 38 | 1. **Vectors** where you learn the basics of working with lists whose 39 | size is policed by types. We'll be using vectors of vectors 40 | (matrices) to manage rectangular blocks of text. 41 | 42 | 2. **Boxes** where you learn to work with rectangular tilings built up 43 | from basic components by putting things the same height side by 44 | side or arranging two things the same width vertically. 45 | 46 | 3. **Cutting** where you learn to cut tilings as required, and to 47 | overlay one tiling in front of another, seeing stuff at the back 48 | through the holes in the front: the key technology for overlapping 49 | windows. 50 | 51 | 4. **Display** where you learn to construct tilings of display 52 | updates, and to send them to the screen. Of course, updates which 53 | happen out of view should result in no action. Here, we'll start to 54 | compile executables built from the pieces and control content from 55 | the keyboard. 56 | 57 | ![Episode 4 going](Ex6-4-Going.png) 58 | 59 | 5. **Applications** where you learn to build interactive systems which 60 | get keystrokes and give updates, then hang them in a framework 61 | which supports *two* of them in separate windows, cooperatively. 62 | 63 | Edit: we're ahead of the game; episode 4 already has two windows! 64 | 65 | 66 | ## Mac Users 67 | 68 | Don't use a regular terminal for this, as shift-up and shift-down 69 | aren't handled properly. Give [iterm2](http://iterm2.com/) a go 70 | instead. I'm grateful to Dan Piponi for this valuable clue. 71 | 72 | 73 | ## Support 74 | 75 | We have two lecture slots booked for Tuesdays at 2pm in LT209. We 76 | should probably use both for orientation: week 11 for episodes 1 to 3; 77 | week 12 for episodes 4 and 5. 78 | 79 | If you are in need of clarification about the intended meaning of 80 | things I've written, please use the myplace forum: others probably 81 | need the same help. If you have questions about *your code*, please 82 | contact me privately. 83 | 84 | I am willing to offer lab help if a bunch of you think that would be 85 | useful, or one-on-one advice by appointment. Don't stay unproductively 86 | stuck. I won't be out of town much, but I mightn't be in my office 87 | much, so showing up at LT1317 unexpected is not the best strategy (but 88 | I won't object if you try your luck). My currently scheduled 89 | disappearances are as follows: 7 May is election day, when I vote (you 90 | should, too) then sleep until polls close and it's time to spend all 91 | night throwing things at the telly; 8 May is the day after election 92 | day, when it will probably hurt; 12 May sees a meeting in Dundee about 93 | Type Inference. 94 | 95 | Support each other. Learn together; code separately. By all means talk 96 | about the difficulties you get into, the better to gain understanding, 97 | but make sure your code comes from your understanding, not from 98 | somebody else's code. 99 | -------------------------------------------------------------------------------- /FuncKit.agda: -------------------------------------------------------------------------------- 1 | module FuncKit where 2 | 3 | open import Ex1Prelude 4 | 5 | _=^=_ : {S T : Set}(f g : S -> T) -> Set 6 | f =^= g = (s : _) -> f s == g s 7 | infixl 2 _=^=_ 8 | 9 | map : {S T : Set} -> (S -> T) -> (List S -> List T) 10 | map f [] = [] 11 | map f (s :> ss) = f s :> map f ss 12 | 13 | mapId : {S : Set} -> map (id {S}) =^= id {List S} 14 | mapId [] = refl 15 | mapId (x :> ss) rewrite mapId ss = refl 16 | 17 | mapComp : {R S T : Set}(f : S -> T)(g : R -> S) -> 18 | map f o map g =^= map (f o g) 19 | mapComp f g [] = refl 20 | mapComp f g (x :> ss) rewrite mapComp f g ss = refl 21 | 22 | _>=_ : Nat -> Nat -> Set 23 | m >= zero = One 24 | zero >= suc n = Zero 25 | suc m >= suc n = m >= n 26 | 27 | geRefl : (n : Nat) -> n >= n 28 | geRefl zero = <> 29 | geRefl (suc x) = geRefl x 30 | 31 | geTrans : (l m n : Nat) -> m >= n -> l >= m -> l >= n 32 | geTrans l zero zero mn lm = <> 33 | geTrans zero zero (suc x) mn lm = mn 34 | geTrans (suc x) zero (suc zero) mn lm = <> 35 | geTrans (suc x) zero (suc (suc x₁)) mn lm = geTrans x zero (suc x₁) mn <> 36 | geTrans l (suc x) zero mn lm = <> 37 | geTrans zero (suc x) (suc x₁) mn lm = lm 38 | geTrans (suc x) (suc x₁) (suc x₂) mn lm = geTrans x x₁ x₂ mn lm 39 | 40 | 41 | data Vec (X : Set) : Nat -> Set where 42 | [] : Vec X zero 43 | _,_ : forall {n} -> X -> Vec X n -> Vec X (suc n) 44 | 45 | take : {X : Set}(m n : Nat) -> m >= n -> (Vec X m -> Vec X n) 46 | take m zero mn xs = [] 47 | take .0 (suc n) () [] 48 | take ._ (suc n) mn (x , xs) = x , take _ n mn xs 49 | 50 | From : Set -> Set -> Set 51 | From A X = A -> X 52 | fromMap : {A S T : Set} -> (S -> T) -> ((From A) S -> (From A) T) 53 | fromMap f g = f o g 54 | 55 | {- 56 | To : Set -> Set -> Set 57 | To B X = X -> B 58 | toMap : {B S T : Set} -> (S -> T) -> ((To B) S -> (To B) T) 59 | toMap {B}{S}{T} f g = {!!} 60 | -} 61 | 62 | NotNot : Set -> Set 63 | NotNot X = (X -> Zero) -> Zero 64 | 65 | nnMap : {S T : Set} -> (S -> T) -> (NotNot S -> NotNot T) 66 | nnMap f nns = \ nt -> nns (\ s -> nt (f s)) 67 | 68 | good : Zero -> One 69 | good () 70 | {- 71 | bad : One -> Zero 72 | bad = toMap good id 73 | -} 74 | 75 | Id : Set -> Set 76 | Id X = X 77 | idMap : {S T : Set} -> (S -> T) -> (Id S -> Id T) 78 | idMap {S}{T} = id 79 | 80 | Product : (F G : Set -> Set) -> Set -> Set 81 | Product F G X = F X /*/ G X 82 | prodMap : {F G : Set -> Set} -> 83 | ({S T : Set} -> (S -> T) -> (F S -> F T)) -> 84 | ({S T : Set} -> (S -> T) -> (G S -> G T)) -> 85 | ({S T : Set} -> (S -> T) -> ((Product F G) S -> (Product F G) T)) 86 | prodMap fmap gmap h (fs , gs) = fmap h fs , gmap h gs 87 | 88 | ex1 : Product Id Id Nat 89 | ex1 = 6 , 7 90 | 91 | ex2 : Product Id Id Two 92 | ex2 = prodMap idMap idMap (\ n -> n <= 6) ex1 93 | 94 | Sum : (F G : Set -> Set) -> Set -> Set 95 | Sum F G X = F X /+/ G X 96 | sumMap : {F G : Set -> Set} -> 97 | ({S T : Set} -> (S -> T) -> (F S -> F T)) -> 98 | ({S T : Set} -> (S -> T) -> (G S -> G T)) -> 99 | ({S T : Set} -> (S -> T) -> ((Sum F G) S -> (Sum F G) T)) 100 | sumMap fmap gmap h (inl fs) = inl (fmap h fs) 101 | sumMap fmap gmap h (inr gs) = inr (gmap h gs) 102 | 103 | ex3 : Sum (Product Id Id) Id Two 104 | ex3 = inl (tt , ff) 105 | 106 | K : Set -> Set -> Set 107 | K A X = A 108 | 109 | kMap : {A S T : Set} -> (S -> T) -> (K A S -> K A T) 110 | kMap f a = a 111 | 112 | Mystery : Set -> Set 113 | Mystery = Sum (K One) Id 114 | 115 | mystery : Mystery Two 116 | mystery = inl <> 117 | 118 | data Kit : Set1 where 119 | kK : Set -> Kit 120 | kId : Kit 121 | _k+_ : Kit -> Kit -> Kit 122 | _k*_ : Kit -> Kit -> Kit 123 | 124 | kFun : Kit -> (Set -> Set) 125 | kFun (kK A) X = A 126 | kFun kId X = X 127 | kFun (f k+ g) X = kFun f X /+/ kFun g X 128 | kFun (f k* g) X = kFun f X /*/ kFun g X 129 | 130 | kitMap : (k : Kit){S T : Set} -> (S -> T) -> (kFun k) S -> (kFun k) T 131 | kitMap (kK A) h a = a 132 | kitMap kId h s = h s 133 | kitMap (f k+ g) h (inl fs) = inl (kitMap f h fs) 134 | kitMap (f k+ g) h (inr gs) = inr (kitMap g h gs) 135 | kitMap (f k* g) h (fs , gs) = kitMap f h fs , kitMap g h gs 136 | 137 | data Data (k : Kit) : Set where 138 | [_] : (kFun k) (Data k) -> Data k 139 | 140 | fold : (k : Kit){X : Set} -> (kFun k X -> X) -> Data k -> X 141 | fold k {X} f [ kd ] = -- f (kitMap k (fold k f) kd) 142 | f (kitMapFold k kd) where 143 | kitMapFold : (j : Kit) -> kFun j (Data k) -> kFun j X 144 | kitMapFold (kK A) a = a 145 | kitMapFold kId s = fold k f s 146 | kitMapFold (f k+ g) (inl fs) = inl (kitMapFold f fs) 147 | kitMapFold (f k+ g) (inr gs) = inr (kitMapFold g gs) 148 | kitMapFold (f k* g) (fs , gs) = kitMapFold f fs , kitMapFold g gs 149 | 150 | -------------------------------------------------------------------------------- /Ex6/HaskellSetup.hs: -------------------------------------------------------------------------------- 1 | module HaskellSetup where 2 | 3 | {- This is the low-level stuff that hooks into the ncurses library, together 4 | with the Haskell versions of the Agda types. You should not need to bother 5 | reading or modifying this file. -} 6 | 7 | import Debug.Trace 8 | import Foreign 9 | import Foreign.C (CInt(..)) 10 | import ANSIEscapes 11 | import System.IO 12 | import System.Environment 13 | import Control.Applicative 14 | import Control.Concurrent 15 | 16 | foreign import ccall 17 | initscr :: IO () 18 | 19 | foreign import ccall "endwin" 20 | endwin :: IO CInt 21 | 22 | foreign import ccall "refresh" 23 | refresh :: IO CInt 24 | 25 | foreign import ccall "&LINES" 26 | linesPtr :: Ptr CInt 27 | 28 | foreign import ccall "&COLS" 29 | colsPtr :: Ptr CInt 30 | 31 | scrSize :: IO (Int, Int) 32 | scrSize = do 33 | lnes <- peek linesPtr 34 | cols <- peek colsPtr 35 | return (fromIntegral cols, fromIntegral lnes) 36 | 37 | data Modifier = Normal | Shift | Control deriving Show 38 | data Key = Char Char | Arrow Modifier Direction | Enter | Backspace | Delete | Escape | Tab deriving Show 39 | data Event = Key Key | Resize Nat Nat 40 | 41 | data Nat = Zero | Suc Nat 42 | toNat :: Int -> Nat 43 | toNat 0 = Zero 44 | toNat n = Suc (toNat (n - 1)) 45 | fromNat :: Nat -> Int 46 | fromNat Zero = 0 47 | fromNat (Suc n) = 1 + fromNat n 48 | 49 | data Colour 50 | = Black | Red | Green | Yellow 51 | | Blue | Magenta | Cyan | White 52 | 53 | data Action 54 | = GoRowCol Nat Nat 55 | | SendText [Char] 56 | | Move Direction Nat 57 | | FgText Colour 58 | | BgText Colour 59 | 60 | act :: Action -> IO () 61 | act (GoRowCol y x) = do 62 | resetCursor 63 | forward (fromNat x) 64 | down (fromNat y) 65 | act (SendText s) = putStr s 66 | act (Move d n) = moveCursor d (fromNat n) 67 | act (FgText Black) = escape "0;30m" 68 | act (FgText Red) = escape "1;31m" 69 | act (FgText Green) = escape "1;32m" 70 | act (FgText Yellow) = escape "1;33m" 71 | act (FgText Blue) = escape "1;34m" 72 | act (FgText Magenta) = escape "1;35m" 73 | act (FgText Cyan) = escape "1;36m" 74 | act (FgText White) = escape "1;37m" 75 | act (BgText Black) = escape "40m" 76 | act (BgText Red) = escape "41m" 77 | act (BgText Green) = escape "42m" 78 | act (BgText Yellow) = escape "43m" 79 | act (BgText Blue) = escape "44m" 80 | act (BgText Magenta) = escape "45m" 81 | act (BgText Cyan) = escape "46m" 82 | act (BgText White) = escape "47m" 83 | 84 | getEscapeKey :: [(String, Key)] -> IO (Maybe Key) 85 | getEscapeKey [] = return Nothing 86 | getEscapeKey sks = case lookup "" sks of 87 | Just k -> return (Just k) 88 | _ -> do 89 | c <- getChar 90 | getEscapeKey [(cs, k) | (d : cs, k) <- sks, d == c] 91 | 92 | directions :: [(Char, Direction)] 93 | directions = [('A', DU), ('B', DD), 94 | ('C', DR), ('D', DL)] 95 | 96 | escapeKeys :: [(String, Key)] 97 | escapeKeys = 98 | [([c], Arrow Normal d) | (c, d) <- directions] ++ 99 | [("1;2" ++ [c], Arrow Shift d) | (c, d) <- directions] ++ 100 | [("1;5" ++ [c], Arrow Control d) | (c, d) <- directions] ++ 101 | [("3~", Delete)] 102 | 103 | keyReady :: IO (Maybe Key) 104 | keyReady = do 105 | b <- hReady stdin 106 | if not b then return Nothing else do 107 | c <- getChar 108 | case c of 109 | '\n' -> return $ Just Enter 110 | '\r' -> return $ Just Enter 111 | '\b' -> return $ Just Backspace 112 | '\DEL' -> return $ Just Backspace 113 | '\t' -> return $ Just Tab 114 | _ | c >= ' ' -> return $ Just (Char c) 115 | '\ESC' -> do 116 | b <- hReady stdin 117 | if not b then return $ Just Escape else do 118 | c <- getChar 119 | case c of 120 | '[' -> getEscapeKey escapeKeys 121 | _ -> return $ Just Escape 122 | _ -> return $ Nothing 123 | 124 | pni :: (Int, Int) -> (Nat, Nat) 125 | pni (y, x) = (toNat y, toNat x) 126 | 127 | mainLoop :: 128 | s -> (Event -> s -> (s, [Action])) -> 129 | IO () 130 | mainLoop start reactor = do 131 | hSetBuffering stdout NoBuffering 132 | hSetBuffering stdin NoBuffering 133 | initscr 134 | innerLoop (0, 0) start 135 | endwin 136 | return () 137 | where 138 | innerLoop oldSize state0 = do 139 | refresh 140 | size@(w, h) <- scrSize 141 | let (state1, acts) = if size /= oldSize 142 | then reactor (Resize (toNat w) (toNat h)) state0 143 | else (state0, []) 144 | mapM_ act acts 145 | mc <- keyReady 146 | case mc of 147 | Nothing -> threadDelay 100 >> innerLoop size state1 148 | Just k -> do 149 | let (state2, acts) = reactor (Key k) state1 150 | mapM_ act acts 151 | innerLoop size state2 152 | -------------------------------------------------------------------------------- /Ex6/Ex6-1-Vec.agda: -------------------------------------------------------------------------------- 1 | module Ex6-1-Vec where 2 | 3 | open import Ex6-Setup 4 | 5 | 6 | --------------------------------------------------------------------------- 7 | -- VECTORS (5 marks) -- 8 | --------------------------------------------------------------------------- 9 | 10 | -- We've touched on them before, when we needed to manage the height of a 11 | -- stack, but here are the "vectors", or "lists of known length. 12 | 13 | data Vec (X : Set) : Nat -> Set where 14 | [] : Vec X zero 15 | _::_ : {n : Nat} -> X -> Vec X n -> Vec X (suc n) 16 | infixr 6 _::_ 17 | 18 | -- This chunk of exercise 6 is about building the basic equipment to work 19 | -- with vectors. We'll need this equipment later. 20 | 21 | 22 | --------------------------------------------------------------------------- 23 | -- CONCATENATION AND ITS INVERSE -- 24 | --------------------------------------------------------------------------- 25 | 26 | infixr 6 _++_ 27 | 28 | -- Implement concatenation for any two vectors. 29 | -- You will need to say how long the result will be. 30 | -- (1 mark) 31 | 32 | _++_ : {X : Set}{m n : Nat} -> Vec X m -> Vec X n -> Vec X {!!} 33 | xs ++ ys = {!!} 34 | 35 | -- Now, we could write "take" and "drop", but it's more useful to 36 | -- prove that every long vector can be given by concatenating two 37 | -- short vectors. 38 | 39 | data Chop {X : Set}(m : Nat){n : Nat} : Vec X {!!} -> Set where 40 | is++ : (xs : Vec X m)(ys : Vec X n) -> Chop m (xs ++ ys) 41 | 42 | -- A "Chop" for a given vector consists of the evidence that it can 43 | -- be made by concatenation. You will need to fill in the Chop length, 44 | -- above, the same way you filled in the length for _++_. 45 | 46 | -- Show that you can compute a Chop for any vector. 47 | -- Hint: you will need to use "with" at some point. 48 | -- (1 mark) 49 | 50 | chop : {X : Set}(m : Nat){n : Nat}(xs : Vec X {!!}) -> Chop m xs 51 | chop m xs = {!!} 52 | 53 | -- Where take and drop give you vectors which you *hope* are the prefix 54 | -- and suffix of the input. Chop gives you the pieces which are seen to 55 | -- be the prefix and suffix of the input. Once you have chop, it's easy 56 | -- to write take and drop in terms of it, and you can see they're right. 57 | -- Try uncommenting and finishing the following (for fun). 58 | 59 | {- 60 | take : {X : Set}(m : Nat){n : Nat}(xs : Vec X {!!}) -> Vec X m 61 | take m xs with chop m xs 62 | take m .(xs ++ ys) | is++ xs ys = xs 63 | -} 64 | 65 | -- EXTRA! For no marks, but some utility in future, check that you can 66 | -- use chop to define the function which just gives you the pair of the 67 | -- prefix and the suffix. 68 | 69 | vchop : {X : Set}(m : Nat){n : Nat} -> 70 | Vec X {!!} -> Vec X m /*/ Vec X n 71 | vchop x xs = {!!} 72 | 73 | 74 | --------------------------------------------------------------------------- 75 | -- APPLICATIVE STRUCTURE -- 76 | --------------------------------------------------------------------------- 77 | 78 | -- Implement the function which makes a vector from a single element by 79 | -- copying it the relevant number of times. Implement the "vectorized 80 | -- application" operator which takes n functions and n arguments and gives 81 | -- you the n results: the jth result should be given by applying the jth 82 | -- function to the jth argument. 83 | -- (1 mark) 84 | 85 | vec : {n : Nat}{X : Set}(x : X) -> Vec X n 86 | vec x = {!!} 87 | 88 | _<*>_ : {n : Nat}{S T : Set} -> Vec (S -> T) n -> Vec S n -> Vec T n 89 | fs <*> ss = {!!} 90 | infixl 2 _<*>_ 91 | 92 | -- The applicative structure is very useful for working with vectors in 93 | -- bulk. For example, I can take the successor of every number in a vector 94 | -- by applying a vector of successor-functions to the vector of numbers. 95 | 96 | mySucs : Vec Nat 5 97 | mySucs = vec suc <*> (0 :: 1 :: 2 :: 3 :: 4 :: []) 98 | -- should evaluate to 1 :: 2 :: 3 :: 4 :: 5 :: [] 99 | 100 | -- Now, using vec and <*> rather than explicit case analysis and recursion, 101 | -- implement vector zipping as a one-liner, turning a pair of vectors into a 102 | -- vector of pairs. 103 | -- (1 mark) 104 | 105 | zip : {n : Nat}{X Y : Set} -> Vec X n -> Vec Y n -> Vec (X /*/ Y) n 106 | zip xs ys = {!!} 107 | 108 | -- Play the same game as we did for concatenation, take and drop. Show 109 | -- that every vector of pairs can be made by zipping two vectors. 110 | -- (1 mark) 111 | 112 | data Unzip {n : Nat}{X Y : Set} : Vec (X /*/ Y) n -> Set where 113 | -- what goes here? 114 | 115 | unzip : {n : Nat}{X Y : Set}(xys : Vec (X /*/ Y) n) -> Unzip xys 116 | unzip xys = {!!} 117 | 118 | -- EXTRA! For no marks, but some utility in future, check that you can 119 | -- use unzip to define the function which just gives you the pair of the 120 | -- two vectors. 121 | 122 | vunzip : {X Y : Set}{n : Nat} -> Vec (X /*/ Y) n -> Vec X n /*/ Vec Y n 123 | vunzip xys = {!!} 124 | -------------------------------------------------------------------------------- /Ex6/Ex6-1-Vec-Dummy.agda: -------------------------------------------------------------------------------- 1 | module Ex6-1-Vec-Dummy where 2 | 3 | open import Ex6-Setup 4 | 5 | --------------------------------------------------------------------------- 6 | -- This is the dummy version of episode 1, which you can use to access -- 7 | -- episode 2 early, if you must, just by importing this instead. -- 8 | --------------------------------------------------------------------------- 9 | 10 | postulate SHUT_IT : {X : Set} -> X 11 | 12 | --------------------------------------------------------------------------- 13 | -- VECTORS (5 marks) -- 14 | --------------------------------------------------------------------------- 15 | 16 | -- We've touched on them before, when we needed to manage the height of a 17 | -- stack, but here are the "vectors", or "lists of known length. 18 | 19 | data Vec (X : Set) : Nat -> Set where 20 | [] : Vec X zero 21 | _::_ : {n : Nat} -> X -> Vec X n -> Vec X (suc n) 22 | infixr 6 _::_ 23 | 24 | -- This chunk of exercise 6 is about building the basic equipment to work 25 | -- with vectors. We'll need this equipment later. 26 | 27 | 28 | --------------------------------------------------------------------------- 29 | -- CONCATENATION AND ITS INVERSE -- 30 | --------------------------------------------------------------------------- 31 | 32 | infixr 6 _++_ 33 | 34 | -- Implement concatenation for any two vectors. 35 | -- You will need to say how long the result will be. 36 | -- (1 mark) 37 | 38 | _++_ : {X : Set}{m n : Nat} -> Vec X m -> Vec X n -> Vec X SHUT_IT 39 | xs ++ ys = SHUT_IT 40 | 41 | -- Now, we could write "take" and "drop", but it's more useful to 42 | -- prove that every long vector can be given by concatenating two 43 | -- short vectors. 44 | 45 | data Chop {X : Set}(m : Nat){n : Nat} : Vec X SHUT_IT -> Set where 46 | is++ : (xs : Vec X m)(ys : Vec X n) -> Chop m (xs ++ ys) 47 | 48 | -- A "Chop" for a given vector consists of the evidence that it can 49 | -- be made by concatenation. You will need to fill in the Chop length, 50 | -- above, the same way you filled in the length for _++_. 51 | 52 | -- Show that you can compute a Chop for any vector. 53 | -- Hint: you will need to use "with" at some point. 54 | -- (1 mark) 55 | 56 | chop : {X : Set}(m : Nat){n : Nat}(xs : Vec X SHUT_IT) -> Chop m {SHUT_IT} xs 57 | chop m xs = SHUT_IT 58 | 59 | -- Where take and drop give you vectors which you *hope* are the prefix 60 | -- and suffix of the input. Chop gives you the pieces which are seen to 61 | -- be the prefix and suffix of the input. Once you have chop, it's easy 62 | -- to write take and drop in terms of it, and you can see they're right. 63 | -- Try uncommenting and finishing the following (for fun). 64 | 65 | {- 66 | take : {X : Set}(m : Nat){n : Nat}(xs : Vec X {!!}) -> Vec X m 67 | take m xs with chop m xs 68 | take m .(xs ++ ys) | is++ xs ys = xs 69 | -} 70 | 71 | -- EXTRA! For no marks, but some utility in future, check that you can 72 | -- use chop to define the function which just gives you the pair of the 73 | -- prefix and the suffix. 74 | 75 | vchop : {X : Set}(m : Nat){n : Nat} -> 76 | Vec X SHUT_IT -> Vec X m /*/ Vec X n 77 | vchop x xs = SHUT_IT 78 | 79 | 80 | --------------------------------------------------------------------------- 81 | -- APPLICATIVE STRUCTURE -- 82 | --------------------------------------------------------------------------- 83 | 84 | -- Implement the function which makes a vector from a single element by 85 | -- copying it the relevant number of times. Implement the "vectorized 86 | -- application" operator which takes n functions and n arguments and gives 87 | -- you the n results: the jth result should be given by applying the jth 88 | -- function to the jth argument. 89 | -- (1 mark) 90 | 91 | vec : {n : Nat}{X : Set}(x : X) -> Vec X n 92 | vec x = SHUT_IT 93 | 94 | _<*>_ : {n : Nat}{S T : Set} -> Vec (S -> T) n -> Vec S n -> Vec T n 95 | fs <*> ss = SHUT_IT 96 | infixl 2 _<*>_ 97 | 98 | -- The applicative structure is very useful for working with vectors in 99 | -- bulk. For example, I can take the successor of every number in a vector 100 | -- by applying a vector of successor-functions to the vector of numbers. 101 | 102 | mySucs : Vec Nat 5 103 | mySucs = vec suc <*> (0 :: 1 :: 2 :: 3 :: 4 :: []) 104 | -- should evaluate to 1 :: 2 :: 3 :: 4 :: 5 :: [] 105 | 106 | -- Now, using vec and <*> rather than explicit case analysis and recursion, 107 | -- implement vector zipping as a one-liner, turning a pair of vectors into a 108 | -- vector of pairs. 109 | -- (1 mark) 110 | 111 | zip : {n : Nat}{X Y : Set} -> Vec X n -> Vec Y n -> Vec (X /*/ Y) n 112 | zip xs ys = SHUT_IT 113 | 114 | -- Play the same game as we did for concatenation, take and drop. Show 115 | -- that every vector of pairs can be made by zipping two vectors. 116 | -- (1 mark) 117 | 118 | data Unzip {n : Nat}{X Y : Set} : Vec (X /*/ Y) n -> Set where 119 | -- what goes here? 120 | 121 | unzip : {n : Nat}{X Y : Set}(xys : Vec (X /*/ Y) n) -> Unzip xys 122 | unzip xys = SHUT_IT 123 | 124 | -- EXTRA! For no marks, but some utility in future, check that you can 125 | -- use unzip to define the function which just gives you the pair of the 126 | -- two vectors. 127 | 128 | vunzip : {X Y : Set}{n : Nat} -> Vec (X /*/ Y) n -> Vec X n /*/ Vec Y n 129 | vunzip xys = SHUT_IT 130 | -------------------------------------------------------------------------------- /Ex6/Ex6-1-Vec-Sol.agda: -------------------------------------------------------------------------------- 1 | module Ex6-1-Vec-Sol where 2 | 3 | open import Ex6-Setup 4 | 5 | 6 | --------------------------------------------------------------------------- 7 | -- VECTORS (5 marks) -- 8 | --------------------------------------------------------------------------- 9 | 10 | -- We've touched on them before, when we needed to manage the height of a 11 | -- stack, but here are the "vectors", or "lists of known length. 12 | 13 | data Vec (X : Set) : Nat -> Set where 14 | [] : Vec X zero 15 | _::_ : {n : Nat} -> X -> Vec X n -> Vec X (suc n) 16 | infixr 6 _::_ 17 | 18 | -- This chunk of exercise 6 is about building the basic equipment to work 19 | -- with vectors. We'll need this equipment later. 20 | 21 | 22 | --------------------------------------------------------------------------- 23 | -- CONCATENATION AND ITS INVERSE -- 24 | --------------------------------------------------------------------------- 25 | 26 | infixr 6 _++_ 27 | 28 | -- Implement concatenation for any two vectors. 29 | -- You will need to say how long the result will be. 30 | -- (1 mark) 31 | 32 | _++_ : {X : Set}{m n : Nat} -> Vec X m -> Vec X n -> Vec X (m + n) 33 | [] ++ ys = ys 34 | (x :: xs) ++ ys = x :: xs ++ ys 35 | -- Now, we could write "take" and "drop", but it's more useful to 36 | -- prove that every long vector can be given by concatenating two 37 | -- short vectors. 38 | 39 | data Chop {X : Set}(m : Nat){n : Nat} : Vec X (m + n) -> Set where 40 | is++ : (xs : Vec X m)(ys : Vec X n) -> Chop m (xs ++ ys) 41 | 42 | -- A "Chop" for a given vector consists of the evidence that it can 43 | -- be made by concatenation. You will need to fill in the Chop length, 44 | -- above, the same way you filled in the length for _++_. 45 | 46 | -- Show that you can compute a Chop for any vector. 47 | -- Hint: you will need to use "with" at some point. 48 | -- (1 mark) 49 | 50 | chop : {X : Set}(m : Nat){n : Nat}(xs : Vec X (m + n)) -> Chop m xs 51 | chop zero xs = is++ [] xs 52 | chop (suc m) (x :: xs) with chop m xs 53 | chop (suc m) (x :: .(xs ++ ys)) | is++ xs ys = is++ (x :: xs) ys 54 | 55 | -- Where take and drop give you vectors which you *hope* are the prefix 56 | -- and suffix of the input. Chop gives you the pieces which are seen to 57 | -- be the prefix and suffix of the input. Once you have chop, it's easy 58 | -- to write take and drop in terms of it, and you can see they're right. 59 | -- Try uncommenting and finishing the following (for fun). 60 | 61 | take : {X : Set}(m : Nat){n : Nat}(xs : Vec X (m + n)) -> Vec X m 62 | take m xs with chop m xs 63 | take m .(xs ++ ys) | is++ xs ys = xs 64 | 65 | -- EXTRA! For no marks, but some utility in future, check that you can 66 | -- use chop to define the function which just gives you the pair of the 67 | -- prefix and the suffix. 68 | 69 | vchop : {X : Set}(m : Nat){n : Nat} -> 70 | Vec X (m + n) -> Vec X m /*/ Vec X n 71 | vchop m xs with chop m xs 72 | vchop m .(xs ++ ys) | is++ xs ys = xs , ys 73 | 74 | 75 | --------------------------------------------------------------------------- 76 | -- APPLICATIVE STRUCTURE -- 77 | --------------------------------------------------------------------------- 78 | 79 | -- Implement the function which makes a vector from a single element by 80 | -- copying it the relevant number of times. Implement the "vectorized 81 | -- application" operator which takes n functions and n arguments and gives 82 | -- you the n results: the jth result should be given by applying the jth 83 | -- function to the jth argument. 84 | -- (1 mark) 85 | 86 | vec : {n : Nat}{X : Set}(x : X) -> Vec X n 87 | vec {zero} x = [] 88 | vec {suc n} x = x :: vec x 89 | 90 | _<*>_ : {n : Nat}{S T : Set} -> Vec (S -> T) n -> Vec S n -> Vec T n 91 | [] <*> [] = [] 92 | f :: fs <*> s :: ss = f s :: (fs <*> ss) 93 | infixl 2 _<*>_ 94 | 95 | -- The applicative structure is very useful for working with vectors in 96 | -- bulk. For example, I can take the successor of every number in a vector 97 | -- by applying a vector of successor-functions to the vector of numbers. 98 | 99 | mySucs : Vec Nat 5 100 | mySucs = vec suc <*> (0 :: 1 :: 2 :: 3 :: 4 :: []) 101 | -- should evaluate to 1 :: 2 :: 3 :: 4 :: 5 :: [] 102 | 103 | -- Now, using vec and <*> rather than explicit case analysis and recursion, 104 | -- implement vector zipping as a one-liner, turning a pair of vectors into a 105 | -- vector of pairs. 106 | -- (1 mark) 107 | 108 | zip : {n : Nat}{X Y : Set} -> Vec X n -> Vec Y n -> Vec (X /*/ Y) n 109 | zip xs ys = vec _,_ <*> xs <*> ys 110 | 111 | -- Play the same game as we did for concatenation, take and drop. Show 112 | -- that every vector of pairs can be made by zipping two vectors. 113 | -- (1 mark) 114 | 115 | data Unzip {n : Nat}{X Y : Set} : Vec (X /*/ Y) n -> Set where 116 | isZip : (xs : Vec X n)(ys : Vec Y n) -> Unzip (zip xs ys) 117 | 118 | unzip : {n : Nat}{X Y : Set}(xys : Vec (X /*/ Y) n) -> Unzip xys 119 | unzip [] = isZip [] [] 120 | unzip ((x , y) :: xys) with unzip xys 121 | unzip ((x , y) :: .(zip xs ys)) | isZip xs ys = isZip (x :: xs) (y :: ys) 122 | 123 | -- EXTRA! For no marks, but some utility in future, check that you can 124 | -- use unzip to define the function which just gives you the pair of the 125 | -- two vectors. 126 | 127 | vunzip : {X Y : Set}{n : Nat} -> Vec (X /*/ Y) n -> Vec X n /*/ Vec Y n 128 | vunzip xys with unzip xys 129 | vunzip .(vec _,_ <*> xs <*> ys) | isZip xs ys = xs , ys 130 | -------------------------------------------------------------------------------- /Ex3Sol.agda: -------------------------------------------------------------------------------- 1 | module Ex3Sol where 2 | 3 | {- Mark Scheme 4 | 3.1 is work 3; 3.2 is worth 4; 3.3 is worth 3; 3.4 is worth 5 5 | The total number of marks available is 15. 6 | See below for individual mark breakdown. 7 | -} 8 | 9 | open import Ex1Prelude 10 | open import FuncKit 11 | 12 | {- 3.1 Numbers in the Kit (3 marks) -} 13 | 14 | {- We can define the type of natural numbers using the tools 15 | from the functor kit like this: -} 16 | 17 | kNat : Kit 18 | kNat = kK One k+ kId 19 | 20 | NAT : Set 21 | NAT = Data kNat 22 | 23 | -- Define the function which sends "ordinary" numbers to 24 | -- the corresponding kit-encoded numbers. (1 mark) 25 | 26 | Nat2NAT : Nat -> NAT 27 | Nat2NAT zero = [ inl <> ] 28 | Nat2NAT (suc n) = [ inr (Nat2NAT n) ] 29 | 30 | -- Use fold to define the function which sends them back. (1 mark) 31 | 32 | NAT2Nat : NAT -> Nat 33 | NAT2Nat = fold (kK One k+ kId) (\ 34 | { (inl <>) -> zero 35 | ; (inr NAT2Nat_n) -> suc NAT2Nat_n 36 | }) 37 | 38 | -- Show that you get the "round trip" property (by writing 39 | -- recursive functions that use rewrite. (1 mark) 40 | 41 | Nat2NAT2Nat : NAT2Nat o Nat2NAT =^= id 42 | Nat2NAT2Nat zero = refl 43 | Nat2NAT2Nat (suc n) rewrite Nat2NAT2Nat n = refl 44 | 45 | NAT2Nat2NAT : Nat2NAT o NAT2Nat =^= id 46 | NAT2Nat2NAT [ inl <> ] = refl 47 | NAT2Nat2NAT [ inr x ] rewrite NAT2Nat2NAT x = refl 48 | 49 | 50 | {- 3.2 Lists in the Kit (4 marks) -} 51 | 52 | -- find the code which gives you lists with a given element 53 | -- type (note that the kId constructor marks the place for 54 | -- recursive *sublists* not for list elements (1 mark) 55 | 56 | kLIST : Set -> Kit 57 | kLIST A = kK One k+ (kK A k* kId) 58 | 59 | LIST : Set -> Set 60 | LIST A = Data (kLIST A) 61 | 62 | -- define nil and cons for your lists (1 mark) 63 | 64 | nil : {A : Set} -> LIST A 65 | nil = [ inl <> ] 66 | 67 | cons : {A : Set} -> A -> LIST A -> LIST A 68 | cons a as = [ inr (a , as) ] 69 | 70 | -- use fold to define concatenation (1 mark) 71 | 72 | conc : {A : Set} -> LIST A -> LIST A -> LIST A 73 | conc {A} xs ys = fold (kLIST A) 74 | (\ { (inl <>) -> ys 75 | ; (inr (a , conc_as_ys)) -> cons a conc_as_ys 76 | }) 77 | xs 78 | 79 | -- prove the following (the yellow bits should disappear when 80 | -- you define kLIST); (1 mark) 81 | -- maddeningly, "rewrite" won't do it, but this piece of kit 82 | -- (which is like a manual version of rewrite) will do it 83 | 84 | cong : {S T : Set}(f : S -> T){a b : S} -> a == b -> f a == f b 85 | cong f refl = refl 86 | 87 | concNil : {A : Set}(as : LIST A) -> conc as nil == as 88 | concNil [ inl <> ] = refl 89 | concNil [ inr (a , as) ] = cong (cons a) (concNil as) 90 | 91 | concAssoc : {A : Set}(as bs cs : LIST A) -> 92 | conc (conc as bs) cs == conc as (conc bs cs) 93 | concAssoc [ inl <> ] bs cs = refl 94 | concAssoc [ inr (a , as) ] bs cs = cong (cons a) (concAssoc as bs cs) 95 | 96 | 97 | {- 3.3 Trees in the Kit (3 marks) -} 98 | 99 | -- give a kit code for binary trees with unlabelled leaves 100 | -- and nodes labelled with elements of NAT (1 mark) 101 | 102 | kTREE : Kit 103 | kTREE = kK One k+ (kId k* (kK NAT k* kId)) 104 | 105 | TREE : Set 106 | TREE = Data kTREE 107 | 108 | -- give the constructors (1 mark) 109 | 110 | leaf : TREE 111 | leaf = [ inl <> ] 112 | 113 | node : TREE -> NAT -> TREE -> TREE 114 | node l n r = [ inr (l , n , r) ] 115 | 116 | -- implement flattening (slow flattening is ok) as a fold (1 mark) 117 | 118 | flatten : TREE -> LIST NAT 119 | flatten = fold kTREE (\ 120 | { (inl <>) -> nil 121 | ; (inr (flatten_l , n , flatten_r)) -> conc flatten_l (cons n flatten_r) 122 | }) 123 | 124 | 125 | {- 3.4 "rec" from "fold" (5 marks) -} 126 | 127 | -- The recursor is a variation on the theme of fold, but you 128 | -- get a wee bit more information at each step. In particular, 129 | -- in each recursive position, you get the original substructure 130 | -- *as well as* the value that is computed from it. 131 | 132 | rec : (k : Kit){X : Set} -> 133 | 134 | (kFun k (Data k /*/ X) -> X) -> 135 | -- ^^^^^^ ^ 136 | -- substructure value 137 | 138 | Data k -> X 139 | 140 | -- Demonstrate that rec is no more powerful than fold by constructing 141 | -- rec from fold. The trouble is that fold throws away the original 142 | -- substructures. But you can compensate by computing something extra 143 | -- as well as the value you actually want. (1 mark) 144 | 145 | rec k {X} f d = outr (fold k {Data k /*/ X} 146 | (\ kdx -> [ kitMap k outl kdx ] , f kdx) d) 147 | 148 | 149 | -- use rec to implement "insList", being the function which inserts 150 | -- a number in a list, such that if the input list is in increasing 151 | -- order, so is the output list; you may assume that "lessEq" exists (1 mark) 152 | 153 | lessEq : NAT -> NAT -> Two 154 | 155 | insList : NAT -> LIST NAT -> LIST NAT 156 | insList n = rec (kLIST NAT) (\ 157 | { (inl <>) -> cons n nil 158 | ; (inr (a , (as , insList_n_as))) -> 159 | if lessEq n a 160 | then cons n (cons a as) 161 | else cons a insList_n_as 162 | }) 163 | 164 | -- justify the assumption by defining "lessEq"; do not use explicit 165 | -- recursion; do use "rec kNat" once more to take numbers apart 166 | -- (2 marks, one for each "rec") 167 | 168 | lessEq x y = rec kNat {NAT -> Two} 169 | (\ { (inl <>) -> \ y -> {- lessEq zero y -} tt 170 | ; (inr (x , lessEq_x)) -> rec kNat (\ 171 | { (inl <>) -> {- lessEq (suc x) zero -} ff 172 | ; (inr (y , lessEq_[suc_x]_y)) -> {- lessEq (suc x) (suc y) -} lessEq_x y 173 | }) 174 | }) 175 | x y 176 | 177 | -- implement insertion for binary search trees using "rec" (1 mark) 178 | 179 | insTree : NAT -> TREE -> TREE 180 | insTree n = rec kTREE (\ 181 | { (inl <>) -> node leaf n leaf 182 | ; (inr ((l , insTree_n_l) , y , (r , insTree_n_r))) -> 183 | if lessEq n y then node insTree_n_l y r else node l y insTree_n_r 184 | }) 185 | -------------------------------------------------------------------------------- /Ex1.agda: -------------------------------------------------------------------------------- 1 | module Ex1 where 2 | 3 | open import Ex1Prelude 4 | 5 | {----------------------------------------------------------------------------} 6 | {- Name: -} 7 | {----------------------------------------------------------------------------} 8 | 9 | {----------------------------------------------------------------------------} 10 | {- DEADLINE: Week 3 Monday 13 October 23:59 (preferably by BitBucket) -} 11 | {----------------------------------------------------------------------------} 12 | 13 | {----------------------------------------------------------------------------- 14 | TOP TIP: if you have annoyingly many open goals, comment out big chunks of the 15 | file with a multi-line comment a bit like this one. 16 | -----------------------------------------------------------------------------} 17 | 18 | 19 | {----------------------------------------------------------------------------} 20 | {- 1.1: Tree Sort -} 21 | {----------------------------------------------------------------------------} 22 | 23 | -- 1.1.1 implement concatenation for lists 24 | 25 | _++_ : {X : Set} -> List X -> List X -> List X 26 | xs ++ ys = {!!} 27 | 28 | infixr 3 _++_ 29 | 30 | -- a datatype of node-labelled binary trees is given as follows 31 | 32 | data Tree (X : Set) : Set where 33 | leaf : Tree X 34 | _<[_]>_ : Tree X -> X -> Tree X -> Tree X 35 | 36 | {- 37 | data Tree x = Leaf | Node (Tree X) X (Tree X) 38 | Leaf :: Tree x 39 | Node :: Tree x -> x -> Tree x -> Tree x 40 | -} 41 | 42 | demoTree : Tree Nat 43 | demoTree = ({!!} <[ 3 ]> {!!}) <[ 5 ]> {!!} 44 | 45 | -- 1.1.2 implement the insertion of a number into a tree, ensuring that 46 | -- the numbers in the tree are in increasing order from left to right; 47 | -- make sure to retain duplicates 48 | 49 | insertTree : Nat -> Tree Nat -> Tree Nat 50 | insertTree x t = {!!} 51 | 52 | -- 1.1.3 implement the function which takes the elements of a list and 53 | -- builds an ordered tree from them, using insertTree 54 | 55 | makeTree : List Nat -> Tree Nat 56 | makeTree xs = {!!} 57 | 58 | -- 1.1.4 implement the function which flattens a tree to a list, 59 | -- using concatenation 60 | 61 | flatten : {X : Set} -> Tree X -> List X 62 | flatten t = {!!} 63 | 64 | -- 1.1.5 using the above components, implement a sorting algorithm which 65 | -- works by building a tree and then flattening it 66 | 67 | treeSort : List Nat -> List Nat 68 | treeSort = {!!} 69 | 70 | -- 1.1.6 give a collection of unit tests which cover every program line 71 | -- from 1.1.1 to 1.1.5 72 | 73 | -- 1.1.7 implement a fast version of flatten, taking an accumulating parameter, 74 | -- never using ++. and ensuring that the law 75 | -- 76 | -- fastFlatten t xs == flatten t ++ xs 77 | -- 78 | -- is true; for an extra style point, ensure that the accumulating parameter 79 | -- is never given a name in your program 80 | 81 | fastFlatten : {X : Set} -> Tree X -> List X -> List X 82 | fastFlatten t = {!!} 83 | 84 | -- 1.1.8 use fastFlatten to build a fast version of tree sort 85 | 86 | fastTreeSort : List Nat -> List Nat 87 | fastTreeSort xs = {!!} 88 | 89 | -- 1.1.9 again, give unit tests which cover every line of code 90 | 91 | 92 | 93 | {----------------------------------------------------------------------------} 94 | {- 1.2: Shooting Propositional Logic Fish In A Barrel -} 95 | {----------------------------------------------------------------------------} 96 | 97 | -- 1.2.1 implement the following operations; try to use only 98 | -- [C-c C-c] and [C-c C-a] 99 | 100 | orCommute : {A B : Set} -> A /+/ B -> B /+/ A 101 | orCommute x = {!!} 102 | 103 | orAbsorbL : {A : Set} -> Zero /+/ A -> A 104 | orAbsorbL x = {!!} 105 | 106 | orAbsorbR : {A : Set} -> A /+/ Zero -> A 107 | orAbsorbR x = {!!} 108 | 109 | orAssocR : {A B C : Set} -> (A /+/ B) /+/ C -> A /+/ (B /+/ C) 110 | orAssocR x = {!!} 111 | 112 | orAssocL : {A B C : Set} -> A /+/ (B /+/ C) -> (A /+/ B) /+/ C 113 | orAssocL x = {!!} 114 | 115 | -- 1.2.2 implement the following operations; try to use only 116 | -- [C-c C-c] and [C-c C-a] 117 | 118 | andCommute : {A B : Set} -> A /*/ B -> B /*/ A 119 | andCommute x = {!!} 120 | 121 | andAbsorbL : {A : Set} -> A -> One /*/ A 122 | andAbsorbL x = {!!} 123 | 124 | andAbsorbR : {A : Set} -> A -> A /*/ One 125 | andAbsorbR x = {!!} 126 | 127 | andAssocR : {A B C : Set} -> (A /*/ B) /*/ C -> A /*/ (B /*/ C) 128 | andAssocR x = {!!} 129 | 130 | andAssocL : {A B C : Set} -> A /*/ (B /*/ C) -> (A /*/ B) /*/ C 131 | andAssocL x = {!!} 132 | 133 | -- how many times is [C-c C-c] really needed? 134 | 135 | -- 1.2.3 implement the following operations; try to use only 136 | -- [C-c C-c] and [C-c C-a] 137 | 138 | distribute : {A B C : Set} -> A /*/ (B /+/ C) -> (A /*/ B) /+/ (A /*/ C) 139 | distribute x = {!!} 140 | 141 | factor : {A B C : Set} -> (A /*/ B) /+/ (A /*/ C) -> A /*/ (B /+/ C) 142 | factor x = {!!} 143 | 144 | 145 | -- 1.2.4 try to implement the following operations; try to use only 146 | -- [C-c C-c] and [C-c C-a]; at least one of them will prove to be 147 | -- impossible, in which case you should comment it out and explain 148 | -- why it's impossible 149 | 150 | Not : Set -> Set 151 | Not X = X -> Zero 152 | 153 | deMorgan1 : {A B : Set} -> (Not A /+/ Not B) -> Not (A /*/ B) 154 | deMorgan1 x y = {!!} 155 | 156 | deMorgan2 : {A B : Set} -> Not (A /*/ B) -> (Not A /+/ Not B) 157 | deMorgan2 x = {!!} 158 | 159 | deMorgan3 : {A B : Set} -> (Not A /*/ Not B) -> Not (A /+/ B) 160 | deMorgan3 x y = {!!} 161 | 162 | deMorgan4 : {A B : Set} -> Not (A /+/ B) -> (Not A /*/ Not B) 163 | deMorgan4 x = {!!} 164 | 165 | 166 | -- 1.2.5 try to implement the following operations; try to use only 167 | -- [C-c C-c] and [C-c C-a]; at least one of them will prove to be 168 | -- impossible, in which case you should comment it out and explain 169 | -- why it's impossible 170 | 171 | dnegI : {X : Set} -> X -> Not (Not X) 172 | dnegI = {!!} 173 | 174 | dnegE : {X : Set} -> Not (Not X) -> X 175 | dnegE = {!!} 176 | 177 | neg321 : {X : Set} -> Not (Not (Not X)) -> Not X 178 | neg321 = {!!} 179 | 180 | hamlet : {B : Set} -> B /+/ Not B 181 | hamlet = {!!} 182 | 183 | nnHamlet : {B : Set} -> Not (Not (B /+/ Not B)) 184 | nnHamlet = {!!} 185 | -------------------------------------------------------------------------------- /Ex2.agda: -------------------------------------------------------------------------------- 1 | module Ex2 where 2 | 3 | {----------------------------------------------------------------------------- 4 | Name: 5 | -----------------------------------------------------------------------------} 6 | 7 | {----------------------------------------------------------------------------- 8 | CS410 Exercise 2, due 5pm on Monday of Week 6 (3 November 2014) 9 | NOTE: I am well aware that week 6 is quite busy with deadlines, 10 | what with CS408-related obligations and so on. I'd much prefer 11 | you did things to the best of your ability rather than on time, 12 | so I would be sympathetic to requests for some flexibility. 13 | Still, your best bet is to make an early start rather than a 14 | late finish. 15 | -----------------------------------------------------------------------------} 16 | 17 | {----------------------------------------------------------------------------- 18 | This exercise is based around extending Hutton's razor with Boolean 19 | values and conditional expressions. By introducing a second value 20 | type, we acquire the risk of type mismatch. The idea here is to 21 | explore different approaches to managing that risk. 22 | -----------------------------------------------------------------------------} 23 | 24 | open import Ex1Prelude 25 | open import Ex2Prelude 26 | 27 | {- The extended Hutton's Razor syntax -} 28 | 29 | data HExpIf : Set where 30 | num : Nat -> HExpIf 31 | boo : Two -> HExpIf 32 | _+++_ : HExpIf -> HExpIf -> HExpIf 33 | hif_then_else_ : HExpIf -> HExpIf -> HExpIf -> HExpIf 34 | 35 | {- Note that an expression 36 | 37 | hif eb then ex1 else ex2 38 | 39 | makes sense only when 40 | * eb produces a Boolean value 41 | * ex1 and ex2 produce the same sort of value (numeric or Boolean) 42 | -} 43 | 44 | HValIf : Set 45 | HValIf = Two /+/ Nat 46 | 47 | {- We now have the risk of run time type errors. Let's introduce a type 48 | for things which can go wrong. -} 49 | 50 | data Error (E X : Set) : Set where 51 | ok : X -> Error E X 52 | error : E -> Error E X 53 | 54 | {- 2.1 Add a constructor to the following datatype for each different 55 | kind of run time error that can happen. (Come back to this exercise 56 | when you're writing the evaluator in 2.3.) Make these error reports 57 | as informative as you can. 58 | -} 59 | 60 | data EvalError : Set where 61 | -- your constructors here 62 | 63 | {- 2.2 Write a little piece of "glue code" to make it easier to manage 64 | errors. The idea is to combine error-prone process in *sequence*, where 65 | the second process can depend on the value produced by the first if it 66 | succeeds. The resulting process is, of course, also error-prone, failing 67 | as soon as either component fails. 68 | -} 69 | 70 | _>>=_ : {E S T : Set} 71 | -> Error E S -- process which tries to get an S 72 | -> (S -> Error E T) -- given an S, process which tries for a T 73 | -> Error E T -- combined in sequence 74 | es >>= s2et = {!!} 75 | 76 | {- 2.3 Implement an evaluator for HExpIf. Be sure to add only numbers and 77 | to branch only on Booleans. Report type mismatches as errors. You should 78 | use _>>=_ to help with the propagation of error messages. 79 | -} 80 | 81 | eval : HExpIf -> Error EvalError HValIf 82 | eval e = {!!} 83 | 84 | {- Note that the type of eval is not specific about whether the value 85 | expected is numeric or Boolean. It may help to introduce auxiliary 86 | definitions of error-prone processes which are "ok" only for the 87 | type that you really want. 88 | -} 89 | 90 | {- Next up, stack machine code, and its execution. -} 91 | 92 | data HBCode : Set where 93 | PUSHN : Nat -> HBCode 94 | PUSHB : Two -> HBCode 95 | ADD : HBCode 96 | _SEQ_ : HBCode -> HBCode -> HBCode 97 | _IFPOP_ : HBCode -> HBCode -> HBCode 98 | 99 | {- The intended behaviour of (t IFPOP f) is as follows 100 | * pop the (we hope) Boolean value from top of stack 101 | * if it's tt, execute t, else execute f 102 | * whichever branch is executed, it gets the popped stack to start 103 | -} 104 | 105 | {- 2.4 Populate the type of possible execution errors and implement the 106 | execution behaviour of HBCode, operating on a stack represented as 107 | a list of HValIf values. 108 | -} 109 | 110 | data ExecError : Set where 111 | -- your constructors here 112 | 113 | exec : HBCode -> List HValIf -> Error ExecError (List HValIf) 114 | exec c s = {!!} 115 | 116 | {- Next, we take a look at code generation and type safety. -} 117 | 118 | data HTy : Set where -- we have two types in HExpIf 119 | NUM BOOL : HTy 120 | 121 | _=HTy=_ : HTy -> HTy -> Two -- we can test if two types are equal 122 | NUM =HTy= NUM = tt 123 | NUM =HTy= BOOL = ff 124 | BOOL =HTy= NUM = ff 125 | BOOL =HTy= BOOL = tt 126 | 127 | {- 2.5 Write a type-synthesizing compiler, computing both the HTy type and 128 | the HBCode executable for a given expression. Your compiler should 129 | give an informative error report if the expression it receives is 130 | ill typed. Your compiler should also ensure (at least informally) that 131 | the code produced will never trigger any execution errors. 132 | -} 133 | 134 | data CompileError : Set where 135 | -- your constructors here 136 | 137 | compile : HExpIf -> Error CompileError (HTy /*/ HBCode) 138 | compile (num x) = {!!} 139 | compile (boo x) = {!!} 140 | compile (e1 +++ e2) = compile e1 >>= \ 141 | { (BOOL , c1) -> error {!!} 142 | ; (NUM , c1) -> {!!} 143 | } 144 | compile (hif e then e₁ else e₂) = {!!} 145 | 146 | 147 | {- You have a little bit more room for creative problem-solving in what's 148 | left of the exercise. The plan is to build the type system into expressions 149 | and code, the same way we did with plain Hutton's Razor in class. 150 | -} 151 | 152 | {- If we *know* which HTy type we want, we can compute which Agda type we 153 | expect our value to take. -} 154 | 155 | HVal : HTy -> Set 156 | HVal NUM = Nat 157 | HVal BOOL = Two 158 | 159 | {- 2.6 Finish the type of typed expressions. You should ensure that only 160 | well HTy-typed expressions can be constructed. -} 161 | 162 | data THExpIf : HTy -> Set where 163 | val : {t : HTy} -> HVal t -> THExpIf t 164 | -- you fill in addition and if-then-else 165 | 166 | {- 2.7 Implement a type-safe evaluator. -} 167 | 168 | teval : {t : HTy} -> THExpIf t -> HVal t 169 | teval e = {!!} 170 | 171 | {- 2.8 Implement a type checker. -} 172 | 173 | data TypeError : Set where 174 | -- your constructors here 175 | 176 | tcheck : (t : HTy) -> HExpIf -> Error TypeError (THExpIf t) 177 | tcheck t e = {!!} 178 | 179 | {- 2.9 Adapt the technique from Hutton.agda to give a type-safe underflow-free 180 | version of HBCode. You will need to think what is a good type to represent 181 | the "shape" of a stack: before, we just used Nat to represent the *height* of 182 | the stack, but now we must worry about types. See next question for a hint. -} 183 | 184 | data THBCode : {- your indices here -} Set where 185 | -- your constructors here 186 | 187 | {- 2.10 Implement the execution semantics for your code. You will need to think 188 | about how to represent a stack. The Ex2Prelude.agda file contains a very 189 | handy piece of kit for this purpose. You write the type, too. -} 190 | 191 | -- your code here 192 | 193 | {- 2.11 Write the compiler from well typed expressions to safe code. -} 194 | 195 | tcompile : {t : HTy} -> THExpIf t -> {!!} 196 | tcompile e = {!!} 197 | -------------------------------------------------------------------------------- /Ex2Tut.agda: -------------------------------------------------------------------------------- 1 | module Ex2Tut where 2 | 3 | {----------------------------------------------------------------------------- 4 | Name: 5 | -----------------------------------------------------------------------------} 6 | 7 | {----------------------------------------------------------------------------- 8 | CS410 Exercise 2, due 5pm on Monday of Week 6 (3 November 2014) 9 | NOTE: I am well aware that week 6 is quite busy with deadlines, 10 | what with CS408-related obligations and so on. I'd much prefer 11 | you did things to the best of your ability rather than on time, 12 | so I would be sympathetic to requests for some flexibility. 13 | Still, your best bet is to make an early start rather than a 14 | late finish. 15 | -----------------------------------------------------------------------------} 16 | 17 | {----------------------------------------------------------------------------- 18 | This exercise is based around extending Hutton's razor with Boolean 19 | values and conditional expressions. By introducing a second value 20 | type, we acquire the risk of type mismatch. The idea here is to 21 | explore different approaches to managing that risk. 22 | -----------------------------------------------------------------------------} 23 | 24 | open import Ex1Prelude 25 | open import Ex2Prelude 26 | 27 | {- The extended Hutton's Razor syntax -} 28 | 29 | data HExpIf : Set where 30 | num : Nat -> HExpIf 31 | boo : Two -> HExpIf 32 | _+++_ : HExpIf -> HExpIf -> HExpIf 33 | hif_then_else_ : HExpIf -> HExpIf -> HExpIf -> HExpIf 34 | 35 | {- Note that an expression 36 | 37 | hif eb then ex1 else ex2 38 | 39 | makes sense only when 40 | * eb produces a Boolean value 41 | * ex1 and ex2 produce the same sort of value (numeric or Boolean) 42 | -} 43 | 44 | HValIf : Set 45 | HValIf = Two /+/ Nat 46 | 47 | {- We now have the risk of run time type errors. Let's introduce a type 48 | for things which can go wrong. -} 49 | 50 | data Error (E X : Set) : Set where 51 | ok : X -> Error E X 52 | error : E -> Error E X 53 | 54 | {- 2.1 Add a constructor to the following datatype for each different 55 | kind of run time error that can happen. (Come back to this exercise 56 | when you're writing the evaluator in 2.3.) Make these error reports 57 | as informative as you can. 58 | -} 59 | 60 | data EvalError : Set where 61 | -- your constructors here 62 | 63 | {- 2.2 Write a little piece of "glue code" to make it easier to manage 64 | errors. The idea is to combine error-prone process in *sequence*, where 65 | the second process can depend on the value produced by the first if it 66 | succeeds. The resulting process is, of course, also error-prone, failing 67 | as soon as either component fails. 68 | -} 69 | 70 | _>>=_ : {E S T : Set} 71 | -> Error E S -- process which tries to get an S 72 | -> (S -> Error E T) -- given an S, process which tries for a T 73 | -> Error E T -- combined in sequence 74 | es >>= s2et = {!!} 75 | 76 | {- 2.3 Implement an evaluator for HExpIf. Be sure to add only numbers and 77 | to branch only on Booleans. Report type mismatches as errors. You should 78 | use _>>=_ to help with the propagation of error messages. 79 | -} 80 | 81 | eval : HExpIf -> Error EvalError HValIf 82 | eval e = {!!} 83 | 84 | {- Note that the type of eval is not specific about whether the value 85 | expected is numeric or Boolean. It may help to introduce auxiliary 86 | definitions of error-prone processes which are "ok" only for the 87 | type that you really want. 88 | -} 89 | 90 | {- Next up, stack machine code, and its execution. -} 91 | 92 | data HBCode : Set where 93 | PUSHN : Nat -> HBCode 94 | PUSHB : Two -> HBCode 95 | ADD : HBCode 96 | _SEQ_ : HBCode -> HBCode -> HBCode 97 | _IFPOP_ : HBCode -> HBCode -> HBCode 98 | 99 | {- The intended behaviour of (t IFPOP f) is as follows 100 | * pop the (we hope) Boolean value from top of stack 101 | * if it's tt, execute t, else execute f 102 | * whichever branch is executed, it gets the popped stack to start 103 | -} 104 | 105 | {- 2.4 Populate the type of possible execution errors and implement the 106 | execution behaviour of HBCode, operating on a stack represented as 107 | a list of HValIf values. 108 | -} 109 | 110 | data ExecError : Set where 111 | -- your constructors here 112 | 113 | exec : HBCode -> List HValIf -> Error ExecError (List HValIf) 114 | exec c s = {!!} 115 | 116 | {- Next, we take a look at code generation and type safety. -} 117 | 118 | data HTy : Set where -- we have two types in HExpIf 119 | NUM BOOL : HTy 120 | 121 | _=HTy=_ : HTy -> HTy -> Two -- we can test if two types are equal 122 | NUM =HTy= NUM = tt 123 | NUM =HTy= BOOL = ff 124 | BOOL =HTy= NUM = ff 125 | BOOL =HTy= BOOL = tt 126 | 127 | {- 2.5 Write a type-synthesizing compiler, computing both the HTy type and 128 | the HBCode executable for a given expression. Your compiler should 129 | give an informative error report if the expression it receives is 130 | ill typed. Your compiler should also ensure (at least informally) that 131 | the code produced will never trigger any execution errors. 132 | -} 133 | 134 | data CompileError : Set where 135 | -- your constructors here 136 | 137 | compile : HExpIf -> Error CompileError (HTy /*/ HBCode) 138 | compile (num x) = {!!} 139 | compile (boo x) = {!!} 140 | compile (e1 +++ e2) = compile e1 >>= \ 141 | { (BOOL , c1) -> error {!!} 142 | ; (NUM , c1) -> {!!} 143 | } 144 | compile (hif e then e₁ else e₂) = {!!} 145 | 146 | 147 | {- You have a little bit more room for creative problem-solving in what's 148 | left of the exercise. The plan is to build the type system into expressions 149 | and code, the same way we did with plain Hutton's Razor in class. 150 | -} 151 | 152 | {- If we *know* which HTy type we want, we can compute which Agda type we 153 | expect our value to take. -} 154 | 155 | HVal : HTy -> Set 156 | HVal NUM = Nat 157 | HVal BOOL = Two 158 | 159 | {- 2.6 Finish the type of typed expressions. You should ensure that only 160 | well HTy-typed expressions can be constructed. -} 161 | 162 | data THExpIf : HTy -> Set where 163 | val : {t : HTy} -> HVal t -> THExpIf t 164 | -- you fill in addition and if-then-else 165 | 166 | {- 2.7 Implement a type-safe evaluator. -} 167 | 168 | teval : {t : HTy} -> THExpIf t -> HVal t 169 | teval (val x) = x 170 | 171 | myNUMExp : THExpIf NUM 172 | myNUMExp = val 42 173 | 174 | myBOOLExp : THExpIf BOOL 175 | myBOOLExp = val ff 176 | 177 | 178 | {- 2.8 Implement a type checker. -} 179 | 180 | data TypeError : Set where 181 | -- your constructors here 182 | 183 | tcheck : (t : HTy) -> HExpIf -> Error TypeError (THExpIf t) 184 | tcheck t e = {!!} 185 | 186 | {- 2.9 Adapt the technique from Hutton.agda to give a type-safe underflow-free 187 | version of HBCode. You will need to think what is a good type to represent 188 | the "shape" of a stack: before, we just used Nat to represent the *height* of 189 | the stack, but now we must worry about types. See next question for a hint. -} 190 | 191 | data THBCode : {- your indices here -} Set where 192 | -- your constructor here 193 | 194 | {- 2.10 Implement the execution semantics for your code. You will need to think 195 | about how to represent a stack. The Ex2Prelude.agda file contains a very 196 | handy piece of kit for this purpose. You write the type, too. -} 197 | 198 | -- your code here 199 | 200 | {- 2.11 Write the compiler from well typed expressions to safe code. -} 201 | 202 | tcompile : {t : HTy} -> THExpIf t -> {!!} 203 | tcompile e = {!!} 204 | -------------------------------------------------------------------------------- /Ex6/Ex6-2-Box.agda: -------------------------------------------------------------------------------- 1 | module Ex6-2-Box where 2 | 3 | open import Ex6-Setup 4 | open import Ex6-1-Vec 5 | 6 | --------------------------------------------------------------------------- 7 | -- BOXES (5 marks) -- 8 | --------------------------------------------------------------------------- 9 | 10 | -- Boxes are sized rectangular tilings which fit together precisely. 11 | -- They allow us to talk about the use of 2D space, e.g., on a screen. 12 | 13 | data Box (X : Nat -> Nat -> Set)(w h : Nat) : Set where 14 | -- ^basic-tile width^ ^height 15 | 16 | [_] : X w h -> Box X w h 17 | -- a basic tile is a tiling 18 | 19 | leri : (wl : Nat) (bl : Box X wl h) 20 | (wr : Nat) (br : Box X wr h) 21 | -> wl + wr == w -> Box X w h 22 | -- combine "left" and "right" tilings the same height 23 | -- to make a tiling with their total width 24 | 25 | tobo : (ht : Nat) (bt : Box X w ht) 26 | (hb : Nat) (bb : Box X w hb) 27 | -> ht + hb == h -> Box X w h 28 | -- combine "top" and "bottom" tilings the same width 29 | -- to make a tiling with their total height 30 | 31 | 32 | --------------------------------------------------------------------------- 33 | -- MONADIC STRUCTURE -- 34 | --------------------------------------------------------------------------- 35 | 36 | -- If X and Y are both kinds of "sized stuff", we can say what it is to be 37 | -- a "size-preserving function" between them. 38 | 39 | _[]>_ : (X Y : Nat -> Nat -> Set) -> Set 40 | X []> Y = {w h : Nat} -> X w h -> Y w h 41 | -- A size preserving function turns an X of some size 42 | -- into a Y the same size. 43 | 44 | -- Think of X as "sized placeholders". If we have a way to turn each 45 | -- placeholder into a tiling which fits into the place, we should be 46 | -- able to deploy it across a whole tiling of placeholders. Check 47 | -- that you can achieve that. 48 | 49 | _=<<_ : forall {X Y} -> X []> Box Y -> Box X []> Box Y 50 | f =<< b = {!!} 51 | 52 | -- Using _=<<_, rather than more recursion, define... 53 | 54 | mapBox : forall {X Y} -> X []> Y -> Box X []> Box Y 55 | mapBox = {!!} 56 | -- roll out a size-preserving function on basic tiles to a whole tiling 57 | 58 | joinBox : forall {X} -> Box (Box X) []> Box X 59 | joinBox = {!!} 60 | -- turn a tiling-of-tilings into a simple tiling 61 | 62 | -- (1 mark) for the lot 63 | 64 | 65 | --------------------------------------------------------------------------- 66 | -- PASTE KITS AND MATRICES -- 67 | --------------------------------------------------------------------------- 68 | 69 | -- A "paste kit" for sized stuff is whatever you need to combine stuff 70 | -- left-to-right and top-to-bottom 71 | 72 | record PasteKit (X : Nat -> Nat -> Set) : Set where 73 | field 74 | leriPaste : (wl wr : Nat){h : Nat} -> X wl h -> X wr h -> X (wl + wr) h 75 | toboPaste : {w : Nat}(ht hb : Nat) -> X w ht -> X w hb -> X w (ht + hb) 76 | 77 | -- Show that a PasteKit is just what you need to turn a tiling of 78 | -- stuff into some stuff. (1 mark) 79 | 80 | pasteBox : {X : Nat -> Nat -> Set} -> PasteKit X -> Box X []> X 81 | pasteBox {X} pk = go where 82 | open PasteKit pk -- brings leriPaste and toboPaste into scope 83 | go : Box X []> X 84 | go b = {!!} 85 | 86 | -- If you were wondering what any of this had to do with part 1, here we 87 | -- go... 88 | 89 | Matrix : Set -> Nat -> Nat -> Set 90 | Matrix C w h = Vec (Vec C w) h 91 | -- matrices are "sized stuff", represented as a vector the right height 92 | -- of rows which are vectors the right width of some sort of unit "cell". 93 | 94 | -- Using the equipment you built in part 1, give matrices their PasteKit. 95 | -- (1 mark) 96 | 97 | matrixPasteKit : {C : Set} -> PasteKit (Matrix C) 98 | matrixPasteKit = {!!} 99 | 100 | 101 | --------------------------------------------------------------------------- 102 | -- INTERLUDE: TESTING WITH TEXT -- 103 | --------------------------------------------------------------------------- 104 | 105 | -- Turn a list into a vector, either by truncating or padding with 106 | -- a given dummy element. 107 | paddy : {X : Set} -> X -> List X -> {n : Nat} -> Vec X n 108 | paddy _ _ {zero} = [] 109 | paddy x [] {suc n} = x :: paddy x [] {n} 110 | paddy x (y :: ys) {suc n} = y :: paddy x ys {n} 111 | 112 | -- Use that to make vectors of characters from strings, padding with space. 113 | [-_-] : String -> {n : Nat} -> Vec Char n 114 | [- s -] = paddy ' ' (primStringToList s) 115 | 116 | -- Now we can have character matrices of a given size 117 | _*C*_ : Nat -> Nat -> Set 118 | w *C* h = Matrix Char w h 119 | 120 | -- Here are some. 121 | mat43-1 : 4 *C* 3 122 | mat43-1 = [- "post" -] :: [- "cake" -] :: [- "flop" -] :: [] 123 | 124 | mat43-2 : 4 *C* 3 125 | mat43-2 = [- "horn" -] :: [- "walk" -] :: [- "ping" -] :: [] 126 | 127 | mat22 : 2 *C* 2 128 | mat22 = [- "go" -] :: [- "do" -] :: [] 129 | 130 | mat62 : 6 *C* 2 131 | mat62 = [- "getter" -] :: [- "gooder" -] :: [] 132 | 133 | -- Put them together as a tiling. 134 | myTiling : Box _*C*_ 8 5 135 | myTiling = tobo 3 (leri 4 [ mat43-1 ] 4 [ mat43-2 ] refl) 136 | 2 (leri 2 [ mat22 ] 6 [ mat62 ] refl) refl 137 | 138 | -- Paste all the pieces and see what you get! 139 | myText : 8 *C* 5 140 | myText = pasteBox matrixPasteKit myTiling 141 | 142 | 143 | --------------------------------------------------------------------------- 144 | -- CUT KITS, MATRICES -- 145 | --------------------------------------------------------------------------- 146 | 147 | -- A "cut kit" for sized stuff is whatever you need to cut stuff into 148 | -- smaller pieces: left-and-right pieces, or top-and-bottom pieces. 149 | 150 | record CutKit (X : Nat -> Nat -> Set) : Set where 151 | field 152 | cutLR : (w h wl wr : Nat) -> wl + wr == w -> 153 | X w h -> X wl h /*/ X wr h 154 | cutTB : (w h ht hb : Nat) -> ht + hb == h -> 155 | X w h -> X w ht /*/ X w hb 156 | 157 | -- Equip matrices with their CutKit. (1 mark) 158 | 159 | matrixCutKit : {C : Set} -> CutKit (Matrix C) 160 | matrixCutKit {C} = {!!} 161 | 162 | 163 | --------------------------------------------------------------------------- 164 | -- HOLES -- 165 | --------------------------------------------------------------------------- 166 | 167 | -- We might want to make sure that, whatever other basic tiles are in play, 168 | -- we can have tiles which are "missing", as if we had cut rectangular 169 | -- holes in a piece of paper. 170 | 171 | data HoleOr (X : Nat -> Nat -> Set)(w h : Nat) : Set where 172 | Hole : HoleOr X w h 173 | [_] : X w h -> HoleOr X w h 174 | 175 | -- A HoleOr X is (you guessed it) either a hole or an X. 176 | 177 | -- Show that if X has a CutKit, so has HoleOr X. What do you get when you 178 | -- cut up a hole? (1 mark) 179 | 180 | holeCutKit : {X : Nat -> Nat -> Set} -> CutKit X -> CutKit (HoleOr X) 181 | holeCutKit {X} ck = {!!} 182 | 183 | 184 | --------------------------------------------------------------------------- 185 | -- A BIT OF FUN -- 186 | --------------------------------------------------------------------------- 187 | 188 | -- Show that you can turn holes into spaces. 189 | 190 | holeSpace : HoleOr _*C*_ []> _*C*_ 191 | holeSpace Hole = vec (vec ' ') 192 | holeSpace [ x ] = x 193 | 194 | -- Show how to render a tiling made of text or holes as text. 195 | 196 | renderHoleOrText : Box (HoleOr _*C*_) []> _*C*_ 197 | renderHoleOrText = pasteBox matrixPasteKit o mapBox holeSpace 198 | 199 | -- Make a test example and see! 200 | 201 | myTest : {!!} *C* {!!} 202 | myTest = renderHoleOrText {!!} 203 | 204 | 205 | --------------------------------------------------------------------------- 206 | -- NEXT TIME... -- 207 | --------------------------------------------------------------------------- 208 | 209 | -- Have a wee think about what you might need to equip Box X with a CutKit. 210 | -------------------------------------------------------------------------------- /FunctorKit.agda: -------------------------------------------------------------------------------- 1 | module FunctorKit where 2 | 3 | open import BasicPrelude 4 | 5 | record Functor (F : Set{-type of elements-} -> Set{-type of structures-}) 6 | : Set1 where 7 | field 8 | 9 | map : {S T : Set} -> (S -> T) {- operation on elements-} 10 | -> F S -> F T {- operation on structures -} 11 | 12 | mapI : {X : Set}(xs : F X) -> map id xs == xs 13 | mapC : {R S T : Set}(f : S -> T)(g : R -> S)(xs : F R) -> 14 | map f (map g xs) == map (f o g) xs 15 | 16 | open Functor public 17 | 18 | ListFunctor : Functor List 19 | ListFunctor = record { map = mapList; mapI = mapIList; mapC = mapCList } where 20 | 21 | mapList : {S T : Set} -> (S -> T) -> List S -> List T 22 | mapList f [] = [] 23 | mapList f (x :> xs) = f x :> mapList f xs 24 | 25 | mapIList : {X : Set} (xs : List X) -> mapList id xs == xs 26 | mapIList [] = refl 27 | mapIList (x :> xs) rewrite mapIList xs = refl 28 | 29 | mapCList : {R S T : Set} (f : S -> T) (g : R -> S) (xs : List R) -> 30 | mapList f (mapList g xs) == mapList (f o g) xs 31 | mapCList f g [] = refl 32 | mapCList f g (x :> xs) rewrite mapCList f g xs = refl 33 | 34 | Label : Set -> (Set -> Set) -- no elements 35 | Label A X = A 36 | 37 | LabelFunctor : (A : Set) -> Functor (Label A) 38 | LabelFunctor A = record 39 | { map = \ _ a -> a; mapI = \ _ -> refl; mapC = \ _ _ _ -> refl } 40 | 41 | Id : Set -> Set -- one element 42 | Id X = X 43 | 44 | IdFunctor : Functor Id 45 | IdFunctor = record { 46 | map = id; 47 | mapI = \ _ -> refl; 48 | mapC = \ _ _ _ -> refl } 49 | 50 | PairFunctor : {F G : Set -> Set} -> Functor F -> Functor G -> 51 | Functor \ X -> F X /*/ G X 52 | PairFunctor {F}{G} FunF FunG = record { map = mapP ; mapI = mapPI ; mapC = mapPC } 53 | where 54 | mapP : {S T : Set} -> (S -> T) -> (F S /*/ G S) -> (F T /*/ G T) 55 | mapP f (xF , xG) = map FunF f xF , map FunG f xG 56 | mapPI : forall {X : Set}(xs : F X /*/ G X) -> mapP id xs == xs 57 | mapPI (xF , xG) rewrite mapI FunF xF | mapI FunG xG = refl 58 | mapPC : {R S T : Set} (f : S -> T) (g : R -> S) (xs : F R /*/ G R) -> 59 | mapP f (mapP g xs) == mapP (f o g) xs 60 | mapPC f g (xF , xG) rewrite mapC FunF f g xF | mapC FunG f g xG = refl 61 | 62 | SumFunctor : {F G : Set -> Set} -> Functor F -> Functor G -> 63 | Functor \ X -> F X /+/ G X 64 | SumFunctor {F}{G} FunF FunG = record { map = mapS ; mapI = mapSI; mapC = mapSC } 65 | where 66 | mapS : {S T : Set} -> (S -> T) -> (F S /+/ G S) -> (F T /+/ G T) 67 | mapS f (inl xF) = inl (map FunF f xF) 68 | mapS f (inr xG) = inr (map FunG f xG) 69 | mapSI : {X : Set} (xs : F X /+/ G X) -> mapS id xs == xs 70 | mapSI (inl xF) rewrite mapI FunF xF = refl 71 | mapSI (inr xG) rewrite mapI FunG xG = refl 72 | mapSC : {R S T : Set} (f : S -> T) (g : R -> S) (xs : F R /+/ G R) -> 73 | mapS f (mapS g xs) == mapS (f o g) xs 74 | mapSC f g (inl xF) rewrite mapC FunF f g xF = refl 75 | mapSC f g (inr xG) rewrite mapC FunG f g xG = refl 76 | 77 | data Kit : Set1 where 78 | zeroK oneK : Kit 79 | idK : Kit 80 | dataK : Kit -> Kit 81 | _*K_ : Kit -> Kit -> Kit 82 | _+K_ : Kit -> Kit -> Kit 83 | 84 | infixr 4 _+K_ 85 | infixr 5 _*K_ 86 | 87 | Fun : Kit -> Set -> Set 88 | 89 | data DATA (f : Kit) : Set where 90 | [_] : Fun f (DATA f) -> DATA f 91 | 92 | Fun zeroK X = Zero 93 | Fun oneK X = One 94 | Fun idK X = Id X 95 | Fun (dataK f) X = DATA f 96 | Fun (f *K g) X = Fun f X /*/ Fun g X 97 | Fun (f +K g) X = Fun f X /+/ Fun g X 98 | 99 | FunFunctor : (f : Kit) -> Functor (Fun f) 100 | FunFunctor zeroK = LabelFunctor Zero 101 | FunFunctor oneK = LabelFunctor One 102 | FunFunctor (dataK f) = LabelFunctor (DATA f) 103 | FunFunctor idK = IdFunctor 104 | FunFunctor (f *K g) = PairFunctor (FunFunctor f) (FunFunctor g) 105 | FunFunctor (f +K g) = SumFunctor (FunFunctor f) (FunFunctor g) 106 | 107 | twoK : Kit 108 | twoK = oneK +K oneK 109 | 110 | pattern true = [ inl <> ] 111 | pattern false = [ inr <> ] 112 | 113 | natK : Kit 114 | natK = oneK +K idK 115 | 116 | pattern ze = [ inl <> ] 117 | pattern su n = [ inr n ] 118 | 119 | toNatK : Nat -> DATA natK 120 | toNatK zero = ze 121 | toNatK (suc n) = su (toNatK n) 122 | 123 | listK : Kit -> Kit 124 | listK f = oneK +K (dataK f *K idK) 125 | 126 | pattern nil = [ inl <> ] 127 | pattern cons x xs = [ inr (x , xs) ] 128 | 129 | treeK : Kit -> Kit 130 | treeK f = oneK +K (idK *K dataK f *K idK) 131 | 132 | leaf' : {f : Kit} -> DATA (treeK f) 133 | pattern leaf = [ inl <> ] 134 | leaf' = leaf 135 | pattern node l x r = [ inr (l , x , r) ] 136 | node' : {f : Kit} -> DATA (treeK f) -> DATA f -> DATA (treeK f) -> DATA (treeK f) 137 | node' l x r = node l x r 138 | 139 | leK : DATA natK -> DATA natK -> DATA twoK 140 | leK ze n = true 141 | leK (su m) ze = false 142 | leK (su m) (su n) = leK m n 143 | 144 | 145 | {- 146 | 147 | noLabels : (f : Kit) -> DATA f -> Zero 148 | 149 | noLabels' : (r f : Kit) -> Fun f (DATA r) -> Zero 150 | noLabels' r idK x = noLabels r x 151 | noLabels' r (f *K g) (xf , xg) = noLabels' r f xf 152 | noLabels' r (f +K g) (inl x) = noLabels' r f x 153 | noLabels' r (f +K g) (inr x) = noLabels' r g x 154 | 155 | noLabels f [ x ] = noLabels' f f x 156 | -} 157 | 158 | {- 159 | mysteryf : Kit 160 | mysteryf = (labelK One) +K idK 161 | 162 | MYSTERY : Set 163 | MYSTERY = DATA mysteryf 164 | 165 | {- -- ask Agsy to try making some elements of the MYSTERY type 166 | mystery : MYSTERY 167 | mystery = {!-l!} -- do [C-c C-a] with -l in the braces 168 | -} 169 | 170 | -- Aha! It's a copy of the natural numbers! 171 | 172 | zeroM : MYSTERY 173 | zeroM = [ inl <> ] 174 | 175 | sucM : MYSTERY -> MYSTERY 176 | sucM n = [ inr n ] 177 | 178 | -- Now how about this... 179 | 180 | treef : Set -> Kit 181 | treef X = labelK One +K idK *K labelK X *K idK 182 | 183 | pattern leaf = [ inl <> ] 184 | pattern node l x r = [ inr (l , x , r) ] 185 | 186 | flatten : {X : Set} -> DATA (treef X) -> List X 187 | flatten leaf = [] 188 | flatten (node l x r) = flatten l ++ x :> flatten r 189 | 190 | insert : Nat -> DATA (treef Nat) -> DATA (treef Nat) 191 | insert n leaf = node leaf n leaf 192 | insert n (node l x r) with n <= x 193 | insert n (node l x r) | tt = node (insert n l) x r 194 | insert n (node l x r) | ff = node l x (insert n r) 195 | 196 | StuffINeed : Kit -> Set 197 | StuffINeed (labelK A) = A -> A -> Two 198 | StuffINeed idK = One 199 | StuffINeed (f *K g) = StuffINeed f /*/ StuffINeed g 200 | StuffINeed (f +K g) = StuffINeed f /*/ StuffINeed g 201 | -} 202 | 203 | kitEq : {f : Kit} -> DATA f -> DATA f -> DATA twoK 204 | 205 | nodeEq : (r f : Kit) -> Fun f (DATA r) -> Fun f (DATA r) -> DATA twoK 206 | nodeEq r zeroK () y 207 | nodeEq r oneK <> <> = true 208 | nodeEq r idK x y = kitEq x y -- here's where r is used 209 | nodeEq r (dataK f) x y = kitEq x y 210 | nodeEq r (f *K g) (xf , xg) (yf , yg) with nodeEq r f xf yf | nodeEq r g xg yg 211 | nodeEq r (f *K g) (xf , xg) (yf , yg) | true | true = true 212 | nodeEq r (f *K g) (xf , xg) (yf , yg) | qf | qg = false 213 | nodeEq r (f +K g) (inl x) (inl y) = nodeEq r f x y 214 | nodeEq r (f +K g) (inl x) (inr y) = false 215 | nodeEq r (f +K g) (inr x) (inl y) = false 216 | nodeEq r (f +K g) (inr x) (inr y) = nodeEq r g x y 217 | 218 | kitEq {f} [ x ] [ y ] = nodeEq f f x y 219 | 220 | delOne : Kit -> Kit 221 | delOne zeroK = zeroK 222 | delOne oneK = zeroK 223 | delOne idK = oneK 224 | delOne (dataK f) = zeroK 225 | delOne (f *K g) = delOne f *K g +K f *K delOne g 226 | delOne (f +K g) = delOne f +K delOne g 227 | 228 | 229 | {- 230 | nodeEq r sr (labelK A) s a a' = s a a' 231 | nodeEq r sr idK s x y = kitEq sr x y 232 | nodeEq r sr (f *K g) (sf , sg) (xf , xg) (yf , yg) 233 | with nodeEq r sr f sf xf yf | nodeEq r sr g sg xg yg 234 | nodeEq r sr (f *K g) (sf , sg) (xf , xg) (yf , yg) | tt | tt = tt 235 | nodeEq r sr (f *K g) (sf , sg) (xf , xg) (yf , yg) | qf | qg = ff 236 | nodeEq r sr (f +K g) s (inl xf) (inl yf) = nodeEq r sr f (outl s) xf yf 237 | nodeEq r sr (f +K g) s (inl xf) (inr yg) = ff 238 | nodeEq r sr (f +K g) s (inr xg) (inl yf) = ff 239 | nodeEq r sr (f +K g) s (inr xg) (inr yg) = nodeEq r sr g (outr s) xg yg 240 | 241 | kitEq {f} s [ x ] [ y ] = nodeEq f s f s x y 242 | 243 | myGo : Two 244 | myGo = kitEq ((\ _ _ -> tt) , _) (sucM (sucM (sucM zeroM))) (sucM (sucM (sucM zeroM))) 245 | -} -------------------------------------------------------------------------------- /Ex5/AgdaSetup.agda: -------------------------------------------------------------------------------- 1 | module AgdaSetup where 2 | 3 | {- This file contains all the basic types you need for the editor. You should 4 | read and understand the Agda in this file, but not bother too much about 5 | the funny compiler directives. -} 6 | 7 | data Nat : Set where 8 | zero : Nat 9 | suc : Nat -> Nat 10 | 11 | {-# BUILTIN NATURAL Nat #-} 12 | {-# COMPILED_DATA Nat HaskellSetup.Nat HaskellSetup.Zero HaskellSetup.Suc #-} 13 | 14 | _+_ : Nat -> Nat -> Nat 15 | zero + n = n 16 | suc m + n = suc (m + n) 17 | 18 | infixr 5 _+_ 19 | 20 | data Zero : Set where 21 | magic : {X : Set} -> 22 | Zero -> X 23 | magic () 24 | 25 | {- In order to compile them, I have to define One and /*/ as data types 26 | rather than records. -} 27 | 28 | data One : Set where 29 | <> : One 30 | {-# COMPILED_DATA One () () #-} 31 | 32 | data _/*/_ (S T : Set) : Set where 33 | _,_ : S -> T -> S /*/ T 34 | {-# COMPILED_DATA _/*/_ (,) (,) #-} 35 | 36 | data Two : Set where 37 | tt ff : Two 38 | {-# BUILTIN BOOL Two #-} 39 | {-# BUILTIN TRUE tt #-} 40 | {-# BUILTIN FALSE ff #-} 41 | {-# COMPILED_DATA Two Bool True False #-} 42 | 43 | _<=_ : Nat -> Nat -> Two 44 | zero <= y = tt 45 | suc x <= zero = ff 46 | suc x <= suc y = x <= y 47 | 48 | if_then_else_ : {X : Set} -> Two -> X -> X -> X 49 | if tt then t else f = t 50 | if ff then t else f = f 51 | 52 | data List (X : Set) : Set where 53 | [] : List X 54 | _:>_ : X -> List X -> List X 55 | infixr 5 _:>_ 56 | 57 | _++_ : {A : Set} -> List A -> List A -> List A 58 | [] ++ ys = ys 59 | (x :> xs) ++ ys = x :> (xs ++ ys) 60 | 61 | {-# COMPILED_DATA List [] [] (:) #-} 62 | {-# BUILTIN LIST List #-} 63 | {-# BUILTIN NIL [] #-} 64 | {-# BUILTIN CONS _:>_ #-} 65 | 66 | {- Here are backward lists, which are useful when the closest element is 67 | conceptually at the right end. They aren't really crucial as you could use 68 | ordinary lists but think of the data as being reversed, but I prefer to 69 | keep my thinking straight and use data which look like what I have in mind. -} 70 | 71 | data Bwd (X : Set) : Set where 72 | [] : Bwd X 73 | _<:_ : Bwd X -> X -> Bwd X 74 | infixl 5 _<:_ 75 | 76 | {- You will need access to characters, imported from Haskell. You can write 77 | character literals like 'c'. You also get strings, with String literals like 78 | "fred" -} 79 | 80 | postulate -- this means that we just suppose the following things exist... 81 | Char : Set 82 | String : Set 83 | {-# BUILTIN CHAR Char #-} 84 | {-# COMPILED_TYPE Char Char #-} -- ...and by the time we reach Haskell... 85 | {-# BUILTIN STRING String #-} 86 | {-# COMPILED_TYPE String String #-} -- ...they *do* exist! 87 | 88 | primitive -- these are baked in; they even work! 89 | primCharEquality : Char -> Char -> Two 90 | primStringAppend : String -> String -> String 91 | primStringToList : String -> List Char 92 | primStringFromList : List Char -> String 93 | 94 | postulate -- Haskell has a monad for doing IO, which we use at the top level 95 | IO : Set -> Set 96 | return : {A : Set} -> A -> IO A 97 | _>>=_ : {A B : Set} -> IO A -> (A -> IO B) -> IO B 98 | infixl 1 _>>=_ 99 | {-# BUILTIN IO IO #-} 100 | {-# COMPILED_TYPE IO IO #-} 101 | {-# COMPILED return (\ _ -> return) #-} 102 | {-# COMPILED _>>=_ (\ _ _ -> (>>=)) #-} 103 | 104 | {- Here's the characterization of keys I give you -} 105 | data Direction : Set where up down left right : Direction 106 | data Modifier : Set where normal shift control : Modifier 107 | data Key : Set where 108 | char : Char -> Key 109 | arrow : Modifier -> Direction -> Key 110 | enter : Key 111 | backspace : Key 112 | delete : Key 113 | escape : Key 114 | 115 | {- This type classifies the difference between two editor states. -} 116 | data Change : Set where 117 | allQuiet : Change -- the buffer should be exactly the same 118 | cursorMove : Change -- the cursor has moved but the text is the same 119 | lineEdit : Change -- only the text on the current line has changed 120 | bigChange : Change -- goodness knows! 121 | 122 | {- This type collects the things you're allowed to do with the text window. -} 123 | data Action : Set where 124 | goRowCol : Nat -> Nat -> Action -- send the cursor somewhere 125 | sendText : List Char -> Action -- send some text 126 | 127 | {- I wire all of that stuff up to its Haskell counterpart. -} 128 | {-# IMPORT HaskellSetup #-} 129 | {-# COMPILED_DATA Direction 130 | HaskellSetup.Direction 131 | HaskellSetup.DU HaskellSetup.DD HaskellSetup.DL HaskellSetup.DR #-} 132 | {-# COMPILED_DATA Modifier 133 | HaskellSetup.Modifier 134 | HaskellSetup.Normal HaskellSetup.Shift HaskellSetup.Control #-} 135 | {-# COMPILED_DATA Key 136 | HaskellSetup.Key 137 | HaskellSetup.Char HaskellSetup.Arrow HaskellSetup.Enter 138 | HaskellSetup.Backspace HaskellSetup.Delete HaskellSetup.Escape #-} 139 | {-# COMPILED_DATA Change 140 | HaskellSetup.Change 141 | HaskellSetup.AllQuiet HaskellSetup.CursorMove HaskellSetup.LineEdit 142 | HaskellSetup.BigChange #-} 143 | {-# COMPILED_DATA Action 144 | HaskellSetup.Action 145 | HaskellSetup.GoRowCol HaskellSetup.SendText #-} 146 | 147 | {- This is the bit of code I wrote to animate your code. -} 148 | postulate 149 | mainLoop : {B : Set} -> -- buffer type 150 | -- INITIALIZER 151 | (List (List Char) -> B) -> -- make a buffer from some lines of text 152 | -- KEYSTROKE HANDLER 153 | (Key -> B -> -- keystroke and buffer in 154 | Change /*/ B) -> -- change report and buffer out 155 | -- RENDERER 156 | ((Nat /*/ Nat) -> -- height and width of screen 157 | (Nat /*/ Nat) -> -- top line number, left column number 158 | (Change /*/ B) -> -- change report and buffer to render 159 | (List Action /*/ -- how to update the display 160 | (Nat /*/ Nat))) -> -- new top line number, left column number 161 | -- PUT 'EM TOGETHER AND YOU'VE GOT AN EDITOR! 162 | IO One 163 | {-# COMPILED mainLoop (\ _ -> HaskellSetup.mainLoop) #-} 164 | 165 | {- You can use this to put noisy debug messages in Agda code. So 166 | trace "fred" tt 167 | evaluates to tt, but prints "fred" in the process. -} 168 | postulate 169 | trace : {A : Set} -> String -> A -> A 170 | {-# IMPORT Debug.Trace #-} 171 | {-# COMPILED trace (\ _ -> Debug.Trace.trace) #-} 172 | 173 | {- You can use this to print an error message when you don't know what else to do. 174 | It's very useful for filling in unfinished holes to persuade the compiler to 175 | compile your code even though it isn't finished: you get an error if you try 176 | to run a missing bit. -} 177 | postulate 178 | error : {A : Set} -> String -> A 179 | {-# COMPILED error (\ _ -> error) #-} 180 | 181 | {- Equality -} 182 | {- x == y is a type whenever x and y are values in the same type -} 183 | {- 184 | data _==_ {X : Set}(x : X) : X -> Set where 185 | refl : x == x -- and x == y has a constructor only when y actually is x! 186 | infixl 1 _==_ 187 | -- {-# BUILTIN EQUALITY _==_ #-} 188 | -- {-# BUILTIN REFL refl #-} 189 | {-# COMPILED_DATA _==_ HaskellSetup.EQ HaskellSetup.Refl #-} 190 | 191 | within_turn_into_because_ : 192 | {X Y : Set}(f : X -> Y)(x x' : X) -> 193 | x == x' -> f x == f x' 194 | within f turn x into .x because refl = refl 195 | -- the dot tells Agda that *only* x can go there 196 | 197 | symmetry : {X : Set}{x x' : X} -> x == x' -> x' == x 198 | symmetry refl = refl 199 | 200 | transitivity : {X : Set}{x0 x1 x2 : X} -> x0 == x1 -> x1 == x2 -> x0 == x2 201 | transitivity refl refl = refl 202 | -} 203 | 204 | postulate 205 | _==_ : {X : Set} -> X -> X -> Set -- the evidence that two X-values are equal 206 | refl : {X : Set}{x : X} -> x == x 207 | symmetry : {X : Set}{x x' : X} -> x == x' -> x' == x 208 | transitivity : {X : Set}{x0 x1 x2 : X} -> x0 == x1 -> x1 == x2 -> x0 == x2 209 | within_turn_into_because_ : 210 | {X Y : Set}(f : X -> Y)(x x' : X) -> 211 | x == x' -> f x == f x' 212 | infix 1 _==_ 213 | 214 | {-# COMPILED_TYPE _==_ HaskellSetup.EQ #-} 215 | 216 | {- Here's an example. -} 217 | 218 | additionAssociative : (x y z : Nat) -> (x + y) + z == x + (y + z) 219 | additionAssociative zero y z = refl 220 | additionAssociative (suc x) y z 221 | = within suc turn ((x + y) + z) into (x + (y + z)) 222 | because additionAssociative x y z 223 | -------------------------------------------------------------------------------- /Ex6/Ex6-3-Cut.agda: -------------------------------------------------------------------------------- 1 | module Ex6-3-Cut where 2 | 3 | open import Ex6-Setup 4 | open import Ex6-1-Vec 5 | open import Ex6-2-Box 6 | 7 | --------------------------------------------------------------------------- 8 | -- CUTTING UP BOXES (5 marks) -- 9 | --------------------------------------------------------------------------- 10 | 11 | -- Previously... 12 | -- ... we established what it is to be a CutKit, and we built CutKits 13 | -- for some sorts of basic tile. Now we need to build the CutKit for 14 | -- Box. Let's think about what that involves for a moment. We're going 15 | -- to need a CutKit for basic tiles to stand a chance. But how do we 16 | -- cut compound tiles? 17 | -- 18 | -- Suppose we're writing cutLR, and we have some 19 | -- cq : cwl + cwr == w -- the "cut widths" equation 20 | -- telling us where we want to make the cut in something of width w. 21 | -- 22 | -- v 23 | -- +--------:------+ 24 | -- | : | 25 | -- | : | 26 | -- +--cwl---:-cwr--+ 27 | -- : ^ : 28 | -- :.......w.......: 29 | -- 30 | -- The tricky part is when the box we're cutting here is built with 31 | -- leri bwl bl bwr br bq 32 | -- where 33 | -- bq : bwl + bwr == w -- the "box widths" equation 34 | -- 35 | -- There are three possible situations, all of which you must detect 36 | -- and handle. 37 | -- 38 | -- (i) you hit the sweet spot... 39 | -- 40 | -- v 41 | -- +--bwl---+-bwr--+ 42 | -- | | | 43 | -- | | | 44 | -- +--cwl---+-cwr--+ 45 | -- : ^ : 46 | -- :.......w.......: 47 | -- 48 | -- ...where the box is already divided in the place where the cut 49 | -- has to go. Happy days. 50 | -- 51 | -- (ii) you're cutting to the left of the join... 52 | -- 53 | -- v 54 | -- +--bwl-----+bwr-+ 55 | -- | : | | 56 | -- | : | | 57 | -- +--cwl---:-cwr--+ 58 | -- : ^ : 59 | -- :.......w.......: 60 | -- 61 | -- ...so you'll need to cut the left box in the correct place. You 62 | -- will need some evidence about widths to do that. And then you'll 63 | -- the have three pieces you can see in my diagram, so to complete 64 | -- the cut, you will need to put two of those pieces together, which 65 | -- will take more evidence. 66 | -- 67 | -- (iii) you're cutting to the right of the join... 68 | -- 69 | -- v 70 | -- +--bwl-+--bwr---+ 71 | -- | | : | 72 | -- | | : | 73 | -- +--cwl---:-cwr--+ 74 | -- : ^ : 75 | -- :.......w.......: 76 | -- 77 | -- ...so you'll need to cut the right box in the correct place, and 78 | -- reassemble the bits. 79 | -- 80 | -- HINT: THE FIRST THREE MARKS IN THIS EPISODE COME FROM ONE PROBLEM. 81 | -- TREAT THEM AS A WHOLE. 82 | 83 | 84 | --------------------------------------------------------------------------- 85 | -- COMPARING THE CUT POSITION -- 86 | --------------------------------------------------------------------------- 87 | 88 | data CutCompare (x x' y y' n : Nat) : Set where 89 | -- Give three constructors for this type which characterize the three 90 | -- possibilities described above whenever 91 | -- x + x' == n and y + y' == n 92 | -- (E.g., take n to be w, x and x' to be cwl and cwr, y and y' to be 93 | -- bwl and bwr. But later, you'll need to do use the same tool for 94 | -- heights.) 95 | -- 96 | -- You will need to investigate what evidence must be packaged in each 97 | -- situation. On the one hand, you need to be able to *generate* the 98 | -- evidence, with cutCompare, below. On the other hand, the evidence 99 | -- must be *useful* when you come to write boxCutKit, further below. 100 | -- Don't expect to know what to put here from the get-go. Figure it 101 | -- out by discovering what you *need*. 102 | -- 103 | -- (1 mark) 104 | 105 | -- Show that whenever you have two ways to express the same n as a sum, 106 | -- you can always deliver the CutCompare evidence. (1 mark) 107 | 108 | cutCompare : (x x' y y' n : Nat) -> x + x' == n -> y + y' == n -> 109 | CutCompare x x' y y' n 110 | cutCompare x x' y y' n xq yq = {!!} 111 | 112 | 113 | --------------------------------------------------------------------------- 114 | -- A CUTKIT FOR BOXES -- 115 | --------------------------------------------------------------------------- 116 | 117 | -- Now, show that you can construct a CutKit for Box X, given a CutKit 118 | -- for X. There will be key points where you get stuck for want of crucial 119 | -- information. The purpose of CutCompare is to *describe* that 120 | -- information. The purpose of cutCompare is to *compute* that information. 121 | -- Note that cutLR and cutTB will work out very similarly, just exchanging 122 | -- the roles of width and height. 123 | -- (1 mark) 124 | 125 | boxCutKit : {X : Nat -> Nat -> Set} -> CutKit X -> CutKit (Box X) 126 | boxCutKit {X} ck = record { cutLR = clr ; cutTB = ctb } where 127 | open CutKit ck 128 | clr : (w h wl wr : Nat) -> 129 | wl + wr == w -> Box X w h -> Box X wl h /*/ Box X wr h 130 | clr w h wl wr wq b = {!!} 131 | ctb : (w h ht hb : Nat) -> 132 | ht + hb == h -> Box X w h -> Box X w ht /*/ Box X w hb 133 | ctb w h ht hb hq b = {!!} 134 | 135 | 136 | --------------------------------------------------------------------------- 137 | -- CROP -- 138 | --------------------------------------------------------------------------- 139 | 140 | -- Show that, given a CutKit, you can implement the "crop" operation which 141 | -- trims a small rectangle out of an enclosing rectangle. 142 | -- (1 mark) 143 | 144 | crop : {X : Nat -> Nat -> Set} -> CutKit X -> 145 | (wl wc wr ht hc hb : Nat) -> 146 | X (wl + wc + wr) (ht + hc + hb) -> X wc hc 147 | crop ck wl wc wr ht hc hb x = {!!} 148 | 149 | -- For fun, practice, and the chance to test your work, try building 150 | -- a nontrivially tiled... 151 | 152 | testBigBox : Box (HoleOr _*C*_) 20 15 153 | testBigBox = {!!} 154 | 155 | -- ...so that you can see this stuff in action: 156 | 157 | textDisplayCutKit : CutKit (Box (HoleOr _*C*_)) 158 | textDisplayCutKit = boxCutKit (holeCutKit matrixCutKit) 159 | 160 | testWeeBox : Box (HoleOr _*C*_) 10 5 161 | testWeeBox = crop textDisplayCutKit 5 10 5 5 5 5 testBigBox 162 | 163 | 164 | --------------------------------------------------------------------------- 165 | -- OVERLAY -- 166 | --------------------------------------------------------------------------- 167 | 168 | -- If we use HoleOr X as the basic tile, we can think of Hole as meaning 169 | -- a bit of a box we can see through. Correspondingly, if we have two 170 | -- boxes (the "front" one and the "back" one), both the same size, we 171 | -- should be able to see through the holes in the front box to whatever 172 | -- stuff is in the back box in the corresponding place. 173 | -- 174 | -- Your task here is to show that you can combine front and back layers 175 | -- into a single box, corresponding to what you would actually see. That 176 | -- is, you will need to fill the front holes in with stuff cut from the 177 | -- back. Which is why you need a CutKit for boxes. 178 | -- 179 | -- Hint: you may be tempted to use crop, but try without crop first. 180 | -- 181 | -- (1 mark) 182 | 183 | overlay : {X : Nat -> Nat -> Set} -> CutKit X -> 184 | {w h : Nat} -> 185 | {- front -} Box (HoleOr X) w h -> 186 | {- back -} Box (HoleOr X) w h -> 187 | {- combined -} Box (HoleOr X) w h 188 | overlay {X} ck = go where 189 | open CutKit (boxCutKit (holeCutKit ck)) 190 | go : {w h : Nat} -> 191 | Box (HoleOr X) w h -> Box (HoleOr X) w h -> Box (HoleOr X) w h 192 | go front back = {!!} 193 | 194 | -- You should ensure (but I won't ask you to prove) that you have thus 195 | -- equipped Box (HoleOr X) w h with the structure of a *monoid* with 196 | -- the neutral value (nil-like thing) being [ Hole ] and the 197 | -- associative operation (append-like thing) being (overlay ck), where 198 | -- ck is your CutKit X. That is, there is such a thing as a totally 199 | -- transparent layer, and you can overlay *any* number of layers by 200 | -- combining any two neighbouring layers at a time. 201 | 202 | -- For fun, and the shape of things to come, build two box tilings. 203 | -- Make sure each has a rectangle of text in the middle and Hole all 204 | -- around. Make sure that the rectangles overlap each other, but not 205 | -- completely. See what happens when you overlay them, either way 206 | -- around. 207 | 208 | rectangleA : Box (HoleOr _*C*_) 20 15 209 | rectangleA = {!!} 210 | 211 | rectangleB : Box (HoleOr _*C*_) 20 15 212 | rectangleB = {!!} 213 | 214 | frontA_backB : 20 *C* 15 215 | frontA_backB = renderHoleOrText (overlay matrixCutKit rectangleA rectangleB) 216 | 217 | frontB_backA : 20 *C* 15 218 | frontB_backA = renderHoleOrText (overlay matrixCutKit rectangleB rectangleA) 219 | -------------------------------------------------------------------------------- /Ex6/Ex6-Setup.agda: -------------------------------------------------------------------------------- 1 | module Ex6-Setup where 2 | 3 | 4 | --------------------------------------------------------------------------- 5 | -- NATURAL NUMBERS -- 6 | --------------------------------------------------------------------------- 7 | 8 | data Nat : Set where 9 | zero : Nat 10 | suc : Nat -> Nat 11 | {-# BUILTIN NATURAL Nat #-} 12 | {-# COMPILED_DATA Nat HaskellSetup.Nat HaskellSetup.Zero HaskellSetup.Suc #-} 13 | 14 | _+_ : Nat -> Nat -> Nat 15 | zero + y = y 16 | suc x + y = suc (x + y) 17 | 18 | infixr 5 _+_ 19 | 20 | 21 | --------------------------------------------------------------------------- 22 | -- ONE, SIGMA TYPES AND BINARY PRODUCT -- 23 | --------------------------------------------------------------------------- 24 | 25 | record One : Set where constructor <> 26 | 27 | record Sg (S : Set)(T : S -> Set) : Set where 28 | constructor _,_ 29 | field 30 | fst : S 31 | snd : T fst 32 | open Sg public 33 | _/*/_ : Set -> Set -> Set 34 | S /*/ T = Sg S \ _ -> T 35 | infixr 3 _/*/_ 36 | infixr 3 _,_ 37 | 38 | 39 | --------------------------------------------------------------------------- 40 | -- EQUALITY, AND SOME FACTS ABOUT SUC AND ADDITION -- 41 | --------------------------------------------------------------------------- 42 | 43 | data _==_ {X : Set}(x : X) : X -> Set where 44 | refl : x == x 45 | infixr 4 _==_ 46 | 47 | transitivity : {X : Set}{x y z : X} -> x == y -> y == z -> x == z 48 | transitivity refl q = q 49 | 50 | sucInj : {x y : Nat} -> suc x == suc y -> x == y 51 | sucInj refl = refl 52 | 53 | sucResp : {x y : Nat} -> x == y -> suc x == suc y 54 | sucResp refl = refl 55 | 56 | plusZeroFact : (x : Nat) -> x + zero == x 57 | plusZeroFact zero = refl 58 | plusZeroFact (suc x) = sucResp (plusZeroFact x) 59 | 60 | plusSucFact : (x y : Nat) -> x + suc y == suc (x + y) 61 | plusSucFact zero y = refl 62 | plusSucFact (suc x) y = sucResp (plusSucFact x y) 63 | 64 | plusCommFact : (x y : Nat) -> y + x == x + y 65 | plusCommFact zero y = plusZeroFact y 66 | plusCommFact (suc x) y 67 | = transitivity (plusSucFact y x) (sucResp (plusCommFact x y)) 68 | 69 | 70 | --------------------------------------------------------------------------- 71 | -- IDENTITY AND COMPOSITION FUNCTIONS -- 72 | --------------------------------------------------------------------------- 73 | 74 | id : {X : Set} -> X -> X 75 | id x = x 76 | 77 | _o_ : {X : Set}{Y : X -> Set}{Z : (x : X) -> Y x -> Set} 78 | (f : {x : X}(y : Y x) -> Z x y)(g : (x : X) -> Y x) -> 79 | (x : X) -> Z x (g x) 80 | (f o g) x = f (g x) 81 | 82 | 83 | --------------------------------------------------------------------------- 84 | -- ORDINARY LISTS -- 85 | --------------------------------------------------------------------------- 86 | 87 | data List (X : Set) : Set where 88 | [] : List X 89 | _::_ : X -> List X -> List X 90 | infixr 6 _::_ 91 | 92 | {-# COMPILED_DATA List [] [] (:) #-} 93 | {-# BUILTIN LIST List #-} 94 | {-# BUILTIN NIL [] #-} 95 | {-# BUILTIN CONS _::_ #-} 96 | 97 | _+-+_ : {X : Set} -> List X -> List X -> List X 98 | [] +-+ ys = ys 99 | (x :: xs) +-+ ys = x :: (xs +-+ ys) 100 | infixr 6 _+-+_ 101 | 102 | concat : {X : Set} -> List (List X) -> List X 103 | concat [] = [] 104 | concat (xs :: xss) = xs +-+ concat xss 105 | 106 | list : {X : Set} -> Nat -> X -> List X 107 | list zero x = [] 108 | list (suc n) x = x :: list n x 109 | 110 | 111 | --------------------------------------------------------------------------- 112 | -- ORDINARY BOOLEANS -- 113 | --------------------------------------------------------------------------- 114 | 115 | data Two : Set where 116 | tt ff : Two 117 | {-# BUILTIN BOOL Two #-} 118 | {-# BUILTIN TRUE tt #-} 119 | {-# BUILTIN FALSE ff #-} 120 | {-# COMPILED_DATA Two Bool True False #-} 121 | 122 | 123 | --------------------------------------------------------------------------- 124 | -- ORDINARY SUMS -- 125 | --------------------------------------------------------------------------- 126 | 127 | data _/+/_ (S T : Set) : Set where 128 | inl : S -> S /+/ T 129 | inr : T -> S /+/ T 130 | infixr 2 _/+/_ 131 | {-# COMPILED_DATA _/+/_ Either Left Right #-} 132 | 133 | 134 | --------------------------------------------------------------------------- 135 | -- CHARACTERS AND STRINGS -- 136 | --------------------------------------------------------------------------- 137 | 138 | postulate -- we just suppose the following things exist... 139 | Char : Set 140 | String : Set 141 | {-# BUILTIN CHAR Char #-} 142 | {-# COMPILED_TYPE Char Char #-} -- ...and by the time we reach Haskell... 143 | {-# BUILTIN STRING String #-} 144 | {-# COMPILED_TYPE String String #-} -- ...they *do* exist! 145 | 146 | primitive -- these are baked in; they even work! 147 | primCharEquality : Char -> Char -> Two 148 | primStringAppend : String -> String -> String 149 | primStringToList : String -> List Char 150 | primStringFromList : List Char -> String 151 | 152 | 153 | --------------------------------------------------------------------------- 154 | -- IO IN HASKELL -- 155 | --------------------------------------------------------------------------- 156 | 157 | postulate -- Haskell has a monad for doing IO, which is our route out 158 | IO : Set -> Set 159 | return : {A : Set} -> A -> IO A 160 | _>>=_ : {A B : Set} -> IO A -> (A -> IO B) -> IO B 161 | infixl 1 _>>=_ 162 | {-# BUILTIN IO IO #-} 163 | {-# COMPILED_TYPE IO IO #-} 164 | {-# COMPILED return (\ _ -> return) #-} 165 | {-# COMPILED _>>=_ (\ _ _ -> (>>=)) #-} 166 | 167 | 168 | --------------------------------------------------------------------------- 169 | -- KEYS -- 170 | --------------------------------------------------------------------------- 171 | 172 | {- Here's the characterization of keys I give you -} 173 | data Direction : Set where up down left right : Direction 174 | data Modifier : Set where normal shift control : Modifier 175 | data Key : Set where 176 | char : Char -> Key 177 | arrow : Modifier -> Direction -> Key 178 | enter : Key 179 | backspace : Key 180 | delete : Key 181 | escape : Key 182 | tab : Key 183 | data Event : Set where 184 | key : (k : Key) -> Event 185 | resize : (w h : Nat) -> Event 186 | 187 | {-# IMPORT ANSIEscapes #-} 188 | {-# IMPORT HaskellSetup #-} 189 | {-# COMPILED_DATA Direction 190 | ANSIEscapes.Direction 191 | ANSIEscapes.DU ANSIEscapes.DD ANSIEscapes.DL ANSIEscapes.DR #-} 192 | {-# COMPILED_DATA Modifier 193 | HaskellSetup.Modifier 194 | HaskellSetup.Normal HaskellSetup.Shift HaskellSetup.Control #-} 195 | {-# COMPILED_DATA Key 196 | HaskellSetup.Key 197 | HaskellSetup.Char HaskellSetup.Arrow HaskellSetup.Enter 198 | HaskellSetup.Backspace HaskellSetup.Delete HaskellSetup.Escape 199 | HaskellSetup.Tab #-} 200 | {-# COMPILED_DATA Event 201 | HaskellSetup.Event 202 | HaskellSetup.Key HaskellSetup.Resize #-} 203 | 204 | 205 | --------------------------------------------------------------------------- 206 | -- COLOURS -- 207 | --------------------------------------------------------------------------- 208 | 209 | data Colour : Set where 210 | black red green yellow blue magenta cyan white : Colour 211 | {-# COMPILED_DATA Colour HaskellSetup.Colour 212 | HaskellSetup.Black HaskellSetup.Red HaskellSetup.Green 213 | HaskellSetup.Yellow HaskellSetup.Blue HaskellSetup.Magenta 214 | HaskellSetup.Cyan HaskellSetup.White #-} 215 | 216 | 217 | --------------------------------------------------------------------------- 218 | -- ACTIONS -- 219 | --------------------------------------------------------------------------- 220 | 221 | data Action : Set where 222 | goRowCol : Nat -> Nat -> Action -- top left is zero zero 223 | sendText : List Char -> Action 224 | move : Direction -> Nat -> Action -- which way and how much 225 | fgText : Colour -> Action 226 | bgText : Colour -> Action 227 | {-# COMPILED_DATA Action HaskellSetup.Action 228 | HaskellSetup.GoRowCol HaskellSetup.SendText HaskellSetup.Move 229 | HaskellSetup.FgText HaskellSetup.BgText #-} 230 | 231 | 232 | --------------------------------------------------------------------------- 233 | -- HASKELL TUPLES -- 234 | --------------------------------------------------------------------------- 235 | 236 | data _/**/_ (S T : Set) : Set where 237 | _,_ : S -> T -> S /**/ T 238 | {-# COMPILED_DATA _/**/_ (,) (,) #-} 239 | 240 | data Thud : Set where <> : Thud 241 | {-# COMPILED_DATA Thud () () #-} 242 | 243 | 244 | -------------------------------------------------------------------------------- /Ex5/Edit.agda: -------------------------------------------------------------------------------- 1 | module Edit where 2 | 3 | {- This is the file where you should work. -} 4 | 5 | open import AgdaSetup 6 | 7 | {- The key editor data structure is the cursor. A Cursor M X represents 8 | being somewhere in the middle of a sequence of X values, holding an M. -} 9 | 10 | record Cursor (M X : Set) : Set where 11 | constructor _<[_]>_ 12 | field 13 | beforeMe : Bwd X 14 | atMe : M 15 | afterMe : List X 16 | infix 4 _<[_]>_ 17 | 18 | {- An editor buffer is a nested cursor: we're in the middle of a bunch of 19 | *lines*, holding a cursor for the current line, which puts us in the 20 | middle of a bunch of characters, holding the element of One. -} 21 | Buffer : Set 22 | Buffer = Cursor (Cursor One Char) (List Char) 23 | 24 | {- This operator, called "chips", shuffles the elements from a backward list 25 | on to the start of a forward list, keeping them in the same order. -} 26 | _<>>_ : {X : Set} -> Bwd X -> List X -> List X 27 | [] <>> xs = xs 28 | (xz <: x) <>> xs = xz <>> (x :> xs) 29 | 30 | {- The "fish" operator goes the other way. -} 31 | _<><_ : {X : Set} -> Bwd X -> List X -> Bwd X 32 | xz <>< [] = xz 33 | xz <>< (x :> xs) = (xz <: x) <>< xs 34 | 35 | {- You can turn a buffer into a list of lines, preserving its text. -} 36 | bufText : Buffer -> List (List Char) 37 | bufText 38 | (sz <[ 39 | cz <[ <> ]> cs 40 | ]> ss) 41 | = sz <>> ((cz <>> cs) :> ss) 42 | 43 | {- Here's an example of a proof of a fact about fish and chips. -} 44 | firstFishFact : {X : Set} -> (xz : Bwd X)(xs : List X) -> 45 | (xz <>< xs) <>> [] == xz <>> xs 46 | firstFishFact xz [] = refl 47 | firstFishFact xz (x :> xs) = firstFishFact (xz <: x) xs 48 | 49 | {- You will need more such facts. -} 50 | 51 | {- EXERCISE 5.1 -} 52 | {- When we start the editor with the command 53 | ./Edit foo.txt 54 | the contents of foo.txt will be turned into a list of lines. 55 | Your (not so tricky) mission is to turn the file contents into a buffer which 56 | contains the same text. 57 | (1 mark) 58 | -} 59 | initBuf : List (List Char) -> Buffer 60 | initBuf ss = 61 | [] <[ 62 | [] <[ <> ]> [] 63 | ]> [] 64 | {- As you can see, the current version will run, but it always gives the empty 65 | buffer, which is not what we want unless the input is empty. -} 66 | 67 | {- Next comes the heart of the editor. You get a keystroke and the current buffer, 68 | and you have to say what is the new buffer. You also have to say what is the 69 | extent of the change. 70 | 71 | The tricky part is this: you have to be honest enough about your change 72 | report, so that we don't underestimate the amount of updating the screen needs. 73 | -} 74 | 75 | Honest : Buffer -> Change /*/ Buffer -> Set 76 | Honest b (allQuiet , b') = b == b' 77 | Honest b (cursorMove , b') = bufText b == bufText b' 78 | Honest (sz <[ _ ]> ss) (lineEdit , (sz' <[ _ ]> ss')) = (sz == sz') /*/ (ss == ss') 79 | Honest _ (bigChange , _) = One 80 | 81 | record UpdateFrom (b : Buffer) : Set where -- b is the starting buffer 82 | constructor _///_ 83 | field 84 | update : Change /*/ Buffer -- change and new buffer 85 | honest : Honest b update 86 | open UpdateFrom 87 | infix 2 _///_ 88 | 89 | {- EXERCISE 5.2 -} 90 | {- Implement the appropriate behaviour for as many keystrokes as you can. 91 | I have done a couple for you, but I don't promise to have done them 92 | correctly. -} 93 | keystroke : Key -> (b : Buffer) -> UpdateFrom b 94 | keystroke (char c) 95 | (sz <[ 96 | cz <[ <> ]> cs 97 | ]> ss) 98 | = lineEdit , 99 | (sz <[ 100 | cz <[ <> ]> c :> cs 101 | ]> ss) 102 | /// refl , refl -- see? same above and below 103 | keystroke (arrow normal right) 104 | (sz <: s <[ 105 | [] <[ <> ]> cs 106 | ]> ss) 107 | = cursorMove , 108 | (sz <[ ([] <>< s) <[ <> ]> [] ]> cs :> ss) 109 | /// within (\ x -> sz <>> (x :> cs :> ss)) turn s into ([] <>< s) <>> [] 110 | because symmetry (firstFishFact [] s) 111 | keystroke k b = allQuiet , b /// refl 112 | {- Please expect to need to invent extra functions, e.g., to measure where you 113 | are, so that up and down arrow work properly. -} 114 | {- Remember also that you can always overestimate the change by saying bigChange, 115 | which needs only a trivial proof. But you may find that the display will flicker 116 | badly if you do. -} 117 | {- (char c) 1 mark 118 | enter 2 marks 119 | backspace delete 2 marks for the pair 120 | left right 2 marks for the pair (with cursorMove change) 121 | up down 2 marks for the pair (with cursorMove change) 122 | -} 123 | 124 | 125 | {- EXERCISE 5.3 -} 126 | {- You will need to improve substantially on my implementation of the next component, 127 | whose purpose is to update the window. Mine displays only one line! -} 128 | render : 129 | Nat /*/ Nat -> -- height and width of window -- CORRECTION! width and height 130 | Nat /*/ Nat -> -- first visible row, first visible column 131 | Change /*/ Buffer -> -- what just happened 132 | List Action /*/ -- how to update screen 133 | (Nat /*/ Nat) -- new first visible row, first visible column 134 | render _ tl (allQuiet , _) = ([] , tl) 135 | render _ tl (_ , (_ <[ cz <[ <> ]> cs ]> _)) 136 | = (goRowCol 0 0 :> sendText (cz <>> cs) :> []) , tl 137 | {- The editor window gives you a resizable rectangular viewport onto the editor buffer. 138 | You get told 139 | the current size of the viewport 140 | which row and col of the buffer are at the top left of the viewport 141 | (so you can handle documents which are taller or wider than the window) 142 | the most recent change report and buffer 143 | 144 | You need to figure out whether you need to move the viewport 145 | (by finding out if the cursor is still within the viewport) 146 | and if so, where to. 147 | 148 | You need to figure out what to redisplay. If the change report says 149 | lineEdit and the viewport has not moved, you need only repaint the 150 | current line. If the viewport has moved or the change report says 151 | bigChange, you need to repaint the whole buffer. 152 | 153 | You will need to be able to grab a rectangular region of text from the 154 | buffer, but you do know how big and where from. 155 | 156 | Remember to put the cursor in the right place, relative to where in 157 | the buffer the viewport is supposed to be. The goRowCol action takes 158 | *viewport* coordinates, not *buffer* coordinates! You will need to 159 | invent subtraction! 160 | -} 161 | {- Your code does not need to worry about resizing the window. My code does 162 | that. On detecting a size change, my code just calls your code with a 163 | bigChange report and the same buffer, so if you are doing a proper repaint, 164 | the right thing will happen. -} 165 | {- 2 marks for ensuring that a buffer smaller than the viewport displays 166 | correctly, with the cursor in the right place, if nobody changes 167 | the viewport size 168 | 2 marks for ensuring that the cursor remains within the viewport even if 169 | the viewport needs to move 170 | 1 mark for ensuring that lineEdit changes need only affect one line of 171 | the display (provided the cursor stays in the viewport) 172 | -} 173 | 174 | {- FOR MASOCHISTS ONLY, you have a chance to be even more creative. You have 175 | spare detectable keys that you could invent meanings for. You also have the 176 | freedom to change the definition of Buffer, as my code does not care what 177 | a Buffer is: it only needs to know how to initialize, update and render, 178 | and these are defined by you. 179 | 180 | Additional structural cursor moves (beginning and end of line, etc) are quite 181 | easy. Going left or right word-by-word would be more fun: you can match 182 | against a pattern such as ' '. 183 | 184 | Selection and cut/copy/paste are more challenging. For these, you need to 185 | modify the Buffer structure to remember the clipboard contents (if any), 186 | and to manage the extent of any selected region. 187 | 188 | If you feel the need to vary the foreground or background colour of the displayed 189 | text (e.g. to show a selection), please let me know. 190 | 191 | (SUBTEXT: this exercise is a cut-down version of last year's post-Easter 192 | task. Feel free to ignore the cutting-down.) 193 | -} 194 | 195 | 196 | {- Your code then hooks into mine to produce a top level executable! -} 197 | main : IO One 198 | main = mainLoop initBuf (\ k b -> update (keystroke k b)) render 199 | 200 | {- To build the editor, just do 201 | make 202 | in a shell window (with Ex5 the current directory). 203 | To run the editor, once compiled, do 204 | ./Edit 205 | in the shell window, which should become the editor window. 206 | To quit the editor, do 207 | ctrl-C 208 | like an old-fashioned soul. 209 | -} 210 | 211 | {- There is no one right way to do this exercise, and there is some scope for 212 | extension. It's important that you get in touch if you need help, either in 213 | achieving the basic deliverable, or in finding ways to explore beyond it. 214 | -} 215 | -------------------------------------------------------------------------------- /Ex6/Ex6-2-Box-Sol.agda: -------------------------------------------------------------------------------- 1 | module Ex6-2-Box-Sol where 2 | 3 | open import Ex6-Setup 4 | open import Ex6-1-Vec-Sol 5 | 6 | --------------------------------------------------------------------------- 7 | -- BOXES (5 marks) -- 8 | --------------------------------------------------------------------------- 9 | 10 | -- Boxes are sized rectangular tilings which fit together precisely. 11 | -- They allow us to talk about the use of 2D space, e.g., on a screen. 12 | 13 | data Box (X : Nat -> Nat -> Set)(w h : Nat) : Set where 14 | -- ^basic-tile width^ ^height 15 | 16 | [_] : X w h -> Box X w h 17 | -- a basic tile is a tiling 18 | 19 | leri : (wl : Nat) (bl : Box X wl h) 20 | (wr : Nat) (br : Box X wr h) 21 | -> wl + wr == w -> Box X w h 22 | -- combine "left" and "right" tilings the same height 23 | -- to make a tiling with their total width 24 | 25 | tobo : (ht : Nat) (bt : Box X w ht) 26 | (hb : Nat) (bb : Box X w hb) 27 | -> ht + hb == h -> Box X w h 28 | -- combine "top" and "bottom" tilings the same width 29 | -- to make a tiling with their total height 30 | 31 | 32 | --------------------------------------------------------------------------- 33 | -- MONADIC STRUCTURE -- 34 | --------------------------------------------------------------------------- 35 | 36 | -- If X and Y are both kinds of "sized stuff", we can say what it is to be 37 | -- a "size-preserving function" between them. 38 | 39 | _[]>_ : (X Y : Nat -> Nat -> Set) -> Set 40 | X []> Y = {w h : Nat} -> X w h -> Y w h 41 | -- A size preserving function turns an X of some size 42 | -- into a Y the same size. 43 | 44 | -- Think of X as "sized placeholders". If we have a way to turn each 45 | -- placeholder into a tiling which fits into the place, we should be 46 | -- able to deploy it across a whole tiling of placeholders. Check 47 | -- that you can achieve that. 48 | 49 | _=<<_ : forall {X Y} -> X []> Box Y -> Box X []> Box Y 50 | f =<< [ x ] = f x 51 | f =<< leri wl bl wr br x = leri wl (f =<< bl) wr (f =<< br) x 52 | f =<< tobo ht bt hb bb x = tobo ht (f =<< bt) hb (f =<< bb) x 53 | 54 | -- Using _=<<_, rather than more recursion, define... 55 | 56 | mapBox : forall {X Y} -> X []> Y -> Box X []> Box Y 57 | mapBox f b = ([_] o f) =<< b 58 | -- roll out a size-preserving function on basic tiles to a whole tiling 59 | 60 | joinBox : forall {X} -> Box (Box X) []> Box X 61 | joinBox b = id =<< b 62 | -- turn a tiling-of-tilings into a simple tiling 63 | 64 | -- (1 mark) for the lot 65 | 66 | 67 | --------------------------------------------------------------------------- 68 | -- PASTE KITS AND MATRICES -- 69 | --------------------------------------------------------------------------- 70 | 71 | -- A "paste kit" for sized stuff is whatever you need to combine stuff 72 | -- left-to-right and top-to-bottom 73 | 74 | record PasteKit (X : Nat -> Nat -> Set) : Set where 75 | field 76 | leriPaste : (wl wr : Nat){h : Nat} -> X wl h -> X wr h -> X (wl + wr) h 77 | toboPaste : {w : Nat}(ht hb : Nat) -> X w ht -> X w hb -> X w (ht + hb) 78 | 79 | -- Show that a PasteKit is just what you need to turn a tiling of 80 | -- stuff into some stuff. (1 mark) 81 | 82 | pasteBox : {X : Nat -> Nat -> Set} -> PasteKit X -> Box X []> X 83 | pasteBox {X} pk = go where 84 | open PasteKit pk -- brings leriPaste and toboPaste into scope 85 | go : Box X []> X 86 | go [ x ] = x 87 | go (leri wl lb wr rb refl) = leriPaste wl wr (go lb) (go rb) 88 | go (tobo ht tb hb bb refl) = toboPaste ht hb (go tb) (go bb) 89 | 90 | -- If you were wondering what any of this had to do with part 1, here we 91 | -- go... 92 | 93 | Matrix : Set -> Nat -> Nat -> Set 94 | Matrix C w h = Vec (Vec C w) h 95 | -- matrices are "sized stuff", represented as a vector the right height 96 | -- of rows which are vectors the right width of some sort of unit "cell". 97 | 98 | -- Using the equipment you built in part 1, give matrices their PasteKit. 99 | -- (1 mark) 100 | 101 | matrixPasteKit : {C : Set} -> PasteKit (Matrix C) 102 | matrixPasteKit = record { 103 | leriPaste = \ _ _ ls rs -> vec _++_ <*> ls <*> rs ; 104 | toboPaste = \ _ _ -> _++_ } 105 | 106 | 107 | --------------------------------------------------------------------------- 108 | -- INTERLUDE: TESTING WITH TEXT -- 109 | --------------------------------------------------------------------------- 110 | 111 | -- Turn a list into a vector, either by truncating or padding with 112 | -- a given dummy element. 113 | paddy : {X : Set} -> X -> List X -> {n : Nat} -> Vec X n 114 | paddy _ _ {zero} = [] 115 | paddy x [] {suc n} = x :: paddy x [] {n} 116 | paddy x (y :: ys) {suc n} = y :: paddy x ys {n} 117 | 118 | -- Use that to make vectors of characters from strings, padding with space. 119 | [-_-] : String -> {n : Nat} -> Vec Char n 120 | [- s -] = paddy ' ' (primStringToList s) 121 | 122 | -- Now we can have character matrices of a given size 123 | _*C*_ : Nat -> Nat -> Set 124 | w *C* h = Matrix Char w h 125 | 126 | -- Here are some. 127 | mat43-1 : 4 *C* 3 128 | mat43-1 = [- "post" -] :: [- "cake" -] :: [- "flop" -] :: [] 129 | 130 | mat43-2 : 4 *C* 3 131 | mat43-2 = [- "horn" -] :: [- "walk" -] :: [- "ping" -] :: [] 132 | 133 | mat22 : 2 *C* 2 134 | mat22 = [- "go" -] :: [- "do" -] :: [] 135 | 136 | mat62 : 6 *C* 2 137 | mat62 = [- "getter" -] :: [- "gooder" -] :: [] 138 | 139 | -- Put them together as a tiling. 140 | myTiling : Box _*C*_ 8 5 141 | myTiling = tobo 3 (leri 4 [ mat43-1 ] 4 [ mat43-2 ] refl) 142 | 2 (leri 2 [ mat22 ] 6 [ mat62 ] refl) refl 143 | 144 | -- Paste all the pieces and see what you get! 145 | myText : 8 *C* 5 146 | myText = pasteBox matrixPasteKit myTiling 147 | 148 | 149 | --------------------------------------------------------------------------- 150 | -- CUT KITS, MATRICES -- 151 | --------------------------------------------------------------------------- 152 | 153 | -- A "cut kit" for sized stuff is whatever you need to cut stuff into 154 | -- smaller pieces: left-and-right pieces, or top-and-bottom pieces. 155 | 156 | record CutKit (X : Nat -> Nat -> Set) : Set where 157 | field 158 | cutLR : (w h wl wr : Nat) -> wl + wr == w -> 159 | X w h -> X wl h /*/ X wr h 160 | cutTB : (w h ht hb : Nat) -> ht + hb == h -> 161 | X w h -> X w ht /*/ X w hb 162 | 163 | -- Equip matrices with their CutKit. (1 mark) 164 | 165 | matrixCutKit : {C : Set} -> CutKit (Matrix C) 166 | matrixCutKit {C} = record { 167 | cutLR = \ {.(wl + wr) h wl wr refl css -> 168 | vunzip (vec (vchop wl) <*> css)} ; 169 | cutTB = \ {w .(ht + hb) ht hb refl -> vchop ht } } 170 | 171 | 172 | --------------------------------------------------------------------------- 173 | -- HOLES -- 174 | --------------------------------------------------------------------------- 175 | 176 | -- We might want to make sure that, whatever other basic tiles are in play, 177 | -- we can have tiles which are "missing", as if we had cut rectangular 178 | -- holes in a piece of paper. 179 | 180 | data HoleOr (X : Nat -> Nat -> Set)(w h : Nat) : Set where 181 | Hole : HoleOr X w h 182 | [_] : X w h -> HoleOr X w h 183 | 184 | -- A HoleOr X is (you guessed it) either a hole or an X. 185 | 186 | -- Show that if X has a CutKit, so has HoleOr X. What do you get when you 187 | -- cut up a hole? (1 mark) 188 | 189 | holeCutKit : {X : Nat -> Nat -> Set} -> CutKit X -> CutKit (HoleOr X) 190 | holeCutKit {X} ck = record { cutLR = clr ; cutTB = ctb } where 191 | open CutKit ck 192 | clr : (w h wl wr : Nat) -> 193 | wl + wr == w -> HoleOr X w h -> HoleOr X wl h /*/ HoleOr X wr h 194 | clr w h wl wr wq Hole = Hole , Hole 195 | clr w h wl wr wq [ x ] with cutLR w h wl wr wq x 196 | clr w h wl wr wq [ x ] | xl , xr = [ xl ] , [ xr ] 197 | ctb : (w h ht hb : Nat) -> 198 | ht + hb == h -> HoleOr X w h -> HoleOr X w ht /*/ HoleOr X w hb 199 | ctb w h ht hb hq Hole = Hole , Hole 200 | ctb w h ht hb hq [ x ] with cutTB w h ht hb hq x 201 | ctb w h ht hb hq [ x ] | xt , xb = [ xt ] , [ xb ] 202 | 203 | 204 | --------------------------------------------------------------------------- 205 | -- A BIT OF FUN -- 206 | --------------------------------------------------------------------------- 207 | 208 | -- Show that you can turn holes into spaces. 209 | 210 | holeSpace : HoleOr _*C*_ []> _*C*_ 211 | holeSpace Hole = vec (vec ' ') 212 | holeSpace [ x ] = x 213 | 214 | -- Show how to render a tiling made of text or holes as text. 215 | 216 | renderHoleOrText : Box (HoleOr _*C*_) []> _*C*_ 217 | renderHoleOrText = pasteBox matrixPasteKit o mapBox holeSpace 218 | 219 | -- Make a test example and see! 220 | 221 | myTest : 8 *C* 6 222 | myTest = renderHoleOrText 223 | (leri 3 (tobo 4 [ [ vec (vec '*') ] ] 2 [ Hole ] refl) 224 | 5 (tobo 2 [ Hole ] 4 [ [ vec (vec '=') ] ] refl) refl) 225 | 226 | 227 | --------------------------------------------------------------------------- 228 | -- NEXT TIME... -- 229 | --------------------------------------------------------------------------- 230 | 231 | -- Have a wee think about what you might need to equip Box X with a CutKit. 232 | -------------------------------------------------------------------------------- /Ex4Lec.agda: -------------------------------------------------------------------------------- 1 | module Ex4Lec where 2 | 3 | {- I'm sorry I haven't quite finished setting this exercise yet, but by 4 | the joy of version control, the rest of it can be merged in later 5 | (quite soon). At least you can get cracking: I promise not to break 6 | anything, just to add a bit more on the end. 7 | 8 | The deadline for this is midnight on the Monday of Week 12 (15 Dec). 9 | It'd be good to get the marks in before Christmas, but if the end of 10 | term is looking deadlinetastic, please open negotiations. 11 | -} 12 | 13 | open import Ex1Prelude 14 | open import IxCon 15 | 16 | {-# BUILTIN BOOL Two #-} 17 | {-# BUILTIN TRUE tt #-} 18 | {-# BUILTIN FALSE ff #-} 19 | {-# BUILTIN LIST List #-} 20 | {-# BUILTIN NIL [] #-} 21 | {-# BUILTIN CONS _:>_ #-} 22 | 23 | postulate -- this means that we just suppose the following things exist... 24 | Char : Set 25 | String : Set 26 | {-# BUILTIN CHAR Char #-} 27 | {-# BUILTIN STRING String #-} 28 | 29 | primitive -- these are baked in; they even work! 30 | primCharEquality : Char -> Char -> Two 31 | primStringAppend : String -> String -> String 32 | primStringToList : String -> List Char 33 | primStringFromList : List Char -> String 34 | 35 | --------------------------------------------------------------------------- 36 | -- WRITING FILES, AN INTERFACE 37 | --------------------------------------------------------------------------- 38 | 39 | {- If you possess the ability to open a file for writing, you might 40 | have the following interface. -} 41 | 42 | -- States 43 | data WriteState : Set where 44 | opened closed : WriteState -- do you currently have a file open or not? 45 | 46 | -- Commands 47 | data WriteC : WriteState -> Set where 48 | openWrite : (fileName : String) -> WriteC closed 49 | writeChar : Char -> WriteC opened 50 | closeWrite : WriteC opened 51 | 52 | -- Responses 53 | WriteR : (j : WriteState)(c : WriteC j) -> Set 54 | WriteR .closed (openWrite fileName) = WriteState -- we get told whether it worked 55 | WriteR .opened (writeChar x) = One -- always works 56 | WriteR .opened closeWrite = One -- always works 57 | 58 | {- 4.1 Implement the following operation which determines the next 59 | state. You should ensure that you can write characters only to 60 | a successfully opened file, and that you can write as many as 61 | you want. It should also be possible to insist that a process 62 | closes its file. -} 63 | 64 | writeNext : (j : WriteState)(c : WriteC j) -> WriteR j c -> WriteState 65 | writeNext j c r = {!!} 66 | 67 | -- the file writing interface, assembled as an indexed container 68 | WRITE : WriteState => WriteState 69 | WRITE = WriteC ReadState -- eof is tt if we're at end of file 82 | closed : ReadState 83 | 84 | {- 4.2 Finish the READ implementation, in accordance with the description. -} 85 | 86 | -- Commands 87 | data ReadC : ReadState -> Set where 88 | openRead : {- your stuff -} ReadC {!!} -- needs a filename; might not open successfully; 89 | -- might open an empty file 90 | readChar : {- your stuff -} ReadC {!!} -- makes sense only if we're not at end of file 91 | -- and might take us to end of file 92 | closeRead : {- your stuff -} ReadC {!!} -- makes sense only if the file is open 93 | 94 | -- Responses 95 | ReadR : (j : ReadState)(c : ReadC j) -> Set 96 | ReadR j c = {!!} 97 | 98 | -- next State; you need to make sure the response gives enough info 99 | readNext : (j : ReadState)(c : ReadC j) -> ReadR j c -> ReadState 100 | readNext j c r = {!!} 101 | 102 | READ : ReadState => ReadState 103 | READ = ReadC I => I -> I => I -> I => I 118 | CRn0 =+= CRn1 = {!!} 119 | 120 | --------------------------------------------------------------------------- 121 | -- WHEN IGNORANCE IS BLISS, BIS 122 | --------------------------------------------------------------------------- 123 | 124 | {- 4.4 If we have a command-response interface with index I representing 125 | states of the system, show that we can index basically the same 126 | commands and responses over a state, I /*/ J, where the J is just 127 | useless information which never changes. (This operation isn't 128 | super-useful on its own, but it's handy in combination with other 129 | things. -} 130 | 131 | GrowR : {I J : Set} -> I => I -> (I /*/ J) => (I /*/ J) 132 | GrowR CRn = {!!} 133 | 134 | -- do the same for "growing the index on the left" 135 | 136 | GrowL : {I J : Set} -> I => I -> (J /*/ I) => (J /*/ I) 137 | GrowL CRn = {!!} 138 | 139 | 140 | --------------------------------------------------------------------------- 141 | -- COMBINING TWO INTERFACES WITH SEPARATE STATE 142 | --------------------------------------------------------------------------- 143 | 144 | {- 4.5 Making use of 4.4 and 4.5, show how to combine two interfaces which 145 | operate independently on separate state: commands from one should 146 | not affect the state of the other. 147 | -} 148 | 149 | _<+>_ : {I0 I1 : Set} -> I0 => I0 -> I1 => I1 -> (I0 /*/ I1) => (I0 /*/ I1) 150 | CRn0 <+> CRn1 = {!!} 151 | 152 | 153 | --------------------------------------------------------------------------- 154 | -- ERROR REPORTING, AN INTERFACE 155 | --------------------------------------------------------------------------- 156 | 157 | {- I'm building the next bit for you. 158 | 159 | When things go wrong, we need to trigger an error condition and abort 160 | mission. However, if we have other stuff going on (open files, etc), 161 | it may not always be ok to drop everything and run away. There will 162 | be some states in which it is safe to escape (and deliver a suitable 163 | error message, perhaps) and other states in which escape should be 164 | impossible. 165 | 166 | If it is safe to issue an error message, we should be able to do so 167 | without fear of any response from the environment that would oblige 168 | us to carry on. 169 | -} 170 | 171 | data ErrorC {I : Set}(SafeMessage : I -> Set)(i : I) : Set where 172 | error : SafeMessage i -> ErrorC SafeMessage i 173 | -- the SafeMessage parameter tells us what is an acceptable 174 | -- error message in any given state; in states where this gives 175 | -- Zero, it will be impossible to trigger an error! 176 | 177 | ErrorR : {I : Set}{SafeMessage : I -> Set}(i : I)(c : ErrorC SafeMessage i) -> Set 178 | ErrorR _ _ = Zero -- there's no comeback 179 | 180 | errorNext : {I : Set}{SafeMessage : I -> Set} 181 | (i : I)(c : ErrorC SafeMessage i) -> ErrorR i c -> I 182 | errorNext i c () -- so we don't have to say how the state will evolve 183 | 184 | ERROR : {I : Set}(SafeMessage : I -> Set) -> I => I 185 | ERROR SafeMessage = ErrorC SafeMessage CPState 210 | CPInterface = {!!} 211 | 212 | {- 4.6.2 Secondly, you should implement your copying process, working to your 213 | interface. I will let you switch off the termination checker: you cannot 214 | predict in advance how long the copying process will go on, as you have 215 | not seen the source file yet. (Later, we'll learn how to be honest about 216 | things which might go on for ever, but for now, let's cheat.) 217 | -} 218 | {-# NO_TERMINATION_CHECK #-} 219 | 220 | cp : (sourceFile targetFile : String) -> Game CPInterface {!!} {!!} 221 | cp sourceFile targetFile = {!!} 222 | 223 | {- HINTS 224 | You will certainly need to build some extra bits and pieces. 225 | 226 | You have the components for reading, writing and error handling, and 227 | suitable kit with which to combine them. Reading and writing don't 228 | interfere with each other, but it's important to make sure that you 229 | can't bomb out with an error, so some shared state seems important. 230 | 231 | There are really two phases to the process: 232 | (1) getting the files open -- this may go wrong 233 | (2) copying from one to the other -- this will work if we reach it 234 | You might want to split these phases apart. 235 | -} 236 | 237 | --------------------------------------------------------------- 238 | -- TO BE CONTINUED... 239 | --------------------------------------------------------------- 240 | -------------------------------------------------------------------------------- /Ex6/Ex6-5-App.agda: -------------------------------------------------------------------------------- 1 | module Ex6-5-App where 2 | 3 | open import Ex6-Setup 4 | open import Ex6-1-Vec-Sol 5 | open import Ex6-2-Box-Sol 6 | open import Ex6-3-Cut-Sol 7 | open import Ex6-4-Dis-Sol 8 | 9 | 10 | --------------------------------------------------------------------------- 11 | -- SMOOTHER AND MORE INTERESTING APPLICATIONS (5 marks) -- 12 | --------------------------------------------------------------------------- 13 | 14 | -- As these are the 5 marks which get you from "awesome first" to 15 | -- "perfection", I'm leaving this task more open. There are two 16 | -- parts to it. 17 | 18 | -- Part 1. MINIMIZE FLICKER. The episode 4 setup repaints the whole 19 | -- screenful every time. With a little bit of redesign, it's possible 20 | -- to ensure that you repaint only what changes. Re-engineer the 21 | -- functionality of exercise 4 to reduce flicker. 22 | -- (2 marks) 23 | 24 | -- Part 2. PUT SOMETHING INTERESTING IN THE RECTANGLES. It's one thing 25 | -- being able to shove rectangles around the screen, but it would be 26 | -- good if there was some actual content to them. You're free to design 27 | -- whatever you like (and to raid Ex5 for spare parts, of course), but 28 | -- I have some marking guidelines. 29 | -- any nontrivial static content in the rectangles scores 1 mark, 30 | -- provided you can still move and resize them; 31 | -- treating the rectangle as a viewport into some content larger than 32 | -- the rectangle scores 1 mark, provided you can move the viewport 33 | -- all around the content 34 | -- significant keyboard interaction with the rectangle at the front, 35 | -- beyond what is needed for moving it, resizing it and refocusing 36 | -- it, is worth 1 mark 37 | -- (3 marks) 38 | 39 | -- If you can think of other interesting things you might want to do that 40 | -- don't quite fit the mark scheme for part 2, by all means pitch them to 41 | -- me and I'll tell you how much I'd be willing to "pay" for them. 42 | 43 | 44 | -- The rest of the file consists of some bits and pieces I came up with 45 | -- while I was experimenting. You are free to adopt, adapt or reject these 46 | -- components. 47 | 48 | 49 | --------------------------------------------------------------------------- 50 | -- GENERALIZING OVERLAY TO MASKING -- 51 | --------------------------------------------------------------------------- 52 | 53 | -- Here's what I should have asked you to build in episode 3. 54 | 55 | mask : {X Y Z : Nat -> Nat -> Set} -> CutKit Y -> 56 | ({w h : Nat} -> X w h -> Box Y w h -> Box Z w h) -> 57 | {w h : Nat} -> 58 | {- front -} Box X w h -> 59 | {- back -} Box Y w h -> 60 | {- combined -} Box Z w h 61 | mask {X}{Y}{Z} ck m = go where 62 | open CutKit (boxCutKit ck) 63 | go : {w h : Nat} -> Box X w h -> Box Y w h -> Box Z w h 64 | go xb yb = {!!} 65 | 66 | -- The idea, as with "overlay", is that the box of X stuff is in front 67 | -- and the box of Y stuff is behind. You need to combine them to make 68 | -- a box of Z stuff. Fortunately, once you've cut your way through the 69 | -- structure to reach each basic X tile, the parameter m is just what 70 | -- you need to know to combine that tile with the Y box to make a Z box. 71 | 72 | -- You should find that the implementation is almost the same as "overlay" 73 | -- but the extra generality is quite useful. You might find the following 74 | -- concepts helpful. 75 | 76 | Update : Nat -> Nat -> Set 77 | Update w h 78 | = Two -- does it demand repainting? 79 | /*/ HoleOr (Matrix ColourChar) w h -- transparent or opaque stuff? 80 | 81 | -- A Box Update is more informative than a Painting, in that every primitive 82 | -- tile tells you whether it is "new" or not; now you can build the logic 83 | -- to combine the changes which happen in each layer. In particular, you can 84 | -- model the idea that moving or resizing in the front can reveal stuff which 85 | -- used to be hidden at the back: that's a "new hole", and even if what's 86 | -- behind it hasn't changed, you'll need to update the display. 87 | 88 | Selection : Nat -> Nat -> Set 89 | Selection = Box \ _ _ -> Two 90 | 91 | -- A selection is a tiling of the rectangle with tt or ff. You can lift all 92 | -- the usual logical operations to selections using mask and mapBox. For 93 | -- example, XOR-ing selections gives you everything in one but not the other, 94 | -- which might help you spot what has changed. 95 | 96 | 97 | --------------------------------------------------------------------------- 98 | -- RUN-LENGTH ENCODING INACTIVITY -- 99 | --------------------------------------------------------------------------- 100 | 101 | -- An idea which might be useful in helping you to manage more selective 102 | -- redrawing is to build the idea of "doing nothing for a bit" into the 103 | -- lists of actions that you build up. Think about updating one line of 104 | -- the display: it might sometimes help to be able to say "keep the next 105 | -- n cells as they were", which you could interpret as a cursor move, rather 106 | -- than a text output. 107 | 108 | -- Correspondingly, you might benefit from a data structure like this: 109 | 110 | data Skippy (X : Set) : Set where 111 | [] : Skippy X -- stop 112 | _::_ : X -> Skippy X -> Skippy X -- give one X then keep going 113 | _>_ : Nat -> Skippy X -> Skippy X -- skip n places, then keep going 114 | 115 | -- Now, when you work with these structures, you should enforce that 116 | -- (i) you never have zero > xs (if there's nothing to skip, don't) 117 | -- (ii) you never have m > n > xs (don't skip twice, skip further) 118 | 119 | -- It's possible to refine the type Skippy to enforce those properties by 120 | -- the power of type checking. Or you could just make sure you never cheat 121 | -- by the more traditional method of defining a "smart constructor" 122 | 123 | _>>_ : {X : Set} -> Nat -> Skippy X -> Skippy X 124 | -- special cases go here 125 | n >> xs = n > xs 126 | 127 | -- The definition I've given you isn't very smart: >> is the same as >. 128 | -- But the idea is that you add some special cases before that last line 129 | -- which catch the possibilities that should never happen and do something 130 | -- else instead. Now you can define operations like concatenation, using 131 | -- the smart constructor in place of the regular one. 132 | 133 | _+>+_ : {X : Set} -> Skippy X -> Skippy X -> Skippy X 134 | [] +>+ ys = ys 135 | (x :: xs) +>+ ys = x :: (xs +>+ ys) 136 | (m > xs) +>+ ys = m >> (xs +>+ ys) 137 | -- ^^ see? 138 | 139 | -- That way, you know that if the lists you're concatenating satisfy the 140 | -- above rules, so will the result. 141 | 142 | 143 | --------------------------------------------------------------------------- 144 | -- ANOTHER SMART CONSTRUCTOR -- 145 | --------------------------------------------------------------------------- 146 | 147 | -- You might consider playing the same game with the List Action type that 148 | -- we use for displaying things. Here's part of mine. 149 | 150 | _:a:_ : Action -> List Action -> List Action 151 | goRowCol _ _ :a: (goRowCol r c :: as) = goRowCol r c :: as 152 | sendText x :a: (sendText y :: as) = sendText (x +-+ y) :: as 153 | a :a: as = a :: as 154 | 155 | -- That's to say 156 | -- (i) there's no point in positioning the cursor twice in a row, when 157 | -- the second just overrides the first; 158 | -- (ii) don't send two small texts when you can send one big text. 159 | 160 | 161 | --------------------------------------------------------------------------- 162 | -- CROP-AND-PAD -- 163 | --------------------------------------------------------------------------- 164 | 165 | -- As with overlay, the types of cropPadLR and cropPadTB from episode 4 166 | -- are more specific than is necessarily helpful. How about this instead? 167 | 168 | cropPadXLR : {X : Nat -> Nat -> Set} -- some stuff 169 | (ck : CutKit X) -> -- how to cut stuff 170 | (px : {w h : Nat} -> X w h) -> -- how to make "blank" stuff 171 | (w h w' : Nat) -> Box X w h -> Box X w' h 172 | cropPadXLR ck px w h w' b = {!!} 173 | 174 | -- and its TB friend, of course. Now you can crop things other than 175 | -- Paintings. 176 | 177 | 178 | --------------------------------------------------------------------------- 179 | -- FROM APPLICATIONS TO UPPLICATIONS -- 180 | --------------------------------------------------------------------------- 181 | 182 | -- The notion of "Application" from episode 4 required you to define a 183 | -- paintMe function which just gives the full display. You may need to 184 | -- rethink this concept to get an *updating* application, or "Upplication" 185 | -- in which at least some of the event handlers tell you just what has 186 | -- changed. You will certainly need *more* information, but you should 187 | -- also consider whether it would be better if the existing information 188 | -- took a different form. 189 | 190 | 191 | --------------------------------------------------------------------------- 192 | -- PUTTING UPPLICATIONS TOGETHER -- 193 | --------------------------------------------------------------------------- 194 | 195 | -- In episode 4, you had to define the frontBack operator, which combined 196 | -- two applications into one by *layering* them. How does that work for 197 | -- upplications? What other spatial combinations of upplications make sense? 198 | -- Here are three possibilities worth considering: 199 | -- (i) putting two applications side-by-side, 200 | -- (ii) putting one application above another, 201 | -- (iii) viewing an application through a rectangular viewport. 202 | -- Of course, there are many more possibilities. 203 | -- 204 | -- Toggling with the tab key is all very well when there are only two 205 | -- components, but you might need to think a little harder about how to 206 | -- navigate when there are more. Normally, you'd use your finger for that, 207 | -- or a mouse. Sadly, I don't know how to organise mouse interaction with 208 | -- terminal windows. But you could make a pretend mouse: a top layer which 209 | -- displays a "mouse cursor" that you can move around with arrow keys when 210 | -- you're in "mouse mode". Clicking could be a keystroke which activates 211 | -- the frontmost opaque thing behind the mouse and exits mouse mode. 212 | 213 | 214 | --------------------------------------------------------------------------- 215 | -- MAIN -- 216 | --------------------------------------------------------------------------- 217 | 218 | -- I've added 219 | -- make go5 220 | -- to the Makefile 221 | 222 | -- I've set the main application to be the silly one from episode 4, but 223 | -- you can swap in your own thing. 224 | 225 | main : IO Thud 226 | main = mainLoop ('*' , 0 , 0) sillyHandler 227 | -------------------------------------------------------------------------------- /Ex2Sol.agda: -------------------------------------------------------------------------------- 1 | module Ex2Sol where 2 | 3 | {----------------------------------------------------------------------------- 4 | Name: Conor McSpecimen 5 | -----------------------------------------------------------------------------} 6 | 7 | {----------------------------------------------------------------------------- 8 | CS410 Exercise 2, due 5pm on Monday of Week 6 (3 November 2014) 9 | NOTE: I am well aware that week 6 is quite busy with deadlines, 10 | what with CS408-related obligations and so on. I'd much prefer 11 | you did things to the best of your ability rather than on time, 12 | so I would be sympathetic to requests for some flexibility. 13 | Still, your best bet is to make an early start rather than a 14 | late finish. 15 | -----------------------------------------------------------------------------} 16 | 17 | {----------------------------------------------------------------------------- 18 | This exercise is based around extending Hutton's razor with Boolean 19 | values and conditional expressions. By introducing a second value 20 | type, we acquire the risk of type mismatch. The idea here is to 21 | explore different approaches to managing that risk. 22 | -----------------------------------------------------------------------------} 23 | 24 | {- Mark scheme 25 | Each part is worth one mark each, apart from the four labelled 26 | as worth two. The total number of marks available is 15. 27 | -} 28 | 29 | open import Ex1Prelude 30 | open import Ex2Prelude 31 | 32 | {- The extended Hutton's Razor syntax -} 33 | 34 | data HExpIf : Set where 35 | num : Nat -> HExpIf 36 | boo : Two -> HExpIf 37 | _+++_ : HExpIf -> HExpIf -> HExpIf 38 | hif_then_else_ : HExpIf -> HExpIf -> HExpIf -> HExpIf 39 | 40 | {- Note that an expression 41 | 42 | hif eb then ex1 else ex2 43 | 44 | makes sense only when 45 | * eb produces a Boolean value 46 | * ex1 and ex2 produce the same sort of value (numeric or Boolean) 47 | -} 48 | 49 | HValIf : Set 50 | HValIf = Two /+/ Nat 51 | 52 | {- We now have the risk of run time type errors. Let's introduce a type 53 | for things which can go wrong. -} 54 | 55 | data Error (E X : Set) : Set where 56 | ok : X -> Error E X 57 | error : E -> Error E X 58 | 59 | {- 2.1 Add a constructor to the following datatype for each different 60 | kind of run time error that can happen. (Come back to this exercise 61 | when you're writing the evaluator in 2.3.) Make these error reports 62 | as informative as you can. 63 | -} 64 | 65 | data EvalError : Set where 66 | wantedANatButGotALousy : HExpIf -> EvalError 67 | wantedATwoButGotALousy : HExpIf -> EvalError 68 | -- your constructors here 69 | 70 | {- 2.2 Write a little piece of "glue code" to make it easier to manage 71 | errors. The idea is to combine error-prone process in *sequence*, where 72 | the second process can depend on the value produced by the first if it 73 | succeeds. The resulting process is, of course, also error-prone, failing 74 | as soon as either component fails. 75 | -} 76 | 77 | _>>=_ : {E S T : Set} 78 | -> Error E S -- process which tries to get an S 79 | -> (S -> Error E T) -- given an S, process which tries for a T 80 | -> Error E T -- combined in sequence 81 | ok s >>= s2et = s2et s 82 | error e >>= s2et = error e 83 | 84 | {- 2.3 Implement an evaluator for HExpIf. Be sure to add only numbers and 85 | to branch only on Booleans. Report type mismatches as errors. You should 86 | use _>>=_ to help with the propagation of error messages. 87 | (2 marks) 88 | -} 89 | 90 | natOrBust : {E : Set} -> E -> HValIf -> Error E Nat 91 | natOrBust e (inl b) = error e 92 | natOrBust e (inr n) = ok n 93 | 94 | twoOrBust : {E : Set} -> E -> HValIf -> Error E Two 95 | twoOrBust e (inl b) = ok b 96 | twoOrBust e (inr n) = error e 97 | 98 | eval : HExpIf -> Error EvalError HValIf 99 | eval (num n) = ok (inr n) 100 | eval (boo x) = ok (inl x) 101 | eval (d +++ e) = 102 | (eval d >>= natOrBust (wantedANatButGotALousy d)) >>= \ dn -> 103 | (eval e >>= natOrBust (wantedANatButGotALousy e)) >>= \ en -> 104 | ok (inr (dn + en)) 105 | eval (hif e then t else f) = 106 | (eval e >>= twoOrBust (wantedATwoButGotALousy e)) >>= \ eb -> 107 | if eb then eval t else eval f 108 | 109 | {- Note that the type of eval is not specific about whether the value 110 | expected is numeric or Boolean. It may help to introduce auxiliary 111 | definitions of error-prone processes which are "ok" only for the 112 | type that you really want. 113 | -} 114 | 115 | {- Next up, stack machine code, and its execution. -} 116 | 117 | data HBCode : Set where 118 | PUSHN : Nat -> HBCode 119 | PUSHB : Two -> HBCode 120 | ADD : HBCode 121 | _SEQ_ : HBCode -> HBCode -> HBCode 122 | _IFPOP_ : HBCode -> HBCode -> HBCode 123 | 124 | {- The intended behaviour of (t IFPOP f) is as follows 125 | * pop the (we hope) Boolean value from top of stack 126 | * if it's tt, execute t, else execute f 127 | * whichever branch is executed, it gets the popped stack to start 128 | -} 129 | 130 | {- 2.4 Populate the type of possible execution errors and implement the 131 | execution behaviour of HBCode, operating on a stack represented as 132 | a list of HValIf values. (2 marks) 133 | -} 134 | 135 | data ExecError : Set where 136 | stackUnderflowInADD : ExecError 137 | stackUnderflowInIFPOP : ExecError 138 | addingATwo : HValIf -> ExecError 139 | iffingANat : HValIf -> ExecError 140 | -- your constructors here 141 | 142 | exec : HBCode -> List HValIf -> Error ExecError (List HValIf) 143 | exec (PUSHN n) s = ok (inr n :> s) 144 | exec (PUSHB b) s = ok (inl b :> s) 145 | exec ADD (y :> x :> s) 146 | = natOrBust (addingATwo x) x >>= \ xn -> 147 | natOrBust (addingATwo y) y >>= \ yn -> 148 | ok (inr (xn + yn) :> s) 149 | exec ADD _ = error stackUnderflowInADD 150 | exec (c SEQ d) s = exec c s >>= exec d 151 | exec (t IFPOP f) [] = error stackUnderflowInIFPOP 152 | exec (t IFPOP f) (x :> s) 153 | = twoOrBust (iffingANat x) x >>= \ xb -> 154 | if xb then exec t s else exec f s 155 | 156 | {- Next, we take a look at code generation and type safety. -} 157 | 158 | data HTy : Set where -- we have two types in HExpIf 159 | NUM BOOL : HTy 160 | 161 | _=HTy=_ : HTy -> HTy -> Two -- we can test if two types are equal 162 | NUM =HTy= NUM = tt 163 | NUM =HTy= BOOL = ff 164 | BOOL =HTy= NUM = ff 165 | BOOL =HTy= BOOL = tt 166 | 167 | {- 2.5 Write a type-synthesizing compiler, computing both the HTy type and 168 | the HBCode executable for a given expression. Your compiler should 169 | give an informative error report if the expression it receives is 170 | ill typed. Your compiler should also ensure (at least informally) that 171 | the code produced will never trigger any execution errors. 172 | (2 marks) 173 | -} 174 | 175 | data CompileError : Set where 176 | addingABool : HExpIf -> CompileError 177 | iffingANumber : HExpIf -> CompileError 178 | ifBranchesMismatchedTypes : (HExpIf /*/ HTy) -> (HExpIf /*/ HTy) -> CompileError 179 | 180 | compile : HExpIf -> Error CompileError (HTy /*/ HBCode) 181 | compile (num x) = ok (NUM , PUSHN x) 182 | compile (boo x) = ok (BOOL , PUSHB x) 183 | compile (e1 +++ e2) = compile e1 >>= \ 184 | { (BOOL , _) -> error (addingABool e1) 185 | ; (NUM , c1) -> compile e2 >>= \ 186 | { (BOOL , _) -> error (addingABool e2) 187 | ; (NUM , c2) -> ok (NUM , (c1 SEQ c2) SEQ ADD) 188 | } 189 | } 190 | compile (hif e then t else f) = compile e >>= \ 191 | { (NUM , _) -> error (iffingANumber e) 192 | ; (BOOL , c) -> compile t >>= \ 193 | { (tty , tc) -> compile f >>= \ 194 | { (fty , fc) -> 195 | if tty =HTy= fty then ok (tty , c SEQ (tc IFPOP fc)) 196 | else error (ifBranchesMismatchedTypes (t , tty) (f , fty)) 197 | } 198 | } 199 | } 200 | 201 | 202 | {- You have a little bit more room for creative problem-solving in what's 203 | left of the exercise. The plan is to build the type system into expressions 204 | and code, the same way we did with plain Hutton's Razor in class. 205 | -} 206 | 207 | {- If we *know* which HTy type we want, we can compute which Agda type we 208 | expect our value to take. -} 209 | 210 | HVal : HTy -> Set 211 | HVal NUM = Nat 212 | HVal BOOL = Two 213 | 214 | {- 2.6 Finish the type of typed expressions. You should ensure that only 215 | well HTy-typed expressions can be constructed. -} 216 | 217 | data THExpIf : HTy -> Set where 218 | val : {t : HTy} -> HVal t -> THExpIf t 219 | _+++_ : THExpIf NUM -> THExpIf NUM -> THExpIf NUM 220 | hif_then_else_ : {t : HTy} -> THExpIf BOOL -> THExpIf t -> THExpIf t -> THExpIf t 221 | -- you fill in addition and if-then-else 222 | 223 | {- 2.7 Implement a type-safe evaluator. -} 224 | 225 | teval : {t : HTy} -> THExpIf t -> HVal t 226 | teval (val x) = x 227 | teval (d +++ e) = teval d + teval e 228 | teval (hif e then t else f) = if teval e then teval t else teval f 229 | 230 | {- 2.8 Implement a type checker. (2 marks) -} 231 | 232 | data TypeError : Set where 233 | wanted_got_ : HTy -> HExpIf -> TypeError 234 | -- your constructors here 235 | 236 | tcheck : (t : HTy) -> HExpIf -> Error TypeError (THExpIf t) 237 | tcheck NUM (num x) = ok (val x) 238 | tcheck BOOL (num x) = error (wanted BOOL got num x) 239 | tcheck NUM (boo x) = error (wanted NUM got boo x) 240 | tcheck BOOL (boo x) = ok (val x) 241 | tcheck NUM (d +++ e) = tcheck NUM d >>= \ dt -> tcheck NUM e >>= \ et -> ok (dt +++ et) 242 | tcheck BOOL (d +++ e) = error (wanted BOOL got (d +++ e)) 243 | tcheck t (hif e then th else el) = 244 | tcheck BOOL e >>= \ et -> 245 | tcheck t th >>= \ tht -> 246 | tcheck t el >>= \ elt -> ok (hif et then tht else elt) 247 | 248 | {- 2.9 Adapt the technique from Hutton.agda to give a type-safe underflow-free 249 | version of HBCode. You will need to think what is a good type to represent 250 | the "shape" of a stack: before, we just used Nat to represent the *height* of 251 | the stack, but now we must worry about types. See next question for a hint. -} 252 | 253 | data THBCode : List HTy -> List HTy -> Set where 254 | PUSHV : {t : HTy}{s : List HTy} -> HVal t -> THBCode s (t :> s) 255 | ADD : {s : List HTy} -> THBCode (NUM :> NUM :> s) (NUM :> s) 256 | _SEQ_ : {i j k : List HTy} -> THBCode i j -> THBCode j k -> THBCode i k 257 | _IFPOP_ : {i j : List HTy} -> THBCode i j -> THBCode i j -> THBCode (BOOL :> i) j 258 | 259 | {- 2.10 Implement the execution semantics for your code. You will need to think 260 | about how to represent a stack. The Ex2Prelude.agda file contains a very 261 | handy piece of kit for this purpose. You write the type, too. -} 262 | 263 | Stack : List HTy → Set 264 | Stack i = All HVal i 265 | 266 | -- forward composition 267 | _followedBy_ : {A B C : Set} (f : A → B) (g : B → C) → A → C 268 | f followedBy g = λ z → g (f z) 269 | 270 | tsemantics : {i j : List HTy} (c : THBCode i j) (s : Stack i) → Stack j 271 | tsemantics (PUSHV x) s = x , s 272 | tsemantics ADD (m , n , s) = m + n , s 273 | tsemantics (c SEQ d) s = (tsemantics c followedBy tsemantics d) s 274 | tsemantics (t IFPOP f) (b , s) = if b then tsemantics t s else tsemantics f s 275 | 276 | {- 2.11 Write the compiler from well typed expressions to safe code. -} 277 | 278 | tcompile : {t : HTy} -> THExpIf t -> {s : List HTy} -> THBCode s (t :> s) 279 | tcompile (val x) = PUSHV x 280 | tcompile (d +++ e) = (tcompile d SEQ tcompile e) SEQ ADD 281 | tcompile (hif e then t else f) = tcompile e SEQ (tcompile t IFPOP tcompile f) 282 | -------------------------------------------------------------------------------- /FuncLec.agda: -------------------------------------------------------------------------------- 1 | module FuncLec where 2 | 3 | open import Ex1Prelude 4 | 5 | _=^=_ : {S T : Set}(f g : S -> T) -> Set 6 | f =^= g = (s : _) -> f s == g s 7 | infixl 2 _=^=_ 8 | 9 | map : {S T : Set} -> (S -> T) -> (List S -> List T) 10 | map f [] = [] 11 | map f (s :> ss) = f s :> map f ss 12 | 13 | mapId : {S : Set} -> map (id {S}) =^= id {List S} 14 | mapId [] = refl 15 | mapId (x :> ss) rewrite mapId ss = refl 16 | 17 | mapComp : {R S T : Set}(f : S -> T)(g : R -> S) -> 18 | map f o map g =^= map (f o g) 19 | mapComp f g [] = refl 20 | mapComp f g (x :> ss) rewrite mapComp f g ss = refl 21 | 22 | _>=_ : Nat -> Nat -> Set 23 | m >= zero = One 24 | zero >= suc n = Zero 25 | suc m >= suc n = m >= n 26 | 27 | geRefl : (n : Nat) -> n >= n 28 | geRefl zero = <> 29 | geRefl (suc x) = geRefl x 30 | 31 | geTrans : (l m n : Nat) -> m >= n -> l >= m -> l >= n 32 | geTrans l zero zero mn lm = <> 33 | geTrans zero zero (suc x) mn lm = mn 34 | geTrans (suc x) zero (suc zero) mn lm = <> 35 | geTrans (suc x) zero (suc (suc x₁)) mn lm = geTrans x zero (suc x₁) mn <> 36 | geTrans l (suc x) zero mn lm = <> 37 | geTrans zero (suc x) (suc x₁) mn lm = lm 38 | geTrans (suc x) (suc x₁) (suc x₂) mn lm = geTrans x x₁ x₂ mn lm 39 | 40 | 41 | data Vec (X : Set) : Nat -> Set where 42 | [] : Vec X zero 43 | _,_ : forall {n} -> X -> Vec X n -> Vec X (suc n) 44 | 45 | take : {X : Set}(m n : Nat) -> m >= n -> (Vec X m -> Vec X n) 46 | take m zero mn xs = [] 47 | take .0 (suc n) () [] 48 | take ._ (suc n) mn (x , xs) = x , take _ n mn xs 49 | 50 | data Tree (X : Set) : Set where 51 | leaf : Tree X 52 | node : Tree X -> X -> Tree X -> Tree X 53 | 54 | treeMap : {S T : Set} -> (S -> T) -> (Tree S -> Tree T) 55 | treeMap f leaf = leaf 56 | treeMap f (node l s r) = node (treeMap f l) (f s) (treeMap f r) 57 | 58 | From : Set -> Set -> Set 59 | From A X = A -> X 60 | fromMap : {A S T : Set} -> (S -> T) -> ((From A) S -> (From A) T) 61 | fromMap f g = f o g 62 | 63 | {- 64 | To : Set -> Set -> Set 65 | To B X = X -> B 66 | toMap : {B S T : Set} -> (S -> T) -> ((To B) S -> (To B) T) 67 | toMap {B}{S}{T} f g = {!!} 68 | -} 69 | 70 | NotNot : Set -> Set 71 | NotNot X = (X -> Zero) -> Zero 72 | 73 | nnMap : {S T : Set} -> (S -> T) -> (NotNot S -> NotNot T) 74 | nnMap f nns = \ nt -> nns (\ s -> nt (f s)) 75 | 76 | good : Zero -> One 77 | good () 78 | {- 79 | bad : One -> Zero 80 | bad = toMap good id 81 | -} 82 | 83 | Id : Set -> Set 84 | Id X = X 85 | idMap : {S T : Set} -> (S -> T) -> (Id S -> Id T) 86 | idMap {S}{T} = id 87 | 88 | Product : (F G : Set -> Set) -> Set -> Set 89 | Product F G X = F X /*/ G X 90 | prodMap : {F G : Set -> Set} -> 91 | ({S T : Set} -> (S -> T) -> (F S -> F T)) -> 92 | ({S T : Set} -> (S -> T) -> (G S -> G T)) -> 93 | ({S T : Set} -> (S -> T) -> ((Product F G) S -> (Product F G) T)) 94 | prodMap fmap gmap h (fs , gs) = fmap h fs , gmap h gs 95 | 96 | ex1 : Product Id Id Nat 97 | ex1 = 6 , 7 98 | 99 | ex2 : Product Id Id Two 100 | ex2 = prodMap idMap idMap (\ n -> n <= 6) ex1 101 | 102 | Sum : (F G : Set -> Set) -> Set -> Set 103 | Sum F G X = F X /+/ G X 104 | sumMap : {F G : Set -> Set} -> 105 | ({S T : Set} -> (S -> T) -> (F S -> F T)) -> 106 | ({S T : Set} -> (S -> T) -> (G S -> G T)) -> 107 | ({S T : Set} -> (S -> T) -> ((Sum F G) S -> (Sum F G) T)) 108 | sumMap fmap gmap h (inl fs) = inl (fmap h fs) 109 | sumMap fmap gmap h (inr gs) = inr (gmap h gs) 110 | 111 | ex3 : Sum (Product Id Id) Id Two 112 | ex3 = inl (tt , ff) 113 | 114 | K : Set -> Set -> Set 115 | K A X = A 116 | 117 | kMap : {A S T : Set} -> (S -> T) -> (K A S -> K A T) 118 | kMap f a = a 119 | 120 | Mystery : Set -> Set 121 | Mystery = Sum (K One) Id 122 | 123 | mystery : Mystery Two 124 | mystery = inl <> 125 | 126 | data Kit : Set1 where 127 | kK : Set -> Kit 128 | kId : Kit 129 | _k+_ : Kit -> Kit -> Kit 130 | _k*_ : Kit -> Kit -> Kit 131 | 132 | kFun : Kit -> (Set -> Set) 133 | kFun (kK A) X = A 134 | kFun kId X = X 135 | kFun (f k+ g) X = kFun f X /+/ kFun g X 136 | kFun (f k* g) X = kFun f X /*/ kFun g X 137 | 138 | kitMap : (k : Kit){S T : Set} -> (S -> T) -> kFun k S -> kFun k T 139 | kitMap (kK A) h a = a 140 | kitMap kId h s = h s 141 | kitMap (f k+ g) h (inl fs) = inl (kitMap f h fs) 142 | kitMap (f k+ g) h (inr gs) = inr (kitMap g h gs) 143 | kitMap (f k* g) h (fs , gs) = kitMap f h fs , kitMap g h gs 144 | 145 | data Data (k : Kit) : Set where 146 | [_] : kFun k (Data k) -> Data k 147 | 148 | fold : (k : Kit){X : Set} -> (kFun k X -> X) -> Data k -> X 149 | fold k {X} f [ kd ] = f (kitMapFold k kd) where 150 | kitMapFold : (j : Kit) -> kFun j (Data k) -> kFun j X 151 | kitMapFold (kK A) a = a 152 | kitMapFold kId s = fold k f s 153 | kitMapFold (f k+ g) (inl fs) = inl (kitMapFold f fs) 154 | kitMapFold (f k+ g) (inr gs) = inr (kitMapFold g gs) 155 | kitMapFold (f k* g) (fs , gs) = kitMapFold f fs , kitMapFold g gs 156 | 157 | kMaybe : Kit 158 | kMaybe = kK One k+ kId 159 | 160 | pattern ze = inl <> 161 | pattern su n = inr n 162 | 163 | NAT = Data kMaybe 164 | exNat : NAT 165 | exNat = [ su [ su [ ze ] ] ] 166 | 167 | _+'_ : NAT -> NAT -> NAT 168 | x +' y = fold kMaybe p x where 169 | p : kFun kMaybe NAT -> NAT 170 | p ze = y 171 | p (su x+y) = [ su x+y ] 172 | 173 | 174 | {- 175 | [ ze ] +' y = y 176 | [ su x ] +' y = [ su (x +' y) ] 177 | -} 178 | 179 | 180 | kT : Kit 181 | kT = kK One k+ (kId k* kId) 182 | 183 | exTree : Data kT 184 | exTree = [ inl <> ] 185 | 186 | FreeMo : Kit -> Set -> Set 187 | FreeMo k X = Data (k k+ kK X) 188 | 189 | return : (k : Kit) -> {A : Set} -> A -> FreeMo k A 190 | return k a = [ inr a ] 191 | 192 | bind : (k : Kit){A B : Set} -> 193 | FreeMo k A -> 194 | (A -> FreeMo k B) -> 195 | FreeMo k B 196 | bind k {A} ma a2mb = fold (k k+ kK A) 197 | (\ { (inl kb) -> [ inl kb ] 198 | ; (inr a) -> a2mb a 199 | }) ma 200 | 201 | Error : Set -> Set -> Set 202 | Error E = FreeMo (kK E) 203 | 204 | kBitWrite : Kit 205 | kBitWrite = kK Two k* kId 206 | 207 | kBitRead : Kit 208 | kBitRead = kId k* kId 209 | 210 | RWBit : Set -> Set 211 | RWBit = FreeMo (kBitWrite k+ kBitRead) 212 | 213 | run : {X : Set} -> RWBit X -> 214 | List Two -> List Two /*/ Error One X 215 | run [ inl (inl (b , p)) ] bs with run p bs 216 | run [ inl (inl (b , p)) ] bs | bs' , ex 217 | = (b :> bs') , ex 218 | run [ inl (inr (tp , fp)) ] [] = [] , [ inl <> ] 219 | run [ inl (inr (tp , fp)) ] (tt :> bs) 220 | = run tp bs 221 | run [ inl (inr (tp , fp)) ] (ff :> bs) 222 | = run fp bs 223 | run [ inr x ] bs = [] , [ inr x ] 224 | 225 | record Container : Set1 where 226 | constructor _ Set -- aka Position 230 | open Container public 231 | 232 | record Sigma (S : Set)(T : S -> Set) : Set where 233 | constructor _,_ 234 | field 235 | fst : S 236 | snd : T fst 237 | open Sigma public 238 | 239 | _*'_ : Set -> Set -> Set 240 | S *' T = Sigma S \ _ -> T 241 | 242 | _+s_ : Set -> Set -> Set 243 | S +s T = Sigma Two \ { tt -> S ; ff -> T } 244 | 245 | [[_]] : Container -> Set -> Set 246 | [[ C R c -> Y) 247 | 248 | cmap : (F : Container) -> {S T : Set} -> (S -> T) -> [[ F ]] S -> [[ F ]] T 249 | cmap F f (c , k) = c , (\ r -> f (k r)) 250 | 251 | data GenMo (F : Container) 252 | (X : Set) : Set where 253 | ret : X -> GenMo F X 254 | <_> : [[ F ]] (GenMo F X) -> GenMo F X 255 | 256 | _>>=_ : {F : Container} 257 | {A B : Set} -> GenMo F A -> (A -> GenMo F B) 258 | -> GenMo F B 259 | ret a >>= f = f a 260 | < c , k > >>= f = < c , (\ r -> k r >>= f) > 261 | 262 | data Fail : Set where 263 | fail : Fail 264 | 265 | FailR : Fail -> Set 266 | FailR fail = Zero 267 | 268 | Maybe : Container 269 | Maybe = Fail 272 | (c : Command F) -> GenMo F (Response F c) 273 | ! c = < c , ret > 274 | 275 | _c+_ : Container -> Container -> Container 276 | (C0 R0 c0 ; (inr c1) -> R1 c1 }) 277 | 278 | inC : {F G : Container}{X : Set} -> [[ F ]] X /+/ [[ G ]] X -> [[ F c+ G ]] X 279 | inC (inl (fc , fk)) = inl fc , fk 280 | inC (inr (gc , gk)) = inr gc , gk 281 | 282 | _c*_ : Container -> Container -> Container 283 | (C0 R0 c0 /+/ R1 c1 }) 284 | 285 | pairC : {F G : Container}{X : Set} -> [[ F ]] X /*/ [[ G ]] X -> [[ F c* G ]] X 286 | pairC ((fc , fk) , (gc , gk)) 287 | = (fc , gc) , (\ { (inl fr) -> fk fr ; (inr gr) -> gk gr }) 288 | 289 | kContainer : Kit -> Container 290 | kContainer (kK A) = A Zero) 291 | kContainer kId = One One) 292 | kContainer (k k+ k') = kContainer k c+ kContainer k' 293 | kContainer (k k* k') = kContainer k c* kContainer k' 294 | 295 | tail : {X : Set} -> List X -> GenMo Maybe (List X) 296 | tail [] = ! fail >>= (\ ()) 297 | tail (x :> xs) = ret xs 298 | 299 | try : {X : Set} -> GenMo Maybe X -> X -> X 300 | try (ret x) _ = x 301 | try < fail , k > x = x 302 | 303 | data State (S : Set) : Set where 304 | get : State S 305 | put : S -> State S 306 | 307 | StateR : {S : Set} -> State S -> Set 308 | StateR {S} get = S 309 | StateR (put x) = One 310 | 311 | StateC : Set -> Container 312 | StateC S = State S >= \ c -> ! (put (suc c)) >>= \ _ -> ret c 316 | 317 | runState : {S X : Set} -> GenMo (StateC S) X -> 318 | S -> X /*/ S 319 | runState (ret x) s = x , s 320 | runState < get , k > s = runState (k s) s 321 | runState < put s' , k > s = runState (k <>) s' 322 | 323 | test : (Nat /*/ Nat) /*/ Nat 324 | test = runState (c++ >>= \ x -> c++ >>= \ y -> ret (x , y)) 41 325 | 326 | data Choose : Set where 327 | choose : Choose 328 | 329 | ChooseR : Choose -> Set 330 | ChooseR choose = Two 331 | 332 | ChooseC : Container 333 | ChooseC = Choose GenMo ChooseC X -> X 336 | truey (ret x) = x 337 | truey < choose , k > = truey (k tt) 338 | 339 | streamy : {X : Set} -> 340 | GenMo ChooseC X -> (Nat -> Two) -> X 341 | streamy (ret x) s = x 342 | streamy < choose , k > s = streamy (k (s zero)) (s o suc) 343 | 344 | _++_ : {X : Set} -> List X -> List X -> List X 345 | [] ++ ys = ys 346 | x :> xs ++ ys = x :> (xs ++ ys) 347 | 348 | infixr 3 _++_ 349 | 350 | pokemon : {X : Set} -> GenMo ChooseC X -> List X 351 | pokemon (ret x) = x :> [] 352 | pokemon < choose , k > = pokemon (k tt) ++ pokemon (k ff) 353 | 354 | FailOrChoose : Container 355 | FailOrChoose = Maybe c+ ChooseC 356 | 357 | answers : {X : Set} -> GenMo FailOrChoose X -> List X 358 | answers (ret x) = x :> [] 359 | answers < inl fail , k > = [] 360 | answers < inr choose , k > = answers (k tt) ++ answers (k ff) 361 | 362 | data Sender (X : Set) : Set where 363 | send : X -> Sender X 364 | 365 | SenderC : Set -> Container 366 | SenderC X = Sender X One 367 | 368 | data Receiver : Set where 369 | receive : Receiver 370 | 371 | ReceiverC : Set -> Container 372 | ReceiverC X = Receiver X 373 | 374 | TransducerC : Set -> Container 375 | TransducerC X = ReceiverC X c+ SenderC X 376 | 377 | FlakyTransducerC : Set -> Container 378 | FlakyTransducerC X = Maybe c+ (ReceiverC X c+ SenderC X) 379 | 380 | pipe : {X Y : Set} -> GenMo (TransducerC X) One -> GenMo (TransducerC X) Y -> 381 | GenMo (FlakyTransducerC X) Y 382 | pipe (ret <>) (ret y) = ret y 383 | pipe (ret <>) < inl receive , k > = < inl fail , (\ ()) > 384 | pipe < inl receive , k > q = < inr (inl receive) , (\ x -> pipe (k x) q) > 385 | pipe < inr (send x) , k > (ret y) = ret y 386 | pipe < inr (send x) , k > < inl receive , j > = pipe (k <>) (j x) 387 | pipe p < inr (send x) , k > = < inr (inr (send x)) , (\ _ -> pipe p (k <>)) > 388 | -------------------------------------------------------------------------------- /Ex1Sol.agda: -------------------------------------------------------------------------------- 1 | module Ex1Sol where 2 | 3 | open import Ex1Prelude 4 | 5 | {----------------------------------------------------------------------------} 6 | {- Name: Conor McSpecimen -} 7 | {----------------------------------------------------------------------------} 8 | 9 | {----------------------------------------------------------------------------} 10 | {- DEADLINE: Week 3 Monday 13 October 23:59 (preferably by BitBucket) -} 11 | {----------------------------------------------------------------------------} 12 | 13 | {----------------------------------------------------------------------------- 14 | TOP TIP: if you have annoyingly many open goals, comment out big chunks of the 15 | file with a multi-line comment a bit like this one. 16 | -----------------------------------------------------------------------------} 17 | 18 | {- Mark scheme: 19 | The programming for each part is worth one mark. 20 | the explanation of why the impossible cases are impossible is worth 21 | one mark. 22 | The total number of available marks is 15. 23 | -} 24 | 25 | 26 | {----------------------------------------------------------------------------} 27 | {- 1.1: Tree Sort -} 28 | {----------------------------------------------------------------------------} 29 | 30 | -- 1.1.1 implement concatenation for lists 31 | 32 | _++_ : {X : Set} -> List X -> List X -> List X 33 | [] ++ ys = ys 34 | x :> xs ++ ys = x :> (xs ++ ys) 35 | 36 | infixr 3 _++_ 37 | 38 | -- a datatype of node-labelled binary trees is given as follows 39 | 40 | data Tree (X : Set) : Set where 41 | leaf : Tree X 42 | _<[_]>_ : Tree X -> X -> Tree X -> Tree X 43 | 44 | {- 45 | data Tree x = Leaf | Node (Tree X) X (Tree X) 46 | Leaf :: Tree x 47 | Node :: Tree x -> x -> Tree x -> Tree x 48 | -} 49 | 50 | demoTree : Tree Nat 51 | demoTree = (leaf <[ 3 ]> leaf) <[ 5 ]> leaf 52 | 53 | -- 1.1.2 implement the insertion of a number into a tree, ensuring that 54 | -- the numbers in the tree are in increasing order from left to right; 55 | -- make sure to retain duplicates 56 | 57 | insertTree : Nat -> Tree Nat -> Tree Nat 58 | insertTree x leaf = leaf <[ x ]> leaf 59 | insertTree x (l <[ y ]> r) with x <= y -- or use if_then_else_ 60 | insertTree x (l <[ y ]> r) | tt = insertTree x l <[ y ]> r 61 | insertTree x (l <[ y ]> r) | ff = l <[ y ]> insertTree x r 62 | 63 | -- 1.1.3 implement the function which takes the elements of a list and 64 | -- builds an ordered tree from them, using insertTree 65 | 66 | makeTree : List Nat -> Tree Nat 67 | makeTree [] = leaf 68 | makeTree (x :> xs) = insertTree x (makeTree xs) 69 | 70 | -- 1.1.4 implement the function which flattens a tree to a list, 71 | -- using concatenation 72 | 73 | flatten : {X : Set} -> Tree X -> List X 74 | flatten leaf = [] 75 | flatten (l <[ x ]> r) = flatten l ++ x :> flatten r 76 | 77 | -- 1.1.5 using the above components, implement a sorting algorithm which 78 | -- works by building a tree and then flattening it 79 | 80 | treeSort : List Nat -> List Nat 81 | treeSort = flatten o makeTree 82 | 83 | -- 1.1.6 give a collection of unit tests which cover every program line 84 | -- from 1.1.1 to 1.1.5 85 | 86 | treeSortTest : treeSort (1 :> 5 :> 2 :> 4 :> 3 :> []) 87 | == (1 :> 2 :> 3 :> 4 :> 5 :> []) 88 | treeSortTest = refl 89 | 90 | -- 1.1.7 implement a fast version of flatten, taking an accumulating parameter, 91 | -- never using ++. and ensuring that the law 92 | -- 93 | -- fastFlatten t xs == flatten t ++ xs 94 | -- 95 | -- is true; 96 | 97 | {- 98 | fastFlatten : {X : Set} -> Tree X -> (List X -> List X) 99 | fastFlatten leaf xs 100 | -- = flatten leaf ++ xs -- by specification 101 | -- = [] ++ xs -- definition of flatten 102 | = xs -- definition of ++ 103 | fastFlatten (l <[ x ]> r) xs 104 | -- = flatten (l <[ x ]> r) ++ xs -- by specification 105 | -- = (flatten l ++ x :> flatten r) ++ xs -- definition of flatten 106 | -- = flatten l ++ x :> flatten r ++ xs -- ++ is associative 107 | -- = flatten l ++ x :> fastFlatten r xs -- by specification 108 | = fastFlatten l (x :> fastFlatten r xs) -- by specification 109 | -} 110 | 111 | -- for an extra style point, ensure that the accumulating parameter 112 | -- is never given a name in your program 113 | 114 | fastFlatten : {X : Set} -> Tree X -> (List X -> List X) 115 | fastFlatten leaf = id 116 | fastFlatten (l <[ x ]> r) = (fastFlatten l) o (_:>_ x) o (fastFlatten r) 117 | 118 | -- 1.1.8 use fastFlatten to build a fast version of tree sort 119 | 120 | fastTreeSort : List Nat -> List Nat 121 | fastTreeSort xs = fastFlatten (makeTree xs) [] 122 | 123 | -- 1.1.9 again, give unit tests which cover every line of code 124 | 125 | fastTreeSortTest : fastTreeSort (1 :> 5 :> 2 :> 4 :> 3 :> []) 126 | == (1 :> 2 :> 3 :> 4 :> 5 :> []) 127 | fastTreeSortTest = refl 128 | 129 | 130 | {----------------------------------------------------------------------------} 131 | {- 1.2: Shooting Propositional Logic Fish In A Barrel -} 132 | {----------------------------------------------------------------------------} 133 | 134 | -- 1.2.1 implement the following operations; try to use only 135 | -- [C-c C-c] and [C-c C-a] 136 | 137 | orCommute : {A B : Set} -> A /+/ B -> B /+/ A 138 | orCommute (inl a) = inr a 139 | orCommute (inr b) = inl b 140 | 141 | orAbsorbL : {A : Set} -> Zero /+/ A -> A 142 | orAbsorbL (inl ()) 143 | orAbsorbL (inr a) = a 144 | 145 | orAbsorbR : {A : Set} -> A /+/ Zero -> A 146 | orAbsorbR (inl a) = a 147 | orAbsorbR (inr ()) 148 | 149 | orAssocR : {A B C : Set} -> (A /+/ B) /+/ C -> A /+/ (B /+/ C) 150 | orAssocR (inl (inl a)) = inl a 151 | orAssocR (inl (inr b)) = inr (inl b) 152 | orAssocR (inr c) = inr (inr c) 153 | 154 | orAssocL : {A B C : Set} -> A /+/ (B /+/ C) -> (A /+/ B) /+/ C 155 | orAssocL (inl a) = inl (inl a) 156 | orAssocL (inr (inl b)) = inl (inr b) 157 | orAssocL (inr (inr c)) = inr c 158 | 159 | -- 1.2.2 implement the following operations; try to use only 160 | -- [C-c C-c] and [C-c C-a] 161 | 162 | andCommute : {A B : Set} -> A /*/ B -> B /*/ A 163 | andCommute (a , b) = b , a 164 | 165 | andAbsorbL : {A : Set} -> A -> One /*/ A 166 | andAbsorbL a = <> , a 167 | 168 | andAbsorbR : {A : Set} -> A -> A /*/ One 169 | andAbsorbR a = a , <> 170 | 171 | andAssocR : {A B C : Set} -> (A /*/ B) /*/ C -> A /*/ (B /*/ C) 172 | andAssocR ((a , b) , c) = a , (b , c) 173 | 174 | andAssocL : {A B C : Set} -> A /*/ (B /*/ C) -> (A /*/ B) /*/ C 175 | andAssocL (a , (b , c)) = (a , b) , c 176 | 177 | -- how many times is [C-c C-c] really needed? 178 | -- NEVER, but I'd rather use patterns than projections 179 | 180 | -- 1.2.3 implement the following operations; try to use only 181 | -- [C-c C-c] and [C-c C-a] 182 | 183 | distribute : {A B C : Set} -> A /*/ (B /+/ C) -> (A /*/ B) /+/ (A /*/ C) 184 | distribute (a , inl b) = inl (a , b) 185 | distribute (a , inr c) = inr (a , c) 186 | 187 | factor : {A B C : Set} -> (A /*/ B) /+/ (A /*/ C) -> A /*/ (B /+/ C) 188 | factor (inl (a , b)) = (a , inl b) 189 | factor (inr (a , c)) = (a , inr c) 190 | 191 | 192 | -- 1.2.4 try to implement the following operations; try to use only 193 | -- [C-c C-c] and [C-c C-a]; at least one of them will prove to be 194 | -- impossible, in which case you should comment it out and explain 195 | -- why it's impossible 196 | 197 | Not : Set -> Set 198 | Not X = X -> Zero 199 | 200 | deMorgan1 : {A B : Set} -> (Not A /+/ Not B) -> Not (A /*/ B) 201 | deMorgan1 (inl na) (a , b) = na a 202 | deMorgan1 (inr nb) (a , b) = nb b 203 | 204 | {- 205 | All I know is that A and B are not both true. That does not tell 206 | me which of the two is false. To give a value in S /+/ T, I must 207 | come off the fence and choose either the inl constructor and give 208 | an S value or the inr constructor with a T. I can't just say "well, 209 | I'm sure it isn't neither of those". 210 | 211 | deMorgan2 : {A B : Set} -> Not (A /*/ B) -> (Not A /+/ Not B) 212 | deMorgan2 x = inl (\ a -> {!!}) 213 | 214 | Closer to the detail, a value of type Not (A /*/ B) is really a 215 | function of type (A /*/ B) -> Zero, so I can never get any actual 216 | data out of it that would help me come off the fence. If I plump 217 | for one side (inl, above), I get offered an A, but that isn't 218 | enough to make use of the hypoothesis. 219 | -} 220 | 221 | deMorgan3 : {A B : Set} -> (Not A /*/ Not B) -> Not (A /+/ B) 222 | deMorgan3 (na , nb) (inl a) = na a 223 | deMorgan3 (na , nb) (inr b) = nb b 224 | 225 | deMorgan4 : {A B : Set} -> Not (A /+/ B) -> (Not A /*/ Not B) 226 | deMorgan4 n = (\ a -> n (inl a)) , (\ b -> n (inr b)) 227 | 228 | 229 | -- 1.2.5 try to implement the following operations; try to use only 230 | -- [C-c C-c] and [C-c C-a]; at least one of them will prove to be 231 | -- impossible, in which case you should comment it out and explain 232 | -- why it's impossible 233 | 234 | dnegI : {X : Set} -> X -> Not (Not X) 235 | dnegI = \ x nx → nx x 236 | 237 | {- 238 | dnegE : {X : Set} -> Not (Not X) -> X 239 | dnegE = {!!} 240 | 241 | Just because you can't prove that X's don't exist, it doesn't mean 242 | you actually know how to compute an X. 243 | -} 244 | 245 | neg321 : {X : Set} -> Not (Not (Not X)) -> Not X 246 | neg321 = λ nnx x → nnx \ nx -> nx x 247 | 248 | {- 249 | hamlet : {B : Set} -> B /+/ Not B 250 | hamlet = {!!} 251 | 252 | For any proposition (e.g., the halting of a Turing machine), that 253 | we can encode as a Set, hamlet promises to compute whether or not 254 | it has a proof. That's far cleverer than a real computer. 255 | -} 256 | 257 | nnHamlet : {B : Set} -> Not (Not (B /+/ Not B)) 258 | nnHamlet z = z (inr (\ b -> z (inl b))) 259 | 260 | {- Just for fun... -} 261 | 262 | DEMORGAN2 : Set1 263 | DEMORGAN2 = {A B : Set} -> Not (A /*/ B) -> (Not A /+/ Not B) 264 | 265 | DNEGE : Set1 266 | DNEGE = {X : Set} -> Not (Not X) -> X 267 | 268 | HAMLET : Set1 -- also known as "the law of the excluded middle" 269 | HAMLET = {B : Set} -> B /+/ Not B -- or "tertium non datur" (third (way) not given) 270 | 271 | -- and one more variation, Peirce's Law, also a classical truth 272 | 273 | PEIRCE : Set1 274 | PEIRCE = {P Q : Set} -> ((P -> Q) -> P) -> P 275 | 276 | -- DNEGE, PEIRCE and HAMLET are equivalent 277 | 278 | imp1 : DNEGE -> HAMLET 279 | imp1 dne = dne nnHamlet 280 | 281 | imp2 : HAMLET -> PEIRCE 282 | imp2 h {P} {Q} pqp with h {P} 283 | imp2 h pqp | inl p = p 284 | imp2 h pqp | inr np = pqp (\ p -> magic (np p)) where 285 | 286 | imp3 : PEIRCE -> DNEGE 287 | imp3 peirce nnx = peirce (\ nx -> magic (nnx nx)) 288 | 289 | -- they all imply DEMORGAN2 290 | 291 | impDeMorgan : DNEGE -> DEMORGAN2 292 | impDeMorgan dne nab = dne (\ z -> z (inl (\ a -> z (inr (\ b → nab (a , b)))))) 293 | 294 | -- but (and sorry if I led some of you to believe the opposite) 295 | -- DEMORGAN2 is weaker than the others, because you can only 296 | -- get one bit at at time 297 | 298 | {- So, the business of constructing values as evidence for 299 | propositions corresponds to functional programming in a "total" 300 | language, but it doesn't give us quite the same logic as the 301 | Boolean logic we teach you when you start. That logic (aka 302 | "classical logic") makes "true" some things which do not correspond 303 | to computations. 304 | 305 | The logic you get here is sometimes called "constructive logic" 306 | because we ask not "is it true?" but "can you make the evidence?". 307 | 308 | FUN FACT (due to Kurt Goedel): if something is true, classically, 309 | you can prove that it's not false, constructively. 310 | 311 | WEIRD POSSIBILITY: there are such things as "anti-classical" logics 312 | which are even more constructive, in which things like HAMLET are 313 | actually false; these logics build in the idea that the *only* 314 | truths arise by construction. 315 | -} 316 | --------------------------------------------------------------------------------