Labs

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, Winows, MAC from: https://racket-lang.org/ The students can use the one installed in the lab computers. The teacher may help the students (to a reasonable degree) to get the IDE running on students’ laptops. Explain the language (scheme variant) selection options. 1. Choose in the environment 2. #lang {scheme|r5rs|…}

Students should understand that learning functional programming is important for improving their programming skills. It helps them master recursion and functional patterns are increasingly common in mainstream programming languages.

Start interaction in REPL. Scheme uses prefix notation for all functions. Let students compute simple formulas, e.g., 2+3/5. For the following exercises, I suggest first explaining the task. Than leaving the students to work on it individually for a few minutes. Discuss their ideas and approach to the problem. Afterwards, a randomly selected student will explain the solution to everyone on the whiteboard with help from the teacher and the other students.

Exercise 1: Use scheme REPL to compute a discriminant of the following quadratic function.

(- (* -3 -3) (* 4 4 5))
=> -71

Exercise 2: Write a function D for computing the discriminant of a quadratic form based of coefficients a, b, c.

(define (D a b c)
  (- (* b b) (* 4 a c)))

Exercise 3: Write a function roots that will use the previously defined computation of the discriminant to return the roots of the quadratic function.

(define (roots a b c)
  (list 
    (/ (+ (- b) (sqrt (D a b c))) (* 2 a))
    (/ (- (- b) (sqrt (D a b c))) (* 2 a))
  )
)

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

(define (my-even? n)
  (cond ((= n 0) #t)
        ((= n 1) #f)
        ((> n 0) (my-even? (- n 2)))
        (#t (my-even? (+ n 2)))
   )
)

Students will likely first forget about the negative numbers. Let them find out what happens with negative input. Relate to best practice rules to avoid infinite recursion. This is an example of analytic recursion.

Exercise 5: Write a function that returns the n-th Fibonacci number.

(define (fib n)
  (cond ((= n 0) 0)
        ((= n 1) 1)
        (else (+ (fib (- n 1)) (fib (- n 2))))
   )
)

Let them try to run (fib 100). Discuss that this function is correct, but very inefficient. Why does it take so much memory? Explain that the stop button and rerun will allow them to continue, if you did not get to that already. This is an example of tree recursion.

Exercise 6: Write a function that returns the n-th Fibonacci number effectively.

Lead the students to realize that if they need an extra “variable”, they can add an argument.
(define (fib-hlp last2 last n)
  (if (= 0 n)
      (+ last2 last)
      (fib-hlp last (+ last2 last) (- n 1))))
(define (fib2 n)
  (fib-hlp -1 1 n))

This exercise can be skipped until the next lab if things are going slowly.

Exercise 7: Write a function that returns a list of the first n fibonacci numbers.

(define (fibs n)
  (define (iter k)
    (if (= k n)
        '()
        (cons (fib2 k) (iter (+ k 1)))
        )
    )
  (iter 0)
  )

Exercise 8: Using the my-even? predicate defined previously, write a function that will for a list of numbers return a list of only even numbers in the list.

(define (take-even l)
  (cond ((null? l) l)
        ((my-even? (car l)) (cons (car l) (take-even (cdr l))))
        (else (take-even (cdr l)))
   )
)

The goal of this lab is to practice writing recursive functions in scheme and using the accumulator to make the functions more efficient. Furthermore, the students should practice using let and lambda abstraction.

We explained the first homework assignment.

Exercise 1: Write a recursive function that would reverse a list. For example (1 2 3 4) → (4 3 2 1).

(define (my-reverse l)
  (cond ((null? l) l)
        (#t (append (my-reverse (cdr l)) (list (car l))))
   )
)

Understand why this function is inefficient (has quadratic complexity).

Exercise 2: Write the function from Exercise 1 in a linear time complexity.

(define (my-reverse2 l)
  (define (rev-acc l acc)
    (cond ((null? l) acc)
        (#t (rev-acc (cdr l) (cons (car l) acc)))
    )
  ) 
  (rev-acc l '())
)

Note that using the accumulator is a general concept.

Exercise 3: Write a function my-flatten that will take any structure of nested lists and return a list of elements in these lists. For example (a b (c d (e) f ()) g) → (a b c d e f g).

(define (my-flatten l)
  (cond ((null? l) l)
        ((list? (car l)) (append ( my-flatten (car l)) (my-flatten (cdr l))))
        (#t (cons (car l) (my-flatten (cdr l))))
  )
)

This is an example of tree recursion.

Exercise 4: Write a more efficient version of the function from Exercise 3 using accumulator.

(define (my-flatten2 lst)
  (define (iter lst acc)
    (cond
      ((null? lst) acc)
      ((list? (car lst)) (iter (cdr lst) (iter (car lst) acc)))
      (else (iter (cdr lst) (append acc (list (car lst)))))
      )
    )
  (iter lst '())
  )

Exercise 5: Let 2D vectors be defined as list of coordinates (1,2), (4,1). Write a function to compute the Euclidean distance between two vectors. Make sure no computation is performed twice.

(define (dist p1 p2)
  (let ((dx (- (car p1) (car p2)))
        (dy (- (cadr p1) (cadr p2)))
        )
    (sqrt (+ (* dx dx) (* dy dy)))
   )
)

Remember the function filter explained in the lecture.

Exercise 6: Write a function that removes all duplicate (or more) elements in a list. For example (1 2 3 2 5 1 3 4 2 5 2 1 3) → (1 2 3 5 4). You may use the function filter.

(define (remove-dup l)
   (if (null? l) l
       (cons (car l) 
             (remove-dup (filter (lambda (x) (not (equal? (car l) x))) 
                                 (cdr l)))
       )
   )
)

Exercise 7: Write a function that applies a given function to i-the element of a list. For example (apply-at sqrt ‘(4 4 4 4 4) 2) → (4 4 2 4 4).

(define (apply-at fn list pos)
  (cond ((= pos 0) (cons (fn (car list)) (cdr list)))
        (#t (cons (car list) (apply-at fn (cdr list) (- pos 1))
   )
)

Exercise 8: Use apply-at to increment 2nd position in a list of numbers in REPL.

(apply-at (lambda (x) (+ x 1)) '(1 2 3 4) 2)

Exercise 9: Use apply-at to write a function substitute that substitutes the i-th element of a list with a new value. For example (subst ‘a ‘(1 2 3 4) 1) → (1 a 3 4)

(define (subst new list pos)
  (apply-at (lambda (x) new) list pos)
)

Exercise 10: (If there is still time) Use function apply-at to write a function apply-at-xy, which will apply the function at position (x,y) in a list of lists. (apply-at-xy sqrt ‘((4 4 4) (4 4 4) (4 4 4)) 1 1) → ((4 4 4) (4 2 4) (4 4 4))

(define (apply-xy fn x y list-of-lists)
  (apply-at (lambda (line)
              (apply-at fn line x)
             ) list-of-lists y)
)

The goal of this lab is to understand and practice the built-in higher order functions in scheme.

Try out the following simple commands in REPL.

(map sqrt '(1 4 9 16 25))
(map car '((A B) (C) (D E)))
(map max '(3 9 17) '(2 4 11) '(7 3 2))

Exercise 1: Write a function that returns n-th line of the Pascal triangle as a list.

(define (pascal n)
  (cond ((= n 1) '(1))
        (#t (let ((prev (pascal (- n 1))))
              (map + (cons 0 prev) (append prev '(0)))
            )
        )
  )
)

Exercise 2: Use foldr/foldl to implement a function that multiplies all elements in a list.

(define (mult list)
  (foldr * 1 list)
)

Exercise 3: Use foldl/foldr to write a function that reverses a list.

(define (reverse4 l)
  (foldl cons '() l)
)

Exercise 4: Use foldl/foldr to write a function that returns the minimum of a list.

(define (min lst)
  (fold (lambda (x y) (if (< x y) x y)) (car lst) (cdr lst))
)

Exercise 5: Use map/fold to compute a dot product of two vectors represented as lists.

(define (dot-product v w)
  (fold + 0 (map * v w))
)

Exercise 6: Use map/fold to compute a product of a matrix and a vectors represented as lists.

(define (mxv m v)
  (map (lambda (row) (dot-product row v)) m))

Exercise 7: Use higher order functions to compute transpose of a matrix.

(define (transpose mat)
   (apply map list mat))

Exercise 8: Use higher order functions to implement multiplication of two matrices.

(define (mxm m n)
  (let ((cols (transpose n)))
    (map (lambda (row) (mxv cols row))
         m)))

The goal of this lab is to practice more complex functions that combine recursion and higher order functions.

We explained the second home assignment.

Exercise 1: Using recursion and higher order functions, write a function that returns a list of all subsets of a given list.

Idea of the algorithm: Take all subsets of a list without first element and return a union of the subsets and the subsets with the removed element added.

(define (power-set s)
  (if (null? s) '(())
      (let ((rest-ps (power-set (cdr s))))
          (append rest-ps (map (lambda (x) (cons (car s) x)) rest-ps)))))

Notice that the above code follows the structure of foldr function. Consequently, we can rewrite it as follows:

(define (power-set2 s)
  (foldr (lambda (x y) (append (map (lambda (z)(cons x z)) y) y)) '(()) s))

Exercise 2: Using recursion and higher order functions, write a function that returns a list of all permutations of a given list.

Idea of the solution: Take all permutations without one element and put the element to the first position in the result. Do it for all elements in the list and combine the result.

(define (perm-set l)
  (if (null? l) '(())
  (apply append (map (lambda (x)
                  (map (lambda (y) (cons x y)) (perm-set (remove x l)))
                ) l))
))

The goal of this lab is to practice lexical scope, lazy evaluation and infinite streams. In order to solve the exercises on streams, you can use the following functions and macros defined in the 4th lecture.

(define-syntax w-delay
  (syntax-rules ()
    ((w-delay expr) (lambda () expr))))
 
(define-syntax w-force
  (syntax-rules ()
    ((w-force expr) (expr))))
 
(define (first stream) (car stream))
(define (rest stream)
  (if (list? (cdr stream))
      (cdr stream)
      (w-force (cdr stream))))
 
(define (take-n n s)
  (cond
    ((= n 0) '())
    ((null? s) '())
    (else
     (cons (first s) (take-n (- n 1) (rest s))))
    )
  )
 
(define (lazy-map f s)
  (cond ((null? s) '())
        (#t (cons (f (first s)) (w-delay (lazy-map f (rest s)))))))

Exercise 1: Draw a schema of variable bindings, closures and references among them during execution of the following code in a way similar to the one shown in the lecture.

(define (f x y)
  (define (g z)
    (if (<= (abs (- x z)) (abs (- y z)))
        x
        y))
  g)
 
(define posneg (f -1 1))
 
(display (posneg 21))
(display (posneg -3))
(display ((f 10 20) 18))

Solution: The program displays 1-120 (see this diagram PDF)

Exercise 2: Define a macro for special form and with lazy evaluation. First write the logics without the macro, then rewrite it to a macro.

(define (my-lazy-and2 a b)
  (if (a) (b) #f))
 
(define-syntax my-mac-and2
  (syntax-rules ()
     ((my-mac-and2) #t)
     ((my-mac-and2 a) e)
     ((my-mac-and2 a b) (my-lazy-and2 (lambda () a) (lambda () b)))))

A good way of testing that the lazy evaluation actually works.

> (my-mac-and2 (begin (display 'a) #t) (begin (display 'b) #t))
ab#t
> (my-mac-and2 (begin (display 'a) #f) (begin (display 'b) #t))
a#f

(The following exercise is taken from https://inst.eecs.berkeley.edu/~cs61as/sp13/lab/11.html)

Exercise 3: An unsolved problem in number theory concerns the following algorithm for creating a sequence of positive integers s1, s2, …       Choose s1 to be some positive integer.        For n > 1,           if sn is odd, then sn+1 is 3sn+1;           if sn is even, then sn+1 is sn/2. No matter what starting value is chosen, the sequence always seems to end with the values 1, 4, 2, 1, 4, 2, 1, … However, it is not known if this is always the case.

a) Write a procedure num-seq that, given a positive integer n as argument, returns the stream of values produced for n by the algorithm just given. For example, (num-seq 7) should return the stream representing the sequence 7, 22, 11, 34, 17, 52, 26, 13, 40, 20, 10, 5, 16, 8, 4, 2, 1, 4, 2, 1, …

(define (num-seq n)
  (cons n (delay (if (even? n)
                     (num-seq (/ n 2))
                     (num-seq (+ (* n 3) 1))))))

b) Write a procedure seq-length that, given a stream produced by num-seq, returns the number of values that occur in the sequence up to and including the first 1. For example, (seq-length (num-seq 7)) should return 17. You should assume that there is a 1 somewhere in the sequence.

(define (seq-len s)
  (if (= (first s)1)
      1
      (+ 1 (seq-len (rest s)))))

Exercise 4: Define an infinite stream of Fibonacci numbers without higher order functions.

(define (fib-hlp a b)
  (cons a
        (w-delay (fib-hlp b (+ a b)))
        )
  )
 
(define fibs (fib-hlp 0 1))

Exercise 5: Write a function sappend that appends two streams.

(define (sappend a b)
  (if (null? a)
      b
      (cons (first a) (w-delay (sappend (rest a) b)))
     )
  )

Exercise 6: Define a function partial-sums that takes as an argument a stream s and returns the stream whose elements are s1, s1+s2, s1+s2+s3,… For example on natural numbers 1,2,3,4,… it returns 1,3,6,10,…

(define (partial-sums s)
  (cons (first s)
        (w-delay
         (lazy-map (lambda (x) (+ x (first s))) (partial-sums (rest s)))
         )
        )
  )

Exercise 7: It is known that the series 1 - 1/3 + 1/5 - 1/7 + 1/9 - … converges to π/4. Using this series, approximate the number π. Hint: Define a stream pi-summands consisting of numbers 1, -1/3, 1/5, -1/7,… and apply the partial-sums function from Exercise 6. The resulting stream pi-stream consists of better and better approximations of π. For example (take-n 1000 pi-stream) gives the first 1000 approximations.

(define (pi-summands n)
  (cons (/ 1.0 n)
        (w-delay
         (lazy-map - (pi-summands (+ n 2)))
         )
        )
  )
 
(define pi-stream
  (lazy-map ((curry *) 4) (partial-sums (pi-summands 1))))

The goal of this lab is to practice imperative paradigms in scheme.

(The following exercise is from https://www.usna.edu/Users/cs/roche/courses/f12si413/l03/index.html)

Exercise 1: Write a function make-stack that creates “stack objects”. Your stack should allow the following messages: 'size: Returns the number of elements in the stack. 'pop: Removes the top element of the stack and returns it. (You can assume that the size of the stack is at least 1 before this method is called.) 'push x1 x2 …: Takes any number of additional objects and puts them on the stack. Note: normally “push” puts a single new object on the top of the stack. Your stack will allow an arbitrary number of arguments, and the effect will be to add them as if they had been pushed individually from right to left.

Here's an example:
> (define S1 (make-stack))
> (S1 'size)
0
> (S1 'push 3 'a 2.1)
> (S1 'pop)
3
> (S1 'push 'x)
> (S1 'pop)
x
> (S1 'pop)
a
> (S1 'size)
1

(define (make-stack)
  (let ((stack '()))
    (define (push . args)
      (set! stack (append args stack))
      )
    (define (pop)
      (if (null? stack)
          'empty
          (let ((out (car stack)))
            (set! stack (cdr stack))
            out)
          )
      )
    (define (dispatch m . args)
      (cond
        ((eq? m 'size) (length stack))
        ((eq? m 'pop) (pop))
        ((eq? m 'push) (apply push args))
        (else 'error)
        )
      )
    dispatch)
  )

(The following exercise is from https://inst.eecs.berkeley.edu/~cs61as/sp13/lab/9.html)

Exercise 2: Provide the arguments for the two set-cdr! operations in the blanks below to produce the indicated effect on list1 and list2. Do not create any new pairs; just rearrange the pointers to the existing ones.

> (define list1 (list (list 'a) 'b))
list1
> (define list2 (list (list 'x) 'y))
list2
> (set-cdr! ________ ________)
okay
> (set-cdr! ________ ________)
okay
> list1
((a x b) b)
> list2
((x b) y)

(set-cdr! (car list2) (cdr list1))
(set-cdr! (car list1) (car list2))

(The following exercise is from Exercise 3.17)

Exercise 3: Devise a correct version of the count-pairs procedure that returns the number of distinct pairs in any structure.

One has to maintain a list of already seen pairs. Either you can keep it in a function closure and update it via set! function:

(define count-pairs
  (let ((seen '()))
    (lambda (x)
      (cond
        ((not (pair? x)) 0)
        ((memq x seen) 0)
        (else
         (set! seen (cons x seen))
         (+ (count-pairs (car x))
            (count-pairs (cdr x))
            1)))
      )
    )
  )

Or the list of seen pairs can be passed to a helper function as an argument:

(define (count-pairs x)
  (define (iter x seen)
    (cond
      ((not (pair? x)) seen)
      ((memq x seen) seen)
      (else
       (let ((seen2 (iter (car x) (cons x seen))))
         (iter (cdr x) seen2)))))
  (length (iter x '()))
  )

Exercise 4: Write vector-append, which takes two vectors as arguments and returns a new vector containing the elements of both arguments, analogous to append for lists.

(define (vector-append u v)
  (let*
      ((lu (vector-length u))
       (lv (vector-length v))
       (w (make-vector (+ lu lv))))
    (do ((i 0 (+ i 1)))
      ((= i lu) #f)
      (vector-set! w i (vector-ref u i)))
    (do ((i 0 (+ i 1)))
      ((= i lv) #f)
      (vector-set! w (+ i lu) (vector-ref v i)))
    w)
  )

The goal of this lab is to practice lambda calculus and the connection to scheme.

Exercise 1: Make a derivation of expression 2S1 in lambda calculus. The solution can be found here.

Exercise 2: Define True, False, And, Or, from lambda calculus in scheme.

(define T
  (lambda (a)
    (lambda (b) a)))
 
(define F
  (lambda (a)
    (lambda (b) b)))
 
(define mand
  (lambda (a)
    (lambda (b)
      ((a b) F))))
 
(define mor
  (lambda (a)
    (lambda (b)
      ((a T) b))))

Exercise 3: Define zero and the successor functions form lambda calculus in scheme.

(define N0
  (lambda (s)
    (lambda (z) z)))
 
(define S
  (lambda (w)
    (lambda (y)
      (lambda (x)
        (y ((w y) x))))))

You can test it as:

(((S (S (S N0))) (lambda (x) (+ x 1))) 0)
(((S (S (S N0))) (lambda (x) (cons 'I x))) '())

An explanation how to derive solutions to the following two exercises can be found here.

Exercise 4: Define recursive function factorial without using define.

((lambda (f)
     (lambda (n)
       (if (= n 0)
           1
           (* n ((f f) (- n 1))))))
   (lambda (f)
     (lambda (n)
       (if (= n 0)
           1
           (* n ((f f) (- n 1)))))))

Exercise 5: Generalize the function to a variant of the Y combinator for scheme.

(define Y
  (lambda (y)
    ((lambda (x)
       (y (lambda (arg) ((x x) arg))))
     (lambda (x)
       (y (lambda (arg) ((x x) arg)))))))

You can use it to recursively call a factorial function.

((Y (lambda (r) (lambda (n) (if (= n 1) 1 (* n (r (- n 1))))))) 5)

The goal of this lab is to get familiar with Haskell interpreter and basics of Haskell programming.

Exercise 1: Write a function for the n-th Fibonacci number using pattern matching.

fib 0 = 1
fib 1 = 1
fib n = fib (n-1) + fib (n-2)

Exercise 2: Write a function for the n-th Fibonacci number using one definition and if-then-else.

fib1 n = if n==0 then 1
         else if n==1 then 1
         else fib1 (n-1) + fib1 (n-2)

Exercise 3: Write a function for the n-th Fibonacci number using guards.

fib2 n | n==0 = 1
       | n==1 = 1
       | otherwise = fib2 (n-1) + fib2 (n-2)

Exercise 4: Write a function for computing roots of a quadratic equations with storing the intermediate results using let and where.

roots1 a b c =
  let sd = sqrt(b^2 - 4*a*c)
      aa = 2*a
  in ((-b+sd)/aa,(-b-sd)/aa)
 
roots2 a b c = ((-b+sd)/aa,(-b-sd)/aa)
  where sd = sqrt(b^2 - 4*a*c)
        aa = 2*a

Exercise 5: Write a function for the n-th Fibonacci number effectively using only one function definition in the top level scope.

fib3 n = x
  where (_,x) = hlp n
          where hlp 1 = (0,1)
                hlp n = (b,a+b)
                  where (a,b) = hlp (n-1)

Exercise 6: Write the standard function take, which returns a list of the first n elements of a list.

take’ 1 (x:_) = [x]
take’ n (x:xs) = [x] ++ take’ (n-1) xs

Exercise 7: Write the standard function reverse, which reverses a list.

reverse’ xs = rev_acc xs [] where
   rev_acc [] acc = acc
   rev_acc (x:xs) acc = rev_acc xs (x:acc)

Further, the students will write merge sort.

Exercise 8: Write the function split, which splits the elements in a list to two equally long lists.

split [] = ([],[])
split [x] = ([x],[])
split (x:y:xs) = (x:fs,y:ss) where (fs,ss) = split xs

Exercise 9: Write the function merge, which merges two sorted lists.

merge xs [] = xs
merge [] ys = ys
merge (x:xs) (y:ys) | x<y       = (x:merge xs (y:ys))
                    | otherwise = (y:merge (x:xs) ys)

Exercise 10: Write the function msort, which uses the previous functions to implement the mergesort.

msort [] = []
msort [x] = [x]
msort xs = merge (msort ls) (msort rs) 
   where (ls,rs) = split xs

The goal of this lab is to practice writing Haskell functions, understand the build-in types in Haskell, type signatures, creating own type definitions and working with them.

Exercise 1: Write type declarations for the functions form the last lab.

fib :: Int -> Int
roots1 :: Floating a => a -> a -> a -> (a,a)
split :: [a] -> ([a],[a])
merge :: Ord a => [a] -> [a] -> [a]
mergesort :: Ord a => [a] -> [a]

Exercise 2: Write a one line function for a list of all Fibonacci numbers.

fibs :: [Integer]
fibs = 1:1:[a+b | (a,b) <- zip fibs (tail fibs)]

Exercise 3: Write a two line function for a list of all prime numbers numbers based on the sieve of Eratosthenes.

primes :: [Integer]
primes = sieve [2..]
  where sieve (p:xs) = p:sieve [x | x<-xs,  x `mod` p /= 0]

Exercise 4: Make an own type for representing colours: Red, Green, Blue (use deriving for Show and Eq). Define a predicate isred determining whether a color is red.

data Colors = Red | Green | Blue deriving (Eq, Show)
 
isred :: Colors -> Bool
isred Red = True
isred _ = False
 
isred2 c = (c == Red)

Exercise 5: Make your own type for representing lists of arbitrary elements (use deriving for Show and Eq). Implement list2myList, length for MyList.

data MyList a = Nil | Cons a (MyList a) deriving (Show, Eq)
 
list2my :: [a] -> (MyList a)
list2my [] = Nil
list2my (x:xs) = Cons x (list2my xs)
 
len :: (MyList a) -> Int
len Nil = 0
len (Cons x xs) = 1 + len xs

Exercise 6: Make a function that creates a binary search tree containing elements of a list and implement an efficient search in the binary search tree.

data BSTree a = BSNil | BSNode (BSTree a) a (BSTree a) deriving Show
 
makeSTree :: (Ord a) => [a] -> (BSTree a)
makeSTree [] = BSNil
makeSTree (x:xs) = BSNode (makeSTree [y | y <-xs, y<x]) 
                          x
                          (makeSTree [y | y <-xs, y>x])  
 
occurs2 :: Ord a => a -> BSTree a -> Bool
occurs2 x BSNil = False
occurs2 x (BSNode l y r) | x == y = True
                         | x < y  = occurs2 x l
                         | x > y  = occurs2 x r

The goal of this lab is to understand Haskell type classes and practice writing own instances.

Exercise 1: Write explicit definitions of instances of Show and Eq for Colors and MyList from the last lab.

instance Show Colors where
  show Red = "red"
  show Green = "green"
  show Blue = "blue"
 
instance Eq Colors where
  Red == Red = True
  Green == Green = True
  Blue == Blue = True
  _    == _    = False
 
instance (Show a) => Show (MyList a) where
  show Nil = ""
  show (Cons x Nil) = show x
  show (Cons x xs) = (show x) ++ ", " ++ (show xs)
 
instance (Eq a) => Eq (MyList a) where
  Nil == Nil = True
  (Cons x xs) == (Cons y ys) = x==y && xs==ys
  _ == _ = False

Exercise 2: Write explicit definition of instance of Show for BSTree from the last lab, so that it is displayed clearly on multiple lines using proper indentation.

instance (Show a) => Show (BSTree a) where
  show t = disp 0 t
    where
      indent n str = take n [' ',' '..] ++ str ++ "\n"
      disp n BSNil = ""
      disp n (BSNode l x r) = indent n (show x)
                              ++ disp (n+4) l
                              ++ disp (n+4) r

Exercise 3: Define infix operator += that adds a new element into a BSTree. Start with the type declaration.

(+=) :: (Ord a) => (BSTree a) -> a -> (BSTree a)
BSNil += x = BSNode BSNil x BSNil
t@(BSNode l x r) += y | x==y = t
                      | x<y  = BSNode l x (r += y)
                      | otherwise = BSNode (l += y) x r

Exercise 4: Define a higher order function treeFold that allows computing the number of elements in a tree, sum of the elements, depth. Assuming it is not a proper search tree also maximum, minimum. Define all these functions using a suitable lambda functions and ending elements.

treeFold :: (a -> b -> b -> b) -> b -> (BSTree a) -> b
treeFold f e BSNil = e
treeFold f e (BSNode l x r) = f x (treeFold f e l) (treeFold f e r)
 
treeSum :: (Num a) => (Tree a) -> a
treeSum = treeFold (\x y z -> x+y+z) 0 
 
treeDepth :: (BSTree a) -> Int
treeDepth = treeFold (\x y z -> 1 + max y z) 0
 
treeNumElems :: (BSTree a) -> Int
treeNumElems = treeFold (\x y z -> 1 + y + z) 0
 
treeMin :: (Ord a) => (BSTree a) -> Maybe a
treeMin BSNil = Nothing
treeMin t@(BSNode l e r) = Just (treeFold (\x y z -> min x (min y z)) e t)
 
treeMax :: (Ord a) => (BSTree a) -> Maybe a
treeMax BSNil = Nothing
treeMax t@(BSNode l e r) = Just (treeFold (\x y z -> max x (max y z)) e t)

This was an extra lab for the Wednesday class on May 6. Its task was to develop a program solving a so-called countdown problem. Given a list of natural numbers ns and a target natural number n, find an algebraic expression built from +,-,*,/ whose value is n. Every number in ns can be used at most once and all the subexpressions has to be evaluated to natural numbers as well.

For example, given numbers 1, 4, 4, 8, 9, 50 and a target number 868. A solution is for instance (8 + 9) * (50 + 1) + (4 / 4) = 868.

data Op = Add | Sub | Mul | Div
 
instance Show Op where
    show Add = " + "
    show Sub = " - "
    show Mul = " * "
    show Div = " / "
 
valid :: Op -> Int -> Int -> Bool
valid Add x y = x <= y
valid Sub x y = x > y
valid Mul x y = x <= y && x /= 1 && y /= 1
valid Div x y = x `mod` y == 0 && y /= 1
 
apply :: Op -> Int -> Int -> Int
apply Add x y = x + y
apply Sub x y = x - y
apply Mul x y = x * y
apply Div x y = x `div` y
 
data Expr = Val Int | App Op Expr Expr
 
instance Show Expr where
    show (Val n) = show n
    show (App o l r) = brak l ++ show o ++ brak r
                       where
                           brak (Val n) = show n
                           brak e       = "(" ++ show e ++ ")"
 
values :: Expr -> [Int]
values (Val n) = [n]
values (App _ l r) = values l ++ values r
 
eval :: Expr -> [Int]
eval (Val n) = [n | n>0]
eval (App o l r) = [apply o x y | x <- eval l, y <- eval r, valid o x y]
 
subs :: [a] -> [[a]]
subs [] = [[]]
subs (x:xs) = yss ++ map (x:) yss
              where yss = subs xs
 
interleave :: a -> [a] -> [[a]]
interleave x [] = [[x]]
interleave x (y:ys) = (x:y:ys) : map (y:) (interleave x ys)
 
perms :: [a] -> [[a]]
perms [] = [[]]
perms (x:xs) = concat (map (interleave x) (perms xs))
 
choices :: [a] -> [[a]]
choices = concat . map perms . subs
 
solution :: Expr -> [Int] -> Int -> Bool
solution e ns n = eval e == [n] && elem (values e) (choices ns)
 
split :: [a] -> [([a], [a])]
--split [1,2,3,4] = [([1],[2,3,4]), ([1,2],[3,4]), ..]
split [] = []
split [_] = []
split (x:xs) = ([x], xs) : [(x:ls,rs) | (ls, rs) <- split xs]
 
exprs :: [Int] -> [Expr]
exprs [] = []
exprs [n] = [Val n]
exprs ns = [e | (ls,rs) <- split ns, l <- exprs ls, r <- exprs rs, e <- combine l r]
 
combine :: Expr -> Expr -> [Expr]
combine l r = [App o l r | o <- ops]
 
ops :: [Op]
ops = [Add, Sub, Mul, Div]
 
solutions :: [Int] -> Int -> [Expr]
solutions ns n = [e | ns' <- choices ns, (e, m) <- results ns', m == n]
 
type Result = (Expr, Int)
 
results :: [Int] -> [Result]
results [] = []
results [n] = [(Val n, n) | n > 0]
results ns = [res | (ls,rs) <- split ns, lx <- results ls, ry <- results rs, res <- combine' lx ry]
 
combine' :: Result -> Result -> [Result]
combine' (l,x) (r,y) = [(App o l r, apply o x y) | o <- ops, valid o x y]
 
main :: IO()
main = print (solutions [1,4,4,8,9,50] 868)

Exercise 1: Define functions for determining whether a BSTree form previous lecture is balanced.

isBalanced :: (BSTree a) -> Bool
isBalanced BSNil = True
isBalanced (BSNode l y r) = isBalanced l && isBalanced r && abs (treeDepth l - treeDepth r) <= 1

Exercise 2: Make BSTree an instance of the Functor class.

instance Functor BSTree where
  fmap f BSNil = BSNil
  fmap f (BSNode l x r) = BSNode (fmap f l) (f x) (fmap f r)

Exercise 3: Use function sections to increment all elements in the tree by 5.

fmap (+5) t

Exercise 4: Make the binary search tree and the related functions a separate module. Use it from another file with qualification T. Replace the treeMin implementation by a more efficient one in the new file.

Add to the beginning of the file 'module BST where' and save the file to BST.hs

import BST as T hiding (treeMin)
 
t = makeSTree [15,20,9,1,16,13,3,17,8,10,11] += 14 += 99
 
treeMin :: (Ord a) => (T.BSTree a) -> Maybe a
treeMin T.BSNil = Nothing
treeMin (T.BSNode T.BSNil x _) = Just x
treeMin (T.BSNode l _ _) = treeMin l

Exercise 5: Write a program that reads from the standard input one line and outputs the number of characters in that line.

main :: IO ()
main = do putStr "Enter a string: \n"
          xs <- getLine
          putStr "The string has "
          putStr (show (length xs))
          putStrLn " characters."

Exercise 6: Rewrite the program from Exercise 5 without do notation.

main :: IO ()
main = putStr "Enter a string: \n" >>
       getLine >>= \xs
       -> putStr "The string has " >>
       putStr (show (length xs)) >>
       putStrLn " characters."

Exercise 1: Implement a standalone program that allows two players to play Nim against each other.

import Data.Char
 
 
type Board = [Int]
 
initial :: Board
initial = [5,4,3,2,1]
 
data Player = P1 | P2 deriving Show
nextPlayer P1 = P2
nextPlayer P2 = P1
 
 
move :: Board -> Int -> Int -> Board
move board row num = take (row-1) board
                     ++ [(board !! (row-1)) - num]
                     ++ drop row board
 
putRow :: Int -> Int -> IO ()
putRow row num = do putStr (show row)
                    putStr ": "
                    putStrLn ['*' | x <- [1..num]]
 
putBoard :: Board -> IO ()
putBoard board = sequence_ [putRow i n | (i,n) <- zip [1..length board] board]
 
isFinished :: Board -> Bool
isFinished b = all (<=0) b
 
getDigit :: String -> IO Int
getDigit msg = do putStrLn msg
                  line <- getLine
                  let x = (line!!0)
                  if length line == 1 && isDigit x then
                    return (digitToInt x)
                  else
                    do putStrLn "Not a digit!!!"
                       getDigit msg
 
play :: Board -> Player -> IO ()
play board player =
  do putBoard board
     if isFinished board then
       do putStrLn ("\nPlayer " ++ (show player) ++ " wins!!!")
     else
       do putStrLn ("\n" ++ (show player))
          row <- getDigit "Enter a row number: "
          num <- getDigit "Stars to remove: "
          play (move board row num) (nextPlayer player)
 
main :: IO ()
main = play initial P1

Exercise 1: In Scheme, implement a function build_matrix which takes two arguments nrows and ncols and returns a matrix filled with increasing cell values.

#lang scheme
 
(define (compute_cell_value i cell)
  (+ (+ i 1) cell))
 
(define (create_row i ncols)
  (cond ((= i ncols) '())
        (#t (cons i (create_row (+ i 1) ncols) ))
        ))
 
(define (create_matrix cell nrows ncols)
  (cond ((= cell nrows) '())
        (#t
         (cons (map (lambda (i) (compute_cell_value i cell)) (create_row 0 ncols))
               (create_matrix (+ cell 1) nrows ncols)))
        ))
 
(define (build_matrix nrows ncols)
  (create_matrix 0 nrows ncols))

Exercise 2: In Haskell, implement a game called Wumpus, where a robot called Wumpus starts at an initial position and needs to travel to a target cell.

import Data.Char 
 
data Cell = Wumpus | Nil deriving Show
type Board = [[Cell]]
 
init_helper :: Int -> [Cell]
init_helper 0 = []
init_helper n = [Nil] ++ (init_helper (n-1))
init_board :: Int -> Int -> Board
init_board 0 _ = []
init_board n m = [ (init_helper m)] ++ (init_board (n-1) m)
 
enforce_helper :: [Cell] -> Int -> Cell -> [Cell]
enforce_helper row j c = take (j-1) row
                         ++ [c]
                         ++ drop j row
enforce_cell :: Board -> Int -> Int -> Cell -> Board
enforce_cell board i j c = take (i-1) board
                           ++ [(enforce_helper (board !! (i-1))  j c)]
                           ++ drop i board
 
initial = (enforce_cell (init_board 3 3) 1 1 Wumpus)
 
get_helper :: [Cell] -> Int
get_helper [] = -1
get_helper (Wumpus:xs) = 1 
get_helper (Nil:xs) | (get_helper xs) == -1 = -1  
                    | otherwise = ((get_helper xs)+1)  
 
get_position :: Board -> Int -> (Int,Int)
get_position [] _ = (-1,-1)
get_position (l:xs) r | (get_helper l) == -1 = (get_position xs (r+1)) 
                    | otherwise = (r,(get_helper l)) 
 
game_ends x y =  (x == 3 && y == 3)
 
 
 
move :: Board -> IO ()
move board = do let (x,y) = get_position board 1
                putStrLn ("Wumpus at " ++ (show (x,y)) ++ "; select move:")
                if game_ends x y
                  then do putStrLn "Game over: you win!!"
                else do line <- getLine
                        let cmd = (line!!0)
                        if cmd == 'n'
                          then (move (enforce_cell (enforce_cell board x y Nil) (x+1) y Wumpus))
                        else if cmd == 'e'
                          then (move (enforce_cell (enforce_cell board x y Nil) x (y+1) Wumpus))
                        else if cmd == 's'
                          then (move (enforce_cell (enforce_cell board x y Nil) (x-1) y Wumpus))
                        else if cmd == 'w'
                          then (move (enforce_cell (enforce_cell board x y Nil) x (y-1) Wumpus))
                        else (move board)
main :: IO()
main = do move initial