Feeds:
Posts
Comments

Archive for the ‘Chapter 2’ Category

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 »

Exercise 2.73

The old version of deriv uses an explicit dispatch on type. The new version tends to use the more sound data-directed style of dispatching on type.

We must realize though, that our deriv procedure actually dispatches on two completely different kinds of “types”.

One of these types is determined by the algebraic operator symbol at the front of the expression – if such exists. The new version of the deriv procedure applies the data-directed style of dispatching on type only with respect to this particular kind of type.

The other kind of type we are dispatching on is determined by the predicates number? and variable? (implemented in terms of the primitive predicate symbol?). This kind of primitive type is built into the Scheme system. This prevents us from naturally assimilating these predicates in our table.

The new definition of deriv allows us to add differentiation rules without changing any existing code.

For example we can add rules for differentiation of sums and products:

(define (install-deriv-package)
  ;;internal procedures
  (define (make-sum a1 a2) (list '+ a1 a2))
  (define (addend s) (car s))
  (define (augend s) (cadr s))
  (define (deriv-sum exp var)
    (make-sum (deriv (addend exp) var)
              (deriv (augend exp) var)))
  
  (define (make-product m1 m2) (list '* m1 m2))
  (define (multiplier p) (car p))
  (define (multiplicand p) (cadr p))
  (define (deriv-product exp var)
    (make-sum (make-product (multiplier exp)
                            (deriv (multiplicand exp) var))
              (make-product (deriv (multiplier exp) var) 
                            (multiplicand exp))))
  
  ;;interface to rest of system
  (put 'deriv '+ deriv-sum)
  (put 'deriv '* deriv-product)
  'done)

And to add a rule for differentiation of exponents we insert the appropriate code in the install-deriv-package (note that the code for sums and products has been omitted for clarity):

(define (install-deriv-package)
  ;;internal procedures
  
  (define (make-exponential base exponent)
    (list '** base exponent))
  (define (base e) (car e))
  (define (exponent e) (cadr e))
  (define (deriv-exponential exp var)
    (make-product (exponent exp)
                  (make-product 
                   (make-exponential (base exp) (- (exponent exp) 1))
                   (deriv (base exp) var)))) 
  
  ;;interface to rest of system
  (put 'deriv '** deriv-exponential)
  'done)

The proposed new change at the end of the exercise can not be incorporated in the existing system additively. One way to introduce it would be to adopt a convention that the first argument to both get and put is the type of the expression, determined by the algebraic operator, and the second argument is the name of the procedure – deriv in our case. This would imply going over the existing code and changing get and put to meet the requirements of the new convention.




Exercise 2.74

Let’s have each division implement its own package. Each package should contain the necessary procedures to access and search the records specific to the division. Packages should also be responsible for installing these procedures into a global registry/table keyed under operation and division names. For example let’s consider a company with two divisions – division-1 and division-2:

(define (install-division-1-package)
  (let ((file '((Joe ((address town) (salary 123)))
                (Pooh ((address forest) (salary -1))))))
    ;;internal procedures
    (define (get-name record)
      (car record))
    (define (get-salary record)
      (cadr (assoc 'salary (cadr record))))
    (define (get-record employee-name)
      (define (search records)
        (cond ((null? records) #f)
              ((eq? employee-name (get-name (car records))) (car records))
              (else (search (cdr records)))))
      (search file))
    (define (tag x) (attach-tag 'division-1 x))
    ;;interface to rest of system
    (put 'get-record 'division-1
         (lambda (employee-name) 
           (let ((record (get-record employee-name)))
             (if record
                 (tag record)
                 '()))))
    (put 'get-salary 'division-1 get-salary)
    'done))

(define (install-division-2-package)
  (let ((file '((Bill ((salary 1000000) (address bigtown) (age 101)))
                (Boss ((salary 9876543) (address bigtown) (age 42))))))
    ;;internal procedures
    (define (get-name record)
      (car record))
    (define (get-salary record)
      (cadr (assoc 'salary (cadr record))))
    (define (get-record employee-name)
      (define (search records)
        (cond ((null? records) #f)
              ((eq? employee-name (get-name (car records))) (car records))
              (else (search (cdr records)))))
      (search file))
    (define (tag x) (attach-tag 'division-2 x))
    ;;interface to rest of system
    (put 'get-record 'division-2
         (lambda (employee-name) 
           (let ((record (get-record employee-name)))
             (if record
                 (tag record)
                 '()))))
    (put 'get-salary 'division-2 get-salary)
    'done))

Having this strategy in place we can define a generic get-record procedure that retrieves a specified employee’s record from the database of the corresponding division:

(define (get-record employee-name file)
  ((get 'get-record file) employee-name))

The implementation of the generic get-salary procedure relies on each retrieved record being tagged with the name of the division it comes from:

(define (get-salary record)
  ((get 'get-salary (type-tag record)) (contents record)))

Definition of the procedure find-employee-record:

(define (find-employee-record employee-name divisions)
  (if (null? divisions)
      '()
      (let ((record (get-record employee-name (car divisions))))
        (if (null? record)
            (find-employee-record employee-name (cdr divisions))
            record))))

Adding a new division to this model would require implementing and installing a new package specific to the division. This can be done without making any changes to the existing system.




Exercise 2.75

Implementation of the constructor make-from-mag-ang in message-passing style:

(define (make-from-mag-ang r a)
  (define (dispatch op)
    (cond ((eq? op 'real-part) (* r (cos a)))
          ((eq? op 'imag-part) (* r (sin a)))
          ((eq? op 'mag) r)
          ((eq? op 'ang) a)
          (else (error "Unkonown op -- MAKE-FROM-MAG-ANG" op))))
  dispatch)




Exercise 2.76

Adding new operations to a system that uses generic operations with explicit dispatch can be done without any changes to existing code. However, adding a new type would require adding extra code to all procedures (operations) that can be performed on that type.

In the case of a system implemented in data-directed style, both adding new operations and new types can be done without changes to existing code.

A system implemented in message-passing style allows for addition of new types without changes to existing code. However, adding a new operation would require adding code to all existing types which have to support this operation.

For a system that will require a frequent addition of new types both data-directed style and message-passing style could be adequate choices.

On the other hand, for a system that will require frequent addition of new operations, either data-directed style or generic operations with explicit dispatch might be considered.

Read Full Post »

Exercise 2.67

Applying the decode procedure to sample-message and sample-tree we get:

(decode sample-message sample-tree)
; => (a d a b b c a)




Exercise 2.68

Encode-symbol can be defined recursively.

If the symbol is not present in the given tree an error message is generated.

If the given tree is a single leaf – the encoding is an empty list.

Otherwise, if the symbol is in the left sub-tree, the encoding is a list that starts with 0 followed by the elements of the list generated by applying encode-symbol to the symbol and the left sub-tree.

If the symbol is in the right sub-tree the encoding is a list that starts with 1 followed by the elements of the list generated by applying encode-symbol to the symbol and the right sub-tree.

(define (encode-symbol symbol tree)
  (if (element-of-set? symbol (symbols tree))
      (if (leaf? tree) 
          '()
          (let ((left-tree (left-branch tree))
                (right-tree (right-branch tree)))
            (if (or (null? left-tree) (not (element-of-set? symbol (symbols left-tree))))
                (cons 1 (encode-symbol symbol right-tree))
                (cons 0 (encode-symbol symbol left-tree)))))
      (error "symbol dose not exist -- ENCODE-SYMBOL" symbol)))

The code relies on element-of-set? predicate for unordered sets which was defined in the previous section.

Applying encode to the result obtained in the previous exercise we get:

(encode '(a d a b b c a) sample-tree)
=> (0 1 1 0 0 1 0 1 0 1 1 1 0)




Exercise 2.69

Definition of successive-merge:

(define (successive-merge set)
  (cond ((null? set) '())
        ((= 1 (length set)) (car set))
        (else (successive-merge 
               (adjoin-set (make-code-tree (car set) (cadr set))
                           (cddr set))))))




Exercise 2.70

Let’s start by building the Huffman encoding tree and defining the message to be encoded:

(define hip-tree 
  (generate-huffman-tree '((A 2) (BOOM 1) (GET 2) (JOB 2) (NA 16) (SHA 3) (YIP 9) (WAH 1)))) 

(define hip-message 
  '(Get a job 
    Sha na na na na na na na na 
    Get a job 
    Sha na na na na na na na na 
    Wah yip yip yip yip yip yip yip yip yip 
    Sha boom))

In order to count the number of bits in the encoding we can proceed by encoding the message and getting the length of the generated list:

(length (encode hip-message hip-tree))
=> 84

If we use a fixed-length code we would need log2 8 = 3 bits for each symbol. Since our message contains 36 symbols a total of 3 * 36 = 108 bits would be needed.




Exercise 2.71

Every power of 2 is greater than the sum of all lesser powers of 2:

2^n > \displaystyle\sum_{i = 0}^{n - 1} 2^i

In the context of Huffman encoding trees this means than when the relative frequencies of the symbols of the alphabet are consecutive powers of 2 we end up with an extremely unbalanced tree.

In the case n = 5 we get:

In general, for an alphabet of n symbols with relative frequencies of 20, 21, 22, …, 2n – 1, we will need 1 bit for encoding the most frequent symbol and n – 1 bits for encoding the least frequent one.




Exercise 2.72

The Huffman encoding tree resulting from an alphabet of n symbols with relative frequencies as described in the previous exercise is extremely unbalanced.

At each step the encode-symbol procedure examines all the elements in the current sub-tree. As a result encoding the least frequent symbol will require O(n2) steps, while encoding the most frequent symbol will require O(n) steps.

Read Full Post »

Older Posts »