Skip to content

GitLab

Commit 728ba081 authored by bbguimaraes's avatar bbguimaraes
Browse files

sicp: section 2.5

parent 581ce163
Hide whitespace changes
Inline Side-by-side
sicp/2/5/1.scm 0 → 100644
View file @ 728ba081
(define (apply-generic dispatch-table op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get dispatch-table op type-tags)))
(if proc
(apply proc (map contents args))
(error
"No method for these types -- APPLY-GENERIC"
(list op type-tags))))))
(define (get table op type-tags)
(if (null? table)
#f
(let ((x (car table)))
(if (and
(eq? (car x) op)
(if (pair? type-tags)
(list-eq? (cadr x) type-tags)
(eq? (cadr x) type-tags)))
(caddr x)
(get (cdr table) op type-tags)))))
(define (list-eq? x y)
(cond
((null? x) (null? y))
((null? y) (null? x))
((not (eq? (car x) (car y))) #f)
(else (list-eq? (cdr x) (cdr y)))))
(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)))
(define (add x y) (apply-generic dispatch-table 'add x y))
(define (sub x y) (apply-generic dispatch-table 'sub x y))
(define (mul x y) (apply-generic dispatch-table 'mul x y))
(define (div x y) (apply-generic dispatch-table 'div x y))
(define (install-scheme-number-package dispatch-table)
(define (tag x) (attach-tag 'scheme-number x))
(append
dispatch-table
(list
(list 'add '(scheme-number scheme-number) (lambda (x y) (tag (+ x y))))
(list 'sub '(scheme-number scheme-number) (lambda (x y) (tag (- x y))))
(list 'mul '(scheme-number scheme-number) (lambda (x y) (tag (* x y))))
(list 'div '(scheme-number scheme-number) (lambda (x y) (tag (/ x y))))
(list 'make 'scheme-number (lambda (x) (tag x))))))
(define (install-rational-package dispatch-table)
;; 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 the rest of the system
(define (tag x) (attach-tag 'rational x))
(append
dispatch-table
(list
(list 'add '(rational rational) (lambda (x y) (tag (add-rat x y))))
(list 'sub '(rational rational) (lambda (x y) (tag (sub-rat x y))))
(list 'mul '(rational rational) (lambda (x y) (tag (mul-rat x y))))
(list 'div '(rational rational) (lambda (x y) (tag (div-rat x y))))
(list 'make 'rational (lambda (n d) (tag (make-rat n d)))))))
(define (real-part z) (apply-generic dispatch-table 'real-part z))
(define (imag-part z) (apply-generic dispatch-table 'imag-part z))
(define (magnitude z) (apply-generic dispatch-table 'magnitude z))
(define (angle z) (apply-generic dispatch-table 'angle z))
(define (install-rectangular-package dispatch-table)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(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-real-imag x y) (cons x y))
;; interface to the rest of the system
(define (tag x) (attach-tag 'rectangular x))
(append
dispatch-table
(list
(list 'real-part '(rectangular) real-part)
(list 'imag-part '(rectangular) imag-part)
(list 'magnitude '(rectangular) magnitude)
(list 'angle '(rectangular) angle)
(list 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y)))))))
(define (install-polar-package dispatch-table)
;; internal procedures
(define (magnitude z) (car z))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
;; interface to the rest of the system
(define (tag x) (attach-tag 'polar x))
(append
dispatch-table
(list
(list 'real-part '(polar) real-part)
(list 'imag-part '(polar) imag-part)
(list 'magnitude '(polar) magnitude)
(list 'angle '(polar) angle)
(list 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a)))))))
(define (install-complex-package dispatch-table)
;; imported procedures from rectangular and polar packages
(define (make-from-real-imag x y)
((get dispatch-table 'make-from-real-imag 'rectangular) x y))
(define (make-from-mag-ang r a)
((get dispatch-table '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-real-imag (* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-real-imag (/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
;; interface to the rest of the system
(define (tag z) (attach-tag 'complex z))
(append
dispatch-table
(list
(list 'add '(complex complex) (lambda (z1 z2) (tag (add-complex z1 z2))))
(list 'sub '(complex complex) (lambda (z1 z2) (tag (sub-complex z1 z2))))
(list 'mul '(complex complex) (lambda (z1 z2) (tag (mul-complex z1 z2))))
(list 'div '(complex complex) (lambda (z1 z2) (tag (div-complex z1 z2))))
(list 'make-from-real-imag 'complex
(lambda (x y) (tag (make-from-real-imag x y))))
(list 'make-from-mag-ang 'complex
(lambda (r a) (tag (make-from-mag-ang r a)))))))
(define dispatch-table
(install-complex-package
(install-rational-package
(install-scheme-number-package
(install-polar-package
(install-rectangular-package '()))))))
(define (make-scheme-number n) ((get dispatch-table 'make 'scheme-number) n))
(define (make-rational n d) ((get dispatch-table 'make 'rational) n d))
(define (make-complex-from-real-imag x y)
((get dispatch-table 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get dispatch-table 'make-from-mag-ang 'complex) r a))
(define (t x y)
(map display (list x " " y))
(newline)
(display (add x y))
(newline)
(display (sub x y))
(newline)
(display (mul x y))
(newline)
(display (div x y))
(newline))
(t (make-scheme-number 2) (make-scheme-number 3))
(newline)
(t (make-rational 1 2) (make-rational 3 4))
(newline)
(t (make-complex-from-real-imag 1 2) (make-complex-from-real-imag 3 4))
(newline)
(t (make-complex-from-mag-ang 1 2) (make-complex-from-mag-ang 3 4))
sicp/2/5/2.scm 0 → 100644
View file @ 728ba081
(define (apply-generic dispatch-table op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get dispatch-table op type-tags)))
(if proc
(apply proc (map contents args))
(error
"No method for these types -- APPLY-GENERIC"
(list op type-tags))))))
(define (get table op type-tags)
(if (null? table)
#f
(let ((x (car table)))
(if (and
(eq? (car x) op)
(if (pair? type-tags)
(list-eq? (cadr x) type-tags)
(eq? (cadr x) type-tags)))
(caddr x)
(get (cdr table) op type-tags)))))
(define (list-eq? x y)
(cond
((null? x) (null? y))
((null? y) (null? x))
((not (eq? (car x) (car y))) #f)
(else (list-eq? (cdr x) (cdr y)))))
(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)))
(define (add x y) (apply-generic dispatch-table 'add x y))
(define (sub x y) (apply-generic dispatch-table 'sub x y))
(define (mul x y) (apply-generic dispatch-table 'mul x y))
(define (div x y) (apply-generic dispatch-table 'div x y))
(define (install-scheme-number-package dispatch-table)
(define (tag x) (attach-tag 'scheme-number x))
(append
dispatch-table
(list
(list 'add '(scheme-number scheme-number) (lambda (x y) (tag (+ x y))))
(list 'sub '(scheme-number scheme-number) (lambda (x y) (tag (- x y))))
(list 'mul '(scheme-number scheme-number) (lambda (x y) (tag (* x y))))
(list 'div '(scheme-number scheme-number) (lambda (x y) (tag (/ x y))))
(list 'make 'scheme-number (lambda (x) (tag x))))))
(define (install-rational-package dispatch-table)
;; 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 the rest of the system
(define (tag x) (attach-tag 'rational x))
(append
dispatch-table
(list
(list 'add '(rational rational) (lambda (x y) (tag (add-rat x y))))
(list 'sub '(rational rational) (lambda (x y) (tag (sub-rat x y))))
(list 'mul '(rational rational) (lambda (x y) (tag (mul-rat x y))))
(list 'div '(rational rational) (lambda (x y) (tag (div-rat x y))))
(list 'make 'rational (lambda (n d) (tag (make-rat n d)))))))
(define (real-part z) (apply-generic dispatch-table 'real-part z))
(define (imag-part z) (apply-generic dispatch-table 'imag-part z))
(define (magnitude z) (apply-generic dispatch-table 'magnitude z))
(define (angle z) (apply-generic dispatch-table 'angle z))
(define (install-rectangular-package dispatch-table)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(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-real-imag x y) (cons x y))
;; interface to the rest of the system
(define (tag x) (attach-tag 'rectangular x))
(append
dispatch-table
(list
(list 'real-part '(rectangular) real-part)
(list 'imag-part '(rectangular) imag-part)
(list 'magnitude '(rectangular) magnitude)
(list 'angle '(rectangular) angle)
(list 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y)))))))
(define (install-polar-package dispatch-table)
;; internal procedures
(define (magnitude z) (car z))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
;; interface to the rest of the system
(define (tag x) (attach-tag 'polar x))
(append
dispatch-table
(list
(list 'real-part '(polar) real-part)
(list 'imag-part '(polar) imag-part)
(list 'magnitude '(polar) magnitude)
(list 'angle '(polar) angle)
(list 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a)))))))
(define (install-complex-package dispatch-table)
;; imported procedures from rectangular and polar packages
(define (make-from-real-imag x y)
((get dispatch-table 'make-from-real-imag 'rectangular) x y))
(define (make-from-mag-ang r a)
((get dispatch-table '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-real-imag (* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-real-imag (/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
;; interface to the rest of the system
(define (tag z) (attach-tag 'complex z))
(append
dispatch-table
(list
(list 'add '(complex complex) (lambda (z1 z2) (tag (add-complex z1 z2))))
(list 'sub '(complex complex) (lambda (z1 z2) (tag (sub-complex z1 z2))))
(list 'mul '(complex complex) (lambda (z1 z2) (tag (mul-complex z1 z2))))
(list 'div '(complex complex) (lambda (z1 z2) (tag (div-complex z1 z2))))
(list 'make-from-real-imag 'complex
(lambda (x y) (tag (make-from-real-imag x y))))
(list 'make-from-mag-ang 'complex
(lambda (r a) (tag (make-from-mag-ang r a)))))))
(define dispatch-table
(install-complex-package
(install-rational-package
(install-scheme-number-package
(install-polar-package
(install-rectangular-package '()))))))
(define (make-scheme-number n) ((get dispatch-table 'make 'scheme-number) n))
(define (make-rational n d) ((get dispatch-table 'make 'rational) n d))
(define (make-complex-from-real-imag x y)
((get dispatch-table 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get dispatch-table 'make-from-mag-ang 'complex) r a))
(define (add-complex-to-schemenum z x)
(make-complex-from-real-imag (+ (real-part z) x)
(imag-part z)))
(define old-dispatch-table dispatch-table)
(define dispatch-table
(append
dispatch-table
(list
(list 'add '(complex scheme-number)
(lambda (z x) (add-complex-to-schemenum z x))))))
(display
(add (make-complex-from-real-imag 1 2)
(make-scheme-number 3)))
(newline)
(define dispatch-table old-dispatch-table)
(define (scheme-number->complex n)
(make-complex-from-real-imag (contents n) 0))
(define coercion-table
(list
(list 'scheme-number 'complex scheme-number->complex)))
(define (apply-generic dispatch-table op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get dispatch-table op type-tags)))
(if proc
(apply proc (map contents args))
(if (= (length args) 2)
(let ((type1 (car type-tags))
(type2 (cadr type-tags))
(a1 (car args))
(a2 (cadr args)))
(let ((t1->t2 (get coercion-table type1 type2))
(t2->t1 (get coercion-table type2 type1)))
(cond (t1->t2 (apply-generic dispatch-table op (t1->t2 a1) a2))
(t2->t1 (apply-generic dispatch-table op a1 (t2->t1 a2)))
(else
(error "No method for these types"
(list op type-tags))))))
(error "No method for these types"
(list op type-tags)))))))
(display
(add (make-complex-from-real-imag 1 2)
(make-scheme-number 3)))
(newline)
sicp/2/5/3.scm 0 → 100644
View file @ 728ba081
(define (apply-generic dispatch-table op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get dispatch-table op type-tags)))
(if proc
(apply proc (map contents args))
(error
"No method for these types -- APPLY-GENERIC"
(list op type-tags))))))
(define (attach-tag type-tag contents)
(if (number? contents)
contents
(cons type-tag contents)))
(define (type-tag datum)
(if (number? datum)
'scheme-number
(if (pair? datum)
(car datum)
(error "Bad tagged datum -- TYPE-TAG" datum))))
(define (contents datum)
(if (number? datum)
datum
(if (pair? datum)
(cdr datum)
(error "Bad tagged datum -- CONTENTS" datum))))
(define (get table op type-tags)
(if (null? table)
#f
(let ((x (car table)))
(if (and
(eq? (car x) op)
(if (pair? type-tags)
(list-eq? (cadr x) type-tags)
(eq? (cadr x) type-tags)))
(caddr x)
(get (cdr table) op type-tags)))))
(define (list-eq? x y)
(cond
((null? x) (null? y))
((null? y) (null? x))
((not (eq? (car x) (car y))) #f)
(else (list-eq? (cdr x) (cdr y)))))
(define (install-scheme-number-package dispatch-table)
(define (tag x) (attach-tag 'scheme-number x))
(append
dispatch-table
(list
(list 'add '(scheme-number scheme-number) (lambda (x y) (tag (+ x y))))
(list 'sub '(scheme-number scheme-number) (lambda (x y) (tag (- x y))))
(list 'mul '(scheme-number scheme-number) (lambda (x y) (tag (* x y))))
(list 'div '(scheme-number scheme-number) (lambda (x y) (tag (/ x y))))
(list 'make 'scheme-number (lambda (x) (tag x))))))
(define (install-polynomial-package dispatch-table)
;; internal procedures
;; representation of poly
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p) (cdr p))
(define (variable? x) (symbol? x))
(define (same-variable? x y)
(and (variable? x) (variable? y) (eq? x y)))
;; representation of terms and term lists
(define (adjoin-term term term-list)
(if (=zero? (coeff term))
term-list
(cons term term-list)))
(define (the-empty-termlist) '())
(define (first-term term-list) (car term-list))
(define (rest-terms term-list) (cdr term-list))
(define (empty-termlist? term-list) (null? term-list))
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(define (add-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(add-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var -- ADD-POLY"
(list p1 p2))))
(define (add-terms L1 L2)
(cond ((empty-termlist? L1) L2)
((empty-termlist? L2) L1)
(else
(let ((t1 (first-term L1)) (t2 (first-term L2)))
(cond ((> (order t1) (order t2))
(adjoin-term
t1 (add-terms (rest-terms L1) L2)))
((< (order t1) (order t2))
(adjoin-term
t2 (add-terms L1 (rest-terms L2))))
(else
(adjoin-term
(make-term (order t1)
(add (coeff t1) (coeff t2)))
(add-terms (rest-terms L1)
(rest-terms L2)))))))))
(define (mul-poly p1 p2)
(define (mul-terms L1 L2)
(if (empty-termlist? L1)
(the-empty-termlist)
(add-terms (mul-term-by-all-terms (first-term L1) L2)
(mul-terms (rest-terms L1) L2))))
(define (mul-term-by-all-terms t1 L)
(if (empty-termlist? L)
(the-empty-termlist)
(let ((t2 (first-term L)))
(adjoin-term
(make-term (+ (order t1) (order t2))
(mul (coeff t1) (coeff t2)))
(mul-term-by-all-terms t1 (rest-terms L))))))
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(mul-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var -- MUL-POLY"
(list p1 p2))))
;; interfaces to rest of the system
(define (tag p) (attach-tag 'polynomial p))
(append
dispatch-table
(list
(list 'add '(polynomial polynomial)
(lambda (p1 p2) (tag (add-poly p1 p2))))
(list 'mul '(polynomial polynomial)
(lambda (p1 p2) (tag (mul-poly p1 p2))))
(list 'make 'polynomial
(lambda (var terms) (tag (make-poly var terms)))))))
(define (=zero? n) (apply-generic dispatch-table '=zero? n))
(define (install-=zero?-package d-table)
(append
d-table
(list
(list '=zero? '(scheme-number)
(lambda (n) (= 0 n)))
(list '=zero? '(rational)
(lambda (n) (or (= 0 (car n))
(= 0 (cdr n)))))
(list '=zero? '(rectangular)
(lambda (n) (= 0 (car n) (cdr n))))
(list '=zero? '(polar)
(lambda (n) (= 0 (car n) (cdr n))))
(list '=zero? '(complex)
(lambda (n) (apply-generic dispatch-table '=zero? n))))))
(define (make-polynomial var terms)
((get dispatch-table 'make 'polynomial) var terms))
(define (add x y) (apply-generic dispatch-table 'add x y))
(define (mul x y) (apply-generic dispatch-table 'mul x y))