3.1 Points and Rectangle **
The purpose of this exercise is to strengthen your understanding of functions used as classes in Scheme.
First, play with the existing Point class defined on this page available from the on-line version of this material.
As an example, construct two points and add them together. Also, construct two lists of each four points, and add them together pair by pair.
Define a new method in the Point class called (move dx dy), which displaces a point with dx units in the x direction and dy units in the y direction. We encourage you to make a functional solution in which move creates a new displaced point. (After that you may consider an imperative solution, in which the state of the receiving point can be changed with an assignment, set!).
Finally, define a new class, Rectangle, which aggregates two points to a representation of a rectangle. Define move and area methods in the new class.
As a practical remark to the 'class Point ' and the send primitive, be sure to define send before you define Point . (This is done to redefine an existing send procedure in Racket).
Solution
Here is a solution, where I both define a 'functional move' and an 'imperative move!' on points. At the end - in comment text - I show a sample interaction with points and rectangles.
(define (send message obj . par) (let ((method (obj message))) (apply method par))) (define (point x y) (letrec ((getx (lambda () x)) (gety (lambda () y)) (add (lambda (p) (point (+ x (send 'getx p)) (+ y (send 'gety p))))) (move (lambda (dx dy) (point (+ x dx) (+ y dy)))) (move! (lambda (dx dy) (set! x (+ x dx)) (set! y (+ y dy)))) (type-of (lambda () 'point)) ) (lambda (message) (cond ((eq? message 'getx) getx) ((eq? message 'gety) gety) ((eq? message 'add) add) ((eq? message 'move) move) ((eq? message 'move!) move!) ((eq? message 'type-of) type-of) (else (error "Message not understood")))))) (define (rectangle upper-left-corner-point lower-right-corner-point) (letrec ((move (lambda (dx dy) (rectangle (send 'move upper-left-corner-point dx dy) (send 'move lower-right-corner-point dx dy)))) (area (lambda () (let ((width (- (send 'getx lower-right-corner-point) (send 'getx upper-left-corner-point))) (height (- (send 'gety lower-right-corner-point) (send 'gety upper-left-corner-point)))) (abs (* width height))))) (info (lambda () (list (send 'getx upper-left-corner-point) (send 'gety upper-left-corner-point) (send 'getx lower-right-corner-point) (send 'gety lower-right-corner-point)))) ) (lambda (message) (cond ((eq? message 'move) move) ((eq? message 'area) area) ((eq? message 'info) info) (else (error "Message not understood")))))) ; (define p (point 3 4)) ; ; > (send 'getx p) ; 3 ; ; > (send 'move! p 5 6) ; ; > (send 'getx p) ; 8 ; ; > (send 'gety p) ; 10 ; ; > (define pp (send 'move p 2 3)) ; ; > (send 'getx pp) ; 10 ; ; > (send 'gety pp) ; 13 ; ; > (define r (rectangle (point 0 0) (point 5 10))) ; ; > (send 'info r) ; (0 0 5 10) ; ; > (define rr (send 'move r 2 3)) ; ; > (send 'info rr) ; (2 3 7 13) ; ; > (send 'area r) ; 50 ; ; > (send 'area rr) ; 50
3.2 Color Point Extensions ***
On this page we have seen the class ColorPoint, which inherits from Point. The classes make use of virtual methods.
In this exercise you should start with the code in this file.
Solution
Here is my solution. The solution relies on a non-standard function optional-parameter, which I use a lot in my LAML stuff. The function (and others) can be found here. (You can access the function defintion by clicking on the Scheme source file in the documentation).
(define (new-instance class . parameters) (let ((instance (apply class parameters))) (virtual-operations instance) instance)) (define (send message object . args) (let ((method (method-lookup object message))) (cond ((procedure? method) (apply method args)) ((null? method) (error "Message not understood: " message)) (else (error "Inappropriate result of method lookup: " method))))) ; Arrange for virtual operations in object (define (virtual-operations object) (send 'set-self! object object)) (define (new-part class . parameters) (apply class parameters)) (define (method-lookup object selector) (cond ((procedure? object) (object selector)) (else (error "Inappropriate object in method-lookup: " object)))) (define (optional-parameter n optional-parameter-list . optional-default-value) (let ((optional-default-value-1 (if (null? optional-default-value) #f (car optional-default-value)))) (if (> n (length optional-parameter-list)) optional-default-value-1 (let ((candidate-value (list-ref optional-parameter-list (- n 1)))) (if (eq? candidate-value 'non-passed-value) optional-default-value-1 candidate-value))))) ; The root in the class hierarchy (define (object) (let ((super '()) (self 'nil)) (define (set-self! object-part) (set! self object-part)) (define (dispatch message) (cond ((eqv? message 'set-self!) set-self!) (else (error "Undefined message" message)))) (set! self dispatch) self)) ; The class point (define (point x y) (let ((super (new-part object)) (self 'nil)) (let ((x x) (y y) ) (define (getx) x) (define (gety) y) (define (add p) (let ((class-to-instantiate (send 'class-of self))) (new-instance class-to-instantiate (+ x (send 'getx p)) (+ y (send 'gety p)) ))) (define (type-of) 'point) (define (class-of) point) (define (point-info) (list (send 'getx self) (send 'gety self) (send 'type-of self))) (define (set-self! object-part) (set! self object-part) (send 'set-self! super object-part)) (define (self message) (cond ((eqv? message 'getx) getx) ((eqv? message 'gety) gety) ((eqv? message 'add) add) ((eqv? message 'type-of) type-of) ((eqv? message 'class-of) class-of) ((eqv? message 'point-info) point-info) ((eqv? message 'set-self!) set-self!) (else (method-lookup super message)))) self))) ; The class color-point which inherits from point ; A color point can be initialized with and without a color. ; The color defaults to blue (define (color-point x y . optional-parameter-list) (let ((super (new-part point x y)) (self 'nil)) (let ((color (optional-parameter 1 optional-parameter-list 'blue))) (define (get-color) color) (define (type-of) 'color-point) (define (set-self! object-part) (set! self object-part) (send 'set-self! super object-part)) ; Redefinition from point. This is done to combine the colors of the two points. ; You can delete this method (and its selector in dispatch). Without add here ; the colors will not combine. Try it. (define (add p) (let ((class-to-instantiate (send 'class-of self))) (new-instance class-to-instantiate (+ x (send 'getx p)) (+ y (send 'gety p)) (list color (send 'get-color p)) ))) (define (class-of) color-point) (define (dispatch message) (cond ((eqv? message 'get-color) get-color) ((eqv? message 'type-of) type-of) ((eqv? message 'set-self!) set-self!) ((eqv? message 'class-of) class-of) ((eqv? message 'add) add) (else (method-lookup super message)))) (set! self dispatch)) self)) ; (define cp (new-instance color-point 5 6 'red)) ; (list (send 'getx cp) (send 'gety cp) (send 'get-color cp)) ; (send 'point-info cp) ; (define cp-1 (send 'add cp (new-instance color-point 1 2 'green))) ; (list (send 'getx cp-1) (send 'gety cp-1) (send 'get-color cp-1)) ; (send 'point-info cp-1)
3.3 Representing HTML with objects in Scheme ****
This is an open exercise - maybe the start of a minor project - The exercises relates to LAML. I do not recommend this exercise in this variant of PP.
In the original mirror of HTML in Scheme, the HTML mirror functions, return strings. In the current version, the mirror functions return an internal syntax tree representation of the web documents. With this, it is realistic to validate a document against a grammar while it is constructed. In this exercise we will experiment with an object representation of a web document. We will use the class and object representation which we have introduced in this lecture.
Construct a general class html-element which implement the general properties of a HTML element object. These include:
In addition, construct one or more examples of specific subclasses of html-element , such as html , head , or body. These subclasses should have methods to access particular, required constituents of an element instance, such as the head and the body of a HTML element, and title of a head element. Also, the concrete validation predicate must be redefined for each specific element.
3.4 A discriminant function in continuation passing style **
Program the following discriminant function (lambda (a b c) (- (* b b) (* 4 a c))) in continuation passing style (CPS).
(define (discriminant a b c) (sub (square b) (mult (mult 4 a) c))) ; AUX functions: (define (square a) (mult a a)) (define (mult a b) (* a b)) (define (sub a b) (- a b))
In the program above we have provided auxilliary functions for squaring, multiplication and subtraction. These functions must be provided with an extra continuation parameter when you program the CPS variants of the functions. Consider different evaluation orders, and how it affects the CPS variant of the functions.
Solution
Here is a possible solution:
(define (discriminant a b c k0) (square b (lambda (v1) (mult 4 a (lambda (v2) (mult v2 c (lambda (v3) (sub v1 v3 k0)))))))) (define (square a k1) (mult a a k1)) (define (mult a b k2) (k2 (* a b))) (define (sub a b k3) (k3 (- a b))) (define (plus a b k4) (k4 (+ a b)))
Please notice that this CPS variant of the program dictates a particular evaluation order:
After these steps - in this particular order - pass the final result b*b - 4*a*c to k0
3.5 Trampolining a recursive factorial function without tail calls?! **
On the accompanying slide we have studied so-called trampolining of tail calls. In this exercise we will understand if/why it is necessary to apply trampolining on tail calls.
Use return and bounce in a 'normal, (non-tail)recursive factorial function' fact-rec or a similar function that does not make use of tail calls. What happens if we call the function, and if we attempt to drive or schedule the computation of (fact-rec 5) with pogo-stick?
Explain your findings, and draw your conclusions.
3.6 A variant of seesaw that completes both threads ***
The function seesaw, as discussed on the slide, only completes one of the threads. This may be convenient in some situations (if one of the threads runs infinitly), but in general we are interested in the results of both threads. Here is the version of seesaw that we discuss:
(define (seesaw thread-1 thread-2)
(cond ((eqv? 'done (tag-of thread-1))
(tag-value thread-1))
((eqv? 'doing (tag-of thread-1))
(seesaw thread-2 (call (tag-value thread-1)))))) Program a version of seesaw that - at the very end - return a list of length 2: First element must be the value finally returned by thread-1, and the second element must be the value finally returned by thread-2. Here is an example of the call of the new version of seesaw:
> (seesaw (fact-iter 5 1) (fib 8)) (120 21)
Your variant of seesaw may be seen as an example of a loop which maintains some state (the two threads, their status (doing/done), and their values - if they exist). As such, this exercise is a good example of programming an iterative, tail-recursive, state-transitioning function in Scheme.
Here is all you need to get started:
(define (return x) (tag 'done x))
(define (bounce thunk) (tag 'doing thunk))
(define (call thunk) (thunk))
(define (tag label thing) (cons label thing))
(define tag-of car)
(define tag-value cdr)
(define (fact-iter n acc)
(if (zero? n)
(return acc)
(bounce
(lambda ()
(fact-iter
(- n 1)
(* acc n))))))
(define (mem? n lst)
(cond ((null? lst) (return #f))
((= (car lst ) n) (return #t))
(else (bounce
(lambda ()
(mem? n (cdr lst)))))))
(define (fib n)
(fib-iter n 0 0 1))
(define (fib-iter n i small large)
(if (< i n)
(bounce
(lambda ()
(fib-iter n (+ i 1) large (+ large small))))
(return small)))
(define (pogo-stick thread)
(cond ((eqv? 'done (tag-of thread))
(tag-value thread))
((eqv? 'doing (tag-of thread))
(pogo-stick (call (tag-value thread))))))
; A version of seesaw that delivers 'the value of the fastest thread'.
; The one from the video.
(define (seesaw thread-1 thread-2)
(cond ((eqv? 'done (tag-of thread-1))
(tag-value thread-1))
((eqv? 'doing (tag-of thread-1))
(seesaw thread-2 (call (tag-value thread-1)))))) Solution
Here is my new version of seesaw:
(define (seesaw thread-1 thread-2) (seesaw-1 thread-1 thread-2 'doing 'doing #f #f)) (define (seesaw-1 thread-1 thread-2 thread-1-status thread-2-status val-1 val-2) (cond ((and (eqv? thread-1-status 'done) (eqv? thread-2-status 'done)) (list val-1 val-2)) ((and (eqv? thread-1-status 'done) (eqv? thread-2-status 'doing)) (let* ((next-thread (call (tag-value thread-2))) (new-val-2 (if (eqv? (tag-of next-thread) 'done) (tag-value next-thread) val-2))) (seesaw-1 thread-1 next-thread 'done (tag-of next-thread) val-1 new-val-2))) ((and (eqv? thread-1-status 'doing) (eqv? thread-2-status 'done)) (let* ((next-thread (call (tag-value thread-1))) (new-val-1 (if (eqv? (tag-of next-thread) 'done) (tag-value next-thread) val-1))) (seesaw-1 next-thread thread-2 (tag-of next-thread) 'done new-val-1 val-2))) (else ; both threads have doing stats - advance both of them (let ((next-thread-1 (call (tag-value thread-1))) (next-thread-2 (call (tag-value thread-2)))) (seesaw-1 next-thread-1 next-thread-2 (tag-of next-thread-1) (tag-of next-thread-2) (tag-value next-thread-1) (tag-value next-thread-2) )))))
As an invariant, thread-1-status is the actual status of thread-1, and val-1 is the actual value produced by thread-1 (when ay). val-1 is only defined in the case where thread-status-1 is done. The same holds for thread-2.
There are four cases - all possible combinations of done/doing for thread-1 and thread-2. In the case where both thread-1 and thread-2 are doing, I execute a step in both of them. You may not like this, as this is different from the original version of seesaw.
3.7 Can you read and understand an expression with call/cc? **
Take a look at this expression:
(let ((x 1)
(y 2)
(z 3)
(v 5))
(cons x
(call/cc (lambda (e)
(cons y
(cons z
(if (even? v) v (e (+ v 1)))))))))What is the value of the expression? [Needless to say: Figure it out without just putting it into your Scheme REPL.]
Play with it - and try out possible variations.
The same for:
(let ((x 1)
(y 2)
(z 3)
(v 5))
(+ x
(call/cc
(lambda (e)
(+ y
(+ z
(if (even? v) v (e (+ v 1)))))))))3.8 Capturing a continuation when traversing a list ***
This exercises is strange! Therefore, I discourage you from making it. Most likely, you will be more confused about continuations after having made this exercise than before...
Write a simple recursive function square-list that traverse a list of numbers, with the purpose of squaring each element in the list.
Modify your function such that it captures a continuation of the handling of the third element in the list (if such an element exists). Replace the squared number with this continuation.
Are you able to access the captured contination from the list, and demonstrate how to use it?
Try this:
> (define xxx (square-list (list 1 2 3 4 5 6))) > ((caddr xxx) '())
Explain your results (or lack of results). caddr is a convenient composition of car, cdr and cdr.
Now try to assign the captured continuation (with set!) to a global variable remember-continuation. After you have called square-list, play with your captured and stored continuation:
> (square-list (list 1 2 3 4 5 6)) > remember-continuation > (remember-continuation '()) > (remember-continuation '(10 11 12))
Discuss and explain the results you obtain.
Solution
; Just the square-list functions - plain and simple: (define (square-list lst) (cond ((null? lst) '()) (else (cons (* (car lst) (car lst)) (square-list (cdr lst)))))) ; The square-list function which caputures the desired continuation: (define (square-list lst) (letrec ((square-list-help (lambda (lst c) (cond ((null? lst) '()) (else (call/cc (lambda (e) (cons (if (= c 3) e (* (car lst) (car lst))) (square-list-help (cdr lst) (+ c 1)))))))))) (square-list-help lst 1))) (define xxx (square-list (list 1 2 3 4 5 6))) xxx ; (1 4 #<continuation> 16 25 36) ((caddr xxx) '()) ; This REDEFINES xxx (!!!), which is extremely weird and tricky to deal with xxx ; (1 4) ((caddr xxx) '(1 2 3)) ; Gives an error, because there is no third element in xxx now. ; Third attempt - a variant that assigns the continuation: (define remember-continuation #f) (define (square-list lst) (letrec ((square-list-help (lambda (lst c) (cond ((null? lst) '()) (else (call/cc (lambda (e) (cons (if (= c 3) (begin (set! remember-continuation e) e) (* (car lst) (car lst))) (square-list-help (cdr lst) (+ c 1)))))))))) (square-list-help lst 1))) (square-list (list 1 2 3 4 5 6)) remember-continuation (remember-continuation '()) (remember-continuation '(10 11 12))
Generated: Tuesday August 17, 2021, 12:49:22