Add exercises from subsection 2.5.2
This commit is contained in:
parent
b326460d60
commit
9a7c305530
9 changed files with 2995 additions and 0 deletions
317
chapter-2/ex-2.77.scm
Normal file
317
chapter-2/ex-2.77.scm
Normal 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
288
chapter-2/ex-2.78.scm
Normal 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
312
chapter-2/ex-2.79.scm
Normal 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
321
chapter-2/ex-2.80.scm
Normal 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
51
chapter-2/ex-2.81.txt
Normal 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
414
chapter-2/ex-2.82.scm
Normal 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
373
chapter-2/ex-2.83-84.scm
Normal 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
422
chapter-2/ex-2.85.scm
Normal 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
497
chapter-2/ex-2.86.scm
Normal 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
|
||||
Loading…
Add table
Reference in a new issue