From 77f312436234711e8716bf28ceef05deb0e593bc Mon Sep 17 00:00:00 2001 From: Felix Martin Date: Thu, 26 Nov 2020 20:59:36 -0500 Subject: [PATCH] Implement till 2.89 I have also added my solution to http://community.schemewiki.org/?sicp-ex-2.89 because none of the other ones looked right to me when checking. --- ex-2_77-97.scm | 168 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 168 insertions(+) diff --git a/ex-2_77-97.scm b/ex-2_77-97.scm index 9364ceb..4d79c2f 100644 --- a/ex-2_77-97.scm +++ b/ex-2_77-97.scm @@ -73,6 +73,8 @@ (lambda (x y) (tag (expt x y)))) (put '=zero? '(scheme-number) (lambda (x) (= x 0))) + (put 'negate '(scheme-number) + (lambda (x) (- x))) (put 'make 'scheme-number (lambda (x) (tag x))) (put 'arctan '(scheme-number scheme-number) @@ -129,6 +131,9 @@ (put 'equ? '(rational rational) equ?) (put '=zero? '(rational) (lambda (x) (= (numer x) 0))) + (put 'negate '(rational) + (lambda (x) (tag (make-rat (- (numer x)) + (denom x))))) (define (arctan-rational x y) (atan (/ (numer x) (denom x)) (/ (numer y) (denom y)))) @@ -248,6 +253,8 @@ (define (equ?-complex z1 z2) (and (equ? (magnitude z1) (magnitude z2)) (equ? (angle z1) (angle z2)))) + (define (negate-complex z) + (tag (make-from-real-imag (- (real-part z)) (- (imag-part z))))) (define (complex->real x) (make-real (real-part x))) ;; interface to rest of the system @@ -270,6 +277,7 @@ (lambda (r a) (tag (make-from-mag-ang r a)))) (put 'equ? '(complex complex) equ?-complex) (put '=zero? '(complex) =zero?) + (put 'negate '(complex) negate-complex) (put 'project 'complex complex->real) (display "[install-complex-package]\n") 'done) @@ -306,6 +314,7 @@ (define (exp x y) (apply-generic 'exp x y)) (define (arctan x y) (apply-generic 'arctan x y)) (define (square-root x) (apply-generic 'square-root x)) +(define (negate x) (apply-generic 'negate x)) (install-scheme-number-package) (install-rational-package) @@ -599,6 +608,16 @@ (error "Polys not in same var -- ADD-POLY" (list p1 p2)))) + (define (sub-poly p1 p2) + (define (negate-term term) + (make-term (order term) (negate (coeff term)))) + (if (same-variable? (variable p1) (variable p2)) + (make-poly (variable p1) + (add-terms (term-list p1) + (map negate-term (term-list p2)))) + (error "Polys not in same var -- ADD-POLY" + (list p1 p2)))) + (define (mul-terms L1 L2) (if (empty-termlist? L1) (the-empty-termlist) @@ -636,6 +655,8 @@ (lambda (p1 p2) (tag (add-poly p1 p2)))) (put 'mul '(polynomial polynomial) (lambda (p1 p2) (tag (mul-poly p1 p2)))) + (put 'sub '(polynomial polynomial) + (lambda (p1 p2) (tag (sub-poly p1 p2)))) (put '=zero? '(polynomial) =zero?-poly) (put 'make 'polynomial (lambda (var terms) (tag (make-poly var terms)))) @@ -669,4 +690,151 @@ (display "\nex-2.88 - sub\n") +; Implement via negate procedure +(assert (negate (make-scheme-number -3)) 3) +(assert (negate (make-rational -1 3)) + (make-rational 1 3)) +(assert (make-complex-from-real-imag 2 4) + (negate (make-complex-from-real-imag -2 -4))) +(define p1 (make-poly 'x (list (list 5 4) (list 2 1)))) +(define p2 (make-poly 'x (list (list 5 2) (list 2 (make-rational 1 2))))) +(assert (sub p1 p2) p2) + +(display "\nex-2.89 - spare representation\n") + + +(define (install-polynomial-sparse-representation-package) + ;; internal procedures + ;; representation of poly + (define (make-poly variable term-list) + (cons variable term-list)) + (define (variable p) (car p)) + (define (term-list p) (cdr p)) + + ;; procedures same-variable? and variable? from section 2.3.2 + (define (variable? x) (symbol? x)) + (define (=number? exp num) + (and (number? exp) (= exp num))) + (define (same-variable? v1 v2) + (and (variable? v1) (variable? v2) (eq? v1 v2))) + + (define (first-term term-list) + (make-term (- (length term-list) 1) + (car term-list))) + + (define (adjoin-term term term-list) + (let ((coeff-term (coeff term)) + (order-term (order term)) + (length-terms (length term-list))) + (cond + ((= order-term length-terms) (cons coeff-term term-list)) + ((< order-term length-terms) (error "Cannot adjoin lower-order term to terms")) + (else (cons coeff-term (adjoin-term (make-term (- order-term 1) 0) term-list)))))) + + (define (the-empty-termlist) '()) + (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 (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) + (define (negate-term term) + (make-term (order term) (negate (coeff term)))) + (if (same-variable? (variable p1) (variable p2)) + (make-poly (variable p1) + (add-terms (term-list p1) + (map negate-term (term-list p2)))) + (error "Polys not in same var -- ADD-POLY" + (list p1 p2)))) + + (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 (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 (=zero?-poly p) + (define (=zero?-terms terms) + (cond + ((empty-termlist? terms) #t) + ((not (=zero? (coeff (first-term terms)))) #f) + (else (=zero?-terms (rest-terms terms))))) + (=zero?-terms (term-list p))) + + ;; interface to rest of the system + (define (tag p) (attach-tag 'polynomial p)) + (put 'add '(polynomial polynomial) + (lambda (p1 p2) (tag (add-poly p1 p2)))) + (put 'mul '(polynomial polynomial) + (lambda (p1 p2) (tag (mul-poly p1 p2)))) + (put 'sub '(polynomial polynomial) + (lambda (p1 p2) (tag (sub-poly p1 p2)))) + (put '=zero? '(polynomial) =zero?-poly) + (put 'make 'polynomial + (lambda (var terms) (tag (make-poly var terms)))) + (display "[install-polynomial-sparse-representation-package]\n") + 'done) + +(install-polynomial-sparse-representation-package) + +(define p1 (make-poly 'x (list 5 1))) +(assert (add p1 p1) (make-poly 'x (list 10 2))) +(assert (add (make-poly 'x (list 2 2 0 1)) + (make-poly 'x (list 1 2 3 2 3 6 6))) + (make-poly 'x (list 1 2 3 4 5 6 7))) +(display (mul (make-poly 'x (list 1 1)) + (make-poly 'x (list 1 1)))) + + +;(display "\nex-2.90\n") + +;(display "\nex-2.91\n") + +;(display "\nex-2.92\n") + +;(display "\nex-2.93\n")