#lang racket
;; This is the complete symbolic algebra program from section 2.5.3, including
;; polynomials in more than one variable, a hierarchy of variables and coercion,
;; and rational functions, as outlined in the exercises.
;;;;;;;;;;;;;;;;;;;;;;
;; GLOBAL VARIABLES ;;
;;;;;;;;;;;;;;;;;;;;;;
;; Specify the output representation for polynomial term lists here.
(define TERMLIST-OUTPUT-TYPE 'dense) ; 'dense or 'sparse
;; Only allow these variables in polynomials.
(define VARIABLE-LIST '(x y z))
(define HIGHEST-VARIABLE (first VARIABLE-LIST))
(define LOWEST-VARIABLE (last VARIABLE-LIST))
;; Only simplify the results of these operations.
(define SIMPLIFY-LIST '(add sub mul div expo
sqroot square
arctan cosine sine
re-part im-part mag-part ang-part
first-term constant-term
))
(define (can-simplify? op) (member op SIMPLIFY-LIST))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PROCEDURE TABLES AND VARIABLE DICTIONARIES ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; procedure table for generic operations
(define op-table (make-hash))
(define (put op tag-list proc)
(hash-set! op-table (cons op tag-list) proc))
(define (can-apply? op tag-list)
(member (cons op tag-list) (hash-keys op-table)))
(define (get op tag-list) (hash-ref op-table (cons op tag-list)))
;; procedure table for type coercion operations
(define coercion-table (make-hash))
(define (put-project type proc)
(hash-set! coercion-table (cons 'project type) proc))
(define (can-project? arg)
(member (cons 'project (type-tag arg)) (hash-keys coercion-table)))
(define (project arg)
((hash-ref coercion-table (cons 'project (type-tag arg))) arg))
;; raising the type
(define (put-raise type proc)
(hash-set! coercion-table (cons 'raise type) proc))
(define (can-raise? arg)
(member (cons 'raise (type-tag arg)) (hash-keys coercion-table)))
(define (raise arg)
((hash-ref coercion-table (cons 'raise (type-tag arg))) arg))
;; variable dictionaries
(define next-higher-variable (make-hash))
(define next-lower-variable (make-hash))
(define (install-variable-dictionaries)
(define (loop var)
(cond [(eq? var LOWEST-VARIABLE) 'done]
[else
(define next-lower (second (member var VARIABLE-LIST)))
(hash-set! next-lower-variable var next-lower)
(hash-set! next-higher-variable next-lower var)
(loop next-lower)]))
(loop HIGHEST-VARIABLE))
(install-variable-dictionaries)
(define (next-higher var) (hash-ref next-higher-variable var))
(define (next-lower var) (hash-ref next-lower-variable var))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; APPLY-GENERIC AND HELPER FUNCTIONS ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; procedures for handling type tags
(define (attach-tag type-tag datum)
(cond [(exact-integer? datum) datum]
[(inexact-real? datum) datum]
[else (cons type-tag datum)]))
(define (type-tag datum)
(cond [(exact-integer? datum) 'integer]
[(inexact-real? datum) 'real]
[(pair? datum) (first datum)]
[else (error "Bad tagged datum -- TYPE-TAG:" datum)]))
(define (contents datum)
(cond [(exact-integer? datum) datum]
[(inexact-real? datum) datum]
[(pair? datum) (cdr datum)]
[else (error "Bad tagged datum -- CONTENTS:" datum)]))
;; type coercion and simplification
(define (simplify arg)
; Simplify arg to the lowest possible correct type.
(cond [(can-project? arg)
(define projected-arg (project arg))
(if (equ? arg (raise projected-arg))
(simplify projected-arg)
arg)]
[else arg]))
(define (highest-type tag-list)
; Return the highest type in tag-list.
(define (loop type arg)
(cond [(can-raise? arg)
(define raised-arg (raise arg))
(define raised-type (type-tag raised-arg))
(if (member raised-type tag-list)
(loop raised-type raised-arg)
(loop type raised-arg))]
[else type]))
(loop 'integer 1))
(define (coerce arg target-type)
; Raise arg until it has type target-type. Assume type of arg <= target-type.
(if (equal? (type-tag arg) target-type)
arg
(coerce (raise arg) target-type)))
(define (coerce-all args target-type)
; Coerce all arguments to the target type.
(map (lambda (arg) (coerce arg target-type)) args))
;; the generic application procedure
(define (apply-generic op . args)
; Dispatch by type.
(define (simplify-result datum)
(if (can-simplify? op)
(simplify datum)
datum))
(define type-tags (map type-tag args))
(cond [(can-apply? op type-tags)
(simplify-result (apply (get op type-tags) (map contents args)))]
[(andmap (lambda (type) (equal? type (first type-tags))) type-tags)
(error "No method available -- APPLY-GENERIC:" op type-tags)]
[else
(define coerced-args (coerce-all args (highest-type type-tags)))
(simplify-result (apply (get op (map type-tag coerced-args))
(map contents coerced-args)))]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; THE GENERIC OPERATIONS ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; constructors and selectors
(define (make-integer a) ((get 'make 'integer) a))
(define (make-rational-number n d) ((get 'make 'rational-number) n d))
(define (make-rational-function n d) ((get 'make 'rational-function) n d))
(define (make-real x) ((get 'make 'real) x))
;; complex numbers
(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 (re-part z) (apply-generic 're-part z))
(define (im-part z) (apply-generic 'im-part z))
(define (mag-part z) (apply-generic 'mag-part z))
(define (ang-part z) (apply-generic 'ang-part z))
;; polynomials
(define (make-poly-from-dense-termlist var term-list)
((get 'make-from-dense-termlist `(polynomial ,var)) term-list))
(define (make-poly-from-sparse-termlist var term-list)
((get 'make-from-sparse-termlist `(polynomial ,var)) term-list))
;; generic operations
(define (=zero? x) (apply-generic '=zero? x))
(define (absolute x) (apply-generic 'absolute x))
(define (add x y) (apply-generic 'add x y))
(define (arctan y x) (apply-generic 'arctan y x))
(define (constant-term p) (apply-generic 'constant-term p))
(define (cosine x) (apply-generic 'cosine x))
(define (div x y) (apply-generic 'div x y))
(define (equ? x y) (apply-generic 'equ? x y))
(define (expo x y) (apply-generic 'expo x y))
(define (first-term p) (apply-generic 'first-term p))
(define (greatest-common-divisor x y)
(apply-generic 'greatest-common-divisor x y))
(define (mul x y) (apply-generic 'mul x y))
(define (polynomial-division p1 p2)
(apply-generic 'polynomial-division p1 p2))
(define (reduce x y) (apply-generic 'reduce x y))
(define (sine x) (apply-generic 'sine x))
(define (sqroot x) (apply-generic 'sqroot x))
(define (square x) (apply-generic 'square x))
(define (sub x y) (apply-generic 'sub x y))
;;;;;;;;;;;;;;;
;; INTEGERS ;;
;;;;;;;;;;;;;;;
(define (install-integer-package)
;; internal procedures
(define (make-integer a)
(define int (floor a))
(if (exact? int)
int
(inexact->exact int)))
(define (=zero-integer? a) (= a 0))
(define (gcd-integer a b)
(if (= b 0) a (gcd-integer b (remainder a b))))
(define (reduce-integer n d)
(define g (gcd-integer n d))
(list (/ n g) (/ d g)))
(define arctan (compose make-real atan))
(define cosine (compose make-real cos))
(define sine (compose make-real sin))
(define sqroot (compose make-real sqrt))
;; coercion procedures
(define (raise a) (make-rational-number a 1))
(put-raise 'integer raise)
;; interface to the rest of the system
(put 'make 'integer make-integer)
(put '=zero? '(integer) =zero-integer?)
(put 'absolute '(integer) abs)
(put 'add '(integer integer) +)
(put 'arctan '(integer integer) arctan)
(put 'cosine '(integer) cosine)
(put 'div '(integer integer) make-rational-number)
(put 'equ? '(integer integer) =)
(put 'expo '(integer integer) expt)
(put 'greatest-common-divisor '(integer integer) gcd-integer)
(put 'mul '(integer integer) *)
(put 'reduce '(integer integer) reduce-integer)
(put 'sine '(integer) sine)
(put 'sqroot '(integer) sqroot)
(put 'square '(integer) sqr)
(put 'sub '(integer integer) -)
)
(install-integer-package)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; RATIONAL NUMBERS AND RATIONAL FUNCTIONS ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (install-rational-package)
;; internal procedures
(define (make-rat n d) (reduce n d))
(define (numer x) (first x))
(define (denom x) (second x))
(define (=zero-rat? x) (=zero? (numer x)))
(define (equ-rat? x y) (equ? (mul (numer x) (denom y))
(mul (denom x) (numer y))))
(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))))
;; procedures for rational numbers only
(define (absolute x) (make-real (abs (/ (numer x) (denom x)))))
(define (arctan y x) (make-real (atan (/ (numer y) (denom y)))))
(define (cosine x) (make-real (cos (/ (numer x) (denom x)))))
(define (expo-ratnum x y) (make-real (expt (/ (numer x) (denom x))
(/ (numer y) (denom y)))))
(define (sine x) (make-real (sin (/ (numer x) (denom x)))))
(define (square x) (make-rat (sqr (numer x)) (sqr (denom x))))
(define (sqroot x) (make-real (sqrt (/ (numer x) (denom x)))))
;; procedures for rational functions only
(define (expo-ratfunc x n)
(cond [(and (integer? n) (positive? n))
(if (= n 1)
x
(mul-rat x (expo-ratfunc x (sub1 n))))]
[else
(error "Exponent must be a positive integer -- EXPO-RATFUNC:" x n)]))
;; coercion procedures for rational numbers
(define (project-rat x) (make-integer (floor (/ (numer x) (denom x)))))
(define (raise-rat x) (make-real (/ (numer x) (denom x))))
(put-project 'rational-number (compose project-rat contents))
(put-raise 'rational-number (compose raise-rat contents))
;; interface to the rest of the system for rational numbers
(define (tag-as-number x) (attach-tag 'rational-number x))
(put 'make 'rational-number
(compose tag-as-number make-rat))
(put '=zero? '(rational-number) =zero-rat?)
(put 'absolute '(rational-number) absolute)
(put 'add '(rational-number rational-number)
(compose tag-as-number add-rat))
(put 'arctan '(rational-number rational-number) arctan)
(put 'cosine '(rational-number) cosine)
(put 'div '(rational-number rational-number)
(compose tag-as-number div-rat))
(put 'equ? '(rational-number rational-number) equ-rat?)
(put 'expo '(rational-number rational-number) expo-ratnum)
(put 'mul '(rational-number rational-number)
(compose tag-as-number mul-rat))
(put 'sine '(rational-number) sine)
(put 'sqroot '(rational-number) sqroot)
(put 'square '(rational-number) (compose tag-as-number square))
(put 'sub '(rational-number rational-number)
(compose tag-as-number sub-rat))
;; interface to the rest of the system for rational functions
(define (tag-as-function x) (attach-tag 'rational-function x))
(put 'make 'rational-function
(compose tag-as-function make-rat))
(put '=zero? '(rational-function) =zero-rat?)
(put 'add '(rational-function rational-function)
(compose tag-as-function add-rat))
(put 'div '(rational-function rational-function)
(compose tag-as-function div-rat))
(put 'equ? '(rational-function rational-function) equ-rat?)
(put 'expo '(rational-function integer)
(compose tag-as-function expo-ratfunc))
(put 'mul '(rational-function rational-function)
(compose tag-as-function mul-rat))
(put 'sub '(rational-function rational-function)
(compose tag-as-function sub-rat))
)
(install-rational-package)
;;;;;;;;;;;;;;;;;;
;; REAL NUMBERS ;;
;;;;;;;;;;;;;;;;;;
(define (install-real-package)
;; internal procedures
(define (make-real x) ; x is a racket number or has lower type
(cond [(pair? x) (raise x)]
[(exact? x) (exact->inexact x)]
[else x]))
; Account for floating-point error.
(define (=zero-real? x) (< (abs x) 0.000000001))
(define (equ-real? x y) (< (abs (- x y)) 0.000000001))
;; coercion procedures
(define (project-real x)
(make-rational-number (make-integer (floor (* x 1000000000))) 1000000000))
(define (raise-real x) (make-complex-from-real-imag x 0))
(put-project 'real project-real)
(put-raise 'real raise-real)
;; interface to the rest of the system
(put 'make 'real make-real)
(put '=zero? '(real) =zero-real?)
(put 'absolute '(real) abs)
(put 'add '(real real) +)
(put 'arctan '(real real) atan)
(put 'cosine '(real) cos)
(put 'div '(real real) /)
(put 'equ? '(real real) =)
(put 'expo '(real real) expt)
(put 'mul '(real real) *)
(put 'sine '(real) sin)
(put 'sqroot '(real) sqrt)
(put 'square '(real) sqr)
(put 'sub '(real real) -)
)
(install-real-package)
;;;;;;;;;;;;;;;;;;;;;
;; COMPLEX NUMBERS ;;
;;;;;;;;;;;;;;;;;;;;;
(define (install-complex-package)
;; rectangular coordinates
(define (install-rectangular-package)
;; internal procedures
(define (make-from-real-imag x y) (list x y))
(define (re-part z) (first z))
(define (im-part z) (second z))
(define (make-from-mag-ang r a)
(list (mul r (cosine a))
(mul r (sine a))))
(define (mag-part z)
(sqroot (add (square (re-part z))
(square (im-part z)))))
(define (ang-part z) (arctan (im-part z) (re-part z)))
;; interface to the rest of the system
(define (tag z) (attach-tag 'rectangular z))
(put 'make-from-mag-ang 'rectangular (compose tag make-from-mag-ang))
(put 'make-from-real-imag 'rectangular (compose tag make-from-real-imag))
(put 're-part '(rectangular) re-part)
(put 'im-part '(rectangular) im-part)
(put 'mag-part '(rectangular) mag-part)
(put 'ang-part '(rectangular) ang-part)
)
(install-rectangular-package)
;; polar coordinates
(define (install-polar-package)
;; internal procedures
(define (make-from-mag-ang r a) (list r a))
(define (mag-part z) (first z))
(define (ang-part z) (second z))
(define (make-from-real-imag x y)
(list (sqroot (add (square x) (square y)))
(arctan y x)))
(define (re-part z) (mul (mag-part z) (cosine (ang-part z))))
(define (im-part z) (mul (mag-part z) (sine (ang-part z))))
;; interface to the rest of the system
(define (tag x) (attach-tag 'polar x))
(put 'make-from-mag-ang 'polar (compose tag make-from-mag-ang))
(put 'make-from-real-imag 'polar (compose tag make-from-real-imag))
(put 're-part '(polar) re-part)
(put 'im-part '(polar) im-part)
(put 'mag-part '(polar) mag-part)
(put 'ang-part '(polar) ang-part)
)
(install-polar-package)
;; imported procedures from rectangular and polar subpackages
(define make-from-real-imag (get 'make-from-real-imag 'rectangular))
(define make-from-mag-ang (get 'make-from-mag-ang 'polar))
;; internal complex number procedures
(define (=zero-complex? z) ; account for floating-point error
(and (< (absolute (re-part z)) 0.000000001)
(< (absolute (im-part z)) 0.000000001)))
(define (equ? z1 z2) ; account for floating-point error
(and (< (absolute (sub (re-part z1) (re-part z2))) 0.000000001)
(< (absolute (sub (im-part z1) (im-part z2))) 0.000000001)))
(define (add-complex z1 z2)
(make-from-real-imag (add (re-part z1) (re-part z2))
(add (im-part z1) (im-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (sub (re-part z1) (re-part z2))
(sub (im-part z1) (im-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (mul (mag-part z1) (mag-part z2))
(add (ang-part z1) (ang-part z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (div (mag-part z1) (mag-part z2))
(sub (ang-part z1) (ang-part z2))))
(define (expo-complex z1 z2)
(define w (expt (+ (make-real (re-part z1))
(* (make-real (im-part z1)) 0+i))
(+ (make-real (re-part z2))
(* (make-real (im-part z2)) 0+i))))
(make-from-real-imag (real-part w) (imag-part w)))
;; coercion procedures
(define (project-complex z) (make-real (re-part z)))
(define (raise-complex z)
(make-poly-from-dense-termlist LOWEST-VARIABLE (list (simplify z))))
(put-project 'complex project-complex)
(put-raise 'complex raise-complex)
;; interface to the rest of the system
(define (tag z) (attach-tag 'complex z))
(put 'make-from-mag-ang 'complex
(compose tag make-from-mag-ang))
(put 'make-from-real-imag 'complex
(compose tag make-from-real-imag))
(put '=zero? '(complex) =zero-complex?)
(put 'add '(complex complex) (compose tag add-complex))
(put 'ang-part '(complex) ang-part)
(put 'div '(complex complex) (compose tag div-complex))
(put 'equ? '(complex complex) equ?)
(put 'expo '(complex complex) (compose tag expo-complex))
(put 'im-part '(complex) im-part)
(put 'mag-part '(complex) mag-part)
(put 'mul '(complex complex) (compose tag mul-complex))
(put 're-part '(complex) re-part)
(put 'sub '(complex complex) (compose tag sub-complex))
)
(install-complex-package)
;;;;;;;;;;;;;;;;;
;; POLYNOMIALS ;;
;;;;;;;;;;;;;;;;;
(define (install-polynomial-package)
;; term list representations
;; sparse term lists
(define (install-sparse-termlist-package)
;; constructors and selectors
(define (make-term order coeff) (list order coeff))
(define (order term) (first term))
(define (coeff term) (second term))
(define (the-empty-termlist) empty)
(define empty-termlist? null?)
(define (first-term L)
(if (empty-termlist? L)
(make-term 0 0)
(first L)))
(define (rest-terms L) (cdr L))
(define (dense->sparse DL)
(cond [(null? DL) (the-empty-termlist)]
[(=zero? (first DL)) (dense->sparse (cdr DL))]
[else (cons (make-term (- (length DL) 1)
(first DL))
(dense->sparse (cdr DL)))]))
;; procedures for generic operations
(define (adjoin-term term L)
(if (=zero? (coeff term))
L
(cons term L)))
(define (constant-term L)
(cond [(empty-termlist? L)
(make-term 0 0)]
[else
(define last-term (last L))
(if (zero? (order last-term))
last-term
(make-term 0 0))]))
(define (negate-terms L)
(map (lambda (term)
(make-term (order term)
(mul -1 (coeff term))))
L))
(define (reduce-coefficients L) ; divide all coeffs by their gcd
(define (list-of-coefficients term-list)
; Return a list of coefficients in no particular order.
(foldr (lambda (term a-list)
(cons (second term) a-list))
empty
term-list))
(define gcf (foldr greatest-common-divisor
0
(list-of-coefficients L)))
(map (lambda (term)
(make-term (order term)
(div (coeff term) gcf)))
L))
;; interface to the rest of the system
(define (tag-as-sparse x) (attach-tag 'sparse x))
(define (tag-as-term x) (attach-tag 'term x))
(put 'make-from-dense-termlist 'sparse
(compose tag-as-sparse dense->sparse))
(put 'make-from-sparse-termlist 'sparse tag-as-sparse)
(put 'adjoin-term '(term sparse)
(compose tag-as-sparse adjoin-term))
(put 'constant-term '(sparse)
(compose tag-as-term constant-term))
(put 'first-term '(sparse)
(compose tag-as-term first-term))
(put 'negate-terms '(sparse)
(compose tag-as-sparse negate-terms))
(put 'reduce-coefficients '(sparse)
(compose tag-as-sparse reduce-coefficients))
(put 'rest-terms '(sparse)
(compose tag-as-sparse rest-terms))
)
(install-sparse-termlist-package)
;; dense term lists
(define (install-dense-termlist-package)
;; internal procedures
(define (make-term order coeff) (list order coeff))
(define (order term) (first term))
(define (coeff term) (second term))
(define (the-empty-termlist) empty)
(define empty-termlist? null?)
(define (first-term L)
(if (empty-termlist? L)
(make-term 0 0)
(make-term (- (length L) 1)
(first L))))
(define (rest-terms L) (cdr L))
(define (sparse->dense SL)
(define (list-of-zeroes n) (for/list ([i (in-range n)]) 0))
(cond [(empty? SL)
(the-empty-termlist)]
[else
(define first-term (first SL))
(cond [(=zero? (coeff first-term))
(sparse->dense (rest SL))]
[(empty? (rest SL)) ; only one term in SL
(cons (coeff first-term)
(list-of-zeroes (order first-term)))]
[else
(define second-term (second SL))
(append (cons (coeff first-term)
(list-of-zeroes (- (order first-term)
(order second-term)
1)))
(sparse->dense (rest SL)))])]))
(define (adjoin-term term L) ; order >= length L
(define (loop term-list)
(if (> (order term) (length term-list))
(loop (cons 0 term-list))
(cons (coeff term) term-list)))
(if (=zero? (coeff term))
L
(loop L)))
(define (constant-term L)
(if (empty-termlist? L)
(make-term 0 0)
(make-term 0 (last L))))
(define (negate-terms L)
(map (lambda (coefficient)
(mul -1 coefficient))
L))
(define (reduce-coefficients L) ; divide all coeffs by their gcd
(define gcf (foldr greatest-common-divisor 0 L))
(map (lambda (coeff)
(div coeff gcf))
L))
;; interface to the rest of the system
(define (tag-as-dense x) (attach-tag 'dense x))
(define (tag-as-term x) (attach-tag 'term x))
(put 'make-from-dense-termlist 'dense tag-as-dense)
(put 'make-from-sparse-termlist 'dense
(compose tag-as-dense sparse->dense))
(put 'adjoin-term '(term dense)
(compose tag-as-dense adjoin-term))
(put 'constant-term '(dense)
(compose tag-as-term constant-term))
(put 'first-term '(dense)
(compose tag-as-term first-term))
(put 'negate-terms '(dense)
(compose tag-as-dense negate-terms))
(put 'reduce-coefficients '(dense)
(compose tag-as-dense reduce-coefficients))
(put 'rest-terms '(dense)
(compose tag-as-dense rest-terms))
)
(install-dense-termlist-package)
;; imported procedures from the term list subpackages
(define make-from-dense-termlist
(get 'make-from-dense-termlist TERMLIST-OUTPUT-TYPE))
(define make-from-sparse-termlist
(get 'make-from-sparse-termlist TERMLIST-OUTPUT-TYPE))
;; term and term list operations
(define (make-term order coeff) (list 'term order coeff))
(define (order term) (second term))
(define (coeff term) (third term))
(define (rest-terms L) (apply-generic 'rest-terms L))
(define (the-empty-termlist) (list TERMLIST-OUTPUT-TYPE))
(define (empty-termlist? L) (null? (contents L)))
(define (=zero-termlist? L)
(or (empty-termlist? L)
(and (=zero? (coeff (first-term L)))
(=zero-termlist? (rest-terms L)))))
(define (reduce-coefficients L)
(apply-generic 'reduce-coefficients L))
(define (adjoin-term term L) (apply-generic 'adjoin-term term L))
(define (negate-terms L) (apply-generic 'negate-terms L))
(define (add-terms L1 L2)
(cond [(empty-termlist? L1) L2]
[(empty-termlist? L2) L1]
[else
(define t1 (first-term L1))
(define 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 (sub-terms L1 L2) (add-terms L1 (negate-terms L2)))
(define (equ-termlist? L1 L2)
(=zero-termlist? (sub-terms L1 L2)))
(define (mul-term-by-all-terms t1 L)
(cond [(empty-termlist? L)
(the-empty-termlist)]
[else
(define t2 (first-term L))
(adjoin-term
(make-term (+ (order t1) (order t2))
(mul (coeff t1) (coeff t2)))
(mul-term-by-all-terms t1 (rest-terms L)))]))
(define (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 (div-terms L1 L2)
(cond [(empty-termlist? L1)
(list (the-empty-termlist) (the-empty-termlist))]
[else
(define t1 (first-term L1))
(define t2 (first-term L2))
(cond [(> (order t2) (order t1))
(list (the-empty-termlist) L1)]
[else
(define divisor-term
(make-term (- (order t1) (order t2))
(div (coeff t1) (coeff t2))))
(define rest-of-result
(div-terms (sub-terms L1
(mul-term-by-all-terms divisor-term
L2))
L2))
(list (adjoin-term divisor-term (first rest-of-result))
(second rest-of-result))])]))
(define (divisor-termlist L1 L2) (first (div-terms L1 L2)))
(define (remainder-termlist L1 L2) (second (div-terms L1 L2)))
(define (expo-terms L n)
(cond [(positive? n)
(if (= n 1)
L
(mul-terms L (expo-terms L (sub1 n))))]
[else
(error "Exponent must be a positive integer -- EXPO-TERMS:" L n)]))
(define (gcd-terms a b)
(if (empty-termlist? b)
a
(gcd-terms b (remainder-termlist a b))))
(define (pseudo-remainder-termlist L1 L2)
; Clear denominators from remainder-termlist.
(remainder-termlist (mul-term-by-all-terms
(make-term 0 (expt (coeff (first-term L2))
(+ 1
(order (first-term L1))
(- (order (first-term L2))))))
L1)
L2))
(define (pseudo-gcd-terms a b)
; Return a gcd term list with integer coefficients.
(if (empty-termlist? b)
a
(pseudo-gcd-terms b (pseudo-remainder-termlist a b))))
(define (reduce-terms a b)
(define (same-sign? L1 L2)
(positive? (make-real
(re-part
(coerce (mul (coeff (first-term L1))
(coeff (first-term L2)))
'complex)))))
(define (fix-signs L1 L2)
; Ensure the leading coefficient of L1/L2 is the same as that of a/b.
(cond [(and (same-sign? a L1) (not (same-sign? b L2)))
(list L1 (negate-terms L2))]
[(and (not (same-sign? a L1)) (same-sign? b L2))
(list (negate-terms L1) L2)]
[(and (not (same-sign? a L1)) (not (same-sign? b L2)))
(list (negate-terms L1) (negate-terms L2))]
[else (list L1 L2)]))
(define pseudo-gcf (pseudo-gcd-terms a b))
(define (integerizing-factor L1 L2)
(expt (coeff (first-term pseudo-gcf))
(+ 1 (max (order (first-term L1)) (order (first-term L2)))
(- (order (first-term pseudo-gcf))))))
(define (clear-denominators L)
(mul-term-by-all-terms (make-term 0 (integerizing-factor a b))
L))
(apply fix-signs
(map (lambda (term-list) (reduce-coefficients
(divisor-termlist
(clear-denominators term-list)
pseudo-gcf)))
(list a b))))
;; polynomial operations
(define (make-poly var term-list)
(attach-tag `(polynomial ,var) term-list))
(define (variable poly) (second (first poly)))
(define (term-list poly) (rest poly))
;; coercion operations
; Coercion procedures act on tagged polynomials.
(define (project-poly-to-complex p)
(coerce (coeff (constant-term (term-list p))) 'complex))
(define (project-poly-to-poly p)
(coerce (coeff (constant-term (term-list p)))
`(polynomial ,(next-lower (variable p)))))
(define (raise-poly p)
(make-poly-from-dense-termlist (next-higher (variable p)) (list p)))
(define (install-coercion-procedures)
(define (loop var) ; assume there is more than one variable
(cond [(eq? var HIGHEST-VARIABLE) ; start of the loop
(put-project `(polynomial ,var) project-poly-to-poly)
(loop (next-lower var))]
[(eq? var LOWEST-VARIABLE) ; end of the loop
(put-project `(polynomial ,var) project-poly-to-complex)
(put-raise `(polynomial ,var) raise-poly)
'done]
[else ; middle of the loop
(put-project `(polynomial ,var) project-poly-to-poly)
(put-raise `(polynomial ,var) raise-poly)
(loop (next-lower var))]))
(if (eq? HIGHEST-VARIABLE LOWEST-VARIABLE) ; only one variable
(put-project `(polynomial ,LOWEST-VARIABLE) project-poly-to-complex)
(loop HIGHEST-VARIABLE)))
(install-coercion-procedures)
;; interface to the rest of the system
; Generic procedures act on the contents of polynomials, ie term lists.
(define (install-generic-procedures)
(define (loop var)
(put 'make-from-dense-termlist `(polynomial ,var)
(compose (curry make-poly var) make-from-dense-termlist))
(put 'make-from-sparse-termlist `(polynomial ,var)
(compose (curry make-poly var) make-from-sparse-termlist))
(put '=zero? `((polynomial ,var)) =zero-termlist?)
(put 'equ? `((polynomial ,var) (polynomial ,var)) equ-termlist?)
(put 'add `((polynomial ,var) (polynomial ,var))
(compose (curry make-poly var) add-terms))
(put 'sub `((polynomial ,var) (polynomial ,var))
(compose (curry make-poly var) sub-terms))
(put 'mul `((polynomial ,var) (polynomial ,var))
(compose (curry make-poly var) mul-terms))
(put 'expo `((polynomial ,var) integer)
(compose (curry make-poly var) expo-terms))
(put 'first-term `((polynomial ,var)) first-term)
(put 'constant-term `((polynomial ,var)) constant-term)
(if (eq? var LOWEST-VARIABLE)
(begin
(put 'polynomial-division
`((polynomial ,LOWEST-VARIABLE)
(polynomial ,LOWEST-VARIABLE))
(lambda (L1 L2)
(map (curry make-poly LOWEST-VARIABLE)
(div-terms L1 L2))))
(put 'greatest-common-divisor
`((polynomial ,LOWEST-VARIABLE)
(polynomial ,LOWEST-VARIABLE))
; return a gcd with reduced integer coefficients
(compose (curry make-poly LOWEST-VARIABLE)
reduce-coefficients
pseudo-gcd-terms))
(put 'reduce
`((polynomial ,LOWEST-VARIABLE)
(polynomial ,LOWEST-VARIABLE))
(lambda (L1 L2) (map (curry make-poly LOWEST-VARIABLE)
(reduce-terms L1 L2))))
)
(loop (next-lower var))))
(loop HIGHEST-VARIABLE))
(install-generic-procedures)
)
(install-polynomial-package)
;;;;;;;;;;;
;; TESTS ;;
;;;;;;;;;;;
;; NUMBERS
(=zero? (sub (make-complex-from-real-imag (make-rational-number 1 2)
0.75)
(make-complex-from-real-imag 0.5
(make-rational-number 3 4))))
;; #t
(equ? (expo (make-complex-from-mag-ang 1 1) pi)
-1) ; e ^ (i * pi) = -1
;; #t
(mul 0.25 (make-complex-from-real-imag 4 0))
;; 1
;; POLYNOMIALS IN DIFFERENT VARIABLES
(define p (make-poly-from-dense-termlist 'x '(1 2 3)))
(define q (make-poly-from-dense-termlist 'y '(4 5 6)))
(add p q)
;; '((polynomial x) dense 1 2 ((polynomial y) dense 4 5 9))
(sub p q)
;; '((polynomial x) dense 1 2 ((polynomial y) dense -4 -5 -3))
(mul p q)
;; '((polynomial x)
;; dense
;; ((polynomial y) dense 4 5 6)
;; ((polynomial y) dense 8 10 12)
;; ((polynomial y) dense 12 15 18))
;; POLYNOMIALS IN THE SAME VARIABLE
(define p1 (make-poly-from-dense-termlist 'z '(1 1)))
(define p2 (make-poly-from-dense-termlist 'z '(1 0 1)))
(mul p1 p2)
;; '((polynomial z) dense 1 1 1 1)
(expo p1 3)
;; '((polynomial z) dense 1 3 3 1)
(reduce (mul p1 p2) (expo p1 3))
;; '(((polynomial z) dense 1 0 1) ((polynomial z) dense 1 2 1))
(polynomial-division
(make-poly-from-dense-termlist 'z '(32 0 0 0 0 -243))
(make-poly-from-dense-termlist 'z '(2 -3)))
;; '(((polynomial z) dense 16 24 36 54 81) ((polynomial z) dense))
;; RATIONAL FUNCTIONS
(define r1 (make-rational-function
(make-poly-from-dense-termlist 'z '(1 3 3 1))
(make-poly-from-dense-termlist 'z '(1 -2 1)))) ; (x+1)^3/(x-1)^2
r1
;; '(rational-function
;; ((polynomial z) dense 1 3 3 1)
;; ((polynomial z) dense 1 -2 1))
(define r2 (make-rational-function
(make-poly-from-dense-termlist 'z '(1 -3 3 -1))
(make-poly-from-dense-termlist 'z '(1 2 1)))) ; (x-1)^3/(x+1)^2
r2
;; '(rational-function
;; ((polynomial z) dense 1 -3 3 -1)
;; ((polynomial z) dense 1 2 1))
(add r1 r2)
;; '(rational-function
;; ((polynomial z) dense 1 0 10 0 5 0)
;; ((polynomial z) dense 1 0 -2 0 1))
(mul r1 r2)
;; '(rational-function ((polynomial z) dense 1 0 -1) ((polynomial z) dense 1))
(div r1 r2)
;; '(rational-function
;; ((polynomial z) dense 1 5 10 10 5 1)
;; ((polynomial z) dense 1 -5 10 -10 5 -1))
;; WITH SPARSE OUTPUT
(define s (make-poly-from-dense-termlist
'y
`(1
2.0
,(make-rational-number 6 2)
,(make-complex-from-real-imag 4 0)
,(make-complex-from-mag-ang -5 pi))))
(expo s 6) ; (y^4 + 2*y^3 + 3*y^2 + 4*y + 5) ^ 6
;; '((polynomial y)
;; sparse
;; (24 1)
;; (23 12)
;; (22 78)
;; (21 364)
;; (20 1365)
;; (19 4332)
;; (18 11974)
;; (17 29376)
;; (16 64818)
;; (15 129740)
;; (14 236958)
;; (13 396516)
;; (12 609389)
;; (11 860772)
;; (10 1117050)
;; (9 1329584)
;; (8 1446498)
;; (7 1430532)
;; (6 1276546)
;; (5 1016220)
;; (4 709125)
;; (3 422500)
;; (2 206250)
;; (1 75000)
;; (0 15625))
Comments
0 B
|👍
/👎
0 B
|👍
/👎