Labs

The labs usually consist of two parts. In the first part, the teacher introduces new concepts from the last lecture and show students how to use them. In the second part, students are given tasks which they try to solve individually. The solutions to the given tasks will be available after the last lecture of the week.

The goal of this lab is to make the students familiar with the IDE we will use for Scheme and help them write first simple programs.

The IDE can be downloaded for free for Linux, Windows, MAC from: https://racket-lang.org/

Due to the pandemic situation, the labs will be online. Thus students are supposed to install DrRacket on their computers so that they can work on the tasks discussed in the labs.

Get familiar with the definition window and REPL in DrRacket. The documentation of implemented functions is accessible via Help Desk in the menu.

Explain the language (scheme variant) selection options via the #lang directive.

1. #lang scheme (same as #lang racket)
2. #lang r5rs (if you wish to follow the R5RS standard)

Start interaction in REPL. Scheme uses prefix notation for all functions. Let students compute simple formulas, e.g., 2+3/5.

Exercise 1: Write a recursive function my-even? that decides whether a number is even using only functions +, -, = (without mutual recursion).

(define (my-even? n)
  (cond
    ([< n 0] (my-even? (- n)))
    ([= n 0] #t)
    ([= n 1] #f)
    (else (my-even? (- n 2)))
    )
  )

Exercise 2: Using the function string-append, create a function (copy-str n str) taking as arguments an integer n, a string str and returns a string consisting of n-many copies of str. For example (copy-str 3 “abc”) ⇒ “abcabcabc”.

(define (copy-str n str)
  (if (<= n 0)
      ""
      (string-append str (copy-str (- n 1) str))
      )
  )

Exercise 3: Rewrite the function from Exercise 2 so that it uses tail recursion.

(define (copy-str n str [acc ""])
  (if (<= n 0)
      acc
      (copy-str (- n 1) str (string-append acc str))
      )
  )

Exercise 4: Write a function (consecutive-chars first last) which takes two characters and returns a string consisting of a sequence of consecutive characters starting with first, ending with last and following the order in ASCII table. For example (consecutive-chars #\A #\D) ⇒ “ABCD” or (consecutive-chars #\z #\u) ⇒ “zyxwvu”. For converting characters into positions in ASCII table use functions char->integer and integer->char.

(define (integer->string i)
  (string (integer->char i))
  )
 
(define (consecutive-chars first last)
  (define first-index (char->integer first))
  (define last-index (char->integer last))
  (define step (if (< first-index last-index) 1 -1))
  (define (iter k acc)
    (if (= k last-index)
        (string-append acc (integer->string k))
        (iter (+ k step)
              (string-append acc (integer->string k)))
        )
    )
  (iter first-index "")
  )

Try to solve the following individual tasks.

Task 1: Write a function num-of-digits which takes an integer n and computes the number of digits n has in the standard decimal representation. For example (num-of-digits 123) ⇒ 3 or (num-of-digits -3456) ⇒ 4.

Hint: The number of digits can be computed by successive dividing the input number by 10. For the integer division, you can use the function quotient.

(define (num-of-digits n [acc 1])
  (cond ([< n 0] (num-of-digits-tail (- n)))
        ([< n 10] acc)
        (else (num-of-digits-tail (quotient n 10) (+ acc 1)))
        )
  )

Task 2: Write a function (num->str n [radix 10]) taking as input an integer n together with radix denoting the number of symbols used to represent the number n (for example 2,10,16 for binary, decimal, hexadecimal representation respectively). This function returns a string containing the representation of n in the corresponding numerical system. For the representation use the standard symbols 0123456789ABCDEF.

Examples:

• (num->str 52) ⇒ “52”,
• (num->str 5 2) ⇒ “101”,
• (num->str 255 16) ⇒ “FF”.

Hint: The representation can be obtained by consecutive division of n by radix and collecting the remainders. The remainder after integer division can be computed by the function remainder.

(define (num->str n [radix 10])
  (define rem (remainder n radix))
  (define initial (if (< rem 10)
                      (char->integer #\0)
                      (- (char->integer #\A) 10)))
  (define rem-str
    (string (integer->char (+ initial rem))))
 
  (if (< n radix)
      rem-str
      (string-append (num->str (quotient n radix) radix)
                     rem-str)
      )
  )

The main purpose is to practice elementary recursive manipulation with lists. Lists can be decomposed by functions car and cdr. On the other hand, lists can be built by functions cons, list or append. Also higher-order functions filter and map can be used as they were introduced in the second lecture (map only applied to a single list).

Exercise 1: Write the function (my-reverse lst) taking a list lst and returning a list consisting of elements from lst in the reverse order. E.g. (my-reverse '(a b c)) ⇒ (c b a). The function should use the tail recursion.

Hint: The idea is to use an accumulator acc storing the intermediate result. We start with an empty accumulator and recursively deconstruct the list lst element by element by means of car,cdr and join them to the accumulator by cons. The computation for lst = '(a b c) and acc = '() go as follows:

(define (my-reverse lst [acc '()])
  (if (null? lst)
      acc
      (my-reverse (cdr lst) (cons (car lst) acc))
      )
  ) 

Note that using the accumulator is a general concept.

Exercise 2: Write a function (letter-frequencies str) which takes a string str and returns a histogram of letters occurring in str so that the most frequent characters come first. The histogram is just a list of pairs (char . num) where char is a character and num is the number of its occurrences in str. E.g. (letter-frequencies “good”) ⇒ ((#\o . 2) (#\d . 1) (#\g . 1)). The string str should be first converted into lowercase characters so that #\A and #\a represent the same character. Non-alphabetic characters should be removed.

Idea: The function letter-frequencies is just a composition of several functions.

string-downcase -> string->list -> filter-alphabetic -> sort -> group-same -> join-lengths -> sort

1. The function string-downcase translates all characters into lowercase letters and it is implemented in racket.
2. The function string->list is implemented as well and it decomposes a given string into a list of its characters.
3. Then non-alphabetic characters can be filter out by filter function using the predicate char-alphabetic?.
4. To compute the number of occurrences of characters, we apply sort function which groups together the same characters, e.g. (sort '(#\c #\z #\c) char<?) ⇒ (#\c #\c #\z). The function sort takes as its second argument a boolean function taking two arguments and comparing them.
5. The function group-same scans the input list and returns a list consisting of lists of the same consecutive characters, e.g. (group-same '(#\c #\c #\z)) ⇒ ((#\c #\c) (#\z)).
6. The function join-lengths creates for each group of the same character a pair of the for (char . num) where the number of occurrences num is computed by function length.
7. Finally, the output is sorted by numbers of occurrences.

The function group-same is the only recursive function in our program. It has to keep as an intermediate result a partially built group of the same character. If the new character (car l) coming from the list is the same as the current character in the group, the partial group is extended by this character. Once the new character (car l) differs from the current character in the group, the partial group is closed, joined to the output and a new group is created.

(define (group-same lst)
  (define (iter l gr)
    (cond
      ([null? l] (list gr))
      ([eqv? (car gr) (car l)] (iter (cdr l) (cons (car gr) gr)))
      (else (cons gr (iter (cdr l) (list (car l)))))
      )
    )
  (if (null? lst)
      '()
      (iter (cdr lst) (list (car lst)))
      )
  )
 
(define (join-lengths grs)
  (map (lambda (g) (cons (car g) (length g))) grs)
  )
 
(define (letter-frequencies str)
  (sort
   (join-lengths
    (group-same
     (sort
      (filter char-alphabetic? (string->list (string-downcase str)))
      char<?)))
   (lambda (x y) (> (cdr x) (cdr y))))
  )

If you wish, you can use function file->string to check letter frequencies in any file, for instance in Shakespeare's Sonnets by calling (letter-frequencies (file->string "sonnets.txt")) and comparing the result with the letter frequencies in English alphabet Wikipedia.

Task 1: Write a function (average-list lst) taking a list of numbers lst and returning their arithmetical average. E.g. (average-lst '(1 2 3)) ⇒ 3. The function should be tail-recursive.

Hint: As the function should be tail-recursive, it has to use an accumulator storing a partial sum of elements from the list. Finally, the resulting sum is divided by the number of all elements in the list. For the number of elements in lst, you can use the function length. Depending on your implementation function can return precise rational numbers like (average-list '(0 1)) ⇒ 1/2. If you want to have the usual floating-point representation, use the function exact->inexact transforming the result into imprecise floting-point representation.

(define (average-list lst)
  (define (iter l acc)
    (if (null? l)
        acc
        (iter (cdr l) (+ acc (car l)))
        )
    )
  (exact->inexact (/ (iter lst 0) (length lst)))
  )      

Task 2: Taking an inspiration from the group-same function, write a function (split-list n lst) which takes a natural number n and a list lst and returns a list of lists consisting of n-tuples of consecutive elements from lst. E.g. (split-list 2 '(a b 1 2 3 4)) => ((a b) (1 2) (3 4)). In case the number of elements is not divisible by n, make the last list in the output shorter. E.g. (split-list 3 '(a b 1 2)) => ((a b 1) (2)).

Using functions split-list and average-list from the previous task, write a function (n-block-average n lst) which splits a given list of numbers lst into n-tuples of consecutive numbers and returns a list of averages of these n-tuples. E.g. (n-block-average 2 '(1 3 1 5)) ⇒ (2 3).

Hint: The function split-list needs two accumulators. The first accumulator keeps a partially built segment of consecutive elements and the second tracks how many elements we have to read from the list to complete the n-tuple of consecutive elements.

(define (split-list n lst)
  (define (iter l k segment)
    (cond
      ([null? l] (list segment))
      ([= k 0] (cons segment (iter l n '())))
      (else (iter (cdr l) (- k 1) (append segment (list (car l)))))
      )
    )
  (iter lst n '())
  )
 
(define (n-block-average n lst)
  (map average-list (split-list n lst))
  )

Exercise 1: Write a function (mult-all-pairs lst1 lst2) taking two lists and returning a list of all possible binary products between elements from lst1 and elements from lst2. Mathematically, it could be written by a comprehension term as [ x*y | x in lst1, y in lst2 ]. E.g. (mult-all-pairs '(1 2 3) '(-2 0)) ⇒ (-2 0 -4 0 -6 0). Once you have it, generalize your function to (f-all-pairs f lst1 lst2) so that the multiplication is replaced by any binary function f. E.g. (f-all-pairs cons '(1 2 3) '(a b)) ⇒ ((1 . a) (1 . b) (2 . a) (2 . b) (3 . a) (3 . b)).

Hint: These functions are just applications of two nested map functions. For each element x in lst1 we multiply by x all elements in lst2. A function multiplying by x can be created from the multiplication function * by partial application of x, i.e., we take the curryfied version of * and apply it to x yielding ((curry *) x). Once we map ((curry *) x) along lst2, the result is a list. So doing it for each x in lst1 results in a list of lists. Thus we have to flatten the result and append all the lists. This can be done by apply-ing append.

(define (mult-all-pairs lst1 lst2)
  (apply   ; flatten the result
   append
   (map
    (lambda (x) (map ((curry *) x) lst2)) ; multiply all elements of lst2 by x
    lst1)                                 ; do it for each element x in lst1
   )
  )
 
(define (f-all-pairs f lst1 lst2)
  (apply
   append
   (map
    (lambda (x) (map ((curry f) x) lst2))
    lst1)
   )
  )

Exercise 2: Suppose we represent univariate polynomials as lists of monomials. Each monomial of the form $ax^n$ is represented as a list (a n) consisting of the coefficient a and the exponent n. Thus the polynomial $2-3x+x^2$ is represented by ((2 0) (-3 1) (1 2)). We assume that each exponent can occur in the polynomial representation at most once. E.g. ((1 0) (2 0)) is not a valid representation. Devise functions (add-pol p1 p2) and (mult-pol p1 p2) taking as arguments two polynomials p1,p2 and returning their sum and product respectively. For example, let p1 be ((1 0) (1 1)) (i.e., $p_1(x)=1+x$) and p2 ((-1 0) (1 1) (3 2)) (i.e., $p_2(x)=-1+x+3x^2$). Then

(add-pol p1 p2) => ((2 1) (3 2))  
(mult-pol p1 p2) => ((-1 0) (4 2) (3 3))

Even though it might look like a tedious task, it is not so terrible because we will call higher-order functions to rescue us. Thanks to the folding function foldl, we will reduce our problem just to monomials. Let's start by defining simple operations on monomials. To make our code more comprehensible, we define the following functions extracting the coefficient and the exponent from a monomial.

(define (get-coef m) (car m)) ; first component
(define (get-exp m) (cadr m)) ; second component

Next it is easy to define addition of two monomials of the same exponents, namely $ax^n + bx^n = (a+b)x^n$. Similarly, multiplication of monomials is defined by $(ax^n)(bx^k)=abx^{n+k}$.

(define (add-mon m1 m2)
  (list (+ (get-coef m1) (get-coef m2)) ; sum coefficients
        (get-exp m1))                   ; keep exponent
  )
 
(define (mult-mon m1 m2)
  (list (* (get-coef m1) (get-coef m2)) ; multiply coefficients
        (+ (get-exp m1) (get-exp m2)))  ; sum exponents
  )

Now we come to the main trick. Suppose we have two polynomials $p_1(x)=a_0+a_1x$ and $p_2(x)=b_0+b_1x+b_2x^2$. We can express their sum as $p_1(x) + p_2(x) = ((p_1(x) + b_0) + b_1x) + b_2x^2$. Thus we need only to add a polynomial and a monomial at a single steps. Then the repetitive sum can be done by foldl function. Similarly for the multiplication, we can first compute products of all monomials by means of the function f-all-pairs from Exercise 1 and then express the results as $p_1(x)p_2(x) = (((a_0b_0 + a_0b_1x) + a_0b_2x^2) + a_1b_0x) + \cdots$.

Thus we need a function adding a monomial mon and a polynomial pol. The function has to distinguish two cases: 1) we add a monomial whose exponent does not occur in pol, 2) or whose exponent occurs in pol. So we first filter monomials in pol according to their exponents to obtain the monomial of the same exponent as mon and the remaining monomials. If there is no monomial of the same exponent, we just cons mon to the result, otherwise we add monomials of the same exponent and cons it to the result.

(define (add-mon-pol mon pol)
  (define (same-exp? m) (= (get-exp mon) (get-exp m))) ; #t if m has the same exponent as mon
  (define same-mon (filter same-exp? pol))             ; list containing the monomial of the same exponent or empty list
  (define rest (filter (compose not same-exp?) pol))   ; remaining monomials of different exponents
  (if (null? same-mon)                                 
      (cons mon rest)
      (cons (add-mon mon (car same-mon)) rest))
  )

Finally, we can apply the folding function foldl to sum all monomials as was shown above. However, there are still two problems we have to deal with. 1) It may happen that the result contains monomials of the form $0x^n$. Such monomials can be clearly filtered out of the result. 2) It is common to sort monomials according to their exponents. Thus we define a function normalize solving these two problems.

(define (normalize p)
  (define (non-zero-coef? m) (not (= 0 (get-coef m)))) 
  (sort
   (filter non-zero-coef? p)
   (lambda (p1 p2) (< (get-exp p1) (get-exp p2))))
  )
 
(define (add-pol p1 p2)
  (normalize (foldl add-mon-pol p1 p2))
  )
 
(define (mult-pol p1 p2)
  (normalize (foldl add-mon-pol '() (f-all-pairs mult-mon p1 p2)))
  )

Task 1: Write a function linear-combination taking a list of vectors, a list of coefficients and returning the corresponding linear combination. The function should be created in the curried form (the list of vectors being the first argument) because it will be convenient for the next task. For example, consider a linear combination $2\cdot(1, 2, 3) - 1\cdot(1, 0, 1) + 3\cdot(0, 2, 0) = (1,10,5)$. Then your implementation should work as follow:

 ((linear-combination '((1 2 3) (1 0 1) (0 2 0))) '(2 -1 3)) => (1 10 5)

Hint: Create first a binary function computing scalar multiplication of a scalar and a vector using map. Then use the fact that map can apply the scalar multiplication to two lists simultaneously (in our case the list of coefficients and the list of vectors). This results in a list of vectors multiplied by respective coefficients. Then it suffices to sum them component by component.

(define (scalar-mult coef vec)
  (map ((curry *) coef) vec)
  )
 
(define (linear-combination vectors)
  (lambda (coefs)
    (apply map + (map scalar-mult coefs vectors))
    )
  )

Task 2: Use the function from the previous task to define a function (matrix-mult m1 m2) computing the matrix multiplication of m1 and m2. Then apply foldl function to define the power of a square matrix, i.e., a function (matrix-power k mat) computing k-fold product of mat. You can assume that $k\geq 1$ so that there is no need to define the identity matrix. E.g.

 (matrix-mult '((1 2 3) 
                (-1 0 2)) 
              '((1 -1) 
                (2 0) 
                (0 3))) => ((5 8) (-1 7)) 
 
 (matrix-power 3 '((2 3) (0 -1))) => ((8 -9) (0 -1))

Hint: Use the fact that the matrix multiplication is just a repeated application of the linear-combination function. More precisely, consider $m_1\cdot m_2$. The $i$-th row of the result is just the linear combination of the rows of $m_2$ with the coefficients taken from the $i$-th row of $m_1$. So it suffices to apply the (linear-combination m_2) to each row of $m_1$.

To define the matrix power, use the foldl function applied to a list composed of the same matrix mat. To create such a list, use function (make-list n el) ⇒ (el el … el).

(define (matrix-mult m1 m2)
  (map (linear-combination m2) m1)
  )
 
(define (matrix-power k mat)
  (foldl matrix-mult mat (make-list (- k 1) mat))
  )

Exercise 1: Write a function (permutations lst) taking a list lst and returning all its permutations. E.g. (permutations '(1 2 3)) => ((1 2 3) (2 1 3) (2 3 1) (1 3 2) (3 1 2) (3 2 1)).

Hint: Suppose that we have all permutations of a list of length $n$ and we want to build all permutations of its extension by an element. To do that it suffices to take the element and interleave it in all possible ways into all the permutations of length $n$. For instance, ((2 3) (3 2)) are all permutations of the list (2 3). If we want to compute all permutations of (1 2 3), we take each permutation of length 2 and interleave the element 1 into it as follows:

(2 3) => ((1 2 3) (2 1 3) (2 3 1))
(3 2) => ((1 3 2) (3 1 2) (3 2 1))

Appending all these lists gives us the desired permutations of (1 2 3).

Write first a function interleave taking an element, a list and returning all possible ways of inserting the element into the list. Using this function, devise the function permutations using the recursion on the length of lst.

(define (interleave el)
  (lambda (lst)
    (if (null? lst)
        (list (list el))                            ; there is only a single way one can insert el into '()
        (cons (cons el lst)                         ; otherwise one possibility is to prepend el to lst 
              (map ((curry cons) (car lst)) 
                   ((interleave el) (cdr lst))))    ; or take all possible insertions of el into (cdr lst) 
        )                                           ; and prepend (car lst)
    )
  )
 
(define (permutations lst)
  (if (null? lst)
      '(())
      (apply append 
             (map (interleave (car lst)) (permutations (cdr lst)))) ; into each permutation of (cdr lst) interleave (car lst) 
      )                                                             ; and append the results
  )

Exercise 2: Binary decision trees are tree representing Boolean functions, i.e., functions from $\{0,1\}^n$ to $\{0,1\}$. Let $f(x_1,\ldots,x_n)$ be a Boolean function. The corresponding binary decision tree is created as follows:

1. Each input variable $x_i$ induces the $i$th-level in the tree whose nodes are labelled by $x_i$.
2. Leaves are elements from $\{0,1\}$.

Each path from the root to a leaf encodes an evaluation of input variables. If the path in an internal node $x_i$ goes to the left, the variable $x_i$ is evaluated by $0$. If to the right, it is evaluated by $1$. The leaf in the path represents the value $f(x_1,\ldots,x_n)$ for the evaluation defined by the path. Example of a Boolean function and its binary decision tree:

We will represent such binary tree in Scheme by nested lists. The internal nodes are of the form (<var> <left-subtree> <right-subtree>). For instance, the above tree is represented as follows:

(define bool-tree '(x1 (x2 (x3 1 0) (x3 0 1)) (x2 (x3 0 0) (x3 1 1))))

Your task is to write two functions. The first one (evaluate tree vals) takes a binary decision tree tree representing a Boolean function $f(x_1,\ldots,x_n)$, a list vals of values of variables $x_1,\ldots,x_n$ and returns $f(x_1,\ldots,x_n)$. E.g.

(evaluate bool-tree '(1 0 1)) => 0
(evaluate bool-tree '(0 1 1)) => 1

The second function (satisficing-evaluations tree) taking a binary decision tree tree representing a Boolean function $f(x_1,\ldots,x_n)$ and returning all its satisficing evaluations, i.e., those for which $f(x_1,\ldots,x_n)=1$. E.g.

(satisficing-evaluations bool-tree) =>
  (((x1 0) (x2 0) (x3 0)) ((x1 0) (x2 1) (x3 1)) ((x1 1) (x2 1) (x3 0)) ((x1 1) (x2 1) (x3 1)))

Before we start to code the functions itself, we define a couple of helper functions accessing the members of a node.

(define (variable tree) (car tree))
(define (left-subtree tree) (cadr tree))
(define (right-subtree tree) (caddr tree))

Such functions are not necessary but it is a good practice to define them for the following reasons:

1. Your code is more readable. E.g. if I write (iter (right-subtree tr) …, then it is clear that I iterate over the right subtree. On the other hand, one has to remember the precise structure of the node to understand (iter (caddr tr) ….
2. Such helper functions erect so-called abstraction barriers between your code and the data representation. If you decide for some reason to change your representation (e.g, to change the structure of nodes to (<left-subtree> <var> <right-subtree>)), it suffices to recode only helpers functions. The rest of your code stays untouched unlike the case when you don't use them.

We devise two versions of evaluate. The first is recursive function consuming consecutively values of $x_1,\ldots,x_n$ and based on its value recursively evaluate either left or right subtree. Once all the values are consumed, we should be in a leaf specifying the value of $f(x_1,\ldots,x_n)$.

(define (evaluate tree vals)
  (cond
    ([null? vals] tree)                                          ; the leaf is the resulting value
    ([= (car vals) 0] (evaluate (left-subtree tree) (cdr vals))) ; if the variable value is 0, go to the left
    (else (evaluate (right-subtree tree) (cdr vals)))            ; otherwise go to the right
    )
  )

The second version uses higher-order functions. It takes the list of values of $x_1,\ldots,x_n$ and converts it into the list of functions left-subtree, right-subtree corresponding to the path defined by vals. Finally, it applies their composition to tree.

(define (evaluate2 tree vals)
  (define (left-right v)                         ; define function 0 -> left-subtree, 1 -> right-subtree
    (if (= v 0) left-subtree right-subtree))
  ((apply compose (map left-right (reverse vals))) tree)   ; map it over vals, compose and apply to tree
  )

The function satisficing-evaluations is a recursive function using an accumulator ev keeping partial evaluation as we traverse the tree. It recursively finds all satisficing evalutions of the left and right subtree, extend them by $0$ (resp. $1$) if they come from left (resp. right), and append them together.

(define (satisficing-evaluations tree)
  (define (make-assignment var val) (list var val))    ; a helper function creating an assignment 
  (define (iter tr ev)
    (if (number? tr)                                   ; are we in a leaf?
        (if (= tr 1) (list (reverse ev)) '())          ; if yes and the resulting value is 1 return that evaluation, otherwise discard it
        (append (iter (left-subtree tr) (cons (make-assignment (variable tr) 0) ev))    ; if not, extend the partial evaluation ev
                (iter (right-subtree tr) (cons (make-assignment (variable tr) 1) ev)))  ; recursively collects satisficing evaluations for
        )                                                                               ; left and right subtree and append
    )
  (iter tree '())
  )

Task 1: Write a function (sub-seq lst) taking a list lst and returning a list of all its sublists/subsequences. E.g.

(sub-seq '(1 2 3)) =>
  (() (3) (2) (2 3) (1) (1 3) (1 2) (1 2 3))

Hint: Code it as a recursive function using the following facts. 1) There is only a single subsequence of the empty list, namely the empty list. 2) Subsequences of $(x_1,x_2,\ldots,x_n)$ are just subsequences of $(x_2,\ldots,x_n)$ together with subsequences starting with $x_1$ and following by a subsequence of $(x_2,\ldots,x_n)$.

(define (sub-seq lst)
  (if (null? lst)
      '(())
      (let ([el (car lst)]
            [rest-sub-seq (sub-seq (cdr lst))])
        (append rest-sub-seq
                (map ((curry cons) el) rest-sub-seq))
        )
      )
  )

Task 2: Consider a binary tree representing a tournament. Each internal node corresponds to a match. Its structure is (<winner> <left-subtree> <right-subtree>). Leafs are of the form (<team>). E.g.

(define tournament '(F (D (A (A) (B)) (D (C) (D))) (F (F (E) (F)) (G (G) (H)))))

represents the following tree:

                 F
                / \
               /   \
              /     \
             /       \
            /         \
           D           F
          / \         / \
         /   \       /   \
        A     D     F     G
       / \   / \   / \   / \
      A   B C   D E   F G   H

Write a function (beaten-teams tree) taking a binary tournament tree and outputting the list of beaten teams by the winner. E.g. (beaten-teams tournament) ⇒ (D G E).

Hint: Code it as a recursive function starting in the root defining the winner of the tournament. Then follow the path labelled by the winner and collects the beaten teams along the path to an accumulator. Once you are in a leaf return the accumulator.

(define (beaten-teams tree)
  (define (winner tr) (car tr))
  (define (is-leaf? tr) (= (length tr) 1))
  (define (left-subtree tr) (cadr tr))
  (define (right-subtree tr) (caddr tr))
  (define (iter tr acc)
    (cond
      ([is-leaf? tr] acc)
      ([eqv? (winner (left-subtree tr)) (winner tree)]
       (iter (left-subtree tr)
             (cons (winner (right-subtree tr)) acc)))
      (else
       (iter (right-subtree tr)
             (cons (winner (left-subtree tr)) acc)))
      )
    )
  (iter tree '())
  )

Exercise 1: Define a function (stream-add s1 s2) adding two infinite streams together component-wise. For instance,

  0 1 2 3 4 5 6 ....
+ 1 1 1 1 1 1 1 ....
--------------------
  1 2 3 4 5 6 7 ....

Using stream-add, define the infinite stream fib-stream of all Fibonacci numbers. We can test it for instance as follows:

(stream->list (stream-take fib-stream 10)) =>
  (0 1 1 2 3 5 8 13 21 34)

Adding two infinite streams can be done recursively. Since the streams are infinite we do not have to check the emptiness of any of the input streams.

(define (stream-add s1 s2)
  (stream-cons (+ (stream-first s1) (stream-first s2))
               (stream-add (stream-rest s1) (stream-rest s2))))

The definition of Fibonacci sequence $F(0)=0$, $F(1)=1$, and $F(n)=F(n-1) + F(n-2)$ for $n>1$ can be reformulated as follows:

      0 1 1 2 3  5  8 13 ...   ; F(n-2) - Fibonacci sequence
+     1 1 2 3 5  8 13 21 ...   ; F(n-1) - shifted Fibonacci sequence to the left by one element
----------------------------
  0 1 1 2 3 5 8 13 21 34 ...   ; Fibonacci sequence starts with 0,1 followed by the sum of the above sequences

This directly leads to the following code:

(define fib-stream
  (stream-cons 0
               (stream-cons 1
                            (stream-add fib-stream
                                        (stream-rest fib-stream))))
  )

Apart from streams, this lab is also focused on graphs. A graph $G=(V,E)$ is a tuple consisting of a set of vertices $V$ (also called nodes) and a set of edges $E\subseteq\{\{u,v\}\mid u,v\in V, u\neq v\}$. We will represent a graph in Scheme as a list of two lists. The first is a list of vertices and the second is a list of edges. An edge $\{u,v\}$ is represented as a list (u v). We define a constructor for a graph and helper functions getting the list of vertices and the list of edges.

(define (make-graph nodes edges)
  (list nodes edges))
(define (get-nodes g) (car g))
(define (get-edges g) (cadr g))

The following graph is represented as follows:

(define gr (make-graph '(1 2 3 4 5 6) '((1 2) (1 5) (2 3) (2 5) (3 4) (4 5) (4 6))))

Exercise 2: Given a graph $G$, a Hamiltonian path is a path visiting each vertex of $G$ exactly once (see wikipedia). We will represent a path as a list of consecutive nodes in the path. The above graph gr has a Hamiltonian path (3 2 1 5 4 6).

Write a function (find-hamiltonian-path g) which takes a graph as its input and returns a Hamiltonian path, if it exists, and #f otherwise. E.g.

(find-hamiltonian-path gr) => (3 2 1 5 4 6)
(find-hamiltonian-path (make-graph '(a b c d) '((a b) (a c) (a d)))) => #f

As a Hamiltonian path traverses each node exactly once, if it exists, it has to be represented by a permutation of the nodes. Thus we can apply the function permutations from the previous lab to generate all permutations of nodes and check for each of them whether it forms a Hamiltonian path or not. We start with a definition of a function checking if a given list of nodes is a path. For that, we need a function testing whether a pair of nodes is connected.

; test whether a pair of nodes is connected
(define (edge? g)
  (lambda (p)
    (define edges (get-edges g))
    (or (member p edges) (member (reverse p) edges))
    )
  )

Given a list, we create a list of pairs of consecutive nodes. E.g. (1 2 3 4) is transformed to ((1 2) (2 3) (3 4)). This is done by taking (1 2 3) and (2 3 4) and joining them by mapping list element-wise. Finally, we test whether all these pairs are connected. To do so, we use the function (andmap f lst). This function is implemented in Racket. It behaves like map but it aggregates the results of f by and function, i.e., once any of the results is #f, it returns #f and the last result otherwise.

(define (check-path g)
  (lambda (lst)
    (define but-last (take lst (- (length lst) 1)))
    (if (andmap (edge? g) (map list but-last (cdr lst)))
        lst
        #f)
    )
  )

Now we can apply the above function to all permutation. The function (check-path g) for a graph g either returns lst if lst forms a path or #f otherwise. Thus we can map it over all permutations of nodes and filter those which form a path. If there is a permuation being a path at the same time, we have a Hamiltonian path. Otherwise, we return #f.

(define (find-hamiltonian-path g)
  (define nodes (get-nodes g))
  (define perms (permutations nodes))
  (let ([paths (filter identity (map (check-path g) perms))])
    (if (null? paths)
        #f
        (car paths)
        )
    )
  )

Task 1: Write a function (stream-mul s1 s2) taking two infinite streams and multiplying them elements-wise. Using this function, define an infinite stream factorial-stream of factorials $0!, 1!, 2!, 3!,\ldots$.

Hint: The recursive definition of factorial $f(0)=1$ and $f(n)=n\cdot f(n-1)$ for $n>0$ gives us

    1 2 3  4   5 ...  ; n
*   1 1 2  6  24 ...  ; f(n-1)
--------------------
  1 1 2 6 24 120 ...  ; f(n)

In your definition, you can use the function (in-naturals n) implemented in Racket defining the stream of natural numbers starting from n.

Once you have the stream of factorials factorial-stream, the function stream-mul and the stream of natural numbers (in-natural 0) (or even simply (in-naturals)), you can define a function (exp-stream x) taking a number x and returning the power series representing $e^x$, i.e., $e^x = 1 + x + \frac{x^2}{2!} + \frac{x^3}{3!} + \cdots$. Then you can approximate the value $e^x$ by summing an initial segment of this stream. E.g. to approximate $e$, we can sum the first 100 elements:

(apply + (stream->list (stream-take (exp-stream 1.0) 100)))

(define (stream-mul s1 s2)
  (stream-cons (* (stream-first s1) (stream-first s2))
               (stream-mul (stream-rest s1) (stream-rest s2))))
 
(define factorial-stream (stream-cons 1 (stream-mul (in-naturals 1) factorial-stream)))
(stream->list (stream-take factorial-stream 10))
 
(define (exp-stream x)
  (define recipr (stream-map ((curry /) 1) factorial-stream))
  (define powers (stream-map ((curry expt) x) (in-naturals)))
  (stream-mul powers recipr)
  )

Task 2: Given a graph $G=(V,E)$, a subset of nodes $S\subseteq V$ is called a vertex cover, if for every edge $\{u,v\}\in E$, we have $u\in S$ or $v\in S$. If $S$ is smallest possible, it is called minimum vertex cover (see wikipedia).

Write a function (min-vertex-cover g) taking a graph g and returning a minimum vertex cover of g. E.g.

(min-vertex-cover gr) => (1 2 4)

Hint: The idea is similar to Exercise 2. Instead of all permutations, we can take all subsets of nodes. Subsets can be generated by the function sub-seq from the previous lab. We can sort them by cardinality and starting from the smallest ones, we can check which of them form a vertex cover. In fact, it is computationally more efficient, if we create a stream of subsets so that subsets are computed lazily as they are needed. Thus we can test smaller subsets first without computing large ones. To create such a lazy stream, we can modify the function sub-seq. It is basically the same code where list functions are replaced by their stream equivalents. However, our original function sub-seq does not generate subsets ordered by their cardinality. To fix this, we have to modify the function merging together the result of the recursive call and the newly created subsets. Thus we define a function (stream-merge s1 s2 cmp) which takes two streams and a function cmp comparing two elements of these streams and returns a stream where the values are merged so that the smaller elements come first.

; lazy subsequences
(define (stream-merge s1 s2 cmp)
  (cond
    ([stream-empty? s1] s2)
    ([stream-empty? s2] s1)
    ([cmp (stream-first s1) (stream-first s2)]
     (stream-cons (stream-first s1) (stream-merge (stream-rest s1) s2 cmp)))
    (else (stream-cons (stream-first s2) (stream-merge s1 (stream-rest s2) cmp)))
    )
  )
 
(define (sub-seq lst)
  (if (null? lst)
      (stream '())
      (let ([el (car lst)]
            [rest-sub-seq (sub-seq (cdr lst))])
        (stream-merge rest-sub-seq
                (stream-map ((curry cons) el) rest-sub-seq)
                (lambda (x y) (< (length x) (length y))))
        )
      )
  )

; minimum vertex cover = smallest subset of nodes such that each edge has one of its node in it
(define (check-cover g)
  (define edges (get-edges g))
  (lambda (lst)
    (if (andmap (lambda (e) (or (member (car e) lst) (member (cadr e) lst))) edges)
        lst
        #f)
    )
  )
 
(define (min-vertex-cover g)
  (define nodes (get-nodes g))
  (stream-first (stream-filter identity (stream-map (check-cover g) (sub-seq nodes))))
  )

This lab is closely related to the corresponding lecture. In that lecture, I showed how to implement an interpreter of a simple programming language Brainf*ck (for details see wikipedia). The syntax of Brainf*ck is very simple. It is just a sequence of eight possible characters: < > + - , . [ ]. The semantics of this language is captured by a tape of a fixed size consisting of positive numbers and having a pointer pointing to an active number. Brainf*ck programs specify computations over this tape.

As I explained in the lecture, Scheme/Racket can represent any tree structure as data. Thus we don't need to write a parser and represent Brainf*ck directly as a list of commands where cycles are recursively represented by nested lists. The only limitation with this approach is the special meaning of symbols , and . in Racket. So we replace them by symbols @ * respectively. For instance, the program reading the first two numbers from input, adding them and displaying the result ,>,[-<+>]<. is represented in Racket as follows:

'(@ > @ [- < + >] < *)

The square brackets are interpreted in Racket as parentheses so the cycle automatically creates a nested list. Another example for your test cases is the program multiplying two numbers:

'(@ > @ < [- > [- > + > + < <] > [- < + >] < <] > > > *)

As the lecture introduced mutable data structures in Racket, I implemented the tape as an object (function closure) containing a mutable fixed-size vector representing the tape and a number representing the index/pointer of the active number. The goal of this lab is to modify my implementation from the lecture so that it is purely functional. This means that you need to replace the tape object with a purely functional data structure. Next, the implementation of the interpreter has to be modified a bit. My implementation creates a global tape that is modified by the interpreter during the computation. However, this is not a purely functional code. Thus the tape has to be as a part of the state of the computation included among interpreter's accumulators.

Task 1: Create a purely functional representation of the tape of a fixed size with a pointer. I will provide detailed hints on how to proceed. Represent your tape as a list (left value right) where left is a list representing numbers on the tape stored left from the pointer, val represents the active number and right is a list representing the number on the right. So start with the following definitions of a constructor, a function creating an empty tape and a function get returning a function accessing a component of the tape according to the message.

(define (make-tape left val right)
  (list left val right))
 
(define (fresh-tape size)
  (make-tape '() 0 (make-list (- size 1) 0)))
 
(define (get msg)
  (cond
    ([eqv? msg 'left] car)
    ([eqv? msg 'val] cadr)
    ([eqv? msg 'right] caddr)
    (else (error "unknown message"))
    )
  )

Now we can access for example the right list of a tape tape by calling ((get 'right) tape).

Your task is to finish the following function definitions:

(define (change op tape)
  (make-tape ((get 'left) tape)
             (op ((get 'val) tape) 1)
             ((get 'right) tape)))  
  )
 
(define (move dir tape)
   (let ([left ((get 'left) tape)]
        [val ((get 'val) tape)]
        [right ((get 'right) tape)])
    (cond
      ([null? ((get dir) tape)] (error "Outside tape"))
      ([eqv? dir 'left] (make-tape (cdr left) (car left) (cons val right)))
      (else (make-tape (cons val left) (car right) (cdr right))))
    ))  
  )

The function (change op tape) takes an operation + (resp. -) and a tape and returns a new tape where the active number is increased (resp. decreased). The second function (move dir tape) takes a direction 'left (resp. 'right) and a tape and returns a new tape where the pointer moves left (resp. right). In case the active number is a boundary number and moving the pointer would get the pointer outside the tape, the function should throw an error by calling (error “outside”). E.g. consider a tape consisting of numbers 1,2,3,4,5,6,7 with 4 being the active number.

(define tape (make-tape '(3 2 1) 4 '(5 6 7))) 
 
(change - tape) => '((3 2 1) 3 (5 6 7))
(change + tape) => '((3 2 1) 5 (5 6 7))
(move 'left tape) => '((2 1) 3 (4 5 6 7))
(move 'right tape) => '((4 3 2 1) 5 (6 7))

Task 2: Modify the implementation of the interpreter from the lecture so that it uses your purely functional tape.

Hint: The implementation from the lecture uses a global mutable tape which is defined once and then only reset when executing a program. Apart from the tape, the interpreter keeps its state in accumulators prg containing remaining commands and input storing the remaining input. You have to add one more accumulator tracking the tape.

Moreover, the function eval-prg returns the remaining input after processing all commands. This allows us to use it to execute a code in a cycle and obtain the remaining input to continue with the computation. In your modification, the function eval-prg has to return the remaining input together with the actual tape. This can be done e.g. by returning a list (list input tape).

For your convenience, my complete implementation is shown below. The particular tasks for you can be found below it.

#lang racket
 
; constant defining the size of tape
(define SIZE 10)
 
; constructor of the object tape of a given size
(define (make-tape size)
  (define tape (make-vector size 0))   ; initialize fresh tape
  (define ptr 0)                       ; pointer points to the first element
 
  (define (change op vec ptr)
    (vector-set! tape ptr (op (vector-ref tape ptr) 1)))
 
  (define (move op ptr)
    (let ([new-ptr (op ptr 1)])
      (if (or (< new-ptr 0) (> new-ptr size))
          (error "Moving outside tape")
          new-ptr)))
 
  (lambda (msg)
    (cond
      ([eqv? msg 'tape] tape)
      ([eqv? msg 'plus] (change + tape ptr))
      ([eqv? msg 'minus] (change - tape ptr))
      ([eqv? msg 'left] (set! ptr (move - ptr)))
      ([eqv? msg 'right] (set! ptr (move + ptr)))
      ([eqv? msg 'dot] (vector-ref tape ptr))
      ([eqv? msg 'comma] (lambda (val) (vector-set! tape ptr val)))
      ([eqv? msg 'reset] (vector-fill! tape 0) (set! ptr 0))
      )
    ))
 
; defines a global tape used by the interpreter
(define tape (make-tape SIZE))
 
; evaluates comma command, i.e., (car input) -> tape[ptr]
(define (eval-comma prg input)
  (cond
    ([null? input] (error "Empty input"))
    (else ((tape 'comma) (car input))
          (eval-prg prg (cdr input)))))  ; recursive call preocessing further commands
 
; evaluates all the commands beside comma
(define (eval-cmd cmd prg input)
  (cond
    ([eqv? cmd '+] (tape 'plus)) 
    ([eqv? cmd '-] (tape 'minus)) 
    ([eqv? cmd '<] (tape 'left)) 
    ([eqv? cmd '>] (tape 'right)) 
    ([eqv? cmd '*] (printf "~a " (tape 'dot))) 
    (else (error "Unknown command")))
  (eval-prg prg input)   ; recursive call preocessing further commands
  )
 
(define (eval-cycle cycle prg input)
  (if (= (tape 'dot) 0)                         ; is cycle is finished? 
      (eval-prg prg input)                      ; if yes, recursive call preocessing further commands
      (let ([new-input (eval-prg cycle input)]) ; otherwise evaluate cycle code
        (eval-cycle cycle prg new-input)        ; and execute the cycle again       
        )
      ))
 
(define (eval-prg prg input)
  (if (null? prg)                 ; are all commands processed?
      input                       ; if yes, return remaining input
      (let ([cmd (car prg)]
            [rest (cdr prg)])
        (cond
          ([eqv? cmd '@] (eval-comma rest input))      
          ([list? cmd] (eval-cycle cmd rest input))
          (else (eval-cmd cmd rest input))))
      ))
 
; executes the given program with the given input
(define (run-prg prg input)
  (tape 'reset)              ; fill tape by zeros
  (eval-prg prg input)       ; evaluate program
  (printf "done~n")
  )

A solution to Task 2 can be found here.

This lab focuses on lambda calculus. First, we focus on the syntax of $\lambda$-expressions. Second, we focus on its semantics, i.e., the computation specified by $\lambda$-expressions whose one step is performed by the $\beta$-reduction (and $\alpha$-conversion if necessary). To help you to play with these notions and concepts, I implemented in Racket an interpreter of $\lambda$-calculus transforming a given $\lambda$-expression into its normal form (if it exists). It follows the normal order evaluation strategy. In addition, I implemented a few helper functions to help you inspect $\lambda$-expressions. You can download the interpreter here lambda-calculus.rkt.

To follow the exercises, it is recommended to have a piece of paper, pen, DrRacket IDE installed and the interpreter. To use the interpreter, download the above-mentioned file and store it in a directory where you want to create your own code. Then create a new Racket file starting as follows:

#lang racket
(require "lambda-calculus.rkt")

$\lambda$-expressions are represented in the interpreter as S-expressions. It does not allow to use of any conventions regarding parenthesis. So you need to explicitly place them all. For instance, the $\lambda$-expression $\lambda xy.xy(\lambda ab.b)$ has to be represented as follows:

'(λ x : (λ y : ((x y) (λ a : (λ b : b)))))

So we had to add the outermost parenthesis, expand the shortcuts $\lambda xy.$ to $\lambda x.(\lambda y.$, and put the parenthesis determining the order of the applications, i.e., as the application is left-associative, $xy(\lambda ab.b)$ is in fact $((x y) (\lambda ab.b))$. The symbol λ can be entered in DrRacket by pressing Ctrl+\. Instead of the dot symbol, the colon symbol is used.

The module lambda-calculus.rkt provides the following functions:

Exercise 1: Draw the syntax tree of the $\lambda$-expression $(\lambda x.y(xx))(\lambda y.y(xx))$ and determine which variable occurrences are free and which are bound.

We will use the helper function draw-expr. First create the correct representation as S-expression:

'((λ x : (y (x x))) (λ y : (y (x x))))

Then evaluate the following function call:

(draw-expr '((λ x : (y (x x))) (λ y : (y (x x)))))

It displays the following tree:

An occurrence of a variable $v$ is bound if it is in the syntax tree below the node $\lambda v$ and it free otherwise. So for our expression, the occurrences of $x$ in the left branch are bound and they are free in the right branch. The occurrence of $y$ in the left branch is free and bound in the right branch.

Exercise 2: Draw the syntax tree of the $\lambda$-expression $\lambda y.xy(\lambda ab.b)$ and determine which variable occurrences are free and which are bound.

Try to first draw the tree on paper. Then compare your result with the result returned by the function draw-expr. The $\lambda$-expression is represented in Racket as follows:

'(λ y : ((x y) (λ a : (λ b : b))))

Exercise 3: Find all redexes in $(\lambda x.x y) z ((\lambda u.u) ((\lambda v.v) z)))$. Which one is the leftmost outermost redex and which one is the leftmost innermost redex? Reduce the leftmost outermost redex.

Hint: Try to find the redexes. Then call (draw-expr expr) for expr being the following S-expression:

'(((λ x : (x y)) z) ((λ u : u) ((λ v : v) z)))

The roots of redexes are colored in red. To check that your reduction was correct call

(reduce '(((λ x : (x y)) z) ((λ u : u) ((λ v : v) z))))

Exercise 4: Recall that multiplication of two numbers is computed by $M \equiv \lambda abc.a(bc)$. Find the normal form of $M01$ following the normal order reduction strategy, i.e., compute $0\cdot 1$ which should result in $0$. The numbers $0,1$ are abbreviations for $\lambda$-expressions $\lambda sz.z$ and $\lambda sz.sz$ respectively.

Hint: Once you do it on paper, check your result in Racket. You can use Racket definitions and semiquoting to make your $\lambda$-expression more readable.

(define zero '(λ s : (λ z : z)))
(define one '(λ s : (λ z : (s z))))
(define M '(λ a : (λ b : (λ c : (a (b c))))))
 
(eval `((,M ,zero) ,one) 'verbose)  ; displays each reduction step as λ-expression
(eval `((,M ,zero) ,one) 'tree)     ; draws each reduction step as syntax tree

Exercise 5: Recall that a pair $(a,b)$ is represented in $\lambda$-calculus as $(a,b)\equiv \lambda z.zab$. The projections into the first and second component can be obtained by applying $(a,b)$ to Boolean values $T\equiv \lambda ab.a$ and $F\equiv \lambda ab.b$. Thus $(a,b)T \to^\beta a$ and $(a,b)T \to^\beta b$. We can even define a cons function by $CONS \equiv \lambda abz.zab$. In Racket you can define all these constructions as follows (the final two calls check that it behaves as expected):

(define T '(λ x : (λ y : x)))
(define F '(λ x : (λ y : y)))
 
(define CONS 
  '(λ a : (λ b : (λ z : ((z a) b))))
  )
 
(eval `(((,CONS a) b) ,T))
(eval `(((,CONS a) b) ,F))

Write a $\lambda$-expression swapping components of a given pair $p$.

Hint: The desired $\lambda$-expression should take a pair $p$ and return another pair with swapped components. So the expression should start with $\lambda pz.z??$ where the question marks are the components of the returned pair.

Solution: $\lambda pz.z(pF)(pT)$

Once you have it, fill it into the following code and check that it correctly swaps the components:

(define SWAP `(λ p : (λ z : ((z (p ,F)) (p ,T)))))
 
(eval `(,SWAP ((,CONS a) b))) => '(λ z : ((z b) a))

Exercise 6: Since we can create pairs, we can create lists as in Racket. We represent the empty list by the false value $F$. Now we can create a list '(a b) by

(define lst `((,CONS a) ((,CONS b) ,F)))
 
(eval `(,lst ,T))  => 'a
(eval `((,lst ,F) ,T)) => 'b

Write a $\lambda$-expression $NULL?$ testing if a list is empty, i.e., it returns $T$ if it is empty and $F$ otherwise.

Hint: A list is either a pair or $F$ if it is empty. Let denote it by $p$. Recall the definition of the zero test from the lecture $Z\equiv \lambda x.xF\neg F$, where $\neg\equiv \lambda x.xFT$. We need something similar for the list $p$. So our desired $\lambda$-expression should look like $\lambda p.pe_1e_2$ where $e_1,e_2$ have to be filled by suitable $\lambda$-expressions serving as arguments for $p$. If $p$ is empty (i.e., $p\equiv F$) then $p$ is just projection into the second argument. Thus $e_2$ should be $T$, i.e., we have $\lambda p.pe_1T$. Now, if we substitute for $p$ a pair (i.e., $p \equiv \lambda z.zab$), we obtain $(\lambda z.zab)e_1T$. Thus $e_1$ is going to be substituted for $z$ and consequently it will be applied to $a$ and $b$, i.e., we would end up with $e_1abT$. Since the result in this case should be $F$, we need the result of $e_1ab$ to be $\neg$ because $\neg F\to^\beta T$.

Solution: $\lambda p.p(\lambda ab.\neg)T$

Check your solution in Racket.

(define neg `(λ x : ((x ,F) ,T)))
(define NULL? `(λ p : ((p (λ a : (λ b : ,neg))) ,T)))
 
(eval `(,NULL? ,F)) ; => T
(eval `(,NULL? ,lst)) ; => F

Exercise 7: Define a $\lambda$-expression computing the length of a list.

Hint: Follow the approach from the lecture where we defined a function $R\equiv \lambda rn.Zn0(nS(r(Pn)))$ which we turned into a recursive one by $Y$-combinator (i.e., $YR$).

Recall $Y\equiv \lambda y.(\lambda x.y(xx))(\lambda x.y(xx))$. You also need the successor function $S\equiv \lambda wyx.y(wyx)$ for adding $1$. The computation of the desired $\lambda$-expression can be expressed in Racket as follows:

(define len 
  (lambda (p) (if (null? p)
                    0
                    (+ (len (cdr p)) 1))))

Modify the $\lambda$-expression $R$ by replacing $Z$ by $NULL?$ from the previous exercise, adding $1$ can be done just by applying the successor function $S$, and the predecessor function $P$ has to be replaced by the expression returning the second component.

Solution: $LEN \equiv \lambda rp.NULL?p0(S(r(pF)))$

Check your solution in Racket:

(define S '(λ w : (λ y : (λ x : (y ((w y) x))))))
(define Y '(λ y : ((λ x : (y (x x))) (λ x : (y (x x))))))
 
(define LEN 
  `(λ r :
     (λ lst : (
               ((,NULL? lst) ,zero)
               (,S (r (lst ,F)))
               )
       )
     )
  )
)
 
(eval `((,Y ,LEN) ,F)) ; => 0
(eval `((,Y ,LEN) ((,CONS a) ,F))) ; => 1 
(eval `((,Y ,LEN) ((,CONS a) ((,CONS b) ,F)))) ; => 2

The aim of the lab is to practice function definitions using pattern matching and guarded equations together with the list comprehension.

Exercise 1: Write a function separate :: [Int] -> ([Int], [Int]) taking a list and returning a pair of lists. The first containing elements on indexes 0,2,4,… and the second on the indexes 1,3,5,… E.g.

separate [1,2,3,4,5] => [[1,3,5], [2,4]]

Hint: Using pattern matching x:y:xs and recursion.

separate :: [Int] -> ([Int], [Int])
separate [] = ([], [])
separate [x] = ([x], [])
separate (x:y:xs) = let (evs, ods) = separate xs
                    in (x:evs, y:ods)

Exercise 2: Write a function numToStr :: Int -> Int -> String taking as input an integer n together with a radix denoting the number of symbols used to represent the number n (for example 2,10,16 for binary, decimal, hexadecimal representation respectively). This function returns a string containing the representation of n in the corresponding numerical system. For the representation use the standard symbols 0123456789ABCDEF.

Examples:

numToStr 52 10 => "52"
numToStr 5 2 => "101"
numToStr 255 16 => "FF".

Hint: The representation can be obtained by consecutive division of n by radix and collecting the remainders. The integer division can be computed by the function div and the remainder after integer division can be computed by the function mod.

numToStr :: Int -> Int -> String
numToStr n radix = if  n < radix then [chars !! n]
                   else (numToStr d radix) ++ [chars !! r]
                 where chars = ['0'..'9'] ++ ['A'..'F']
                       d = n `div` radix
                       r = n `mod` radix

Exercise 3: Write a function split n xs that takes a natural number n and a list xs :: [Int] and splits xs into a list of lists of n-many consecutive elements. The last chunk of numbers can be shorter than n. E.g.

split 3 [1..10] => [[1,2,3],[4,5,6],[7,8,9],[10]]
split 3 [1,2] => [[1,2]]

Use the function split to implement a function average_n n xs taking a list of integers and returning the list of the averages of n consecutive elements. E.g.

average_n 3 [-1,0,1,2,3] => [0.0,2.5]

Hint: You can use functions take n xs and drop n xs. The first one returns the list of the first n elements of xs. The second returns the remaining list after stripping the first n elements off. Further, use function length xs returning the length of xs.

The function split can be written recursively. If the length of xs is less than or equal to n then return just xs. If it is bigger then take the first n elements and cons them to the result of the recursive call of split after dropping the first n elements.

split :: Int -> [Int] -> [[Int]]
split n xs | (length xs) <= n = [xs]
           | otherwise = take n xs : (split n (drop n xs))

The function average_n can be easily written via the list comprehension using split. The only caveat is the division operation involved in the computation of averages. Even though the inner lists after applying split are of the type [Int], their averages are floating numbers. So the type of average_n is Int -> [Int] -> [Float]. We can compute the sum of an inner list by the function sum and its length by length but the type system would complain if we want to divide them. To overcome this problem, one has to convert the integer arguments into floating-point numbers. This can be done by the function fromIntegral converting an integer into any more general numeric type.

average_n :: Int -> [Int] -> [Float]
average_n n ys = [fromIntegral (sum xs) / fromIntegral (length xs) | xs <- xss]
    where xss = split n ys

Task 1: Write a function copy :: Int -> String -> String that takes an integer n and a string str and returns a string consisting of n copies of str. E.g.

copy 3 "abc" => "abcabcabc"

copy :: Int -> String -> String
copy n str | n <= 0 = ""
           | otherwise = str ++ copy (n - 1) str
 
-- tail recursive version
copy2 :: Int -> String -> String
copy2 n str = iter n "" where
    iter k acc | k <= 0 = acc
               | otherwise = iter (k-1) (acc ++ str) 

Task 2: The Luhn algorithm is used to check bank card numbers for simple errors such as mistyping a digit, and proceeds as follows:

• consider each digit as a separate number;
• moving left, double every other number from the second last, e.g. 1 7 8 4 ⇒ 2 7 16 4;
• subtract 9 from each number that is now greater than 9;
• add all the resulting numbers together;
• if the total is divisible by 10, the card number is valid.

Define a function luhnDouble :: Int -> Int that doubles a digit and subtracts 9 if the result is greater than 9. For example:

luhnDouble 3 => 6
luhnDouble 7 => 5

Using luhnDouble and the integer remainder function mod, define a function luhn :: [Int] -> Bool that decides if a list of numbers representing a bank card number is valid. For example:

luhn [1,7,8,4] => True
luhn [4,7,8,3] => False

Hint: Since the numbers are processed from right to left, reverse first the list by the function reverse. Then create a list of numbers to be luhnDoubled and the rest by the function separate.

luhnDouble :: Int -> Int
luhnDouble n | n > 4 = 2*n - 9
             | otherwise = 2*n
 
luhn :: [Int] -> Bool
luhn xs = (sum evs + sum [luhnDouble x | x <- ods]) `mod` 10 == 0
    where rxs = reverse xs
          (evs, ods) = separate rxs

Exercise 1: Define a type representing binary trees storing data in leaves of a general type a. Each non-leaf node has always two children. Make your type an instance of the class Show so that it can be displayed in an xml-like format. A leaf node containing a datum x should be displayed as <Leaf x/> and an inner node <Node>…children nodes…</Node>. E.g. the following tree

     *
    / \
   *  'd'
  / \
'a'  *
    / \
  'b' 'c'

is displayed as

<Node><Node><Leaf 'a'/><Node><Leaf 'b'/><Leaf 'c'/></Node></Node><Leaf 'd'/></Node>

Solution: We will declare a recursive parametric data type Tree a over a general type a. There will be two data constructors Leaf and Node. The leaf contain a datum of type a and the node has a left subtree and a right subtree.

data Tree a = Leaf a | Node (Tree a) (Tree a)

To make Tree a an instance of the Show class. We have to constrain type a to be an instance of Show otherwise it would not be clear how to display the data stored in the tree. The definition of the function show is then straightforward.

instance (Show a) => Show (Tree a) where
    show (Leaf x) = "<Leaf " ++ show x ++ "/>"
    show (Node left right) = "<Node>" ++ show left ++ show right ++ "</Node>"

Now we can define the tree from the above picture as

tree :: Tree Char
tree = Node (Node (Leaf 'a') (Node (Leaf 'b') (Leaf 'c'))) (Leaf 'd')

Exercise 2: Consider the Tree a data type from the previous exercise. Write a function

treeDepth :: Tree a -> Int

taking a tree and returning its depth.

Solution: The tree depth can be computed recursively as $treeDepth(t) = 1$ if $t$ is a leaf and $treeDepth(t)=1+\max(treeDepth(left),treeDepth(right))$ if $t$ has two subtrees $left$ and $right$. This is a recursive definition which can be directly rewritten into Haskell as follows:

treeDepth :: Tree a -> Int
treeDepth (Leaf _) = 1
treeDepth (Node left right) = 1 + max (treeDepth left) (treeDepth right)

For the tree from the previous exercise we have

> treeDepth tree
4

Exercise 3: Consider again the Tree a data type from Exercise 1. Write a function

labelTree :: Tree a -> Tree (a, Int)

labelling the leaves of a tree by consecutive natural numbers in the infix order. So it should replace a leaf datum x by the pair (x,n) for some natural number. So we would like to obtain something like that:

     *                  *
    / \                / \
   *  'd'             * ('d',3)
  / \       =>       / \
'a'  *          ('a',0) *
    / \                / \
  'b' 'c'        ('b',1) ('c',2)

Solution: To traverse through the nodes (in particular leaves) can be easily done recursively. The problem is with the counter for labels. In imperative programming language, we could introduce a variable counter initialize it by 0. Once we would encounter a leaf, we would label it by counter and modify counter = counter + 1. Unfortunately, we cannot do that in a purely functional language like Haskell.

We need an accumulator in the signature of the labelling function holding the counter value. So we could think of a helper function

labelHlp :: Tree a -> Int -> Tree (a, Int)

taking as input the second argument representing the counter. Unfortunately, this is still not enough because such an accumulator can depend only on the path leading from the root node into a leaf. However, the accumulator has to depend on the previously labelled leaves. So we must enrich the output of the helper function as well so that we send the counter value back when returning from a recursive call. So we actually need to return not only the labelled tree but also the counter value as follows:

labelHlp :: Tree a -> Int -> (Tree (a, Int), Int)

Now, when we encounter a leaf node, we label it by the counter accumulator and return a labelled leaf together with the increased counter value. For the non-leaf nodes, we first label the left subtree by the numbers starting with the counter value. This results in a labelled tree and a new counter value. Second, we label the right subtree with the numbers starting from the new counter value.

labelHlp :: Tree a -> Int -> (Tree (a, Int), Int)
labelHlp (Leaf x) n = (Leaf (x, n), n+1)
labelHlp (Node left right) n = let (left', n') = labelHlp left n
                                   (right', n'') = labelHlp right n'
                                in (Node left' right', n'')

Finally, we wrap the helper function in the definition of labelTree. This definition just set the counter value to 0, call the helper function and then project into the first component via the function fst.

labelTree :: Tree a -> Tree (a, Int)
labelTree t = fst (labelHlp t 0)

Task 1: Define a recursive data type Polynomial a representing univariate polynomials with an indeterminate $x$ whose coefficients are of a general type a. The definition will have two data constructors. First, Null representing the zero polynomial. Second, Pol whose parameters are a monomial and recursively the rest of the polynomial. Monomial should by represented as pairs of type (a, Int) where the first component is the coefficient and the second is the exponent. E.g. (c,e) represents $cx^e$. You can define a new name for that type as follow:

type Monomial a = (a, Int)

Make your type an instance of show class. Polynomials should be displayed as follows:

> Null
0
 
> Pol (3, 2) Null
3*x^2
 
> Pol (-2, 0) Null
(-2)
 
> Pol (-1, 0) (Pol (-2, 1) (Pol (1, 3) Null))
(-1) + (-2)*x^1 + 1*x^3

Hint: Make first a function

format :: (Show a, Ord a, Num a) => Monomial a -> String

that returns a string representing a given monomial. Note the constraint on the type a. We assume that coefficients are numeric values that can be added and subtracted and can be ordered. The reason for this that we need to find out whether the given coefficient is negative and in that case we have to wrap it into parentheses, i.e., we need to compare with 0. Further, note that a constant monomial has no x^0. Then define the instance of Show for Polynomial a. You need to constrain the show function in the same way as format.

type Monomial a = (a, Int)
data Polynomial a = Null | Pol (Monomial a) (Polynomial a)
 
format :: (Show a, Num a, Ord a) => Monomial a -> String
format (c, e) | e == 0 = display c
              | otherwise = display c ++ "x*^" ++ show e 
    where display k | k >= 0 = show k
                    | otherwise = "(" ++ show k ++ ")"
 
instance (Show a, Num a, Ord a) => Show (Polynomial a) where
    show Null = "0"
    show (Pol m Null) = format m
    show (Pol m ms) = format m ++ " + " ++ show ms

Task 2: Write a function

getDegree :: Polynomial a -> Int 

returning the degree of a given polynomial. The zero polynomial has degree $-1$ by definition. Otherwise, you have to find the highest exponent occurring in the polynomial.

getDegree :: Polynomial a -> Int
getDegree p = iter p (-1) where
    iter Null n = n
    iter (Pol (_, e) ms) n | e > n = iter ms e
                           | otherwise = iter ms n 

Exercise 1: Haskell functions can be polymorphic if we use type variables in their definitions. Write a function

permutations :: [a] -> [[a]]

taking a list of elements of type a and returning a list of all its permutations.

Solution: We will use the same approach as in Racket. First, we define a function

interleave :: a -> [a] -> [[a]]

taking an element x of type a and a list ys of elements of type a and returning a list of lists where x is plugged into ys by all possible ways. E.g.

> interleave 0 [1,2,3]
[[0,1,2,3],[1,0,2,3],[1,2,0,3],[1,2,3,0]]

The base case for the interleave function is simple as there is only a single way to plug x into the empty list [], namely [x]. If the list is of the form y:ys, then one way to plug x into it is to prepend x (i.e., x:y:ys). The remaining possibilities can be computed recursively by calling interleave x ys and prepending y.

interleave :: a -> [a] -> [[a]]
interleave x [] = [[x]]
interleave x (y:ys) = (x:y:ys) : [y:xs | xs <- interleave x ys]

Now we can easily define the permutations function. The base case for the empty list is trivial. For a nonempty list x:xs we can recursively compute permutations of xs and interleave x into all such permutations. Finally, we have to concatenate the results into a single list of permutations. This can be done by the function concat which is implemented in Prelude (you also saw how to implement such function in the lecture. I called that function flatten).

permutations :: [a] -> [[a]]
permutations [] = [[]]
permutations (x:xs) = concat [interleave x p | p <- permutations xs]

Exercise 2: Use the function permutations from the previous exercise to write a function findHamiltonian which finds all Hamiltonian paths in a given graph.

We first have to represent graphs in a data structure. To be general, we define a graph data structure over any data type a. First, we define a type for edges as pairs of values of type a. Second, we define a parametric algebraic data type Graph a as a record consisting of a list of vertices and a list of edges. We also make this type an instance of the type class Show by automatic derivation.

type Edge a = (a,a) 
data Graph a = Graph {vertices :: [a], edges :: [Edge a]} deriving Show

Now it is possible to define graphs for instance as follows:

gr :: Graph Int
gr = Graph {vertices=[1..6], edges=[(1, 2), (1, 5), (2, 3), (2, 5), (3, 4), (4, 5), (4, 6)]}
 
> gr
Graph {vertices = [1,2,3,4,5,6], edges = [(1,2),(1,5),(2,3),(2,5),(3,4),(4,5),(4,6)]}

Moreover, we have automatically functions vertices :: Graph a -> [a] and edges :: Graph a -> [Edge a]:

> vertices gr
[1,2,3,4,5,6]
 
> edges gr
[(1,2),(1,5),(2,3),(2,5),(3,4),(4,5),(4,6)]

Recall that a Hamiltonian path in a graph is a path going through all the vertices exactly once. To solve the task, we will use brute force, generating all possible permutations of vertices and checking if they form a path or not. First, we define a helper function isEdge taking a pair of vertices of type a and a graph over a and returning True if those vertices are connected and False otherwise. To test the membership of an element in a list, we can use the function elem. Note the type declaration of isEdge. As the function is polymorphic, we have to assume that a is an instance of the class Eq so that we test the membership by the elem function.

isEdge :: Eq a => Edge a -> Graph a -> Bool
isEdge (a,b) g = (a,b) `elem` edgs || (b,a) `elem` edgs where
    edgs = edges g

Next, we define a function testing whether a given list of vertices is a path in a given graph. That can be easily done by list comprehension generating all indexes but the last one. Note the use of the function and. It can be applied to a list of type [Bool] performing logical conjunction of all its members.

isPath :: Eq a => [a] -> Graph a -> Bool
isPath vs g = and [ isEdge (vs !! i, vs !! (i+1)) g | i <- [0..length vs-2] ]

Finally, we take all permutations of vertices and test which of them form a path in a given graph. Collecting all such paths is the list of all Hamiltonian paths.

findHamiltonian :: Eq a => Graph a -> [[a]]
findHamiltonian g = [p | p <- perms, isPath p g]
    where perms = permutations (vertices g)

Exercise 3: The next exercise focuses on operator overloading. With the boom of neural nets, it became important to find algorithms how to compute efficiently and precisely derivatives of functions that are used to construct networks layers. There are basically three approaches. First, syntactic derivation manipulating symbolic expressions. Second, approximation via the limit defining the derivative of a function at a point. Third, computing derivatives via dual numbers. We will discuss the last approach.

Dual numbers are numbers of the form $a+b\epsilon$ for $a,b\in\mathbb{R}$ and $\epsilon$ is something like the complex unit $i$ but instead of $i^2=-1$ we have $\epsilon^2=0$ https://en.wikipedia.org/wiki/Dual_number. For those who like algebra, it can be constructed by taking the ring of univariate polynomials $\mathbb{R}[\epsilon]$ and taking its quotient by the ideal generated by $\epsilon^2$, i.e., $\mathbb{R}[\epsilon]/\langle\epsilon^2\rangle$. If you do not understand the last sentence, you can safely ignore it. As I like algebra I could not resist the temptation to explain it in the algebraic language. Based on the above definition, we can define over the set of dual numbers algebraic operations like addition $(a+b\epsilon)+(c+d\epsilon)=(a+c) + (b+d)\epsilon$, multiplication $(a+b\epsilon)(c+d\epsilon)=ac+(ad+bc)\epsilon+bd\epsilon^2=ac+(ad+bc)\epsilon$.

Dual numbers can be used to compute the derivative of a function at a point. Consider first a polynomial $p(x)=b_0+b_1x+b_2x^2$. Let us compute its value at $a+\epsilon$. \[p(a+\epsilon) = b_0 + b_1(a+\epsilon) + b_2(a+\epsilon)^2= b_0 + b_1a + b_2a^2 + b_1\epsilon + b_22a\epsilon=p(a)+p'(a)\epsilon\] So you see that the resulting dual number contains the value of $p(a)$ and also its derivative $p'(a)$. This can be generalized to any analytic function by taking its Taylor expansion at a point $a$: \[f(x) = \sum_{i=0}^\infty \frac{f^{(n)}(a)}{n!}(x-a)^n\] If we evaluate this series at $a+\epsilon$, we get \[f(a+\epsilon) = \sum_{i=0}^\infty \frac{f^{(n)}(a)}{n!}(a+\epsilon-a)^n = f(a) + f'(a)\epsilon\] as $\epsilon^n=0$ for $n\geq 2$. Thus we again computed the value $f(a)$ and also $f'(a)$ by evaluating a function $f(x)$ at $a+\epsilon$.

We will represent dual numbers as pairs. Thus we declare a new parametric type over a type a. We also automatically derive its instances of the class Eq and Ord. This automatic derivation orders the dual numbers lexicographically and two dual numbers are equal if they have the same components.

data DualNum a = DN a a deriving (Eq, Ord)

We also define our own instance of Show so that e.g. DN 3 10 is displayed as 3 + 10eps.

instance Show a => Show (DualNum a) where
    show (DN x x') = show x ++ " + " ++ show x' ++ "eps"

In order to be able to evaluate a function at a dual number, we define DualNum a an instance of Num. Then we can compute $f(a)$ and $f'(a)$ for $f$ defined as any composition of functions from the Num definition.

instance Num a => Num (DualNum a) where
    (DN x x') + (DN y y') = DN (x + y) (x' + y')
    (DN x x') - (DN y y') = DN (x - y) (x' - y')
    (DN x x') * (DN y y') = DN (x * y) (x*y' + y*x')
    fromInteger i = DN (fromInteger i) 0
    abs (DN x x') = DN (abs x) (signum x * x')
    signum (DN x _) = DN (signum x) 0

I should likely comment on the above definition a bit. The addition, subtraction, multiplication is clear. The function fromInteger :: Num a => Integer -> a embeds integers into the set of dual numbers. So it maps $a$ to $a+0\epsilon$. The last two definitions are not mathematically correct. We pretend that signum function has the derivative $0$ everywhere which is not true at $0$. Similarly abs has no derivative at $0$.

Dual numbers can be also divided if the first component of the divisor is non-zero as follows: \[\frac{x+x'\epsilon}{y+y'\epsilon}=\frac{(x+x'\epsilon)(y-y'\epsilon)}{(y+y'\epsilon)(y-y'\epsilon)}=\frac{xy+(x'y-xy')\epsilon}{y^2}= \frac{x}{y}+\frac{x'y-xy'}{y^2}\epsilon\] So we can make DualNum a an instance of Fractional.

instance Fractional a => Fractional (DualNum a) where
    (DN x x') / (DN y y') = DN (x/y) ((x'*y - x*y') / (y*y))
    fromRational r = DN (fromRational r) 0

Now we can define a function $f$ and evaluate it at a dual number $a+\epsilon$ to compute $f(a)$ and $f'(a)$. The function has to be polymorphic working for any instance a of the class Num or Fractional.

f :: Num a => a -> a
f x = x^2 + 1
 
> f (DN 5 1)
26 + 10eps

Indeed, for $f(x)=x^2+1$ we have $f(5)=5^2+1=26$ and $f'(x)=2x$, $f'(5)=10$. Another example

g :: Fractional a => a -> a
g x = (x^2 - 2) / (x - 1)
 
> g (DN 0 1)
2.0 + 2.0eps

because $g'(x)=\frac{x^2-2x+2}{(x-1)^2}$, i.e., $g(0)=2$ and $g'(0)=2$.

The next example is more impressive. Consider the function sqr computing the square root of a given number. We define this function by iterative computation via the Raphson-Newton method. The function iterate f a computes an infinite list [a,f a, f (f a), f (f (f a)),…]. So in our case, it calls iteratively improve to compute better and better estimates. Once two consecutive elements of this infinite list are close enough, we finish the computation.

sqr :: (Fractional a, Ord a) => a -> a
sqr x = convAbs $ iterate improve 1
  where improve r = (r + x/r) / 2
        convAbs (x1:x2:xs) | abs (x1-x2) < 1e-10 = x2
                           | otherwise = convAbs xs

I think that it is quite impressive that we can compute a derivative of the function sqr at a point even though it is defined by an iterative computation.

> sqr (DN 9 1)
3.0 + 0.16666666666666666eps

Indeed, for $sqr(x)=\sqrt{x}$ we have $sqr'(x)=\frac{1}{2\sqrt{x}}$ so that $sqr'(9)=\frac{1}{6}=0.1\overline{6}$.

Extra bonus: For those who are interested, we can go even further and make DualNum a an instance of Floating. If you recall the chain rule, i.e., for a compose function $f(x)=h(g(x))$ we have $f'(x) = h'(g(x))g'(x)$), then it is easy to decode the following definitions.

instance (Floating a) => Floating (DualNum a) where
    pi               = DN pi 0
    exp (DN x x')    = DN r (r*x') where r = exp x 
    log (DN x x')    = DN (log x) (x' / x)
    sqrt (DN x x')   = DN r (x' / (2 * r)) where r = sqrt x
    sin (DN x x')    = DN (sin x) (x' * cos x) 
    cos (DN x x')    = DN (cos x) (-x' * sin x) 
    acos (DN x x')   = DN (acos x) (-x' / sqrt(1 - x*x))
    asin (DN x x')   = DN (asin x) ( x' / sqrt(1 - x*x))
    atan (DN x x')   = DN (atan x) ( x' / (1 + x*x))
    sinh x           = (exp x - exp (-x)) / 2
    cosh x           = (exp x + exp (-x)) / 2
    asinh x          = log (x + sqrt (x*x + 1))
    acosh x          = log (x + sqrt (x*x - 1))
    atanh x          = (log (1 + x) - log (1 - x)) / 2

Then it is possible to define any polymorphic function over an instance of Floating and we can compute its derivative. E.g.

f2 :: Floating a => a -> a
f2 x = x^4 + sin (x^2) - exp x * log x + 7
 
-- the derivative of f2
df2 :: Floating a => a -> a
df2 x = 4*x^3 + 2 * x * cos (x^2) - exp x/x - exp x * log x
 
-- value of f2 and its derivative at 3
> f2 (DN 3 1)
66.34590079693074 + 73.77182176598502eps
 
-- value of df2 at 3
> df2 3
73.77182176598502

Task 1: Write a function merge :: Ord b => (a -> b) -> [a] -> [a] -> [a] taking a function f :: a -> b where b is supposed to be an orderable type and two lists of elements of type a. Suppose that these two lists are sorted via f, i.e., for [a1,a2,a3,…] we have f a1 <= f a2 <= f a3 <= .... As a result it returns a merged sorted list.

Once you have the function merge, implement a function subseqs :: [a] -> [[a]] which takes a list and returns all its sublists (i.e., subsequence of its elements) sorted by their length.

Hint: The subsequences can be generated recursively because subsequences of x:xs are just subsequences of xs together with subsequences of xs extended by x. To produce the sorted result, use the merge function.

merge :: (a -> Int) -> [a] -> [a] -> [a]
merge _ [] ys = ys
merge _ xs [] = xs
merge f p@(x:xs) q@(y:ys) | f x < f y = x:merge f xs q
                          | otherwise = y:merge f p ys
 
subseqs :: [a] -> [[a]]
subseqs [] = [[]]
subseqs (x:xs) = merge length (subseqs xs) [x:ys | ys <- subseqs xs]

Exercise 1: This is a warm-up exercise. Write a function converting a string into a CamelCase format. It takes a string, splits particular words separated by whitespace characters, changes the first letter of each word to uppercase and join all the words into a single string. E.g. “ no air” is converted into “NoAir”. Moreover, make the function polymorphic so that it works over any functor instance over String, i.e., our function should have the following type:

toCamelCaseF :: Functor f => f String -> f String

Solution: First, we need a function converting an alphabetic character into uppercase. In the library Data.Char there is a function toUpper doing that. We will implement this function ourselves. To represent the relation between lowercase and uppercase letters, we take a list of tuples [('a','A'), ('b','B'),…]. This can be created by zipping ['a'..'z'] and ['A'..'Z']. For a character c if it is a lowercase letter, then we return the corresponding uppercase letter; otherwise we return just c. To do that we can use the function

lookup :: Eq a => a -> [(a, b)] -> Maybe b

that takes an element of type a and a list of pairs and lookups the element among first components of those pairs. If it is there, it returns Just the second component and otherwise Nothing. Using the case expression, we can distinguish both cases by pattern matching.

toUpper :: Char -> Char
toUpper c = case lookup c $ zip ['a'..'z'] ['A'..'Z'] of
    Nothing -> c
    Just c' -> c'

To split the input string into particular words, we can apply the function

words :: String -> [String]

Then we have to apply toUpper to the first letter of each word. Finally, concatenate the resulting words. Thus we have a function converting a string into a CamelCase string.

toCamelCase :: String -> String
toCamelCase = concat . map toUpperHead . words where
    toUpperHead "" = ""
    toUpperHead (x:xs) = toUpper x:xs

It remains to lift the above function by fmap so that we can apply toCamelCase over any functor instance.

toCamelCaseF :: Functor f => f String -> f String
toCamelCaseF = fmap toCamelCase

Examples:

> toCamelCaseF [" no air ", " get back"]  -- over the list functor
["NoAir","GetBack"]
 
> toCamelCaseF (Just " no air ")  -- over the Maybe functor
Just "NoAir"
 
> toCamelCaseF getLine   -- over IO functor
 no  air                 -- user's input
"NoAir"

Exercise 2: A deterministic finite automaton (DFA) is a tuple $\langle Q,\Sigma,\delta,init,F\rangle$, where $Q$ is a set of states, $\Sigma$ is a finite alphabet, $\delta\colon Q\times\Sigma\to Q$ is a transition function, $init\in Q$ is an initial state and $F\subseteq Q$ is a set of final states. DFAs play a crucial role in applications of regular expressions as each regular expression can be converted into an equivalent DFA accepting the language defined by the regular expression. For instance, the regular expression [0-9]+\.[0-9][0-9] defines a language of numbers having the decimal point followed by two digits, e.g. $123.00$, $0.12$, $3476.25$. The equivalent automaton is depicted below. It has states Before, Digit, Dot, First, Second. Before is the initial state and Second is the only final state. Automaton reads the input characters and changes its state according to $\delta$. After the whole input is read, it accepts the input string iff it is in a final state. At the beginning it is in Before. Once it reads a digit, the state changes to Digit and remains there until . is read. Then next digit changes the state to First and finally the second digit after the decimal point changes the state to Second that is final. Anything else leads to the state Fail.

Our task is to define a parametric data type DFA a modelling a DFA and implement the function

evalDFA :: DFA a -> String -> Bool

taking an automaton, a string w and returning true if w is accepted by the automaton and false otherwise.

Further, define the above automaton and use it to implement a function

parseNum :: String -> Maybe Float

taking a string and returning Just the parsed floating number if the string is accepted by the automaton or Nothing. Finally, lift parseNum to any functor instance

parseNumF :: Functor f => f String -> f (Maybe Float)

Solution: To model an automaton, the transition function $\delta\colon Q\times\Sigma\to Q$, the initial and final states. We make the type DFA a parametric over a type a representing states as we wish to work with automata whose states might be integers or strings or other data types. We could also make DFA a parametric over a type a representing the alphabet $\Sigma$ but for this example we set $\Sigma=$ Char. Thus the transition function $\delta$ is of type a -> Char -> a. The initial state is of type a and the set of final states can be represented as a predicate of type a -> Bool.

data DFA a = Automaton (a->Char->a) a (a->Bool)

Now we can write the function simulating the automaton computation. It starts with the initial states and repeatedly applies the transition function to the current state and the current letter. This can be done by folding as I explained in the lecture introducing folding in Scheme. In the comment below, you can see how to implement the automaton computation directly without folding. Finally, the predicate defining the final states is applied.

evalDFA :: DFA a -> String -> Bool
evalDFA (Automaton dlt s inF) w = 
    inF (foldl dlt s w)
--  inF (deltaStar s w) 
--  where deltaStar q [] = q
--       deltaStar q (a:ws) = deltaStar (dlt q a) ws

We first define a type representing the states. Then we define the automaton over these states.

data State = Before | Digit | Dot | First | Second | Fail
 
isNum :: Char -> Bool
isNum c = c `elem` ['0'..'9']
 
final :: State -> Bool
final Second = True
final _ = False
 
delta :: State -> Char -> State
delta Before c | isNum c = Digit
               | otherwise = Fail
delta Digit c | isNum c = Digit
              | c == '.' = Dot
              | otherwise = Fail
delta Dot c | isNum c = First
            | otherwise = Fail
delta First c | isNum c = Second
              | otherwise = Fail
delta Second _ = Fail
delta Fail _ = Fail
 
automaton :: DFA State
automaton = Automaton delta Before final

Next, the function parseNum takes a string, uses the automaton to check if the string has the correct format. If yes, it is read by the read function and otherwise Nothing is returned.

parseNum :: String -> Maybe Float
parseNum w = if evalDFA automaton w then Just (read w)
             else Nothing

Now, we can lift it via fmap.

parseNumF :: Functor f => f String -> f (Maybe Float)
parseNumF = fmap parseNum

Examples:

> parseNumF ["234", "123.12", ".5", "0.50"]  -- the list functor instance
[Nothing,Just 123.12,Nothing,Just 0.5]
 
> parseNumF getLine   -- IO functor instance
1234.34               -- user's input
Just 1234.34
 
> parseNumF getLine   -- IO functor instance
1.234                 -- user's input
Nothing

Exercise 3: Using the function parseNumF from the previous exercise, write a function parseIO :: IO () that displays a string “Enter number:\n” and then reads from the keyboard a string. If the string has the correct format (i.e., number with two digits after the decimal point), then it displays “Ok”; otherwise it asks the user's input again.

Solution: First, we execute the action putStrLn displaying the string “Enter number:”. Then we execute the action parseNumF getLine :: IO (Maybe Float). Depending of its result, we either display “Ok” or execute the whole action parseIO again. We can either use the monadic operators as follows:

parseIO :: IO ()
parseIO = putStrLn "Enter number:" 
          >> parseNumF getLine 
          >>= \x -> case x of          
                      Nothing -> parseIO
                      Just _ -> putStrLn "Ok"

or we can use the do-syntax as follows:

parseIO :: IO ()
parseIO = do putStrLn "Enter number:"
             x <- parseNumF getLine
             case x of
               Nothing -> parseIO
               Just _ -> putStrLn "Ok"

Task 1: Consider the following data type representing Boolean propositional formulas built up from atoms by negations, conjunctions and disjunctions.

data Expr a = Atom a
            | Neg (Expr a)
            | And (Expr a) (Expr a) 
            | Or (Expr a) (Expr a) 
                deriving (Eq, Show)

The type constructor Expr has a single parameter a representing a data type for atoms. So for instance Expr Bool is a Boolean expression that can be directly evaluated, e.g. the expression $(True\wedge \neg False)\vee False$ is represented as

expr :: Expr Bool
expr = Or (And (Atom True) (Neg (Atom False))) (Atom False) 

On the other hand, Expr String might represent propositional formulas whose atoms are variables represented as strings, e.g. the formula $(\neg x\vee x)\wedge y$ is represented as

fle :: Expr String
fle = And (Or (Neg (Atom "x")) (Atom "x")) (Atom "y")

Write a function eval :: Expr Bool -> Bool evaluating a given Boolean expression. Thus it should evaluate expr to True. Further, implement a function getAtoms :: Expr a -> [a] returning the list of atoms for a given expression, e.g. getAtoms fle should return [“x”,“x”,“y”].

Hint: Logical operations negation, conjunction and disjunction can be respectively computed by not, &&, ||. The last two are infix operators.

eval :: Expr Bool -> Bool
eval (Atom c) = c
eval (Neg e) = not (eval e)
eval (And e1 e2) = eval e1 && eval e2
eval (Or e1 e2) = eval e1 || eval e2
 
getAtoms :: Expr a -> [a]
getAtoms (Atom c) = [c]
getAtoms (Neg e) = getAtoms e
getAtoms (And e1 e2) = getAtoms e1 ++ getAtoms e2
getAtoms (Or e1 e2) = getAtoms e1 ++ getAtoms e2

Task 2: The type constructor Expr from the previous task can be made into an instance of Functor as follows:

instance Functor Expr where
    fmap f (Atom c) = Atom (f c)
    fmap f (Neg e) = Neg (fmap f e)
    fmap f (And e1 e2) = And (fmap f e1) (fmap f e2)
    fmap f (Or e1 e2) = Or (fmap f e1) (fmap f e2)

Thus if we have a map f :: a -> b, it can be lifted by fmap to a map of type Expr a -> Expr b. This might be handy if we need to rename variables or we want to assign concrete Boolean values to variables. Write a polymorphic function

subst :: Functor f => [String] -> f String -> f Bool

taking a list of strings (variables) and a data structure over strings returning the same data structure where the strings (variables) in the input list are replaced by True and the rest by False. Use the lifting by fmap.

subst :: Functor f => [String] -> f String -> f Bool
subst xs = fmap (`elem` xs)

Next, apply the function subseqs :: [a] -> [[a]] from the previous lab returning a list of all sublists of a given list.

subseqs :: [a] -> [[a]]
subseqs [] = [[]]
subseqs (x:xs) = subseqs xs ++ [x:ys | ys <- subseqs xs]

The above function can generate all possible evaluations of a propositional formula if we apply it to the result of getAtoms. Implement functions

isTaut, isSat :: Expr String -> Bool

testing whether a given formula is a tautology (resp. satisfiable). A propositional formula is satisfiable if there exists an evaluation of atoms such that the Boolean expression resulted from the replacing atoms by the respective Boolean values is evaluated to True. A propositional formula is called tautology if it is satisfied by all possible evaluations of its atoms.

Hint: To check that there exists an evaluation satisfying a formula or if all evaluations satisfy the formula, use the functions or, and respectively. These functions are applicable to any list of Boolean values.

check :: ([Bool] -> Bool) -> Expr String -> Bool
check g e = g [ eval $ subst vs e | vs <- vss] 
    where vss = subseqs $ getAtoms e
 
isTaut, isSat :: Expr String -> Bool
isTaut = check and
isSat = check or

This lab will illustrate a complete Haskell program searching the shortest path in a maze. We will see Maybe and IO monads in action. It will be split into two parts. The first part deals with the breadth-first search and the second with the parsing of the file containing a maze. Short fragments of code are left for you to fill.

Before you start, make sure that you have the following imports in your source file:

import Data.Char
import Control.Applicative

We are going to need these libraries for our parser.

As building blocks for a maze, we introduce the following data type:

data Block = W | F | S deriving (Eq,Show)

The values W, F, S represent respectively a wall, a free space and a star that we will use to depict solutions. A data type capturing mazes can be defined as follows:

data Maze = M [[Block]]
 
maze :: Maze   -- a testing maze
maze = M [[W,W,W,W,W],
          [W,F,W,F,W],
          [W,F,W,W,W],
          [W,F,F,F,W],
          [W,W,W,W,W]]

To display a maze we make Maze into an instance of Show.

instance Show Maze where
    show (M []) = ""
    show (M (r:rs)) = map dispBlock r ++ "\n" ++ show (M rs)
       where dispBlock W = '#'
             dispBlock F = ' '
             dispBlock S = '*'

Finally, we represent a position in a maze by a tuple of integers. A path can be represented as a list of positions and a planning task is a triple consisting of start and goal positions and a maze.

type Pos = (Int, Int)
type Path = [Pos]
type Task = (Pos,Pos,Maze)

We will need to extract a block on a given position and conversely to set a block on a given position. To see Maybe monad in action, we implement these function to be safe. E.g. if we provide a position outside the maze, it will return Nothing. We will start by implementing such safe functions for lists.

Suppose we have an index n, an element x :: a and a list xs :: [a]. We want to implement a function that replaces the element of index n in xs by x provided that n is within the range of indexes of xs. If n is outside this range, it returns Nothing.

safePut :: Int -> a -> [a] -> Maybe [a]
safePut n x xs | n `elem` [0..length xs-1] = Just $ take n xs ++ [x] ++ drop (n+1) xs
               | otherwise = Nothing

Similarly, try to implement the function safeGet that extract the element of index n provided it exists:

safeGet :: Int -> [a] -> Maybe a
safeGet n xs | n `elem` [0..length xs-1] = Just $ xs !! n
             | otherwise = Nothing

Now we can use the above functions to implement functions extracting and setting a block in a maze. To extract a block, we first safely extract a row of a maze. If it is successful, we can extract the block from the row. Using the fact that Maybe is a monad, we don't have to test every time if the computation was successful.

getBlock :: Pos -> Maze -> Maybe Block
getBlock (x,y) (M xss) = do row <- safeGet y xss
                            block <- safeGet x row
                            return block  
 
> getBlock (1,0) maze
Just W
 
> getBlock (10,10) maze
Nothing

Using safeGet and safePut, try to implement a function that takes a block b, a maze m, a position (x,y) and returns a new maze created by replacing the block on (x,y) by b.

setBlock :: Block -> Pos -> Maze -> Maybe Maze
setBlock b (x,y) (M xss) = do row <- safeGet y xss
                              row' <- safePut x b row
                              xss' <- safePut y row' xss
                              return (M xss')                              
 
> setBlock S (1,2) maze
Just #####
# # #
#*###
#   #
#####

Finally, if we have a path (i.e., a list of positions), we can set recursively all its positions in a maze. Again using the fact that Maybe is a monad.

setPath :: Maze -> Path -> Maybe Maze
setPath m [] = Just m
setPath m (p:ps) = do m' <- setBlock S p m
                      m'' <- setPath m' ps
                      return m''  

You might note that this is in fact a kind of monadic foldr. There is of course a generic monadic foldr called foldrM. If you import Data.Foldable, then you can rewrite the above function as follows:

setPath = foldrM (setBlock S) 

As setPath returns a value of type Maybe Maze, we can extract it from the Maybe context by pattern matching.

drawSol :: Maze -> Path -> Maze
drawSol m ps = case setPath m ps of
                 Nothing -> m
                 Just m' -> m'

To find a path leading from a start position into the goal position, we need a function taking a position and returning all possible next positions. Assume that there are at most 8 possible moves. All possibilities are generated by the function neighbs. Out of these possibilities we have to filter only those leading to a free block. Moreover, it is necessary to check that the input position is admissible as well.

neighbs :: Pos -> [Pos]
neighbs (x,y) = [(x-1,y), (x+1,y), (x,y-1), (x,y+1),
                 (x-1,y-1), (x-1,y+1), (x+1,y-1), (x+1,y+1)]
 
nextPos :: Pos -> Maze -> [Pos]
nextPos p m = case getBlock p m of                                          -- is the input position admissible?
                Just F -> [ p' | p' <- neighbs p, getBlock p' m == Just F]  -- if yes, take all possibilities and filter admissible positions
                _ -> []
 
> nextPos (1,1) maze
[(1,2)]

Using nextPos, implement the following function taking a path, a maze and returning all its possible extensions. For efficiency reasons we will represent paths in BFS in the reversed order. Thus extend a given path using the operator (:).

extend :: Path -> Maze -> [Path]
extend [] _ = []
extend path@(p:_) m = map (:path) $ nextPos p m
 
> extend [(1,2),(1,1)] maze
[[(1,1),(1,2),(1,1)],[(1,3),(1,2),(1,1)],[(2,3),(1,2),(1,1)]]

Now we can easily implement BFS. Recall that in BFS we use a queue storing partial solutions. We will implement this queue naively as a list. In addition, we have to keep information about which positions were already visited. We define the function solve that is just a wrapper for the bfs function implementing BFS. The function bfs takes several arguments. The first is a list of already visited positions. The second is the queue of partial solutions. The third is the goal position and the last one is the maze.

solve :: Task -> Maybe Path  
solve (p,q,m) = bfs [] [[p]] q m
 
bfs :: [Pos] -> [Path] -> Pos -> Maze -> Maybe Path
bfs _ [] _ _ = Nothing
bfs visited (path@(p:_):paths) q m                       -- consider the first path in the queue and its head p
    | p == q = Just $ reverse path                       -- is path a solution? If yes, return the reversed solution
    | p `elem` visited = bfs visited paths q m           -- does path end in an already visited position? If yes, disregard it 
    | otherwise = bfs (p:visited) (paths ++ extend path m) q m  -- add p to visited positions and extend path by all possible positions 
 
> solve ((1,2),(3,3),maze)
Just [(1,2),(2,3),(3,3)]
 
> solve ((3,1),(3,3),maze)
Nothing

As a next task, we have to create a user interface for the BFS solver. We have to allow the user to specify a maze together with start and goal positions. The user provides a string containing all the necessary data via the standard input. It might look as follows:

start = (1,1)
goal = (28,4)
#########################################
#                #             #        #
#                #             #        #
###########   #######   ###########     #
#                   #   #         #     #
#          #####################        #
####       #            #      #        #
#       ##########    ################  #
#                                       #
#       #                   #           #
#########################################

Our program is supposed to parse this input and display its solution provided it exists:

#########################################
#*********       #             #        #
#         *      #             #        #
###########*  #######   ###########     #
#         *         #   #   ****  #     #
#        * #####################*       #
####    *  #            #      # *****  #
#      *##########    ################* #
#       ******************************  #
#       #                   #           #
#########################################

We will use the type constructor Parser that I explained in the lecture. Below you can find its definition and definitions of all its instances for Functor, Applicative, Monad and Alternative. So you can directly copy them into your source file.

Let me recall the info on Parser shortly. A parser over type a is a function taking an input string, consuming a part of it and returning the parsed value of type a and the remaining unused input string. The parsing can fail that's why it returns a value of type Maybe (a, String). For instance, if you want to parse an integer and the input string starts with a letter, then the parsing fails.

The function parse just helps us to remove the data constructor P. So if you want to apply a parser p to an input inp, call parse p inp.

As we want to make Parser an instance of Monad so that we can sequence parsers, we have to define also instances for super-classes Applicative and Functor. Functor instances over data type a implements a function fmap allowing to lift a map f :: a -> b to a map of type Parser a -> Parser b. The function fmap always keeps the functor structure untouched only changes values of type parameter a. So for Parser a it just keeps the parsing function the same expect of modifying the output value v :: a by f v.

Functors allow lifting unary maps to the functorial context. E.g. we can lift (+1) to Parser Int but we cannot lift binary (+). If we lift (+) :: Int -> Int -> Int to Parser Int by fmap, we obtain a function Parser Int -> Parser (Int -> Int). However, to lift (+), we need type Parser Int -> Parser Int -> Parser Int. Applicative functors implement <*> that can transform Parser (Int -> Int) to Parser Int -> Parser Int. The function pure just wraps a value into the Parser context. It is in fact a synonym for the monadic return.

The monad instance for Parser has to define the bind operator »=. Its implementation first parses a value v :: a. If the parsing fails, then the whole parsing fails. Otherwise, we apply f v obtaining the next parser applied to the unused input out.

Finally, we define the instance of Alternative. It consists of empty and <|>. The first is the always failing parser. The second operator allows trying two parsers for the same input and the first successful returns its result.

newtype Parser a = P (String -> Maybe (a, String))
 
parse :: Parser a -> String -> Maybe (a, String)
parse (P p) inp = p inp
 
instance Functor Parser where
    -- fmap :: (a -> b) -> Parser a -> Parser b
    fmap f p = P (\inp -> case parse p inp of
                            Nothing -> Nothing
                            Just (v,out) -> Just (f v, out))
 
instance Applicative Parser where
    -- (<*>) :: Parser (a -> b) -> Parser a -> Parser b
    pg <*> px = P (\inp -> case parse pg inp of
                             Nothing -> Nothing
                             Just (g,out) -> parse (fmap g px) out)
    pure v = P (\inp -> Just (v,inp))
 
instance Monad Parser where
    -- (>>=) :: Parser a -> (a -> Parser b) -> Parser b
    p >>= f = P (\inp -> case parse p inp of
                           Nothing -> Nothing
                           Just (v,out) -> parse (f v) out)
 
instance Alternative Parser where
    -- empty :: Parser a
    empty = P (\_ -> Nothing)
    -- (<|>) :: Parser a -> Parser a -> Parser a
    p <|> q = P (\inp -> case parse p inp of
                           Nothing -> parse q inp
                           Just (v,out) -> Just (v,out))

Now we are ready to implement the parser for our BFS application. We start with simple parsers out of which we compose the final one. The structure of the input <file> is specified by the following grammar. The first line contains a definition of the start position and the second one a definition of the goal position. The start definition starts with “start” followed possibly by spaces, then “=”, again possibly followed by spaces and then a position followed by the new-line character “\n”. The goal definition is analogous. The position is just a tuple of numbers in parentheses separated by a comma and possibly by spaces. The maze <map> consists of rows followed by “\n”. Each row is a (possibly empty) sequence of the wall “#” and free “ ” blocks.

<file> -> <start> <goal> <map>
 
<start> -> "start" <sep>* "=" <sep>* <pos> "\n"
<goal> -> "goal" <sep>* "=" <sep>* <pos> "\n"
 
<pos> -> "(" <sep>* <digit>+ <sep>* "," <sep>* <digit>+ <sep>* ")"
 
<map> -> (<row> "\n")* <map> 
<row> -> (<wall> | <sep>)* "\n"
 
<wall> -> "#"
<digit> -> 0 | 1 | ... | 9
<sep> -> " "

First, we create a basic parser item consuming a single character and failing if there is none. Based on that we can define a parser sat parsing a character satisfying a given predicate. If you need extra exercises, reimplement the following parsers using the operators >>= and >>.

item :: Parser Char
item = P (\inp -> case inp of
                    "" -> Nothing
                    (x:xs) -> Just (x,xs))
 
sat :: (Char -> Bool) -> Parser Char
sat pr = do x <- item 
            if pr x then return x
            else empty 

To parse numbers we need a parser for a single digit. The predicate isDigit from Data.Char recognizes digits. Further, we need parsers for a specific character and even a specific string like “start”.

digit :: Parser Char
digit = sat isDigit
 
char :: Char -> Parser Char
char c = sat (== c)
 
string :: String -> Parser String
string [] = return []
string (x:xs) = do char x 
                   string xs
                   return (x:xs)
 
> parse digit "34abc"
Just ('3',"4abc")
 
> parse (string "start") "start = (1,2)" 
Just ("start"," = (1,2)")

Note that the above function string returns a parser whose output value is known in advance (it is x:xs). Its only reason is to check if the parsing does not fail.

As we define Parser to be an instance of Alternative, we have for free two parser combinators many and some. Both of them apply repeatedly a given parser until it fails. The parser many p always succeeds even if p fails for the first time. On the other hand, some p succeeds only if the first application of p succeeds.

> parse (many (char 'a')) "aaabc"
Just ("aaa","bc")
 
> parse (many (char 'a')) "bc"
Just ("","bc")
 
> parse (some (char 'a')) "aaabc"
Just ("aaa","bc")
 
> parse (some (char 'a')) "bc"
Nothing

Thus many can handle (possibly empty) sequences (e.g., an arbitrary sequence of spaces) and some non-empty sequences (e.g., non-empty sequences of digits representing an integer). To disregard sequences of spaces, we define the following parser together with the function token that transform any parser so that it omits spaces at the beginning and at the end.

space :: Parser ()
space = do many (sat isSpace) 
           return ()
 
token :: Parser a -> Parser a
token p = do space 
             x <- p
             space
             return x
 
> parse (token (char '=')) " = (1,2)"
Just ('=',"(1,2)")             

Now we will follow the grammar. We start with a parser for a position.

pos :: Parser Pos
pos = do char '('                -- it has to start with '('
         space                   -- possibly followed by spaces
         x <- some digit         -- then parses a nonempty sequence of digits
         token (char ',')        -- then comma possible surrounded by spaces
         y <- some digit         -- then a second non-empty sequence of digits  
         space                   -- possibly spaces
         char ')'                -- then the closing ')'
         return (read x, read y) -- the position is returned, sequences of digits are converted by read
 
> parse pos "(  343, 55 )"
Just ((343,55),"")
 
> parse pos "(1 2)"
Nothing

Using the above parsers, try to define the following function taking a string and returning the parser of a definition.

def :: String -> Parser Pos 
def str = do string str
             token (char '=')
             p <- pos
             char '\n'
             return p
 
> parse (def "start") "start = (3,2)\n"
Just ((3,2),"")

Next, we focus on maze parsing. We define simple parsers for blocks. Out of them, we can create a parser for rows. Using the operator <|>, we can define the parser wall <|> free which parses either the wall or free block.

wall :: Parser Block
wall = do char '#'
          return W
 
free :: Parser Block
free = do char ' '
          return F
 
row :: Parser [Block]
row = do bs <- many (wall <|> free)
         char '\n'
         return bs
 
> parse row "  ### # \n#      #\n"
Just ([F,F,W,W,W,F,W,F],"#      #\n")

A maze is just a (possibly empty) sequence of rows. The input starts with the start and goal definitions followed by a maze.

mapP :: Parser Maze
mapP = do rs <- many row
          return (M rs) 
 
file :: Parser Task
file = do p <- def "start"
          q <- def "goal"
          m <- mapP
          return (p,q,m)