From 40a017043b28e551c979160632dd942e4986fae7 Mon Sep 17 00:00:00 2001 From: Felix Martin Date: Sat, 21 Nov 2020 10:34:55 -0500 Subject: [PATCH] Implement till 2.84 --- ex-2_77-97.scm | 111 +++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 93 insertions(+), 18 deletions(-) diff --git a/ex-2_77-97.scm b/ex-2_77-97.scm index 41a7877..6204641 100644 --- a/ex-2_77-97.scm +++ b/ex-2_77-97.scm @@ -49,26 +49,33 @@ "No method for these types -- APPLY-GENERIC" (list op type-tags)))))) -(define (install-scheme-number-package) +(define (install-integer-package) + (define (make-integer x) + (if (integer? x) + (tag x) + (error "Not an integer -- MAKE-INTEGER " x))) + (define (integer->rational x) + (make-rational x 1)) (define (tag x) - (attach-tag 'scheme-number x)) - (put 'add '(scheme-number scheme-number) + (attach-tag 'integer x)) + (put 'add '(integer integer) (lambda (x y) (tag (+ x y)))) - (put 'sub '(scheme-number scheme-number) + (put 'sub '(integer integer) (lambda (x y) (tag (- x y)))) - (put 'mul '(scheme-number scheme-number) + (put 'mul '(integer integer) (lambda (x y) (tag (* x y)))) - (put 'div '(scheme-number scheme-number) + (put 'div '(integer integer) (lambda (x y) (tag (/ x y)))) - (put 'equ? '(scheme-number scheme-number) + (put 'equ? '(integer integer) (lambda (x y) (= x y))) - (put 'exp '(scheme-number scheme-number) + (put 'exp '(integer integer) (lambda (x y) (tag (expt x y)))) ; using primitive expt - (put '=zero? '(scheme-number) + (put '=zero? '(integer) (lambda (x) (= x 0))) - (put 'make 'scheme-number - (lambda (x) (tag x))) - (display "[install-scheme-number-package]\n") + (put 'make 'integer + (lambda (x) (make-integer x))) + (put 'raise '(integer) integer->rational) + (display "[install-integer-package]\n") 'done) (define (install-rational-package) @@ -97,6 +104,8 @@ (define (equ? x y) (= (* (numer x) (denom y)) (* (numer y) (denom x)))) + (define (rational->real x) + (make-scheme-number (/ (numer x) (denom x)))) ;; interface to rest of the system (define (tag x) (attach-tag 'rational x)) (put 'add '(rational rational) @@ -114,9 +123,35 @@ (lambda (x) (= (numer x) 0))) (put 'make 'rational (lambda (n d) (tag (make-rat n d)))) + (put 'raise '(rational) rational->real) (display "[install-rational-package]\n") 'done) +(define (install-scheme-number-package) + (define (tag x) + (attach-tag 'scheme-number x)) + (define (real->complex x) + (make-complex-from-real-imag x 0)) + (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 'equ? '(scheme-number scheme-number) + (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) + (lambda (x) (= x 0))) + (put 'make 'scheme-number + (lambda (x) (tag x))) + (put 'raise '(scheme-number) real->complex) + (display "[install-scheme-number-package]\n") + 'done) + (define (install-rectangular-package) (define (real-part z) (car z)) (define (imag-part z) (cdr z)) @@ -216,12 +251,15 @@ 'done) ;; constructors -(define (make-scheme-number n) - ((get 'make 'scheme-number) n)) +(define (make-integer n) + ((get 'make 'integer) n)) (define (make-rational n d) ((get 'make 'rational) n d)) +(define (make-scheme-number n) + ((get 'make 'scheme-number) n)) + (define (make-complex-from-real-imag x y) ((get 'make-from-real-imag 'complex) x y)) @@ -242,9 +280,11 @@ (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)) -(install-scheme-number-package) +(install-integer-package) (install-rational-package) +(install-scheme-number-package) (install-rectangular-package) (install-polar-package) (install-complex-package) @@ -344,8 +384,6 @@ (make-rational (contents n) 1)) (put-coercion 'scheme-number 'rational scheme-number->rational) -; Try to coerce all args into target-type. Returns list if successful and empty -; list otherwise. (define (coerce-args target-type args) (define (coerce-arg arg) (let ((t1->t2 (get-coercion (type-tag arg) target-type))) @@ -375,7 +413,44 @@ (newline) (display "ex-2.83") (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 i (make-integer 3)) +(display i) (newline) +(display (raise i)) (newline) +(display (raise (raise i))) (newline) +(display (raise (raise (raise i)))) (newline) + (newline) (display "ex-2.84") (newline) +; All we have to do is update coerce-args to do consecutive raises +; to reach the target type. +(define (coerce-args target-type args) + (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)) + 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)))) + +(newline) (display "ex-2.85 - drop it") (newline) + + +(newline) (display "ex-2.86") (newline) + -(newline) (display "ex-2.85 - we are back!") (newline)