From bebccac4c2d7d6e4de34ffe0632f792239e52a5a Mon Sep 17 00:00:00 2001 From: Felix Martin Date: Fri, 20 Nov 2020 22:04:19 -0500 Subject: [PATCH] Implement till 2.83 --- ex-2_77-97.scm | 122 ++++++++++++++++++++++++++++++++++++++++++++++++- util.scm | 29 +++++++----- 2 files changed, 138 insertions(+), 13 deletions(-) diff --git a/ex-2_77-97.scm b/ex-2_77-97.scm index 3957099..41a7877 100644 --- a/ex-2_77-97.scm +++ b/ex-2_77-97.scm @@ -2,6 +2,26 @@ (display "\nexample - generic arithmetic operations\n") +; (define (display x) ()) +; (define (newline) ()) +; can be used to import stuff silently + +; Put and get functions. We could have implemented this via a list of +; three-tuples, but I don't know how to create global variables yet so we just +; use this code from SO. Doesn't look too complicated. +; https://stackoverflow.com/questions/5499005/how-do-i-get-the-functions-put-and-get-in-sicp-scheme-exercise-2-78-and-on +(define *op-table* (make-hash-table)) +(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)) + +(define *coercion-table* (make-hash-table)) +(define (put-coercion type1 type2 proc) + (hash-table/put! *coercion-table* (list type1 type2) proc)) +(define (get-coercion type1 type2) + (hash-table/get *coercion-table* (list type1 type2) #f)) + ;; Helpers for generic arithmetic operations (define (attach-tag type-tag contents) (cond @@ -42,6 +62,8 @@ (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 @@ -70,6 +92,8 @@ (define (div-rat x y) (make-rat (* (numer x) (denom y)) (* (denom x) (numer y)))) + (define (add3-rat x y z) + (add-rat (add-rat x y) z)) (define (equ? x y) (= (* (numer x) (denom y)) (* (numer y) (denom x)))) @@ -77,6 +101,8 @@ (define (tag x) (attach-tag 'rational x)) (put 'add '(rational rational) (lambda (x y) (tag (add-rat x y)))) + (put 'add3 '(rational rational rational) + (lambda (x y z) (tag (add3-rat x y z)))) (put 'sub '(rational rational) (lambda (x y) (tag (sub-rat x y)))) (put 'mul '(rational rational) @@ -209,11 +235,13 @@ ;; generic operations (define (add x y) (apply-generic 'add x y)) +(define (add3 x y z) (apply-generic 'add3 x y z)) (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)) (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)) (install-scheme-number-package) (install-rational-package) @@ -257,5 +285,97 @@ (assert (=zero? e1) #f) (assert (=zero? p1) #f) -(newline) (display "ex-2.81") (newline) +(newline) (display "ex-2.81 - Louis trying things") (newline) +(define (scheme-number->complex n) + (make-complex-from-real-imag (contents n) 0)) + +(put-coercion 'scheme-number 'complex scheme-number->complex) + +(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)) + (if (= (length args) 2) + (let ((type1 (car type-tags)) + (type2 (cadr type-tags)) + (a1 (car args)) + (a2 (cadr args))) + (let ((t1->t2 (get-coercion type1 type2)) + (t2->t1 (get-coercion type2 type1))) + (cond + ((eq? type1 type2) (error "No need to coerce identical types" + (list op type-tags))) + (t1->t2 (apply-generic op (t1->t2 a1) a2)) + (t2->t1 (apply-generic op a1 (t2->t1 a2))) + (else (error "No method for these types" (list op type-tags)))))) + (error "No method for these types" + (list op type-tags))))))) + +(display "[see comments]\n") +(assert (exp 3 3) 27) +(assert (add (make-scheme-number 3) (make-complex-from-real-imag 3 4)) + (make-complex-from-real-imag 6 4)) + +; a. This is an endless loop. Louis change is not necessary, because if we +; coerce the arguments into the same type we would have found the respective +; procedure already. + +; (define (scheme-number->scheme-number n) n) +; (define (complex->complex z) z) +; (put-coercion 'scheme-number 'scheme-number scheme-number->scheme-number) +; (put-coercion 'complex 'complex complex->complex) + +; (exp (make-complex-from-real-imag 3 4) (make-complex-from-mag-ang 2 3)) + +; b. apply-generic already handles arguments of the same type correctly. It +; will simply not find a coercion procedure and return. + +; c. added check for identical types to apply-generic. The following now just +; causes an error and no endless loop. +; (exp (make-complex-from-real-imag 3 4) (make-complex-from-mag-ang 2 3)) + + +(newline) (display "ex-2.82 - multi argument coercion") (newline) + + +(define (scheme-number->rational n) + (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))) + (if (procedure? t1->t2) (t1->t2 arg) arg))) + (map coerce-arg args)) + +(define (apply-generic op . args) + (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) + (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 (add3 (make-rational 1 3) 2 (make-rational 3 9)) (make-rational 8 3)) + +; This approach does not work if there exist procedures for mixed types or if +; the coerced type that would work is different from any of the existing +; arguments' types. + +(display (coerce-args 'rational (list (make-rational 1 3) 2 3))) (newline) + +(newline) (display "ex-2.83") (newline) + +(newline) (display "ex-2.84") (newline) + + +(newline) (display "ex-2.85 - we are back!") (newline) diff --git a/util.scm b/util.scm index 5a365bf..4babb59 100644 --- a/util.scm +++ b/util.scm @@ -35,16 +35,21 @@ nil (cons low (enumerate-interval (+ low 1) high)))) -; Put and get functions. We could have implemented this via a list of -; three-tuples, but I don't know how to create global variables yet so we just -; use this code from SO. Doesn't look too complicated. -; https://stackoverflow.com/questions/5499005/how-do-i-get-the-functions-put-and-get-in-sicp-scheme-exercise-2-78-and-on -(define *op-table* (make-hash-table)) -(define (put op type proc) - (hash-table/put! *op-table* (list op type) proc)) -(define (get op type) - (let ((e (hash-table/get *op-table* (list op type) #f))) - (if (eq? e #f) - (error "Unknown op type -- GET" (list op type)) - e))) +; Returns #t if there is no #f in xs, otherwise returns #f. +(define (all? xs) + (cond ((null? xs) #t) + ((eq? (car xs) #f) #f) + (else (all? (cdr xs))))) + +(define (all-eq? xs) + (cond ((null? xs) #t) + ((null? (cdr xs)) #t) + ((eq? (car xs) (cadr xs)) (all-eq? (cdr xs))) + (else #f))) + +(define (fold-right op initial sequence) ; same as accumulate + (if (null? sequence) + initial + (op (car sequence) + (fold-right op initial (cdr sequence)))))