From d9676999efcfb71a2042318d095a1e26bf0b6806 Mon Sep 17 00:00:00 2001 From: Felix Martin Date: Sat, 21 Nov 2020 20:44:04 -0500 Subject: [PATCH] Implement till 2.86 --- ex-2_77-97.scm | 256 +++++++++++++++++++++++++++++++++---------------- 1 file changed, 175 insertions(+), 81 deletions(-) diff --git a/ex-2_77-97.scm b/ex-2_77-97.scm index 6204641..8cd5766 100644 --- a/ex-2_77-97.scm +++ b/ex-2_77-97.scm @@ -34,6 +34,12 @@ ((pair? datum) (car datum)) (else (error "Bad tagged datum -- TYPE-TAG" datum)))) +(define (has-tag? datum) + (cond + ((number? datum) #t) + ((pair? datum) #t) + (else #f))) + (define (contents datum) (cond ((number? datum) datum) @@ -49,33 +55,31 @@ "No method for these types -- APPLY-GENERIC" (list op type-tags)))))) -(define (install-integer-package) - (define (make-integer x) - (if (integer? x) - (tag x) - (error "Not an integer -- MAKE-INTEGER " x))) - (define (integer->rational x) +(define (install-scheme-number-package) + (define (tag x) x) + (define (scheme->rational x) (make-rational x 1)) - (define (tag x) - (attach-tag 'integer x)) - (put 'add '(integer integer) + (put 'add '(scheme-number scheme-number) (lambda (x y) (tag (+ x y)))) - (put 'sub '(integer integer) + (put 'sub '(scheme-number scheme-number) (lambda (x y) (tag (- x y)))) - (put 'mul '(integer integer) + (put 'mul '(scheme-number scheme-number) (lambda (x y) (tag (* x y)))) - (put 'div '(integer integer) + (put 'div '(scheme-number scheme-number) (lambda (x y) (tag (/ x y)))) - (put 'equ? '(integer integer) + (put 'equ? '(scheme-number scheme-number) (lambda (x y) (= x y))) - (put 'exp '(integer integer) - (lambda (x y) (tag (expt x y)))) ; using primitive expt - (put '=zero? '(integer) + (put 'exp '(scheme-number scheme-number) + (lambda (x y) (tag (expt x y)))) + (put '=zero? '(scheme-number) (lambda (x) (= x 0))) - (put 'make 'integer - (lambda (x) (make-integer x))) - (put 'raise '(integer) integer->rational) - (display "[install-integer-package]\n") + (put 'make 'scheme-number + (lambda (x) (tag x))) + (put 'arctan '(scheme-number scheme-number) + (lambda (x y) (atan x y))) + (put 'square-root '(scheme-number) sqrt) + (put 'raise 'scheme-number scheme->rational) + (display "[install-scheme-number-package]\n") 'done) (define (install-rational-package) @@ -83,8 +87,10 @@ (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)))) + (if (and (integer? n) (integer? d)) + (let ((g (gcd n d))) + (cons (/ n g) (/ d g))) + (cons n d))) (define (add-rat x y) (make-rat (+ (* (numer x) (denom y)) (* (numer y) (denom x))) @@ -105,7 +111,9 @@ (= (* (numer x) (denom y)) (* (numer y) (denom x)))) (define (rational->real x) - (make-scheme-number (/ (numer x) (denom x)))) + (make-real (/ (numer x) (denom x)))) + (define (rational->scheme x) + (make-scheme-number (inexact->exact (round (/ (numer x) (denom x)))))) ;; interface to rest of the system (define (tag x) (attach-tag 'rational x)) (put 'add '(rational rational) @@ -121,51 +129,63 @@ (put 'equ? '(rational rational) equ?) (put '=zero? '(rational) (lambda (x) (= (numer x) 0))) + (define (arctan-rational x y) + (atan (/ (numer x) (denom x)) + (/ (numer y) (denom y)))) + (put 'arctan '(rational rational) arctan-rational) + (put 'square-root '(rational) + (lambda (x) (sqrt (/ (numer x) (denom x))))) (put 'make 'rational (lambda (n d) (tag (make-rat n d)))) - (put 'raise '(rational) rational->real) + (put 'raise 'rational rational->real) + (put 'project 'rational rational->scheme) (display "[install-rational-package]\n") 'done) -(define (install-scheme-number-package) - (define (tag x) - (attach-tag 'scheme-number x)) +(define (install-real-package) + (define (make-real x) (tag x)) + (define (real->rational x) + (make-rational x 1)) (define (real->complex x) (make-complex-from-real-imag x 0)) - (put 'add '(scheme-number scheme-number) + (define (tag x) + (attach-tag 'real x)) + (put 'add '(real real) (lambda (x y) (tag (+ x y)))) - (put 'sub '(scheme-number scheme-number) + (put 'sub '(real real) (lambda (x y) (tag (- x y)))) - (put 'mul '(scheme-number scheme-number) + (put 'mul '(real real) (lambda (x y) (tag (* x y)))) - (put 'div '(scheme-number scheme-number) + (put 'div '(real real) (lambda (x y) (tag (/ x y)))) - (put 'equ? '(scheme-number scheme-number) + (put 'equ? '(real real) (lambda (x y) (= x y))) - (put 'exp '(scheme-number scheme-number) - (lambda (x y) (tag (expt x y)))) ; using primitive expt - (put '=zero? '(scheme-number) + (put 'exp '(real real) + (lambda (x y) (tag (expt x y)))) + (put '=zero? '(real) (lambda (x) (= x 0))) - (put 'make 'scheme-number - (lambda (x) (tag x))) - (put 'raise '(scheme-number) real->complex) - (display "[install-scheme-number-package]\n") + (put 'make 'real + (lambda (x) (make-real x))) + (put 'raise 'real real->complex) + (put 'project 'real real->rational) + (display "[install-real-package]\n") 'done) (define (install-rectangular-package) (define (real-part z) (car z)) (define (imag-part z) (cdr z)) + (define (square x) (mul x x)) (define (magnitude z) - (sqrt (+ (square (real-part z)) - (square (imag-part z))))) + (square-root (add (square (real-part z)) + (square (imag-part z))))) (define (angle z) - (atan (imag-part z) - (real-part z))) + (arctan (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))))) + (tag (cons (mul r (cos a)) (mul r (sin a))))) ; interface to the rest of the system (put 'real-part '(rectangular) real-part) (put 'imag-part '(rectangular) imag-part) @@ -179,14 +199,15 @@ (define (install-polar-package) (define (real-part z) - (* (magnitude z) (cos (angle z)))) + (mul (magnitude z) (cos (angle z)))) (define (imag-part z) - (* (magnitude z) (sin (angle z)))) + (mul (magnitude z) (sin (angle z)))) (define (magnitude z) (car z)) (define (angle z) (cdr z)) + (define (sqrt x) (mul x x)) (define (tag z) (attach-tag 'polar z)) (define (make-from-real-imag x y) - (tag (cons (sqrt (+ (square x) (square y))) + (tag (cons (sqrt (add (square x) (square y))) (atan y x)))) (define (make-from-mag-ang r a) (tag (cons r a))) ; interface to rest of the system @@ -213,20 +234,22 @@ (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)))) + (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 (- (real-part z1) (real-part z2)) - (- (imag-part z1) (imag-part 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 (* (magnitude z1) (magnitude z2)) - (+ (angle z1) (angle z2)))) + (make-from-mag-ang (mul (magnitude z1) (magnitude z2)) + (add (angle z1) (angle z2)))) (define (div-complex z1 z2) - (make-from-mag-ang (/ (magnitude z1) (magnitude z2)) - (- (angle z1) (angle z2)))) - (define (equ? z1 z2) - (and (= (magnitude z1) (magnitude z2)) - (= (angle z1) (angle z2)))) + (make-from-mag-ang (div (magnitude z1) (magnitude z2)) + (sub (angle z1) (angle z2)))) + (define (equ?-complex z1 z2) + (and (equ? (magnitude z1) (magnitude z2)) + (equ? (angle z1) (angle z2)))) + (define (complex->real x) + (make-real (real-part x))) ;; interface to rest of the system (put 'real-part '(complex) real-part) (put 'imag-part '(complex) imag-part) @@ -245,20 +268,21 @@ (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)))) - (put 'equ? '(complex complex) equ?) + (put 'equ? '(complex complex) equ?-complex) (put '=zero? '(complex) =zero?) + (put 'project 'complex complex->real) (display "[install-complex-package]\n") 'done) ;; constructors -(define (make-integer n) - ((get 'make 'integer) n)) +(define (make-scheme-number n) + ((get 'make 'scheme-number) n)) (define (make-rational n d) ((get 'make 'rational) n d)) -(define (make-scheme-number n) - ((get 'make 'scheme-number) n)) +(define (make-real n) + ((get 'make 'real) n)) (define (make-complex-from-real-imag x y) ((get 'make-from-real-imag 'complex) x y)) @@ -280,11 +304,12 @@ (define (equ? x y) (apply-generic 'equ? x y)) (define (=zero? x) (apply-generic '=zero? x)) (define (exp x y) (apply-generic 'exp x y)) -(define (raise x) (apply-generic 'raise x)) +(define (arctan x y) (apply-generic 'arctan x y)) +(define (square-root x) (apply-generic 'square-root x)) -(install-integer-package) -(install-rational-package) (install-scheme-number-package) +(install-rational-package) +(install-real-package) (install-rectangular-package) (install-polar-package) (install-complex-package) @@ -411,15 +436,18 @@ (display (coerce-args 'rational (list (make-rational 1 3) 2 3))) (newline) -(newline) (display "ex-2.83") (newline) +(newline) (display "ex-2.83 - raise") (newline) ; Our scheme-number package supports real numbers so we use that as our ; real-number package without further changes. Additionally, we create an ; integer package that only accepts integers in the constructor. -(assert (sub (make-integer 3) (make-integer 1)) (make-integer 2)) +(define (raise x) + ((get 'raise (type-tag x)) (contents x))) -(define i (make-integer 3)) +(assert (sub (make-scheme-number 3) (make-scheme-number 1)) (make-scheme-number 2)) + +(define i (make-scheme-number 3)) (display i) (newline) (display (raise i)) (newline) (display (raise (raise i))) (newline) @@ -433,24 +461,90 @@ (define (coerce-arg arg) (if (eq? (type-tag arg) target-type) arg - (let ((proc (get 'raise (list (type-tag arg))))) - (if (procedure? proc) - (proc (contents arg)) + (let ((raise (get 'raise (type-tag arg)))) + (if (procedure? raise) + (raise (contents arg)) arg)))) (let ((coerced-args (map coerce-arg args))) (if (equal? args coerced-args) coerced-args ; no more raising possible (coerce-args target-type coerced-args)))) -(assert (equ? (make-integer 3) (make-complex-from-real-imag 3 0)) #t) -(assert (equ? (make-integer 3) (make-complex-from-real-imag 3 1)) #f) -(assert (equ? (make-integer 3) (make-rational 3 1)) #t) -(assert (add3 (make-rational 1 3) (make-integer 2) (make-rational 3 9)) (make-rational 8 3)) -;(display (coerce-args 'scheme-number (list (make-rational 1 3) 2 (make-rational 3 9)))) +(assert (equ? (make-scheme-number 3) (make-complex-from-real-imag 3 0)) #t) +(assert (equ? (make-scheme-number 3) (make-complex-from-real-imag 3 1)) #f) +(assert (equ? (make-scheme-number 3) (make-rational 3 1)) #t) +(assert (add3 (make-rational 1 3) (make-scheme-number 2) (make-rational 3 9)) (make-rational 8 3)) -(newline) (display "ex-2.85 - drop it") (newline) - - -(newline) (display "ex-2.86") (newline) +(newline) (display "ex-2.85 - project and drop") (newline) + +; Do not implement project in terms of apply-generic as that will result in an +; endless loop when trying to drop values later automatically within the +; context of apply-generic. +(define (project x) + ((get 'project (type-tag x)) (contents x))) + +(define c (make-complex-from-real-imag 4.2 1)) +(display c) (newline) +(display (project c)) (newline) +(display (project (project c))) (newline) +(display (project (project (project c)))) (newline) + +; Implement drop to transform number to lowest possible representation +(define (drop x) + ;(display "---------\ndrop ") (display x) (newline) + (if (has-tag? x) + (let ((project (get 'project (type-tag x)))) + (if (procedure? project) + (let ((projected (project (contents x)))) + (if (equ? projected x) + (drop projected) + x)) + x)) + x)) + +;(assert (drop 3) (make-scheme-number 3)) +;(assert (drop (make-complex-from-real-imag 3.2 0)) (drop (make-real (/ 16 5.)))) +;(assert (drop (make-complex-from-real-imag 3 0)) (make-scheme-number 3)) + +(define (apply-generic op . args) + ;(display "-----\napply-generic ") (display op) (display " ") (display args) (newline) + (define (try-args args-list) + (if (null? args-list) + (error "No method for these types" (list op (map type-tag args))) + (let ((proc (get op (map type-tag (car args-list)))) + (args-contents (map contents (car args-list)))) + (if (procedure? proc) + (drop (apply proc args-contents)) + (try-args (cdr args-list)))))) + (define (coerce-to-arg arg) + (coerce-args (type-tag arg) args)) + (try-args (cons args (map coerce-to-arg args)))) + +(assert (equ? (add (make-rational 1 3) + (make-complex-from-real-imag 3 0)) + (make-rational 10 3)) #t) +(assert (add (make-rational 6 3) + (make-complex-from-real-imag 3 0)) + (make-scheme-number 5)) +(assert (add (make-rational 6 3) + (make-complex-from-real-imag 3 0)) + 5) + +(display "\nex-2.86 - generic complex numbers\n") + +; All the procedures that are used by the complex packages would also have to +; use the generic procedures. For example, we cannot use *, -, /, +, and have +; to replace them with their generic counter-part. We then also have to +; implement sine and cosine. I have skipped sin and cos, but handle atan and +; sqrt, so the following works. + +(define cr (make-complex-from-real-imag (make-rational 1 2) + (make-rational 1 2))) +(display (add cr cr)) (newline) +(display (mul cr cr)) (newline) + +(display "\n\nexample - symbolic algebra\n") + +(display "\nex-2.87\n")