Skip to content

Instantly share code, notes, and snippets.

@mururu

mururu/0415.scm

Last active December 16, 2015 05:49
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save mururu/5387191 to your computer and use it in GitHub Desktop.
Save mururu/5387191 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
0415.scm
(define false #f)
(define true #t)
(define (p a)
(print a))
(define (pb a)
(print a)
(print ""))
(define (start a)
(display a)
(pb "========================================"))
(define (finish a)
(display a)
(pb "========================================/"))
(define (attach-tag type-tag contents)
(if (eq? type-tag 'scheme-number)
contents
(cons type-tag contents)))
(define (type-tag datum)
(if (pair? datum)
(car datum)
'scheme-number))
(define (contents datum)
(if (pair? datum)
(cdr datum)
datum))
(define (square x) (* x x))
(define (install-rectangular-package)
(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))))
(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 x y))))
'done)
(define (install-polar-package)
(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)))
(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 x y))))
'done)
(define (apply-generic op . args)
(print 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))))))
(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-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation --TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(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 (rem x y) (apply-generic 'rem x y))
(define (install-scheme-number-package)
(define (gcd a b)
(if (= b 0)
a
(gcd b (remainder a b))))
(define (reduce-interges n d)
(let ((g (gcd n d)))
(list (/ n g) (/ d g))))
(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 'greatest-common-divisor '(scheme-number scheme-number)
(lambda (x y) (tag (gcd x y))))
(put 'reduce '(scheme-number scheme-number)
(lambda (x y) (map tag (reduce-integers x y))))
(put 'make 'scheme-number
(lambda (x) (tag x)))
(put 'nega '(scheme-number)
(lambda (x) (tag (- x))))
'done)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
(define (install-complex-package)
(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))
(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))))
(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 (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 (add-complex-to-schemenum z x)
(make-from-real-imag (+ (real-part z) x)
(imag-part z)))
(put 'add '(complex scheme-number)
(lambda (z x) (tag (add-complex-to-schemenum z x))))
(define (scheme-number->complex n)
(make-complex-from-real-imag (contents n) 0))
(define coercion-table (make-table))
(define get-coercion (coercion-table 'lookup-proc))
(define put-coercion (coercion-table 'insert-proc!))
(put-coercion 'scheme-number 'complex scheme-number->complex)
(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)))
(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)))))))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
(define (make-polynomial var terms)
((get 'make 'polynomial) var terms))
(define (install-=zero?-package)
(define (=zero?-scheme-number n)
(eq? n 0))
(define (=zero?-rational x)
(eq? (car x) 0))
(define (=zero?-complex x)
(eq? (magnitude x) 0))
(put '=zero? '(scheme-number)
(lambda (x) (=zero?-scheme-number x)))
(put '=zero? '(rational)
(lambda (x) (=zero?-rational x)))
(put '=zero? '(complex)
(lambda (x) (=zero?-complex x)))
'done)
(define (=zero? x) (apply-generic '=zero? x))
(define (install-nega-package)
(define (nega-scheme-number n)
(- n))
(put 'nega '(scheme-number)
(lambda (x) (nega-scheme-number x)))
'done)
(define (nega x) (apply-generic 'nega x))
(define (make-polynomial n d)
((get 'make 'polynomial) n d))
(define (make-rational n d)
((get 'make 'rational) n d))
(install-scheme-number-package)
(install-=zero?-package)
Raw
Makefile
test: q2.88 q2.89 q2.90 q2.90.2 q2.91 q2.92 q2.93 q2.94 q2.95 q2.96 q2.97
q2.88:
gosh q2.88.scm
q2.89:
gosh q2.89.scm
q2.90:
gosh q2.90.scm
q2.90.2:
gosh q2.90.2.scm
q2.91:
gosh q2.91.scm
q2.92:
gosh q2.92.scm
q2.93:
gosh q2.93.scm
q2.94:
gosh q2.94.scm
q2.95:
gosh q2.95.scm
q2.96:
gosh q2.96.scm
q2.97:
gosh q2.97.scm
Raw
q2.88.scm
(define (install-polynomial-package)
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p) (cdr p))
(define (=zero?-poly p)
(=zero?-terms (term-list p)))
(define (=zero?-terms L)
(or (empty-termlist? L)
(and (=zero? (cadr (first-term L))) (=zero?-terms (rest-terms L)))))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
(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 (sub-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(add-poly p1 (nega-poly p2))
(error "Polys not in same var -- SUB-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 (div-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(let ((answer ((div-terms (term-list p1)
(term-list p2)))))
(make-poly (variable p1) (car answer)))
(error "Polys not in same var -- DIV-POLY"
(list p1 p2))))
(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-terms L1 L2)
(cond ((empty-termlist? L1) L2)
((empty-termlist? L2) L1)
(else
(let ((t1 (first-term L1)) (t2 (first-term L2)))
(cond ((> (order t1) (order t2))
(adjoin-term
t1 (add-terms (rest-terms L1) L2)))
((< (order t1) (order t2))
(adjoin-term
t2 (add-terms L1 (rest-terms L2))))
(else
(adjoin-term
(make-term (order t1)
(add (coeff t1) (coeff t2)))
(add-terms (rest-terms L1)
(rest-terms L2)))))))))
(define (mul-terms L1 L2)
(if (empty-termlist? L1)
(the-empty-termlist)
(add-terms (mul-term-by-all-terms (first-term L1) L2)
(mul-terms (rest-terms L1) L2))))
(define (mul-term-by-all-terms t1 L)
(if (empty-termlist? L)
(the-empty-termlist)
(let ((t2 (first-term L)))
(adjoin-term
(make-term (+ (order t1) (order t2))
(mul (coeff t1) (coeff t2)))
(mul-term-by-all-terms t1 (rest-terms L))))))
(define (nega-poly p)
(define nega-term-list (map nega-term (term-list p)))
(cons (variable p) nega-term-list))
(define (nega-term term)
(make-term (order term)
(nega (coeff term))))
(define (tag p) (attach-tag 'polynomial p))
(put 'add '(polynomial polynomial)
(lambda (p1 p2) (tag (add-poly p1 p2))))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2) (tag (sub-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))))
(put '=zero? '(polynomial)
(lambda (p) (=zero?-poly p)))
(put 'nega '(polynomial)
(lambda (p) (tag (nega-poly p))))
'done)
; ====== q2.88
(load "./0415.scm")
(start "q2.88")
(install-polynomial-package)
(define p1 (make-polynomial 'x '((5 1) (0 -1))))
(define p2 (make-polynomial 'x '((2 1) (0 -1))))
(define q1 (make-polynomial 'y `((1 ,p1) (0 ,p2))))
(define q2 (make-polynomial 'y `((1 ,p2) (0 ,p1))))
(p "整数係数")
(p "p1:")
(p p1)
(p "p2:")
(pb p2)
(p "(add p1 p2)")
(pb (add p1 p2))
(p "(sub p1 p2)")
(pb (sub p1 p2))
(p "(mul p1 p2)")
(pb (mul p1 p2))
(p "多項式係数")
(p "q1:")
(p q1)
(p "q2:")
(pb q2)
(p "(add q1 q2)")
(pb (add q1 q2))
(p "(sub q1 q2)")
(pb (sub q1 q2))
(p "(mul q1 q2)")
(pb (mul q1 q2))
(finish "q2.88")
; ======/q2.88
Raw
q2.89.scm
(define (install-polynomial-package-2)
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p) (cdr p))
(define (=zero?-poly p)
(=zero?-terms (term-list p)))
(define (=zero?-terms L)
(or (empty-termlist? L)
(and (=zero? (first-term L)) (=zero?-terms (rest-terms L)))))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
(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 (sub-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(add-poly p1 (nega-poly p2))
(error "Polys not in same var -- SUB-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 (div-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(let ((answer ((div-terms (term-list p1)
(term-list p2)))))
(make-poly (variable p1) (car answer)))
(error "Polys not in same var -- DIV-POLY"
(list p1 p2))))
(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))
; (0 1 0) -> (1 0)
(define (make-term-list terms)
(if (empty-termlist? terms)
(the-empty-termlist)
(if (=zero? (first-term terms))
(make-term-list (rest-terms terms))
terms)))
(define (add-terms L1 L2)
(cond ((empty-termlist? L1) L2)
((empty-termlist? L2) L1)
(else
(let ((reversed-L1 (reverse L1))
(reversed-L2 (reverse L2)))
(let ((long (longer reversed-L1 reversed-L2))
(short (shorter reversed-L1 reversed-L2)))
(make-term-list (reverse (do-add-terms long short))))))))
(define (do-add-terms long short)
(if (null? short)
long
(cons (add (first-term long) (first-term short))
(do-add-terms (rest-terms long) (rest-terms short)))))
(define (add-terms-with-order order short long)
; mulの性質よりとりあえず bl と sl が完全にずれた場合は考慮しなくてもいい
(define (do-add-terms-with-order order long short)
(define (add-terms-n L1 L2)
(cond ((empty-termlist? L1) L2)
((empty-termlist? L2) L1)
(else
(let ((reversed-L1 (reverse L1))
(reversed-L2 (reverse L2)))
(let ((long (longer L1 L2))
(short (shorter L1 L2)))
(do-add-terms long short))))))
(cond ((> order 0)
(cons (first-term long)
(do-add-terms-with-order (- order 1) (rest-terms long) short)))
(else
(add-terms-n long short))))
(cond ((empty-termlist? short) long)
((empty-termlist? long) short)
(else
(let ((reversed-short (reverse short))
(reversed-long (reverse long)))
(make-term-list (reverse (do-add-terms-with-order order reversed-long reversed-short)))))))
(define (mul-terms L1 L2)
(cond ((empty-termlist? L1) (the-empty-termlist))
((empty-termlist? L2) (the-empty-termlist))
(else (let ((short (shorter L1 L2))
(long (longer L1 L2)))
(add-terms-with-order (- (length short) 1)
(mul-term-by-all-terms (first-term short) long)
(mul-terms (rest-terms short) long))))))
(define (mul-term-by-all-terms t1 L)
(map (lambda (t) (mul t t1)) L))
(define (longer L1 L2)
(if (> (length L1) (length L2)) L1 L2))
(define (shorter L1 L2)
(if (<= (length L1) (length L2)) L1 L2))
(define (nega-poly p)
(define nega-term-list (map nega (term-list p)))
(cons (variable p) nega-term-list))
(define (tag p) (attach-tag 'polynomial p))
(put 'add '(polynomial polynomial)
(lambda (p1 p2) (tag (add-poly p1 p2))))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2) (tag (sub-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))))
(put '=zero? '(polynomial)
(lambda (p) (=zero?-poly p)))
(put 'nega '(polynomial)
(lambda (p) (tag (nega-poly p))))
'done)
; ====== q2.89
(load "./0415.scm")
(start "q2.89")
(install-polynomial-package-2)
(define p1 (make-polynomial 'x '(1 0 0 0 0 -1 )))
(define p2 (make-polynomial 'x '(1 0 -1)))
(define q1 (make-polynomial 'y `(,p1 ,p2)))
(define q2 (make-polynomial 'y `(,p2 ,p1)))
(p "整数係数")
(p "p1:")
(p p1)
(p "p2:")
(pb p2)
(p "(add p1 p2)")
(pb (add p1 p2))
(p "(sub p1 p2)")
(pb (sub p1 p2))
(p "(mul p1 p2)")
(pb (mul p1 p2))
(p "多項式係数")
(p "q1:")
(p q1)
(p "q2:")
(pb q2)
(p "(add q1 q2)")
(pb (add q1 q2))
(p "(sub q1 q2)")
(pb (sub q1 q2))
(p "(mul p1 p2)")
(pb (mul q1 q2))
(finish "q2.89")
; ======/q2.89
Raw
q2.90.2.scm
(define (install-sparse-polynomial-package)
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p) (cdr p))
(define (=zero?-poly p)
(=zero?-terms (term-list p)))
(define (=zero?-terms L)
(or (empty-termlist? L)
(and (=zero? (cadr (first-term L))) (=zero?-terms (rest-terms L)))))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
(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 (sub-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(add-poly p1 (nega-poly p2))
(error "Polys not in same var -- SUB-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 (div-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(let ((answer ((div-terms (term-list p1)
(term-list p2)))))
(make-poly (variable p1) (car answer)))
(error "Polys not in same var -- DIV-POLY"
(list p1 p2))))
(define (to-dense-poly p)
(make-poly (variable p) (to-dense-terms (term-list p))))
(define (sparse?-poly p)
(sparse?-terms (term-list p)))
(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-terms L1 L2)
(cond ((empty-termlist? L1) L2)
((empty-termlist? L2) L1)
(else
(let ((t1 (first-term L1)) (t2 (first-term L2)))
(cond ((> (order t1) (order t2))
(adjoin-term
t1 (add-terms (rest-terms L1) L2)))
((< (order t1) (order t2))
(adjoin-term
t2 (add-terms L1 (rest-terms L2))))
(else
(adjoin-term
(make-term (order t1)
(add (coeff t1) (coeff t2)))
(add-terms (rest-terms L1)
(rest-terms L2)))))))))
(define (mul-terms L1 L2)
(if (empty-termlist? L1)
(the-empty-termlist)
(add-terms (mul-term-by-all-terms (first-term L1) L2)
(mul-terms (rest-terms L1) L2))))
(define (mul-term-by-all-terms t1 L)
(if (empty-termlist? L)
(the-empty-termlist)
(let ((t2 (first-term L)))
(adjoin-term
(make-term (+ (order t1) (order t2))
(mul (coeff t1) (coeff t2)))
(mul-term-by-all-terms t1 (rest-terms L))))))
(define (to-dense-terms L)
(define (get-next L)
(if (empty-termlist? L)
-1
(order (first-term L))))
(define (iter i next L acc)
(if (< i 0)
acc
(if (= i next)
(iter (- i 1) (get-next (cdr L)) (cdr L) (cons (coeff (first-term L)) acc))
(iter (- i 1) next L (cons 0 acc)))))
(reverse (iter (order (first-term L)) (get-next L) L '())))
(define (sparse?-terms L)
(let ((len (length L))
(o (+ (order (first-term L)) 1)))
(<= (/ len o) (/ 1 3))))
(define (nega-poly p)
(define nega-term-list (map nega-term (term-list p)))
(cons (variable p) nega-term-list))
(define (nega-term term)
(make-term (order term)
(nega (coeff term))))
(define (tag p) (attach-tag 'sparse-polynomial p))
(put 'add '(sparse-polynomial sparse-polynomial)
(lambda (p1 p2) (tag (add-poly p1 p2))))
(put 'sub '(sparse-polynomial sparse-polynomial)
(lambda (p1 p2) (tag (sub-poly p1 p2))))
(put 'mul '(sparse-polynomial sparse-polynomial)
(lambda (p1 p2) (tag (mul-poly p1 p2))))
(put 'convert-to-sparse '(sparse-polynomial)
(lambda (p) (tag p)))
(put 'convert-to-dense '(sparse-polynomial)
(lambda (p) (attach-tag 'dense-polynomial (to-dense-poly p))))
(put 'sparse? '(sparse-polynomial)
(lambda (p) (sparse?-poly p)))
(put 'make 'sparse-polynomial
(lambda (var terms) (tag (make-poly var terms))))
(put '=zero? '(sparse-polynomial)
(lambda (p) (=zero?-poly p)))
(put 'nega '(sparse-polynomial)
(lambda (p) (tag (nega-poly p))))
'done)
(define (install-dense-polynomial-package)
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p) (cdr p))
(define (=zero?-poly p)
(=zero?-terms (term-list p)))
(define (=zero?-terms L)
(or (empty-termlist? L)
(and (=zero? (first-term L)) (=zero?-terms (rest-terms L)))))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
(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 (sub-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(add-poly p1 (nega-poly p2))
(error "Polys not in same var -- SUB-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 (to-sparse-poly p)
(make-poly (variable p)
(to-sparse-terms (term-list p))))
(define (sparse?-poly p)
(sparse?-terms (term-list p)))
(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))
; (0 1 0) -> (1 0)
(define (make-term-list terms)
(if (empty-termlist? terms)
(the-empty-termlist)
(if (=zero? (first-term terms))
(make-term-list (rest-terms terms))
terms)))
(define (add-terms L1 L2)
(cond ((empty-termlist? L1) L2)
((empty-termlist? L2) L1)
(else
(let ((reversed-L1 (reverse L1))
(reversed-L2 (reverse L2)))
(let ((big (bigger reversed-L1 reversed-L2))
(small (smaller reversed-L1 reversed-L2)))
(make-term-list (reverse (do-add-terms big small))))))))
(define (do-add-terms bl sl)
(if (null? sl)
bl
(cons (add (first-term bl) (first-term sl)) (do-add-terms (rest-terms bl) (rest-terms sl)))))
(define (add-terms-n L1 L2)
(cond ((empty-termlist? L1) L2)
((empty-termlist? L2) L1)
(else
(let ((reversed-L1 (reverse L1))
(reversed-L2 (reverse L2)))
(let ((big (bigger L1 L2))
(small (smaller L1 L2)))
(do-add-terms big small))))))
(define (do-add-terms-n bl sl)
(if (null? sl)
bl
(cons (add (first-term bl) (first-term sl)) (do-add-terms (rest-terms bl) (rest-terms sl)))))
(define (add-terms-with-order order L1 L2)
(cond ((empty-termlist? L1) L2)
((empty-termlist? L2) L1)
(else
(let ((reversed-L1 (reverse L1))
(reversed-L2 (reverse L2)))
(make-term-list (reverse (do-add-terms-with-order order reversed-L2 reversed-L1)))))))
; mulの性質よりとりあえず bl と sl が完全にずれた場合は考慮しなくてもいい
(define (do-add-terms-with-order order bl sl)
(cond ((> order 0)
(cons (first-term bl) (do-add-terms-with-order (- order 1) (rest-terms bl) sl)))
(else
(add-terms-n bl sl))))
(define (bigger L1 L2)
(if (> (length L1) (length L2))
L1
L2))
(define (smaller L1 L2)
(if (> (length L1) (length L2))
L2
L1))
(define (fix-length L len)
(if (>= (length L) len)
L
(fix-length (cons 0 L) len)))
(define (fix-length-tail L order)
(reverse (fix-length (reverse L) (+ (length L) order))))
(define (mul-terms L1 L2)
(cond ((empty-termlist? L1) (the-empty-termlist))
((empty-termlist? L2) (the-empty-termlist))
(else (let ((short (shorter L1 L2))
(long (longer L1 L2)))
(add-terms-with-order (- (length short) 1)
(mul-term-by-all-terms (first-term short) long)
(mul-terms (rest-terms short) long))))))
(define (longer L1 L2)
(if (> (length L1) (length L2))
L1
L2))
(define (shorter L1 L2)
(if (<= (length L1) (length L2))
L1
L2))
(define (mul-term-by-all-terms t1 L)
(map (lambda (t) (mul t t1)) L))
(define (to-sparse-terms L)
(define (iter order L acc)
(if (< order 0)
acc
(let ((t (car L))
(rest (cdr L)))
(if (=zero? t)
(iter (- order 1) rest acc)
(iter (- order 1) rest (cons (list order t) acc))))))
(reverse (iter (- (length L) 1) L '())))
(define (sparse?-terms L)
(let ((len (length L))
(sign (fold (lambda (acc x) (if (=zero? x)
acc
(+ acc 1))) 0 L)))
(<= (/ sign len) (/ 1 3))))
(define (nega-poly p)
(define nega-term-list (map nega (term-list p)))
(cons (variable p) nega-term-list))
(define (tag p) (attach-tag 'dense-polynomial p))
(put 'add '(dense-polynomial dense-polynomial)
(lambda (p1 p2) (tag (add-poly p1 p2))))
(put 'sub '(dense-polynomial dense-polynomial)
(lambda (p1 p2) (tag (sub-poly p1 p2))))
(put 'mul '(dense-polynomial dense-polynomial)
(lambda (p1 p2) (tag (mul-poly p1 p2))))
(put 'convert-to-sparse '(dense-polynomial)
(lambda (p) (attach-tag 'sparse-polynomial (to-sparse-poly p))))
(put 'convert-to-dense '(dense-polynomial)
(lambda (p) (tag p)))
(put 'sparse? '(dense-polynomial)
(lambda (p) (sparse?-poly p)))
(put 'make 'dense-polynomial
(lambda (var terms) (tag (make-poly var terms))))
(put '=zero? '(dense-polynomial)
(lambda (p) (=zero?-poly p)))
(put 'nega '(dense-polynomial)
(lambda (p) (tag (nega-poly p))))
'done)
(define (install-polynomial-package)
(define (make-polynomial-for-sparse variable term-list)
((get 'make 'sparse-polynomial) variable term-list))
(define (make-polynomial-for-dense variable term-list)
((get 'make 'dense-polynomial) variable term-list))
(define (same-type? p1 p2)
(if (eq? (type-tag p1) (type-tag p2))
true
false))
(define (add-poly p1 p2)
(if (same-type? p1 p2)
(optimize (add p1 p2))
(let ((sparse-p1 (convert-to-sparse p1))
(sparse-p2 (convert-to-sparse p2)))
(let ((p (add sparse-p1 sparse-p2)))
(optimize p)))))
(define (sub-poly p1 p2)
(if (same-type? p1 p2)
(optimize (sub p1 p2))
(let ((sparse-p1 (convert-to-sparse p1))
(sparse-p2 (convert-to-sparse p2)))
(let ((p (sub sparse-p1 sparse-p2)))
(optimize p)))))
(define (mul-poly p1 p2)
(if (same-type? p1 p2)
(optimize (mul p1 p2))
(let ((sparse-p1 (convert-to-sparse p1))
(sparse-p2 (convert-to-sparse p2)))
(let ((p (mul sparse-p1 sparse-p2)))
(optimize p)))))
(define (optimize p)
(if (sparse? p)
(convert-to-sparse p)
(convert-to-dense p)))
(define (tag p) (attach-tag 'polynomial p))
(put 'add '(polynomial polynomial)
(lambda (p1 p2) (tag (add-poly p1 p2))))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2) (tag (sub-poly p1 p2))))
(put 'mul '(polynomial polynomial)
(lambda (p1 p2) (tag (mul-poly p1 p2))))
(put 'div '(polynomial polynomial)
(lambda (p1 p2) (tag (div-poly p1 p2))))
(put '=zero? '(polynomial)
(lambda (p) (=zero? p)))
(put 'nega '(polynomial)
(lambda (p) (tag (nega p))))
(put 'make-polynomial-for-sparse 'polynomial
(lambda (v t) (tag (make-polynomial-for-sparse v t))))
(put 'make-polynomial-for-dense 'polynomial
(lambda (v t) (tag (make-polynomial-for-dense v t))))
'done)
(define (make-polynomial-for-sparse variable term-list)
((get 'make-polynomial-for-sparse 'polynomial) variable term-list))
(define (make-polynomial-for-dense variable term-list)
((get 'make-polynomial-for-dense 'polynomial) variable term-list))
(define (convert-to-sparse p) (apply-generic 'convert-to-sparse p))
(define (convert-to-dense p) (apply-generic 'convert-to-dense p))
(define (sparse? p) (apply-generic 'sparse? p))
; ====== q2.90.2
(load "./0415.scm")
(start "q2.90.2")
(install-sparse-polynomial-package)
(install-dense-polynomial-package)
(install-polynomial-package)
(define p1 (make-polynomial-for-sparse 'x '((5 1) (0 -1))))
(define p2 (make-polynomial-for-dense 'x '(1 0 -1)))
(define q1 (make-polynomial-for-sparse 'y `((1 ,p1) (0 ,p2))))
(define q2 (make-polynomial-for-dense 'y `(,p2 ,p1)))
(p (nega (cdr p1)))
(p "整数係数")
(p "p1:")
(p p1)
(p "p2:")
(pb p2)
(p "(add p1 p2)")
(pb (add p1 p2))
(p "(sub p1 p2)")
(pb (sub p1 p2))
(p "(mul p1 p2)")
(pb (mul p1 p2))
(p "多項式係数")
(p "q1:")
(p q1)
(p "q2:")
(pb q2)
(p "(add q1 q2)")
(pb (add q1 q2))
(p "(sub q1 q2)")
(pb (sub q1 q2))
(p "(mul q1 q2)")
(pb (mul q1 q2))
(finish "q2.90.2")
; ======/q2.90.2
Raw
q2.90.scm
(define (install-sparse-polynomial-package)
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable-poly p) (car p))
(define (term-list-poly p) (cdr p))
(define (=zero?-poly p)
(=zero?-terms (term-list-poly p)))
(define (=zero?-terms L)
(or (empty-termlist? L)
(and (=zero? (cadr (first-term L))) (=zero?-terms (rest-terms L)))))
(define (nega-poly p)
(define nega-term-list (map nega-term (term-list-poly p)))
(cons (variable-poly p) nega-term-list))
(define (nega-term term)
(make-term (order term)
(nega (coeff term))))
(define (the-empty-termlist) '())
(define (first-term term-list) (car term-list))
(define (rest-terms term-list) (cdr term-list))
(define (empty-termlist? term-list) (null? term-list))
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(define (tag p) (attach-tag 'sparse-polynomial p))
(put 'variable '(sparse-polynomial)
(lambda (p) (variable-poly p)))
(put 'term-list '(sparse-polynomial)
(lambda (p) (term-list-poly p)))
(put 'make 'sparse-polynomial
(lambda (var terms) (tag (make-poly var terms))))
(put '=zero? '(sparse-polynomial)
(lambda (p) (=zero?-poly p)))
(put 'nega '(sparse-polynomial)
(lambda (p) (tag (nega-poly p))))
'done)
(define (install-dense-polynomial-package)
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable-poly p) (car p))
(define (term-list-poly p)
(reverse (do-term-list (- (length (cdr p)) 1) (cdr p) '())))
(define (do-term-list order L acc)
(if (null? L) acc
(let ((first (car L))
(rest (cdr L)))
(if (=zero? first)
(do-term-list (- order 1) rest acc)
(do-term-list (- order 1) rest (cons (list order first) acc))))))
(define (=zero?-poly p)
(=zero?-terms (cdr p)))
(define (=zero?-terms L)
(or (empty-termlist? L)
(and (=zero? (first-term L)) (=zero?-terms (rest-terms L)))))
(define (nega-poly p)
(define nega-term-list (map nega (cdr p)))
(cons (variable-poly p) nega-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 (tag p) (attach-tag 'dense-polynomial p))
(put 'variable '(dense-polynomial)
(lambda (p) (variable-poly p)))
(put 'term-list '(dense-polynomial)
(lambda (p) (term-list-poly p)))
(put 'make 'dense-polynomial
(lambda (var terms) (tag (make-poly var terms))))
(put '=zero? '(dense-polynomial)
(lambda (p) (=zero?-poly p)))
(put 'nega '(dense-polynomial)
(lambda (p) (tag (nega-poly p))))
'done)
(define (install-polynomial-package)
(define (make-polynomial-for-sparse variable term-list)
((get 'make 'sparse-polynomial) variable term-list))
(define (make-polynomial-for-dense variable term-list)
((get 'make 'dense-polynomial) variable term-list))
(define (add-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(make-polynomial-for-sparse (variable p1)
(add-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var -- ADD-POLY"
(list p1 p2))))
(define (sub-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(add-poly p1 (nega p2))
(error "Polys not in same var -- SUB-POLY"
(list p1 p2))))
(define (mul-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(make-polynomial-for-sparse (variable p1)
(mul-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var -- MUL-POLY"
(list p1 p2))))
(define (div-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(let ((answer ((div-terms (term-list p1)
(term-list p2)))))
(make-polynomial-for-sparse (variable p1) (car answer)))
(error "Polys not in same var -- DIV-POLY"
(list p1 p2))))
(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-terms L1 L2)
(cond ((empty-termlist? L1) L2)
((empty-termlist? L2) L1)
(else
(let ((t1 (first-term L1)) (t2 (first-term L2)))
(cond ((> (order t1) (order t2))
(adjoin-term
t1 (add-terms (rest-terms L1) L2)))
((< (order t1) (order t2))
(adjoin-term
t2 (add-terms L1 (rest-terms L2))))
(else
(adjoin-term
(make-term (order t1)
(add (coeff t1) (coeff t2)))
(add-terms (rest-terms L1)
(rest-terms L2)))))))))
(define (mul-terms L1 L2)
(if (empty-termlist? L1)
(the-empty-termlist)
(add-terms (mul-term-by-all-terms (first-term L1) L2)
(mul-terms (rest-terms L1) L2))))
(define (mul-term-by-all-terms t1 L)
(if (empty-termlist? L)
(the-empty-termlist)
(let ((t2 (first-term L)))
(adjoin-term
(make-term (+ (order t1) (order t2))
(mul (coeff t1) (coeff t2)))
(mul-term-by-all-terms t1 (rest-terms L))))))
(define (tag z) (attach-tag 'polynomial z))
(put 'add '(polynomial polynomial)
(lambda (z1 z2) (tag (add-poly z1 z2))))
(put 'sub '(polynomial polynomial)
(lambda (z1 z2) (tag (sub-poly z1 z2))))
(put 'mul '(polynomial polynomial)
(lambda (z1 z2) (tag (mul-poly z1 z2))))
(put 'div '(polynomial polynomial)
(lambda (z1 z2) (tag (div-poly z1 z2))))
(put '=zero? '(polynomial)
(lambda (p) (=zero? p)))
(put 'nega '(polynomial)
(lambda (p) (tag (nega p))))
(put 'make-polynomial-for-sparse 'polynomial
(lambda (v t) (tag (make-polynomial-for-sparse v t))))
(put 'make-polynomial-for-dense 'polynomial
(lambda (v t) (tag (make-polynomial-for-dense v t))))
'done)
(define (make-polynomial-for-sparse variable term-list)
((get 'make-polynomial-for-sparse 'polynomial) variable term-list))
(define (make-polynomial-for-dense variable term-list)
((get 'make-polynomial-for-dense 'polynomial) variable term-list))
(define (variable p) (apply-generic 'variable p))
(define (term-list p) (apply-generic 'term-list p))
; ====== q2.90
(load "./0415.scm")
(start "q2.90")
(install-sparse-polynomial-package)
(install-dense-polynomial-package)
(install-polynomial-package)
(define p1 (make-polynomial-for-sparse 'x '((5 1) (0 -1))))
(define p2 (make-polynomial-for-dense 'x '(1 0 -1)))
(define q1 (make-polynomial-for-sparse 'y `((1 ,p1) (0 ,p2))))
(define q2 (make-polynomial-for-dense 'y `(,p2 ,p1)))
(p (nega (cdr p1)))
(p "整数係数")
(p "p1:")
(p p1)
(p "p2:")
(pb p2)
(p "(add p1 p2)")
(pb (add p1 p2))
(p "(sub p1 p2)")
(pb (sub p1 p2))
(p "(mul p1 p2)")
(pb (mul p1 p2))
(p "多項式係数")
(p "q1:")
(p q1)
(p "q2:")
(pb q2)
(p "(add q1 q2)")
(pb (add q1 q2))
(p "(sub q1 q2)")
(pb (sub q1 q2))
(p "(mul p1 p2)")
(pb (mul q1 q2))
(finish "q2.90")
; ======/q2.90
Raw
q2.91.scm
(define (install-polynomial-package)
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p) (cdr p))
(define (=zero?-poly p)
(=zero?-terms (term-list p)))
(define (=zero?-terms L)
(or (empty-termlist? L)
(and (=zero? (cadr (first-term L))) (=zero?-terms (rest-terms L)))))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
(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 (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 (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 (div-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(let ((answer (div-terms (term-list p1)
(term-list p2))))
(make-poly (variable p1) (car answer)))
(error "Polys not in same var -- DIV-POLY"
(list p1 p2))))
(define (rem-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(let ((answer (div-terms (term-list p1)
(term-list p2))))
(make-poly (variable p1) (cadr answer)))
(error "Polys not in same var -- DIV-POLY"
(list p1 p2))))
(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-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 (sub-terms L1 L2)
(add-terms L1 (nega-terms L2)))
(define (mul-terms L1 L2)
(if (empty-termlist? L1)
(the-empty-termlist)
(add-terms (mul-term-by-all-terms (first-term L1) L2)
(mul-terms (rest-terms L1) L2))))
(define (mul-term-by-all-terms t1 L)
(if (empty-termlist? L)
(the-empty-termlist)
(let ((t2 (first-term L)))
(adjoin-term
(make-term (+ (order t1) (order t2))
(mul (coeff t1) (coeff t2)))
(mul-term-by-all-terms t1 (rest-terms L))))))
(define (div-terms L1 L2)
(if (empty-termlist? L1)
(list (the-empty-termlist) (the-empty-termlist))
(let ((t1 (first-term L1))
(t2 (first-term L2)))
(if (> (order t2) (order t1))
(list (the-empty-termlist) L1)
(let ((new-c (div (coeff t1) (coeff t2)))
(new-o (- (order t1) (order t2))))
(let ((rest-of-result (div-terms (sub-terms L1 (mul-term-by-all-terms (make-term new-o new-c) L2)) L2)))
(list (adjoin-term (make-term new-o new-c) (car rest-of-result))
(cadr rest-of-result))))))))
(define (nega-poly p)
(define nega-term-list (nega-terms (term-list p)))
(cons (variable p) nega-term-list))
(define (nega-terms L)
(map nega-term L))
(define (nega-term term)
(make-term (order term)
(nega (coeff term))))
(define (tag p) (attach-tag 'polynomial p))
(put 'add '(polynomial polynomial)
(lambda (p1 p2) (tag (add-poly p1 p2))))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2) (tag (sub-poly p1 p2))))
(put 'mul '(polynomial polynomial)
(lambda (p1 p2) (tag (mul-poly p1 p2))))
(put 'div '(polynomial polynomial)
(lambda (p1 p2) (tag (div-poly p1 p2))))
(put 'rem '(polynomial polynomial)
(lambda (p1 p2) (tag (rem-poly p1 p2))))
(put 'make 'polynomial
(lambda (var terms) (tag (make-poly var terms))))
(put '=zero? '(polynomial)
(lambda (p) (=zero?-poly p)))
(put 'nega '(polynomial)
(lambda (p) (tag (nega-poly p))))
'done)
; ====== q2.91
(load "./0415.scm")
(start "q2.91")
(install-polynomial-package)
(define p1 (make-polynomial 'x '((5 1) (0 -1))))
(define p2 (make-polynomial 'x '((2 1) (0 -1))))
(define q1 (make-polynomial 'y `((1 ,p1) (0 ,p2))))
(define q2 (make-polynomial 'y `((1 ,p2) (0 ,p1))))
(p "p1:")
(p p1)
(p "p2:")
(pb p2)
(p "(div p1 p2)")
(pb (div p1 p2))
(p "(rem p1 p2)")
(pb (rem p1 p2))
(finish "q2.91")
; ======/q2.91
Raw
q2.92.scm
; ====== q2.91
(load "./0415.scm")
(start "q2.92")
(pb "易しくはない")
(finish "q2.92")
; ======/q2.91
Raw
q2.93.scm
(define (install-polynomial-package)
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p) (cdr p))
(define (=zero?-poly p)
(=zero?-terms (term-list p)))
(define (=zero?-terms L)
(or (empty-termlist? L)
(and (=zero? (cadr (first-term L))) (=zero?-terms (rest-terms L)))))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
(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 (sub-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(add-poly p1 (nega-poly p2))
(error "Polys not in same var -- SUB-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 (div-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(let ((answer ((div-terms (term-list p1)
(term-list p2)))))
(make-poly (variable p1) (car answer)))
(error "Polys not in same var -- DIV-POLY"
(list p1 p2))))
(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-terms L1 L2)
(cond ((empty-termlist? L1) L2)
((empty-termlist? L2) L1)
(else
(let ((t1 (first-term L1)) (t2 (first-term L2)))
(cond ((> (order t1) (order t2))
(adjoin-term
t1 (add-terms (rest-terms L1) L2)))
((< (order t1) (order t2))
(adjoin-term
t2 (add-terms L1 (rest-terms L2))))
(else
(adjoin-term
(make-term (order t1)
(add (coeff t1) (coeff t2)))
(add-terms (rest-terms L1)
(rest-terms L2)))))))))
(define (mul-terms L1 L2)
(if (empty-termlist? L1)
(the-empty-termlist)
(add-terms (mul-term-by-all-terms (first-term L1) L2)
(mul-terms (rest-terms L1) L2))))
(define (mul-term-by-all-terms t1 L)
(if (empty-termlist? L)
(the-empty-termlist)
(let ((t2 (first-term L)))
(adjoin-term
(make-term (+ (order t1) (order t2))
(mul (coeff t1) (coeff t2)))
(mul-term-by-all-terms t1 (rest-terms L))))))
(define (nega-poly p)
(define nega-term-list (map nega-term (term-list p)))
(cons (variable p) nega-term-list))
(define (nega-term term)
(make-term (order term)
(nega (coeff term))))
(define (tag p) (attach-tag 'polynomial p))
(put 'add '(polynomial polynomial)
(lambda (p1 p2) (tag (add-poly p1 p2))))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2) (tag (sub-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))))
(put '=zero? '(polynomial)
(lambda (p) (=zero?-poly p)))
(put 'nega '(polynomial)
(lambda (p) (tag (nega-poly p))))
'done)
(define (install-rational-package)
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(cons n d))
(define (add-rat x y)
(make-rat (add (mul (numer x) (denom y))
(mul (numer y) (denom x)))
(mul (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (sub (mul (numer x) (denom y))
(mul (numer y) (denom x)))
(mul (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (mul (numer x) (numer y))
(mul (denom x) (denom y))))
(define (div-rat x y)
(make-rat (mul (numer x) (denom y))
(mul (denom x) (numer y))))
(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))))
'done)
; ====== q2.93
(load "./0415.scm")
(start "q2.93")
(install-polynomial-package)
(install-rational-package)
(define p1 (make-polynomial 'x '((2 1) (0 1))))
(define p2 (make-polynomial 'x '((3 1) (0 1))))
(define rf (make-rational p2 p1))
(pb rf)
(finish "q2.93")
; ======/q2.93
Raw
q2.94.scm
(define (install-polynomial-package)
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p) (cdr p))
(define (=zero?-poly p)
(=zero?-terms (term-list p)))
(define (=zero?-terms L)
(or (empty-termlist? L)
(and (=zero? (cadr (first-term L))) (=zero?-terms (rest-terms L)))))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
(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 (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 (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 (div-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(let ((answer (div-terms (term-list p1)
(term-list p2))))
(make-poly (variable p1) (car answer)))
(error "Polys not in same var -- DIV-POLY"
(list p1 p2))))
(define (rem-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(let ((answer (div-terms (term-list p1)
(term-list p2))))
(make-poly (variable p1) (cadr answer)))
(error "Polys not in same var -- DIV-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 -- DIV-POLY"
(list p1 p2))))
(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-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 (sub-terms L1 L2)
(add-terms L1 (nega-terms L2)))
(define (mul-terms L1 L2)
(if (empty-termlist? L1)
(the-empty-termlist)
(add-terms (mul-term-by-all-terms (first-term L1) L2)
(mul-terms (rest-terms L1) L2))))
(define (mul-term-by-all-terms t1 L)
(if (empty-termlist? L)
(the-empty-termlist)
(let ((t2 (first-term L)))
(adjoin-term
(make-term (+ (order t1) (order t2))
(mul (coeff t1) (coeff t2)))
(mul-term-by-all-terms t1 (rest-terms L))))))
(define (div-terms L1 L2)
(if (empty-termlist? L1)
(list (the-empty-termlist) (the-empty-termlist))
(let ((t1 (first-term L1))
(t2 (first-term L2)))
(if (> (order t2) (order t1))
(list (the-empty-termlist) L1)
(let ((new-c (div (coeff t1) (coeff t2)))
(new-o (- (order t1) (order t2))))
(let ((rest-of-result (div-terms (sub-terms L1 (mul-term-by-all-terms (make-term new-o new-c) L2)) L2)))
(list (adjoin-term (make-term new-o new-c) (car rest-of-result))
(cadr rest-of-result))))))))
(define (remainder-terms L1 L2)
(cadr (div-terms L1 L2)))
(define (gcd-terms L1 L2)
(if (empty-termlist? L2)
L1
(gcd-terms L2 (remainder-terms L1 L2))))
(define (nega-poly p)
(define nega-term-list (nega-terms (term-list p)))
(cons (variable p) nega-term-list))
(define (nega-terms L)
(map nega-term L))
(define (nega-term term)
(make-term (order term)
(nega (coeff term))))
(define (tag p) (attach-tag 'polynomial p))
(put 'add '(polynomial polynomial)
(lambda (p1 p2) (tag (add-poly p1 p2))))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2) (tag (sub-poly p1 p2))))
(put 'mul '(polynomial polynomial)
(lambda (p1 p2) (tag (mul-poly p1 p2))))
(put 'div '(polynomial polynomial)
(lambda (p1 p2) (tag (div-poly p1 p2))))
(put 'rem '(polynomial polynomial)
(lambda (p1 p2) (tag (rem-poly p1 p2))))
(put 'greatest-common-divisor '(polynomial polynomial)
(lambda (p1 p2) (tag (gcd-poly p1 p2))))
(put 'make 'polynomial
(lambda (var terms) (tag (make-poly var terms))))
(put '=zero? '(polynomial)
(lambda (p) (=zero?-poly p)))
(put 'nega '(polynomial)
(lambda (p) (tag (nega-poly p))))
'done)
(define (greatest-common-divisor x y) (apply-generic 'greatest-common-divisor x y))
; ====== q2.94
(load "./0415.scm")
(start "q2.94")
(install-polynomial-package)
(define p1 (make-polynomial 'x '((4 1) (3 -1) (2 -2) (1 2))))
(define p2 (make-polynomial 'x '((3 1) (1 -1))))
(p "p1:")
(p p1)
(p "p2:")
(pb p2)
(p "(greatest-common-divisor p1 p2)")
(pb (greatest-common-divisor p1 p2))
(p "(greatest-common-divisor 24 18)")
(pb (greatest-common-divisor 24 18))
(finish "q2.94")
; ======/q2.94
Raw
q2.95.scm
(define (install-polynomial-package)
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p) (cdr p))
(define (=zero?-poly p)
(=zero?-terms (term-list p)))
(define (=zero?-terms L)
(or (empty-termlist? L)
(and (=zero? (cadr (first-term L))) (=zero?-terms (rest-terms L)))))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
(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 (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 (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 (div-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(let ((answer (div-terms (term-list p1)
(term-list p2))))
(make-poly (variable p1) (car answer)))
(error "Polys not in same var -- DIV-POLY"
(list p1 p2))))
(define (rem-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(let ((answer (div-terms (term-list p1)
(term-list p2))))
(make-poly (variable p1) (cadr answer)))
(error "Polys not in same var -- DIV-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 -- DIV-POLY"
(list p1 p2))))
(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-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 (sub-terms L1 L2)
(add-terms L1 (nega-terms L2)))
(define (mul-terms L1 L2)
(if (empty-termlist? L1)
(the-empty-termlist)
(add-terms (mul-term-by-all-terms (first-term L1) L2)
(mul-terms (rest-terms L1) L2))))
(define (mul-term-by-all-terms t1 L)
(if (empty-termlist? L)
(the-empty-termlist)
(let ((t2 (first-term L)))
(adjoin-term
(make-term (+ (order t1) (order t2))
(mul (coeff t1) (coeff t2)))
(mul-term-by-all-terms t1 (rest-terms L))))))
(define (div-terms L1 L2)
(if (empty-termlist? L1)
(list (the-empty-termlist) (the-empty-termlist))
(let ((t1 (first-term L1))
(t2 (first-term L2)))
(if (> (order t2) (order t1))
(list (the-empty-termlist) L1)
(let ((new-c (div (coeff t1) (coeff t2)))
(new-o (- (order t1) (order t2))))
(let ((rest-of-result (div-terms (sub-terms L1 (mul-term-by-all-terms (make-term new-o new-c) L2)) L2)))
(list (adjoin-term (make-term new-o new-c) (car rest-of-result))
(cadr rest-of-result))))))))
(define (remainder-terms L1 L2)
(cadr (div-terms L1 L2)))
(define (gcd-terms L1 L2)
(if (empty-termlist? L2)
L1
(gcd-terms L2 (remainder-terms L1 L2))))
(define (nega-poly p)
(define nega-term-list (nega-terms (term-list p)))
(cons (variable p) nega-term-list))
(define (nega-terms L)
(map nega-term L))
(define (nega-term term)
(make-term (order term)
(nega (coeff term))))
(define (tag p) (attach-tag 'polynomial p))
(put 'add '(polynomial polynomial)
(lambda (p1 p2) (tag (add-poly p1 p2))))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2) (tag (sub-poly p1 p2))))
(put 'mul '(polynomial polynomial)
(lambda (p1 p2) (tag (mul-poly p1 p2))))
(put 'div '(polynomial polynomial)
(lambda (p1 p2) (tag (div-poly p1 p2))))
(put 'rem '(polynomial polynomial)
(lambda (p1 p2) (tag (rem-poly p1 p2))))
(put 'greatest-common-divisor '(polynomial polynomial)
(lambda (p1 p2) (tag (gcd-poly p1 p2))))
(put 'make 'polynomial
(lambda (var terms) (tag (make-poly var terms))))
(put '=zero? '(polynomial)
(lambda (p) (=zero?-poly p)))
(put 'nega '(polynomial)
(lambda (p) (tag (nega-poly p))))
'done)
(define (greatest-common-divisor x y) (apply-generic 'greatest-common-divisor x y))
; ====== q2.95
(load "./0415.scm")
(start "q2.95")
(install-polynomial-package)
(define p1 (make-polynomial 'x '((2 1) (1 -2) (0 1))))
(define p2 (make-polynomial 'x '((2 11) (0 7))))
(define p3 (make-polynomial 'x '((1 13) (0 5))))
(define q1 (mul p1 p2))
(define q2 (mul p1 p3))
(p "p1:")
(p p1)
(p "p2:")
(p p2)
(p "p2:")
(pb p3)
(p "q1:")
(p q1)
(p "q2:")
(pb q2)
(p "(greatest-common-divisor q1 q2)")
(pb (greatest-common-divisor q1 q2))
(finish "q2.95")
; ======/q2.95
Raw
q2.96.scm
(define (install-polynomial-package)
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p) (cdr p))
(define (=zero?-poly p)
(=zero?-terms (term-list p)))
(define (=zero?-terms L)
(or (empty-termlist? L)
(and (=zero? (cadr (first-term L))) (=zero?-terms (rest-terms L)))))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
(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 (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 (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 (div-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(let ((answer (div-terms (term-list p1)
(term-list p2))))
(make-poly (variable p1) (car answer)))
(error "Polys not in same var -- DIV-POLY"
(list p1 p2))))
(define (rem-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(let ((answer (div-terms (term-list p1)
(term-list p2))))
(make-poly (variable p1) (cadr answer)))
(error "Polys not in same var -- DIV-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 -- DIV-POLY"
(list p1 p2))))
(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-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 (sub-terms L1 L2)
(add-terms L1 (nega-terms L2)))
(define (mul-terms L1 L2)
(if (empty-termlist? L1)
(the-empty-termlist)
(add-terms (mul-term-by-all-terms (first-term L1) L2)
(mul-terms (rest-terms L1) L2))))
(define (mul-term-by-all-terms t1 L)
(if (empty-termlist? L)
(the-empty-termlist)
(let ((t2 (first-term L)))
(adjoin-term
(make-term (+ (order t1) (order t2))
(mul (coeff t1) (coeff t2)))
(mul-term-by-all-terms t1 (rest-terms L))))))
(define (div-terms L1 L2)
(if (empty-termlist? L1)
(list (the-empty-termlist) (the-empty-termlist))
(let ((t1 (first-term L1))
(t2 (first-term L2)))
(if (> (order t2) (order t1))
(list (the-empty-termlist) L1)
(let ((new-c (div (coeff t1) (coeff t2)))
(new-o (- (order t1) (order t2))))
(let ((rest-of-result (div-terms (sub-terms L1 (mul-term-by-all-terms (make-term new-o new-c) L2)) L2)))
(list (adjoin-term (make-term new-o new-c) (car rest-of-result))
(cadr rest-of-result))))))))
(define (remainder-terms L1 L2)
(cadr (div-terms L1 L2)))
(define (pseudoremainder-terms L1 L2)
(define (order-terms L)
(if (empty-termlist? L)
0
(order (first-term L))))
(define (first-term-coeff L)
(if (empty-termlist? L)
0
(coeff (first-term L))))
(define (mul-coeff-by-all-terms c L)
(map (lambda (t) (list (order t) (* (coeff t) c))) L))
(let ((o1 (order-terms L1))
(o2 (order-terms L2))
(c (first-term-coeff L2)))
(let ((cL1 (mul-coeff-by-all-terms (expt c (+ 1 (- o1 o2))) L1)))
(cadr (div-terms cL1 L2)))))
(define (gcd-terms L1 L2)
(define (raw-gcd)
(if (empty-termlist? L2)
L1
(gcd-terms L2 (pseudoremainder-terms L1 L2))))
(let ((rL (raw-gcd)))
(let ((coeffs (map coeff rL))
(orders (map order rL)))
(let ((coeff-gcd (fold greatest-common-divisor (car coeffs) coeffs)))
(let ((new-coeffs (map (lambda (x) (/ x coeff-gcd)) coeffs)))
(map make-term orders new-coeffs))))))
(define (nega-poly p)
(define nega-term-list (nega-terms (term-list p)))
(cons (variable p) nega-term-list))
(define (nega-terms L)
(map nega-term L))
(define (nega-term term)
(make-term (order term)
(nega (coeff term))))
(define (tag p) (attach-tag 'polynomial p))
(put 'add '(polynomial polynomial)
(lambda (p1 p2) (tag (add-poly p1 p2))))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2) (tag (sub-poly p1 p2))))
(put 'mul '(polynomial polynomial)
(lambda (p1 p2) (tag (mul-poly p1 p2))))
(put 'div '(polynomial polynomial)
(lambda (p1 p2) (tag (div-poly p1 p2))))
(put 'rem '(polynomial polynomial)
(lambda (p1 p2) (tag (rem-poly p1 p2))))
(put 'greatest-common-divisor '(polynomial polynomial)
(lambda (p1 p2) (tag (gcd-poly p1 p2))))
(put 'make 'polynomial
(lambda (var terms) (tag (make-poly var terms))))
(put '=zero? '(polynomial)
(lambda (p) (=zero?-poly p)))
(put 'nega '(polynomial)
(lambda (p) (tag (nega-poly p))))
'done)
(define (greatest-common-divisor x y) (apply-generic 'greatest-common-divisor x y))
; ====== q2.96
(load "./0415.scm")
(start "q2.96")
(install-polynomial-package)
(define p1 (make-polynomial 'x '((2 1) (1 -2) (0 1))))
(define p2 (make-polynomial 'x '((2 11) (0 7))))
(define p3 (make-polynomial 'x '((1 13) (0 5))))
(define q1 (mul p1 p2))
(define q2 (mul p1 p3))
(p "p1:")
(p p1)
(p "p2:")
(p p2)
(p "p2:")
(pb p3)
(p "q1:")
(p q1)
(p "q2:")
(pb q2)
(p "(greatest-common-divisor q1 q2)")
(pb (greatest-common-divisor q1 q2))
(finish "q2.96")
; ======/q2.96
Raw
q2.97.scm
(define (install-rational-package)
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (reduce n d)))
(cons (car g) (cadr g))))
(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))))
(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))))
'done)
(define (install-polynomial-package)
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p) (cdr p))
(define (=zero?-poly p)
(=zero?-terms (term-list p)))
(define (=zero?-terms L)
(or (empty-termlist? L)
(and (=zero? (cadr (first-term L))) (=zero?-terms (rest-terms L)))))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
(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 (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 (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 (div-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(let ((answer (div-terms (term-list p1)
(term-list p2))))
(make-poly (variable p1) (car answer)))
(error "Polys not in same var -- DIV-POLY"
(list p1 p2))))
(define (rem-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(let ((answer (div-terms (term-list p1)
(term-list p2))))
(make-poly (variable p1) (cadr answer)))
(error "Polys not in same var -- DIV-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 -- DIV-POLY"
(list p1 p2))))
(define (reduce-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(let ((termlists (reduce-terms (term-list p1) (term-list p2))))
(map (lambda (L) (make-poly (variable p1) L)) termlists))
(error "Polys not in same var -- DIV-POLY"
(list p1 p2))))
(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-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 (sub-terms L1 L2)
(add-terms L1 (nega-terms L2)))
(define (mul-terms L1 L2)
(if (empty-termlist? L1)
(the-empty-termlist)
(add-terms (mul-term-by-all-terms (first-term L1) L2)
(mul-terms (rest-terms L1) L2))))
(define (mul-term-by-all-terms t1 L)
(if (empty-termlist? L)
(the-empty-termlist)
(let ((t2 (first-term L)))
(adjoin-term
(make-term (+ (order t1) (order t2))
(mul (coeff t1) (coeff t2)))
(mul-term-by-all-terms t1 (rest-terms L))))))
(define (div-terms L1 L2)
(if (empty-termlist? L1)
(list (the-empty-termlist) (the-empty-termlist))
(let ((t1 (first-term L1))
(t2 (first-term L2)))
(if (> (order t2) (order t1))
(list (the-empty-termlist) L1)
(let ((new-c (div (coeff t1) (coeff t2)))
(new-o (- (order t1) (order t2))))
(let ((rest-of-result (div-terms (sub-terms L1 (mul-term-by-all-terms (make-term new-o new-c) L2)) L2)))
(list (adjoin-term (make-term new-o new-c) (car rest-of-result))
(cadr rest-of-result))))))))
(define (remainder-terms L1 L2)
(cadr (div-terms L1 L2)))
(define (order-terms L)
(if (empty-termlist? L)
0
(order (first-term L))))
(define (first-term-coeff L)
(if (empty-termlist? L)
0
(coeff (first-term L))))
(define (mul-coeff-by-all-terms c L)
(map (lambda (t) (list (order t) (mul (coeff t) c))) L))
(define (div-coeff-by-all-terms c L)
(p c)
(p L)
(map (lambda (t) (list (order t) (div (coeff t) c))) L))
(define (pseudoremainder-terms L1 L2)
(let ((o1 (order-terms L1))
(o2 (order-terms L2))
(c (first-term-coeff L2)))
(let ((cL1 (mul-coeff-by-all-terms (expt c (+ 1 (- o1 o2))) L1)))
(cadr (div-terms cL1 L2)))))
(define (gcd-terms L1 L2)
(define (raw-gcd)
(if (empty-termlist? L2)
L1
(gcd-terms L2 (pseudoremainder-terms L1 L2))))
(let ((rL (raw-gcd)))
(let ((coeffs (map coeff rL))
(orders (map order rL)))
(let ((coeff-gcd (fold greatest-common-divisor (car coeffs) coeffs)))
(let ((new-coeffs (map (lambda (x) (div x coeff-gcd)) coeffs)))
(map make-term orders new-coeffs))))))
(define (reduce-terms L1 L2)
(let ((the-gcd (gcd-terms L1 L2)))
(let ((o1 (order-terms L1))
(o2 (order-terms L2))
(c (first-term-coeff the-gcd)))
(let ((cL1 (mul-coeff-by-all-terms (expt c (+ 1 (- o1 o2))) L1))
(cL2 (mul-coeff-by-all-terms (expt c (+ 1 (- o1 o2))) L2)))
(list (car (div-terms cL1 the-gcd)) (car (div-terms cL2 the-gcd)))))))
(define (nega-poly p)
(define nega-term-list (nega-terms (term-list p)))
(cons (variable p) nega-term-list))
(define (nega-terms L)
(map nega-term L))
(define (nega-term term)
(make-term (order term)
(nega (coeff term))))
(define (tag p) (attach-tag 'polynomial p))
(put 'add '(polynomial polynomial)
(lambda (p1 p2) (tag (add-poly p1 p2))))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2) (tag (sub-poly p1 p2))))
(put 'mul '(polynomial polynomial)
(lambda (p1 p2) (tag (mul-poly p1 p2))))
(put 'div '(polynomial polynomial)
(lambda (p1 p2) (tag (div-poly p1 p2))))
(put 'rem '(polynomial polynomial)
(lambda (p1 p2) (tag (rem-poly p1 p2))))
(put 'greatest-common-divisor '(polynomial polynomial)
(lambda (p1 p2) (tag (gcd-poly p1 p2))))
(put 'reduce '(polynomial polynomial)
(lambda (p1 p2) (map tag (reduce-poly p1 p2))))
(put 'make 'polynomial
(lambda (var terms) (tag (make-poly var terms))))
(put '=zero? '(polynomial)
(lambda (p) (=zero?-poly p)))
(put 'nega '(polynomial)
(lambda (p) (tag (nega-poly p))))
'done)
(define (greatest-common-divisor x y) (apply-generic 'greatest-common-divisor x y))
(define (reduce x y) (apply-generic 'reduce x y))
; ====== q2.97
(load "./0415.scm")
(start "q2.97")
(install-polynomial-package)
(install-rational-package)
(define p1 (make-polynomial 'x '((2 1) (1 -2) (0 1))))
(define p2 (make-polynomial 'x '((2 11) (0 7))))
(define p3 (make-polynomial 'x '((1 13) (0 5))))
(define q1 (mul p1 p2))
(define q2 (mul p1 p3))
(p "p1:")
(p p1)
(p "p2:")
(p p2)
(p "p2:")
(pb p3)
(p "q1:")
(p q1)
(p "q2:")
(pb q2)
(p "(greatest-common-divisor q1 q2)")
(pb (greatest-common-divisor q1 q2))
(p "(reduce q1 q1)")
(pb (reduce q1 q2))
(define a1 (make-polynomial 'x '((1 1) (0 1))))
(define a2 (make-polynomial 'x '((3 1) (0 -1))))
(define a3 (make-polynomial 'x '((1 1))))
(define a4 (make-polynomial 'x '((2 1) (0 -1))))
(define rf1 (make-rational a1 a2))
(define rf2 (make-rational a3 a4))
(p "a1:")
(p a1)
(p "a2:")
(p a2)
(p "a3:")
(p a3)
(p "a4:")
(pb a4)
(p "rf1:")
(p rf1)
(p "rf2:")
(pb rf2)
(p "(add rf1 rf2)")
(p (add rf1 rf2))
(finish "q2.97")
; ======/q2.97
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment