Generic Arithmetic Operations
Imports: Example: Arithmetic Operations for Rational Numbers add-rat denom div-rat mul-rat numer sub-rat, Tagged Data attach-tag, Data-Directed Programming and Additivity add-complex apply-generic apply-specific div-complex make-from-mag-ang make-from-real-imag mul-complex polar-pkg rectangular-pkg sub-complex using, Exercise 2.1 make-rat
(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (scheme-number-pkg)
(define (tag x) (attach-tag 'scheme-number x))
(put 'add '(scheme-number scheme-number) (lambda (x y) (tag (+ x y))))
(put 'sub '(scheme-number scheme-number) (lambda (x y) (tag (- x y))))
(put 'mul '(scheme-number scheme-number) (lambda (x y) (tag (* x y))))
(put 'div '(scheme-number scheme-number) (lambda (x y) (tag (/ x y))))
(put 'make 'scheme-number tag))
(define (make-scheme-number n)
(apply-specific 'make 'scheme-number n))
(define (rational-pkg)
(define (tag x) (attach-tag 'rational x))
(put 'add '(rational rational) (lambda (x y) (tag (add-rat x y))))
(put 'sub '(rational rational) (lambda (x y) (tag (sub-rat x y))))
(put 'mul '(rational rational) (lambda (x y) (tag (mul-rat x y))))
(put 'div '(rational rational) (lambda (x y) (tag (div-rat x y))))
(put 'make 'rational (lambda (n d) (tag (make-rat n d)))))
(define (make-rational n d)
(apply-specific 'make 'rational n d))
(define (complex-pkg)
(define (tag z) (attach-tag 'complex z))
(rectangular-pkg)
(polar-pkg)
(put 'add '(complex complex) (lambda (z1 z2) (tag (add-complex z1 z2))))
(put 'sub '(complex complex) (lambda (z1 z2) (tag (sub-complex z1 z2))))
(put 'mul '(complex complex) (lambda (z1 z2) (tag (mul-complex z1 z2))))
(put 'div '(complex complex) (lambda (z1 z2) (tag (div-complex z1 z2))))
(put 'make-from-real-imag 'complex
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'complex
(lambda (r a) (tag (make-from-mag-ang r a)))))
(define (make-complex-from-real-imag x y)
(apply-specific 'make-from-real-imag 'complex x y))
(define (make-complex-from-mag-ang r a)
(apply-specific 'make-from-mag-ang 'complex r a))
(define (numeric-pkg)
(scheme-number-pkg)
(rational-pkg)
(complex-pkg))
(using numeric-pkg)
(add (make-scheme-number 1) (make-scheme-number 2))
=> (make-scheme-number 3)
(mul (make-rational 1 2) (make-rational 3 4))
=> (make-rational 3 8)
(sub (make-complex-from-mag-ang 1 0) (make-complex-from-real-imag 1 1))
=> (make-complex-from-real-imag 0 -1)Exercise 2.77
Imports: Compound Procedures square, Data-Directed Programming and Additivity angle apply-generic imag-part magnitude real-part using, Generic Arithmetic Operations complex-pkg make-complex-from-real-imag
(define (complex-components-pkg)
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle))This works because these selectors were defined in Data-Directed Programming and Additivity using apply-generic, so now they will dispatch back to themselves when given a data object tagged 'complex. In other words, we are telling the system to strip off the type tag and try again.
(using complex-pkg complex-components-pkg)
(define z (make-complex-from-real-imag 3 4))
(magnitude z)
=> (magnitude '(complex rectangular 3 . 4))
=> (apply-generic 'magnitude '(complex rectangular 3 . 4)) ; 1st call
=> (apply (get 'magnitude '(complex)) '((rectangular 3 . 4)))
=> (magnitude '(rectangular 3 . 4))
=> (apply-generic 'magnitude '(rectangular 3 . 4)) ; 2nd call
=> (apply (get 'magnitude '(rectangular)) '((3 . 4)))
=> (sqrt (+ (square 3) (square 4)))
=> (sqrt (+ 9 16))
=> (sqrt 25)
=> 5In this example, apply-generic is invoked twice: once on the outer 'complex object and again on the inner 'rectangular object. Each invocation strips off one type tag.
Exercise 2.78
Imports: Data-Directed Programming and Additivity using
(define (attach-tag type-tag contents)
(if (eq? type-tag 'scheme-number)
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((number? datum) 'scheme-number)
(else (error 'type-tag "bad tagged datum" datum))))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((number? datum) datum)
(else (error 'contents "bad tagged datum" datum))))
(attach-tag 'foo 'a) => '(foo . a)
(attach-tag 'scheme-number 1) => 1
(type-tag '(foo . a)) => 'foo
(type-tag 1) => 'scheme-number
(contents '(foo . a)) => 'a
(contents 1) => 1
(paste (:2.4.3 apply-generic) (:2.5.1 add div mul scheme-number-pkg sub))
(using scheme-number-pkg)
(add 1 2) => 3
(mul 3 4) => 12Exercise 2.79
Imports: Example: Arithmetic Operations for Rational Numbers denom numer Data-Directed Programming and Additivity apply-generic imag-part real-part using, Generic Arithmetic Operations make-complex-from-mag-ang make-complex-from-real-imag make-rational make-scheme-number numeric-pkg
In addition to Scheme numbers, rationals, and complex numbers, we’ll also make it work for integers and reals. This will be used to implement drop in Exercise 2.85.
(define (equ-pkg)
(put 'equ? '(scheme-number scheme-number) =)
(put 'equ? '(integer integer) =)
(put 'equ? '(real real) =)
(put 'equ? '(rational rational)
(lambda (x y)
(and (= (numer x) (numer y))
(= (denom x) (denom y)))))
(put 'equ? '(complex complex)
(lambda (z1 z2)
(and (= (real-part z1) (real-part z2))
(= (imag-part z1) (imag-part z2))))))
(define (equ? x y) (apply-generic 'equ? x y))
(using numeric-pkg equ-pkg)
(equ? (make-scheme-number 1) (make-scheme-number 1)) => #t
(equ? (make-scheme-number 1) (make-scheme-number 2)) => #f
(equ? (make-rational 1 2) (make-rational 2 4)) => #t
(equ? (make-rational 1 3) (make-rational 2 4)) => #f
(equ? (make-complex-from-real-imag 1 0) (make-complex-from-mag-ang 1 0)) => #t
(equ? (make-complex-from-real-imag 1 1) (make-complex-from-mag-ang 1 0)) => #fExercise 2.80
Imports: Example: Arithmetic Operations for Rational Numbers numer, Data-Directed Programming and Additivity apply-generic imag-part real-part using, Generic Arithmetic Operations make-complex-from-mag-ang make-complex-from-real-imag make-rational make-scheme-number numeric-pkg
(define (zero-pkg)
(put '=zero? '(scheme-number) zero?)
(put '=zero? '(rational)
(lambda (x) (zero? (numer x))))
(put '=zero? '(complex)
(lambda (x) (and (zero? (real-part x))
(zero? (imag-part x))))))
(define (=zero? n) (apply-generic '=zero? n))
(using numeric-pkg zero-pkg)
(=zero? (make-scheme-number 0)) => #t
(=zero? (make-scheme-number 1)) => #f
(=zero? (make-rational 0 1)) => #t
(=zero? (make-rational 1 1)) => #f
(=zero? (make-complex-from-mag-ang 0 2)) => #t
(=zero? (make-complex-from-real-imag 0 1)) => #fCombining Data of Different Types
Imports: Tagged Data contents type-tag, Data-Directed Programming and Additivity using, Generic Arithmetic Operations make-complex-from-real-imag make-scheme-number numeric-pkg
(define (get-coercion type1 type2)
(get 'coerce (list type1 type2)))
(define (put-coercion type1 type2 coerce)
(put 'coerce (list type1 type2) coerce))
(define (apply-generic op . args)
(let* ((type-tags (map type-tag args))
(proc (get op type-tags)))
(define (err)
(error 'apply-generic "no method for types" op type-tags))
(if proc
(apply proc (map contents args))
(if (= (length args) 2)
(let* ((type1 (car type-tags))
(type2 (cadr type-tags))
(a1 (car args))
(a2 (cadr args))
(t1->t2 (get-coercion type1 type2))
(t2->t1 (get-coercion type2 type1)))
(cond (t1->t2 (apply-generic op (t1->t2 a1) a2))
(t2->t1 (apply-generic op a1 (t2->t1 a2)))
(else (err))))
(err)))))
(paste (:2.5.1 add div mul sub))
(define (scheme-number-to-complex-pkg)
(define (coerce n)
(make-complex-from-real-imag (contents n) 0))
(put-coercion 'scheme-number 'complex coerce))
(using numeric-pkg scheme-number-to-complex-pkg)
(add (make-scheme-number 1) (make-complex-from-real-imag 0 1))
=> (add (make-complex-from-real-imag 0 1) (make-scheme-number 1))
=> (make-complex-from-real-imag 1 1)Exercise 2.81
Imports: Tagged Data attach-tag contents type-tag, Data-Directed Programming and Additivity using, Generic Arithmetic Operations complex-pkg make-complex-from-real-imag, Combining Data of Different Types apply-generic get-coercion put-coercion
(define (identity-pkg)
(put-coercion 'scheme-number 'scheme-number (lambda (x) x))
(put-coercion 'complex 'complex (lambda (x) x)))
(define (exp-pkg)
(define (tag x) (attach-tag 'scheme-number x))
(put 'exp '(scheme-number scheme-number) (lambda (x y) (tag (expt x y)))))
(define (exp x y) (apply-generic 'exp x y))a. If we call exp with two complex numbers, it will enter an infinite recursion because it will keep trying to unnecessarily coerce the first argument to the type of the second.
(using complex-pkg identity-pkg exp-pkg)
(define z (make-complex-from-real-imag 0 0))
(exp z z) =>...b. Louis is wrong: nothing needs to be done about coercion with arguments of the same type. As long as we don’t install any self-coercions as tried above, apply-generic will fail to find a coercion and report an error.
c. This implementation doesn’t coerce two arguments of the same type:
(define (new-apply-generic op . args)
(let* ((type-tags (map type-tag args))
(proc (get op type-tags)))
(define (err)
(error 'new-apply-generic "no method for types" op type-tags))
(if proc
(apply proc (map contents args))
(if (= (length args) 2)
(let ((type1 (car type-tags))
(type2 (cadr type-tags)))
(if (eq? type1 type2)
(err)
(let ((a1 (car args))
(a2 (cadr args))
(t1->t2 (get-coercion type1 type2))
(t2->t1 (get-coercion type2 type1)))
(cond (t1->t2 (new-apply-generic op (t1->t2 a1) a2))
(t2->t1 (new-apply-generic op a1 (t2->t1 a2)))
(else (err))))))
(err)))))
(define (exp x y) (new-apply-generic 'exp x y))
(exp z z) =!> "no method for types"Exercise 2.82
Imports: Tagged Data attach-tag contents type-tag, Data-Directed Programming and Additivity add-complex using, Generic Arithmetic Operations make-complex-from-real-imag make-scheme-number numeric-pkg, Combining Data of Different Types add get-coercion scheme-number-to-complex-pkg
(define (get-coercion-or-id from to)
(if (eq? from to)
(lambda (x) x)
(get-coercion from to)))
(define (all-good? xs)
(or (null? xs)
(and (car xs)
(all-good? (cdr xs)))))
(define (coerce-all vals types to)
(let ((cs (map (lambda (from) (get-coercion-or-id from to)) types)))
(if (all-good? cs)
(map (lambda (c v) (c v)) cs vals)
#f)))
(define (apply-generic op . args)
(let* ((type-tags (map type-tag args))
(proc (get op type-tags)))
(define (try tt)
(when (null? tt)
(error 'apply-generic "no method for types" op type-tags))
(let* ((try-type (car tt))
(coerced-args (coerce-all args type-tags try-type))
(new-type-tags (map (lambda (x) try-type) type-tags))
(proc (get op new-type-tags)))
(if proc
(apply proc (map contents coerced-args))
(try (cdr tt)))))
(if proc
(apply proc (map contents args))
(try type-tags))))
(define (add3c-pkg)
(define (tag z) (attach-tag 'complex z))
(put 'add3c '(complex complex complex)
(lambda (z1 z2 z3)
(tag (add-complex z1 (add-complex z2 z3))))))
(define (add3c z1 z2 z3) (apply-generic 'add3c z1 z2 z3))
(using numeric-pkg scheme-number-to-complex-pkg add3c-pkg)
(add3c (make-scheme-number 1)
(make-complex-from-real-imag 1 1)
(make-scheme-number 1))
=> (make-complex-from-real-imag 3 1)This won’t work if two complex numbers are supplied and the operation takes one real number and one complex number. It only works for operations given the exact types they need, or for operations that take arguments that are all of the same type (assuming all the necessary coercions are possible).
Exercise 2.83
Imports: Example: Arithmetic Operations for Rational Numbers denom numer, Tagged Data attach-tag, Data-Directed Programming and Additivity apply-generic apply-specific using, Generic Arithmetic Operations add complex-pkg div make-complex-from-real-imag make-rational rational-pkg
(define (integer-pkg)
(define (tag x) (attach-tag 'integer x))
(put 'add '(integer integer) (lambda (x y) (tag (+ x y))))
(put 'sub '(integer integer) (lambda (x y) (tag (- x y))))
(put 'mul '(integer integer) (lambda (x y) (tag (* x y))))
(put 'div '(integer integer)
(lambda (x y)
(let ((z (/ x y)))
(if (integer? z) (tag z) (make-rational x y)))))
(put 'make 'integer tag))
(define (make-integer x) (apply-specific 'make 'integer x))
(define (real-pkg)
(define (tag x) (attach-tag 'real x))
(put 'add '(real real) (lambda (x y) (tag (+ x y))))
(put 'sub '(real real) (lambda (x y) (tag (- x y))))
(put 'mul '(real real) (lambda (x y) (tag (* x y))))
(put 'div '(real real) (lambda (x y) (tag (/ x y))))
(put 'make 'real tag))
(define (make-real x) (apply-specific 'make 'real x))The extended-numeric-pkg is like numeric-pkg from Generic Arithmetic Operations, but it splits 'scheme-number into 'integer and 'real.
(define (extended-numeric-pkg)
(integer-pkg)
(rational-pkg)
(real-pkg)
(complex-pkg))
(define (raise-pkg)
(define (integer->rational n)
(make-rational n 1))
(define (rational->real x)
(make-real (inexact (/ (numer x) (denom x)))))
(define (real->complex n)
(make-complex-from-real-imag n 0))
(put 'raise '(integer) integer->rational)
(put 'raise '(rational) rational->real)
(put 'raise '(real) real->complex))
(define (raise x) (apply-generic 'raise x))
(using extended-numeric-pkg raise-pkg)
(add (make-integer 1) (make-integer 2)) => (make-integer 3)
(div (make-integer 10) (make-integer 2)) => (make-integer 5)
(div (make-integer 1) (make-integer 2)) => (make-rational 1 2)
(raise (make-integer 1)) => (make-rational 1 1)
(raise (make-rational 1 2)) => (make-real 0.5)
(raise (make-real 0.5)) => (make-complex-from-real-imag 0.5 0)Exercise 2.84
Imports: Tagged Data contents type-tag, Data-Directed Programming and Additivity using, Generic Arithmetic Operations make-complex-from-real-imag make-rational, Exercise 2.83 extended-numeric-pkg make-integer make-real raise raise-pkg
(define numeric-tower
'(integer rational real complex))
(define (tower-bottom? type) (eq? type 'integer))
(define (tower-top? type) (eq? type 'complex))
(define (tower-position type)
(define (iter tower n)
(cond ((null? tower) #f)
((eq? type (car tower)) n)
(else (iter (cdr tower) (+ n 1)))))
(iter numeric-tower 0))
(define (apply-generic op . args)
(let* ((type-tags (map type-tag args))
(vals (map contents args))
(proc (get op type-tags)))
(define (err)
(error 'apply-generic "no method for types" op type-tags))
(cond (proc (apply proc vals))
((null? args) (err))
((null? (cdr args))
(if (tower-top? (car type-tags))
(err)
(apply-generic op (raise (car args)))))
((null? (cddr args))
(let ((a1 (car args))
(a2 (cadr args))
(p1 (tower-position (car type-tags)))
(p2 (tower-position (cadr type-tags))))
(cond ((or (not p1) (not p2) (= p1 p2)) (err))
((< p1 p2) (apply-generic op (raise a1) a2))
(else (apply-generic op a1 (raise a2))))))
(else (err)))))
(paste (:2.5.1 add div mul sub))
(using extended-numeric-pkg raise-pkg)
(add (make-integer 1) (make-complex-from-real-imag 2.0 3.0))
=> (make-complex-from-real-imag 3.0 3.0)
(add (make-rational 1 2) (make-real 0.5))
=> (make-real 1.0)
(div (make-real 1) (make-integer 2))
=> (make-real 0.5)Exercise 2.85
Imports: Example: Arithmetic Operations for Rational Numbers denom numer, Tagged Data contents type-tag, Data-Directed Programming and Additivity real-part using, Generic Arithmetic Operations make-complex-from-real-imag make-rational, Exercise 2.79 equ-pkg equ?, Exercise 2.83 extended-numeric-pkg make-integer make-real raise raise-pkg, Exercise 2.84 tower-bottom? tower-position tower-top?
Projection from reals to rationals is the hardest. Instead of designing an algorithm to find the nearest rational, we’ll cheat and use the procedures exact, numerator, and denominator which deal with Scheme’s built-in rational numbers.
(define (project-pkg)
(define (complex->real x)
(make-real (real-part x)))
(define (real->rational x)
(let ((y (exact x)))
(make-rational (numerator y) (denominator y))))
(define (rational->integer r)
(make-integer (quotient (numer r) (denom r))))
(put 'project '(complex) complex->real)
(put 'project '(real) real->rational)
(put 'project '(rational) rational->integer))
(define (project x) (apply-generic 'project x))
(define (drop x)
(let ((type (type-tag x)))
(if (tower-bottom? type)
x
(let* ((down (project x))
(down-up (raise down)))
(if (equ? x down-up) (drop down) x)))))
(define (apply-generic op . args)
(let* ((type-tags (map type-tag args))
(vals (map contents args))
(proc (get op type-tags)))
(define (err)
(error 'apply-generic "no method for types" op type-tags))
(cond (proc
(let ((result (apply proc vals)))
(if (and (pair? result)
(tower-position (type-tag result))
(not (or (eq? op 'raise) (eq? op 'project))))
(drop result)
result)))
((null? args) (err))
((null? (cdr args))
(if (tower-top? (car type-tags))
(err)
(apply-generic op (raise (car args)))))
((null? (cddr args))
(let ((a1 (car args))
(a2 (cadr args))
(p1 (tower-position (car type-tags)))
(p2 (tower-position (cadr type-tags))))
(cond ((or (not p1) (not p2) (= p1 p2)) (err))
((< p1 p2) (apply-generic op (raise a1) a2))
(else (apply-generic op a1 (raise a2))))))
(else (err)))))
(paste (:2.5.1 add div mul sub))
(using extended-numeric-pkg equ-pkg raise-pkg project-pkg)
(div (make-real 1) (make-complex-from-real-imag 2 0)) => (make-rational 1 2)
(add (make-complex-from-real-imag 1 0) (make-integer 1)) => (make-integer 2)
(mul (make-rational 3 2) (make-real 8)) => (make-integer 12)
(sub (make-real 2) (make-real 0.5)) => (make-rational 3 2)Exercise 2.86
Imports:
To support complex numbers whose components are themselves tagged data objects, we must rewrite all the complex number operations using generic procedures like add instead of specific procedures like +. Before we can do that, we need generic procedures for squares, square roots, and trigonometric functions. Thanks to the automatic coercion in Exercise 2.85’s apply-generic, we only need to define them for 'real.
(define (square x) (mul x x))
(define (sqrt-trig-pkg)
(define (tag x) (attach-tag 'real x))
(put 'square-root '(real) (lambda (x) (tag (sqrt x))))
(put 'sine '(real) (lambda (x) (tag (sin x))))
(put 'cosine '(real) (lambda (x) (tag (cos x))))
(put 'atan2 '(real real) (lambda (y x) (tag (atan y x)))))
(define (square-root x) (apply-generic 'square-root x))
(define (sine x) (apply-generic 'sine x))
(define (cosine x) (apply-generic 'cosine x))
(define (atan2 x y) (apply-generic 'atan2 x y))Now we can rewrite the rectangular and polar packages:
(define (rectangular-pkg)
(define real-part car)
(define imag-part cdr)
(define make-from-real-imag cons)
(define (magnitude z)
(square-root (add (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan2 (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (mul r (cosine a)) (mul r (sine a))))
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a)))))
(define (polar-pkg)
(define magnitude car)
(define angle cdr)
(define make-from-mag-ang cons)
(define (real-part z)
(mul (magnitude z) (cosine (angle z))))
(define (imag-part z)
(mul (magnitude z) (sine (angle z))))
(define (make-from-real-imag x y)
(cons (square-root (add (square x) (square y)))
(atan2 y x)))
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a)))))Next, we will rewrite the complex package:
(define (add-complex z1 z2)
(make-from-real-imag (add (real-part z1) (real-part z2))
(add (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (sub (real-part z1) (real-part z2))
(sub (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (mul (magnitude z1) (magnitude z2))
(add (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (div (magnitude z1) (magnitude z2))
(sub (angle z1) (angle z2))))
(paste (:2.5.1 complex-pkg))Finally, we need to fix some procedures in other packages that assumed a complex number’s real part and imaginary part were plain Scheme numbers. Fixing equ? is tricky because the equ? from Exercise 2.79 used the old apply-generic without coercion. That was fine since we only use it in drop on x and (raise (project x)), which must be the same type. But now, if they are complex numbers, their component types might be different. So in the new 'complex implementation of equ?, we need to recursively invoke a version of equ? that supports coercion.
(define (complex-patch-pkg)
(define (equ-with-coercion? x y) (apply-generic 'equ? x y))
(put 'equ? '(complex complex)
(lambda (z1 z2)
(and (equ-with-coercion? (real-part z1) (real-part z2))
(equ-with-coercion? (imag-part z1) (imag-part z2)))))
(put 'raise '(real)
(lambda (x) (make-complex-from-real-imag (make-real x) (make-real 0))))
(put 'project '(complex)
(lambda (x)
(let ((r (real-part x)))
(case (type-tag r)
((real) r)
((rational) (raise r))
((integer) (raise (raise r))))))))Putting it all together:
(define (final-numeric-pkg)
(integer-pkg)
(rational-pkg)
(real-pkg)
(complex-pkg)
(sqrt-trig-pkg)
(equ-pkg)
(raise-pkg)
(project-pkg)
(complex-patch-pkg))
(using final-numeric-pkg)
(add (make-complex-from-mag-ang (make-rational 1 2) (make-integer 0))
(make-complex-from-real-imag (make-rational 3 4) (make-real 2)))
=> (make-complex-from-real-imag (make-rational 5 4) (make-integer 2))
(div (make-complex-from-mag-ang (make-integer 3) (make-real 1))
(make-complex-from-mag-ang (make-rational 1 2) (make-real 1)))
=> (make-integer 6)Example: Symbolic Algebra
Arithmetic on Polynomials
Imports:
We are using the generic arithmetic system from Exercise 2.78, where Scheme numbers are not explicitly tagged.
(define make-poly cons)
(define variable car)
(define term-list cdr)
(define (polynomial-pkg)
(define (add-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(add-terms (term-list p1) (term-list p2)))
(error 'add-poly "polys not in same var" p1 p2)))
(define (mul-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(mul-terms (term-list p1) (term-list p2)))
(error 'mul-poly "polys not in same var" p1 p2)))
(define (tag p) (attach-tag 'polynomial p))
(put 'make 'polynomial (lambda (var terms) (tag (make-poly var terms))))
(put 'add '(polynomial polynomial) (lambda (p1 p2) (tag (add-poly p1 p2))))
(put 'mul '(polynomial polynomial) (lambda (p1 p2) (tag (mul-poly p1 p2)))))
(define (add-terms l1 l2)
(cond ((empty-termlist? l1) l2)
((empty-termlist? l2) l1)
(else
(let ((t1 (first-term l1))
(t2 (first-term l2)))
(cond ((> (order t1) (order t2))
(adjoin-term t1
(add-terms (rest-terms l1) l2)))
((< (order t1) (order t2))
(adjoin-term t2
(add-terms l1 (rest-terms l2))))
(else
(adjoin-term (make-term (order t1)
(add (coeff t1) (coeff t2)))
(add-terms (rest-terms l1)
(rest-terms l2)))))))))
(define (mul-terms l1 l2)
(if (empty-termlist? l1)
(the-empty-termlist)
(add-terms (mul-term-by-all-terms (first-term l1) l2)
(mul-terms (rest-terms l1) l2))))
(define (mul-term-by-all-terms t1 l)
(if (empty-termlist? l)
(the-empty-termlist)
(let ((t2 (first-term l)))
(adjoin-term (make-term (+ (order t1) (order t2))
(mul (coeff t1) (coeff t2)))
(mul-term-by-all-terms t1 (rest-terms l))))))Representing term lists
Imports:
We have to use apply-generic below because importing =zero? from Exercise 2.87 would cause an import cycle.
(define (adjoin-term term term-list)
(if (apply-generic '=zero? (coeff term))
term-list
(cons term term-list)))
(define (the-empty-termlist) '())
(define first-term car)
(define rest-terms cdr)
(define empty-termlist? null?)
(define make-term list)
(define order car)
(define coeff cadr)
(define (make-polynomial var terms)
(apply-specific 'make 'polynomial var terms))This package is used in Exercise 2.90:
(define (sparse-termlist-pkg)
(define (tag tl) (attach-tag 'sparse-termlist tl))
(put 'make 'sparse-termlist tag)
;; Curried so that it only dispatches on the term list, not the term.
(put 'adjoin-term '(sparse-termlist)
(lambda (tl) (lambda (t) (tag (adjoin-term t tl)))))
(put 'the-empty-termlist 'sparse-termlist
(lambda () (tag (the-empty-termlist))))
(put 'first-term '(sparse-termlist) first-term)
(put 'rest-terms '(sparse-termlist) (lambda (tl) (tag (rest-terms tl))))
(put 'empty-termlist? '(sparse-termlist) empty-termlist?))Exercise 2.87
Imports:
(define (zero-pkg)
(define (poly-zero? p)
(define (all-zero? terms)
(or (empty-termlist? terms)
(and (=zero? (coeff (first-term terms)))
(all-zero? (rest-terms terms)))))
(all-zero? (term-list p)))
(put '=zero? '(scheme-number) zero?)
(put '=zero? '(polynomial) poly-zero?))
(define (=zero? n) (apply-generic '=zero? n))
(using scheme-number-pkg polynomial-pkg zero-pkg)
(=zero? (make-polynomial 'x '())) => #t
(=zero? (make-polynomial 'x '((2 0)))) => #t
(=zero? (make-polynomial 'x '((2 1) (1 0)))) => #f
(add (make-polynomial 'x '((100 1) (2 3)))
(make-polynomial 'x '((3 1) (2 2) (0 5))))
=> (make-polynomial 'x '((100 1) (3 1) (2 5) (0 5)))
(mul (make-polynomial 'x '((2 1) (0 1)))
(make-polynomial 'x '((1 2))))
=> (make-polynomial 'x '((3 2) (1 2)))
(add (make-polynomial 'x '()) (make-polynomial 'y '()))
=!> "polys not in same var"Exercise 2.88
Imports:
(define (negate-terms tl)
(if (empty-termlist? tl)
(the-empty-termlist)
(let* ((term (first-term tl))
(new-term (make-term (order term) (negate (coeff term)))))
(adjoin-term new-term
(negate-terms (rest-terms tl))))))
(define (negate-pkg)
(put 'negate '(scheme-number) -)
(put 'negate '(polynomial)
(lambda (p)
(make-polynomial (variable p) (negate-terms (term-list p))))))
(define (negate x) (apply-generic 'negate x))
(define (sub x y) (add x (negate y)))
(using scheme-number-pkg polynomial-pkg zero-pkg negate-pkg)
(negate 1) => -1
(sub 5 2) => 3
(negate (make-polynomial 'x '((2 1))))
=> (make-polynomial 'x '((2 -1)))
(sub (make-polynomial 'x '((3 1) (1 2)))
(make-polynomial 'x '((2 2) (1 1) (0 -1))))
=> (make-polynomial 'x '((3 1) (2 -2) (1 1) (0 1)))