From d8e3a4072f0fb43d22f59863d1f06cfb0ccf1518 Mon Sep 17 00:00:00 2001 From: Felix Martin Date: Wed, 18 Nov 2020 17:54:54 -0500 Subject: [PATCH] Implement till 2.78 --- ex-2_77-97.scm | 221 +++++++++++++++++++++++++++++++++++++++++++++++-- util.scm | 5 +- 2 files changed, 219 insertions(+), 7 deletions(-) diff --git a/ex-2_77-97.scm b/ex-2_77-97.scm index 81829bd..35821e3 100644 --- a/ex-2_77-97.scm +++ b/ex-2_77-97.scm @@ -1,13 +1,222 @@ (load "util.scm") -(newline) (display "ex-2.77") (newline) +(display "\nexample - generic arithmetic operations\n") -(newline) (display "ex-2.78") (newline) +;; Helpers for generic arithmetic operations +(define (attach-tag type-tag contents) + (cond + ((eq? type-tag 'scheme-number) contents) + (else (cons type-tag contents)))) -(newline) (display "ex-2.79") (newline) +(define (type-tag datum) + (cond + ((number? datum) 'scheme-number) + ((pair? datum) (car datum)) + (else (error "Bad tagged datum -- TYPE-TAG" datum)))) -(newline) (display "ex-2.80") (newline) +(define (contents datum) + (cond + ((number? datum) datum) + ((pair? datum) (cdr datum)) + (else (error "Bad tagged datum -- CONTENTS" datum)))) -(newline) (display "ex-2.81") (newline) +(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)) + (error + "No method for these types -- APPLY-GENERIC" + (list op type-tags)))))) -(newline) (display "ex-2.82") (newline) +(define (install-scheme-number-package) + (define (tag x) + (attach-tag 'scheme-number x)) + (put 'add '(scheme-number scheme-number) + (lambda (x y) (tag (+ x y)))) + (put 'sub '(scheme-number scheme-number) + (lambda (x y) (tag (- x y)))) + (put 'mul '(scheme-number scheme-number) + (lambda (x y) (tag (* x y)))) + (put 'div '(scheme-number scheme-number) + (lambda (x y) (tag (/ x y)))) + (put 'make 'scheme-number + (lambda (x) (tag x))) + (display "[install-scheme-number-package]\n") + 'done) + +(define (install-rational-package) + ;; internal procedures + (define (numer x) (car x)) + (define (denom x) (cdr x)) + (define (make-rat n d) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g)))) + (define (add-rat x y) + (make-rat (+ (* (numer x) (denom y)) + (* (numer y) (denom x))) + (* (denom x) (denom y)))) + (define (sub-rat x y) + (make-rat (- (* (numer x) (denom y)) + (* (numer y) (denom x))) + (* (denom x) (denom y)))) + (define (mul-rat x y) + (make-rat (* (numer x) (numer y)) + (* (denom x) (denom y)))) + (define (div-rat x y) + (make-rat (* (numer x) (denom y)) + (* (denom x) (numer y)))) + ;; interface to rest of the system + (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)))) + (display "[install-rational-package]\n") + 'done) + +(define (install-rectangular-package) + (define (real-part z) (car z)) + (define (imag-part z) (cdr z)) + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + (define (angle z) + (atan (imag-part z) + (real-part z))) + (define (tag z) (attach-tag 'rectangular z)) + (define (make-from-real-imag x y) + (tag (cons x y))) + (define (make-from-mag-ang r a) + (tag (cons (* r (cos a)) (* r (sin a))))) + ; interface to the rest of the system + (put 'real-part '(rectangular) real-part) + (put 'imag-part '(rectangular) imag-part) + (put 'magnitude '(rectangular) magnitude) + (put 'angle '(rectangular) angle) + (put 'make-from-mag-ang 'rectangular make-from-mag-ang) + (put 'make-from-real-imag 'rectangular make-from-real-imag) + (display "[install-rectangular-package]\n") + 'done) + +(define (install-polar-package) + (define (real-part z) + (* (magnitude z) (cos (angle z)))) + (define (imag-part z) + (* (magnitude z) (sin (angle z)))) + (define (magnitude z) (car z)) + (define (angle z) (cdr z)) + (define (tag z) (attach-tag 'polar z)) + (define (make-from-real-imag x y) + (tag (cons (sqrt (+ (square x) (square y))) + (atan y x)))) + (define (make-from-mag-ang r a) (tag (cons r a))) + ; interface to rest of the system + (put 'real-part '(polar) real-part) + (put 'imag-part '(polar) imag-part) + (put 'magnitude '(polar) magnitude) + (put 'angle '(polar) angle) + (put 'make-from-mag-ang 'polar make-from-mag-ang) + (put 'make-from-real-imag 'polar make-from-real-imag) + (display "[install-polar-package]\n") + 'done) + +(define (install-complex-package) + ;; imported procedures from rectangular and polar packages + (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)) + ;; getters + (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)) + ;; internal procedures + (define (add-complex z1 z2) + (make-from-real-imag (+ (real-part z1) (real-part z2)) + (+ (imag-part z1) (imag-part z2)))) + (define (sub-complex z1 z2) + (make-from-real-imag (- (real-part z1) (real-part z2)) + (- (imag-part z1) (imag-part z2)))) + (define (mul-complex z1 z2) + (make-from-mag-ang (* (magnitude z1) (magnitude z2)) + (+ (angle z1) (angle z2)))) + (define (div-complex z1 z2) + (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) + (- (angle z1) (angle z2)))) + ;; interface to rest of the system + (put 'real-part '(complex) real-part) + (put 'imag-part '(complex) imag-part) + (put 'magnitude '(complex) magnitude) + (put 'angle '(complex) angle) + (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)))) + (display "[install-complex-package]\n") + 'done) + +;; constructors +(define (make-scheme-number n) + ((get 'make 'scheme-number) n)) + +(define (make-rational n d) + ((get 'make 'rational) n d)) + +(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)) + +;; generic operations +(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)) + +(install-scheme-number-package) +(install-rational-package) +(install-rectangular-package) +(install-polar-package) +(install-complex-package) + +(assert (add (make-scheme-number 10) (make-scheme-number 20)) (make-scheme-number 30)) +(define p1 (make-complex-from-mag-ang 14.142 0.7853)) +(define e1 (make-complex-from-real-imag 10 10)) +(assert (add e1 e1) (make-complex-from-real-imag 20 20)) + +(newline) (display "ex-2.77 - see comments") (newline) + +; real-part (and all other selectors are implemented via calls to apply +; generic. The first call to apply generic has the type 'magnitude '(complex). +; By adding the code from Alyssa that call gets dispatched a second time which +; results in a call to apply generic with 'magnitude '(rectangular). This calls +; the actual magnitude function from the rectangular package. + +(newline) (display "ex-2.78 - simplify scheme number") (newline) + +; Solution at the beginning of this file. +(assert (add 5 3) 8) + +(newline) (display "ex-2.79 - equ?") (newline) + + +(newline) (display "ex-2.80 - =zero?") (newline) diff --git a/util.scm b/util.scm index 69d0e02..5a365bf 100644 --- a/util.scm +++ b/util.scm @@ -43,5 +43,8 @@ (define (put op type proc) (hash-table/put! *op-table* (list op type) proc)) (define (get op type) - (hash-table/get *op-table* (list op type) #f)) + (let ((e (hash-table/get *op-table* (list op type) #f))) + (if (eq? e #f) + (error "Unknown op type -- GET" (list op type)) + e)))