Feeds:
Posts
Comments

Archive for the ‘Project SICP’ Category

Exercise 3.9

Let’s start with the recursive factorial:

(define (factorial n)
  (if (= n 1)
      1
      (* n (factorial (- n 1)))))

For simplicity, especially since drawing these pictures in OpenOffice is a bit tedious, let’s trace out the evaluation of (factorial 3) instead of (factorial 6). When the procedure factorial is applied to the argument 3 a new environment E1 is created who’s parent environment is the environment in which factorial was defined (the global environment), and in which the formal parameter n is bound to the value 3. Then the body of factorial is evaluated in this new environment, resulting in another application of factorial with 2 as an argument. This creates a new environment E2 in which the formal parameter n is bound to 2. The environment E3 is created in a similar manner, with n bound to 1. Finally the base case of factorial is reached, the computation unwinds and finishes:

Now let’s examine the iterative version of factorial:

(define (factorial n)
  (fact-iter 1 1 n))

(define (fact-iter product counter max-count)
  (if (> counter max-count)
      product
      (fact-iter (* counter product)
                 (+ counter 1)
                 max-count)))

Again everything starts with the application (factorial 3). The body of factorial is evaluated in an environment E1, where the formal parameter n is bound to 3. This results in the application (fact-iter 1 1 n), which reduces to evaluating the body of the procedure fact-iter in a new environment E2 with the formal parameters product, counter, and max-count bound to 1, 1, and 3 respectively. The process continues with the environments E3, E4, and E5 being created along the way until the computation finally ends:

Read Full Post »

Exercise 3.7

Make-joint can be implemented to return a procedure that takes two arguments – a password password and a message m. It works by checking whether password and new-password match and if they do sends the message to the local account object along with the original password:

(define (make-joint account account-password new-password)
  (lambda (password m)
    (if (eq? password new-password)
        (account account-password m)
        "Incorrect password")))

No changes to make-account are required.




Exercise 3.8

Let f be a procedure with a single local state variable last which stores the value of the argument x that was last passed to f. Initially, if f has not been called, last has the value of 0. When applied, f updates the value of last to that of its argument and returns the old value of last:

(define f
  (let ((last 0))
    (lambda (x) 
      (let ((result last))
        (set! last x)
        result))))

Now let’s consider the evaluation of the expression (+ (f 0) (f 1)). If the arguments are evaluated from left to right the first application (f 0) will evaluate to 0 (the initial value of last), and the second application (f 1) will also evaluate to 0 (the value of the argument in the previous application). Adding up 0 and 0 we get 0. If, however, the arguments are evaluated from right to left the first application would be (f 1) which evaluates to 0 (the initial value of last), and the second application (f 0) would evaluate to 1 – the value of the argument in the previous application. When we add the two together we get 1.

Read Full Post »

Exercise 3.5

Estimate-integral defines an internal test procedure. Its task is to generate random x and y coordinates and check whether they satisfy the predicate P. This procedure is then passed as the experiment argument to the Monte Carlo simulation. The result of the simulation is multiplied by the area of the bounding rectangle within which the random coordinates are generated:

;; Returns a random number in the interval [low, high).
(define (random-in-range low high)
  (let ((range (- high low)))
    (+ low (* range (random)))))

(define (estimate-integral P x1 x2 y1 y2 trails)
  (define (test)
    (P (random-in-range x1 x2)
       (random-in-range y1 y2)))
  (let ((area (* 1.0 (- x2 x1) (- y2 y1))))
    (* area (monte-carlo trails test))))

Having defined estimate-integral we can use it to estimate the area of a unit circle by passing the appropriate predicate, bounding rectangle and number of trials:

(estimate-integral 
 (lambda (x y)
   (<= (+ (square x) (square y)) 1))
 -1.0
 1.0
 -1.0
 1.0
 100000)

=> 3.14292

Note that in PLT Racket random is not defined when the language is set to R5RS. Furthermore, if we change the language to Racket, random does not work with a single argument that is a floating point number. However, if random is called with no arguments, it returns a random number in the range [0, 1). This number can then be multiplied by some other number, say r, to get a random number in the range [0, r). This is the technique random-in-range uses.




Exercise 3.6

The message-passing paradigm is very appropriate for dealing with this particular task. Rand can be defined as a procedure that takes a single argument – a message. If the message is the symbol generate, then the local state of the random-number generator is updated, and the next value in the sequence is returned. If, however, the message is the symbol reset, then a new procedure that resets the internal state variable to a provided value is returned.

(define rand 
  (let ((x random-init))
    (lambda (m)
      (cond ((eq? m 'generate)
             (set! x (random-update x))
             x)
            ((eq? m 'reset)
             (lambda (value)
               (set! x value)))
            (else (error "Unkown request -- RAND" m))))))

Read Full Post »

Exercise 3.1

Definition of make-accumulator:

(define (make-accumulator sum)
  (lambda (amount)
    (set! sum (+ sum amount))
    sum))




Exercise 3.2

The implementation of make-monitored uses the message-passing style of programming:

(define (make-monitored f)
  (let ((times-called 0))
    (lambda (arg)
      (cond ((eq? arg 'how-many-calls?) times-called)
            ((eq? arg 'reset-count) (set! times-called 0))
            (else 
             (set! times-called (+ times-called 1))
             (f arg))))))




Exercise 3.3

In order to modify the make-account procedure, so that it creates password-protected accounts, we can change the definition of the internal dispatch procedure, to first check the provided password. If it is incorrect then the string “Incorrect password” is returned. Otherwise the message is processed and the appropriate procedure, either withdraw or deposit, is returned. The benefit of this approach is that the password check has to be implemented only in a single place:

(define (make-account balance password)
  (define (withdraw amount)
    (if (>= balance amount)
        (begin (set! balance (- balance amount))
               balance)
        "Insufficient funds"))
  (define (deposit amount)
    (set! balance (+ balance amount))
    balance)
  (define (bad-password? pass)
    (not (eq? pass password)))
  (define (dispatch pass m)
    (cond ((bad-password? pass) "Incorrect password")
          ((eq? m 'withdraw) withdraw)
          ((eq? m 'deposit) deposit)
          (else (error "Unknown request -- MAKE-ACCOUNT" m))))
  dispatch)

Note that using this implementation, will cause the second example in the book to return an error rather than the message “Incorrect password”. The expression (acc ‘some-other-password ‘deposit) will evaluate to the string “Incorrect password” which will then be applied to 50. However the fact that the incorrect password is detected and signaled at the earliest possible moment makes much more sense than returning some procedure that, when called, will complain about the incorrectness of the previously provided password.




Exercise 3.4

The “centralized” password validation implemented in the previous exercise makes the new modification much easier. All code changes are limited to the bad-password? predicate and to introducing a new local variable – incorrect-guesses.

(define (make-account balance password)
  (let ((incorrect-guesses 0))
    (define (withdraw amount)
      (if (>= balance amount)
          (begin (set! balance (- balance amount))
                 balance)
          "Insufficient funds"))
    (define (deposit amount)
      (set! balance (+ balance amount))
      balance)
    (define (bad-password? pass)
      (cond ((eq? pass password) 
             (set! incorrect-guesses 0)
             #f)
            (else 
             (set! incorrect-guesses (+ incorrect-guesses 1))
             (if (> incorrect-guesses 7) (call-the-cops))
             #t)))
    (define (dispatch pass m)
      (cond ((bad-password? pass) "Incorrect password")
            ((eq? m 'withdraw) withdraw)
            ((eq? m 'deposit) deposit)
            (else (error "Unknown request -- MAKE-ACCOUNT" m))))
    dispatch))

Read Full Post »

Exercise 2.87

A polynomial is zero if all the coefficients of all its terms are zeroes. To implement this logic we can add the following code to the polynomial package:

(define (zero-terms? L)
    (if (empty-termlist? L)
        #t
        (and (=zero? (coeff (first-term L)))
             (zero-terms? (rest-terms L)))))

(define (zero-poly? p)
    (zero-terms? (term-list p)))

(put '=zero? '(polynomial) zero-poly?)




Exercise 2.88

To implement the subtraction operation for polynomials we will follow the given hint and reduce the operation to addition. In order to achieve this we have to define a generic negate operation and provide implementations of it for all the types in the arithmetic system. For all types, except polynomials, negate can be defined as multiplication by -1:

;;generic negate operation
(define (negate x) (apply-generic 'negate x))

;;add to the scheme number package
(put 'negate '(scheme-number) 
     (lambda (x) (tag (* -1 x))))

;;add to the rational number package
(put 'negate '(rational) 
     (lambda (x) (tag (mul-rat (make-rat -1 1) x))))

;;add to the complex number package
(put 'negate '(complex) 
     (lambda (x) (tag (mul-complex (make-from-real-imag -1.0 0.0) x))))

To negate a polynomial, however, we have to negate all the coefficients of its terms:

;;code to be added to the polynomial package
(define (negate-terms L)
    (if (empty-termlist? L)
        (the-empty-termlist)
        (let ((t (first-term L)))
          (adjoin-term (make-term (order t) (negate (coeff t)))
                       (negate-terms (rest-terms L))))))

(define (negate-poly p)
    (make-poly (variable p)
               (negate-terms (term-list p))))

(put 'negate '(polynomial) (lambda (p) (tag (negate-poly p))))

Finally, we can reduce subtraction to addition with the negative of the subtrahend as addend:

;;code to be added to the polynomial package
(define (sub-poly p1 p2)
    (add-poly p1 (negate-poly p2)))

(put 'sub '(polynomial polynomial)
     (lambda (p1 p2) (tag (sub-poly p1 p2))))




Exercise 2.89

The following procedures implement the term-list representation as appropriate for dense polynomials and can replace the previous representation in polynomial package:

;;Term lists for dense polynomials
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(define (the-empty-termlist) '())
(define (first-term term-list) 
  (make-term (- (length term-list) 1)
             (car term-list)))
(define (rest-terms term-list) (cdr term-list))
(define (empty-termlist? term-list) (null? term-list))
(define (adjoin-term term term-list)
  (let ((term-order (order term))
        (list-length (length term-list)))
    (cond ((= term-order list-length) 
           (cons (coeff term) term-list))
          ((> term-order list-length) 
           (cons (coeff term)
                 (adjoin-term (make-term (- term-order 1) 0) term-list)))
          (else (error "Term order to small to be adjoined" (list term term-list))))))

The most interesting parts are the first-term and adjoin-term procedures.

Since the dense representation is a list of coefficients, first-term has to construct a new term from the coefficient found at the car of its term-list argument and compute its order by taking the length of term-list and subtracting 1.

Adjoin-list works by assuming that the order of its first argument – term (the term being adjoined) is greater than the order of its second argument – term-list. If this condition is not met an error is signaled. Otherwise the resulting term list is the coefficient of the term, followed by some number of zeroes, followed by the term-list we are adjoining to. This is done recursively. The base case is the situation where term “fits” directly in front of the term-list – no extra zeroes are required. In the recursive case we cons the coefficient of term with the result of adjoining a new term with a coefficient of zero and an order of one less than that of the current term with term-list.




Exercise 2.90

To make the system support both sparse and dense polynomial representations I have decided to split the polynomial package in two separate packages – one for sparse polynomials and one for dense polynomials, each of them containing a different representation of term-lists:

;;;Sparse polynomial package
(define (install-sparse-polynomial-package)
  ;;internal procedures
  (define (make-poly variable term-list) 
    (cons variable term-list))
  (define (variable p) (car p))
  (define (term-list p) (cdr p))
  (define (same-variable? v1 v2)
    (and (symbol? v1) (symbol? v2) (eq? v1 v2)))
  
  ;;Term lists for sparse polynomials
  (define (make-term order coeff) (list order coeff))
  (define (order term) (car term))
  (define (coeff term) (cadr term))
  (define (the-empty-termlist) '())
  (define (first-term term-list) (car term-list))
  (define (rest-terms term-list) (cdr term-list))
  (define (empty-termlist? term-list) (null? term-list))
  (define (adjoin-term term term-list)
    (if (=zero? (coeff term))
        term-list
        (cons term term-list)))
  (define (zero-terms? L)
    (if (empty-termlist? L)
        #t
        (and (=zero? (coeff (first-term L)))
             (zero-terms? (rest-terms L)))))
  (define (negate-terms L)
    (if (empty-termlist? L)
        (the-empty-termlist)
        (let ((t (first-term L)))
          (adjoin-term (make-term (order t) (negate (coeff t)))
                       (negate-terms (rest-terms L))))))
  
  (define (add-terms L1 L2)
    (cond ((empty-termlist? L1) L2)
          ((empty-termlist? L2) L1)
          (else 
           (let ((t1 (first-term L1))
                 (t2 (first-term L2)))
             (cond ((> (order t1) (order t2))
                    (adjoin-term t1 (add-terms (rest-terms L1) L2)))
                   ((< (order t1) (order t2))
                    (adjoin-term t2 (add-terms L1 (rest-terms L2))))
                   (else 
                    (adjoin-term 
                     (make-term (order t1)
                                (add (coeff t1) (coeff t2)))
                     (add-terms (rest-terms L1) (rest-terms L2)))))))))
  
  (define (mul-terms L1 L2)
    (if (empty-termlist? L1)
        (the-empty-termlist)
        (add-terms (mul-term-by-all-terms (first-term L1) L2)
                   (mul-terms (rest-terms L1) L2))))
  
  (define (mul-term-by-all-terms t1 L)
    (if (empty-termlist? L) 
        (the-empty-termlist)
        (let ((t2 (first-term L)))
          (adjoin-term 
           (make-term (+ (order t1) (order t2))
                      (mul (coeff t1) (coeff t2)))
           (mul-term-by-all-terms t1 (rest-terms L))))))
  
  (define (add-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
        (make-poly (variable p1)
                   (add-terms (term-list p1)
                              (term-list p2)))
        (error "Polys not in same variable -- ADD-POLY" (list p1 p2))))
  
  (define (mul-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
        (make-poly (variable p1)
                   (mul-terms (term-list p1)
                              (term-list p2)))
        (error "Polys not in same variable -- MUL-POLY" (list p1 p2))))
  
  (define (sub-poly p1 p2)
    (add-poly p1 (negate-poly p2)))
  
  (define (zero-poly? p)
    (zero-terms? (term-list p)))
  
  (define (negate-poly p)
    (make-poly (variable p)
               (negate-terms (term-list p))))
  
  ;;interface to rest of system
  (define (tag x) 
    (attach-tag 'sparse-polynomial x))
  (put 'add '(sparse-polynomial sparse-polynomial) 
       (lambda (p1 p2) (tag (add-poly p1 p2))))
  (put 'sub '(sparse-polynomial sparse-polynomial)
       (lambda (p1 p2) (tag (sub-poly p1 p2))))
  (put 'mul '(sparse-polynomial sparse-polynomial)
       (lambda (p1 p2) (tag (mul-poly p1 p2))))
  (put '=zero? '(sparse-polynomial) zero-poly?)
  (put 'negate '(sparse-polynomial) (lambda (p) (tag (negate-poly p))))
  (put 'make 'sparse-polynomial
       (lambda (var terms) (tag (make-poly var terms))))
  
  'done)

(define (make-sparse-polynomial var terms)
  ((get 'make 'sparse-polynomial) var terms))


;;;Dense polynomial package
(define (install-dense-polynomial-package)
  ;;internal procedures
  (define (make-poly variable term-list) 
    (cons variable term-list))
  (define (variable p) (car p))
  (define (term-list p) (cdr p))
  (define (same-variable? v1 v2)
    (and (symbol? v1) (symbol? v2) (eq? v1 v2)))
  
  ;;Term lists for dense polynomials
  (define (make-term order coeff) (list order coeff))
  (define (order term) (car term))
  (define (coeff term) (cadr term))
  (define (the-empty-termlist) '())
  (define (first-term term-list) 
    (make-term (- (length term-list) 1)
               (car term-list)))
  (define (rest-terms term-list) (cdr term-list))
  (define (empty-termlist? term-list) (null? term-list))
  (define (adjoin-term term term-list)
    (let ((term-order (order term))
          (list-length (length term-list)))
      (cond ((= term-order list-length) 
             (cons (coeff term) term-list))
            ((> term-order list-length) 
             (cons (coeff term)
                   (adjoin-term (make-term (- term-order 1) 0) term-list)))
            (else (error "Term order to small to be adjoined" (list term term-list))))))
  
  
  (define (zero-terms? L)
    (if (empty-termlist? L)
        #t
        (and (=zero? (coeff (first-term L)))
             (zero-terms? (rest-terms L)))))
  (define (negate-terms L)
    (if (empty-termlist? L)
        (the-empty-termlist)
        (let ((t (first-term L)))
          (adjoin-term (make-term (order t) (negate (coeff t)))
                       (negate-terms (rest-terms L))))))
  
  (define (add-terms L1 L2)
    (cond ((empty-termlist? L1) L2)
          ((empty-termlist? L2) L1)
          (else 
           (let ((t1 (first-term L1))
                 (t2 (first-term L2)))
             (cond ((> (order t1) (order t2))
                    (adjoin-term t1 (add-terms (rest-terms L1) L2)))
                   ((< (order t1) (order t2))
                    (adjoin-term t2 (add-terms L1 (rest-terms L2))))
                   (else 
                    (adjoin-term 
                     (make-term (order t1)
                                (add (coeff t1) (coeff t2)))
                     (add-terms (rest-terms L1) (rest-terms L2)))))))))
  
  (define (mul-terms L1 L2)
    (if (empty-termlist? L1)
        (the-empty-termlist)
        (add-terms (mul-term-by-all-terms (first-term L1) L2)
                   (mul-terms (rest-terms L1) L2))))
  
  (define (mul-term-by-all-terms t1 L)
    (if (empty-termlist? L) 
        (the-empty-termlist)
        (let ((t2 (first-term L)))
          (adjoin-term 
           (make-term (+ (order t1) (order t2))
                      (mul (coeff t1) (coeff t2)))
           (mul-term-by-all-terms t1 (rest-terms L))))))
  
  (define (add-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
        (make-poly (variable p1)
                   (add-terms (term-list p1)
                              (term-list p2)))
        (error "Polys not in same variable -- ADD-POLY" (list p1 p2))))
  
  (define (mul-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
        (make-poly (variable p1)
                   (mul-terms (term-list p1)
                              (term-list p2)))
        (error "Polys not in same variable -- MUL-POLY" (list p1 p2))))
  
  (define (sub-poly p1 p2)
    (add-poly p1 (negate-poly p2)))
  
  (define (zero-poly? p)
    (zero-terms? (term-list p)))
  
  (define (negate-poly p)
    (make-poly (variable p)
               (negate-terms (term-list p))))
  
  ;;interface to rest of system
  (define (tag x) 
    (attach-tag 'dense-polynomial x))
  (put 'add '(dense-polynomial dense-polynomial) 
       (lambda (p1 p2) (tag (add-poly p1 p2))))
  (put 'sub '(dense-polynomial dense-polynomial)
       (lambda (p1 p2) (tag (sub-poly p1 p2))))
  (put 'mul '(dense-polynomial dense-polynomial)
       (lambda (p1 p2) (tag (mul-poly p1 p2))))
  (put '=zero? '(dense-polynomial) zero-poly?)
  (put 'negate '(dense-polynomial) (lambda (p) (tag (negate-poly p))))
  (put 'make 'dense-polynomial
       (lambda (var terms) (tag (make-poly var terms))))
  
  'done)

(define (make-dense-polynomial var terms)
  ((get 'make 'dense-polynomial) var terms))




Exercise 2.91

The completed implementation of div-terms follows:

(define (div-terms L1 L2)
  (if (empty-termlist? L1)
      (list (the-empty-termlist) (the-empty-termlist))
      (let ((t1 (first-term L1))
            (t2 (first-term L2)))
        (if (> (order t2) (order t1))
            (list (the-empty-termlist) L1)
            (let ((new-c (div (coeff t1) (coeff t2)))
                  (new-o (- (order t1) (order t2))))
              (let ((rest-of-result 
                     (div-terms 
                      (sub-terms
                       L1
                       (mul-term-by-all-terms 
                        (make-term new-o new-c)
                        L2))
                      L2)))
                (list (adjoin-term 
                       (make-term new-o new-c)
                       (car rest-of-result))
                      (cadr rest-of-result))))))))

(define (sub-terms L1 L2)
  (add-terms L1 (negate-terms L2)))

Note that we had to define sub-terms as a helper procedure so that we could subtract two term lists. To do so we rely on the negate-terms procedure that was defined earlier (see Exercise 2.88).

Having this dividing two polynomials becomes straight forward:

(define (div-poly p1 p2)
  (if (same-variable? (variable p1) (variable p2))
      (let ((result (div-terms (term-list p1) (term-list p2))))
        (list (make-poly (variable p1)
                         (car result))
              (make-poly (variable p1)
                         (cadr result))))
      (error "Polys not in same variable -- DIV-POLY" (list p1 p2))))




Exercise 2.92

Skipped.




Exercise 2.93

After modifying the rational-number package to use generic operations and changing the constructor so that no reduction of fractions takes place, we can create rational functions and apply generic arithmetic on them:

(define p1 (make-polynomial 'x '((2 1) (0 1))))
(define p2 (make-polynomial 'x '((3 1) (0 1))))
(define rf (make-rational p2 p1))

(add rf rf)
=> (rational (polynomial x (5 2) (3 2) (2 2) (0 2)) polynomial x (4 1) (2 2) (0 1))

As can be expected the result is not reduced to lowest terms.




Exercise 2.94

Definitions of remainder-terms, gcd-terms, and gcd-poly which can be added to the polynomial package:

(define (remainder-terms a b)
  (cadr (div-terms a b)))
  
(define (gcd-terms a b)
  (if (empty-termlist? b)
      a
      (gcd-terms b (remainder-terms a b))))

(define (gcd-poly a b)
  (if (same-variable? (variable a) (variable b))
      (make-poly (variable a)
                 (gcd-terms (term-list a) 
                            (term-list b)))
      (error "Polys not in same variable -- GCD-POLY" (list a b))))

Code for installing in the system greatest-common-divisor as a generic operation and registering concrete implementations for ordinary numbers and polynomials:

;;Generic operation - greatest-common-divisor
(define (greatest-common-divisor x y) (apply-generic 'greatest-common-divisor x y))

;;Should be added to the polynomial package
(put 'greatest-common-divisor '(polynomial polynomial) 
     (lambda (p1 p2) (tag (gcd-poly p1 p2))))

;;Should be added to the scheme-number package
(put 'greatest-common-divisor '(scheme-number scheme-number)
     (lambda (x y) (tag (gcd x y))))

When testing greatest-common-divisor we get:

(p1 (make-polynomial 'x '((4 1) (3 -1) (2 -2) (1 2))))
(p2 (make-polynomial 'x '((3 1) (1 -1)))))
(greatest-common-divisor p1 p2)
=> (polynomial x (2 -1) (1 1))




Exercise 2.95

Let’s try the example:

(define p1 (make-polynomial 'x '((2 1) (1 -2) (0 1))))
(define p2 (make-polynomial 'x '((2 11) (0 7))))
(define p3 (make-polynomial 'x '((1 13) (0 5))))
(define q1 (mul p1 p2))
(define q2 (mul p1 p3))

(greatest-common-divisor q1 q2)
=> (polynomial x (2 1458/169) (1 -2916/169) (0 1458/169))

Greatest-common-divisor definitely does not return p1, but it does return a polynomial (of the same order as p1) that divides both q1 and q2. So why does it not return p1? Apparently because it has found some other polynomial that it deems “greater” than p1, and that is a divisor of q1 and q2.




Exercise 2.96

When defining pseudoremainder-terms it is convenient to have a helper procedure that computes the integerizing factor when given two term lists:

(define (integerizing-factor a b)
    (if (or (empty-termlist? a) (empty-termlist? b))
        0
        (let ((t1 (first-term a))
              (t2 (first-term b)))
          (expt (coeff t2)
                (+ (order t1)
                   (- (order t2))
                   1)))))
  
  (define (pseudoremainder-terms a b)
    (remainder-terms 
     (mul-term-by-all-terms 
      (make-term 0 (integerizing-factor a b))
      a)
     b))

After modifying the gcd-terms procedure we can test again the example from the previous exercise and confirm that we do not get fractions:

(define (gcd-terms a b)
  (if (empty-termlist? b)
      a
      (gcd-terms b (pseudoremainder-terms a b))))
  
(greatest-common-divisor q1 q2)
=> (polynomial x (2 1458) (1 -2916) (0 1458))

The rest of the exercise requires gcd-terms to remove the common factors from the coefficients of its result. To simplify the implementation we can define another helper procedure reduce-termlist:

(define (reduce-termlist term-list)
  (mul-term-by-all-terms (make-term 0
                                    (div 1 (apply gcd (map coeff term-list))))
                         term-list))
  
(define (gcd-terms a b)
  (if (empty-termlist? b)
      (reduce-termlist a)
      (gcd-terms b (pseudoremainder-terms a b))))




Exercise 2.97

Definitions of reduce-terms and reduce-poly. To simplify the implementation two helper procedures – mul-terms-by-scalar and quotient-terms are introduced:

(define (mul-terms-by-scalar s term-list)
  (mul-term-by-all-terms (make-term 0 s)
                         term-list))
  
(define (quotient-terms a b)
  (car (div-terms a b)))
  
(define (reduce-terms n d)
  (let* ((g (gcd-terms n d))
         (factor
          (integerizing-factor 
           (if (> (order (first-term n))
                  (order (first-term d)))
               n
               d)
           g))
         (n1 (mul-terms-by-scalar factor n))
         (d1 (mul-terms-by-scalar factor d))
         (n2 (quotient-terms n1 g))
         (d2 (quotient-terms d1 g))
         (coeff-gcd (gcd (apply gcd (map coeff n2))
                         (apply gcd (map coeff d2)))))
    (list (mul-terms-by-scalar (div 1 coeff-gcd) n2)
          (mul-terms-by-scalar (div 1 coeff-gcd) d2))))

(define (reduce-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
        (let ((result (reduce-terms (term-list p1) (term-list p2))))
          (list (make-poly (variable p1) (car result))
                (make-poly (variable p2) (cadr result))))
        (error "Polys not in same variable -- REDUCE-POLY" (list p1 p2))))

Code that defines the generic reduce operation, provides implementations of it for polynomials and scheme-numbers and reimplements the make-rat constructor:

;;Generic operation - reduce
(define (reduce x y) (apply-generic 'reduce x y))

;;Should be added to the scheme-number package
(put 'reduce '(scheme-number scheme-number)
     (lambda (x y) 
       (let ((result (reduce-integers x y)))
         (list (tag (car result)) (tag (cadr result))))))

;;Should be added to the polynomial package
(put 'reduce '(polynomial polynomial)
       (lambda (p1 p2)
         (let ((result (reduce-poly p1 p2)))
           (list (tag (car result)) (tag (cadr result))))))

;;Should be added to the rational package in place of the old constructor
(define (make-rat n d)
    (let ((result (reduce n d)))
      (cons (car result) (cadr result))))

Now if we test the code with the rational functions given at the beginning of the extended exercise we get:

(p1 (make-polynomial 'x '((1 1) (0 1))))
(p2 (make-polynomial 'x '((3 1) (0 -1))))
(p3 (make-polynomial 'x '((1 1))))
(p4 (make-polynomial 'x '((2 1) (0 -1))))
(rf1 (make-rational p1 p2))
(rf2 (make-rational p3 p4))

(add rf1 rf2)
=> (rational (polynomial x (3 -1) (2 -2) (1 -3) (0 -1)) polynomial x (4 -1) (3 -1) (1 1) (0 1))

Note that the result is almost correct, the only difference is that the numerator and denominator are both multiplied by -1, but otherwise the rational function is simplified as expected.

Read Full Post »

Exercise 2.81

If apply-generic is called with two arguments of type scheme-number or of type complex, and no operation is found for these types, than the coercion mechanism comes into play. As a result the type of one of the arguments gets coerced to itself and apply-generic is invoked with exactly the same pair of arguments. The result is an infinite recursive loop.

If, by convention, Mr. Reasoner never installs any coercion procedures from a type to itself than apply-generic will always terminate in a finite number of steps. However, if at some later point apply- generic becomes more elaborate, it might be useful for there to be “identity” coercions.

Here is a modified version of apply-generic that does not try to coerce arguments of the same type:

(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
          (apply proc (map contents args))
          (if (= (length args) 2)
              (let ((type1 (car type-tags))
                    (type2 (cadr type-tags))
                    (a1 (car args))
                    (a2 (cadr args)))
                (if (eq? type1 type2)
                    (error "No method for these types" (list op type-tags)))
                    (let ((t1->t2 (get-coercion type1 type2))
                          (t2->t1 (get-coercion type2 type1)))
                      (cond (t1->t2 (apply-generic op (t1->t2 a1) a2))
                            (t2->t1 (apply-generic op a1 (t2->t1 a2)))
                            (else (error "No method for these types" 
                                         (list op type-tags)))))
                (error "No method for these types" (list op type-tags))))))))




Exercise 2.82

This new version of apply-generic is capable of applying coercion not only in two argument cases but for any number of arguments. It consecutively scans the arguments and for each one attempts to coerce all other arguments to its type until an acceptable coercion is found or no more coercions are possible. Special precautions are taken to avoid infinite recursive loops as seen in the previous exercise:

(define (apply-generic op . args)
  (define (coercion-good? coerced-args)
    (let ((type-tags (map type-tag args))
          (coerced-type-tags (map type-tag coerced-args)))
      (and (not (equal? type-tags coerced-type-tags))
           (get op coerced-type-tags))))
  (define (coerce-argument to-type arg)
    (if (eq? to-type (type-tag arg))
        arg
        (let ((coerce-proc (get-coercion (type-tag arg) to-type)))
          (if coerce-proc 
              (coerce-proc arg)
              'failed))))
  (define (coerce-arguments to-type args)
    (if (null? args)
        '()
        (let ((coerced-arg (coerce-argument to-type (car args)))
              (coerced-args (coerce-arguments to-type (cdr args)))) 
          (if (or (eq? coerced-arg 'failed) (eq? coerced-args 'failed))
              'failed
              (cons coerced-arg coerced-args)))))
  (define (search rest)
    (if (null? rest) 
        #f
        (let ((coerced-args (coerce-arguments (type-tag (car rest)) args)))
          (if (and (not (eq? coerced-args 'failed))
                   (coercion-good? coerced-args))
              coerced-args
              (search (cdr rest))))))
  
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc 
          (apply proc (map contents args))
          (let ((coerced-args (search args)))
            (if coerced-args 
                (apply apply-generic (cons op coerced-args))
                (error "No method for these types" (list op type-tags))))))))

To understand why this coercion strategy is still not general enough consider a situation where we try to apply some operation to two arguments of types a and b. Let the operation be defined only for arguments of type c. Since c is not among the initial argument types, no attempt will be made to coerce a to c and b to c.




Exercise 2.83

For types integer, rational, and real we register a raise operation in the operation table and define a generic raise that delegates its job to apply-generic:

(define (raise-integer x)
  (make-rational x 1))

(define (raise-rational x)
  (make-real (/ (* 1.0 (numer x)) (* 1.0 (denom x)))))

(define (raise-real x)
  (make-from-real-imag x 0))

(put 'raise '(integer) raise-integer)
(put 'raise '(rational) raise-rational)
(put 'raise '(real) raise-real)

(define (raise x) (apply-generic 'raise x))




Exercise 2.84

A new unary generic operation height is defined such that for any two types a and b (height a) is greater than (height b) if a is located above b in the tower of types. This allows apply-generic to check the height of its arguments and if necessary raise the lower one or both of them (if their heights are the same) until a matching operation is found or raising is no longer possible:

(put 'height '(integer)  (lambda (x) 0))
(put 'height '(rational) (lambda (x) 1))
(put 'height '(real)     (lambda (x) 2))
(put 'height '(complex)  (lambda (x) 3))

(define (height x) (apply-generic 'height x))

(define (apply-generic op . args)
  (let* ((type-tags (map type-tag args))
         (proc (get op type-tags)))
    (if proc
        (apply proc (map contents args))
        (if (= (length args) 2)
            (let* ((a1 (car args))
                   (a2 (cadr args))
                   (h1 (height a1))
                   (h2 (height a2)))
              (cond ((< h1 h2) (apply-generic (raise a1) a2))
                    ((> h1 h2) (apply-generic a1 (raise a2)))
                    (else (apply-generic (raise a1) (raise a2)))))
            (error "No method for these types -- APPLY-GENERIC" (op type-tags))))))




Exercise 2.85

There is some ambiguity in this exercise. On the one hand the authors suggest using the type tower from exercise 2.83 (integer -> rational -> real -> complex), and on the other, they talk about projecting reals directly onto integers, entirely forgetting about rational numbers.

I have decided not to skip rational numbers. To implement the projecting from reals to rationals I am using the rationalize and inexact->exact procedures provided by the Scheme system:

(define (project-complex x)
  (make-real (real-part x)))

(define (project-real x)
  (let ((scheme-rat (rationalize (inexact->exact x) 0.00001)))
    (make-rational (numerator x) (denominator x))))

(define (project-rational x)
  (make-integer (numer x)))

(put 'project '(complex) project-complex)
(put 'project '(real) project-real)
(put 'project '(rational) project-rational)

(define (project x) (apply-generic 'project x))

And here is the definition of the drop procedure:

(define (drop x)
  (if (and (get 'project (list (type-tag x)))
           (equ? (raise (project x)) x))
      (drop (project x))
      x))

The final part of the exercise is also a bit fishy. If apply-generic would actually apply drop to its result, then imagine what would happen if we execute the generic raise operation. The argument would first be raised and then immediately dropped down again. This would even cause an infinite recursive loop when apply-generic tries to coerce its arguments.

Probably the best that can be done is to leave apply-generic alone and instead choose whether to use drop when defining new generic operations. For example add, sub, mul, and div could have been defined as:

(define (add x y) (drop (apply-generic 'add x y)))
(define (sub x y) (drop (apply-generic 'sub x y)))
(define (mul x y) (drop (apply-generic 'mul x y)))
(define (div x y) (drop (apply-generic 'div x y)))




Exercise 2.86

To introduce the required changes to the system we need to redefine the internal procedures in the complex packages to use the generic add, sub, mul, and div operations instead of their built-in equivalents +, , *, and /. Furthermore, we have to define new generic operations for sine, cosine, arctan, square-root, and square:

(define (sine x)        (apply-generic 'sine x))
(define (cosine x)      (apply-generic 'cosine x))
(define (arctan x y)    (apply-generic 'arctan x y))
(define (square-root x) (apply-generic 'square-root x))
(define (square x)      (apply-generic 'square x))

Next we have to add implementations for these new operations in the Scheme-number and rational-number packages:

;;internal to the scheme number package
(put 'sine        '(scheme-number)      (lambda (x) (tag (sin x))))
(put 'cosine      '(scheme-number)      (lambda (x) (tag (cos x))))
(put 'arctan      '(scheme-number scheme-number) (lambda (x y) (tag (atan x y))))
(put 'square-root '(scheme-number)      (lambda (x) (tag (sqrt x))))
(put 'square      '(scheme-number)      (lambda (x) (tag (* x x))))

;;internal to the rational number package
(define (to-scheme-number x)
    (make-scheme-number (/ (* 1.0 (numer x) (denom x)))))

(put 'sine        '(rational) (lambda (x) (sine (to-scheme-number x))))
(put 'cosine      '(rational) (lambda (x) (cosine (to-scheme-number x))))
(put 'arctan      '(rational rational) 
     (lambda (x y) (arctan (to-scheme-number x) (to-scheme-number y))))
(put 'square-root '(rational) (lambda (x) (square-root (to-scheme-number x))))
(put 'square      '(rational) (lambda (x) (square (to-scheme-number x))))

Finally, we have to modify the polar and rectangular packages to use the new generic operations instead of their built-in counterparts.

Read Full Post »

Exercise 2.77

In order to trace through the procedures called in evaluating the expression (magnitude z) we can use the substitution model:

(magnitude '(complex rectangular 3 4))                =>
(apply-generic 'magnitude '(complex rectangular 3 4)) =>
(apply magnitude '(rectangular 3 4))                  =>
(apply-generic 'magnitude '(rectangular 3 4))         =>
(apply magnitude '(3 4))                              =>
5

Apply-generic is invoked twice – once for each of the tags complex and rectangular.

The first time apply-generic is invoked it strips off the tag complex of its argument and passes the rest of the argument to the generic magnitude procedure.

Generic magnitude invokes apply-generic again. This time the tag rectangular is stripped from the argument and the rest of it is passed to the internal magnitude procedure defined in the rectangular package. At this stage the desired computation is finally carried out without further calls to apply-generic.




Exercise 2.78

Modified definitions of attach-tag, type-tag, and contents:

(define (attach-tag type-tag contents)
  (if (eq? type-tag 'scheme-number)
      contents
      (cons type-tag contents)))

(define (type-tag datum)
  (cond ((number? datum) 'scheme-number)
        ((pair? datum) (car datum))
        (else (error "Bad tagged datum --TYPE-TAG" datum))))

(define (contents datum)
  (cond ((number? datum) datum)
        ((pair? datum) (cdr datum))
        (else (error "Bad tagged datum --TYPE-TAG" datum))))




Exercise 2.79

Definition of a generic equ? predicate:

(define (equ? x y) (apply-generic 'equ? x y))

Code we need to add to the scheme-number package:

(put 'equ? '(scheme-number scheme-number)
       (lambda (x y) (= x y)))

Code we need to add to the rational package:

(define (equ? x y)
    (= (* (numer x) 
          (denom y))
       (* (numer y)
          (denom x))))

(put 'equ? '(rational rational) equ?)

Code we need to add to the complex package:

(define (equ? z1 z2)
    (and (= (real z1)
            (real z2))
         (= (imag z1)
            (imag z2))))

(put 'equ? '(complex complex) equ?)

After these modifications the new operation equ? should work for ordinary numbers, rational numbers, and complex numbers.




Exercise 2.80

Definition of a generic =zero? predicate:

(define (=zero? x) (apply-generic '=zero? x))

Code we need to add to the scheme-number package:

(put '=zero? '(scheme-number) (lambda (x) (= x 0)))

Code we need to add to the rational package:

(define (=zero? x)
    (= (numer x) 0))

(put '=zero? '(rational) =zero?)

Code we need to add to the complex package:

(define (=zero? z)
    (< (mag z) 0.0000001))

(put '=zero? '(complex) =zero?)

Read Full Post »

Older Posts »