ompayne
/
sicp
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Completed exercise 2.97

This commit is contained in:
Oliver Payne 2022-04-17 23:07:53 +01:00
parent 4c1ec4dbc3
commit 83104b379c
1 changed files with 112 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

139
2_78.rkt
View File

@ -165,6 +165,10 @@
;; Scheme numbers
(define (install-scheme-number-package)
(define (reduce-integers n d)
(let ((g (gcd n d)))
(list (/ n g) (/ d g))))
(define (tag x)
(attach-tag 'scheme-number x))
(define (exp x y) (apply-generic 'exp x y))
@ -188,6 +192,11 @@
(lambda (x) (tag (sqrt x))))
(put 'greatest-common-divisor '(scheme-number scheme-number)
(lambda (a b) (tag (gcd a b))))
(put 'reduce '(scheme-number scheme-number)
(lambda (a b)
(let ((reduced (reduce-integers a b)))
(list (tag (car reduced))
(tag (cadr reduced))))))
(put 'equ? '(scheme-number scheme-number) =)
(put '=zero? '(scheme-number)
(lambda (x) (= x 0)))
@ -251,7 +260,11 @@
;; internal procedures
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d) (cons n d))
(define (make-rat n d)
(let ((reduced (reduce n d)))
(cons
(car reduced)
(cadr reduced))))
(define (add-rat x y)
(make-rat (add (mul (numer x) (denom y))
(mul (numer y) (denom x)))
@ -491,6 +504,15 @@
(greatest-common-divisor
(term-list p1)
(term-list p2)))))
(define (reduce-poly p1 p2)
(let ((reduced-termlist
(reduce (term-list p1)
(term-list p2))))
(if (same-variable? (variable p1) (variable p2))
(list
(make-poly (variable p1) (car reduced-termlist))
(make-poly (variable p1) (cadr reduced-termlist))))))
(define (negate-poly p)
(make-poly (variable p)
@ -519,6 +541,12 @@
(tag (cadr quotient-remainder))))))
(put 'greatest-common-divisor '(polynomial polynomial)
(lambda (p1 p2) (tag (gcd-poly p1 p2))))
(put 'reduce '(polynomial polynomial)
(lambda (p1 p2)
(let ((reduced (reduce-poly p1 p2)))
(list
(tag (car reduced))
(tag (cadr reduced))))))
(put 'negate '(polynomial)
(lambda (p) (tag (negate-poly p))))
(put '=zero? '(polynomial)
@ -594,6 +622,16 @@
(define (remainder-terms L1 L2)
(cadr (div-terms L1 L2)))
(define (mul-terms-by-scalar termlist s)
(mul-terms
termlist
(adjoin-term
(make-term 0 s)
((get 'the-empty-termlist (type-tag termlist))))))
(define (div-terms-by-scalar termlist s)
(mul-terms-by-scalar termlist (/ 1 s)))
(define (pseudo-remainder-terms L1 L2)
(let* ((c (coeff (first-term L2)))
@ -609,22 +647,30 @@
L1)
L2))))
(define (coeff-gcd termlist)
(if (empty-termlist? termlist)
0
(gcd (coeff (first-term termlist))
(coeff-gcd (rest-terms termlist)))))
(define (gcd-terms a b)
(define (coeff-gcd termlist)
(if (empty-termlist? termlist)
0
(gcd (coeff (first-term termlist))
(coeff-gcd (rest-terms termlist)))))
(define (div-by-coeff-gcd termlist)
(div-terms
termlist
(adjoin-term
(make-term 0 (coeff-gcd termlist))
((get 'the-empty-termlist (type-tag termlist))))))
(if (empty-termlist? b)
(div-by-coeff-gcd a)
(div-terms-by-scalar a (coeff-gcd a))
(gcd-terms b (pseudo-remainder-terms a b))))
(define (reduce-terms n d)
(let* ((term-gcd (gcd-terms n d))
(o1 (max (order n) (order d)))
(o2 (order term-gcd))
(i-factor (exp
(coeff (first-term term-gcd))
(+ 1 (- o1 o2)))))
(list
;; Dividing by the gcd will give remainder zero, so we are only
;; interested in the quotient
(car (div-terms (mul-terms-by-scalar n i-factor) term-gcd))
(car (div-terms (mul-terms-by-scalar d i-factor) term-gcd)))))
;; Constructors
(put 'make-sparse-empty-termlist 'termlist
@ -684,6 +730,13 @@
(lambda (L1 L2)
(tag (gcd-terms L1 L2))))
(put 'reduce '(termlist termlist)
(lambda (L1 L2)
(let ((reduced-termlist
(reduce-terms L1 L2)))
(list (tag (car reduced-termlist))
(tag (cadr reduced-termlist))))))
'done)
(define (install-sparse-package)
@ -730,6 +783,12 @@
(put 'empty-termlist? '(sparse) empty-termlist?)
(put 'order '(sparse)
(lambda (termlist)
(if (pair? termlist)
(caar termlist)
0)))
;; Operators
(put 'negate '(sparse)
(lambda (termlist)
@ -795,6 +854,8 @@
(put 'empty-termlist? '(dense)
empty-termlist?)
(put 'order '(dense) highest-order-term)
;; Operators
(put 'negate '(dense)
(lambda (termlist)
@ -888,6 +949,8 @@
(define (square x) (mul x x))
(define (greatest-common-divisor a b)
(apply-generic 'greatest-common-divisor a b))
(define (reduce a b)
(apply-generic 'reduce a b))
(define (equ? x y) (apply-generic 'equ? x y))
;;(put 'equ? '(complex complex) equ?)
@ -948,20 +1011,42 @@
;; 2.95
(define p1 (make-polynomial 'x
(adjoin-term (make-term 2 1)
(adjoin-term (make-term 1 -2)
(adjoin-term (make-term 0 1)
(make-sparse-empty-termlist))))))
(define p2 (make-polynomial 'x
(adjoin-term (make-term 2 11)
(adjoin-term (make-term 0 7)
(make-sparse-empty-termlist)))))
(define p3 (make-polynomial 'x (adjoin-term (make-term 1 13)
(adjoin-term (make-term 0 5)
(make-sparse-empty-termlist)))))
(define q1 (mul p1 p2))
(define q2 (mul p1 p3))
;;(define p1 (make-polynomial 'x
;; (adjoin-term (make-term 2 1)
;; (adjoin-term (make-term 1 -2)
;; (adjoin-term (make-term 0 1)
;; (make-sparse-empty-termlist))))))
;;(define p2 (make-polynomial 'x
;; (adjoin-term (make-term 2 11)
;; (adjoin-term (make-term 0 7)
;; (make-sparse-empty-termlist)))))
;;(define p3 (make-polynomial 'x (adjoin-term (make-term 1 13)
;; (adjoin-term (make-term 0 5)
;; (make-sparse-empty-termlist)))))
;;(define q1 (mul p1 p2))
;;(define q2 (mul p1 p3))
;; GCD of q1 and q2 is not p1: it is a polynomial with rational coefficients because
;; of the division of coefficients.
;; 2.97
(define p1 (make-polynomial 'x
(adjoin-term (make-term 1 1)
(adjoin-term (make-term 0 1)
(make-sparse-empty-termlist)))))
(define p2 (make-polynomial 'x
(adjoin-term (make-term 3 1)
(adjoin-term (make-term 0 -1)
(make-sparse-empty-termlist)))))
(define p3 (make-polynomial 'x
(adjoin-term (make-term 1 1)
(make-sparse-empty-termlist))))
(define p4 (make-polynomial 'x
(adjoin-term (make-term 2 1)
(adjoin-term (make-term 0 -1)
(make-sparse-empty-termlist)))))
(define rf1 (make-rational p1 p2))
(define rf2 (make-rational p3 p4))