SICP/ex-2_77-97.scm
2020-11-25 10:48:56 -05:00

673 lines
23 KiB
Scheme

(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")