CprS376 Schedule
CprS376 Class 9
CprS376 Class 11

Systems with Generic Operations

Class 10 - Section 2.5



Contents

Generic Arithmetic

;; generic-arithmetic.ss

;; a modular generic arithmetic system
;; SICP source code supporting Section 2.5

;; uses tables

(load "tables.ss")

;;;SECTION 2.5.1

(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 (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
          (apply proc (map contents args))
          (error
            "No method for these types -- APPLY-GENERIC"
            (list op type-tags))))))

(define (install-scheme-number-package)
  (define (tag x)
    (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)

(define (make-scheme-number n)
  ((get 'make 'scheme-number) n))

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

(define (make-rational n d)
  ((get 'make 'rational) n d))

(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))))
  'done)

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

;;==========================================

;; 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)))

Generic Arithmetic Transcript

;; generic-arithmetic.transcript

;; The structure of this system is diagrammed in SICP on page 188

;;=================================

;; load the generic arithmetic procedures

(load "tables.ss")
(load "complex-package.ss")
(load "generic-arithmetic.ss")

(install-scheme-number-package)
(install-rational-package)
(install-complex-package)
(install-rectangular-package)
(install-polar-package)

;;=================================

;; test generic arithmetic


;; working with scheme numbers

(define two (make-scheme-number 2))
(define three (make-scheme-number 3))
(define pi (make-scheme-number 3.14159))

two
; => (scheme-number . 2)

three
; => (scheme-number . 3)

pi
; => (scheme-number . 3.14159)


(add two three)
; => (scheme-number . 5)

(sub two three)
; => (scheme-number . -1)

(mul two three)
; => (scheme-number . 6)

(div two three)
; => (scheme-number . 2/3)

(add two pi)
; => (scheme-number . 5.14159)

(mul two pi)
; => (scheme-number . 6.28318)

(div pi two)
; => (scheme-number . 1.570795)



;; working with rational numbers

(define one-third (make-rational 1 3))
(define five-eighths (make-rational 5 8))

one-third
; => (rational 1 . 3)

five-eighths
; => (rational 5 . 8)

(add one-third five-eighths)
; => (rational 23 . 24)

(sub one-third five-eighths)
; => (rational -7 . 24)

(mul one-third five-eighths)
; => (rational 5 . 24)

(div one-third five-eighths)
; => (rational 8 . 15)


;; working with complex numbers

(define z_1+2i (make-complex-from-real-imag 1 2))
(define z_3-4i (make-complex-from-real-imag 3 -4))

(define pie 3.14159)

(define z_i (make-complex-from-mag-ang 1 (/ pie 2)))
(define z_-3 (make-complex-from-mag-ang 3 pie))

(add z_1+2i z_3-4i)
; => (complex rectangular 4 . -2)

(sub z_i z_-3)
; => (complex rectangular 3.0000013267843344 . .9999920392297398)

(mul z_1+2i z_3-4i)
; => (complex polar 11.180339887498949 . .17985349979247822)

(div z_i z_-3)
; => (complex polar 1/3 . -1.570795)

Polynomial Package

;; polynomial-package.ss

;; a polynomial package built on top of
;; a modular generic arithmetic system
;; SICP source code supporting Section 2.5

;; does not support coercion in the numeric hierarchy

;; uses tables and the generic arithmetic package

(load "tables.ss")
(load "complex-package.ss")
(load "generic-arithmetic.ss")

;;; ALL procedures in 2.5.3 except make-polynomial
;;; have been inserted into install-polynomial-package

(define (install-polynomial-package)
  
  ;;; internal procedures
  
  ;; representation of poly
  
  (define (make-poly variable term-list)
    (cons variable term-list))
  
  (define (variable p) (car p))
  
  (define (term-list p) (cdr p))
  
  ;;[procedures same-variable? and variable? from section 2.3.2]
  
  (define (variable? x) (symbol? x))
  
  (define (same-variable? v1 v2)
    (and (variable? v1) (variable? v2) (eq? v1 v2)))
  
  ;; representation of terms and term lists
  
  (define (adjoin-term term term-list)
    (if (=zero? (coeff term))
      term-list
      (cons term term-list)))
  
  (define (=zero? coeff)
    (equal? coeff (make-scheme-number 0)))
    
  (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))
  
  ;; add-poly
  
  (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))))
  
  ;; procedures used by add-poly
  
  (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)))))))))
  
  
  ;; mul-poly
  
  (define (mul-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
      (make-poly (variable p1)
                 (mul-terms (term-list p1)
                            (term-list p2)))
      (error "Polys not in same var -- MUL-POLY"
             (list p1 p2))))
  
  ;; procedures used by mul-poly
  
  (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))))))
  
  ;; interface to rest of the system
  
  (define (tag p) (attach-tag 'polynomial p))
  
  (put 'add '(polynomial polynomial) 
       (lambda (p1 p2) (tag (add-poly p1 p2))))
  
  (put 'mul '(polynomial polynomial) 
       (lambda (p1 p2) (tag (mul-poly p1 p2))))
  
  (put 'make 'polynomial
       (lambda (var terms) (tag (make-poly var terms))))
  'done)


;; Constructor 
;; (which must be visible to the outside world)

(define (make-polynomial var terms)
  ((get 'make 'polynomial) var terms))

Polynomial Package Transcript

;; polynomial-package.transcript

;; a polynomial package built on top of
;; a modular generic arithmetic system
;; SICP source code supporting Section 2.5

;; uses tables and the generic arithmetic package

;; BEWARE: This implementation does not support coercion in the numeric hierarchy

;;=================================

;; load the generic arithmetic procedures

(load "tables.ss")
(load "complex-package.ss")
(load "generic-arithmetic.ss")
(load "polynomial-package.ss")

(install-scheme-number-package)
(install-rational-package)
(install-complex-package)
(install-rectangular-package)
(install-polar-package)
(install-polynomial-package)

;;=================================

;; test polynomial arithmetic

;;;SECTION 2.5.3

(define a 
  (let ((a2 (make-scheme-number 1))
        (a1 (make-scheme-number -2))
        (a0 (make-scheme-number -5)))
    (make-polynomial 'x `((2 ,a2) (1 ,a1) (0 ,a0)))))

a
; => (polynomial x (2 (scheme-number . 1)) 
;                  (1 (scheme-number . -2)) 
;                  (0 (scheme-number . -5)))

(add a a)
; => (polynomial x (2 (scheme-number . 2)) 
;                  (1 (scheme-number . -4)) 
;                  (0 (scheme-number . -10)))


(define b 
  (let ((b5 (make-scheme-number -7))
        (b2 (make-scheme-number 3))
        (b1 (make-scheme-number 4))
        (b0 (make-scheme-number 1)))
    (make-polynomial 'x `((5 ,b5) (2 ,b2) (1 ,b1) (0 ,b0)))))


b
; => (polynomial x (5 (scheme-number . -7)) 
;                  (2 (scheme-number . 3)) 
;                  (1 (scheme-number . 4)) 
;                  (0 (scheme-number . 1)))

(add a b)
; => (polynomial x (5 (scheme-number . -7)) 
;                  (2 (scheme-number . 4)) 
;                  (1 (scheme-number . 2)) 
;                  (0 (scheme-number . -4)))

(mul a b)
; => (polynomial x (7 (scheme-number . -7)) 
;                  (6 (scheme-number . 14)) 
;                  (5 (scheme-number . 35)) 
;                  (4 (scheme-number . 3)) 
;                  (3 (scheme-number . -2)) 
;                  (2 (scheme-number . -22)) 
;                  (1 (scheme-number . -22)) 
;                  (0 (scheme-number . -5)))


(define r 
  (let ((r4 (make-rational 2 3))
        (r0 (make-rational 5 8)))
    (make-polynomial 'x `((4 ,r4) (0 ,r0)))))

r
; => (polynomial x (4 (rational 2 . 3)) 
;                  (0 (rational 5 . 8)))


(mul r r)
; => (polynomial x (8 (rational 4 . 9)) 
;                  (4 (rational 5 . 6)) 
;                  (0 (rational 25 . 64)))


;; BEWARE: the present system does not support coercion

(mul a r)
; => *** ERROR -- No method for these types 
;              -- APPLY-GENERIC (mul (scheme-number rational))

SICP Source Code

Programming Exercises

In class today we will continue our work on the following exercises from chapter 2: 1, 4, 5, 8, 10, 11, 19, 20, 21, 23, 24, 25, 26, 27, 58, 59, 60, 61, 67, 73, 87, 88, 89.