# 2.5 Systems with Generic Operations⁠

# 2.5.1 Generic Arithmetic Operations⁠

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

(define (scheme-number-pkg)
  (define (tag x) (attach-tag 'scheme-number x))
  (put 'add '(scheme-number scheme-number) (lambda (x y) (tag (+ x y))))
  (put 'sub '(scheme-number scheme-number) (lambda (x y) (tag (- x y))))
  (put 'mul '(scheme-number scheme-number) (lambda (x y) (tag (* x y))))
  (put 'div '(scheme-number scheme-number) (lambda (x y) (tag (/ x y))))
  (put 'make 'scheme-number tag))

(define (make-scheme-number n)
  (apply-specific 'make 'scheme-number n))

(define (rational-pkg)
  (define (tag x) (attach-tag 'rational x))
  (put 'add '(rational rational) (lambda (x y) (tag (add-rat x y))))
  (put 'sub '(rational rational) (lambda (x y) (tag (sub-rat x y))))
  (put 'mul '(rational rational) (lambda (x y) (tag (mul-rat x y))))
  (put 'div '(rational rational) (lambda (x y) (tag (div-rat x y))))
  (put 'make 'rational (lambda (n d) (tag (make-rat n d)))))

(define (make-rational n d)
  (apply-specific 'make 'rational n d))

(define (complex-pkg)
  (define (tag z) (attach-tag 'complex z))
  (rectangular-pkg)
  (polar-pkg)
  (put 'add '(complex complex) (lambda (z1 z2) (tag (add-complex z1 z2))))
  (put 'sub '(complex complex) (lambda (z1 z2) (tag (sub-complex z1 z2))))
  (put 'mul '(complex complex) (lambda (z1 z2) (tag (mul-complex z1 z2))))
  (put 'div '(complex complex) (lambda (z1 z2) (tag (div-complex z1 z2))))
  (put 'make-from-real-imag 'complex
       (lambda (x y) (tag (make-from-real-imag x y))))
  (put 'make-from-mag-ang 'complex
       (lambda (r a) (tag (make-from-mag-ang r a)))))

(define (make-complex-from-real-imag x y)
  (apply-specific 'make-from-real-imag 'complex x y))
(define (make-complex-from-mag-ang r a)
  (apply-specific 'make-from-mag-ang 'complex r a))

(define (numeric-pkg)
  (scheme-number-pkg)
  (rational-pkg)
  (complex-pkg))

(using numeric-pkg)

(add (make-scheme-number 1) (make-scheme-number 2))
=> (make-scheme-number 3)

(mul (make-rational 1 2) (make-rational 3 4))
=> (make-rational 3 8)

(sub (make-complex-from-mag-ang 1 0) (make-complex-from-real-imag 1 1))
=> (make-complex-from-real-imag 0 -1)

# Exercise 2.77⁠

(define (complex-components-pkg)
  (put 'real-part '(complex) real-part)
  (put 'imag-part '(complex) imag-part)
  (put 'magnitude '(complex) magnitude)
  (put 'angle '(complex) angle))

This works because these selectors were defined in § 2.4.3 using apply-generic, so now they will dispatch back to themselves when given a data object tagged 'complex. In other words, we are telling the system to strip off the type tag and try again.

(using complex-pkg complex-components-pkg)

(define z (make-complex-from-real-imag 3 4))

(magnitude z)
=> (magnitude '(complex rectangular 3 . 4))
=> (apply-generic 'magnitude '(complex rectangular 3 . 4))    ; 1st call
=> (apply (get 'magnitude '(complex)) '((rectangular 3 . 4)))
=> (magnitude '(rectangular 3 . 4))
=> (apply-generic 'magnitude '(rectangular 3 . 4))            ; 2nd call
=> (apply (get 'magnitude '(rectangular)) '((3 . 4)))
=> (sqrt (+ (square 3) (square 4)))
=> (sqrt (+ 9 16))
=> (sqrt 25)
=> 5

In this example, apply-generic is invoked twice: once on the outer 'complex object and again on the inner 'rectangular object. Each invocation strips off one type tag.

# Exercise 2.78⁠

(define (attach-tag type-tag contents)
  (if (eq? type-tag 'scheme-number)
      contents
      (cons type-tag contents)))
(define (type-tag datum)
  (cond ((pair? datum) (car datum))
        ((number? datum) 'scheme-number)
        (else (error 'type-tag "bad tagged datum" datum))))
(define (contents datum)
  (cond ((pair? datum) (cdr datum))
        ((number? datum) datum)
        (else (error 'contents "bad tagged datum" datum))))

(attach-tag 'foo 'a) => '(foo . a)
(attach-tag 'scheme-number 1) => 1
(type-tag '(foo . a)) => 'foo
(type-tag 1) => 'scheme-number
(contents '(foo . a)) => 'a
(contents 1) => 1

(paste (:2.4.3 apply-generic) (:2.5.1 add div mul scheme-number-pkg sub))

(using scheme-number-pkg)

(add 1 2) => 3
(mul 3 4) => 12

# Exercise 2.79⁠

In addition to Scheme numbers, rationals, and complex numbers, we’ll also make it work for integers and reals. This will be used to implement drop in Exercise 2.85.

(define (equ-pkg)
  (put 'equ? '(scheme-number scheme-number) =)
  (put 'equ? '(integer integer) =)
  (put 'equ? '(real real) =)
  (put 'equ? '(rational rational)
       (lambda (x y)
         (and (= (numer x) (numer y))
              (= (denom x) (denom y)))))
  (put 'equ? '(complex complex)
       (lambda (z1 z2)
         (and (= (real-part z1) (real-part z2))
              (= (imag-part z1) (imag-part z2))))))

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

(using numeric-pkg equ-pkg)

(equ? (make-scheme-number 1) (make-scheme-number 1)) => #t
(equ? (make-scheme-number 1) (make-scheme-number 2)) => #f
(equ? (make-rational 1 2) (make-rational 2 4)) => #t
(equ? (make-rational 1 3) (make-rational 2 4)) => #f
(equ? (make-complex-from-real-imag 1 0) (make-complex-from-mag-ang 1 0)) => #t
(equ? (make-complex-from-real-imag 1 1) (make-complex-from-mag-ang 1 0)) => #f

# Exercise 2.80⁠

(define (zero-pkg)
  (put '=zero? '(scheme-number) zero?)
  (put '=zero? '(rational)
       (lambda (x) (zero? (numer x))))
  (put '=zero? '(complex)
       (lambda (x) (and (zero? (real-part x))
                        (zero? (imag-part x))))))

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

(using numeric-pkg zero-pkg)

(=zero? (make-scheme-number 0)) => #t
(=zero? (make-scheme-number 1)) => #f
(=zero? (make-rational 0 1)) => #t
(=zero? (make-rational 1 1)) => #f
(=zero? (make-complex-from-mag-ang 0 2)) => #t
(=zero? (make-complex-from-real-imag 0 1)) => #f

# 2.5.2 Combining Data of Different Types⁠

(define (get-coercion type1 type2)
  (get 'coerce (list type1 type2)))
(define (put-coercion type1 type2 coerce)
  (put 'coerce (list type1 type2) coerce))

(define (apply-generic op . args)
  (let* ((type-tags (map type-tag args))
         (proc (get op type-tags)))
    (define (err)
      (error 'apply-generic "no method for types" 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))
                   (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 (err))))
            (err)))))

(paste (:2.5.1 add div mul sub))

(define (scheme-number-to-complex-pkg)
  (define (coerce n)
    (make-complex-from-real-imag (contents n) 0))
  (put-coercion 'scheme-number 'complex coerce))

(using numeric-pkg scheme-number-to-complex-pkg)

(add (make-scheme-number 1) (make-complex-from-real-imag 0 1))
=> (add (make-complex-from-real-imag 0 1) (make-scheme-number 1))
=> (make-complex-from-real-imag 1 1)

# Exercise 2.81⁠

(define (identity-pkg)
  (put-coercion 'scheme-number 'scheme-number (lambda (x) x))
  (put-coercion 'complex 'complex (lambda (x) x)))

(define (exp-pkg)
  (define (tag x) (attach-tag 'scheme-number x))
  (put 'exp '(scheme-number scheme-number) (lambda (x y) (tag (expt x y)))))

(define (exp x y) (apply-generic 'exp x y))

1. If we call exp with two complex numbers, it will enter an infinite recursion because it will keep trying to unnecessarily coerce the first argument to the type of the second.

   (using complex-pkg identity-pkg exp-pkg)
   
   (define z (make-complex-from-real-imag 0 0))
   (exp z z) =>...

2. Louis is wrong: nothing needs to be done about coercion with arguments of the same type. As long as we don’t install any self-coercions as tried above, apply-generic will fail to find a coercion and report an error.

3. This implementation doesn’t coerce two arguments of the same type:

   (define (new-apply-generic op . args)
     (let* ((type-tags (map type-tag args))
            (proc (get op type-tags)))
       (define (err)
         (error 'new-apply-generic "no method for types" op type-tags))
       (if proc
           (apply proc (map contents args))
           (if (= (length args) 2)
               (let ((type1 (car type-tags))
                     (type2 (cadr type-tags)))
                 (if (eq? type1 type2)
                     (err)
                     (let ((a1 (car args))
                           (a2 (cadr args))
                           (t1->t2 (get-coercion type1 type2))
                           (t2->t1 (get-coercion type2 type1)))
                       (cond (t1->t2 (new-apply-generic op (t1->t2 a1) a2))
                             (t2->t1 (new-apply-generic op a1 (t2->t1 a2)))
                             (else (err))))))
               (err)))))
   
   (define (exp x y) (new-apply-generic 'exp x y))
   
   (exp z z) =!> "no method for types"

# Exercise 2.82⁠

(define (get-coercion-or-id from to)
  (if (eq? from to)
      (lambda (x) x)
      (get-coercion from to)))
(define (all-good? xs)
  (or (null? xs)
      (and (car xs)
           (all-good? (cdr xs)))))
(define (coerce-all vals types to)
  (let ((cs (map (lambda (from) (get-coercion-or-id from to)) types)))
    (if (all-good? cs)
        (map (lambda (c v) (c v)) cs vals)
        #f)))

(define (apply-generic op . args)
  (let* ((type-tags (map type-tag args))
         (proc (get op type-tags)))
    (define (try tt)
      (when (null? tt)
        (error 'apply-generic "no method for types" op type-tags))
      (let* ((try-type (car tt))
             (coerced-args (coerce-all args type-tags try-type))
             (new-type-tags (map (lambda (x) try-type) type-tags))
             (proc (get op new-type-tags)))
        (if proc
            (apply proc (map contents coerced-args))
            (try (cdr tt)))))
    (if proc
        (apply proc (map contents args))
        (try type-tags))))

(define (add3c-pkg)
  (define (tag z) (attach-tag 'complex z))
  (put 'add3c '(complex complex complex)
       (lambda (z1 z2 z3)
         (tag (add-complex z1 (add-complex z2 z3))))))

(define (add3c z1 z2 z3) (apply-generic 'add3c z1 z2 z3))

(using numeric-pkg scheme-number-to-complex-pkg add3c-pkg)

(add3c (make-scheme-number 1)
       (make-complex-from-real-imag 1 1)
       (make-scheme-number 1))
=> (make-complex-from-real-imag 3 1)

This won’t work if two complex numbers are supplied and the operation takes one real number and one complex number. It only works for operations given the exact types they need, or for operations that take arguments that are all of the same type (assuming all the necessary coercions are possible).

# Exercise 2.83⁠

(define (integer-pkg)
  (define (tag x) (attach-tag 'integer x))
  (put 'add '(integer integer) (lambda (x y) (tag (+ x y))))
  (put 'sub '(integer integer) (lambda (x y) (tag (- x y))))
  (put 'mul '(integer integer) (lambda (x y) (tag (* x y))))
  (put 'div '(integer integer)
       (lambda (x y)
         (let ((z (/ x y)))
           (if (integer? z) (tag z) (make-rational x y)))))
  (put 'make 'integer tag))

(define (make-integer x) (apply-specific 'make 'integer x))

(define (real-pkg)
  (define (tag x) (attach-tag 'real x))
  (put 'add '(real real) (lambda (x y) (tag (+ x y))))
  (put 'sub '(real real) (lambda (x y) (tag (- x y))))
  (put 'mul '(real real) (lambda (x y) (tag (* x y))))
  (put 'div '(real real) (lambda (x y) (tag (/ x y))))
  (put 'make 'real tag))

(define (make-real x) (apply-specific 'make 'real x))

The extended-numeric-pkg is like numeric-pkg from § 2.5.1, but it splits 'scheme-number into 'integer and 'real.

(define (extended-numeric-pkg)
  (integer-pkg)
  (rational-pkg)
  (real-pkg)
  (complex-pkg))

(define (raise-pkg)
  (define (integer->rational n)
    (make-rational n 1))
  (define (rational->real x)
    (make-real (inexact (/ (numer x) (denom x)))))
  (define (real->complex n)
    (make-complex-from-real-imag n 0))
  (put 'raise '(integer) integer->rational)
  (put 'raise '(rational) rational->real)
  (put 'raise '(real) real->complex))

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

(using extended-numeric-pkg raise-pkg)

(add (make-integer 1) (make-integer 2)) => (make-integer 3)
(div (make-integer 10) (make-integer 2)) => (make-integer 5)
(div (make-integer 1) (make-integer 2)) => (make-rational 1 2)

(raise (make-integer 1)) => (make-rational 1 1)
(raise (make-rational 1 2)) => (make-real 0.5)
(raise (make-real 0.5)) => (make-complex-from-real-imag 0.5 0)

# Exercise 2.84⁠

(define numeric-tower
  '(integer rational real complex))

(define (tower-bottom? type) (eq? type 'integer))
(define (tower-top? type) (eq? type 'complex))

(define (tower-position type)
  (define (iter tower n)
    (cond ((null? tower) #f)
          ((eq? type (car tower)) n)
          (else (iter (cdr tower) (+ n 1)))))
  (iter numeric-tower 0))

(define (apply-generic op . args)
  (let* ((type-tags (map type-tag args))
         (vals (map contents args))
         (proc (get op type-tags)))
    (define (err)
      (error 'apply-generic "no method for types" op type-tags))
    (cond (proc (apply proc vals))
          ((null? args) (err))
          ((null? (cdr args))
           (if (tower-top? (car type-tags))
               (err)
               (apply-generic op (raise (car args)))))
          ((null? (cddr args))
           (let ((a1 (car args))
                 (a2 (cadr args))
                 (p1 (tower-position (car type-tags)))
                 (p2 (tower-position (cadr type-tags))))
             (cond ((or (not p1) (not p2) (= p1 p2)) (err))
                   ((< p1 p2) (apply-generic op (raise a1) a2))
                   (else (apply-generic op a1 (raise a2))))))
          (else (err)))))

(paste (:2.5.1 add div mul sub))

(using extended-numeric-pkg raise-pkg)

(add (make-integer 1) (make-complex-from-real-imag 2.0 3.0))
=> (make-complex-from-real-imag 3.0 3.0)

(add (make-rational 1 2) (make-real 0.5))
=> (make-real 1.0)

(div (make-real 1) (make-integer 2))
=> (make-real 0.5)

# Exercise 2.85⁠

Projection from reals to rationals is the hardest. Instead of designing an algorithm to find the nearest rational, we’ll cheat and use the procedures exact, numerator, and denominator which deal with Scheme’s built-in rational numbers.

(define (project-pkg)
  (define (complex->real x)
    (make-real (real-part x)))
  (define (real->rational x)
    (let ((y (exact x)))
      (make-rational (numerator y) (denominator y))))
  (define (rational->integer r)
    (make-integer (quotient (numer r) (denom r))))
  (put 'project '(complex) complex->real)
  (put 'project '(real) real->rational)
  (put 'project '(rational) rational->integer))

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

(define (drop x)
  (let ((type (type-tag x)))
    (if (tower-bottom? type)
        x
        (let* ((down (project x))
               (down-up (raise down)))
          (if (equ? x down-up) (drop down) x)))))

(define (apply-generic op . args)
  (let* ((type-tags (map type-tag args))
         (vals (map contents args))
         (proc (get op type-tags)))
    (define (err)
      (error 'apply-generic "no method for types" op type-tags))
    (cond (proc
           (let ((result (apply proc vals)))
             (if (and (pair? result)
                      (tower-position (type-tag result))
                      (not (or (eq? op 'raise) (eq? op 'project))))
                 (drop result)
                 result)))
          ((null? args) (err))
          ((null? (cdr args))
           (if (tower-top? (car type-tags))
               (err)
               (apply-generic op (raise (car args)))))
          ((null? (cddr args))
           (let ((a1 (car args))
                 (a2 (cadr args))
                 (p1 (tower-position (car type-tags)))
                 (p2 (tower-position (cadr type-tags))))
             (cond ((or (not p1) (not p2) (= p1 p2)) (err))
                   ((< p1 p2) (apply-generic op (raise a1) a2))
                   (else (apply-generic op a1 (raise a2))))))
          (else (err)))))

(paste (:2.5.1 add div mul sub))

(using extended-numeric-pkg equ-pkg raise-pkg project-pkg)

(div (make-real 1) (make-complex-from-real-imag 2 0)) => (make-rational 1 2)
(add (make-complex-from-real-imag 1 0) (make-integer 1)) => (make-integer 2)
(mul (make-rational 3 2) (make-real 8)) => (make-integer 12)
(sub (make-real 2) (make-real 0.5)) => (make-rational 3 2)

# Exercise 2.86⁠

To support complex numbers whose components are themselves tagged data objects, we must rewrite all the complex number operations using generic procedures like add instead of specific procedures like +. Before we can do that, we need generic procedures for squares, square roots, and trigonometric functions. Thanks to the automatic coercion in Exercise 2.85’s apply-generic, we only need to define them for 'real.

(define (square x) (mul x x))

(define (sqrt-trig-pkg)
  (define (tag x) (attach-tag 'real x))
  (put 'square-root '(real) (lambda (x) (tag (sqrt x))))
  (put 'sine '(real) (lambda (x) (tag (sin x))))
  (put 'cosine '(real) (lambda (x) (tag (cos x))))
  (put 'atan2 '(real real) (lambda (y x) (tag (atan y x)))))

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

Now we can rewrite the rectangular and polar packages:

(define (rectangular-pkg)
  (define real-part car)
  (define imag-part cdr)
  (define make-from-real-imag cons)
  (define (magnitude z)
    (square-root (add (square (real-part z))
                      (square (imag-part z)))))
  (define (angle z)
    (atan2 (imag-part z) (real-part z)))
  (define (make-from-mag-ang r a)
    (cons (mul r (cosine a)) (mul r (sine a))))
  (define (tag x) (attach-tag 'rectangular x))
  (put 'real-part '(rectangular) real-part)
  (put 'imag-part '(rectangular) imag-part)
  (put 'magnitude '(rectangular) magnitude)
  (put 'angle '(rectangular) angle)
  (put 'make-from-real-imag 'rectangular
       (lambda (x y) (tag (make-from-real-imag x y))))
  (put 'make-from-mag-ang 'rectangular
       (lambda (r a) (tag (make-from-mag-ang r a)))))

(define (polar-pkg)
  (define magnitude car)
  (define angle cdr)
  (define make-from-mag-ang cons)
  (define (real-part z)
    (mul (magnitude z) (cosine (angle z))))
  (define (imag-part z)
    (mul (magnitude z) (sine (angle z))))
  (define (make-from-real-imag x y)
    (cons (square-root (add (square x) (square y)))
          (atan2 y x)))
  (define (tag x) (attach-tag 'polar x))
  (put 'real-part '(polar) real-part)
  (put 'imag-part '(polar) imag-part)
  (put 'magnitude '(polar) magnitude)
  (put 'angle '(polar) angle)
  (put 'make-from-real-imag 'polar
       (lambda (x y) (tag (make-from-real-imag x y))))
  (put 'make-from-mag-ang 'polar
       (lambda (r a) (tag (make-from-mag-ang r a)))))

Next, we will rewrite the complex package:

(define (add-complex z1 z2)
  (make-from-real-imag (add (real-part z1) (real-part z2))
                       (add (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
  (make-from-real-imag (sub (real-part z1) (real-part z2))
                       (sub (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
  (make-from-mag-ang (mul (magnitude z1) (magnitude z2))
                     (add (angle z1) (angle z2))))
(define (div-complex z1 z2)
  (make-from-mag-ang (div (magnitude z1) (magnitude z2))
                     (sub (angle z1) (angle z2))))

(paste (:2.5.1 complex-pkg))

Finally, we need to fix some procedures in other packages that assumed a complex number’s real part and imaginary part were plain Scheme numbers. Fixing equ? is tricky because the equ? from Exercise 2.79 used the old apply-generic without coercion. That was fine since we only use it in drop on x and (raise (project x)), which must be the same type. But now, if they are complex numbers, their component types might be different. So in the new 'complex implementation of equ?, we need to recursively invoke a version of equ? that supports coercion.

(define (complex-patch-pkg)
  (define (equ-with-coercion? x y) (apply-generic 'equ? x y))
  (put 'equ? '(complex complex)
       (lambda (z1 z2)
         (and (equ-with-coercion? (real-part z1) (real-part z2))
              (equ-with-coercion? (imag-part z1) (imag-part z2)))))
  (put 'raise '(real)
       (lambda (x) (make-complex-from-real-imag (make-real x) (make-real 0))))
  (put 'project '(complex)
       (lambda (x)
         (let ((r (real-part x)))
           (case (type-tag r)
             ((real) r)
             ((rational) (raise r))
             ((integer) (raise (raise r))))))))

Putting it all together:

(define (final-numeric-pkg)
  (integer-pkg)
  (rational-pkg)
  (real-pkg)
  (complex-pkg)
  (sqrt-trig-pkg)
  (equ-pkg)
  (raise-pkg)
  (project-pkg)
  (complex-patch-pkg))

(using final-numeric-pkg)

(add (make-complex-from-mag-ang (make-rational 1 2) (make-integer 0))
     (make-complex-from-real-imag (make-rational 3 4) (make-real 2)))
=> (make-complex-from-real-imag (make-rational 5 4) (make-integer 2))

(div (make-complex-from-mag-ang (make-integer 3) (make-real 1))
     (make-complex-from-mag-ang (make-rational 1 2) (make-real 1)))
=> (make-integer 6)

# 2.5.3 Example: Symbolic Algebra⁠

# 2.5.3.1 Arithmetic on polynomials

We are following Footnote 58 and using the generic arithmetic system from Exercise 2.78, where Scheme numbers are not explicitly tagged.

(define make-poly cons)
(define variable car)
(define term-list cdr)

(define (polynomial-pkg)
  (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 'add-poly "polys not in same var" 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 'mul-poly "polys not in same var" p1 p2)))
  (define (tag p) (attach-tag 'polynomial p))
  (put 'make 'polynomial (lambda (var terms) (tag (make-poly var terms))))
  (put 'add '(polynomial polynomial) (lambda (p1 p2) (tag (add-poly p1 p2))))
  (put 'mul '(polynomial polynomial) (lambda (p1 p2) (tag (mul-poly p1 p2)))))

(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))))))

# 2.5.3.2 Representing term lists

We have to use apply-generic below because importing =zero? from Exercise 2.87 would cause an import cycle.

(define (adjoin-term term term-list)
  (if (apply-generic '=zero? (coeff term))
      term-list
      (cons term term-list)))

(define (the-empty-termlist) '())
(define first-term car)
(define rest-terms cdr)
(define empty-termlist? null?)

(define make-term list)
(define order car)
(define coeff cadr)

(define (make-polynomial var terms)
  (apply-specific 'make 'polynomial var terms))

This package is used in Exercise 2.90:

(define (sparse-termlist-pkg)
  (define (tag tl) (attach-tag 'sparse-termlist tl))
  (put 'make 'sparse-termlist tag)
  ;; Curried so that it only dispatches on the term list, not the term.
  (put 'adjoin-term '(sparse-termlist)
       (lambda (tl) (lambda (t) (tag (adjoin-term t tl)))))
  (put 'the-empty-termlist 'sparse-termlist
       (lambda () (tag (the-empty-termlist))))
  (put 'first-term '(sparse-termlist) first-term)
  (put 'rest-terms '(sparse-termlist) (lambda (tl) (tag (rest-terms tl))))
  (put 'empty-termlist? '(sparse-termlist) empty-termlist?))

# Exercise 2.87⁠

(define (zero-pkg)
  (define (poly-zero? p)
    (define (all-zero? terms)
      (or (empty-termlist? terms)
          (and (=zero? (coeff (first-term terms)))
               (all-zero? (rest-terms terms)))))
    (all-zero? (term-list p)))
  (put '=zero? '(scheme-number) zero?)
  (put '=zero? '(polynomial) poly-zero?))

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

(using scheme-number-pkg polynomial-pkg zero-pkg)

(=zero? (make-polynomial 'x '())) => #t
(=zero? (make-polynomial 'x '((2 0)))) => #t
(=zero? (make-polynomial 'x '((2 1) (1 0)))) => #f

(add (make-polynomial 'x '((100 1) (2 3)))
     (make-polynomial 'x '((3 1) (2 2) (0 5))))
=> (make-polynomial 'x '((100 1) (3 1) (2 5) (0 5)))

(mul (make-polynomial 'x '((2 1) (0 1)))
     (make-polynomial 'x '((1 2))))
=> (make-polynomial 'x '((3 2) (1 2)))

(add (make-polynomial 'x '()) (make-polynomial 'y '()))
=!> "polys not in same var"

# Exercise 2.88⁠

(define (negate-terms tl)
  (if (empty-termlist? tl)
      (the-empty-termlist)
      (let* ((term (first-term tl))
             (new-term (make-term (order term) (negate (coeff term)))))
        (adjoin-term new-term
                     (negate-terms (rest-terms tl))))))

(define (negate-pkg)
  (put 'negate '(scheme-number) -)
  (put 'negate '(polynomial)
       (lambda (p)
         (make-polynomial (variable p) (negate-terms (term-list p))))))

(define (negate x) (apply-generic 'negate x))
(define (sub x y) (add x (negate y)))

(using scheme-number-pkg polynomial-pkg zero-pkg negate-pkg)

(negate 1) => -1
(sub 5 2) => 3

(negate (make-polynomial 'x '((2 1))))
=> (make-polynomial 'x '((2 -1)))

(sub (make-polynomial 'x '((3 1) (1 2)))
     (make-polynomial 'x '((2 2) (1 1) (0 -1))))
=> (make-polynomial 'x '((3 1) (2 -2) (1 1) (0 1)))

# Exercise 2.89⁠

As mentioned in Footnote 59, we are assuming that adjoin-term is always called with a higher-order term than appears in the list.

(define (adjoin-term term term-list)
  (let ((o (order term)))
    (define (iter term-list len)
      (cond ((< len o) (iter (cons 0 term-list) (+ len 1)))
            ((= len o) (cons (coeff term) term-list))
            (else (error 'adjoin-term "term list already has order" o))))
    (if (=zero? (coeff term))
        term-list
        (iter term-list (length term-list)))))

(define (first-term term-list)
  (make-term (- (length term-list) 1)
             (car term-list)))

(adjoin-term (make-term 3 1) (the-empty-termlist)) => '(1 0 0 0)
(first-term '(1 0 0 0)) => (make-term 3 1)

(adjoin-term (make-term 0 1) '(2)) =!> "term list already has order: 0"

This package is used in Exercise 2.90:

(define (dense-termlist-pkg)
  (define (tag tl) (attach-tag 'dense-termlist tl))
  (put 'make 'dense-termlist tag)
  ;; Curried so that it only dispatches on the term list, not the term.
  (put 'adjoin-term '(dense-termlist)
       (lambda (tl) (lambda (t) (tag (adjoin-term t tl)))))
  (put 'the-empty-termlist 'dense-termlist
       (lambda () (tag (the-empty-termlist))))
  (put 'first-term '(dense-termlist) first-term)
  (put 'rest-terms '(dense-termlist) (lambda (tl) (tag (rest-terms tl))))
  (put 'empty-termlist? '(dense-termlist) empty-termlist?))

# Exercise 2.90⁠

To allow sparse and dense representations of polynomials to coexist, we must redefine the arithmetic operations using generic term list selectors:

(define (the-empty-termlist)
  (apply-specific 'the-empty-termlist 'sparse-termlist))
(define (empty-termlist? tl) (apply-generic 'empty-termlist? tl))
(define (first-term tl) (apply-generic 'first-term tl))
(define (rest-terms tl) (apply-generic 'rest-terms tl))
(define (adjoin-term term tl) ((apply-generic 'adjoin-term tl) term))

(paste (:2.5.3.1 add-terms mul-term-by-all-terms mul-terms polynomial-pkg)
       (?2.87 zero-pkg) (?2.88 negate-pkg negate-terms))

(using sparse-termlist-pkg dense-termlist-pkg scheme-number-pkg polynomial-pkg
       zero-pkg negate-pkg)

Let’s define some polynomials using a helper that infers the representation:

(define (poly var terms)
  (let ((type (if (or (null? terms) (pair? (car terms)))
                  'sparse-termlist
                  'dense-termlist)))
    (apply-specific 'make 'polynomial var (apply-specific 'make type terms))))

(define sparse-a (poly 'x '((3 3) (0 1))))
(define dense-a (poly 'x '(3 0 0 1)))

(define sparse-b (poly 'x '((2 3) (1 3) (0 2))))
(define dense-b (poly 'x '(0 3 3 2)))

(define sparse-a+b (poly 'x '((3 3) (2 3) (1 3) (0 3))))
(define dense-a+b (poly 'x '(3 3 3 3)))

(define sparse-a*b (poly 'x '((5 9) (4 9) (3 6) (2 3) (1 3) (0 2))))
(define dense-a*b (poly 'x '(9 9 6 3 3 2)))

Make sure the sparse and dense versions are equal:

(=zero? (sub sparse-a dense-a)) => #t
(=zero? (sub sparse-b dense-b)) => #t
(=zero? (sub sparse-a+b dense-a+b)) => #t
(=zero? (sub sparse-a*b dense-a*b)) => #t

For addition, the second argument determines the result’s representation:

(add sparse-a sparse-b) => sparse-a+b
(add dense-a sparse-b) => sparse-a+b
(add dense-a dense-b) => dense-a+b
(add sparse-a dense-b) => dense-a+b

For multiplication, the result is always sparse:

(mul sparse-a sparse-b) => sparse-a*b
(mul dense-a sparse-b) => sparse-a*b
(mul dense-a dense-b) => sparse-a*b
(mul sparse-a dense-b) => sparse-a*b

# Exercise 2.91⁠

(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 (sub (order t1) (order t2)))
                   (new-term (make-term new-o new-c))
                   (multiplied (mul-term-by-all-terms new-term l2))
                   (new-l1 (add-terms l1 (negate-terms multiplied)))
                   (rest-of-result (div-terms new-l1 l2)))
              (list (adjoin-term new-term (car rest-of-result))
                    (cadr rest-of-result)))))))

(define (polynomial-div-pkg)
  (define (div-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
        (let ((var (variable p1))
              (result (div-terms (term-list p1) (term-list p2))))
          (list (make-polynomial var (car result))
                (make-polynomial var (cadr result))))
        (error 'div-poly "polys not in same var" p1 p2)))
  (put 'div '(polynomial polynomial) div-poly))

(using scheme-number-pkg polynomial-pkg zero-pkg negate-pkg polynomial-div-pkg)

Now we can test the example given in the exercise:

$$\frac{x^5 - 1}{x^2 - 1} = x^3 + x,\;\text{remainder}\;x - 1.$$

(div (make-polynomial 'x '((5 1) (0 -1)))
     (make-polynomial 'x '((2 1) (0 -1))))
=> (list (make-polynomial 'x '((3 1) (1 1)))
         (make-polynomial 'x '((1 1) (0 -1))))

And some other examples:

(div (make-polynomial 'x '((2 2)))
     (make-polynomial 'x '((1 2))))
=> (list (make-polynomial 'x '((1 1)))
         (make-polynomial 'x '()))

(div (make-polynomial 'x '((1 2)))
     (make-polynomial 'x '((2 2))))
=> (list (make-polynomial 'x '())
         (make-polynomial 'x '((1 2))))

# 2.5.3.3 Hierarchies of types in symbolic algebra

# Exercise 2.92⁠

To add or multiply of polynomials in different variables, we first need to coerce them to a common variable. We’ll choose the variable that comes first alphabetically.

Suppose we’re coercing a polynomial from $y$ to $x\htmlClass{math-punctuation}{\text{.}}$ For a term with a numerical coefficient like $5y^2\htmlClass{math-punctuation}{\text{,}}$ we’ll change it to a constant term with a polynomial coefficient: $(5y^2)x^0\htmlClass{math-punctuation}{\text{.}}$ For a term with a polynomial coefficient like $(3x+1)y^2\htmlClass{math-punctuation}{\text{,}}$ we’ll first coerce the coefficient to $x$ (already done) and then multiply it by $(y^2)x^0\htmlClass{math-punctuation}{\text{,}}$ resulting in $(3y^2)x^1+(y^2)x^0\htmlClass{math-punctuation}{\text{.}}$ For this to work, we need to support adding and multiplying Scheme numbers with polynomials, since coefficients can be a mix of the two.

(define (polynomial-pkg)
  (define (singleton t)
    (adjoin-term t (the-empty-termlist)))
  (define (constant-term var term)
    (make-term 0 (make-polynomial var (singleton term))))
  (define (variable<? a b)
    (string<? (symbol->string a) (symbol->string b)))
  (define (principal-variable v1 v2)
    (if (variable<? v1 v2) v1 v2))
  (define (coerce-term t from to)
    (case (type-tag (coeff t))
      ((scheme-number) (singleton (constant-term from t)))
      ((polynomial)
       (let ((tl (term-list (coerce-poly (contents (coeff t)) to))))
         (if (zero? (order t))
             tl
             (mul-term-by-all-terms
              (constant-term from (make-term (order t) 1))
              tl))))
      (else (error 'coerce-term "invalid coeff type" (coeff t)))))
  (define (coerce-termlist tl from to)
    (if (empty-termlist? tl)
        tl
        (add-terms
         (coerce-term (first-term tl) from to)
         (coerce-termlist (rest-terms tl) from to))))
  (define (coerce-poly p var)
    (if (same-variable? (variable p) var)
        p
        (make-poly var (coerce-termlist (term-list p) (variable p) var))))
  (define (binary-op term-fn)
    (lambda (p1 p2)
      (let ((var (principal-variable (variable p1) (variable p2))))
        (make-poly var (term-fn (term-list (coerce-poly p1 var))
                                (term-list (coerce-poly p2 var)))))))
  (define add-poly (binary-op add-terms))
  (define mul-poly (binary-op mul-terms))
  (define (add-mixed x p)
    (make-poly (variable p)
               (add-terms (singleton (make-term 0 x)) (term-list p))))
  (define (mul-mixed x p)
    (make-poly (variable p)
               (map (lambda (t) (make-term (order t) (mul x (coeff t))))
                    (term-list p))))
  (define (tag p) (attach-tag 'polynomial p))
  (put 'make 'polynomial (lambda (var terms) (tag (make-poly var terms))))
  (put 'add '(polynomial polynomial) (lambda (p1 p2) (tag (add-poly p1 p2))))
  (put 'mul '(polynomial polynomial) (lambda (p1 p2) (tag (mul-poly p1 p2))))
  (put 'add '(scheme-number polynomial) (lambda (x p) (tag (add-mixed x p))))
  (put 'add '(polynomial scheme-number) (lambda (p x) (tag (add-mixed x p))))
  (put 'mul '(scheme-number polynomial) (lambda (x p) (tag (mul-mixed x p))))
  (put 'mul '(polynomial scheme-number) (lambda (p x) (tag (mul-mixed x p)))))

(using scheme-number-pkg polynomial-pkg zero-pkg)

Here’s a simple test:

$$x + y = y + x = 1x^1 + \left(1y^1\right)x^0.$$

(add (make-polynomial 'x '((1 1))) (make-polynomial 'y '((1 1))))
=> (add (make-polynomial 'y '((1 1))) (make-polynomial 'x '((1 1))))
=> (make-polynomial 'x `((1 1) (0 ,(make-polynomial 'y '((1 1))))))

Here’s a more complicated test:

$$\begin{aligned} &\phantom{=} (yx^3 + 2)(y + x^2 + 1) \\ &= \left(1y^1\right)x^5 + \left(1y^2 + 1y^1\right)x^3 + 2x^2 + \left(2y^1 + 2y^0\right)x^0. \end{aligned}$$

(mul (make-polynomial 'x `((3 ,(make-polynomial 'y '((1 1)))) (0 2)))
     (make-polynomial 'y `((1 1) (0 ,(make-polynomial 'x '((2 1) (0 1)))))))
=> (make-polynomial 'x `((5 ,(make-polynomial 'y '((1 1))))
                         (3 ,(make-polynomial 'y '((2 1) (1 1))))
                         (2 2)
                         (0 ,(make-polynomial 'y '((1 2) (0 2))))))

# 2.5.3.4 Extended exercise: Rational functions

# Exercise 2.93⁠

(define (make-rat n d) (cons n d))

(define (add-rat x y)
  (make-rat (add (mul (numer x) (denom y))
                 (mul (numer y) (denom x)))
            (mul (denom x) (denom y))))
(define (sub-rat x y)
  (make-rat (sub (mul (numer x) (denom y))
                 (mul (numer y) (denom x)))
            (mul (denom x) (denom y))))
(define (mul-rat x y)
  (make-rat (mul (numer x) (numer y))
            (mul (denom x) (denom y))))
(define (div-rat x y)
  (make-rat (mul (numer x) (denom y))
            (mul (denom x) (numer y))))

(paste (:2.5.1 rational-pkg))

(using scheme-number-pkg zero-pkg polynomial-pkg rational-pkg)

This gives a correct answer, but does not reduce it to lowest terms:

$$\frac{x^3 + 1}{x^2 + 1} + \frac{x^3 + 1}{x^2 + 1} = \frac{2x^5 + 2x^3 + 2x^2 + 2}{x^4 + 2x^2 + 1}.$$

(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)
=> (make-rational (make-polynomial 'x '((5 2) (3 2) (2 2) (0 2)))
                  (make-polynomial 'x '((4 1) (2 2) (0 1))))

# Exercise 2.94⁠

(define (remainder-terms l1 l2)
  (cadr (div-terms l1 l2)))

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

(define (greatest-common-divisor-pkg)
  (define (gcd-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
        (let ((tl (gcd-terms (term-list p1) (term-list p2))))
          (make-polynomial (variable p1) tl))
        (error 'gcd-poly "polys not in same var" p1 p2)))
  (put 'greatest-common-divisor '(scheme-number scheme-number) gcd)
  (put 'greatest-common-divisor '(polynomial polynomial) gcd-poly))

(define (greatest-common-divisor a b)
  (apply-generic 'greatest-common-divisor a b))

(using scheme-number-pkg polynomial-pkg zero-pkg negate-pkg
       greatest-common-divisor-pkg)

Now it works for integers:

(greatest-common-divisor 128 40) => 8

And for polynomials:

(define p1 (make-polynomial 'x '((4 1) (3 -1) (2 -2) (1 2))))
(define p2 (make-polynomial 'x '((3 1) (1 -1))))

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

# Exercise 2.95⁠

(using scheme-number-pkg polynomial-pkg zero-pkg negate-pkg polynomial-div-pkg
       greatest-common-divisor-pkg)

(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))

For brevity, we’ll give names to the term lists of $Q_1$ and $Q_2\htmlClass{math-punctuation}{\text{:}}$

(define q1-tl (term-list (contents q1)))
(define q2-tl (term-list (contents q2)))

Tracing through the GCD calculation, we see that it reduces to the remainder of dividing the original two polynomials:

(gcd-terms q1-tl q2-tl)
=> (gcd-terms q2-tl (remainder-terms q1-tl q2-tl))
=> (gcd-terms (remainder-terms q1-tl q2-tl)
              (remainder-terms q2-tl (remainder-terms q1-tl q2-tl)))
=> (gcd-terms (remainder-terms q1-tl q2-tl)
              (the-empty-termlist))
=> (remainder-terms q1-tl q2-tl)
=> '((2 1458/169) (1 -2916/169) (0 1458/169))

The problem is that div-terms from Exercise 2.91 calls div on coefficients, so they end up as fractions. In this case, we have to multiply by a factor of $169/1458$ to get the desired answer, $P_1\htmlClass{math-punctuation}{\text{:}}$

(mul (greatest-common-divisor q1 q2)
     (make-polynomial 'x '((0 169/1458))))
=> p1

# Exercise 2.96⁠

(paste (?2.94 greatest-common-divisor-pkg))

(using scheme-number-pkg polynomial-pkg zero-pkg negate-pkg polynomial-div-pkg
       greatest-common-divisor-pkg)

1. Polynomial GCD with integer coefficients:

   (define (pseudoremainder-terms l1 l2)
     (let* ((o1 (order (first-term l1)))
            (o2 (order (first-term l2)))
            (c (coeff (first-term l2)))
            (integerizing-factor (expt c (+ 1 o1 (- o2))))
            (term (make-term 0 integerizing-factor))
            (ml1 (mul-term-by-all-terms term l1)))
       (remainder-terms ml1 l2)))
   
   (define (gcd-terms a b)
     (if (empty-termlist? b)
         a
         (gcd-terms b (pseudoremainder-terms a b))))
   
   (greatest-common-divisor q1 q2)
   => (make-polynomial 'x '((2 1458) (1 -2916) (0 1458)))
   => (mul p1 (make-polynomial 'x '((0 1458))))

2. Polynomial GCD with reduced integer coefficients:

   (define (termlist-coeffs tl)
     (if (empty-termlist? tl)
         '()
         (cons (coeff (first-term tl))
               (termlist-coeffs (rest-terms tl)))))
   
   (define (gcd-terms a b)
     (if (empty-termlist? b)
         (let* ((cs (termlist-coeffs a))
                (coeff-gcd (accumulate gcd (car cs) (cdr cs))))
           (mul-term-by-all-terms (make-term 0 (/ coeff-gcd)) a))
         (gcd-terms b (pseudoremainder-terms a b))))
   
   (greatest-common-divisor q1 q2)
   => (make-polynomial 'x '((2 1) (1 -2) (0 1)))
   => p1

# Exercise 2.97⁠

1. Reducing a rational function to lowest terms:

   (define (termlist-order tl) (order (first-term tl)))
   (define (quotient-terms l1 l2) (car (div-terms l1 l2)))
   
   (define (reduce-terms n d)
     (let* ((nd-gcd (gcd-terms n d))
            (leading-coeff (coeff (first-term nd-gcd)))
            (exponent (+ 1
                         (max (termlist-order n) (termlist-order d))
                         (- (termlist-order nd-gcd))))
            (integerizing-factor (expt leading-coeff exponent))
            (term1 (make-term 0 integerizing-factor))
            (n/gcd (quotient-terms (mul-term-by-all-terms term1 n) nd-gcd))
            (d/gcd (quotient-terms (mul-term-by-all-terms term1 d) nd-gcd))
            (all-coeffs (append (termlist-coeffs n/gcd)
                                (termlist-coeffs d/gcd)))
            (coeff-gcd (accumulate gcd (car all-coeffs) (cdr all-coeffs)))
            (term2 (make-term 0 (/ coeff-gcd)))
            (nn (mul-term-by-all-terms term2 n/gcd))
            (dd (mul-term-by-all-terms term2 d/gcd)))
       (list nn dd)))
   
   (define (reduce-poly n d)
     (if (same-variable? (variable n) (variable d))
         (let ((var (variable n))
               (reduced (reduce-terms (term-list n) (term-list d))))
           (list (make-polynomial var (car reduced))
                 (make-polynomial var (cadr reduced))))
         (error 'reduce-poly "polys not in same var" n d)))

2. Rational arithmetic system supporting integers and polynomials:

   (define (reduce-integers n d)
     (let ((g (gcd n d)))
       (list (/ n g) (/ d g))))
   
   (define (reduce-pkg)
     (put 'reduce '(scheme-number scheme-number) reduce-integers)
     (put 'reduce '(polynomial polynomial) reduce-poly))
   
   (define (reduce n d) (apply-generic 'reduce n d))
   
   (define (make-rat n d)
     (let ((reduced (reduce n d)))
       (cons (car reduced) (cadr reduced))))
   
   (paste (?2.93 add-rat div-rat mul-rat sub-rat) (:2.5.1 rational-pkg))
   
   (using scheme-number-pkg polynomial-pkg zero-pkg negate-pkg polynomial-div-pkg
          rational-pkg reduce-pkg)

   Now it works for integers: $\displaystyle\frac{4}{7} + \frac{30}{33} = \frac{114}{77}.$

   (add (make-rational 4 7) (make-rational 30 33))
   => (make-rational 114 77)

   And for polynomials: $\displaystyle\frac{x + 1}{x^3 - 1} + \frac{x}{x^2 - 1} = \frac{x^3 + 2x^2 + 3x + 1}{x^4 + x^3 - x - 1}.$

   (define p1 (make-polynomial 'x '((1 1) (0 1))))
   (define p2 (make-polynomial 'x '((3 1) (0 -1))))
   (define p3 (make-polynomial 'x '((1 1))))
   (define p4 (make-polynomial 'x '((2 1) (0 -1))))
   
   (define rf1 (make-rational p1 p2))
   (define rf2 (make-rational p3 p4))
   
   (add rf1 rf2)
   => (make-rational (make-polynomial 'x '((3 1) (2 2) (1 3) (0 1)))
                     (make-polynomial 'x '((4 1) (3 1) (1 -1) (0 -1))))