Note: At the end it looks like we talk about polynomials, it might be worth skimming over some simple algorithms from Ideals, Varieties, and Algorithms and maybe implementing a simple one.
Note: Lagrange interpolating polynomials are cool. https://en.wikipedia.org/wiki/Lagrange_polynomial
TODO: Skip 86
https://sarabander.github.io/sicp/html/2_002e5.xhtml#g_t2_002e5
Louis Reasoner tries to evaluate
the expression (magnitude z) where z is the object shown in
Figure 2.24. To his surprise, instead of the answer 5 he gets an error
message from apply-generic, saying there is no method for the operation
magnitude on the types (complex). He shows this interaction to
Alyssa P. Hacker, who says "The problem is that the complex-number selectors
were never defined for complex numbers, just for polar and
rectangular numbers. All you have to do to make this work is add the
following to the complex package:"
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
Describe in detail why this works. As an example, trace through all the
procedures called in evaluating the expression (magnitude z) where
z is the object shown in Figure 2.24. In particular, how many
times is apply-generic invoked? What procedure is dispatched to in each
case?
Implicitly, we must mean that we have also defined:
(define (magnitude z)
(apply-generic 'magnitude z))
So then the sequence of calls looks as follows. We make two calls to
apply-generic, on the first call we wind up inside the complex package,
and on the second call we wind up inside the rectangular package.
(magnitude z)
(apply-generic 'magnitude z)
;; This calls the following inside apply-generic:
;; (apply (get op type-tags) (map contents args))
;; type-tags is just equal to 'complex, so we call magnitude again,
;; this time it was the magnitude scoped inside the complex package.
;; The argument to this function is the contents of args, so inside
;; the structure ('complex . ('rectangular . (3 . 4))) we've stripped away the 'complex.
(apply-generic 'magnitude ('rectangular . (3 . 4)))
;; Inside install-rectangular-package
(magnitude (3 . 4))
5
Full working example:
#lang sicp
(define (square x) (* x x))
;; ===================================================================
;; =========================== generic ops ===========================
;; ===================================================================
(define operation-table '())
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (assoc-op key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc-op key (cdr records)))))
(define (put op type-tags proc)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(set-cdr! proc-pair-entry proc)
(set-car! (cdr op-list-entry)
(cons (cons type-tags proc) proc-list)))))
(set! operation-table
(cons (list op (list (cons type-tags proc)))
operation-table)))))
(define (get op type-tags)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(cdr proc-pair-entry)
#f)))
#f)))
;; Modified for ex2-78.
(define (attach-tag type-tag contents)
(if (equal? type-tag 'scheme-number)
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((number? datum) 'scheme-number)
(else (error "Bad tagged datum: TYPE-TAG" datum))))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((number? datum) datum)
(else (error "Bad tagged datum: CONTENTS" datum))))
(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))
(error
"No method for these types: APPLY-GENERIC"
(list op type-tags))))))
;; ===================================================================
;; ================= Complex polar and rectangular ===================
;; ===================================================================
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
;; interface to the rest of the system
(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))))
'done)
(install-polar-package)
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y)
(cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
;; interface to the rest of the system
(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))))
'done)
(install-rectangular-package)
;; ===================================================================
;; ========================= Complex package =========================
;; ===================================================================
(define (install-complex-package)
;; imported procedures from rectangular
;; and polar packages
(define (make-from-real-imag x y)
((get 'make-from-real-imag
'rectangular)
x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar)
r a))
;; internal procedures
(define (add-complex z1 z2)
(make-from-real-imag
(+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag
(- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang
(* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang
(/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
;; interface to rest of the system
(define (tag z) (attach-tag 'complex z))
(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))))
'done)
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(install-complex-package)
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
(define a (make-complex-from-real-imag 3 4))
(magnitude a)
(display a)
done done done 5 (complex rectangular 3 . 4)
The internal procedures in the
scheme-number package are essentially nothing more than calls to the
primitive procedures +, -, etc. It was not possible to use the
primitives of the language directly because our type-tag system requires that
each data object have a type attached to it. In fact, however, all Lisp
implementations do have a type system, which they use internally. Primitive
predicates such as symbol? and number? determine whether data
objects have particular types. Modify the definitions of type-tag,
contents, and attach-tag from 2.4.2 so that our
generic system takes advantage of Scheme's internal type system. That is to
say, the system should work as before except that ordinary numbers should be
represented simply as Scheme numbers rather than as pairs whose car is
the symbol scheme-number.
So, the point of this problem is that we can make these modifications and that's all we need to do: we need no modifications to the scheme-number package.
(define (attach-tag type-tag contents)
(if (equal? type-tag 'scheme-number)
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((number? datum) 'scheme-number)
(else (error "Bad tagged datum: TYPE-TAG" datum))))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((number? datum) datum)
(else (error "Bad tagged datum: CONTENTS" datum))))
Working example:
#lang sicp
;; get and put definitions
(define operation-table '())
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (assoc-op key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc-op key (cdr records)))))
(define (put op type-tags proc)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(set-cdr! proc-pair-entry proc)
(set-car! (cdr op-list-entry)
(cons (cons type-tags proc) proc-list)))))
(set! operation-table
(cons (list op (list (cons type-tags proc)))
operation-table)))))
(define (get op type-tags)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(cdr proc-pair-entry)
#f)))
#f)))
;; Modified for ex2-78.
(define (attach-tag type-tag contents)
(if (equal? type-tag 'scheme-number)
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((number? datum) 'scheme-number)
(else (error "Bad tagged datum: TYPE-TAG" datum))))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((number? datum) datum)
(else (error "Bad tagged datum: CONTENTS" datum))))
(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))
(error
"No method for these types: APPLY-GENERIC"
(list op type-tags))))))
;; Number package
(define (install-scheme-number-package)
(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
(lambda (x) (tag x)))
'done)
(install-scheme-number-package)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
(display "Output of
(apply-generic 'mul
(make-scheme-number 13)
(make-scheme-number 11))")(newline)
(let ((a (make-scheme-number 13))
(b (make-scheme-number 11)))
(apply-generic 'mul a b))
done Output of (apply-generic 'mul (make-scheme-number 13) (make-scheme-number 11)) 143
Define a generic equality
predicate equ? that tests the equality of two numbers, and install it in
the generic arithmetic package. This operation should work for ordinary
numbers, rational numbers, and complex numbers.
We certainly want to do this without type coercion, because we get to type coercion in the next sections.
;; Inside scheme-number
;; This depends how it's defined. If we define it as in 2.78,
;; then we can just compare the numbers directly.
(define (equ? z1 z2)
(= z1 z2))
(put 'equ? '(scheme-number scheme-number) equ?)
;; Inside rational-package
;; z1a/z1b = z2a/z2b iff z1a*z2b - z2a*z1b = 0
(define (equ? z1 z2)
(= (- (* (numer z1) (denom z2))
(* (numer z2) (denom z1)))
0))
(put 'equ? '(rational rational) equ?)
;;inside complex-package
(define (equ? z1 z2)
(and (= (real-part z1) (real-part z2))
(= (imag-part z1) (imag-part z2))))
(put 'equ? '(complex complex) equ?)
(define (equ? z1 z2)
(apply-generic 'equ? z1 z2))
Testing:
#lang sicp
(define (square x) (* x x))
;; ===================================================================
;; =========================== generic ops ===========================
;; ===================================================================
(define operation-table '())
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (assoc-op key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc-op key (cdr records)))))
(define (put op type-tags proc)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(set-cdr! proc-pair-entry proc)
(set-car! (cdr op-list-entry)
(cons (cons type-tags proc) proc-list)))))
(set! operation-table
(cons (list op (list (cons type-tags proc)))
operation-table)))))
(define (get op type-tags)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(cdr proc-pair-entry)
#f)))
#f)))
;; Modified for ex2-78.
(define (attach-tag type-tag contents)
(if (equal? type-tag 'scheme-number)
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((number? datum) 'scheme-number)
(else (error "Bad tagged datum: TYPE-TAG" datum))))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((number? datum) datum)
(else (error "Bad tagged datum: CONTENTS" datum))))
(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))
(error
"No method for these types: APPLY-GENERIC"
(list op type-tags))))))
;; ===================================================================
;; ========================== Number package =========================
;; ===================================================================
(define (install-scheme-number-package)
(define (tag x)
(attach-tag 'scheme-number x))
(put 'egu? '(scheme-number scheme-number)
(lambda (x y) (= x y))) ;Problem 2.79
(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
(lambda (x) (tag x)))
;problem 2.80
(put '=zero? '(scheme-number)
(lambda (a) (= a 0)))
'done)
(install-scheme-number-package)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
;; ===================================================================
;; ======================== Rational package =========================
;; ===================================================================
(define (install-rational-package)
;; internal procedures
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
;; z1a/z1b = z2a/z2b iff z1a*z2b - z2a*z1b = 0
;; equ? for problem 2.79
(define (equ? z1 z2)
(= (- (* (numer z1) (denom z2))
(* (numer z2) (denom z1)))
0))
;; interface to rest of the system
(put 'equ? '(rational rational) equ?)
(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))))
;problem 2.80
(put '=zero? '(rational)
(lambda (a) (= (numer a) 0)))
'done)
(install-rational-package)
(define (make-rational n d)
((get 'make 'rational) n d))
;; ===================================================================
;; ================= Complex polar and rectangular ===================
;; ===================================================================
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
;; interface to the rest of the system
(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))))
'done)
(install-polar-package)
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y)
(cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
;; interface to the rest of the system
(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))))
'done)
(install-rectangular-package)
;; ===================================================================
;; ========================= Complex package =========================
;; ===================================================================
(define (install-complex-package)
;; imported procedures from rectangular
;; and polar packages
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (make-from-real-imag x y)
((get 'make-from-real-imag
'rectangular)
x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar)
r a))
;; internal procedures
(define (add-complex z1 z2)
(make-from-real-imag
(+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag
(- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang
(* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang
(/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
(define (equ? z1 z2) ; for problem 2.79
(and (= (real-part z1) (real-part z2))
(= (imag-part z1) (imag-part z2))))
;; interface to rest of the system
(put 'equ? '(complex complex) equ?)
(put 'real-part '(complex) real-part) ; Changes from problem 2.77
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(define (tag z) (attach-tag 'complex z))
(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))))
;problem 2.80
(put '=zero? '(complex)
(lambda (z) (and (= (real-part z) 0) (= (imag-part z) 0))))
'done)
(install-complex-package)
(define (=zero? a)
(apply-generic '=zero? a))
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (equ? a b)
(apply-generic 'equ? a b))
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
(define a (make-complex-from-real-imag 3 4))
(define b (make-complex-from-real-imag 3 4))
(define c (make-rational 3 4))
(define d (make-rational 6 8))
(newline) (display "Testing for 2.79") (newline)
(display "(equ? (make-complex-from-real-imag 3 4)
(make-complex-from-real-imag 3 4))") (newline)
(equ? a b)
(display "(equ? (make-rational 3 4)
(make-rational 6 8))") (newline)
(equ? c d)
(display "(equ? (make-rational 3 4)
(add (make-rational 3 4) (make-rational 6 8)))") (newline)
(equ? a (apply-generic 'add a b))
done
done
done
done
done
Testing for 2.79
(equ? (make-complex-from-real-imag 3 4)
(make-complex-from-real-imag 3 4))
#t
(equ? (make-rational 3 4)
(make-rational 6 8))
#t
(equ? (make-rational 3 4)
(add (make-rational 3 4) (make-rational 6 8)))
#f
Define a generic predicate
=zero? that tests if its argument is zero, and install it in the generic
arithmetic package. This operation should work for ordinary numbers, rational
numbers, and complex numbers.
;;inside scheme-number
(put '=zero? 'scheme-number
(lambda (a) (= a 0)))
;;inside rational-package
(put '=zero? 'rational
(lambda (a) (= (numer a) 0)))
;;inside complex-package
(put '=zero? 'complex
(lambda (z) (and (= (real-part z) 0) (= (imag-part z) 0))))
(define (=zero? a)
(apply-generic '=zero? a))
Testing:
#lang sicp
(define (square x) (* x x))
;; ===================================================================
;; =========================== generic ops ===========================
;; ===================================================================
(define operation-table '())
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (assoc-op key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc-op key (cdr records)))))
(define (put op type-tags proc)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(set-cdr! proc-pair-entry proc)
(set-car! (cdr op-list-entry)
(cons (cons type-tags proc) proc-list)))))
(set! operation-table
(cons (list op (list (cons type-tags proc)))
operation-table)))))
(define (get op type-tags)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(cdr proc-pair-entry)
#f)))
#f)))
;; Modified for ex2-78.
(define (attach-tag type-tag contents)
(if (equal? type-tag 'scheme-number)
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((number? datum) 'scheme-number)
(else (error "Bad tagged datum: TYPE-TAG" datum))))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((number? datum) datum)
(else (error "Bad tagged datum: CONTENTS" datum))))
(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))
(error
"No method for these types: APPLY-GENERIC"
(list op type-tags))))))
;; ===================================================================
;; ========================== Number package =========================
;; ===================================================================
(define (install-scheme-number-package)
(define (tag x)
(attach-tag 'scheme-number x))
(put 'egu? '(scheme-number scheme-number)
(lambda (x y) (= x y))) ;Problem 2.79
(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
(lambda (x) (tag x)))
;problem 2.80
(put '=zero? '(scheme-number)
(lambda (a) (= a 0)))
'done)
(install-scheme-number-package)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
;; ===================================================================
;; ======================== Rational package =========================
;; ===================================================================
(define (install-rational-package)
;; internal procedures
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
;; z1a/z1b = z2a/z2b iff z1a*z2b - z2a*z1b = 0
;; equ? for problem 2.79
(define (equ? z1 z2)
(= (- (* (numer z1) (denom z2))
(* (numer z2) (denom z1)))
0))
;; interface to rest of the system
(put 'equ? '(rational rational) equ?)
(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))))
;problem 2.80
(put '=zero? '(rational)
(lambda (a) (= (numer a) 0)))
'done)
(install-rational-package)
(define (make-rational n d)
((get 'make 'rational) n d))
;; ===================================================================
;; ================= Complex polar and rectangular ===================
;; ===================================================================
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
;; interface to the rest of the system
(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))))
'done)
(install-polar-package)
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y)
(cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
;; interface to the rest of the system
(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))))
'done)
(install-rectangular-package)
;; ===================================================================
;; ========================= Complex package =========================
;; ===================================================================
(define (install-complex-package)
;; imported procedures from rectangular
;; and polar packages
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (make-from-real-imag x y)
((get 'make-from-real-imag
'rectangular)
x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar)
r a))
;; internal procedures
(define (add-complex z1 z2)
(make-from-real-imag
(+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag
(- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang
(* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang
(/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
(define (equ? z1 z2) ; for problem 2.79
(and (= (real-part z1) (real-part z2))
(= (imag-part z1) (imag-part z2))))
;; interface to rest of the system
(put 'equ? '(complex complex) equ?)
(put 'real-part '(complex) real-part) ; Changes from problem 2.77
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(define (tag z) (attach-tag 'complex z))
(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))))
;problem 2.80
(put '=zero? '(complex)
(lambda (z) (and (= (real-part z) 0) (= (imag-part z) 0))))
'done)
(install-complex-package)
(define (=zero? a)
(apply-generic '=zero? a))
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (equ? a b)
(apply-generic 'equ? a b))
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
(define a (make-complex-from-real-imag 3 4))
(define b (make-complex-from-real-imag 3 4))
(define c (make-rational 3 4))
(define d (make-rational 6 8))
(newline) (display "Testing for 2.80") (newline)
(display "(=zero? (make-complex-from-real-imag 3 4))") (newline)
(=zero? a)
(display "(=zero? (sub (make-complex-from-real-imag 3 4)
(make-complex-from-real-imag 3 4)))") (newline)
(=zero? (apply-generic 'sub a b))
done
done
done
done
done
Testing for 2.80
(=zero? (make-complex-from-real-imag 3 4))
#f
(=zero? (sub (make-complex-from-real-imag 3 4)
(make-complex-from-real-imag 3 4)))
#t
Louis Reasoner has noticed that
apply-generic may try to coerce the arguments to each other's type even
if they already have the same type. Therefore, he reasons, we need to put
procedures in the coercion table to coerce arguments of each type to
their own type. For example, in addition to the
scheme-number->complex coercion shown above, he would do:
(define (scheme-number->scheme-number n) n)
(define (complex->complex z) z)
(put-coercion 'scheme-number 'scheme-number
scheme-number->scheme-number)
(put-coercion 'complex 'complex
complex->complex)
1. With Louis's coercion procedures installed, what happens if
apply-generic is called with two arguments of type scheme-number
or two arguments of type complex for an operation that is not found in
the table for those types? For example, assume that we've defined a generic
exponentiation operation:
(define (exp x y)
(apply-generic 'exp x y))
and have put a procedure for exponentiation in the Scheme-number package but not in any other package:
;; following added to Scheme-number package
(put 'exp
'(scheme-number scheme-number)
(lambda (x y)
(tag (expt x y))))
; using primitive expt
What happens if we call exp with two complex numbers as arguments?
2. Is Louis correct that something had to be done about coercion with arguments of
the same type, or does apply-generic work correctly as is?
3. Modify apply-generic so that it doesn't try coercion if the two
arguments have the same type.
So first of all, it should be fine with no definitions. We do two extra lookups, which both return false to say there is no coercion from type A to type A, and then we give an error. But let's suppose we do this anyways.
Part 1.
proc is false, but we now find coercion functions
t1->t2 and t2->t1, but the first call to this function introduces a problem:
(apply-generic op (t1->t2 a1) a2)
We apply the lookup again, proc is false, we coerce and call apply-generic again... so we just get an infinite recursion!
Part 2. apply-generic works fine as-is. If the function isn't found
and assigned to proc, then there's nothing we can do, we want t1->t2 and t2->t1 to be false exactly as they are.
Part 3. We really don't need this, but we could check for eq? among
the two types. After we check to make sure that the length is two and
after we use let to get the two types, we check for type equality.
(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) ;; <-- our modification
(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)))))))
Show how to generalize
apply-generic to handle coercion in the general case of multiple
arguments. One strategy is to attempt to coerce all the arguments to the type
of the first argument, then to the type of the second argument, and so on.
Give an example of a situation where this strategy (and likewise the
two-argument version given above) is not sufficiently general. (Hint: Consider
the case where there are some suitable mixed-type operations present in the
table that will not be tried.)
Well, this is a really shoddy type conversion system! Let's implement it like
the book asks. But of course it won't be sufficient, say we wanted to define
fast-pow from chapter 1 as (fast-pow complex int). Our type conversion
system would miss this.
I ended up with a very overcomplicated method to do this, I wanted to power through it but it's definitely worth comparing to other solutions to see if they did it a simpler way.
;; Try to coerce every element of args into target-type (a single type).
;; If a coercion fails to exist, or if the function on type (target-type
;; target-type ...) doesn't exist, return false.
(define (coerce-all target-type args)
;; get the function f that coerces source-type to target-type if it
;; exists, identity lambda if it's the same type, and false otherwise.
(define (coerce-function source-type)
(let ((coercion (get-coercion source-type target-type)))
(if coercion
coercion
(if (eq? source-type target-type)
(lambda (x) x)
#f))))
;; Coerce all arguments if all type coercions exist, else return false.
(define (map-if-exists procs args)
(if (= (length procs) (length args))
(if (null? procs) '()
(let ((coercion (car procs)) (x (car args)))
(if coercion
(let ((rest (map-if-exists (cdr procs) (cdr args))))
(if rest
(cons (coercion x) rest)
#f))
#f)))
(error "procs and args must be the same length inside coerce-all")))
(let ((type-tags (map type-tag args)))
(let ((procs (map coerce-function type-tags)))
(map-if-exists procs args))))
(define (apply-generic op . args)
;; Attempt the coerction to the nth type.
;; The car of the result will be false if no function and coercion exists
;; If one does exist, the car will be true and the cadr will be the result.
(define (attempt-coercions n type-tags args)
;; So long as n<=length(type-tags) try to look up a function
;; with type tags all of (list-ref type-tags n). If not, increase n by one
;; and try again.
(if (< n (length type-tags))
(let ((target-type (list-ref type-tags n)))
(let ((proc (get op (map (lambda (x) target-type) type-tags)))
(args-coerced (coerce-all target-type args)))
(if (and proc args-coerced)
(list #t (apply proc (map contents args-coerced)))
(attempt-coercions (+ n 1) type-tags args))))
(list #f )))
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(if (> (length args) 1)
(let ((res (attempt-coercions 0 type-tags args)))
(if (car res)
(cadr res)
(error
"No method for these types!!!"
(list op type-tags))))
(error
"No method for these types"
(list op type-tags)))))))
Because this is so much code, I wanted to run a bunch of test cases for it:
#lang sicp
(define (square x) (* x x))
;; ===================================================================
;; =========================== generic ops ===========================
;; ===================================================================
(define operation-table '())
(define coercion-table '()) ; Problems 2.81+
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (put op type-tags proc)
(let ((op-list-entry (assoc op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(set-cdr! proc-pair-entry proc)
(set-car! (cdr op-list-entry)
(cons (cons type-tags proc) proc-list)))))
(set! operation-table
(cons (list op (list (cons type-tags proc)))
operation-table)))))
(define (get op type-tags)
(let ((op-list-entry (assoc op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(cdr proc-pair-entry)
#f)))
#f)))
;; Type coercion stuff for ex2-81 onwards.
;; Stores a procedure to convert from type1 to type2
(define (put-coercion type1 type2 proc)
(let ((type1-entry (assoc type1 coercion-table)))
(if type1-entry
(let ((proc-list (cadr type1-entry)))
(let ((type2-entry (assoc type2 proc-list)))
(if type2-entry
(set-cdr! type2-entry proc)
(set-car! (cdr type1-entry)
(cons (cons type2 proc) proc-list)))))
(set! coercion-table
(cons (list type1 (list (cons type2 proc)))
coercion-table)))))
(define (get-coercion type1 type2)
(let ((type1-entry (assoc type1 coercion-table)))
(if type1-entry
(let ((proc-list (cadr type1-entry)))
(let ((type2-entry (assoc type2 proc-list)))
(if type2-entry
(cdr type2-entry)
#f)))
#f)))
;; Modified for ex2-78.
(define (attach-tag type-tag contents)
(if (equal? type-tag 'scheme-number)
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((number? datum) 'scheme-number)
(else (error "Bad tagged datum: TYPE-TAG" datum))))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((number? datum) datum)
(else (error "Bad tagged datum: CONTENTS" datum))))
;; Try to coerce every element of args into target-type (a single type).
;; If a coercion fails to exist, or if the function on type (target-type
;; target-type ...) doesn't exist, return false.
(define (coerce-all target-type args)
;; get the function f that coerces source-type to target-type if it
;; exists, identity lambda if it's the same type, and false otherwise.
(define (coerce-function source-type)
(let ((coercion (get-coercion source-type target-type)))
(if coercion
coercion
(if (eq? source-type target-type)
(lambda (x) x)
#f))))
;; Coerce all arguments if all type coercions exist, else return false.
(define (map-if-exists procs args)
(if (= (length procs) (length args))
(if (null? procs) '()
(let ((coercion (car procs)) (x (car args)))
(if coercion
(let ((rest (map-if-exists (cdr procs) (cdr args))))
(if rest
(cons (coercion x) rest)
#f))
#f)))
(error "procs and args must be the same length inside coerce-all")))
(let ((type-tags (map type-tag args)))
(let ((procs (map coerce-function type-tags)))
(map-if-exists procs args))))
(define (apply-generic op . args)
;; Attempt the coerction to the nth type.
;; The car of the result will be false if no function and coercion exists
;; If one does exist, the car will be true and the cadr will be the result.
(define (attempt-coercions n type-tags args)
;; So long as n<=length(type-tags) try to look up a function
;; with type tags all of (list-ref type-tags n). If not, increase n by one
;; and try again.
(if (< n (length type-tags))
(let ((target-type (list-ref type-tags n)))
(let ((proc (get op (map (lambda (x) target-type) type-tags)))
(args-coerced (coerce-all target-type args)))
(if (and proc args-coerced)
(list #t (apply proc (map contents args-coerced)))
(attempt-coercions (+ n 1) type-tags args))))
(list #f )))
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(if (> (length args) 1)
(let ((res (attempt-coercions 0 type-tags args)))
(if (car res)
(cadr res)
(error
"No method for these types!!!"
(list op type-tags))))
(error
"No method for these types"
(list op type-tags)))))))
;; ===================================================================
;; ========================== Number package =========================
;; ===================================================================
(define (install-scheme-number-package)
(define (tag x)
(attach-tag 'scheme-number x))
(put 'egu? '(scheme-number scheme-number)
(lambda (x y) (= x y))) ;Problem 2.79
(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
(lambda (x) (tag x)))
;problem 2.80
(put '=zero? '(scheme-number)
(lambda (a) (= a 0)))
'done)
(install-scheme-number-package)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
;; ===================================================================
;; ======================== Rational package =========================
;; ===================================================================
(define (install-rational-package)
;; internal procedures
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
;; z1a/z1b = z2a/z2b iff z1a*z2b - z2a*z1b = 0
;; equ? for problem 2.79
(define (equ? z1 z2)
(= (- (* (numer z1) (denom z2))
(* (numer z2) (denom z1)))
0))
;; interface to rest of the system
(put 'equ? '(rational rational) equ?)
(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))))
;problem 2.80
(put '=zero? '(rational)
(lambda (a) (= (numer a) 0)))
'done)
(install-rational-package)
(define (make-rational n d)
((get 'make 'rational) n d))
;; ===================================================================
;; ================= Complex polar and rectangular ===================
;; ===================================================================
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
;; interface to the rest of the system
(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))))
'done)
(install-polar-package)
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y)
(cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
;; interface to the rest of the system
(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))))
'done)
(install-rectangular-package)
;; ===================================================================
;; ========================= Complex package =========================
;; ===================================================================
(define (install-complex-package)
;; imported procedures from rectangular
;; and polar packages
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (make-from-real-imag x y)
((get 'make-from-real-imag
'rectangular)
x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar)
r a))
;; internal procedures
(define (add-complex z1 z2)
(make-from-real-imag
(+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag
(- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang
(* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang
(/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
(define (equ? z1 z2) ; for problem 2.79
(and (= (real-part z1) (real-part z2))
(= (imag-part z1) (imag-part z2))))
;; interface to rest of the system
(put 'equ? '(complex complex) equ?)
(put 'real-part '(complex) real-part) ; Changes from problem 2.77
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(define (tag z) (attach-tag 'complex z))
(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))))
;problem 2.80
(put '=zero? '(complex)
(lambda (z) (and (= (real-part z) 0) (= (imag-part z) 0))))
'done)
(install-complex-package)
(define (=zero? a)
(apply-generic '=zero? a))
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (equ? a b)
(apply-generic 'equ? a b))
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
;; Crazy test cases (test cases generated by gemini 2.5 pro)
;; ===================================================================
;; ===================== Coercion Procedures =======================
;; ===================================================================
(define (scheme-number->rational n) (make-rational (contents n) 1))
(define (scheme-number->complex n) (make-complex-from-real-imag (contents n) 0))
(define (rational->complex r)
(let ((rat-val (contents r)))
(make-complex-from-real-imag (/ (car rat-val) (cdr rat-val)) 0)))
;; Install the coercions
(put-coercion 'scheme-number 'rational scheme-number->rational)
(put-coercion 'scheme-number 'complex scheme-number->complex)
(put-coercion 'rational 'complex rational->complex)
(display "Coercions installed.") (newline)
;; ===================================================================
;; ======================== Test Variables =========================
;; ===================================================================
(define sn1 (make-scheme-number 5))
(define sn2 (make-scheme-number -2))
(define rat1 (make-rational 1 2))
(define rat2 (make-rational 3 4))
(define comp1 (make-complex-from-real-imag 2 3))
(define comp2 (make-complex-from-real-imag 1 1))
;; ===================================================================
;; ========================== Test Suite ===========================
;; ===================================================================
(newline) (display "--- Testing Basic Operations ---") (newline)
(display "Add SN+SN: ") (display (apply-generic 'add sn1 sn2)) (newline)
(display "Add Rat+Rat: ") (display (apply-generic 'add rat1 rat2)) (newline)
(display "Add Comp+Comp: ") (display (apply-generic 'add comp1 comp2)) (newline)
(newline) (display "--- Testing Simple Coercion (2 Args) ---") (newline)
(display "Add SN+Rat: ") (display (apply-generic 'add sn1 rat1)) (newline) ; Expect Rat (11 . 2)
(display "Add Rat+SN: ") (display (apply-generic 'add rat1 sn1)) (newline) ; Expect Rat (11 . 2)
(display "Add SN+Comp: ") (display (apply-generic 'add sn1 comp1)) (newline) ; Expect Comp (rect 7 . 3)
(display "Add Comp+SN: ") (display (apply-generic 'add comp1 sn1)) (newline) ; Expect Comp (rect 7 . 3)
(display "Add Rat+Comp: ") (display (apply-generic 'add rat1 comp2)) (newline) ; Expect Comp (rect 1.5 . 1)
(display "Add Comp+Rat: ") (display (apply-generic 'add comp2 rat1)) (newline) ; Expect Comp (rect 1.5 . 1)
(newline) (display "--- Testing Equ? with Coercion ---") (newline)
(display "Equ? SN=Rat: ") (display (equ? (make-scheme-number 3) (make-rational 6 2))) (newline) ; Expect #t
(display "Equ? Rat=Comp: ") (display (equ? (make-rational 3 2) (make-complex-from-real-imag 1.5 0))) (newline) ; Expect #t
(display "Equ? SN=Comp: ") (display (equ? sn1 (make-complex-from-real-imag 5 0))) (newline) ; Expect #t
(display "Equ? SN!=Comp: ") (display (equ? sn1 comp1)) (newline) ; Expect #f
done done done done done Coercions installed. --- Testing Basic Operations --- Add SN+SN: 3 Add Rat+Rat: (rational 5 . 4) Add Comp+Comp: (complex rectangular 3 . 4) --- Testing Simple Coercion (2 Args) --- Add SN+Rat: (rational 11 . 2) Add Rat+SN: (rational 11 . 2) Add SN+Comp: (complex rectangular 7 . 3) Add Comp+SN: (complex rectangular 7 . 3) Add Rat+Comp: (complex rectangular 3/2 . 1) Add Comp+Rat: (complex rectangular 3/2 . 1) --- Testing Equ? with Coercion --- Equ? SN=Rat: #t Equ? Rat=Comp: #t Equ? SN=Comp: #t Equ? SN!=Comp: #f
Other solutions include...
member and (map func list1 list2). In Python this would be something like [func(a,b) for (a,b) in zip(list1,list2)].Suppose you are designing a
generic arithmetic system for dealing with the tower of types shown in
Figure 2.25: integer, rational, real, complex. For each type (except
complex), design a procedure that raises objects of that type one level in the
tower. Show how to install a generic raise operation that will work for
each type (except complex).
We want something like this. Of course scheme-number might be just an untagged
number, and real might be an untagged floating point number, so we have to assume
contents takes care of that properly.
;; inside scheme-number
(put 'raise '(scheme-number)
(lambda (a) ((get 'make 'rational) (contents a) 1)))
;; inside rational package
(put 'raise '(rational)
(lambda (rat) (
(apply-generic 'div ((get 'make 'real) (numer rat))
((get 'make 'real) (denom rat))))))
;; inside real package
(put 'raise '(real)
(lambda (r) ((get 'make 'complex) (contents real) 0) ))
Using the raise operation
of Exercise 2.83, modify the apply-generic procedure so that it
coerces its arguments to have the same type by the method of successive
raising, as discussed in this section. You will need to devise a way to test
which of two types is higher in the tower. Do this in a manner that is
compatible with the rest of the system and will not lead to problems in
adding new levels to the tower.
Let's use our solution to 2.82.
All we need to do is implement coerce-all in this new context, and everything will work.
;; Use accumulate from chapter 2-2.
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op
initial
(cdr sequence)))))
;; returns (list #t raised-result) if repeated application of raise can turn
;; source into target. Returns (list #f) otherwise.
(define (raise-recurse argument target-type)
(let ((source-type (type-tag argument)))
(if (eq? source-type target-type)
(list #t argument)
(let ((raise-func (get 'raise (list source-type))))
(if raise-func
(raise-recurse (raise-func (contents argument)) target-type)
(list #f))))))
(define (coerce-all target-type args)
;; The point of this is that when we apply (map (... raise-recurse ) args),
;; we get a list list ((#t coerced) (#t coerced) (#f) (#t coerced))
;; If anything is false, then we fail.
;; If all are true, then we return a list (list #t coerced-list)
((lambda (args-coerced) (if (car args-coerced) (cadr args-coerced) #f))
(accumulate (lambda (x y)
(if (and (car x) (car y))
(list #t (cons (cadr x) (cadr y)))
(list #f)))
(list #t '())
(map (lambda (arg) (raise-recurse arg target-type)) args))))
;; The rest is the same as in 2-82, all we've done is replace coerce-all to work
;; by repeated application of raise.
(define (apply-generic op . args)
(define (attempt-coercions n type-tags args)
(if (< n (length type-tags))
(let ((target-type (list-ref type-tags n)))
(let ((proc (get op (map (lambda (x) target-type) type-tags)))
(args-coerced (coerce-all target-type args)))
(if (and proc args-coerced)
(list #t (apply proc (map contents args-coerced)))
(attempt-coercions (+ n 1) type-tags args))))
(list #f )))
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(if (> (length args) 1)
(let ((res (attempt-coercions 0 type-tags args)))
(if (car res)
(cadr res)
(error
"No method for these types!!!"
(list op type-tags))))
(error
"No method for these types"
(list op type-tags)))))))
Working example:
#lang sicp
(define (square x) (* x x))
;; ===================================================================
;; =========================== generic ops ===========================
;; ===================================================================
(define operation-table '())
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (put op type-tags proc)
(let ((op-list-entry (assoc op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(set-cdr! proc-pair-entry proc)
(set-car! (cdr op-list-entry)
(cons (cons type-tags proc) proc-list)))))
(set! operation-table
(cons (list op (list (cons type-tags proc)))
operation-table)))))
(define (get op type-tags)
(let ((op-list-entry (assoc op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(cdr proc-pair-entry)
#f)))
#f)))
;; Modified for ex2-78.
(define (attach-tag type-tag contents)
(if (equal? type-tag 'scheme-number)
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((number? datum) 'scheme-number)
(else (error "Bad tagged datum: TYPE-TAG" datum))))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((number? datum) datum)
(else (error "Bad tagged datum: CONTENTS" datum))))
;; Use accumulate from chapter 2-2.
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op
initial
(cdr sequence)))))
;; returns (list #t raised-result) if repeated application of raise can turn
;; source into target. Returns (list #f) otherwise.
(define (raise-recurse argument target-type)
(let ((source-type (type-tag argument)))
(if (eq? source-type target-type)
(list #t argument)
(let ((raise-func (get 'raise (list source-type))))
(if raise-func
(raise-recurse (raise-func (contents argument)) target-type)
(list #f))))))
(define (coerce-all target-type args)
;; The point of this is that when we apply (map (... raise-recurse ) args),
;; we get a list list ((#t coerced) (#t coerced) (#f) (#t coerced))
;; If anything is false, then we fail.
;; If all are true, then we return a list (list #t coerced-list)
((lambda (args-coerced) (if (car args-coerced) (cadr args-coerced) #f))
(accumulate (lambda (x y)
(if (and (car x) (car y))
(list #t (cons (cadr x) (cadr y)))
(list #f)))
(list #t '())
(map (lambda (arg) (raise-recurse arg target-type)) args))))
;; The rest is the same as in 2-82, all we've done is replace coerce-all to work
;; by repeated application of raise.
(define (apply-generic op . args)
(define (attempt-coercions n type-tags args)
(if (< n (length type-tags))
(let ((target-type (list-ref type-tags n)))
(let ((proc (get op (map (lambda (x) target-type) type-tags)))
(args-coerced (coerce-all target-type args)))
(if (and proc args-coerced)
(list #t (apply proc (map contents args-coerced)))
(attempt-coercions (+ n 1) type-tags args))))
(list #f )))
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(if (> (length args) 1)
(let ((res (attempt-coercions 0 type-tags args)))
(if (car res)
(cadr res)
(error
"No method for these types!!!"
(list op type-tags))))
(error
"No method for these types"
(list op type-tags)))))))
;; ===================================================================
;; ========================== Number package =========================
;; ===================================================================
(define (install-scheme-number-package)
(define (tag x)
(attach-tag 'scheme-number x))
(put 'egu? '(scheme-number scheme-number)
(lambda (x y) (= x y))) ;Problem 2.79
(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
(lambda (x) (tag x)))
;problem 2.80
(put '=zero? '(scheme-number)
(lambda (a) (= a 0)))
(put 'raise '(scheme-number)
(lambda (a) ((get 'make 'rational) (contents a) 1)))
'done)
(install-scheme-number-package)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
;; ===================================================================
;; ======================== Rational package =========================
;; ===================================================================
(define (install-rational-package)
;; internal procedures
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
;; z1a/z1b = z2a/z2b iff z1a*z2b - z2a*z1b = 0
;; equ? for problem 2.79
(define (equ? z1 z2)
(= (- (* (numer z1) (denom z2))
(* (numer z2) (denom z1)))
0))
;; interface to rest of the system
(put 'equ? '(rational rational) equ?)
(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))))
(put 'raise '(rational)
;; a rubber lambda with rats
(lambda (rat)
(apply-generic 'div ((get 'make-from-real-imag 'complex) (numer rat) 0)
((get 'make-from-real-imag 'complex) (denom rat) 0))))
;problem 2.80
(put '=zero? '(rational)
(lambda (a) (= (numer a) 0)))
'done)
(install-rational-package)
(define (make-rational n d)
((get 'make 'rational) n d))
;; ===================================================================
;; ================= Complex polar and rectangular ===================
;; ===================================================================
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
;; interface to the rest of the system
(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))))
'done)
(install-polar-package)
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y)
(cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
;; interface to the rest of the system
(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))))
'done)
(install-rectangular-package)
;; ===================================================================
;; ========================= Complex package =========================
;; ===================================================================
(define (install-complex-package)
;; imported procedures from rectangular
;; and polar packages
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (make-from-real-imag x y)
((get 'make-from-real-imag
'rectangular)
x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar)
r a))
;; internal procedures
(define (add-complex z1 z2)
(make-from-real-imag
(+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag
(- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang
(* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang
(/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
(define (equ? z1 z2) ; for problem 2.79
(and (= (real-part z1) (real-part z2))
(= (imag-part z1) (imag-part z2))))
;; interface to rest of the system
(put 'equ? '(complex complex) equ?)
(put 'real-part '(complex) real-part) ; Changes from problem 2.77
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(define (tag z) (attach-tag 'complex z))
(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))))
;problem 2.80
(put '=zero? '(complex)
(lambda (z) (and (= (real-part z) 0) (= (imag-part z) 0))))
'done)
(install-complex-package)
(define (=zero? a)
(apply-generic '=zero? a))
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (equ? a b)
(apply-generic 'equ? a b))
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
;; Crazy test cases (test cases generated by gemini 2.5 pro)
;; ===================================================================
;; ===================== Coercion Procedures =======================
;; ===================================================================
(define (scheme-number->rational n) (make-rational (contents n) 1))
(define (scheme-number->complex n) (make-complex-from-real-imag (contents n) 0))
(define (rational->complex r)
(let ((rat-val (contents r)))
(make-complex-from-real-imag (/ (car rat-val) (cdr rat-val)) 0)))
;; ===================================================================
;; ======================== Test Variables =========================
;; ===================================================================
(define sn1 (make-scheme-number 5))
(define sn2 (make-scheme-number -2))
(define rat1 (make-rational 1 2))
(define rat2 (make-rational 3 4))
(define comp1 (make-complex-from-real-imag 2 3))
(define comp2 (make-complex-from-real-imag 1 1))
(apply-generic 'raise sn1)
(apply-generic 'raise rat2)
;; ===================================================================
;; ========================== Test Suite ===========================
;; ===================================================================
(newline) (display "--- Testing Basic Operations ---") (newline)
(display "Add SN+SN: ") (display (apply-generic 'add sn1 sn2)) (newline)
(display "Add Rat+Rat: ") (display (apply-generic 'add rat1 rat2)) (newline)
(display "Add Comp+Comp: ") (display (apply-generic 'add comp1 comp2)) (newline)
(newline) (display "--- Testing Simple Coercion (2 Args) ---") (newline)
(display "Add SN+Rat: ") (display (apply-generic 'add sn1 rat1)) (newline) ; Expect Rat (11 . 2)
(display "Add Rat+SN: ") (display (apply-generic 'add rat1 sn1)) (newline) ; Expect Rat (11 . 2)
(display "Add SN+Comp: ") (display (apply-generic 'add sn1 comp1)) (newline) ; Expect Comp (rect 7 . 3)
(display "Add Comp+SN: ") (display (apply-generic 'add comp1 sn1)) (newline) ; Expect Comp (rect 7 . 3)
(display "Add Rat+Comp: ") (display (apply-generic 'add rat1 comp2)) (newline) ; Expect Comp (rect 1.5 . 1)
(display "Add Comp+Rat: ") (display (apply-generic 'add comp2 rat1)) (newline) ; Expect Comp (rect 1.5 . 1)
(newline) (display "--- Testing Equ? with Coercion ---") (newline)
(display "Equ? SN=Rat: ") (display (equ? (make-scheme-number 3) (make-rational 6 2))) (newline) ; Expect #t
(display "Equ? Rat=Comp: ") (display (equ? (make-rational 3 2) (make-complex-from-real-imag 1.5 0))) (newline) ; Expect #t
(display "Equ? SN=Comp: ") (display (equ? sn1 (make-complex-from-real-imag 5 0))) (newline) ; Expect #t
(display "Equ? SN!=Comp: ") (display (equ? sn1 comp1)) (newline) ; Expect #f
done done done done done (rational 5 . 1) (complex polar 3/4 . 0) --- Testing Basic Operations --- Add SN+SN: 3 Add Rat+Rat: (rational 5 . 4) Add Comp+Comp: (complex rectangular 3 . 4) --- Testing Simple Coercion (2 Args) --- Add SN+Rat: (rational 11 . 2) Add Rat+SN: (rational 11 . 2) Add SN+Comp: (complex rectangular 7 . 3) Add Comp+SN: (complex rectangular 7 . 3) Add Rat+Comp: (complex rectangular 3/2 . 1) Add Comp+Rat: (complex rectangular 3/2 . 1) --- Testing Equ? with Coercion --- Equ? SN=Rat: #t Equ? Rat=Comp: #t Equ? SN=Comp: #t Equ? SN!=Comp: #f
This section mentioned a method
for simplifying a data object by lowering it in the tower of types as far
as possible. Design a procedure drop that accomplishes this for the
tower described in Exercise 2.83. The key is to decide, in some general
way, whether an object can be lowered. For example, the complex number
$1.5 + 0i$ can be lowered as far as real, the complex number $1 + 0i$ can
be lowered as far as integer, and the complex number $2 + 3i$ cannot
be lowered at all. Here is a plan for determining whether an object can be
lowered: Begin by defining a generic operation project that pushes
an object down in the tower. For example, projecting a complex number would
involve throwing away the imaginary part. Then a number can be dropped if,
when we project it and raise the result back to the type we
started with, we end up with something equal to what we started with. Show how
to implement this idea in detail, by writing a drop procedure that drops
an object as far as possible. You will need to design the various projection
operations and
install project as a generic operation in the system. You will also
need to make use of a generic equality predicate, such as described in
Exercise 2.79. Finally, use drop to rewrite apply-generic
from Exercise 2.84 so that it simplifies its answers.
Let's assume that we have the solution to 2.84 and 2.79. Then we can just
do something like (equ? (drop arg) arg) and the raising will be handled for us,
using the code of 2.84.
First of all, since we're changing apply-generic I found that I had some unintended side-effects with my 'raise rational definition. So I change that definition too.
;; inside rational package
(put 'project '(rational) (lambda (rat)
(/ (- (numer rat) (remainder (numer rat) (denom rat))) (denom rat))))
(put 'raise '(rational)
(lambda (rat)
((get 'make-from-real-imag 'complex) (/ (numer rat) (denom rat)) 0)))
;; inside complex package
(put 'project '(complex) (lambda (z)
((get 'make 'rational) (real-part z) 1)))
(define (drop arg)
(let ((proj-proc (get 'project (type-tag arg))))
(if (not proj-proc)
arg
(let ((projected-arg (proj-proc (contents arg))))
(let ((raise-proc (get 'raise (type-tag projected-arg))))
(if (not raise-proc)
(error "type is projected to but has no raise function!" projected-arg)
(let ((raised-projected-arg (raise-proc projected-arg))
(equ? (get 'equ? (list (type-tag arg) (type-tag arg)))))
(if (equ? arg raised-projected-arg)
(drop projected-arg)
arg))))))))
#lang sicp
(define (square x) (* x x))
;; ===================================================================
;; =========================== generic ops ===========================
;; ===================================================================
(define operation-table '())
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (put op type-tags proc)
(let ((op-list-entry (assoc op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(set-cdr! proc-pair-entry proc)
(set-car! (cdr op-list-entry)
(cons (cons type-tags proc) proc-list)))))
(set! operation-table
(cons (list op (list (cons type-tags proc)))
operation-table)))))
(define (get op type-tags)
(let ((op-list-entry (assoc op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(cdr proc-pair-entry)
#f)))
#f)))
;; Modified for ex2-78.
(define (attach-tag type-tag contents)
(if (equal? type-tag 'scheme-number)
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((number? datum) 'scheme-number)
((boolean? datum) 'scheme-bool)
(else (error "Bad tagged datum: TYPE-TAG" datum))))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((number? datum) datum)
(else (error "Bad tagged datum: CONTENTS" datum))))
;; Use accumulate from chapter 2-2.
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op
initial
(cdr sequence)))))
;; returns (list #t raised-result) if repeated application of raise can turn
;; source into target. Returns (list #f) otherwise.
(define (raise-recurse argument target-type)
(let ((source-type (type-tag argument)))
(if (eq? source-type target-type)
(list #t argument)
(let ((raise-func (get 'raise (list source-type))))
(if raise-func
(raise-recurse (raise-func (contents argument)) target-type)
(list #f))))))
(define (coerce-all target-type args)
;; The point of this is that when we apply (map (... raise-recurse ) args),
;; we get a list list ((#t coerced) (#t coerced) (#f) (#t coerced))
;; If anything is false, then we fail.
;; If all are true, then we return a list (list #t coerced-list)
((lambda (args-coerced) (if (car args-coerced) (cadr args-coerced) #f))
(accumulate (lambda (x y)
(if (and (car x) (car y))
(list #t (cons (cadr x) (cadr y)))
(list #f)))
(list #t '())
(map (lambda (arg) (raise-recurse arg target-type)) args))))
;; The rest is the same as in 2-82, all we've done is replace coerce-all to work
;; by repeated application of raise.
(define (apply-generic-inner op . args)
(define (attempt-coercions n type-tags args)
(if (< n (length type-tags))
(let ((target-type (list-ref type-tags n)))
(let ((proc (get op (map (lambda (x) target-type) type-tags)))
(args-coerced (coerce-all target-type args)))
(if (and proc args-coerced)
(list #t (apply proc (map contents args-coerced)))
(attempt-coercions (+ n 1) type-tags args))))
(list #f )))
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(if (> (length args) 1)
(let ((res (attempt-coercions 0 type-tags args)))
(if (car res)
(cadr res)
(error
"No method for these types!!!"
(list op type-tags))))
(error
"No method for these types"
(list op type-tags)))))))
(define (drop arg)
(let ((proj-proc (get 'project (list (type-tag arg)))))
(if (not proj-proc)
arg
(let ((projected-arg (proj-proc (contents arg))))
(let ((raise-proc (get 'raise (list (type-tag projected-arg)))))
(if (not raise-proc)
(error "type is projected to but has no raise function!" projected-arg)
(let ((raised-projected-arg (raise-proc (contents projected-arg)))
(equ? (get 'equ? (list (type-tag arg) (type-tag arg)))))
(if (equ? (contents arg) (contents raised-projected-arg))
(drop projected-arg)
arg))))))))
(define (apply-generic op . args)
(drop (apply apply-generic-inner (cons op args))))
;; ===================================================================
;; ========================== Number package =========================
;; ===================================================================
(define (install-scheme-number-package)
(define (tag x)
(attach-tag 'scheme-number x))
(put 'egu? '(scheme-number scheme-number)
(lambda (x y) (= x y))) ;Problem 2.79
(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
(lambda (x) (tag x)))
;problem 2.80
(put '=zero? '(scheme-number)
(lambda (a) (= a 0)))
(put 'raise '(scheme-number)
(lambda (a) ((get 'make 'rational) (contents a) 1)))
'done)
(install-scheme-number-package)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
;; ===================================================================
;; ======================== Rational package =========================
;; ===================================================================
(define (install-rational-package)
;; internal procedures
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
;; z1a/z1b = z2a/z2b iff z1a*z2b - z2a*z1b = 0
;; equ? for problem 2.79
(define (equ? z1 z2)
(= (- (* (numer z1) (denom z2))
(* (numer z2) (denom z1))) 0))
;; interface to rest of the system
(put 'equ? '(rational rational) equ?)
(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))))
(put 'raise '(rational)
(lambda (rat)
((get 'make-from-real-imag 'complex) (/ (numer rat) (denom rat)) 0)))
(put 'project '(rational) (lambda (rat)
(/ (- (numer rat) (remainder (numer rat) (denom rat))) (denom rat))))
;problem 2.80
(put '=zero? '(rational)
(lambda (a) (= (numer a) 0)))
'done)
(install-rational-package)
(define (make-rational n d)
((get 'make 'rational) n d))
;; ===================================================================
;; ================= Complex polar and rectangular ===================
;; ===================================================================
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
;; interface to the rest of the system
(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))))
'done)
(install-polar-package)
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y)
(cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
;; interface to the rest of the system
(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))))
'done)
(install-rectangular-package)
;; ===================================================================
;; ========================= Complex package =========================
;; ===================================================================
(define (install-complex-package)
;; imported procedures from rectangular
;; and polar packages
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (make-from-real-imag x y)
((get 'make-from-real-imag
'rectangular)
x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar)
r a))
;; internal procedures
(define (add-complex z1 z2)
(make-from-real-imag
(+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag
(- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang
(* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang
(/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
(define (equ? z1 z2) ; for problem 2.79
(and (= (real-part z1) (real-part z2))
(= (imag-part z1) (imag-part z2))))
;; interface to rest of the system
(put 'equ? '(complex complex) equ?)
(put 'real-part '(complex) real-part) ; Changes from problem 2.77
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(define (tag z) (attach-tag 'complex z))
(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))))
(put 'project '(complex) (lambda (z)
((get 'make 'rational) (real-part z) 1)))
;problem 2.80
(put '=zero? '(complex)
(lambda (z) (and (= (real-part z) 0) (= (imag-part z) 0))))
'done)
(install-complex-package)
(define (=zero? a)
(apply-generic '=zero? a))
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (equ? a b)
(apply-generic 'equ? a b))
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
;; Crazy test cases (test cases generated by gemini 2.5 pro)
;; ===================================================================
;; ===================== Coercion Procedures =======================
;; ===================================================================
(define (scheme-number->rational n) (make-rational (contents n) 1))
(define (scheme-number->complex n) (make-complex-from-real-imag (contents n) 0))
(define (rational->complex r)
(let ((rat-val (contents r)))
(make-complex-from-real-imag (/ (car rat-val) (cdr rat-val)) 0)))
;; ===================================================================
;; ======================== Test Variables =========================
;; ===================================================================
(define sn1 (make-scheme-number 5))
(define sn2 (make-scheme-number -2))
(define rat1 (make-rational 1 2))
(define rat2 (make-rational 3 4))
(define comp1 (make-complex-from-real-imag 2 3))
(define comp2 (make-complex-from-real-imag 1 1))
(apply-generic 'raise sn1)
(apply-generic 'raise rat2)
(newline)(display "Testing whether 1/2+1/2 simplifies:")(newline)
(apply-generic 'add rat1 rat1)
;; ===================================================================
;; ========================== Test Suite ===========================
;; ===================================================================
(newline) (display "--- Testing Basic Operations ---") (newline)
(display "Add SN+SN: ") (display (apply-generic 'add sn1 sn2)) (newline)
(display "Add Rat+Rat: ") (display (apply-generic 'add rat1 rat2)) (newline)
(display "Add Comp+Comp: ") (display (apply-generic 'add comp1 comp2)) (newline)
(newline) (display "--- Testing Simple Coercion (2 Args) ---") (newline)
(display "Add SN+Rat: ") (display (apply-generic 'add sn1 rat1)) (newline) ; Expect Rat (11 . 2)
(display "Add Rat+SN: ") (display (apply-generic 'add rat1 sn1)) (newline) ; Expect Rat (11 . 2)
(display "Add SN+Comp: ") (display (apply-generic 'add sn1 comp1)) (newline) ; Expect Comp (rect 7 . 3)
(display "Add Comp+SN: ") (display (apply-generic 'add comp1 sn1)) (newline) ; Expect Comp (rect 7 . 3)
(display "Add Rat+Comp: ") (display (apply-generic 'add rat1 comp2)) (newline) ; Expect Comp (rect 1.5 . 1)
(display "Add Comp+Rat: ") (display (apply-generic 'add comp2 rat1)) (newline) ; Expect Comp (rect 1.5 . 1)
(newline) (display "--- Testing Equ? with Coercion ---") (newline)
(display "Equ? SN=Rat: ") (display (equ? (make-scheme-number 3) (make-rational 6 2))) (newline) ; Expect #t
(display "Equ? Rat=Comp: ") (display (equ? (make-rational 3 2) (make-complex-from-real-imag 1.5 0))) (newline) ; Expect #t
(display "Equ? SN=Comp: ") (display (equ? sn1 (make-complex-from-real-imag 5 0))) (newline) ; Expect #t
(display "Equ? SN!=Comp: ") (display (equ? sn1 comp1)) (newline) ; Expect #f
done done done done done 5 (rational 3 . 4) Testing whether 1/2+1/2 simplifies: 1 --- Testing Basic Operations --- Add SN+SN: 3 Add Rat+Rat: (rational 5 . 4) Add Comp+Comp: (complex rectangular 3 . 4) --- Testing Simple Coercion (2 Args) --- Add SN+Rat: (rational 11 . 2) Add Rat+SN: (rational 11 . 2) Add SN+Comp: (complex rectangular 7 . 3) Add Comp+SN: (complex rectangular 7 . 3) Add Rat+Comp: (complex rectangular 3/2 . 1) Add Comp+Rat: (complex rectangular 3/2 . 1) --- Testing Equ? with Coercion --- Equ? SN=Rat: #t Equ? Rat=Comp: #t Equ? SN=Comp: #t Equ? SN!=Comp: #f
Suppose we want to handle complex
numbers whose real parts, imaginary parts, magnitudes, and angles can be either
ordinary numbers, rational numbers, or other numbers we might wish to add to
the system. Describe and implement the changes to the system needed to
accommodate this. You will have to define operations such as sine and
cosine that are generic over ordinary numbers and rational numbers.
Inside the complex numbers packages, we have to make sure that we always use
apply-generic 'mul instead of *, and we also have to make sure to use
apply-generic 'sin instead of sin, as well as define the sine and
cosine generic functions inside the other packages. I'll omit defining
the sine and cosine of complex numbers, but this can be done using the
hyperbolic trig functions and/or exponentials.
#lang sicp
(define (square x) (* x x))
;; ===================================================================
;; =========================== generic ops ===========================
;; ===================================================================
(define operation-table '())
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (assoc-op key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc-op key (cdr records)))))
(define (put op type-tags proc)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(set-cdr! proc-pair-entry proc)
(set-car! (cdr op-list-entry)
(cons (cons type-tags proc) proc-list)))))
(set! operation-table
(cons (list op (list (cons type-tags proc)))
operation-table)))))
(define (get op type-tags)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(cdr proc-pair-entry)
#f)))
#f)))
;; Modified for ex2-78.
(define (attach-tag type-tag contents)
(if (equal? type-tag 'scheme-number)
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((number? datum) 'scheme-number)
(else (error "Bad tagged datum: TYPE-TAG" datum))))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((number? datum) datum)
(else (error "Bad tagged datum: CONTENTS" datum))))
(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))
(error
"No method for these types: APPLY-GENERIC"
(list op type-tags))))))
;; ===================================================================
;; ========================== Number package =========================
;; ===================================================================
(define (install-scheme-number-package)
(define (tag x)
(attach-tag 'scheme-number x))
(put 'egu? '(scheme-number scheme-number)
(lambda (x y) (= x y))) ;Problem 2.79
(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
(lambda (x) (tag x)))
(put 'cos '(scheme-number)
(lambda (r) (tag (cos r))))
(put 'sin '(scheme-number)
(lambda (r) (tag (sin r))))
(put 'sqrt '(scheme-number)
(lambda (r) (tag (sqrt r))))
(put 'atan '(scheme-number scheme-number)
(lambda (y x) (tag (atan y x))))
;problem 2.80
(put '=zero? '(scheme-number)
(lambda (a) (= a 0)))
'done)
(install-scheme-number-package)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
;; ===================================================================
;; ======================== Rational package =========================
;; ===================================================================
(define (install-rational-package)
;; internal procedures
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
;; z1a/z1b = z2a/z2b iff z1a*z2b - z2a*z1b = 0
;; equ? for problem 2.79
(define (equ? z1 z2)
(= (- (* (numer z1) (denom z2))
(* (numer z2) (denom z1)))
0))
;; interface to rest of the system
(put 'equ? '(rational rational) equ?)
(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))))
;problem 2.80
(put '=zero? '(rational)
(lambda (a) (= (numer a) 0)))
(put 'cos '(rational)
(lambda (r) (cos (/ (numer r) (denom r)))))
(put 'sin '(rational)
(lambda (r) (sin (/ (numer r) (denom r)))))
(put 'sqrt '(rational)
(lambda (r) (sqrt (/ (numer r) (denom r)))))
(put 'atan '(rational rational)
(lambda (y x) (atan (/ (numer y) (denom y)) (/ (numer x) (denom x)))))
'done)
(install-rational-package)
(define (make-rational n d)
((get 'make 'rational) n d))
;; ===================================================================
;; ================= Complex polar and rectangular ===================
;; ===================================================================
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(apply-generic 'mul (magnitude z) (apply-generic 'cos (angle z))))
(define (imag-part z)
(apply-generic 'mul (magnitude z) (apply-generic 'sin (angle z))))
(define (square x) (apply-generic 'mul x x))
(define (make-from-real-imag x y)
(cons (apply-generic 'sqrt (apply-generic 'add (square x) (square y)))
(apply-generic 'atan y x)))
;; interface to the rest of the system
(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))))
'done)
(install-polar-package)
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y)
(cons x y))
(define (square x) (apply-generic 'mul x x))
(define (magnitude z)
(apply-generic 'sqrt (apply-generic 'add (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(apply-generic 'atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (apply-generic 'mul r (apply-generic 'cos a))
(apply-generic 'mul r (apply-generic 'sin a))))
;; interface to the rest of the system
(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))))
'done)
(install-rectangular-package)
;; ===================================================================
;; ========================= Complex package =========================
;; ===================================================================
(define (install-complex-package)
;; imported procedures from rectangular
;; and polar packages
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (make-from-real-imag x y)
((get 'make-from-real-imag
'rectangular)
x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar)
r a))
;; internal procedures
(define (add-complex z1 z2)
(make-from-real-imag
(apply-generic 'add (real-part z1) (real-part z2))
(apply-generic 'add (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag
(apply-generic 'sub (real-part z1) (real-part z2))
(apply-generic 'sub (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang
(apply-generic 'mul (magnitude z1) (magnitude z2))
(apply-generic 'add (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang
(apply-generic 'div (magnitude z1) (magnitude z2))
(apply-generic 'sub (angle z1) (angle z2))))
(define (equ? z1 z2) ; for problem 2.79
(and (apply-generic '=equ? (real-part z1) (real-part z2))
(apply-generic '=equ? (imag-part z1) (imag-part z2))))
;; interface to rest of the system
(put 'equ? '(complex complex) equ?)
(put 'real-part '(complex) real-part) ; Changes from problem 2.77
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(define (tag z) (attach-tag 'complex z))
(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))))
;problem 2.80
(put '=zero? '(complex)
(lambda (z) (and (= (real-part z) 0) (= (imag-part z) 0))))
'done)
(install-complex-package)
(define (=zero? a)
(apply-generic '=zero? a))
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (equ? a b)
(apply-generic 'equ? a b))
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
(define a (make-complex-from-real-imag 3 4))
(define b (make-complex-from-real-imag 3 4))
(define c (make-rational 3 4))
(define d (make-rational 6 8))
(make-complex-from-real-imag c d)
(apply-generic 'mul (make-complex-from-real-imag c d)
(make-complex-from-real-imag c d))
done done done done done (complex rectangular (rational 3 . 4) rational 3 . 4) (complex polar 1.1249999999999998 . 1.5707963267948966)
Install =zero? for
polynomials in the generic arithmetic package. This will allow
adjoin-term to work for polynomials with coefficients that are
themselves polynomials.
I make use of the accumulate function.
Ideally, we'd prevent the construction of terms with zero coefficients, but that doesn't seem
to be the approach we're taking so we have to check each coef individually.
(define (=zero?-poly poly)
(accumulate (lambda (x y) (and y (=zero? (coeff x))))
#t
(term-list poly)))
;; Make sure to install the function
(put '=zero? '(polynomial) =zero?-poly)
#lang sicp
(define (square x) (* x x))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op
initial
(cdr sequence)))))
;; get and put definitions
(define operation-table '())
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (assoc-op key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc-op key (cdr records)))))
(define (put op type-tags proc)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(set-cdr! proc-pair-entry proc)
(set-car! (cdr op-list-entry)
(cons (cons type-tags proc) proc-list)))))
(set! operation-table
(cons (list op (list (cons type-tags proc)))
operation-table)))))
(define (get op type-tags)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(cdr proc-pair-entry)
#f)))
#f)))
;; Modified for ex2-78.
(define (attach-tag type-tag contents)
(if (equal? type-tag 'scheme-number)
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((number? datum) 'scheme-number)
(else (error "Bad tagged datum: TYPE-TAG" datum))))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((number? datum) datum)
(else (error "Bad tagged datum: CONTENTS" datum))))
(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))
(error
"No method for these types: APPLY-GENERIC"
(list op type-tags))))))
;; Number package
(define (install-scheme-number-package)
(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
(lambda (x) (tag x)))
(put '=zero? '(scheme-number)
(lambda (x) (= x 0)))
'done)
(install-scheme-number-package)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
;; ===================================================================
;; ======================== Rational package =========================
;; ===================================================================
(define (install-rational-package)
;; internal procedures
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
;; z1a/z1b = z2a/z2b iff z1a*z2b - z2a*z1b = 0
;; equ? for problem 2.79
(define (equ? z1 z2)
(= (- (* (numer z1) (denom z2))
(* (numer z2) (denom z1)))
0))
;; interface to rest of the system
(put 'equ? '(rational rational) equ?)
(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))))
;problem 2.80
(put '=zero? '(rational)
(lambda (a) (= (numer a) 0)))
'done)
(install-rational-package)
(define (make-rational n d)
((get 'make 'rational) n d))
;; ===================================================================
;; ================= Complex polar and rectangular ===================
;; ===================================================================
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
;; interface to the rest of the system
(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))))
'done)
(install-polar-package)
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y)
(cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
;; interface to the rest of the system
(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))))
'done)
(install-rectangular-package)
;; ===================================================================
;; ========================= Complex package =========================
;; ===================================================================
(define (install-complex-package)
;; imported procedures from rectangular
;; and polar packages
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (make-from-real-imag x y)
((get 'make-from-real-imag
'rectangular)
x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar)
r a))
;; internal procedures
(define (add-complex z1 z2)
(make-from-real-imag
(+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag
(- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang
(* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang
(/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
(define (equ? z1 z2) ; for problem 2.79
(and (= (real-part z1) (real-part z2))
(= (imag-part z1) (imag-part z2))))
;; interface to rest of the system
(put 'equ? '(complex complex) equ?)
(put 'real-part '(complex) real-part) ; Changes from problem 2.77
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(define (tag z) (attach-tag 'complex z))
(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))))
;problem 2.80
(put '=zero? '(complex)
(lambda (z) (and (= (real-part z) 0) (= (imag-part z) 0))))
'done)
(install-complex-package)
(define (=zero? a)
(apply-generic '=zero? a))
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (mul a b)
(apply-generic 'mul a b))
(define (add a b)
(apply-generic 'add a b))
(define (sub a b)
(apply-generic 'sub a b))
(define (equ? a b)
(apply-generic 'equ? a b))
(define (install-polynomial-package)
;; internal procedures
;; representation of poly
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p) (cdr p))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1)
(variable? v2)
(eq? v1 v2)))
(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))))))
;; representation of terms and term lists
(define (adjoin-term term term-list)
(if (=zero? (coeff term))
term-list
(cons term term-list)))
(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 (make-term order coeff)
(list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(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 var:
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 var:
MUL-POLY"
(list 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)))))))))
;; During construction, we don't check whether coefficients are zero
;; So now, we have to check all coefficients.
(define (=zero?-poly poly)
(accumulate (lambda (x y) (and y (=zero? (coeff x))))
#t
(term-list poly)))
;; Make sure to install the function
(put '=zero? '(polynomial) =zero?-poly)
;; interface to rest of the system
(define (tag p) (attach-tag 'polynomial p))
(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 'make 'polynomial
(lambda (var terms)
(tag (make-poly var terms))))
'done)
(install-polynomial-package)
(define (make-polynomial var terms)
((get 'make 'polynomial) var terms))
(define a (make-polynomial 'x '((2 1) (0 1))))
(define b (make-polynomial 'x '((2 1) (0 -1))))
(display "(x^2+1)(x^2-1) = ")
(apply-generic 'mul a b)
(define c (make-polynomial 'x '((2 0) (0 0))))
(display "P1 = ")
c
(display "(=zero? P1)") (newline)
(=zero? c)
(display "P2 = ")
a
(display "(=zero? P2)") (newline)
(=zero? a)
done done done done done done (x^2+1)(x^2-1) = (polynomial x (4 1) (0 -1)) P1 = (polynomial x (2 0) (0 0)) (=zero? P1) #t P2 = (polynomial x (2 1) (0 1)) (=zero? P2) #f
Extend the polynomial system to include subtraction of polynomials. (Hint: You may find it helpful to define a generic negation operation.)
Let's add a generic 'negate. We do have to define negate for the other types as well.
;; Exercise 2-88.
;; Inside the polynomial package.
(define (negate-terms L)
(if (empty-termlist? L)
L
(let ((t (first-term L)) (r (rest-terms L)))
(adjoin-term (make-term (order t) (apply-generic 'negate (coeff t)))
(negate-terms r)))))
(define (sub-terms L1 L2)
(add-terms L1 (negate-terms L2)))
(define (sub-poly p1 p2)
(if (same-variable? (variable p1)
(variable p2))
(make-poly
(variable p1)
(sub-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var:
SUB-POLY"
(list p1 p2))))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2)
(tag (sub-poly p1 p2))))
(put 'negate '(polynomial)
(lambda (p)
(tag (make-poly (variable p) (negate-terms (term-list p))))))
Generic negate:
(put 'negate '(scheme-number)
(lambda (x) (- x)))
(put 'negate '(rational)
(lambda (r) (tag (make-rat (- (numer r)) (denom r)))))
(put 'negate '(polar)
(lambda (z) (tag (make-from-mag-ang (magnitude z) (+ (angle z) pi)))))
(put 'negate '(rectangular)
(lambda (z) (tag (make-from-real-imag (- (real-part z) (- (imag-part z)))))))
Full code:
#lang sicp
(define pi 3.14159)
(define (square x) (* x x))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op
initial
(cdr sequence)))))
;; get and put definitions
(define operation-table '())
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (assoc-op key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc-op key (cdr records)))))
(define (put op type-tags proc)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(set-cdr! proc-pair-entry proc)
(set-car! (cdr op-list-entry)
(cons (cons type-tags proc) proc-list)))))
(set! operation-table
(cons (list op (list (cons type-tags proc)))
operation-table)))))
(define (get op type-tags)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(cdr proc-pair-entry)
#f)))
#f)))
;; Modified for ex2-78.
(define (attach-tag type-tag contents)
(if (equal? type-tag 'scheme-number)
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((number? datum) 'scheme-number)
(else (error "Bad tagged datum: TYPE-TAG" datum))))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((number? datum) datum)
(else (error "Bad tagged datum: CONTENTS" datum))))
(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))
(error
"No method for these types: APPLY-GENERIC"
(list op type-tags))))))
;; Number package
(define (install-scheme-number-package)
(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
(lambda (x) (tag x)))
(put '=zero? '(scheme-number)
(lambda (x) (= x 0)))
(put 'negate '(scheme-number)
(lambda (x) (- x)))
'done)
(install-scheme-number-package)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
;; ===================================================================
;; ======================== Rational package =========================
;; ===================================================================
(define (install-rational-package)
;; internal procedures
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
;; z1a/z1b = z2a/z2b iff z1a*z2b - z2a*z1b = 0
;; equ? for problem 2.79
(define (equ? z1 z2)
(= (- (* (numer z1) (denom z2))
(* (numer z2) (denom z1)))
0))
;; interface to rest of the system
(put 'equ? '(rational rational) equ?)
(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))))
;problem 2.80
(put '=zero? '(rational)
(lambda (a) (= (numer a) 0)))
(put 'negate '(rational)
(lambda (r) (tag (make-rat (- (numer r)) (denom r)))))
'done)
(install-rational-package)
(define (make-rational n d)
((get 'make 'rational) n d))
;; ===================================================================
;; ================= Complex polar and rectangular ===================
;; ===================================================================
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
;; interface to the rest of the system
(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))))
(put 'negate '(polar)
(lambda (z) (tag (make-from-mag-ang (magnitude z) (+ (angle z) pi)))))
'done)
(install-polar-package)
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y)
(cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
;; interface to the rest of the system
(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))))
(put 'negate '(rectangular)
(lambda (z) (tag (make-from-real-imag (- (real-part z) (- (imag-part z)))))))
'done)
(install-rectangular-package)
;; ===================================================================
;; ========================= Complex package =========================
;; ===================================================================
(define (install-complex-package)
;; imported procedures from rectangular
;; and polar packages
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (make-from-real-imag x y)
((get 'make-from-real-imag
'rectangular)
x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar)
r a))
;; internal procedures
(define (add-complex z1 z2)
(make-from-real-imag
(+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag
(- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang
(* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang
(/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
(define (equ? z1 z2) ; for problem 2.79
(and (= (real-part z1) (real-part z2))
(= (imag-part z1) (imag-part z2))))
;; interface to rest of the system
(put 'equ? '(complex complex) equ?)
(put 'real-part '(complex) real-part) ; Changes from problem 2.77
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(put 'negate '(complex)
(lambda (z) (tag (apply-generic 'negate z))))
(define (tag z) (attach-tag 'complex z))
(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))))
;problem 2.80
(put '=zero? '(complex)
(lambda (z) (and (= (real-part z) 0) (= (imag-part z) 0))))
'done)
(install-complex-package)
(define (=zero? a)
(apply-generic '=zero? a))
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (mul a b)
(apply-generic 'mul a b))
(define (add a b)
(apply-generic 'add a b))
(define (sub a b)
(apply-generic 'sub a b))
(define (equ? a b)
(apply-generic 'equ? a b))
(define (install-polynomial-package)
;; internal procedures
;; representation of poly
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p) (cdr p))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1)
(variable? v2)
(eq? v1 v2)))
(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))))))
;; representation of terms and term lists
(define (adjoin-term term term-list)
(if (=zero? (coeff term))
term-list
(cons term term-list)))
(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 (make-term order coeff)
(list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(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 var:
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 var:
MUL-POLY"
(list 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)))))))))
;; During construction, we don't check whether coefficients are zero
;; So now, we have to check all coefficients.
(define (=zero?-poly poly)
(accumulate (lambda (x y) (and y (=zero? (coeff x))))
#t
(term-list poly)))
;; Make sure to install the function
(put '=zero? '(polynomial) =zero?-poly)
;; Exercise 2-88
(define (negate-terms L)
(if (empty-termlist? L)
L
(let ((t (first-term L)) (r (rest-terms L)))
(adjoin-term (make-term (order t) (apply-generic 'negate (coeff t)))
(negate-terms r)))))
(define (sub-terms L1 L2)
(add-terms L1 (negate-terms L2)))
(define (sub-poly p1 p2)
(if (same-variable? (variable p1)
(variable p2))
(make-poly
(variable p1)
(sub-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var:
SUB-POLY"
(list p1 p2))))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2)
(tag (sub-poly p1 p2))))
(put 'negate '(polynomial)
(lambda (p)
(tag (make-poly (variable p) (negate-terms (term-list p))))))
;; interface to rest of the system
(define (tag p) (attach-tag 'polynomial p))
(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 'make 'polynomial
(lambda (var terms)
(tag (make-poly var terms))))
'done)
(install-polynomial-package)
(define (make-polynomial var terms)
((get 'make 'polynomial) var terms))
(define a (make-polynomial 'x '((2 1) (0 1))))
(define b (make-polynomial 'x '((2 1) (0 -1))))
(display "(x^2+1)+(x^2-1) = ")
(apply-generic 'add a b)
(display "(x^2+1)-(x^2-1) = ")
(apply-generic 'sub a b)
done done done done done done (x^2+1)+(x^2-1) = (polynomial x (2 2)) (x^2+1)-(x^2-1) = (polynomial x (0 2))
Define procedures that implement the term-list representation described above as appropriate for dense polynomials.
Let's define an install-dense-polynomial-package. Some changes that have to be made are:
order or coeff functions that can be applied to each term.First, inside make-poly I chop off leading zeros (we can't chop off trailing zeros):
;; Chop off the leading zeros of a term list.
(define (chop-leading-zeros L)
(cond ((null? L) L)
((apply-generic '=zero? (car L)) (chop-leading-zeros (cdr L)))
(else L)))
(define (make-poly variable term-list)
(cons variable (chop-leading-zeros term-list)))
Addition is somewhat simple. Note that the order of the algorithm is much worse than it needs to be
because of my calls to length. There's probably some trick we can do to avoid this overhead by thinking
about tail recursive or linear recursive algorithms, but I just wanted to get this working. Also note that
add-poly is the same as before with no changes, it just calls the add-terms function.
(define (add-terms L1 L2)
(let ((length1 (length L1)) (length2 (length L2)))
;; divide into cases. If L2 is longer, swap the terms
(cond ((< length1 length2) (add-terms L2 L1))
;; if the lengths are equal, add term by term
((= length1 length2)
(map (lambda (x y)
(apply-generic 'add x y))
L1
L2))
;; else, shorten the longer list.
(else (cons (car L1) (add-terms (cdr L1) L2))))))
Multiplication is a bit more complicated. I define functions map-indexed
and make-zero-terms. Then, I follow the same approach as the polynomial package.
First we define (monomial) $\times$ (term list) multiplication, and then use this to
build (term list) $\times$ (term list) multiplication.
;; Note: this is NOT generic if we don't have type coercion.
;; We could define a ((get 'make-zero type)) to make it generic.
(define (make-zero-terms l)
(if (= l 0) '() (cons 0 (make-zero-terms (- l 1)))))
;; returns the term list representing
;; (coeff)*(variable)^order * (polynomial represented by L)
(define (mul-term-by-all-terms order coeff L)
(if (null? L)
'()
(append (map (lambda (x)
(apply-generic 'mul x coeff))
L)
(make-zero-terms order))))
;; Define a map-indexed function. (map-indexed f '(a b c)) is
;; ((f a 0) (f b 1) (f c 2))
(define (map-indexed my-lambda lst)
(define (map-indexed-inner lst-cur counter)
(if (null? lst-cur) '()
(cons (my-lambda (car lst-cur) counter) (map-indexed-inner (cdr lst-cur) (+ counter 1)))))
(map-indexed-inner lst 0))
(define (mul-terms L1 L2)
(let ((length1 (length L1)) (length2 (length L2)))
(cond ((< length1 length2) (mul-terms L2 L1))
((= length2 0) '())
(else
(accumulate
(lambda (Lx Ly) (add-terms Lx Ly))
'()
(map-indexed
(lambda (coeff ctr)
;; multiply L2 polynomial by the term x*(var)^(order).
(mul-term-by-all-terms (- (- length1 ctr) 1) coeff L2))
L1))))))
#lang sicp
(define pi 3.14159)
(define (square x) (* x x))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op
initial
(cdr sequence)))))
;; get and put definitions
(define operation-table '())
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (assoc-op key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc-op key (cdr records)))))
(define (put op type-tags proc)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(set-cdr! proc-pair-entry proc)
(set-car! (cdr op-list-entry)
(cons (cons type-tags proc) proc-list)))))
(set! operation-table
(cons (list op (list (cons type-tags proc)))
operation-table)))))
(define (get op type-tags)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(cdr proc-pair-entry)
#f)))
#f)))
;; Modified for ex2-78.
(define (attach-tag type-tag contents)
(if (equal? type-tag 'scheme-number)
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((number? datum) 'scheme-number)
(else (error "Bad tagged datum: TYPE-TAG" datum))))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((number? datum) datum)
(else (error "Bad tagged datum: CONTENTS" datum))))
(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))
(error
"No method for these types: APPLY-GENERIC"
(list op type-tags))))))
;; Number package
(define (install-scheme-number-package)
(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
(lambda (x) (tag x)))
(put '=zero? '(scheme-number)
(lambda (x) (= x 0)))
(put 'negate '(scheme-number)
(lambda (x) (- x)))
'done)
(install-scheme-number-package)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
;; ===================================================================
;; ======================== Rational package =========================
;; ===================================================================
(define (install-rational-package)
;; internal procedures
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
;; z1a/z1b = z2a/z2b iff z1a*z2b - z2a*z1b = 0
;; equ? for problem 2.79
(define (equ? z1 z2)
(= (- (* (numer z1) (denom z2))
(* (numer z2) (denom z1)))
0))
;; interface to rest of the system
(put 'equ? '(rational rational) equ?)
(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))))
;problem 2.80
(put '=zero? '(rational)
(lambda (a) (= (numer a) 0)))
(put 'negate '(rational)
(lambda (r) (tag (make-rat (- (numer r)) (denom r)))))
'done)
(install-rational-package)
(define (make-rational n d)
((get 'make 'rational) n d))
;; ===================================================================
;; ================= Complex polar and rectangular ===================
;; ===================================================================
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
;; interface to the rest of the system
(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))))
(put 'negate '(polar)
(lambda (z) (tag (make-from-mag-ang (magnitude z) (+ (angle z) pi)))))
'done)
(install-polar-package)
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y)
(cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
;; interface to the rest of the system
(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))))
(put 'negate '(rectangular)
(lambda (z) (tag (make-from-real-imag (- (real-part z) (- (imag-part z)))))))
'done)
(install-rectangular-package)
;; ===================================================================
;; ========================= Complex package =========================
;; ===================================================================
(define (install-complex-package)
;; imported procedures from rectangular
;; and polar packages
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (make-from-real-imag x y)
((get 'make-from-real-imag
'rectangular)
x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar)
r a))
;; internal procedures
(define (add-complex z1 z2)
(make-from-real-imag
(+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag
(- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang
(* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang
(/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
(define (equ? z1 z2) ; for problem 2.79
(and (= (real-part z1) (real-part z2))
(= (imag-part z1) (imag-part z2))))
;; interface to rest of the system
(put 'equ? '(complex complex) equ?)
(put 'real-part '(complex) real-part) ; Changes from problem 2.77
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(put 'negate '(complex)
(lambda (z) (tag (apply-generic 'negate z))))
(define (tag z) (attach-tag 'complex z))
(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))))
;problem 2.80
(put '=zero? '(complex)
(lambda (z) (and (= (real-part z) 0) (= (imag-part z) 0))))
'done)
(install-complex-package)
(define (=zero? a)
(apply-generic '=zero? a))
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (mul a b)
(apply-generic 'mul a b))
(define (add a b)
(apply-generic 'add a b))
(define (sub a b)
(apply-generic 'sub a b))
(define (equ? a b)
(apply-generic 'equ? a b))
(define (install-polynomial-package)
;; internal procedures
;; representation of poly
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p) (cdr p))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1)
(variable? v2)
(eq? v1 v2)))
(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))))))
;; representation of terms and term lists
(define (adjoin-term term term-list)
(if (=zero? (coeff term))
term-list
(cons term term-list)))
(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 (make-term order coeff)
(list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(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 var:
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 var:
MUL-POLY"
(list 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)))))))))
;; During construction, we don't check whether coefficients are zero
;; So now, we have to check all coefficients.
(define (=zero?-poly poly)
(accumulate (lambda (x y) (and y (=zero? (coeff x))))
#t
(term-list poly)))
;; Make sure to install the function
(put '=zero? '(polynomial) =zero?-poly)
;; Exercise 2-88
(define (negate-terms L)
(if (empty-termlist? L)
L
(let ((t (first-term L)) (r (rest-terms L)))
(adjoin-term (make-term (order t) (apply-generic 'negate (coeff t)))
(negate-terms r)))))
(define (sub-terms L1 L2)
(add-terms L1 (negate-terms L2)))
(define (sub-poly p1 p2)
(if (same-variable? (variable p1)
(variable p2))
(make-poly
(variable p1)
(sub-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var:
SUB-POLY"
(list p1 p2))))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2)
(tag (sub-poly p1 p2))))
(put 'negate '(polynomial)
(lambda (p)
(tag (make-poly (variable p) (negate-terms (term-list p))))))
;; interface to rest of the system
(define (tag p) (attach-tag 'polynomial p))
(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 'make 'polynomial
(lambda (var terms)
(tag (make-poly var terms))))
'done)
(define (install-dense-polynomial-package)
;; internal procedures
;; representation of poly
;; Chop off the leading zeros of a term list.
(define (chop-leading-zeros L)
(cond ((null? L) L)
((apply-generic '=zero? (car L)) (chop-leading-zeros (cdr L)))
(else L)))
(define (make-poly variable term-list)
(cons variable (chop-leading-zeros term-list)))
(define (variable p) (car p))
(define (term-list p) (cdr p))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1)
(variable? v2)
(eq? v1 v2)))
;; Note: this is NOT generic. We could define a ((get 'make-zero type))
;; to make it generic.
(define (make-zero-terms l)
(if (= l 0) '() (cons 0 (make-zero-terms (- l 1)))))
;; returns the term list representing
;; (coeff)*(variable)^order * (polynomial represented by L)
(define (mul-term-by-all-terms order coeff L)
(if (null? L)
'()
(append (map (lambda (x)
(apply-generic 'mul x coeff))
L)
(make-zero-terms order))))
;; Define a map-indexed function. (map-indexed f '(a b c)) is
;; ((f a 0) (f b 1) (f c 2))
(define (map-indexed my-lambda lst)
(define (map-indexed-inner lst-cur counter)
(if (null? lst-cur) '()
(cons (my-lambda (car lst-cur) counter) (map-indexed-inner (cdr lst-cur) (+ counter 1)))))
(map-indexed-inner lst 0))
(define (mul-terms L1 L2)
(let ((length1 (length L1)) (length2 (length L2)))
(cond ((< length1 length2) (mul-terms L2 L1))
((= length2 0) '())
(else
(accumulate
(lambda (Lx Ly) (add-terms Lx Ly))
'()
(map-indexed
(lambda (coeff ctr)
;; multiply L2 polynomial by the term x*(var)^(order).
(mul-term-by-all-terms (- (- length1 ctr) 1) coeff L2))
L1))))))
(define (empty-termlist? term-list)
(null? term-list))
(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 var:
MUL-POLY"
(list p1 p2))))
(define (add-terms L1 L2)
(let ((length1 (length L1)) (length2 (length L2)))
(cond ((< length1 length2) (add-terms L2 L1))
((= length1 length2)
(map (lambda (x y)
(apply-generic 'add x y))
L1
L2))
(else (cons (car L1) (add-terms (cdr L1) L2))))))
(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 var:
ADD-POLY"
(list p1 p2))))
(define (=zero?-poly poly)
(accumulate (lambda (x y) (and y (=zero? x)))
#t
(term-list poly)))
(define (negate-terms L)
(map (lambda (x) (apply-generic 'negate x)) L))
(define (sub-terms L1 L2)
(add-terms L1 (negate-terms L2)))
(define (sub-poly p1 p2)
(if (same-variable? (variable p1)
(variable p2))
(make-poly
(variable p1)
(sub-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var:
SUB-POLY"
(list p1 p2))))
;; interface to rest of the system
(define (tag p) (attach-tag 'dense-poly p))
(put 'add '(dense-poly dense-poly)
(lambda (p1 p2)
(tag (add-poly p1 p2))))
(put 'mul '(dense-poly dense-poly)
(lambda (p1 p2)
(tag (mul-poly p1 p2))))
(put 'make 'dense-poly
(lambda (var terms)
(tag (make-poly var terms))))
(put 'sub '(dense-poly dense-poly)
(lambda (p1 p2)
(tag (sub-poly p1 p2))))
(put 'negate '(dense-poly)
(lambda (p)
(tag (make-poly (variable p) (negate-terms (term-list p))))))
(put '=zero? '(dense-poly) =zero?-poly)
'done)
(install-polynomial-package)
(install-dense-polynomial-package)
(define (make-dense-polynomial var terms)
((get 'make 'dense-poly) var terms))
(define a (make-dense-polynomial 'x '(1 1 1 1)))
(define b (make-dense-polynomial 'x '(1 -1)))
(display "(x^3+x^2+x+1)+(x-1) = ")
(apply-generic 'add a b)
(display "(x^3+x^2+x+1)*(x-1) = ")
(apply-generic 'mul a b)
done done done done done done done (x^3+x^2+x+1)+(x-1) = (dense-poly x 1 1 2 0) (x^3+x^2+x+1)*(x-1) = (dense-poly x 1 0 0 0 -1)
Suppose we want to have a polynomial system that is efficient for both sparse and dense polynomials. One way to do this is to allow both kinds of term-list representations in our system. The situation is analogous to the complex-number example of 2.4, where we allowed both rectangular and polar representations. To do this we must distinguish different types of term lists and make the operations on term lists generic. Redesign the polynomial system to implement this generalization. This is a major effort, not a local change.
We already have most things handled. Firstly, I renamed the tags to sparse-poly and dense-poly.
There are six generic functions for our polynomial package:
'add, 'sub, 'mul, 'negate, '=zero?, and 'make. We should expand this into 'make-dense-polynomial and
'make-sparse-polynomial.
(install-sparse-polynomial-package)
(install-dense-polynomial-package)
(define (install-polynomial-package)
(define (tag p) (attach-tag 'polynomial p))
(put '=zero? '(polynomial)
(lambda (p) (apply-generic '=zero? p)))
(put 'negate '(polynomial)
(lambda (p) (tag (apply-generic 'negate p))))
(put 'make-sparse-polynomial 'polynomial
(lambda (var terms)
(tag ((get 'make 'sparse-poly) var terms))))
(put 'make-dense-polynomial 'polynomial
(lambda (var terms)
(tag ((get 'make 'dense-poly) var terms))))
...)
The only difficult remaining thing would be handling operations involving two different types of polynomials, depending on how we've implemented type coercion. I handle this by converting to sparse - sparse operations by default.
(define (dense-poly->sparse-poly dense)
(let ((var (car dense))
(terms (cdr dense))
(order (length (cdr dense))))
((get 'make 'sparse-poly)
var
(map-indexed (lambda (term index) (list (- (- order index) 1) term)) terms))))
(define (put-poly-symb symb)
(put symb '(polynomial polynomial)
(lambda (p1 p2)
(tag
(let ((t1 (type-tag p1)) (t2 (type-tag p2)))
(cond ((eq? t1 t2) (apply-generic symb p1 p2))
((and (eq? t1 'sparse-poly)
(eq? t2 'dense-poly))
(apply-generic symb p1 (dense-poly->sparse-poly (contents p2))))
((and (eq? t1 'dense-poly)
(eq? t2 'sparse-poly))
(apply-generic symb (dense-poly->sparse-poly (contents p1)) p2))
(else (error "Symbol called with polynomials of invalid types:" symb t1 t2))))))))
(put-poly-symb 'add)
(put-poly-symb 'mul)
(put-poly-symb 'sub)
Working code test:
#lang sicp
(define pi 3.14159)
(define (square x) (* x x))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op
initial
(cdr sequence)))))
;; Define a map-indexed function. (map-indexed f '(a b c)) is
;; ((f a 0) (f b 1) (f c 2))
(define (map-indexed my-lambda lst)
(define (map-indexed-inner lst-cur counter)
(if (null? lst-cur) '()
(cons (my-lambda (car lst-cur) counter) (map-indexed-inner (cdr lst-cur) (+ counter 1)))))
(map-indexed-inner lst 0))
;; get and put definitions
(define operation-table '())
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (assoc-op key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc-op key (cdr records)))))
(define (put op type-tags proc)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(set-cdr! proc-pair-entry proc)
(set-car! (cdr op-list-entry)
(cons (cons type-tags proc) proc-list)))))
(set! operation-table
(cons (list op (list (cons type-tags proc)))
operation-table)))))
(define (get op type-tags)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(cdr proc-pair-entry)
#f)))
#f)))
;; Modified for ex2-78.
(define (attach-tag type-tag contents)
(if (equal? type-tag 'scheme-number)
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((number? datum) 'scheme-number)
(else (error "Bad tagged datum: TYPE-TAG" datum))))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((number? datum) datum)
(else (error "Bad tagged datum: CONTENTS" datum))))
(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))
(error
"No method for these types: APPLY-GENERIC"
(list op type-tags))))))
;; Number package
(define (install-scheme-number-package)
(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
(lambda (x) (tag x)))
(put '=zero? '(scheme-number)
(lambda (x) (= x 0)))
(put 'negate '(scheme-number)
(lambda (x) (- x)))
'done)
(install-scheme-number-package)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
;; ===================================================================
;; ======================== Rational package =========================
;; ===================================================================
(define (install-rational-package)
;; internal procedures
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
;; z1a/z1b = z2a/z2b iff z1a*z2b - z2a*z1b = 0
;; equ? for problem 2.79
(define (equ? z1 z2)
(= (- (* (numer z1) (denom z2))
(* (numer z2) (denom z1)))
0))
;; interface to rest of the system
(put 'equ? '(rational rational) equ?)
(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))))
;problem 2.80
(put '=zero? '(rational)
(lambda (a) (= (numer a) 0)))
(put 'negate '(rational)
(lambda (r) (tag (make-rat (- (numer r)) (denom r)))))
'done)
(install-rational-package)
(define (make-rational n d)
((get 'make 'rational) n d))
;; ===================================================================
;; ================= Complex polar and rectangular ===================
;; ===================================================================
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
;; interface to the rest of the system
(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))))
(put 'negate '(polar)
(lambda (z) (tag (make-from-mag-ang (magnitude z) (+ (angle z) pi)))))
'done)
(install-polar-package)
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y)
(cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
;; interface to the rest of the system
(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))))
(put 'negate '(rectangular)
(lambda (z) (tag (make-from-real-imag (- (real-part z) (- (imag-part z)))))))
'done)
(install-rectangular-package)
;; ===================================================================
;; ========================= Complex package =========================
;; ===================================================================
(define (install-complex-package)
;; imported procedures from rectangular
;; and polar packages
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (make-from-real-imag x y)
((get 'make-from-real-imag
'rectangular)
x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar)
r a))
;; internal procedures
(define (add-complex z1 z2)
(make-from-real-imag
(+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag
(- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang
(* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang
(/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
(define (equ? z1 z2) ; for problem 2.79
(and (= (real-part z1) (real-part z2))
(= (imag-part z1) (imag-part z2))))
;; interface to rest of the system
(put 'equ? '(complex complex) equ?)
(put 'real-part '(complex) real-part) ; Changes from problem 2.77
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(put 'negate '(complex)
(lambda (z) (tag (apply-generic 'negate z))))
(define (tag z) (attach-tag 'complex z))
(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))))
;problem 2.80
(put '=zero? '(complex)
(lambda (z) (and (= (real-part z) 0) (= (imag-part z) 0))))
'done)
(install-complex-package)
(define (=zero? a)
(apply-generic '=zero? a))
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (mul a b)
(apply-generic 'mul a b))
(define (add a b)
(apply-generic 'add a b))
(define (sub a b)
(apply-generic 'sub a b))
(define (equ? a b)
(apply-generic 'equ? a b))
(define (install-sparse-polynomial-package)
;; internal procedures
;; representation of poly
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p) (cdr p))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1)
(variable? v2)
(eq? v1 v2)))
(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))))))
;; representation of terms and term lists
(define (adjoin-term term term-list)
(if (=zero? (coeff term))
term-list
(cons term term-list)))
(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 (make-term order coeff)
(list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(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 var:
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 var:
MUL-POLY"
(list 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)))))))))
;; During construction, we don't check whether coefficients are zero
;; So now, we have to check all coefficients.
(define (=zero?-poly poly)
(accumulate (lambda (x y) (and y (=zero? (coeff x))))
#t
(term-list poly)))
;; Make sure to install the function
(put '=zero? '(sparse-poly) =zero?-poly)
;; Exercise 2-88
(define (negate-terms L)
(if (empty-termlist? L)
L
(let ((t (first-term L)) (r (rest-terms L)))
(adjoin-term (make-term (order t) (apply-generic 'negate (coeff t)))
(negate-terms r)))))
(define (sub-terms L1 L2)
(add-terms L1 (negate-terms L2)))
(define (sub-poly p1 p2)
(if (same-variable? (variable p1)
(variable p2))
(make-poly
(variable p1)
(sub-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var:
SUB-POLY"
(list p1 p2))))
(put 'sub '(sparse-poly sparse-poly)
(lambda (p1 p2)
(tag (sub-poly p1 p2))))
(put 'negate '(sparse-poly)
(lambda (p)
(tag (make-poly (variable p) (negate-terms (term-list p))))))
;; interface to rest of the system
(define (tag p) (attach-tag 'sparse-poly p))
(put 'add '(sparse-poly sparse-poly)
(lambda (p1 p2)
(tag (add-poly p1 p2))))
(put 'mul '(sparse-poly sparse-poly)
(lambda (p1 p2)
(tag (mul-poly p1 p2))))
(put 'make 'sparse-poly
(lambda (var terms)
(tag (make-poly var terms))))
'done)
(define (install-dense-polynomial-package)
;; internal procedures
;; representation of poly
;; Chop off the leading zeros of a term list.
(define (chop-leading-zeros L)
(cond ((null? L) L)
((apply-generic '=zero? (car L)) (chop-leading-zeros (cdr L)))
(else L)))
(define (make-poly variable term-list)
(cons variable (chop-leading-zeros term-list)))
(define (variable p) (car p))
(define (term-list p) (cdr p))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1)
(variable? v2)
(eq? v1 v2)))
;; Note: this is NOT generic. We could define a ((get 'make-zero type))
;; to make it generic.
(define (make-zero-terms l)
(if (= l 0) '() (cons 0 (make-zero-terms (- l 1)))))
;; returns the term list representing
;; (coeff)*(variable)^order * (polynomial represented by L)
(define (mul-term-by-all-terms order coeff L)
(if (null? L)
'()
(append (map (lambda (x)
(apply-generic 'mul x coeff))
L)
(make-zero-terms order))))
(define (mul-terms L1 L2)
(let ((length1 (length L1)) (length2 (length L2)))
(cond ((< length1 length2) (mul-terms L2 L1))
((= length2 0) '())
(else
(accumulate
(lambda (Lx Ly) (add-terms Lx Ly))
'()
(map-indexed
(lambda (coeff ctr)
;; multiply L2 polynomial by the term x*(var)^(order).
(mul-term-by-all-terms (- (- length1 ctr) 1) coeff L2))
L1))))))
(define (empty-termlist? term-list)
(null? term-list))
(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 var:
MUL-POLY"
(list p1 p2))))
(define (add-terms L1 L2)
(let ((length1 (length L1)) (length2 (length L2)))
(cond ((< length1 length2) (add-terms L2 L1))
((= length1 length2)
(map (lambda (x y)
(apply-generic 'add x y))
L1
L2))
(else (cons (car L1) (add-terms (cdr L1) L2))))))
(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 var:
ADD-POLY"
(list p1 p2))))
(define (=zero?-poly poly)
(accumulate (lambda (x y) (and y (=zero? x)))
#t
(term-list poly)))
(define (negate-terms L)
(map (lambda (x) (apply-generic 'negate x)) L))
(define (sub-terms L1 L2)
(add-terms L1 (negate-terms L2)))
(define (sub-poly p1 p2)
(if (same-variable? (variable p1)
(variable p2))
(make-poly
(variable p1)
(sub-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var:
SUB-POLY"
(list p1 p2))))
;; interface to rest of the system
(define (tag p) (attach-tag 'dense-poly p))
(put 'add '(dense-poly dense-poly)
(lambda (p1 p2)
(tag (add-poly p1 p2))))
(put 'mul '(dense-poly dense-poly)
(lambda (p1 p2)
(tag (mul-poly p1 p2))))
(put 'make 'dense-poly
(lambda (var terms)
(tag (make-poly var terms))))
(put 'sub '(dense-poly dense-poly)
(lambda (p1 p2)
(tag (sub-poly p1 p2))))
(put 'negate '(dense-poly)
(lambda (p)
(tag (make-poly (variable p) (negate-terms (term-list p))))))
(put '=zero? '(dense-poly) =zero?-poly)
'done)
(define (install-polynomial-package)
(define (tag p) (attach-tag 'polynomial p))
(put '=zero? '(polynomial)
(lambda (p) (apply-generic '=zero? p)))
(put 'negate '(polynomial)
(lambda (p) (tag (apply-generic 'negate p))))
(put 'make-sparse-polynomial 'polynomial
(lambda (var terms)
(tag ((get 'make 'sparse-poly) var terms))))
(put 'make-dense-polynomial 'polynomial
(lambda (var terms)
(tag ((get 'make 'dense-poly) var terms))))
(define (dense-poly->sparse-poly dense)
(let ((var (car dense))
(terms (cdr dense))
(order (length (cdr dense))))
((get 'make 'sparse-poly)
var
(map-indexed (lambda (term index) (list (- (- order index) 1) term)) terms))))
(define (put-poly-symb symb)
(put symb '(polynomial polynomial)
(lambda (p1 p2)
(tag
(let ((t1 (type-tag p1)) (t2 (type-tag p2)))
(cond ((eq? t1 t2) (apply-generic symb p1 p2))
((and (eq? t1 'sparse-poly)
(eq? t2 'dense-poly))
(apply-generic symb p1 (dense-poly->sparse-poly (contents p2))))
((and (eq? t1 'dense-poly)
(eq? t2 'sparse-poly))
(apply-generic symb (dense-poly->sparse-poly (contents p1)) p2))
(else (error "Symbol called with polynomials of invalid types:" symb t1 t2))))))))
(put-poly-symb 'add)
(put-poly-symb 'mul)
(put-poly-symb 'sub))
(install-sparse-polynomial-package)
(install-dense-polynomial-package)
(install-polynomial-package)
(define (make-dense-polynomial var terms)
((get 'make-dense-polynomial 'polynomial) var terms))
(define (make-sparse-polynomial var terms)
((get 'make-sparse-polynomial 'polynomial) var terms))
(define a (make-dense-polynomial 'x '(1 1 1 1)))
(define b (make-dense-polynomial 'x '(1 -1)))
(define c (make-sparse-polynomial 'x '((3 1) (2 1) (1 1) (0 1))))
(define d (make-sparse-polynomial 'x '((1 1) (0 -1))))
(display "dense-dense (x^3+x^2+x+1)+(x-1) = ")
(apply-generic 'add a b)
(display "dense-dense (x^3+x^2+x+1)*(x-1) = ")
(apply-generic 'mul a b)
(display "sparse-sparse (x^3+x^2+x+1)+(x-1) = ")
(apply-generic 'add c d)
(display "sparse-sparse (x^3+x^2+x+1)*(x-1) = ")
(apply-generic 'mul c d)
(display "dense-sparse (x^3+x^2+x+1)+(x-1) = ")
(apply-generic 'add a d)
(display "sparse-dense (x^3+x^2+x+1)*(x-1) = ")
(apply-generic 'mul c b)
done done done done done done done dense-dense (x^3+x^2+x+1)+(x-1) = (polynomial dense-poly x 1 1 2 0) dense-dense (x^3+x^2+x+1)*(x-1) = (polynomial dense-poly x 1 0 0 0 -1) sparse-sparse (x^3+x^2+x+1)+(x-1) = (polynomial sparse-poly x (3 1) (2 1) (1 2)) sparse-sparse (x^3+x^2+x+1)*(x-1) = (polynomial sparse-poly x (4 1) (0 -1)) dense-sparse (x^3+x^2+x+1)+(x-1) = (polynomial sparse-poly x (3 1) (2 1) (1 2)) sparse-dense (x^3+x^2+x+1)*(x-1) = (polynomial sparse-poly x (4 1) (0 -1))
A univariate polynomial can be divided by another one to produce a polynomial quotient and a polynomial remainder. For example,
$${x^5 - 1 \over x^2 - 1} \,=\, {x^3 + x,} \text{ remainder } {x - 1.} $$
Division can be performed via long division. That is, divide the highest-order term of the dividend by the highest-order term of the divisor. The result is the first term of the quotient. Next, multiply the result by the divisor, subtract that from the dividend, and produce the rest of the answer by recursively dividing the difference by the divisor. Stop when the order of the divisor exceeds the order of the dividend and declare the dividend to be the remainder. Also, if the dividend ever becomes zero, return zero as both quotient and remainder.
We can design a div-poly procedure on the model of add-poly and
mul-poly. The procedure checks to see if the two polys have the same
variable. If so, div-poly strips off the variable and passes the
problem to div-terms, which performs the division operation on term
lists. Div-poly finally reattaches the variable to the result supplied
by div-terms. It is convenient to design div-terms to compute
both the quotient and the remainder of a division. Div-terms can take
two term lists as arguments and return a list of the quotient term list and the
remainder term list.
Complete the following definition of div-terms by filling in the missing
expressions. Use this to implement div-poly, which takes two polys as
arguments and returns a list of the quotient and remainder polys.
(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
⟨compute rest of result recursively}⟩ ))
⟨form complete result⟩ ))))))
Given the new term $t$, we have:
$$\frac{P_1}{P_2} =\frac{P_1- t P_2+t P_2}{P_2} = t + \frac{P_1-t P_2}{P_2}$$
And the whole idea behind long division is to choose $t$ so that the leading term of $P_1$ cancels.
I do this subtraction using the function sub-terms which I defined in problem 2.88.
(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 (apply-generic 'div (coeff t1)
(coeff t2)))
(new-o (- (order t1)
(order t2))))
(let ((new-t (make-term new-o new-c)))
(let ((rest-of-result
(div-terms
(sub-terms L1 (mul-term-by-all-terms new-t L2))
L2)))
(let ((div-val (car rest-of-result))
(rem-val (cadr rest-of-result)))
(list (add-terms (list new-t) div-val)
rem-val)))))))))
Also, in order to do the plumbing for everything, I define
(define (div-poly p1 p2)
(if (same-variable? (variable p1)
(variable p2))
(let ((res (div-terms (term-list p1)
(term-list p2))))
(list (make-poly (variable p1) (car res)) (make-poly (variable p1) (cadr res))))
(error "Polys not in same var:
SUB-POLY"
(list p1 p2))))
(put 'div-poly '(polynomial polynomial)
(lambda (p1 p2)
(let ((res (div-poly p1 p2)))
(list (tag (car res)) (tag (cadr res))))))
#lang sicp
(define pi 3.14159)
(define (square x) (* x x))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op
initial
(cdr sequence)))))
;; get and put definitions
(define operation-table '())
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (assoc-op key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc-op key (cdr records)))))
(define (put op type-tags proc)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(set-cdr! proc-pair-entry proc)
(set-car! (cdr op-list-entry)
(cons (cons type-tags proc) proc-list)))))
(set! operation-table
(cons (list op (list (cons type-tags proc)))
operation-table)))))
(define (get op type-tags)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(cdr proc-pair-entry)
#f)))
#f)))
;; Modified for ex2-78.
(define (attach-tag type-tag contents)
(if (equal? type-tag 'scheme-number)
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((number? datum) 'scheme-number)
(else (error "Bad tagged datum: TYPE-TAG" datum))))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((number? datum) datum)
(else (error "Bad tagged datum: CONTENTS" datum))))
(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))
(error
"No method for these types: APPLY-GENERIC"
(list op type-tags))))))
;; Number package
(define (install-scheme-number-package)
(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
(lambda (x) (tag x)))
(put '=zero? '(scheme-number)
(lambda (x) (= x 0)))
(put 'negate '(scheme-number)
(lambda (x) (- x)))
'done)
(install-scheme-number-package)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
;; ===================================================================
;; ======================== Rational package =========================
;; ===================================================================
(define (install-rational-package)
;; internal procedures
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
;; z1a/z1b = z2a/z2b iff z1a*z2b - z2a*z1b = 0
;; equ? for problem 2.79
(define (equ? z1 z2)
(= (- (* (numer z1) (denom z2))
(* (numer z2) (denom z1)))
0))
;; interface to rest of the system
(put 'equ? '(rational rational) equ?)
(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))))
;problem 2.80
(put '=zero? '(rational)
(lambda (a) (= (numer a) 0)))
(put 'negate '(rational)
(lambda (r) (tag (make-rat (- (numer r)) (denom r)))))
'done)
(install-rational-package)
(define (make-rational n d)
((get 'make 'rational) n d))
;; ===================================================================
;; ================= Complex polar and rectangular ===================
;; ===================================================================
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
;; interface to the rest of the system
(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))))
(put 'negate '(polar)
(lambda (z) (tag (make-from-mag-ang (magnitude z) (+ (angle z) pi)))))
'done)
(install-polar-package)
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y)
(cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
;; interface to the rest of the system
(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))))
(put 'negate '(rectangular)
(lambda (z) (tag (make-from-real-imag (- (real-part z) (- (imag-part z)))))))
'done)
(install-rectangular-package)
;; ===================================================================
;; ========================= Complex package =========================
;; ===================================================================
(define (install-complex-package)
;; imported procedures from rectangular
;; and polar packages
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (make-from-real-imag x y)
((get 'make-from-real-imag
'rectangular)
x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar)
r a))
;; internal procedures
(define (add-complex z1 z2)
(make-from-real-imag
(+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag
(- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang
(* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang
(/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
(define (equ? z1 z2) ; for problem 2.79
(and (= (real-part z1) (real-part z2))
(= (imag-part z1) (imag-part z2))))
;; interface to rest of the system
(put 'equ? '(complex complex) equ?)
(put 'real-part '(complex) real-part) ; Changes from problem 2.77
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(put 'negate '(complex)
(lambda (z) (tag (apply-generic 'negate z))))
(define (tag z) (attach-tag 'complex z))
(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))))
;problem 2.80
(put '=zero? '(complex)
(lambda (z) (and (= (real-part z) 0) (= (imag-part z) 0))))
'done)
(install-complex-package)
(define (=zero? a)
(apply-generic '=zero? a))
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (mul a b)
(apply-generic 'mul a b))
(define (add a b)
(apply-generic 'add a b))
(define (sub a b)
(apply-generic 'sub a b))
(define (equ? a b)
(apply-generic 'equ? a b))
(define (install-polynomial-package)
;; internal procedures
;; representation of poly
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p) (cdr p))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1)
(variable? v2)
(eq? v1 v2)))
(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))))))
;; representation of terms and term lists
(define (adjoin-term term term-list)
(if (=zero? (coeff term))
term-list
(cons term term-list)))
(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 (make-term order coeff)
(list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(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 var:
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 var:
MUL-POLY"
(list 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)))))))))
;; (ct1 x^(ot1)+rest1)/(ct2 x^(ot2)+rest2)
;; =(poly1 - (ct1/ct2) x^(ot1-ot2)(poly2) + (ct1/ct2) x^(ot1-ot2)(poly2))/(poly2)
;; =(ct1/ct2) x^(ot1-ot2) + (poly1 - (ct1/ct2) x^(ot1-ot2)(poly2))/poly2
;; During construction, we don't check whether coefficients are zero
;; So now, we have to check all coefficients.
(define (=zero?-poly poly)
(accumulate (lambda (x y) (and y (=zero? (coeff x))))
#t
(term-list poly)))
;; Make sure to install the function
(put '=zero? '(polynomial) =zero?-poly)
;; Exercise 2-88
(define (negate-terms L)
(if (empty-termlist? L)
L
(let ((t (first-term L)) (r (rest-terms L)))
(adjoin-term (make-term (order t) (apply-generic 'negate (coeff t)))
(negate-terms r)))))
(define (sub-terms L1 L2)
(add-terms L1 (negate-terms L2)))
(define (sub-poly p1 p2)
(if (same-variable? (variable p1)
(variable p2))
(make-poly
(variable p1)
(sub-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var:
SUB-POLY"
(list p1 p2))))
(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 (apply-generic 'div (coeff t1)
(coeff t2)))
(new-o (- (order t1)
(order t2))))
(let ((new-t (make-term new-o new-c)))
(let ((rest-of-result
(div-terms
(sub-terms L1 (mul-term-by-all-terms new-t L2))
L2)))
(let ((div-val (car rest-of-result))
(rem-val (cadr rest-of-result)))
(list (add-terms (list new-t) div-val)
rem-val)))))))))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2)
(tag (sub-poly p1 p2))))
(define (div-poly p1 p2)
(if (same-variable? (variable p1)
(variable p2))
(let ((res (div-terms (term-list p1)
(term-list p2))))
(list (make-poly (variable p1) (car res)) (make-poly (variable p1) (cadr res))))
(error "Polys not in same var:
SUB-POLY"
(list p1 p2))))
(put 'div-poly '(polynomial polynomial)
(lambda (p1 p2)
(let ((res (div-poly p1 p2)))
(list (tag (car res)) (tag (cadr res))))))
(put 'negate '(polynomial)
(lambda (p)
(tag (make-poly (variable p) (negate-terms (term-list p))))))
;; interface to rest of the system
(define (tag p) (attach-tag 'polynomial p))
(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 'make 'polynomial
(lambda (var terms)
(tag (make-poly var terms))))
'done)
(install-polynomial-package)
(define (make-polynomial var terms)
((get 'make 'polynomial) var terms))
(define a (make-polynomial 'x '((5 1) (0 -1))))
(define b (make-polynomial 'x '((2 1) (0 -1))))
(define c (make-polynomial 'x '((1 1) (0 -1))))
(display "(x^5-1)/(x^2-1) = ")
(apply-generic 'div-poly a b)
(display "(x^5-1)/(x-1) = ")
(apply-generic 'div-poly a c)
done done done done done done (x^5-1)/(x^2-1) = ((polynomial x (3 1) (1 1)) (polynomial x (1 1) (0 -1))) (x^5-1)/(x-1) = ((polynomial x (4 1) (3 1) (2 1) (1 1) (0 1)) (polynomial x))
By imposing an ordering on variables, extend the polynomial package so that addition and multiplication of polynomials works for polynomials in different variables. (This is not easy!)
We have a few different options here:
set of monomials. variables with variable-list and use the ordering imposed by that list.I'm going with the third option. The monomial $C x^a y^b$
will be represented as (list (list (list 'x a) (list 'y b)) C). So now, (coeff term) still behaves the same,
but (order term) gives the order of the lits of variables.
First, let's make sure I can define the ordering on monomials properly:
#lang sicp
;; insertion sort from https://gist.github.com/miyukino/5652107
(define (insert L M comp)
(if (null? L) M
(if (null? M) L
(if (comp (car L) (car M))
(cons (car L) (insert (cdr L) M comp))
(cons (car M) (insert (cdr M) L comp))))))
(define (insertionsort L comp)
(if (null? L) '()
(insert (list (car L)) (insertionsort (cdr L) comp) comp)))
(define sort insertionsort)
(define (symbol<? s1 s2)
(string<? (symbol->string s1) (symbol->string s2)))
(define (symbol=? s1 s2)
(string=? (symbol->string s1) (symbol->string s2)))
;; Lexicographic ordering on monomials. If we want the highest order monomial as the first element, we
;; could sort from least to greatest where we define '() to be the greatest element, so this definition
;; might look a bit backwards.
(define (single-order<? so1 so2)
(or (symbol<? (car so1) (car so2))
(< (cadr so2) (cadr so1))))
(define (order<? o1 o2)
(cond
((null? o1) #f)
((null? o2) #t)
((< (length o2) (length o1)) #t)
((single-order<? (car o1) (car o2)) #t)
((single-order<? (car o2) (car o1)) #f)
(else (order<? (cdr o1) (cdr o2)))))
(define l1 '((x 2) (y 1)))
(define l2 '((x 2) (y 2)))
(define l3 (sort '((x 2) (y 2) (foobar 10) (a 4)) single-order<?))
(define l4 '())
(sort (list l1 l2 l3 l4) order<?)
(((foobar 10) (a 4) (x 2) (y 2)) ((x 2) (y 2)) ((x 2) (y 1)) ())
Next, we can define a function to create a correct polynomial from a unsorted list of monomials (unsorted because I can never remember the correct way to do things).
(define (install-polynomial-package)
(define (single-order<? so1 so2)
(or (symbol<? (car so1) (car so2))
(< (cadr so2) (cadr so1))))
(define (order<? o1 o2)
(cond
((null? o1) #f)
((null? o2) #t)
((< (length o2) (length o1)) #t)
((single-order<? (car o1) (car o2)) #t)
((single-order<? (car o2) (car o1)) #f)
(else (order<? (cdr o1) (cdr o2)))))
;; Term list should be a list of (list coeff monomial)
;; monomial is of the form '((x 3) (y 2) (z 4)) to represent x^3*y^2*z^4.
(define (make-mono coeff order) (list coeff order))
(define (coeff mono) (car mono))
(define (order mono) (cadr mono))
(define (make-poly-from-unsorted term-list)
(define (sort-monomial mono)
(make-mono (coeff mono) (sort (order mono) single-order<?)))
(define (monomial-compare x y)
(order<? (order x) (order y)))
(sort (map sort-monomial term-list) monomial-compare))
(define (tag p) (attach-tag 'polynomial p))
(put 'make 'polynomial
(lambda (terms)
(tag (make-poly-from-unsorted terms))))
...
'done)
Now, add-poly is going to be basically the same as add-terms,
except instead of < to compare orders, we'll have to use order<?.
We'll also have to define adjoin-term correctly.
negate and sub are easy.
Testing some polynomial multiplication examples:
#lang sicp
;; insertion sort from https://gist.github.com/miyukino/5652107
(define (insert L M comp)
(if (null? L) M
(if (null? M) L
(if (comp (car L) (car M))
(cons (car L) (insert (cdr L) M comp))
(cons (car M) (insert (cdr M) L comp))))))
(define (insertionsort L comp)
(if (null? L) '()
(insert (list (car L)) (insertionsort (cdr L) comp) comp)))
(define sort insertionsort)
(define (symbol<? s1 s2)
(string<? (symbol->string s1) (symbol->string s2)))
(define (symbol=? s1 s2)
(string=? (symbol->string s1) (symbol->string s2)))
(define pi 3.14159)
(define (square x) (* x x))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op
initial
(cdr sequence)))))
;; get and put definitions
(define operation-table '())
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (assoc-op key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc-op key (cdr records)))))
(define (put op type-tags proc)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(set-cdr! proc-pair-entry proc)
(set-car! (cdr op-list-entry)
(cons (cons type-tags proc) proc-list)))))
(set! operation-table
(cons (list op (list (cons type-tags proc)))
operation-table)))))
(define (get op type-tags)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(cdr proc-pair-entry)
#f)))
#f)))
;; Modified for ex2-78.
(define (attach-tag type-tag contents)
(if (equal? type-tag 'scheme-number)
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((number? datum) 'scheme-number)
(else (error "Bad tagged datum: TYPE-TAG" datum))))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((number? datum) datum)
(else (error "Bad tagged datum: CONTENTS" datum))))
(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))
(error
"No method for these types: APPLY-GENERIC"
(list op type-tags))))))
;; Number package
(define (install-scheme-number-package)
(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
(lambda (x) (tag x)))
(put '=zero? '(scheme-number)
(lambda (x) (= x 0)))
(put 'negate '(scheme-number)
(lambda (x) (- x)))
'done)
(install-scheme-number-package)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
;; ===================================================================
;; ======================== Rational package =========================
;; ===================================================================
(define (install-rational-package)
;; internal procedures
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
;; z1a/z1b = z2a/z2b iff z1a*z2b - z2a*z1b = 0
;; equ? for problem 2.79
(define (equ? z1 z2)
(= (- (* (numer z1) (denom z2))
(* (numer z2) (denom z1)))
0))
;; interface to rest of the system
(put 'equ? '(rational rational) equ?)
(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))))
;problem 2.80
(put '=zero? '(rational)
(lambda (a) (= (numer a) 0)))
(put 'negate '(rational)
(lambda (r) (tag (make-rat (- (numer r)) (denom r)))))
'done)
(install-rational-package)
(define (make-rational n d)
((get 'make 'rational) n d))
;; ===================================================================
;; ================= Complex polar and rectangular ===================
;; ===================================================================
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
;; interface to the rest of the system
(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))))
(put 'negate '(polar)
(lambda (z) (tag (make-from-mag-ang (magnitude z) (+ (angle z) pi)))))
'done)
(install-polar-package)
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y)
(cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
;; interface to the rest of the system
(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))))
(put 'negate '(rectangular)
(lambda (z) (tag (make-from-real-imag (- (real-part z) (- (imag-part z)))))))
'done)
(install-rectangular-package)
;; ===================================================================
;; ========================= Complex package =========================
;; ===================================================================
(define (install-complex-package)
;; imported procedures from rectangular
;; and polar packages
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (make-from-real-imag x y)
((get 'make-from-real-imag
'rectangular)
x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar)
r a))
;; internal procedures
(define (add-complex z1 z2)
(make-from-real-imag
(+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag
(- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang
(* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang
(/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
(define (equ? z1 z2) ; for problem 2.79
(and (= (real-part z1) (real-part z2))
(= (imag-part z1) (imag-part z2))))
;; interface to rest of the system
(put 'equ? '(complex complex) equ?)
(put 'real-part '(complex) real-part) ; Changes from problem 2.77
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(put 'negate '(complex)
(lambda (z) (tag (apply-generic 'negate z))))
(define (tag z) (attach-tag 'complex z))
(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))))
;problem 2.80
(put '=zero? '(complex)
(lambda (z) (and (= (real-part z) 0) (= (imag-part z) 0))))
'done)
(install-complex-package)
(define (=zero? a)
(apply-generic '=zero? a))
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (mul a b)
(apply-generic 'mul a b))
(define (add a b)
(apply-generic 'add a b))
(define (sub a b)
(apply-generic 'sub a b))
(define (equ? a b)
(apply-generic 'equ? a b))
(define (install-polynomial-package)
(define (single-order<? so1 so2)
(or (symbol<? (car so1) (car so2))
(< (cadr so2) (cadr so1))))
(define (order<? o1 o2)
(cond
((null? o1) #f)
((null? o2) #t)
((< (length o2) (length o1)) #t)
((< (length o1) (length o2)) #f)
((single-order<? (car o1) (car o2)) #t)
((single-order<? (car o2) (car o1)) #f)
(else (order<? (cdr o1) (cdr o2)))))
;; Term list should be a list of (list coeff monomial)
;; monomial is of the form '((x 3) (y 2) (z 4)) to represent x^3*y^2*z^4.
(define (make-mono coeff order) (list coeff order))
(define (coeff mono) (car mono))
(define (order mono) (cadr mono))
(define (make-poly-from-unsorted term-list)
(define (sort-monomial mono)
(make-mono (coeff mono) (sort (order mono) single-order<?)))
(define (monomial-compare x y)
(order<? (order x) (order y)))
(sort (map sort-monomial term-list) monomial-compare))
;; negate
(define (negate polynomial)
(map (lambda (mono)
(make-mono (apply-generic 'negate (coeff mono))
(order mono))) polynomial))
(define (empty-polynomial? poly)
(null? poly))
(define (first-monomial poly)
(car poly))
(define (rest-monomials poly)
(cdr poly))
(define (adjoin-term term polynomial)
(if (apply-generic '=zero? (coeff term))
polynomial
(cons term polynomial)))
;; add-poly
(define (add-polys L1 L2)
(cond
((empty-polynomial? L1) L2)
((empty-polynomial? L2) L1)
(else
(let ((t1 (first-monomial L1))
(t2 (first-monomial L2)))
(cond
((order<? (order t1) (order t2) )
(adjoin-term
t1
(add-polys (rest-monomials L1)
L2)))
((order<? (order t2) (order t1))
(adjoin-term
t2
(add-polys
L1
(rest-monomials L2))))
(else
(adjoin-term
(make-mono
;(define (make-mono coeff order) (list coeff order))
(apply-generic 'add (coeff t1)
(coeff t2))
(order t1))
(add-polys
(rest-monomials L1)
(rest-monomials L2)))))))))
(define (sub-polys p1 p2)
(add-polys p1 (negate p2)))
(define (adjoin-order single-order order)
(if (= (cadr single-order) 0)
order
(cons single-order order)))
(define (add-orders o1 o2)
(cond
((null? o1) o2)
((null? o2) o1)
(else
(let ((so1 (car o1))
(so2 (car o2)))
(cond
((symbol<? (car so1) (car so2))
(adjoin-order
so1
(add-orders (cdr o1)
o2)))
((symbol<? (car so2) (car so1))
(adjoin-order
so2
(add-orders
o1
(cdr o2))))
(else
(adjoin-order
(list
(car so1)
(+ (cadr so1) (cadr so2)))
(add-orders
(cdr o1)
(cdr o2)))))))))
;; mul-poly
(define (mul-mono-by-poly m1 P)
(define (mul-mono-by-poly-inner m1 P)
(if (empty-polynomial? P)
'()
(let ((m2 (first-monomial P)))
(adjoin-term
(make-mono
(apply-generic 'mul (coeff m1) (coeff m2))
(add-orders (order m1) (order m2)))
;; If m2 < m3, does m1*m2 < m1*m3?
;; NO!
;; '((a 3)) < '((b 3)) <-- true
;; '((a 3)) * '((a 1)) = '((a 4))
;; '((b 3)) * '((a 1)) = '((a 1) (b 3))
;; So with my definition, '((a 1) (b 3)) < '((a 4))
;; Therefore, we need to make sure we sort the result.
(mul-mono-by-poly-inner
m1
(rest-monomials P))))))
(make-poly-from-unsorted (mul-mono-by-poly-inner m1 P)))
(define (mul-polys P1 P2)
(if (empty-polynomial? P1)
'()
(add-polys
(mul-mono-by-poly
(first-monomial P1) P2)
(mul-polys (rest-monomials P1) P2))))
(define (tag p) (attach-tag 'polynomial p))
(put 'make 'polynomial
(lambda (terms)
(tag (make-poly-from-unsorted terms))))
(put 'negate '(polynomial)
(lambda (p) (tag (negate p))))
(put 'add '(polynomial polynomial)
(lambda (p1 p2) (tag (add-polys p1 p2))))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2)
(tag (sub-polys p1 p2))))
(put 'mul '(polynomial polynomial)
(lambda (p1 p2) (tag (mul-polys p1 p2))))
'done)
(install-polynomial-package)
(define (make-polynomial terms)
((get 'make 'polynomial) terms))
(define l1 '((x 2) (y 1)))
(define l2 '((x 2) (y 2)))
;;(define l3 (sort '((x 2) (y 2) (b 10) (a 4)) single-order<?))
(define l3 '((x 2) (y 2) (b 10) (a 4)))
(define l4 '())
(define p1 (make-polynomial (list (list 1 l1) (list -1 l2) (list 3 l3) (list -10 l4))))
(define p2 (apply-generic 'negate p1))
(define p3 (make-polynomial '((1 ((x 3))) (1 ((x 1))))))
(define p4 (make-polynomial '((1 ((x 2))) (1 ()) (-1 ((y 1))))))
(define p5 (make-polynomial '((1 ((x 4))) (1 ((x 3))) (1 ((x 2))) (1 ((x 1))) (1 ()))))
(define p6 (make-polynomial '((1 ((x 1))) (-1 ()))))
;;p1
;;p2
(apply-generic 'add p1 p3)
;;(apply-generic 'add p1 p1)
;;(apply-generic 'add p1 p1)
(display "(x^3+x)(x^2-y+1) = -x^3y -xy + x^5 + 2x^3 + x^2 + x") (newline)
(apply-generic 'mul p3 p4)
(display "(x^4+x^3+x^2+x+1)(x-1) = x^5 - 1") (newline)
(apply-generic 'mul p5 p6)
done done done done done done (polynomial (3 ((b 10) (a 4) (x 2) (y 2))) (-1 ((x 2) (y 2))) (1 ((x 2) (y 1))) (1 ((x 3))) (1 ((x 1))) (-10 ())) (x^3+x)(x^2-y+1) = -x^3y -xy + x^5 + 2x^3 + x^2 + x (polynomial (-1 ((x 3) (y 1))) (-1 ((x 1) (y 1))) (1 ((x 5))) (2 ((x 3))) (1 ((x 1)))) (x^4+x^3+x^2+x+1)(x-1) = x^5 - 1 (polynomial (1 ((x 5))) (-1 ()))
Modify the rational-arithmetic
package to use generic operations, but change make-rat so that it does
not attempt to reduce fractions to lowest terms. Test your system by calling
make-rational on two polynomials to produce a rational function:
(define p1 (make-polynomial 'x '((2 1) (0 1))))
(define p2 (make-polynomial 'x '((3 1) (0 1))))
(define rf (make-rational p2 p1))
Now add rf to itself, using add. You will observe that this
addition procedure does not reduce fractions to lowest terms.
We have the following rational function
$$r_f = \frac{x^3+1}{x^2+1}$$
We add rational numbers by doing
$$\frac{a}{b}+\frac{c}{d} = \frac{ad+bc}{bd}$$
According to this rule
#lang sicp
(define pi 3.14159)
(define (square x) (* x x))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op
initial
(cdr sequence)))))
;; get and put definitions
(define operation-table '())
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (assoc-op key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc-op key (cdr records)))))
(define (put op type-tags proc)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(set-cdr! proc-pair-entry proc)
(set-car! (cdr op-list-entry)
(cons (cons type-tags proc) proc-list)))))
(set! operation-table
(cons (list op (list (cons type-tags proc)))
operation-table)))))
(define (get op type-tags)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(cdr proc-pair-entry)
#f)))
#f)))
;; Modified for ex2-78.
(define (attach-tag type-tag contents)
(if (equal? type-tag 'scheme-number)
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((number? datum) 'scheme-number)
(else (error "Bad tagged datum: TYPE-TAG" datum))))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((number? datum) datum)
(else (error "Bad tagged datum: CONTENTS" datum))))
(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))
(error
"No method for these types: APPLY-GENERIC"
(list op type-tags))))))
;; Number package
(define (install-scheme-number-package)
(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
(lambda (x) (tag x)))
(put '=zero? '(scheme-number)
(lambda (x) (= x 0)))
(put 'negate '(scheme-number)
(lambda (x) (- x)))
'done)
(install-scheme-number-package)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
;; ===================================================================
;; ======================== Rational package =========================
;; ===================================================================
(define (install-rational-package)
;; internal procedures
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(cons n d))
(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 (=zero? x) (apply-generic '=zero? x))
(define (negate x) (apply-generic 'negate x))
(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))))
;; z1a/z1b = z2a/z2b iff z1amulz2b - z2amulz1b = 0
;; equ? for problem 2.79
(define (equ? z1 z2)
(=zero? (sub (mul (numer z1) (denom z2))
(mul (numer z2) (denom z1)))))
;; interface to rest of the system
(put 'equ? '(rational rational) equ?)
(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))))
;problem 2.80
(put '=zero? '(rational)
(lambda (a) (=zero? (numer a))))
(put 'negate '(rational)
(lambda (r) (tag (make-rat (negate (numer r)) (denom r)))))
'done)
(install-rational-package)
(define (make-rational n d)
((get 'make 'rational) n d))
(define (=zero? a)
(apply-generic '=zero? a))
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (mul a b)
(apply-generic 'mul a b))
(define (add a b)
(apply-generic 'add a b))
(define (sub a b)
(apply-generic 'sub a b))
(define (equ? a b)
(apply-generic 'equ? a b))
(define (install-polynomial-package)
;; internal procedures
;; representation of poly
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p) (cdr p))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1)
(variable? v2)
(eq? v1 v2)))
(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))))))
;; representation of terms and term lists
(define (adjoin-term term term-list)
(if (=zero? (coeff term))
term-list
(cons term term-list)))
(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 (make-term order coeff)
(list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(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 var:
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 var:
MUL-POLY"
(list 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)))))))))
;; During construction, we don't check whether coefficients are zero
;; So now, we have to check all coefficients.
(define (=zero?-poly poly)
(accumulate (lambda (x y) (and y (=zero? (coeff x))))
#t
(term-list poly)))
;; Make sure to install the function
(put '=zero? '(polynomial) =zero?-poly)
;; Exercise 2-88
(define (negate-terms L)
(if (empty-termlist? L)
L
(let ((t (first-term L)) (r (rest-terms L)))
(adjoin-term (make-term (order t) (apply-generic 'negate (coeff t)))
(negate-terms r)))))
(define (sub-terms L1 L2)
(add-terms L1 (negate-terms L2)))
(define (sub-poly p1 p2)
(if (same-variable? (variable p1)
(variable p2))
(make-poly
(variable p1)
(sub-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var:
SUB-POLY"
(list p1 p2))))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2)
(tag (sub-poly p1 p2))))
(put 'negate '(polynomial)
(lambda (p)
(tag (make-poly (variable p) (negate-terms (term-list p))))))
;; interface to rest of the system
(define (tag p) (attach-tag 'polynomial p))
(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 'make 'polynomial
(lambda (var terms)
(tag (make-poly var terms))))
'done)
(install-polynomial-package)
(define (make-polynomial var terms)
((get 'make 'polynomial) var terms))
(define p1 (make-polynomial 'x '((2 1) (0 1))))
(define p2 (make-polynomial 'x '((3 1) (0 1))))
(define rf (make-rational p2 p1))
rf
(apply-generic 'add rf rf)
done done done (rational (polynomial x (3 1) (0 1)) polynomial x (2 1) (0 1)) (rational (polynomial x (5 2) (3 2) (2 2) (0 2)) polynomial x (4 1) (2 2) (0 1))
Using div-terms, implement
the procedure remainder-terms and use this to define gcd-terms as
above. Now write a procedure gcd-poly that computes the polynomial
GCD of two polys. (The procedure should signal an error if the two
polys are not in the same variable.) Install in the system a generic operation
greatest-common-divisor that reduces to gcd-poly for polynomials
and to ordinary gcd for ordinary numbers. As a test, try
(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)
and check your result by hand.
Let's do it by hand first. Writing this out in excruciating detail...
Checking, we do in fact get the same result.
#lang sicp
(define pi 3.14159)
(define (square x) (* x x))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op
initial
(cdr sequence)))))
;; get and put definitions
(define operation-table '())
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (assoc-op key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc-op key (cdr records)))))
(define (put op type-tags proc)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(set-cdr! proc-pair-entry proc)
(set-car! (cdr op-list-entry)
(cons (cons type-tags proc) proc-list)))))
(set! operation-table
(cons (list op (list (cons type-tags proc)))
operation-table)))))
(define (get op type-tags)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(cdr proc-pair-entry)
#f)))
#f)))
;; Modified for ex2-78.
(define (attach-tag type-tag contents)
(if (equal? type-tag 'scheme-number)
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((number? datum) 'scheme-number)
(else (error "Bad tagged datum: TYPE-TAG" datum))))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((number? datum) datum)
(else (error "Bad tagged datum: CONTENTS" datum))))
(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))
(error
"No method for these types: APPLY-GENERIC"
(list op type-tags))))))
;; Number package
(define (install-scheme-number-package)
(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
(lambda (x) (tag x)))
(put '=zero? '(scheme-number)
(lambda (x) (= x 0)))
(put 'negate '(scheme-number)
(lambda (x) (- x)))
'done)
(install-scheme-number-package)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
;; ===================================================================
;; ======================== Rational package =========================
;; ===================================================================
(define (install-rational-package)
;; internal procedures
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
;; z1a/z1b = z2a/z2b iff z1a*z2b - z2a*z1b = 0
;; equ? for problem 2.79
(define (equ? z1 z2)
(= (- (* (numer z1) (denom z2))
(* (numer z2) (denom z1)))
0))
;; interface to rest of the system
(put 'equ? '(rational rational) equ?)
(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))))
;problem 2.80
(put '=zero? '(rational)
(lambda (a) (= (numer a) 0)))
(put 'negate '(rational)
(lambda (r) (tag (make-rat (- (numer r)) (denom r)))))
'done)
(install-rational-package)
(define (make-rational n d)
((get 'make 'rational) n d))
;; ===================================================================
;; ================= Complex polar and rectangular ===================
;; ===================================================================
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
;; interface to the rest of the system
(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))))
(put 'negate '(polar)
(lambda (z) (tag (make-from-mag-ang (magnitude z) (+ (angle z) pi)))))
'done)
(install-polar-package)
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y)
(cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
;; interface to the rest of the system
(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))))
(put 'negate '(rectangular)
(lambda (z) (tag (make-from-real-imag (- (real-part z) (- (imag-part z)))))))
'done)
(install-rectangular-package)
;; ===================================================================
;; ========================= Complex package =========================
;; ===================================================================
(define (install-complex-package)
;; imported procedures from rectangular
;; and polar packages
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (make-from-real-imag x y)
((get 'make-from-real-imag
'rectangular)
x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar)
r a))
;; internal procedures
(define (add-complex z1 z2)
(make-from-real-imag
(+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag
(- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang
(* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang
(/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
(define (equ? z1 z2) ; for problem 2.79
(and (= (real-part z1) (real-part z2))
(= (imag-part z1) (imag-part z2))))
;; interface to rest of the system
(put 'equ? '(complex complex) equ?)
(put 'real-part '(complex) real-part) ; Changes from problem 2.77
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(put 'negate '(complex)
(lambda (z) (tag (apply-generic 'negate z))))
(define (tag z) (attach-tag 'complex z))
(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))))
;problem 2.80
(put '=zero? '(complex)
(lambda (z) (and (= (real-part z) 0) (= (imag-part z) 0))))
'done)
(install-complex-package)
(define (=zero? a)
(apply-generic '=zero? a))
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (mul a b)
(apply-generic 'mul a b))
(define (add a b)
(apply-generic 'add a b))
(define (sub a b)
(apply-generic 'sub a b))
(define (equ? a b)
(apply-generic 'equ? a b))
(define (install-polynomial-package)
;; internal procedures
;; representation of poly
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p) (cdr p))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1)
(variable? v2)
(eq? v1 v2)))
(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))))))
;; representation of terms and term lists
(define (adjoin-term term term-list)
(if (=zero? (coeff term))
term-list
(cons term term-list)))
(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 (make-term order coeff)
(list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(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 var:
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 var:
MUL-POLY"
(list 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)))))))))
;; (ct1 x^(ot1)+rest1)/(ct2 x^(ot2)+rest2)
;; =(poly1 - (ct1/ct2) x^(ot1-ot2)(poly2) + (ct1/ct2) x^(ot1-ot2)(poly2))/(poly2)
;; =(ct1/ct2) x^(ot1-ot2) + (poly1 - (ct1/ct2) x^(ot1-ot2)(poly2))/poly2
;; During construction, we don't check whether coefficients are zero
;; So now, we have to check all coefficients.
(define (=zero?-poly poly)
(accumulate (lambda (x y) (and y (=zero? (coeff x))))
#t
(term-list poly)))
;; Make sure to install the function
(put '=zero? '(polynomial) =zero?-poly)
;; Exercise 2-88
(define (negate-terms L)
(if (empty-termlist? L)
L
(let ((t (first-term L)) (r (rest-terms L)))
(adjoin-term (make-term (order t) (apply-generic 'negate (coeff t)))
(negate-terms r)))))
(define (sub-terms L1 L2)
(add-terms L1 (negate-terms L2)))
(define (sub-poly p1 p2)
(if (same-variable? (variable p1)
(variable p2))
(make-poly
(variable p1)
(sub-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var:
SUB-POLY"
(list p1 p2))))
(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 (apply-generic 'div (coeff t1)
(coeff t2)))
(new-o (- (order t1)
(order t2))))
(let ((new-t (make-term new-o new-c)))
(let ((rest-of-result
(div-terms
(sub-terms L1 (mul-term-by-all-terms new-t L2))
L2)))
(let ((div-val (car rest-of-result))
(rem-val (cadr rest-of-result)))
(list (add-terms (list new-t) div-val)
rem-val)))))))))
(define (remainder-terms L1 L2)
(cadr (div-terms L1 L2)))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2)
(tag (sub-poly p1 p2))))
(define (div-poly p1 p2)
(if (same-variable? (variable p1)
(variable p2))
(let ((res (div-terms (term-list p1)
(term-list p2))))
(list (make-poly (variable p1) (car res)) (make-poly (variable p1) (cadr res))))
(error "Polys not in same var:
SUB-POLY"
(list p1 p2))))
(define (poly-remainder p1 p2)
(cadr (div-poly p1 p2)))
(define (poly-gcd a b)
(if (=zero?-poly b)
a
(poly-gcd b (poly-remainder a b))))
(put 'remainder '(polynomial polynomial)
(lambda (p1 p2)
(tag (poly-remainder p1 p2))))
(put 'gcd '(polynomial polynomial)
(lambda (p1 p2)
(tag (poly-gcd p1 p2))))
(put 'div-poly '(polynomial polynomial)
(lambda (p1 p2)
(let ((res (div-poly p1 p2)))
(list (tag (car res)) (tag (cadr res))))))
(put 'negate '(polynomial)
(lambda (p)
(tag (make-poly (variable p) (negate-terms (term-list p))))))
;; interface to rest of the system
(define (tag p) (attach-tag 'polynomial p))
(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 'make 'polynomial
(lambda (var terms)
(tag (make-poly var terms))))
'done)
(install-polynomial-package)
(define (make-polynomial var terms)
((get 'make 'polynomial) var terms))
(define p1
(make-polynomial
'x '((4 1) (3 -1) (2 -2) (1 2))))
(define p2
(make-polynomial
'x '((3 1) (1 -1))))
(apply-generic 'gcd p1 p2)
done done done done done done (polynomial x (2 -1) (1 1))
Define $P_1$, $P_2$, and $P_3$ to be the polynomials
$$\begin{array}{rl} P_1: & x^2 - 2x + 1, \ P_2: & 11x^2 + 7, \ P_3: & 13x + 5. \end{array} $$
Now define $Q_1$ to be the product of $P_1$ and $P_2$, and $Q_2$ to be
the product of $P_1$ and $P_3$, and use greatest-common-divisor
(Exercise 2.94) to compute the GCD of $Q_1$ and $Q_2$.
Note that the answer is not the same as $P_1$. This example introduces
noninteger operations into the computation, causing difficulties with the
GCD algorithm. To understand what is happening, try tracing
gcd-terms while computing the GCD or try performing the
division by hand.
#lang sicp
(define pi 3.14159)
(define (square x) (* x x))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op
initial
(cdr sequence)))))
;; get and put definitions
(define operation-table '())
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (assoc-op key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc-op key (cdr records)))))
(define (put op type-tags proc)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(set-cdr! proc-pair-entry proc)
(set-car! (cdr op-list-entry)
(cons (cons type-tags proc) proc-list)))))
(set! operation-table
(cons (list op (list (cons type-tags proc)))
operation-table)))))
(define (get op type-tags)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(cdr proc-pair-entry)
#f)))
#f)))
;; Modified for ex2-78.
(define (attach-tag type-tag contents)
(if (equal? type-tag 'scheme-number)
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((number? datum) 'scheme-number)
(else (error "Bad tagged datum: TYPE-TAG" datum))))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((number? datum) datum)
(else (error "Bad tagged datum: CONTENTS" datum))))
(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))
(error
"No method for these types: APPLY-GENERIC"
(list op type-tags))))))
;; Number package
(define (install-scheme-number-package)
(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
(lambda (x) (tag x)))
(put '=zero? '(scheme-number)
(lambda (x) (= x 0)))
(put 'negate '(scheme-number)
(lambda (x) (- x)))
'done)
(install-scheme-number-package)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
;; ===================================================================
;; ======================== Rational package =========================
;; ===================================================================
(define (install-rational-package)
;; internal procedures
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
;; z1a/z1b = z2a/z2b iff z1a*z2b - z2a*z1b = 0
;; equ? for problem 2.79
(define (equ? z1 z2)
(= (- (* (numer z1) (denom z2))
(* (numer z2) (denom z1)))
0))
;; interface to rest of the system
(put 'equ? '(rational rational) equ?)
(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))))
;problem 2.80
(put '=zero? '(rational)
(lambda (a) (= (numer a) 0)))
(put 'negate '(rational)
(lambda (r) (tag (make-rat (- (numer r)) (denom r)))))
'done)
(install-rational-package)
(define (make-rational n d)
((get 'make 'rational) n d))
;; ===================================================================
;; ================= Complex polar and rectangular ===================
;; ===================================================================
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
;; interface to the rest of the system
(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))))
(put 'negate '(polar)
(lambda (z) (tag (make-from-mag-ang (magnitude z) (+ (angle z) pi)))))
'done)
(install-polar-package)
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y)
(cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
;; interface to the rest of the system
(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))))
(put 'negate '(rectangular)
(lambda (z) (tag (make-from-real-imag (- (real-part z) (- (imag-part z)))))))
'done)
(install-rectangular-package)
;; ===================================================================
;; ========================= Complex package =========================
;; ===================================================================
(define (install-complex-package)
;; imported procedures from rectangular
;; and polar packages
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (make-from-real-imag x y)
((get 'make-from-real-imag
'rectangular)
x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar)
r a))
;; internal procedures
(define (add-complex z1 z2)
(make-from-real-imag
(+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag
(- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang
(* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang
(/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
(define (equ? z1 z2) ; for problem 2.79
(and (= (real-part z1) (real-part z2))
(= (imag-part z1) (imag-part z2))))
;; interface to rest of the system
(put 'equ? '(complex complex) equ?)
(put 'real-part '(complex) real-part) ; Changes from problem 2.77
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(put 'negate '(complex)
(lambda (z) (tag (apply-generic 'negate z))))
(define (tag z) (attach-tag 'complex z))
(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))))
;problem 2.80
(put '=zero? '(complex)
(lambda (z) (and (= (real-part z) 0) (= (imag-part z) 0))))
'done)
(install-complex-package)
(define (=zero? a)
(apply-generic '=zero? a))
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (mul a b)
(apply-generic 'mul a b))
(define (add a b)
(apply-generic 'add a b))
(define (sub a b)
(apply-generic 'sub a b))
(define (equ? a b)
(apply-generic 'equ? a b))
(define (install-polynomial-package)
;; internal procedures
;; representation of poly
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p) (cdr p))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1)
(variable? v2)
(eq? v1 v2)))
(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))))))
;; representation of terms and term lists
(define (adjoin-term term term-list)
(if (=zero? (coeff term))
term-list
(cons term term-list)))
(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 (make-term order coeff)
(list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(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 var:
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 var:
MUL-POLY"
(list 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)))))))))
;; (ct1 x^(ot1)+rest1)/(ct2 x^(ot2)+rest2)
;; =(poly1 - (ct1/ct2) x^(ot1-ot2)(poly2) + (ct1/ct2) x^(ot1-ot2)(poly2))/(poly2)
;; =(ct1/ct2) x^(ot1-ot2) + (poly1 - (ct1/ct2) x^(ot1-ot2)(poly2))/poly2
;; During construction, we don't check whether coefficients are zero
;; So now, we have to check all coefficients.
(define (=zero?-poly poly)
(accumulate (lambda (x y) (and y (=zero? (coeff x))))
#t
(term-list poly)))
;; Make sure to install the function
(put '=zero? '(polynomial) =zero?-poly)
;; Exercise 2-88
(define (negate-terms L)
(if (empty-termlist? L)
L
(let ((t (first-term L)) (r (rest-terms L)))
(adjoin-term (make-term (order t) (apply-generic 'negate (coeff t)))
(negate-terms r)))))
(define (sub-terms L1 L2)
(add-terms L1 (negate-terms L2)))
(define (sub-poly p1 p2)
(if (same-variable? (variable p1)
(variable p2))
(make-poly
(variable p1)
(sub-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var:
SUB-POLY"
(list p1 p2))))
(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 (apply-generic 'div (coeff t1)
(coeff t2)))
(new-o (- (order t1)
(order t2))))
(let ((new-t (make-term new-o new-c)))
(let ((rest-of-result
(div-terms
(sub-terms L1 (mul-term-by-all-terms new-t L2))
L2)))
(let ((div-val (car rest-of-result))
(rem-val (cadr rest-of-result)))
(list (add-terms (list new-t) div-val)
rem-val)))))))))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2)
(tag (sub-poly p1 p2))))
(define (div-poly p1 p2)
(if (same-variable? (variable p1)
(variable p2))
(let ((res (div-terms (term-list p1)
(term-list p2))))
(list (make-poly (variable p1) (car res)) (make-poly (variable p1) (cadr res))))
(error "Polys not in same var:
SUB-POLY"
(list p1 p2))))
(define (poly-remainder p1 p2)
(cadr (div-poly p1 p2)))
(define (poly-gcd a b)
(if (=zero?-poly b)
a
(poly-gcd b (poly-remainder a b))))
(put 'remainder '(polynomial polynomial)
(lambda (p1 p2)
(tag (poly-remainder p1 p2))))
(put 'gcd '(polynomial polynomial)
(lambda (p1 p2)
(tag (poly-gcd p1 p2))))
(put 'div-poly '(polynomial polynomial)
(lambda (p1 p2)
(let ((res (div-poly p1 p2)))
(list (tag (car res)) (tag (cadr res))))))
(put 'negate '(polynomial)
(lambda (p)
(tag (make-poly (variable p) (negate-terms (term-list p))))))
;; interface to rest of the system
(define (tag p) (attach-tag 'polynomial p))
(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 'make 'polynomial
(lambda (var terms)
(tag (make-poly var terms))))
'done)
(install-polynomial-package)
(define (make-polynomial var terms)
((get 'make 'polynomial) var terms))
(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
(apply-generic 'mul p1 p2))
(define q2
(apply-generic 'mul p1 p3))
(apply-generic 'gcd q1 q2)
done done done done done done (polynomial x (2 1458/169) (1 -2916/169) (0 1458/169))
This is just a general fact of Euclidean domains. The GCD is only defined up to multiplication by invertible elements. Most applications would choose to normalize the leading term to 1, in which case we get back the polynomial $x^2-2x+1.$
1. Implement the procedure pseudoremainder-terms, which is just like
remainder-terms except that it multiplies the dividend by the
integerizing factor described above before calling div-terms. Modify
gcd-terms to use pseudoremainder-terms, and verify that
greatest-common-divisor now produces an answer with integer coefficients
on the example in Exercise 2.95.
2. The GCD now has integer coefficients, but they are larger than those
of $P_1$. Modify gcd-terms so that it removes common factors from the
coefficients of the answer by dividing all the coefficients by their (integer)
greatest common divisor.
For part 1, it's just an exercise in computing the correct power of c.
I use mul-term-by-all-terms to perform the scalar multiplication.
(define (term-order L)
(if (null? L) 0
(order (first-term L))))
(define (pow a b)
(if (= b 0) 1 (* a (pow a (- b 1)))))
(define (pseudoremainder-terms L1 L2)
(let ((o1 (term-order L1))
(o2 (term-order L2))
(c (coeff (first-term L2))))
(remainder-terms
(mul-term-by-all-terms
(list 0 (pow c (+ 1 (- o1 o2))))
L1)
L2)))
With this change alone, we end up printing out the polynomial
('polynomial 'x ((2 1458) (1 -2916) (0 1458))) which isn't reduced.
For part 2, I use accumulate to find the gcd of all the coefficients,
then apply remove-common-factors inside the gcd function.
(define (remove-common-factors L)
(let ((common-factor
(accumulate (lambda (x y) (gcd x y))
(coeff (car L))
(map coeff (cdr L)))))
(map (lambda (x) (make-term (order x) (/ (coeff x) common-factor))) L)))
(define (gcd-terms L1 L2)
(remove-common-factors
(if (=zero?-terms L2)
L1
(gcd-terms L2 (pseudoremainder-terms L1 L2)))))
Working example:
#lang sicp
(define pi 3.14159)
(define (square x) (* x x))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op
initial
(cdr sequence)))))
;; get and put definitions
(define operation-table '())
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (assoc-op key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc-op key (cdr records)))))
(define (put op type-tags proc)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(set-cdr! proc-pair-entry proc)
(set-car! (cdr op-list-entry)
(cons (cons type-tags proc) proc-list)))))
(set! operation-table
(cons (list op (list (cons type-tags proc)))
operation-table)))))
(define (get op type-tags)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(cdr proc-pair-entry)
#f)))
#f)))
;; Modified for ex2-78.
(define (attach-tag type-tag contents)
(if (equal? type-tag 'scheme-number)
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((number? datum) 'scheme-number)
(else (error "Bad tagged datum: TYPE-TAG" datum))))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((number? datum) datum)
(else (error "Bad tagged datum: CONTENTS" datum))))
(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))
(error
"No method for these types: APPLY-GENERIC"
(list op type-tags))))))
;; Number package
(define (install-scheme-number-package)
(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
(lambda (x) (tag x)))
(put '=zero? '(scheme-number)
(lambda (x) (= x 0)))
(put 'negate '(scheme-number)
(lambda (x) (- x)))
'done)
(install-scheme-number-package)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
;; ===================================================================
;; ======================== Rational package =========================
;; ===================================================================
(define (install-rational-package)
;; internal procedures
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
;; z1a/z1b = z2a/z2b iff z1a*z2b - z2a*z1b = 0
;; equ? for problem 2.79
(define (equ? z1 z2)
(= (- (* (numer z1) (denom z2))
(* (numer z2) (denom z1)))
0))
;; interface to rest of the system
(put 'equ? '(rational rational) equ?)
(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))))
;problem 2.80
(put '=zero? '(rational)
(lambda (a) (= (numer a) 0)))
(put 'negate '(rational)
(lambda (r) (tag (make-rat (- (numer r)) (denom r)))))
'done)
(install-rational-package)
(define (make-rational n d)
((get 'make 'rational) n d))
;; ===================================================================
;; ================= Complex polar and rectangular ===================
;; ===================================================================
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
;; interface to the rest of the system
(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))))
(put 'negate '(polar)
(lambda (z) (tag (make-from-mag-ang (magnitude z) (+ (angle z) pi)))))
'done)
(install-polar-package)
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y)
(cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
;; interface to the rest of the system
(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))))
(put 'negate '(rectangular)
(lambda (z) (tag (make-from-real-imag (- (real-part z) (- (imag-part z)))))))
'done)
(install-rectangular-package)
;; ===================================================================
;; ========================= Complex package =========================
;; ===================================================================
(define (install-complex-package)
;; imported procedures from rectangular
;; and polar packages
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (make-from-real-imag x y)
((get 'make-from-real-imag
'rectangular)
x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar)
r a))
;; internal procedures
(define (add-complex z1 z2)
(make-from-real-imag
(+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag
(- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang
(* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang
(/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
(define (equ? z1 z2) ; for problem 2.79
(and (= (real-part z1) (real-part z2))
(= (imag-part z1) (imag-part z2))))
;; interface to rest of the system
(put 'equ? '(complex complex) equ?)
(put 'real-part '(complex) real-part) ; Changes from problem 2.77
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(put 'negate '(complex)
(lambda (z) (tag (apply-generic 'negate z))))
(define (tag z) (attach-tag 'complex z))
(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))))
;problem 2.80
(put '=zero? '(complex)
(lambda (z) (and (= (real-part z) 0) (= (imag-part z) 0))))
'done)
(install-complex-package)
(define (=zero? a)
(apply-generic '=zero? a))
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (mul a b)
(apply-generic 'mul a b))
(define (add a b)
(apply-generic 'add a b))
(define (sub a b)
(apply-generic 'sub a b))
(define (equ? a b)
(apply-generic 'equ? a b))
(define (install-polynomial-package)
;; internal procedures
;; representation of poly
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p) (cdr p))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1)
(variable? v2)
(eq? v1 v2)))
(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))))))
;; representation of terms and term lists
(define (adjoin-term term term-list)
(if (=zero? (coeff term))
term-list
(cons term term-list)))
(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 (make-term order coeff)
(list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(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 var:
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 var:
MUL-POLY"
(list 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)))))))))
;; (ct1 x^(ot1)+rest1)/(ct2 x^(ot2)+rest2)
;; =(poly1 - (ct1/ct2) x^(ot1-ot2)(poly2) + (ct1/ct2) x^(ot1-ot2)(poly2))/(poly2)
;; =(ct1/ct2) x^(ot1-ot2) + (poly1 - (ct1/ct2) x^(ot1-ot2)(poly2))/poly2
;; During construction, we don't check whether coefficients are zero
;; So now, we have to check all coefficients.
(define (=zero?-terms L)
(accumulate (lambda (x y) (and y (=zero? (coeff x))))
#t
L))
(define (=zero?-poly poly)
(=zero?-terms (term-list poly)))
;; Make sure to install the function
(put '=zero? '(polynomial) =zero?-poly)
;; Exercise 2-88
(define (negate-terms L)
(if (empty-termlist? L)
L
(let ((t (first-term L)) (r (rest-terms L)))
(adjoin-term (make-term (order t) (apply-generic 'negate (coeff t)))
(negate-terms r)))))
(define (sub-terms L1 L2)
(add-terms L1 (negate-terms L2)))
(define (sub-poly p1 p2)
(if (same-variable? (variable p1)
(variable p2))
(make-poly
(variable p1)
(sub-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var:
SUB-POLY"
(list p1 p2))))
(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 (apply-generic 'div (coeff t1)
(coeff t2)))
(new-o (- (order t1)
(order t2))))
(let ((new-t (make-term new-o new-c)))
(let ((rest-of-result
(div-terms
(sub-terms L1 (mul-term-by-all-terms new-t L2))
L2)))
(let ((div-val (car rest-of-result))
(rem-val (cadr rest-of-result)))
(list (add-terms (list new-t) div-val)
rem-val)))))))))
(define (div-poly p1 p2)
(if (same-variable? (variable p1)
(variable p2))
(let ((res (div-terms (term-list p1)
(term-list p2))))
(list (make-poly (variable p1) (car res)) (make-poly (variable p1) (cadr res))))
(error "Polys not in same var:
DIV-POLY"
(list p1 p2))))
(define (remainder-terms L1 L2)
(cadr (div-terms L1 L2)))
(define (term-order L)
(if (null? L) 0
(order (first-term L))))
(define (pow a b)
(if (= b 0) 1 (* a (pow a (- b 1)))))
(define (pseudoremainder-terms L1 L2)
(let ((o1 (term-order L1))
(o2 (term-order L2))
(c (coeff (first-term L2))))
(remainder-terms
(mul-term-by-all-terms
(list 0 (pow c (+ 1 (- o1 o2))))
L1)
L2)))
(define (remove-common-factors L)
(let ((common-factor
(accumulate (lambda (x y) (gcd x y))
(coeff (car L))
(map coeff (cdr L)))))
(map (lambda (x) (make-term (order x) (/ (coeff x) common-factor))) L)))
(define (gcd-terms L1 L2)
(remove-common-factors
(if (=zero?-terms L2)
L1
(gcd-terms L2 (pseudoremainder-terms L1 L2)))))
(define (gcd-poly p1 p2)
(if (same-variable? (variable p1)
(variable p2))
(make-poly (variable p1) (gcd-terms (term-list p1) (term-list p2)))
(error "Polys not in same var:
GCD-POLY"
(list p1 p2))))
(define (poly-remainder p1 p2)
(cadr (div-poly p1 p2)))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2)
(tag (sub-poly p1 p2))))
(put 'remainder '(polynomial polynomial)
(lambda (p1 p2)
(tag (poly-remainder p1 p2))))
(put 'gcd '(polynomial polynomial)
(lambda (p1 p2)
(tag (gcd-poly p1 p2))))
(put 'div-poly '(polynomial polynomial)
(lambda (p1 p2)
(let ((res (div-poly p1 p2)))
(list (tag (car res)) (tag (cadr res))))))
(put 'negate '(polynomial)
(lambda (p)
(tag (make-poly (variable p) (negate-terms (term-list p))))))
;; interface to rest of the system
(define (tag p) (attach-tag 'polynomial p))
(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 'make 'polynomial
(lambda (var terms)
(tag (make-poly var terms))))
'done)
(install-polynomial-package)
(define (make-polynomial var terms)
((get 'make 'polynomial) var terms))
(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
(apply-generic 'mul p1 p2))
(define q2
(apply-generic 'mul p1 p3))
(apply-generic 'gcd q1 q2)
done done done done done done (polynomial x (2 1) (1 -2) (0 1))
1. Implement this algorithm as a procedure reduce-terms that takes two term
lists n and d as arguments and returns a list nn,
dd, which are n and d reduced to lowest terms via the
algorithm given above. Also write a procedure reduce-poly, analogous to
add-poly, that checks to see if the two polys have the same variable.
If so, reduce-poly strips off the variable and passes the problem to
reduce-terms, then reattaches the variable to the two term lists
supplied by reduce-terms.
2. Define a procedure analogous to reduce-terms that does what the original
make-rat did for integers:
(define (reduce-integers n d)
(let ((g (gcd n d)))
(list (/ n g) (/ d g))))
and define reduce as a generic operation that calls apply-generic
to dispatch to either reduce-poly (for polynomial arguments) or
reduce-integers (for scheme-number arguments). You can now
easily make the rational-arithmetic package reduce fractions to lowest terms by
having make-rat call reduce before combining the given numerator
and denominator to form a rational number. The system now handles rational
expressions in either integers or polynomials. To test your program, try the
example at the beginning of this extended exercise:
(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)
See if you get the correct answer, correctly reduced to lowest terms.
Part 1: Here's what I did for reduce:
(define (reduce-terms L1 L2)
(let ((my-gcd (gcd-terms L1 L2)))
(let ((o1 (max (term-order L1) (term-order L2)))
(o2 (term-order my-gcd))
(c (coeff (first-term my-gcd))))
(let ((numer-list (div-terms
(mul-term-by-all-terms
(list 0 (pow c (+ 1 (- o1 o2))))
L1)
my-gcd))
(denom-list (div-terms
(mul-term-by-all-terms
(list 0 (pow c (+ 1 (- o1 o2))))
L2)
my-gcd)))
(list (car numer-list) (car denom-list))))))
(define (reduce-poly p1 p2)
(if (same-variable? (variable p1)
(variable p2))
(map (lambda (L) (make-poly (variable p1) L))
(reduce-terms (term-list p1) (term-list p2)))
(error "Polys not in same var:
REDUCE-POLY"
(list p1 p2))))
(put 'reduce '(polynomial polynomial)
(lambda (p1 p2)
(map tag (reduce-poly p1 p2))))
Part 2 We change the make-rational function to look like this:
(define (make-rat n d)
(let ((red (apply-generic 'reduce n d)))
(cons (car red) (cadr red))))
Demonstrate that it works:
#lang sicp
(define pi 3.14159)
(define (square x) (* x x))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op
initial
(cdr sequence)))))
;; get and put definitions
(define operation-table '())
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (assoc-op key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc-op key (cdr records)))))
(define (put op type-tags proc)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(set-cdr! proc-pair-entry proc)
(set-car! (cdr op-list-entry)
(cons (cons type-tags proc) proc-list)))))
(set! operation-table
(cons (list op (list (cons type-tags proc)))
operation-table)))))
(define (get op type-tags)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(cdr proc-pair-entry)
#f)))
#f)))
;; Modified for ex2-78.
(define (attach-tag type-tag contents)
(if (equal? type-tag 'scheme-number)
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((number? datum) 'scheme-number)
(else (error "Bad tagged datum: TYPE-TAG" datum))))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((number? datum) datum)
(else (error "Bad tagged datum: CONTENTS" datum))))
(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))
(error
"No method for these types: APPLY-GENERIC"
(list op type-tags))))))
;; Number package
(define (install-scheme-number-package)
(define (tag x)
(attach-tag 'scheme-number x))
(put 'reduce '(scheme-number scheme-number)
(lambda (x y) (tag
(let ((g (gcd x y)))
(list (/ x g) (/ y g))))))
(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
(lambda (x) (tag x)))
(put '=zero? '(scheme-number)
(lambda (x) (= x 0)))
(put 'negate '(scheme-number)
(lambda (x) (- x)))
'done)
(install-scheme-number-package)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
;; ===================================================================
;; ======================== Rational package =========================
;; ===================================================================
(define (install-rational-package)
;; internal procedures
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((red (apply-generic 'reduce n d)))
(cons (car red) (cadr red))))
(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 (=zero? x) (apply-generic '=zero? x))
(define (negate x) (apply-generic 'negate x))
(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))))
;; z1a/z1b = z2a/z2b iff z1amulz2b - z2amulz1b = 0
;; equ? for problem 2.79
(define (equ? z1 z2)
(=zero? (sub (mul (numer z1) (denom z2))
(mul (numer z2) (denom z1)))))
;; interface to rest of the system
(put 'equ? '(rational rational) equ?)
(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))))
;problem 2.80
(put '=zero? '(rational)
(lambda (a) (=zero? (numer a))))
(put 'negate '(rational)
(lambda (r) (tag (make-rat (negate (numer r)) (denom r)))))
'done)
(install-rational-package)
(define (make-rational n d)
((get 'make 'rational) n d))
;; ===================================================================
;; ================= Complex polar and rectangular ===================
;; ===================================================================
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
;; interface to the rest of the system
(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))))
(put 'negate '(polar)
(lambda (z) (tag (make-from-mag-ang (magnitude z) (+ (angle z) pi)))))
'done)
(install-polar-package)
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y)
(cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
;; interface to the rest of the system
(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))))
(put 'negate '(rectangular)
(lambda (z) (tag (make-from-real-imag (- (real-part z) (- (imag-part z)))))))
'done)
(install-rectangular-package)
;; ===================================================================
;; ========================= Complex package =========================
;; ===================================================================
(define (install-complex-package)
;; imported procedures from rectangular
;; and polar packages
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (make-from-real-imag x y)
((get 'make-from-real-imag
'rectangular)
x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar)
r a))
;; internal procedures
(define (add-complex z1 z2)
(make-from-real-imag
(+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag
(- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang
(* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang
(/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
(define (equ? z1 z2) ; for problem 2.79
(and (= (real-part z1) (real-part z2))
(= (imag-part z1) (imag-part z2))))
;; interface to rest of the system
(put 'equ? '(complex complex) equ?)
(put 'real-part '(complex) real-part) ; Changes from problem 2.77
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(put 'negate '(complex)
(lambda (z) (tag (apply-generic 'negate z))))
(define (tag z) (attach-tag 'complex z))
(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))))
;problem 2.80
(put '=zero? '(complex)
(lambda (z) (and (= (real-part z) 0) (= (imag-part z) 0))))
'done)
(install-complex-package)
(define (=zero? a)
(apply-generic '=zero? a))
(define (real-part z)
(apply-generic 'real-part z))
(define (imag-part z)
(apply-generic 'imag-part z))
(define (magnitude z)
(apply-generic 'magnitude z))
(define (angle z)
(apply-generic 'angle z))
(define (mul a b)
(apply-generic 'mul a b))
(define (add a b)
(apply-generic 'add a b))
(define (sub a b)
(apply-generic 'sub a b))
(define (equ? a b)
(apply-generic 'equ? a b))
(define (install-polynomial-package)
;; internal procedures
;; representation of poly
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p) (cdr p))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1)
(variable? v2)
(eq? v1 v2)))
(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))))))
;; representation of terms and term lists
(define (adjoin-term term term-list)
(if (=zero? (coeff term))
term-list
(cons term term-list)))
(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 (make-term order coeff)
(list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(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 var:
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 var:
MUL-POLY"
(list 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)))))))))
;; (ct1 x^(ot1)+rest1)/(ct2 x^(ot2)+rest2)
;; =(poly1 - (ct1/ct2) x^(ot1-ot2)(poly2) + (ct1/ct2) x^(ot1-ot2)(poly2))/(poly2)
;; =(ct1/ct2) x^(ot1-ot2) + (poly1 - (ct1/ct2) x^(ot1-ot2)(poly2))/poly2
;; During construction, we don't check whether coefficients are zero
;; So now, we have to check all coefficients.
(define (=zero?-terms L)
(accumulate (lambda (x y) (and y (=zero? (coeff x))))
#t
L))
(define (=zero?-poly poly)
(=zero?-terms (term-list poly)))
;; Make sure to install the function
(put '=zero? '(polynomial) =zero?-poly)
;; Exercise 2-88
(define (negate-terms L)
(if (empty-termlist? L)
L
(let ((t (first-term L)) (r (rest-terms L)))
(adjoin-term (make-term (order t) (apply-generic 'negate (coeff t)))
(negate-terms r)))))
(define (sub-terms L1 L2)
(add-terms L1 (negate-terms L2)))
(define (sub-poly p1 p2)
(if (same-variable? (variable p1)
(variable p2))
(make-poly
(variable p1)
(sub-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var:
SUB-POLY"
(list p1 p2))))
(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 (apply-generic 'div (coeff t1)
(coeff t2)))
(new-o (- (order t1)
(order t2))))
(let ((new-t (make-term new-o new-c)))
(let ((rest-of-result
(div-terms
(sub-terms L1 (mul-term-by-all-terms new-t L2))
L2)))
(let ((div-val (car rest-of-result))
(rem-val (cadr rest-of-result)))
(list (add-terms (list new-t) div-val)
rem-val)))))))))
(define (div-poly p1 p2)
(if (same-variable? (variable p1)
(variable p2))
(let ((res (div-terms (term-list p1)
(term-list p2))))
(list (make-poly (variable p1) (car res)) (make-poly (variable p1) (cadr res))))
(error "Polys not in same var:
DIV-POLY"
(list p1 p2))))
(define (remainder-terms L1 L2)
(cadr (div-terms L1 L2)))
(define (term-order L)
(if (null? L) 0
(order (first-term L))))
(define (pow a b)
(if (= b 0) 1 (* a (pow a (- b 1)))))
(define (pseudoremainder-terms L1 L2)
(let ((o1 (term-order L1))
(o2 (term-order L2))
(c (coeff (first-term L2))))
(remainder-terms
(mul-term-by-all-terms
(list 0 (pow c (+ 1 (- o1 o2))))
L1)
L2)))
(define (remove-common-factors L)
(let ((common-factor
(accumulate (lambda (x y) (gcd x y))
(coeff (car L))
(map coeff (cdr L)))))
(map (lambda (x) (make-term (order x) (/ (coeff x) common-factor))) L)))
(define (gcd-terms L1 L2)
(remove-common-factors
(if (=zero?-terms L2)
L1
(gcd-terms L2 (pseudoremainder-terms L1 L2)))))
(define (reduce-terms L1 L2)
(let ((my-gcd (gcd-terms L1 L2)))
(let ((o1 (max (term-order L1) (term-order L2)))
(o2 (term-order my-gcd))
(c (coeff (first-term my-gcd))))
(let ((numer-list (div-terms
(mul-term-by-all-terms
(list 0 (pow c (+ 1 (- o1 o2))))
L1)
my-gcd))
(denom-list (div-terms
(mul-term-by-all-terms
(list 0 (pow c (+ 1 (- o1 o2))))
L2)
my-gcd)))
(list (car numer-list) (car denom-list))))))
(define (reduce-poly p1 p2)
(if (same-variable? (variable p1)
(variable p2))
(map (lambda (L) (make-poly (variable p1) L))
(reduce-terms (term-list p1) (term-list p2)))
(error "Polys not in same var:
REDUCE-POLY"
(list p1 p2))))
(define (gcd-poly p1 p2)
(if (same-variable? (variable p1)
(variable p2))
(make-poly (variable p1) (gcd-terms (term-list p1) (term-list p2)))
(error "Polys not in same var:
GCD-POLY"
(list p1 p2))))
(define (poly-remainder p1 p2)
(cadr (div-poly p1 p2)))
(put 'reduce '(polynomial polynomial)
(lambda (p1 p2)
(map tag (reduce-poly p1 p2))))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2)
(tag (sub-poly p1 p2))))
(put 'remainder '(polynomial polynomial)
(lambda (p1 p2)
(tag (poly-remainder p1 p2))))
(put 'gcd '(polynomial polynomial)
(lambda (p1 p2)
(tag (gcd-poly p1 p2))))
(put 'div-poly '(polynomial polynomial)
(lambda (p1 p2)
(let ((res (div-poly p1 p2)))
(list (tag (car res)) (tag (cadr res))))))
(put 'negate '(polynomial)
(lambda (p)
(tag (make-poly (variable p) (negate-terms (term-list p))))))
;; interface to rest of the system
(define (tag p) (attach-tag 'polynomial p))
(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 'make 'polynomial
(lambda (var terms)
(tag (make-poly var terms))))
'done)
(install-polynomial-package)
(define (make-polynomial var terms)
((get 'make 'polynomial) var terms))
(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
(apply-generic 'mul p1 p2))
(define q2
(apply-generic 'mul p1 p3))
;; (apply-generic 'gcd q1 q2)
;; (apply-generic 'reduce q1 q2)
(display "(make-rational 15 5) = ")
(make-rational 15 5)
(display "
(make-rational
(polynomial x (4 11) (3 -22) (2 18) (1 -14) (0 7))
(polynomial x (3 13) (2 -21) (1 3) (0 5)))
=
")
(make-rational q1 q2)
(newline)
(display "Testing that (x+1)/(x-1) does not get simplified:")(newline)
(make-rational
'(polynomial x (1 1) (0 1))
'(polynomial x (1 1) (0 -1)))
done done done done done done (make-rational 15 5) = (rational 3 . 1) (make-rational (polynomial x (4 11) (3 -22) (2 18) (1 -14) (0 7)) (polynomial x (3 13) (2 -21) (1 3) (0 5))) = (rational (polynomial x (2 11) (0 7)) polynomial x (1 13) (0 5)) Testing that (x+1)/(x-1) does not get simplified: (rational (polynomial x (1 1) (0 1)) polynomial x (1 1) (0 -1))
Important note: I've just focused on getting things that work for our test cases of integer polynomials, I can't guarantee that everything works correctly, especially in case rational numbers sneak into the objects without me noticing, or we get division by zero or that sort of thing! This can definitely be rewritten in a better way.