(load "util.scm") (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 ((eq? type-tag 'scheme-number) contents) (else (cons type-tag contents)))) (define (type-tag datum) (cond ((number? datum) 'scheme-number) ((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) ((pair? datum) (cdr datum)) (else (error "Bad tagged datum -- CONTENTS" datum)))) (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)))))) (define (install-scheme-number-package) (define (tag x) x) (define (scheme->rational x) (make-rational x 1)) (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)))) (put '=zero? '(scheme-number) (lambda (x) (= x 0))) (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) ;; internal procedures (define (numer x) (car x)) (define (denom x) (cdr x)) (define (make-rat n d) (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))) (* (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)))) (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)))) (define (rational->real 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) (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) (lambda (x y) (tag (mul-rat x y)))) (put 'div '(rational rational) (lambda (x y) (tag (div-rat x y)))) (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 'project 'rational rational->scheme) (display "[install-rational-package]\n") 'done) (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)) (define (tag x) (attach-tag 'real x)) (put 'add '(real real) (lambda (x y) (tag (+ x y)))) (put 'sub '(real real) (lambda (x y) (tag (- x y)))) (put 'mul '(real real) (lambda (x y) (tag (* x y)))) (put 'div '(real real) (lambda (x y) (tag (/ x y)))) (put 'equ? '(real real) (lambda (x y) (= x y))) (put 'exp '(real real) (lambda (x y) (tag (expt x y)))) (put '=zero? '(real) (lambda (x) (= x 0))) (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) (square-root (add (square (real-part z)) (square (imag-part z))))) (define (angle 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 (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) (put 'magnitude '(rectangular) magnitude) (put 'angle '(rectangular) angle) (put '=zero? '(rectangular) (lambda (z) (= (real-part z) (imag-part z) 0))) (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) (mul (magnitude z) (cos (angle z)))) (define (imag-part 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 (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 (put 'real-part '(polar) real-part) (put 'imag-part '(polar) imag-part) (put 'magnitude '(polar) magnitude) (put 'angle '(polar) angle) (put '=zero? '(polar) (lambda (z) (= (magnitude z) 0))) (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 (add (real-part z1) (real-part z2)) (add (imag-part z1) (imag-part z2)))) (define (sub-complex z1 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 (mul (magnitude z1) (magnitude z2)) (add (angle z1) (angle z2)))) (define (div-complex z1 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) (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)))) (put 'equ? '(complex complex) equ?-complex) (put '=zero? '(complex) =zero?) (put 'project 'complex complex->real) (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-real n) ((get 'make 'real) n)) (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)) (define (real-part z) ((get 'real-part '(complex)) z)) (define (imag-part z) ((get 'imag-part '(complex)) z)) (define (magnitude z) ((get 'magnitude '(complex)) z)) (define (angle z) ((get 'angle '(complex)) z)) ;; 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)) (define (arctan x y) (apply-generic 'arctan x y)) (define (square-root x) (apply-generic 'square-root x)) (install-scheme-number-package) (install-rational-package) (install-real-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.142135623730951 0.7853981633974483)) (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) ; Extended each of the packages and defined generic procedure (assert (equ? (make-scheme-number 10) (make-scheme-number 10)) #t) (assert (equ? (make-rational 3 4) (make-rational 6 8)) #t) (assert (equ? (make-complex-from-mag-ang 3 4) (make-complex-from-real-imag 6 8)) #f) (assert (equ? p1 e1) #t) ; define above (newline) (display "ex-2.80 - =zero?") (newline) ; Extended each of the packages and defined generic procedure (assert (=zero? 0) #t) (assert (=zero? 1) #f) (assert (=zero? (make-rational 0 1)) #t) (assert (=zero? (make-rational 1 1)) #f) (assert (=zero? e1) #f) (assert (=zero? p1) #f) (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) (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 - 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. (define (raise x) ((get 'raise (type-tag x)) (contents x))) (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) (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 ((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-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 - 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 "\nexample - symbolic algebra\n") (define (install-polynomial-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))) ;; representation of terms and term lists (define (adjoin-term term term-list) (if (=zero? (coeff term)) term-list (cons term term-list))) (define (the-empty-termlist) '()) (define (first-term term-list) (car term-list)) (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 (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 '=zero? '(polynomial) =zero?-poly) (put 'make 'polynomial (lambda (var terms) (tag (make-poly var terms)))) (display "[install-polynomial-package]\n") 'done) (install-polynomial-package) (define (make-poly var terms) ((get 'make 'polynomial) var terms)) (define p (make-poly 'x '((100 2) (1 2)))) ;(display p) (assert (mul p p) (make-poly 'x '((200 4) (101 8) (2 4)))) (display "\nex-2.87 - =zero?\n") (assert (=zero? p) #f) (assert #t (=zero? (make-poly 'x (list (list 10 (make-rational 0 10)) (list 5 (make-complex-from-real-imag 0 0)) (list 1 0))))) (define px p) (define py (make-poly 'y (list (list 3 px)))) (display (add py py)) (newline) (display "\nex-2.88 - sub\n")