kayprish/sicp-solutions
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add exercises from subsection 2.5.2

Browse source
This commit is contained in:
Petar Kapriš 2025-11-13 19:27:18 +01:00
parent b326460d60
commit 9a7c305530
9 changed files with 2995 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

317
chapter-2/ex-2.77.scm Normal file
View file

@ -0,0 +1,317 @@
#lang sicp
;;;
;;;
;;; Setup for the exercise
;;;
;;;
(define (square x) (* x x))
; Dispatch table: list of rows, structure below:
; one row: (op-tag . (... one cell) (...) (...))
; one cell: ((list of type tags) . procedure)
; essentially, the whole table is an alist of alists
; (list of type tags) is a list of length n for n-ary op
; a unary op can be called with a symbol instead of a list of symbols for a type
; tag, but this will be converted to a length-1 list while searching the table
(define *dispatch-table* '())
;;;
;;; Dispatch table
;;;
; finds member in alist based on tag, which is the car of the row
(define (search-in-list tag list)
(if (null? list)
nil
(let* ((current-member (car list))
(member-tag (car current-member)))
(if (equal? member-tag tag)
current-member ; we don't strip the key when returning
(search-in-list tag (cdr list))))))
(define (get op-tag init-type-tags)
(let* ((type-tags (if (symbol? init-type-tags)
(list init-type-tags)
init-type-tags))
; wrap type-tags in a list if it's supplied as a symbol
(row-1 (search-in-list op-tag *dispatch-table*))
(row (if (null? row-1) nil (cdr row-1))) ; we strip the name of the row
(procedure-1 (search-in-list type-tags row))
(procedure (if (null? procedure-1) nil (cdr procedure-1))))
(if (null? procedure)
(error "Procedure not found in dispatch table:" op-tag type-tags)
procedure)))
(define (add-pair! alist tag value)
(set! alist (cons (cons tag value)
alist)))
(define (put op-tag init-type-tags procedure)
(let* ((type-tags (if (symbol? init-type-tags)
(list init-type-tags)
init-type-tags))
(search-row (search-in-list op-tag *dispatch-table*))
; here we don't strip the key from search-in-list
(row (if (null? search-row)
(begin (set! *dispatch-table* (cons (cons op-tag nil)
*dispatch-table*))
(car *dispatch-table*))
search-row))
(search-cell (search-in-list type-tags (cdr row))))
(if (null? search-cell)
(set-cdr! row (cons (cons type-tags procedure)
(cdr row)))
; attaching new pair to row
(set-cdr! search-cell procedure))))
;;;
;;; Auxillary functions for type tags
;;;
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(if (pair? datum)
(car datum)
(error "Bad tagged datum: TYPE-TAG" datum)))
(define (contents datum)
(if (pair? datum)
(cdr datum)
(error "Bad tagged datum: CONTENTS" datum)))
;;;
;;; Complex packages
;;;
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
;; interface to the rest of the system
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z) (* (magnitude z) (cos (angle z))))
(define (imag-part z) (* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
;; interface to the rest of the system
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(install-rectangular-package)
(install-polar-package)
;;;
;;; Apply generic and complex function definitions
;;;
(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 (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))
(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))
;;;
;;; Generic function definition
;;;
(define (add x y) (apply-generic 'add x y))
(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))
;;;
;;; Scheme number package
;;;
(define (install-scheme-number-package)
(define (tag x) (attach-tag 'scheme-number x))
(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 'make 'scheme-number (lambda (x) (tag x)))
'done)
(install-scheme-number-package)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
;;;
;;; Rational number package
;;;
(define (install-rational-package)
;; internal procedures
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(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))))
;; 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 '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 'make 'rational
(lambda (n d) (tag (make-rat n d))))
'done)
(install-rational-package)
(define (make-rational n d)
((get 'make 'rational) n d))
;;;
;;; Complex number package
;;;
(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))
;; internal procedures
(define (add-complex z1 z2)
(make-from-real-imag (+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
;; interface to rest of the system
(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))))
; Code added as fix in the exercise 2.77
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
; Code added as fix in the exercise
'done)
(install-complex-package)
(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))
;;;
;;;
;;; The actual exercise
;;;
;;;
; The explanation:
; When magnitude is invoked on the object '(complex rectangular 3 . 4), the call
; sequence will look roughly like so (represented in the substitution model:
; (magnitude '(complex rectangular 3 . 4))
; (apply-generic 'magnitude '(complex rectangular 3 . 4))
; (let ((type-tags (map type-tag args))) <- this will be '(complex)
; (let ((proc (get op type-tags))) <- this will return the exact same
; magnitude procedure again
; (if #<proc:magnitude> <- this will not be #f
; (apply #<proc:magnitude> (map contents '((complex rectangular 3 . 4))))
; (error "No method for these types: APPLY-GENERIC"
; (list op type-tags))))))
; (apply #<procedure:magnitude> (map contents '((complex rectangular 3 . 4))))
; (apply #<procedure:magnitude> '((rectangular 3 . 4)))
; (#<procedure:magnitude> '(rectangular 3 . 4))
; (apply-generic 'magnitude '(rectangular 3 . 4)) <- apply-generic expands again
; but we'll skip that
; (#<proc:magnitude-from-rectangular package> '(3 . 4))
; (sqrt (+ (square (real-part '(3 . 4)))
; (square (imag-part '(3 . 4)))))
; (sqrt (+ (square 3) (square 4)))
; 5
; In other words, the magnitude procedure, which calls apply-generic, will strip
; the outer tag 'complex, and then pass the stripped object back to itself
; (magnitude), which will, again, call apply-generic, which will then strip the
; second tag 'rectangular, and finally pass the object to magnitude and
; sub-procedures in the rectangular package. So apply-generic gets called twice.

288
chapter-2/ex-2.78.scm Normal file
View file

@ -0,0 +1,288 @@
#lang sicp
; Building on top of exercise 2.77
;;;
;;;
;;; Setup for the exercise
;;;
;;;
(define (square x) (* x x))
; Dispatch table: list of rows, structure below:
; one row: (op-tag . (... one cell) (...) (...))
; one cell: ((list of type tags) . procedure)
; essentially, the whole table is an alist of alists
; (list of type tags) is a list of length n for n-ary op
; a unary op can be called with a symbol instead of a list of symbols for a type
; tag, but this will be converted to a length-1 list while searching the table
(define *dispatch-table* '())
;;;
;;; Dispatch table
;;;
; finds member in alist based on tag, which is the car of the row
(define (search-in-list tag list)
(if (null? list)
nil
(let* ((current-member (car list))
(member-tag (car current-member)))
(if (equal? member-tag tag)
current-member ; we don't strip the key when returning
(search-in-list tag (cdr list))))))
(define (get op-tag init-type-tags)
(let* ((type-tags (if (symbol? init-type-tags)
(list init-type-tags)
init-type-tags))
; wrap type-tags in a list if it's supplied as a symbol
(row-1 (search-in-list op-tag *dispatch-table*))
(row (if (null? row-1) nil (cdr row-1))) ; we strip the name of the row
(procedure-1 (search-in-list type-tags row))
(procedure (if (null? procedure-1) nil (cdr procedure-1))))
(if (null? procedure)
(error "Procedure not found in dispatch table:" op-tag type-tags)
procedure)))
(define (add-pair! alist tag value)
(set! alist (cons (cons tag value)
alist)))
(define (put op-tag init-type-tags procedure)
(let* ((type-tags (if (symbol? init-type-tags)
(list init-type-tags)
init-type-tags))
(search-row (search-in-list op-tag *dispatch-table*))
; here we don't strip the key from search-in-list
(row (if (null? search-row)
(begin (set! *dispatch-table* (cons (cons op-tag nil)
*dispatch-table*))
(car *dispatch-table*))
search-row))
(search-cell (search-in-list type-tags (cdr row))))
(if (null? search-cell)
(set-cdr! row (cons (cons type-tags procedure)
(cdr row)))
; attaching new pair to row
(set-cdr! search-cell procedure))))
;;;
;;; Auxillary functions for type tags
;;;
; The actual exercise 2.78
(define (attach-tag type-tag contents)
(if (eq? type-tag 'scheme-number)
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((number? datum) 'scheme-number)
(error "Bad tagged datum: TYPE-TAG" datum)))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((number? datum) datum)
(error "Bad tagged datum: CONTENTS" datum)))
;;;
;;; Complex packages
;;;
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
;; interface to the rest of the system
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z) (* (magnitude z) (cos (angle z))))
(define (imag-part z) (* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
;; interface to the rest of the system
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(install-rectangular-package)
(install-polar-package)
;;;
;;; Apply generic and complex function definitions
;;;
(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 (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))
(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))
;;;
;;; Generic function definition
;;;
(define (add x y) (apply-generic 'add x y))
(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))
;;;
;;; Scheme number package
;;;
(define (install-scheme-number-package)
(define (tag x) (attach-tag 'scheme-number x))
(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 'make 'scheme-number (lambda (x) (tag x)))
'done)
(install-scheme-number-package)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
;;;
;;; Rational number package
;;;
(define (install-rational-package)
;; internal procedures
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(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))))
;; 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 '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 'make 'rational
(lambda (n d) (tag (make-rat n d))))
'done)
(install-rational-package)
(define (make-rational n d)
((get 'make 'rational) n d))
;;;
;;; Complex number package
;;;
(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))
;; internal procedures
(define (add-complex z1 z2)
(make-from-real-imag (+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
;; interface to rest of the system
(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))))
; Code added as fix in the exercise 2.77
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
; Code added as fix in the exercise
'done)
(install-complex-package)
(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))

312
chapter-2/ex-2.79.scm Normal file
View file

@ -0,0 +1,312 @@
#lang sicp
; Building on top of exercise 2.78
;;;
;;;
;;; Setup for the exercise
;;;
;;;
(define (square x) (* x x))
; Dispatch table: list of rows, structure below:
; one row: (op-tag . (... one cell) (...) (...))
; one cell: ((list of type tags) . procedure)
; essentially, the whole table is an alist of alists
; (list of type tags) is a list of length n for n-ary op
; a unary op can be called with a symbol instead of a list of symbols for a type
; tag, but this will be converted to a length-1 list while searching the table
(define *dispatch-table* '())
;;;
;;; Dispatch table
;;;
; finds member in alist based on tag, which is the car of the row
(define (search-in-list tag list)
(if (null? list)
nil
(let* ((current-member (car list))
(member-tag (car current-member)))
(if (equal? member-tag tag)
current-member ; we don't strip the key when returning
(search-in-list tag (cdr list))))))
(define (get op-tag init-type-tags)
(let* ((type-tags (if (symbol? init-type-tags)
(list init-type-tags)
init-type-tags))
; wrap type-tags in a list if it's supplied as a symbol
(row-1 (search-in-list op-tag *dispatch-table*))
(row (if (null? row-1) nil (cdr row-1))) ; we strip the name of the row
(procedure-1 (search-in-list type-tags row))
(procedure (if (null? procedure-1) nil (cdr procedure-1))))
(if (null? procedure)
(error "Procedure not found in dispatch table:" op-tag type-tags)
procedure)))
(define (add-pair! alist tag value)
(set! alist (cons (cons tag value)
alist)))
(define (put op-tag init-type-tags procedure)
(let* ((type-tags (if (symbol? init-type-tags)
(list init-type-tags)
init-type-tags))
(search-row (search-in-list op-tag *dispatch-table*))
; here we don't strip the key from search-in-list
(row (if (null? search-row)
(begin (set! *dispatch-table* (cons (cons op-tag nil)
*dispatch-table*))
(car *dispatch-table*))
search-row))
(search-cell (search-in-list type-tags (cdr row))))
(if (null? search-cell)
(set-cdr! row (cons (cons type-tags procedure)
(cdr row)))
; attaching new pair to row
(set-cdr! search-cell procedure))))
;;;
;;; Auxillary functions for type tags
;;;
; The actual exercise 2.78
(define (attach-tag type-tag contents)
(if (eq? type-tag 'scheme-number)
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((number? datum) 'scheme-number)
(error "Bad tagged datum: TYPE-TAG" datum)))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((number? datum) datum)
(error "Bad tagged datum: CONTENTS" datum)))
;;;
;;; Complex packages
;;;
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
;; interface to the rest of the system
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z) (* (magnitude z) (cos (angle z))))
(define (imag-part z) (* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
;; interface to the rest of the system
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(install-rectangular-package)
(install-polar-package)
;;;
;;; Apply generic and complex function definitions
;;;
(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 (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))
(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))
;;;
;;; Generic function definition
;;;
(define (add x y) (apply-generic 'add x y))
(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))
;;;
;;; Scheme number package
;;;
(define (install-scheme-number-package)
(define (tag x) (attach-tag 'scheme-number x))
(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 'make 'scheme-number (lambda (x) (tag x)))
; part of exercise 2.79
(put 'equ? '(scheme-number scheme-number) =)
'done)
(install-scheme-number-package)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
;;;
;;; Rational number package
;;;
(define (install-rational-package)
;; internal procedures
(define (numer x) (car x))
(define (denom x) (cdr x))
; Modified to make exercise 2.79 easier to implement
(define (make-rat n d)
(let ((g (gcd n d))
(sign-flip (if (< d 0) -1 1)))
(cons (/ n g sign-flip) (/ d g sign-flip))))
(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))))
;; 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 '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 'make 'rational
(lambda (n d) (tag (make-rat n d))))
; part of exercise 2.79
(put 'equ? '(rational rational)
(lambda (x y) (and (= (numer x) (numer y))
(= (denom x) (denom y)))))
'done)
(install-rational-package)
(define (make-rational n d)
((get 'make 'rational) n d))
;;;
;;; Complex number package
;;;
(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))
;; internal procedures
(define (add-complex z1 z2)
(make-from-real-imag (+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
;; interface to rest of the system
(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))))
; Code added as fix in the exercise 2.77
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
; Code added as fix in the exercise
; part of exercise 2.79
(put 'equ? '(complex complex)
(lambda (z1 z2) (and (= (real-part z1) (real-part z2))
(= (imag-part z1) (imag-part z2)))))
'done)
(install-complex-package)
(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))
;;;
;;;
;;; The actual exercise is dispersed through the packages, but clearly marked
;;;
;;;
; I believe that in this exercise, we are only expected to define equ? to
; compare numbers of the same type, not on different types, since this matter
; is more fully addressed in the following subsection of the book.
(define (equ? x y) (apply-generic 'equ? x y))

321
chapter-2/ex-2.80.scm Normal file
View file

@ -0,0 +1,321 @@
#lang sicp
; Building on top of exercise 2.79
;;;
;;;
;;; Setup for the exercise
;;;
;;;
(define (square x) (* x x))
; Dispatch table: list of rows, structure below:
; one row: (op-tag . (... one cell) (...) (...))
; one cell: ((list of type tags) . procedure)
; essentially, the whole table is an alist of alists
; (list of type tags) is a list of length n for n-ary op
; a unary op can be called with a symbol instead of a list of symbols for a type
; tag, but this will be converted to a length-1 list while searching the table
(define *dispatch-table* '())
;;;
;;; Dispatch table
;;;
; finds member in alist based on tag, which is the car of the row
(define (search-in-list tag list)
(if (null? list)
nil
(let* ((current-member (car list))
(member-tag (car current-member)))
(if (equal? member-tag tag)
current-member ; we don't strip the key when returning
(search-in-list tag (cdr list))))))
(define (get op-tag init-type-tags)
(let* ((type-tags (if (symbol? init-type-tags)
(list init-type-tags)
init-type-tags))
; wrap type-tags in a list if it's supplied as a symbol
(row-1 (search-in-list op-tag *dispatch-table*))
(row (if (null? row-1) nil (cdr row-1))) ; we strip the name of the row
(procedure-1 (search-in-list type-tags row))
(procedure (if (null? procedure-1) nil (cdr procedure-1))))
(if (null? procedure)
(error "Procedure not found in dispatch table:" op-tag type-tags)
procedure)))
(define (add-pair! alist tag value)
(set! alist (cons (cons tag value)
alist)))
(define (put op-tag init-type-tags procedure)
(let* ((type-tags (if (symbol? init-type-tags)
(list init-type-tags)
init-type-tags))
(search-row (search-in-list op-tag *dispatch-table*))
; here we don't strip the key from search-in-list
(row (if (null? search-row)
(begin (set! *dispatch-table* (cons (cons op-tag nil)
*dispatch-table*))
(car *dispatch-table*))
search-row))
(search-cell (search-in-list type-tags (cdr row))))
(if (null? search-cell)
(set-cdr! row (cons (cons type-tags procedure)
(cdr row)))
; attaching new pair to row
(set-cdr! search-cell procedure))))
;;;
;;; Auxillary functions for type tags
;;;
; The actual exercise 2.78
(define (attach-tag type-tag contents)
(if (eq? type-tag 'scheme-number)
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((number? datum) 'scheme-number)
(error "Bad tagged datum: TYPE-TAG" datum)))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((number? datum) datum)
(error "Bad tagged datum: CONTENTS" datum)))
;;;
;;; Complex packages
;;;
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
;; interface to the rest of the system
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z) (* (magnitude z) (cos (angle z))))
(define (imag-part z) (* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
;; interface to the rest of the system
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(install-rectangular-package)
(install-polar-package)
;;;
;;; Apply generic and complex function definitions
;;;
(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 (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))
(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))
;;;
;;; Generic function definition
;;;
(define (add x y) (apply-generic 'add x y))
(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))
;;;
;;; Scheme number package
;;;
(define (install-scheme-number-package)
(define (tag x) (attach-tag 'scheme-number x))
(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 'make 'scheme-number (lambda (x) (tag x)))
; part of exercise 2.79
(put 'equ? '(scheme-number scheme-number) =)
; part of exercise 2.80
(put '=zero? '(scheme-number) (lambda (x) (zero? x)))
'done)
(install-scheme-number-package)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
;;;
;;; Rational number package
;;;
(define (install-rational-package)
;; internal procedures
(define (numer x) (car x))
(define (denom x) (cdr x))
; Modified to make exercise 2.79 easier to implement
(define (make-rat n d)
(let ((g (gcd n d))
(sign-flip (if (< d 0) -1 1)))
(cons (/ n g sign-flip) (/ d g sign-flip))))
(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))))
;; 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 '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 'make 'rational
(lambda (n d) (tag (make-rat n d))))
; part of exercise 2.79
(put 'equ? '(rational rational)
(lambda (x y) (and (= (numer x) (numer y))
(= (denom x) (denom y)))))
; part of exercise 2.80
(put '=zero? '(rational)
(lambda (x) (= (numer x) 0)))
'done)
(install-rational-package)
(define (make-rational n d)
((get 'make 'rational) n d))
;;;
;;; Complex number package
;;;
(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))
;; internal procedures
(define (add-complex z1 z2)
(make-from-real-imag (+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
;; interface to rest of the system
(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))))
; Code added as fix in the exercise 2.77
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
; Code added as fix in the exercise
; part of exercise 2.79
(put 'equ? '(complex complex)
(lambda (z1 z2) (and (= (real-part z1) (real-part z2))
(= (imag-part z1) (imag-part z2)))))
; part of exercise 2.80
(put '=zero? '(complex)
(lambda (z) (= (magnitude z) 0)))
'done)
(install-complex-package)
(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))
;;;
;;;
;;; The actual exercise is dispersed through the packages, but clearly marked
;;;
;;;
; I believe that in this exercise, we are only expected to define equ? to
; compare numbers of the same type, not on different types, since this matter
; is more fully addressed in the following subsection of the book.
(define (equ? x y) (apply-generic 'equ? x y))
(define (=zero? x) (apply-generic '=zero? x))

51
chapter-2/ex-2.81.txt Normal file
View file

@ -0,0 +1,51 @@
a) This is not going to work, it will simply coerce one of the complex numbers
into a complex number, then call the 'exp procedure generically for two
complex numbers, and will then loop infinitely.
b) He is mostly wrong, the apply-generic procedure will error out if the types
are the same and there is no procedure for them. But this is what we'd expect.
It just means there is no procedure for these types.
Maybe this is what we want, but we may actually want the type of both to be
raised when we attempt this procedure.
That being said, the example presented:
```
(define (exp x y) (apply-generic 'exp x y))
;; following added to Scheme-number package
(put 'exp '(scheme-number scheme-number)
(lambda (x y) (tag (expt x y))))
; using primitive expt
(exp complex1 complex2)
```
would not work, *even* if we did that, because complex numbers are supertypes
of scheme numbers, and couldn't be simplified.
c) Okay, but it's just going to error out in the exact same way, just in a
different place.
```
(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)))
(if (eq? type1 type2)
(error "No method for these types"
(list op type-tags))
(let ((t1->t2 (get-coercion type1 type2))
(t2->t1 (get-coercion type2 type1)))
(cond (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)))))))
```

414
chapter-2/ex-2.82.scm Normal file
View file

@ -0,0 +1,414 @@
#lang sicp
; Building on top of exercise 2.80
;
; a) First part is the program where apply-generic is generalized
; b) The second part of the exercise is the example of a situation where the
; approach is not general enough. This will be outlined in the bottom of the
; file.
;
;;;
;;;
;;; Setup for the exercise
;;;
;;;
(define (square x) (* x x))
; Dispatch table: list of rows, structure below:
; one row: (op-tag . (... one cell) (...) (...))
; one cell: ((list of type tags) . procedure)
; essentially, the whole table is an alist of alists
; (list of type tags) is a list of length n for n-ary op
; a unary op can be called with a symbol instead of a list of symbols for a type
; tag, but this will be converted to a length-1 list while searching the table
(define *dispatch-table* '())
(define *coercion-table* '())
;;;
;;; Dispatch table
;;;
; finds member in alist based on tag, which is the car of the row
(define (search-in-list tag list)
(if (null? list)
nil
(let* ((current-member (car list))
(member-tag (car current-member)))
(if (equal? member-tag tag)
current-member ; we don't strip the key when returning
(search-in-list tag (cdr list))))))
(define (get op-tag init-type-tags)
(let* ((type-tags (if (symbol? init-type-tags)
(list init-type-tags)
init-type-tags))
; wrap type-tags in a list if it's supplied as a symbol
(row-1 (search-in-list op-tag *dispatch-table*))
(row (if (null? row-1) nil (cdr row-1))) ; we strip the name of the row
(procedure-1 (search-in-list type-tags row))
(procedure (if (null? procedure-1) nil (cdr procedure-1))))
(if (null? procedure)
#f
procedure)))
(define (add-pair! alist tag value)
(set! alist (cons (cons tag value)
alist)))
(define (put op-tag init-type-tags procedure)
(let* ((type-tags (if (symbol? init-type-tags)
(list init-type-tags)
init-type-tags))
(search-row (search-in-list op-tag *dispatch-table*))
; here we don't strip the key from search-in-list
(row (if (null? search-row)
(begin (set! *dispatch-table* (cons (cons op-tag nil)
*dispatch-table*))
(car *dispatch-table*))
search-row))
(search-cell (search-in-list type-tags (cdr row))))
(if (null? search-cell)
(set-cdr! row (cons (cons type-tags procedure)
(cdr row)))
; attaching new pair to row
(set-cdr! search-cell procedure))))
;;;
;;; Auxillary functions for type tags
;;;
; The actual exercise 2.78
(define (attach-tag type-tag contents)
(if (eq? type-tag 'scheme-number)
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((number? datum) 'scheme-number)
(error "Bad tagged datum: TYPE-TAG" datum)))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((number? datum) datum)
(error "Bad tagged datum: CONTENTS" datum)))
;;;
;;; Complex packages
;;;
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
;; interface to the rest of the system
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z) (* (magnitude z) (cos (angle z))))
(define (imag-part z) (* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
;; interface to the rest of the system
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(install-rectangular-package)
(install-polar-package)
;;;
;;; Apply generic and complex function definitions (modified for exercise 2.82)
;;;
; Check if all members in a list are not #f
(define (all list)
(cond ((null? list) #t)
((car list) (all (cdr list)))
(else #f)))
(define (try-coercion t1 t2)
(if (eq? t1 t2)
(lambda (x) x)
(get-coercion t1 t2)))
; Generate list of lists, where every i-th member is a list of conversions of
; all other types into the i-th type
(define (generate-coercion-attempts type-tags)
(map (lambda (to)
; list of coercions
(map (lambda (from)
(try-coercion from to))
type-tags))
type-tags))
(define (filter p list)
(cond ((null? list) nil)
((p (car list)) (cons (car list)
(filter p (cdr list))))
(else (filter p (cdr list)))))
(define (get-op-for-any-coercion-attempt op args coercion-attempts)
(if (null? coercion-attempts)
(error "No method for these types"
(list op (map type-tag args)))
(let* ((current-attempt (car coercion-attempts))
(new-args (map (lambda (arg coercion)
(coercion arg))
args current-attempt))
(new-type-tags (map type-tag new-args))
(new-contents (map contents new-args))
(proc (get op new-type-tags)))
(if proc
(apply proc new-contents)
(get-op-for-any-coercion-attempt op args
(cdr coercion-attempts))))))
(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))
(let* ((coercion-attempts (generate-coercion-attempts type-tags))
(filtered-attempts (filter all coercion-attempts)))
; only try those coercion lists where only procedures are
; returned, without a single #f
(get-op-for-any-coercion-attempt op args filtered-attempts))))))
(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))
(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))
;;;
;;; Generic function definition
;;;
(define (add x y) (apply-generic 'add x y))
(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))
;;;
;;; Scheme number package
;;;
(define (install-scheme-number-package)
(define (tag x) (attach-tag 'scheme-number x))
(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 'make 'scheme-number (lambda (x) (tag x)))
; part of exercise 2.79
(put 'equ? '(scheme-number scheme-number) =)
; part of exercise 2.80
(put '=zero? '(scheme-number) (lambda (x) (zero? x)))
'done)
(install-scheme-number-package)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
;;;
;;; Rational number package
;;;
(define (install-rational-package)
;; internal procedures
(define (numer x) (car x))
(define (denom x) (cdr x))
; Modified to make exercise 2.79 easier to implement
(define (make-rat n d)
(let ((g (gcd n d))
(sign-flip (if (< d 0) -1 1)))
(cons (/ n g sign-flip) (/ d g sign-flip))))
(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))))
;; 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 '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 'make 'rational
(lambda (n d) (tag (make-rat n d))))
; part of exercise 2.79
(put 'equ? '(rational rational)
(lambda (x y) (and (= (numer x) (numer y))
(= (denom x) (denom y)))))
; part of exercise 2.80
(put '=zero? '(rational)
(lambda (x) (= (numer x) 0)))
'done)
(install-rational-package)
(define (make-rational n d)
((get 'make 'rational) n d))
;;;
;;; Complex number package
;;;
(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))
;; internal procedures
(define (add-complex z1 z2)
(make-from-real-imag (+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
;; interface to rest of the system
(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))))
; Code added as fix in the exercise 2.77
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
; Code added as fix in the exercise
; part of exercise 2.79
(put 'equ? '(complex complex)
(lambda (z1 z2) (and (= (real-part z1) (real-part z2))
(= (imag-part z1) (imag-part z2)))))
; part of exercise 2.80
(put '=zero? '(complex)
(lambda (z) (= (magnitude z) 0)))
'done)
(install-complex-package)
(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))
;;;
;;; Type coercion functions (added in exercise 2.82)
;;;
(define (get-coercion t1 t2)
(let* ((row-1 (search-in-list t1 *coercion-table*))
(row (if (null? row-1) nil (cdr row-1))) ; we strip the name of the row
(procedure-1 (search-in-list t2 row))
(procedure (if (null? procedure-1) nil (cdr procedure-1))))
(if (null? procedure)
#f
procedure)))
(define (put-coercion t1 t2 procedure)
(let* ((search-row (search-in-list t1 *coercion-table*))
; here we don't strip the key from search-in-list
(row (if (null? search-row)
(begin (set! *coercion-table* (cons (cons t1 nil)
*coercion-table*))
(car *coercion-table*))
search-row))
(search-cell (search-in-list t2 (cdr row))))
(if (null? search-cell)
(set-cdr! row (cons (cons t2 procedure)
(cdr row)))
; attaching new pair to row
(set-cdr! search-cell procedure))))
(put-coercion 'scheme-number 'rational ; assuming integer
(lambda (x) (make-rational x 1)))
(put-coercion 'scheme-number 'complex
(lambda (x) (make-complex-from-real-imag x 0)))
(put-coercion 'rational 'complex ; assuming integer
(lambda (x)
(make-complex-from-real-imag (exact->inexact (/ (cadr x)
(caddr x)))
0)))
; I'm not going to be very careful and modular about this code, because this
; exercise is based on a leaky idea of the type hierarchy anyways
; (scheme-numbers can already be real, which is a superset of the rationals,
; this approach will have to be fixed in the following exercises anyways
; As for the flaws of the approach given in apply-generic, there are plenty of
; examples as to how the approach could fail. For example imagine the op:
; (exp 'complex 'rational)
; now, imagine we apply it to a 'complex and a 'scheme-number
; if we had a more general strategy the scheme-number would be converted to a
; 'rational, and the operation would succeed, but the current version will only
; try (exp 'complex 'complex), and will then fail.

373
chapter-2/ex-2.83-84.scm Normal file
View file

@ -0,0 +1,373 @@
#lang sicp
; Building on top of exercise 2.82
; With lots of changes, from here on, I'm splitting the scheme-number type into
; two separate types, integer and real. Both will be marked with a preceding
; symbol.
; We will assume that the scheme-internal "rational?" type *will not be used at
; all*
;;;
;;;
;;; Setup for the exercise
;;;
;;;
(define (square x) (* x x))
; Dispatch table: list of rows, structure below:
; one row: (op-tag . (... one cell) (...) (...))
; one cell: ((list of type tags) . procedure)
; essentially, the whole table is an alist of alists
; (list of type tags) is a list of length n for n-ary op
; a unary op can be called with a symbol instead of a list of symbols for a type
; tag, but this will be converted to a length-1 list while searching the table
(define *dispatch-table* '())
;;;
;;; Dispatch table
;;;
; finds member in alist based on tag, which is the car of the row
(define (search-in-list tag list)
(if (null? list)
nil
(let* ((current-member (car list))
(member-tag (car current-member)))
(if (equal? member-tag tag)
current-member ; we don't strip the key when returning
(search-in-list tag (cdr list))))))
(define (get op-tag init-type-tags)
(let* ((type-tags (if (symbol? init-type-tags)
(list init-type-tags)
init-type-tags))
; wrap type-tags in a list if it's supplied as a symbol
(row-1 (search-in-list op-tag *dispatch-table*))
(row (if (null? row-1) nil (cdr row-1))) ; we strip the name of the row
(procedure-1 (search-in-list type-tags row))
(procedure (if (null? procedure-1) nil (cdr procedure-1))))
(if (null? procedure)
#f
procedure)))
(define (add-pair! alist tag value)
(set! alist (cons (cons tag value)
alist)))
(define (put op-tag init-type-tags procedure)
(let* ((type-tags (if (symbol? init-type-tags)
(list init-type-tags)
init-type-tags))
(search-row (search-in-list op-tag *dispatch-table*))
; here we don't strip the key from search-in-list
(row (if (null? search-row)
(begin (set! *dispatch-table* (cons (cons op-tag nil)
*dispatch-table*))
(car *dispatch-table*))
search-row))
(search-cell (search-in-list type-tags (cdr row))))
(if (null? search-cell)
(set-cdr! row (cons (cons type-tags procedure)
(cdr row)))
; attaching new pair to row
(set-cdr! search-cell procedure))))
;;;
;;; Auxillary functions for type tags
;;;
; The actual exercise 2.78
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(if (pair? datum)
(car datum)
(error "Bad tagged datum: TYPE-TAG" datum)))
(define (contents datum)
(if (pair? datum)
(cdr datum)
(error "Bad tagged datum: CONTENTS" datum)))
;;;
;;; Complex packages
;;;
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
;; interface to the rest of the system
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z) (* (magnitude z) (cos (angle z))))
(define (imag-part z) (* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
;; interface to the rest of the system
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(install-rectangular-package)
(install-polar-package)
;;;
;;; Apply generic and complex function definitions (modified for exercise 2.82)
;;;
(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)))
(cond ((supertype type1 type2)
(apply-generic op a1 (raise a2)))
((supertype type2 type1)
(apply-generic op (raise a1) a2))
(else (error "No method for these types"
(list op type-tags)))))
(error "No method for these types"
(list op type-tags)))))))
(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))
(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))
;;;
;;; Generic function definition
;;;
(define (add x y) (apply-generic 'add x y))
(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))
;;;
;;; Scheme number package
;;;
; we turn this into two packages, since most of the code is identical, we will
; turn the old function into a template, and then use it with some addendums
(define (install-scheme-number-package-template subtype-tag)
(define (tag x) (attach-tag subtype-tag x))
(put 'add (list subtype-tag subtype-tag)
(lambda (x y) (tag (+ x y))))
(put 'sub (list subtype-tag subtype-tag)
(lambda (x y) (tag (- x y))))
(put 'mul (list subtype-tag subtype-tag)
(lambda (x y) (tag (* x y))))
(put 'div (list subtype-tag subtype-tag)
(lambda (x y) (tag (/ x y))))
; part of exercise 2.79
(put 'equ? (list subtype-tag subtype-tag) =)
; part of exercise 2.80
(put '=zero? (list subtype-tag) (lambda (x) (zero? x)))
'done)
(define (install-integer-package)
(install-scheme-number-package-template 'integer)
(put 'make 'integer (lambda (x)
(attach-tag 'integer (inexact->exact (round x))))))
; if a user gives a float or fraction to make-integer, we will simply round it
(define (install-real-package)
(install-scheme-number-package-template 'real)
(put 'make 'real (lambda (x)
(attach-tag 'real (exact->inexact x)))))
; if a user gives a scheme rational or integer to make a real, we will convert
; it
(install-integer-package)
(install-real-package)
(define (make-integer n)
((get 'make 'integer) n))
(define (make-real n)
((get 'make 'real) n))
;;;
;;; Rational number package
;;;
(define (install-rational-package)
;; internal procedures
(define (numer x) (car x))
(define (denom x) (cdr x))
; Modified to make exercise 2.79 easier to implement
(define (make-rat n d)
(let ((g (gcd n d))
(sign-flip (if (< d 0) -1 1)))
(cons (/ n g sign-flip) (/ d g sign-flip))))
(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))))
;; 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 '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 'make 'rational
(lambda (n d) (tag (make-rat n d))))
(put 'numer 'rational numer)
(put 'denom 'rational denom)
; part of exercise 2.79
(put 'equ? '(rational rational)
(lambda (x y) (and (= (numer x) (numer y))
(= (denom x) (denom y)))))
; part of exercise 2.80
(put '=zero? '(rational)
(lambda (x) (= (numer x) 0)))
'done)
(install-rational-package)
(define (make-rational n d)
((get 'make 'rational) n d))
(define (numer x)
((get 'numer 'rational) x))
(define (denom x)
((get 'denom 'rational) x))
;;;
;;; Complex number package
;;;
(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))
;; internal procedures
(define (add-complex z1 z2)
(make-from-real-imag (+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
;; interface to rest of the system
(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))))
; Code added as fix in the exercise 2.77
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
; Code added as fix in the exercise
; part of exercise 2.79
(put 'equ? '(complex complex)
(lambda (z1 z2) (and (= (real-part z1) (real-part z2))
(= (imag-part z1) (imag-part z2)))))
; part of exercise 2.80
(put '=zero? '(complex)
(lambda (z) (= (magnitude z) 0)))
'done)
(install-complex-package)
(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))
;;;
;;; Raise package
;;;
(define (install-raise-package)
(define (integer->rational n)
(make-rational n 1))
(define (rational->real x)
(make-real (exact->inexact (/ (numer x) (denom x)))))
(define (real->complex x)
(make-complex-from-real-imag x 0))
(put 'raise 'integer integer->rational)
(put 'raise 'rational rational->real)
(put 'raise 'real real->complex))
(install-raise-package)
(define (raise x) (apply-generic 'raise x))
(define (subtype t1 t2)
(let* ((type-hier '(integer rational real complex))
(t1-supertypes (cdr (memq t1 type-hier))))
(not (eq? #f (memq t2 t1-supertypes)))))
(define (supertype t1 t2)
(subtype t2 t1))

422
chapter-2/ex-2.85.scm Normal file
View file

@ -0,0 +1,422 @@
#lang sicp
; Building on top of exercise 2.83-84
; With lots of changes, from here on, I'm splitting the scheme-number type into
; two separate types, integer and real. Both will be marked with a preceding
; symbol.
; We will assume that the scheme-internal "rational?" type *will not be used at
; all*
;;;
;;;
;;; Setup for the exercise
;;;
;;;
(define (square x) (* x x))
; Dispatch table: list of rows, structure below:
; one row: (op-tag . (... one cell) (...) (...))
; one cell: ((list of type tags) . procedure)
; essentially, the whole table is an alist of alists
; (list of type tags) is a list of length n for n-ary op
; a unary op can be called with a symbol instead of a list of symbols for a type
; tag, but this will be converted to a length-1 list while searching the table
(define *dispatch-table* '())
;;;
;;; Dispatch table
;;;
; finds member in alist based on tag, which is the car of the row
(define (search-in-list tag list)
(if (null? list)
nil
(let* ((current-member (car list))
(member-tag (car current-member)))
(if (equal? member-tag tag)
current-member ; we don't strip the key when returning
(search-in-list tag (cdr list))))))
(define (get op-tag init-type-tags)
(let* ((type-tags (if (symbol? init-type-tags)
(list init-type-tags)
init-type-tags))
; wrap type-tags in a list if it's supplied as a symbol
(row-1 (search-in-list op-tag *dispatch-table*))
(row (if (null? row-1) nil (cdr row-1))) ; we strip the name of the row
(procedure-1 (search-in-list type-tags row))
(procedure (if (null? procedure-1) nil (cdr procedure-1))))
(if (null? procedure)
#f
procedure)))
(define (add-pair! alist tag value)
(set! alist (cons (cons tag value)
alist)))
(define (put op-tag init-type-tags procedure)
(let* ((type-tags (if (symbol? init-type-tags)
(list init-type-tags)
init-type-tags))
(search-row (search-in-list op-tag *dispatch-table*))
; here we don't strip the key from search-in-list
(row (if (null? search-row)
(begin (set! *dispatch-table* (cons (cons op-tag nil)
*dispatch-table*))
(car *dispatch-table*))
search-row))
(search-cell (search-in-list type-tags (cdr row))))
(if (null? search-cell)
(set-cdr! row (cons (cons type-tags procedure)
(cdr row)))
; attaching new pair to row
(set-cdr! search-cell procedure))))
;;;
;;; Auxillary functions for type tags
;;;
; The actual exercise 2.78
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(if (pair? datum)
(car datum)
(error "Bad tagged datum: TYPE-TAG" datum)))
(define (contents datum)
(if (pair? datum)
(cdr datum)
(error "Bad tagged datum: CONTENTS" datum)))
;;;
;;; Complex packages
;;;
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
;; interface to the rest of the system
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z) (* (magnitude z) (cos (angle z))))
(define (imag-part z) (* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
;; interface to the rest of the system
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(install-rectangular-package)
(install-polar-package)
;;;
;;; Apply generic and complex function definitions
;;;
(define (apply-generic op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(let ((result
(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)))
(cond ((supertype type1 type2)
(apply-generic op a1 (raise a2)))
((supertype type2 type1)
(apply-generic op (raise a1) a2))
(else (error "No method for these types"
(list op type-tags)))))
(error "No method for these types"
(list op type-tags))))))
(if (and (pair? result)
(memq (type-tag result) '(integer rational real complex))
; remember, apply-generic can return objects which are not in our
; type system at all, so we have to check for that before we drop
; the result
(not (memq op '(raise project))))
; also, we don't want a call to project or raise to call drop, which
; calls them both
(drop result)
result)))))
(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))
(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))
;;;
;;; Generic function definition
;;;
(define (add x y) (apply-generic 'add x y))
(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))
;;;
;;; Scheme number package
;;;
; we turn this into two packages, since most of the code is identical, we will
; turn the old function into a template, and then use it with some addendums
(define (install-scheme-number-package-template subtype-tag)
(define (tag x) (attach-tag subtype-tag x))
(put 'add (list subtype-tag subtype-tag)
(lambda (x y) (tag (+ x y))))
(put 'sub (list subtype-tag subtype-tag)
(lambda (x y) (tag (- x y))))
(put 'mul (list subtype-tag subtype-tag)
(lambda (x y) (tag (* x y))))
(put 'div (list subtype-tag subtype-tag)
(lambda (x y) (tag (/ x y))))
; part of exercise 2.79
(put 'equ? (list subtype-tag subtype-tag) =)
; part of exercise 2.80
(put '=zero? (list subtype-tag) (lambda (x) (zero? x)))
'done)
(define (install-integer-package)
(install-scheme-number-package-template 'integer)
(put 'make 'integer (lambda (x)
(attach-tag 'integer (inexact->exact (round x))))))
; if a user gives a float or fraction to make-integer, we will simply round it
(define (install-real-package)
(install-scheme-number-package-template 'real)
(put 'make 'real (lambda (x)
(attach-tag 'real (exact->inexact x)))))
; if a user gives a scheme rational or integer to make a real, we will convert
; it
(install-integer-package)
(install-real-package)
(define (make-integer n)
((get 'make 'integer) n))
(define (make-real n)
((get 'make 'real) n))
;;;
;;; Rational number package
;;;
(define (install-rational-package)
;; internal procedures
(define (numer x) (car x))
(define (denom x) (cdr x))
; Modified to make exercise 2.79 easier to implement
(define (make-rat n d)
(let ((g (gcd n d))
(sign-flip (if (< d 0) -1 1)))
(cons (/ n g sign-flip) (/ d g sign-flip))))
(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))))
;; 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 '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 'make 'rational
(lambda (n d) (tag (make-rat n d))))
(put 'numer 'rational numer)
(put 'denom 'rational denom)
; part of exercise 2.79
(put 'equ? '(rational rational)
(lambda (x y) (and (= (numer x) (numer y))
(= (denom x) (denom y)))))
; part of exercise 2.80
(put '=zero? '(rational)
(lambda (x) (= (numer x) 0)))
'done)
(install-rational-package)
(define (make-rational n d)
((get 'make 'rational) n d))
(define (numer x) (apply-generic 'numer x))
(define (denom x) (apply-generic 'denom x))
;;;
;;; Complex number package
;;;
(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))
;; internal procedures
(define (add-complex z1 z2)
(make-from-real-imag (+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
;; interface to rest of the system
(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))))
; Code added as fix in the exercise 2.77
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
; Code added as fix in the exercise
; part of exercise 2.79
(put 'equ? '(complex complex)
(lambda (z1 z2) (and (= (real-part z1) (real-part z2))
(= (imag-part z1) (imag-part z2)))))
; part of exercise 2.80
(put '=zero? '(complex)
(lambda (z) (= (magnitude z) 0)))
'done)
(install-complex-package)
(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))
;;;
;;; Raise package
;;;
(define (install-raise-package)
(define (integer->rational n)
(make-rational n 1))
(define (rational->real x)
(define tagged-x (attach-tag 'rational x))
(make-real (exact->inexact (/ (numer tagged-x)
(denom tagged-x)))))
(define (real->complex x)
(make-complex-from-real-imag x 0))
(put 'raise 'integer integer->rational)
(put 'raise 'rational rational->real)
(put 'raise 'real real->complex)
; added in exercise 2.85
(define (complex->real z)
(make-real (real-part z)))
; we will drop the real directly to integer, not to rational
; we could use inexact->exact to convert it to a rational, but this would be
; worse, since rationals are made up of bigints, there will always be a
; fraction close enough to be equ?. We will only simplify when the real is
; actually an integer.
; In principle, we could drop it to rational and check if the numerator and
; deominator are "small enough", but
; 1) this is beyond the scope of the exercise
; 2) even numbers as simple as 0.333..., would fail to be simplified this way
(define (real->integer x)
(make-integer x)) ; we get to use the builtin rounding we added, ha!
(define (rational->integer x)
(define tagged-x (attach-tag 'rational x))
(make-integer (/ (numer tagged-x) (denom tagged-x))))
(put 'project 'complex complex->real)
(put 'project 'real real->integer)
(put 'project 'rational rational->integer))
(install-raise-package)
(define (raise x) (apply-generic 'raise x))
(define (drop x)
(if (eq? (type-tag x) 'integer)
x
(let ((dropped-x (apply-generic 'project x)))
(let ((re-raised-x (if (eq? (type-tag x) 'real)
; we do this because we project real->integer,
; skipping the rationals
(raise (raise dropped-x))
(raise dropped-x))))
(if (equ? re-raised-x x)
(drop dropped-x)
x)))))
(define (subtype t1 t2)
(let* ((type-hier '(integer rational real complex))
(t1-supertypes (cdr (memq t1 type-hier))))
(not (eq? #f (memq t2 t1-supertypes)))))
(define (supertype t1 t2)
(subtype t2 t1))

497
chapter-2/ex-2.86.scm Normal file
View file

@ -0,0 +1,497 @@
#lang sicp
; Building on top of exercise 2.83-84
; With lots of changes, from here on, I'm splitting the scheme-number type into
; two separate types, integer and real. Both will be marked with a preceding
; symbol.
; We will assume that the scheme-internal "rational?" type *will not be used at
; all*
;;;
;;;
;;; Setup for the exercise
;;;
;;;
(define (square x) (mul x x))
; Dispatch table: list of rows, structure below:
; one row: (op-tag . (... one cell) (...) (...))
; one cell: ((list of type tags) . procedure)
; essentially, the whole table is an alist of alists
; (list of type tags) is a list of length n for n-ary op
; a unary op can be called with a symbol instead of a list of symbols for a type
; tag, but this will be converted to a length-1 list while searching the table
(define *dispatch-table* '())
;;;
;;; Dispatch table
;;;
; finds member in alist based on tag, which is the car of the row
(define (search-in-list tag list)
(if (null? list)
nil
(let* ((current-member (car list))
(member-tag (car current-member)))
(if (equal? member-tag tag)
current-member ; we don't strip the key when returning
(search-in-list tag (cdr list))))))
(define (get op-tag init-type-tags)
(let* ((type-tags (if (symbol? init-type-tags)
(list init-type-tags)
init-type-tags))
; wrap type-tags in a list if it's supplied as a symbol
(row-1 (search-in-list op-tag *dispatch-table*))
(row (if (null? row-1) nil (cdr row-1))) ; we strip the name of the row
(procedure-1 (search-in-list type-tags row))
(procedure (if (null? procedure-1) nil (cdr procedure-1))))
(if (null? procedure)
#f
procedure)))
(define (add-pair! alist tag value)
(set! alist (cons (cons tag value)
alist)))
(define (put op-tag init-type-tags procedure)
(let* ((type-tags (if (symbol? init-type-tags)
(list init-type-tags)
init-type-tags))
(search-row (search-in-list op-tag *dispatch-table*))
; here we don't strip the key from search-in-list
(row (if (null? search-row)
(begin (set! *dispatch-table* (cons (cons op-tag nil)
*dispatch-table*))
(car *dispatch-table*))
search-row))
(search-cell (search-in-list type-tags (cdr row))))
(if (null? search-cell)
(set-cdr! row (cons (cons type-tags procedure)
(cdr row)))
; attaching new pair to row
(set-cdr! search-cell procedure))))
;;;
;;; Auxillary functions for type tags
;;;
; The actual exercise 2.78
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(if (pair? datum)
(car datum)
(error "Bad tagged datum: TYPE-TAG" datum)))
(define (contents datum)
(if (pair? datum)
(cdr datum)
(error "Bad tagged datum: CONTENTS" datum)))
;;;
;;; Complex packages
;;;
(define (prohibit-complex-number x func-name)
(if (and (pair? x)
(memq (type-tag x) '(complex rectangular polar)))
(error "Complex arguments prohibited in constructor: " func-name x)))
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y)
(prohibit-complex-number x)
(prohibit-complex-number y)
(cons (tag-scheme-number x)
(tag-scheme-number y)))
(define (magnitude z)
(square-root (add (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(arctangent (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(prohibit-complex-number r)
(prohibit-complex-number a)
(cons (mul r (cosine a)) (mul r (sine a))))
;; interface to the rest of the system
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a)
(prohibit-complex-number r)
(prohibit-complex-number a)
(cons r a))
(define (real-part z) (* (magnitude z) (cos (angle z))))
(define (imag-part z) (* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(prohibit-complex-number x)
(prohibit-complex-number y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
;; interface to the rest of the system
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(install-rectangular-package)
(install-polar-package)
;;;
;;; Apply generic and complex function definitions
;;;
(define (apply-generic op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(let ((result
(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)))
(cond ((supertype type1 type2)
(apply-generic op a1 (raise a2)))
((supertype type2 type1)
(apply-generic op (raise a1) a2))
(else (error "No method for these types"
(list op type-tags)))))
(error "No method for these types"
(list op type-tags))))))
(if (and (pair? result)
(memq (type-tag result) '(integer rational real complex))
; remember, apply-generic can return objects which are not in our
; type system at all, so we have to check for that before we drop
; the result
(not (memq op '(raise project))))
; also, we don't want a call to project or raise to call drop, which
; calls them both
(drop result)
result)))))
(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))
(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))
;;;
;;; Generic function definition
;;;
(define (add x y) (apply-generic 'add x y))
(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 (square-root x) (apply-generic 'square-root x))
(define (arctangent x) (apply-generic 'arctangent x))
(define (cosine x) (apply-generic 'sine x))
(define (sine x) (apply-generic 'cosine x))
;;;
;;; Scheme number package
;;;
; we turn this into two packages, since most of the code is identical, we will
; turn the old function into a template, and then use it with some addendums
(define (install-scheme-number-package-template subtype-tag)
(define (tag x) (attach-tag subtype-tag x))
(put 'add (list subtype-tag subtype-tag)
(lambda (x y) (tag (+ x y))))
(put 'sub (list subtype-tag subtype-tag)
(lambda (x y) (tag (- x y))))
(put 'mul (list subtype-tag subtype-tag)
(lambda (x y) (tag (* x y))))
(put 'div (list subtype-tag subtype-tag)
(lambda (x y) (tag (/ x y))))
; part of exercise 2.79
(put 'equ? (list subtype-tag subtype-tag) =)
; part of exercise 2.80
(put '=zero? (list subtype-tag) (lambda (x) (zero? x)))
(put 'sine subtype-tag
(lambda (x) (tag (sin x))))
(put 'cosine subtype-tag
(lambda (x) (tag (sin x))))
(put 'arctangent subtype-tag
(lambda (x) (tag (atan x))))
(put 'arctangent (list subtype-tag subtype-tag)
(lambda (x y) (tag (atan x y))))
(put 'square-root subtype-tag
(lambda (x) (tag (sqrt x))))
'done)
(define (install-integer-package)
(install-scheme-number-package-template 'integer)
(put 'make 'integer (lambda (x)
(attach-tag 'integer (inexact->exact (round x))))))
; if a user gives a float or fraction to make-integer, we will simply round it
(define (install-real-package)
(install-scheme-number-package-template 'real)
(put 'make 'real (lambda (x)
(attach-tag 'real (exact->inexact x)))))
; if a user gives a scheme rational or integer to make a real, we will convert
; it
(define (tag-scheme-number x)
(cond ((integer? x) (cons 'integer x))
((real? x) (cons 'real x))
(else x)))
; sometimes we want
(install-integer-package)
(install-real-package)
(define (make-integer n)
((get 'make 'integer) n))
(define (make-real n)
((get 'make 'real) n))
;;;
;;; Rational number package
;;;
(define (install-rational-package)
;; internal procedures
(define (numer x) (car x))
(define (denom x) (cdr x))
; Modified to make exercise 2.79 easier to implement
(define (make-rat n d)
(let ((g (gcd n d))
(sign-flip (if (< d 0) -1 1)))
(cons (/ n g sign-flip) (/ d g sign-flip))))
(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))))
;; 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 '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 'make 'rational
(lambda (n d) (tag (make-rat n d))))
(put 'numer 'rational numer)
(put 'denom 'rational denom)
; part of exercise 2.79
(put 'equ? '(rational rational)
(lambda (x y) (and (= (numer x) (numer y))
(= (denom x) (denom y)))))
; part of exercise 2.80
(put '=zero? '(rational)
(lambda (x) (= (numer x) 0)))
(put 'sine '(rational)
(lambda (x) (tag (sin (/ (numer x)
(denom x))))))
(put 'cosine '(rational)
(lambda (x) (tag (sin (/ (numer x)
(denom x))))))
(put 'arctangent '(rational)
(lambda (x) (tag (atan (/ (numer x)
(denom x))))))
(put 'arctangent '(rational rational)
(lambda (x y) (tag (atan (/ (numer x)
(denom x))
(/ (numer y)
(denom y))))))
(put 'square-root '(rational)
(lambda (x) (tag (sqrt (/ (numer x)
(denom x))))))
'done)
(install-rational-package)
(define (make-rational n d)
((get 'make 'rational) n d))
(define (numer x) (apply-generic 'numer x))
(define (denom x) (apply-generic 'denom x))
;;;
;;; Complex number package
;;;
(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))
;; 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))))
;; interface to rest of the system
(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))))
; Code added as fix in the exercise 2.77
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
; Code added as fix in the exercise
; part of exercise 2.79
(put 'equ? '(complex complex)
(lambda (z1 z2) (and (equ? (real-part z1) (real-part z2))
(equ? (imag-part z1) (imag-part z2)))))
; part of exercise 2.80
(put '=zero? '(complex)
(lambda (z) (equ? (magnitude z) (make-integer 0))))
'done)
(install-complex-package)
(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))
;;;
;;; Raise package
;;;
(define (install-raise-package)
(define (integer->rational n)
(make-rational n 1))
(define (rational->real x)
(define tagged-x (attach-tag 'rational x))
(make-real (exact->inexact (/ (numer tagged-x)
(denom tagged-x)))))
(define (real->complex x)
(make-complex-from-real-imag x 0))
(put 'raise 'integer integer->rational)
(put 'raise 'rational rational->real)
(put 'raise 'real real->complex)
; added in exercise 2.85
; removed in exercise 2.86, because this projection is now better
; covered by real-part
;;;(define (complex->real z)
;;; (make-real (real-part z)))
; we will drop the real directly to integer, not to rational
; we could use inexact->exact to convert it to a rational, but this would be
; worse, since rationals are made up of bigints, there will always be a
; fraction close enough to be equ?. We will only simplify when the real is
; actually an integer.
; In principle, we could drop it to rational and check if the numerator and
; deominator are "small enough", but
; 1) this is beyond the scope of the exercise
; 2) even numbers as simple as 0.333..., would fail to be simplified this way
(define (real->integer x)
(make-integer x)) ; we get to use the builtin rounding we added, ha!
(define (rational->integer x)
(define tagged-x (attach-tag 'rational x))
(make-integer (/ (numer tagged-x) (denom tagged-x))))
(put 'project 'complex real-part)
(put 'project 'real real->integer)
(put 'project 'rational rational->integer))
(install-raise-package)
(define (raise x) (apply-generic 'raise x))
(define (drop x)
(define (re-raise-until obj original-type)
(if (eq? (type-tag obj) original-type)
obj
(re-raise-until (raise obj) original-type)))
(let ((tag (type-tag x)))
(if (eq? tag 'integer)
x
(let ((dropped-x (apply-generic 'project x)))
(let ((re-raised-x (re-raise-until dropped-x tag)))
(if (equ? re-raised-x x)
(drop dropped-x)
x))))))
(define (subtype t1 t2)
(let* ((type-hier '(integer rational real complex))
(t1-supertypes (cdr (memq t1 type-hier))))
(not (eq? #f (memq t2 t1-supertypes)))))
(define (supertype t1 t2)
(subtype t2 t1))
; If we want to be able to wrap complex numbers around ordinary or rational
; numbers, we must be able to do the following:
; 1) As mentioned, we need sine/cosine/atan functions that work on other types of numbers.
; We will install it in the integer, rational and real package.
; 2) We need the rectangular/polar packages to explicitly handle nesting of these other
; number types while selecting, constructing or just operating on complex numbers
; 3) These packages must, at the same time, prohibit the use of complex numbers
; as arguments here: for example:
; (make-from-real-imag (make-rational 1 4) 5) should produce something like:
; '(complex rectangular (rational 1 . 4) . (integer . 5)), same as
; '(complex rectangular (rational 1 . 4) integer . 5)
; a call for:
; (make-from-real-imag (make-from-real-imag 3 1)
; 5)
; should produce an error