ompayne
/
sicp
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Move project and raise from apply-generic to the coercion table

This commit is contained in:
Oliver Payne 2022-03-12 16:23:22 +00:00
parent 4968558e49
commit 75d6bb8e05
1 changed files with 46 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
2_78.rkt
View File

@ -79,6 +79,29 @@
#f
(tower-iter tower)))
(define tower '(integer rational scheme-number complex))
(define (next-type type tower)
(cond ((or (null? tower)
(null? (cdr tower))) '())
((eq? type (car tower)) (cadr tower))
(else (next-type type (cdr tower)))))
(define (transform-type x tower)
(and (type-tagged? x)
(let* ((type (type-tag x))
(proj-type (next-type type tower)))
(if proj-type
((get-coercion type proj-type) (contents x))
'()))))
(define (raise x)
(transform-type x tower))
(define (project x)
(transform-type x (reverse tower)))
(define (apply-generic op . args)
(define (coerce-to t)
(letrec ((coerce (lambda (arg)
@ -192,16 +215,16 @@
(put 'equ? '(scheme-number scheme-number) =)
(put '=zero? '(scheme-number)
(lambda (x) (= x 0)))
(put 'raise '(scheme-number)
(lambda (x)
(make-complex-from-real-imag
(tag x)
(tag 0))))
(put 'project '(scheme-number)
(lambda (x)
(make-rational
(round (* x 1000))
1000)))
(put-coercion 'scheme-number 'complex
(lambda (x)
(make-complex-from-real-imag
(tag x)
(tag 0))))
(put-coercion 'scheme-number 'rational
(lambda (x)
(make-rational
(round (* x 1000))
1000)))
(put 'exp '(scheme-number scheme-number)
(lambda (x y) (tag (expt x y))))
(put 'make 'scheme-number
@ -231,20 +254,17 @@
(put 'negate '(integer)
(lambda (x) (* -1 x)))
(put 'sine '(integer)
(lambda (x) (sine (raise-int x))))
(lambda (x) (make-scheme-number (sin x))))
(put 'cosine '(integer)
(lambda (x) (cosine (raise-int x))))
(lambda (x) (cos x)))
(put 'square-root '(integer)
(lambda (x) (square-root (raise-int x))))
(lambda (x) (make-scheme-number (sqrt x))))
(put 'arctan '(integer integer)
(lambda (x y) (arctan (raise-int x)
(raise-int y))))
(lambda (x y) (make-scheme-number (atan x y))))
(put 'equ? '(integer integer)
(lambda (x y)
(= x y)))
(put 'raise '(integer) raise-int)
(put 'project '(integer)
(lambda (x) '()))
(put-coercion 'integer 'rational raise-int)
(put 'make 'integer
(lambda (x) (tag (round x))))
'done)
@ -304,11 +324,11 @@
(put 'equ? '(rational rational) eq-rat)
(put '=zero? '(rational)
(lambda (x) (equ? (numer x) (make-integer 0))))
(put 'raise '(rational) raise-rat)
(put 'project '(rational)
(lambda (x)
(make-integer
(/ (numer x) (denom x)))))
(put-coercion 'rational 'scheme-number raise-rat)
(put-coercion 'rational 'integer
(lambda (x)
(make-integer
(/ (numer x) (denom x)))))
(put 'make 'rational
(lambda (n d) (tag (make-rat n d))))
@ -439,9 +459,9 @@
(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 'project '(complex)
(lambda (z)
(real-part z)))
(put-coercion 'complex 'scheme-number
(lambda (z)
(real-part z)))
'done)
;; *incomplete* skeleton of package
@ -599,8 +619,6 @@
(define (=zero? x) (apply-generic '=zero? x))
(define (exp x y) (apply-generic 'exp x y))
(define (raise x) (apply-generic 'raise x))
(define (project x) (apply-generic 'project x))
(define (drop x)
(and (type-tagged? x)
@ -641,14 +659,8 @@
(define (scheme-number->rational n)
(make-rational n 1))
(put-coercion 'scheme-number 'complex scheme-number->complex)
(put-coercion 'scheme-number 'rational scheme-number->rational)
(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)
;; 2.81a: If we call exp with two complex arguments, apply-generic fails to find an
;; operation with the correct argument list, so tries to coerce t1->t2.