For this section, we have to use code that we don't know how to write yet, fun times.
get and put this way:#lang sicp
(define operation-table '())
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (assoc-op key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc-op key (cdr records)))))
(define (put op type-tags proc)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(set-cdr! proc-pair-entry proc)
(set-car! (cdr op-list-entry)
(cons (cons type-tags proc) proc-list)))))
(set! operation-table
(cons (list op (list (cons type-tags proc)))
operation-table)))))
(define (get op type-tags)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(cdr proc-pair-entry)
#f)))
#f)))
(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 (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 (my-add-one x) (+ x 1))
(put 'inc '(my) my-add-one)
(apply-generic 'inc (attach-tag 'my 10))
11
#lang sicp
(define operation-table '())
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (assoc-op key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc-op key (cdr records)))))
(define (put op type-tags proc)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(set-cdr! proc-pair-entry proc)
(set-car! (cdr op-list-entry)
(cons (cons type-tags proc) proc-list)))))
(set! operation-table
(cons (list op (list (cons type-tags proc)))
operation-table)))))
(define (get op type-tags)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(cdr proc-pair-entry)
#f)))
#f)))
;; Code from book:
(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 (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))))))
;; polar-package stuff:
(define (square x) (* x x))
(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)
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang
'polar)
r a))
(install-polar-package)
(define polar-num (make-from-mag-ang (sqrt 2.0) (/ 3.14159 4.0)))
polar-num
(type-tag polar-num)
(contents polar-num)
done (polar 1.4142135623730951 . 0.7853975) polar (1.4142135623730951 . 0.7853975)
For install-rectangular-package and install-polar-package
It's kind of weird that some methods are tagged with a list,
and other methods are tagged without a list (like 'make-from-real-imag).
I notice that things tagged with a list seem to be called through
apply-generic, while things tagged without a list seem to be called
through get. eg:
(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)
(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))
Important functions: put, get, apply-generic.
Mutability hasn't been covered yet, so we can't really implement put.
2.3.2 described a program that performs symbolic differentiation:
(define (deriv exp var)
(cond ((number? exp) 0)
((variable? exp)
(if (same-variable? exp var) 1 0))
((sum? exp)
(make-sum (deriv (addend exp) var)
(deriv (augend exp) var)))
((product? exp)
(make-sum
(make-product
(multiplier exp)
(deriv (multiplicand exp) var))
(make-product
(deriv (multiplier exp) var)
(multiplicand exp))))
⟨@var{more rules can be added here}⟩
(else (error "unknown expression type:
DERIV" exp))))
We can regard this program as performing a dispatch on the type of the
expression to be differentiated. In this situation the `type tag'' of the
datum is the algebraic operator symbol (such as+) and the operation
being performed isderiv`. We can transform this program into
data-directed style by rewriting the basic derivative procedure as
(define (deriv exp var)
(cond ((number? exp) 0)
((variable? exp)
(if (same-variable? exp var)
1
0))
(else ((get 'deriv (operator exp))
(operands exp)
var))))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
1. Explain what was done above. Why can't we assimilate the predicates
number? and variable? into the data-directed dispatch?
2. Write the procedures for derivatives of sums and products, and the auxiliary code required to install them in the table used by the program above.
3. Choose any additional differentiation rule that you like, such as the one for exponents (Exercise 2.56), and install it in this data-directed system.
4. In this simple algebraic manipulator the type of an expression is the algebraic
operator that binds it together. Suppose, however, we indexed the procedures
in the opposite way, so that the dispatch line in deriv looked like
((get (operator exp) 'deriv)
(operands exp) var)
What corresponding changes to the derivative system are required?
Part 1: We can't assimilate the cases where it's a number or variable, because these aren't tagged data.
Part 2 and part 3: Note: I removed the keyword operands from
the function deriv, as this is more consistent with the code.
I could have added the tag back everywhere (let ((exp-tagged (cons '+ exp))) ...), but it's easier to just remove operands.
#lang sicp
(define operation-table '())
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (assoc-op key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc-op key (cdr records)))))
(define (put op type-tags proc)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(set-cdr! proc-pair-entry proc)
(set-car! (cdr op-list-entry)
(cons (cons type-tags proc) proc-list)))))
(set! operation-table
(cons (list op (list (cons type-tags proc)))
operation-table)))))
(define (get op type-tags)
(let ((op-list-entry (assoc-op op operation-table)))
(if op-list-entry
(let ((proc-list (cadr op-list-entry)))
(let ((proc-pair-entry (assoc type-tags proc-list)))
(if proc-pair-entry
(cdr proc-pair-entry)
#f)))
#f)))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1)
(variable? v2)
(eq? v1 v2)))
(define (make-sum a1 a2)
(cond ((=number? a1 0) a2)
((=number? a2 0) a1)
((and (number? a1) (number? a2))
(+ a1 a2))
(else (list '+ a1 a2))))
(define (make-product m1 m2)
(cond ((or (=number? m1 0)
(=number? m2 0))
0)
((=number? m1 1) m2)
((=number? m2 1) m1)
((and (number? m1) (number? m2))
(* m1 m2))
(else (list '* m1 m2))))
(define (=number? exp num)
(and (number? exp) (= exp num)))
(define (sum? x)
(and (pair? x) (eq? (car x) '+)))
(define (addend s) (cadr s))
(define (augend s) (caddr s))
(define (product? x)
(and (pair? x) (eq? (car x) '*)))
(define (multiplier p) (cadr p))
(define (multiplicand p) (caddr p))
(define (exponentiation? x)
(and (pair? x) (eq? (car x) '**)))
(define (base x) (cadr x))
(define (exponent x) (caddr x))
(define (make-exponentiation a b)
(cond ((=number? b 0) 1)
((=number? b 1) a)
((=number? a 0) 0)
(else (list '** a b))))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
(define (deriv exp var)
(cond ((number? exp) 0)
((variable? exp)
(if (same-variable? exp var)
1
0))
(else ((get 'deriv (operator exp))
exp
var))))
(put 'deriv '+
(lambda (exp var)
(make-sum (deriv (addend exp) var)
(deriv (augend exp) var))))
(put 'deriv '*
(lambda (exp var)
(make-sum
(make-product
(multiplier exp)
(deriv (multiplicand exp) var))
(make-product
(deriv (multiplier exp) var)
(multiplicand exp)))))
(put 'deriv '**
(lambda (exp var)
(make-product
(make-product
(exponent exp)
(make-exponentiation (base exp) (make-sum (exponent exp) -1)))
(deriv (base exp) var))))
(deriv (make-exponentiation 'x 3) 'x)
(deriv (make-exponentiation 'x 2) 'x)
(deriv (make-exponentiation 'x 1) 'x)
;;d((y*(x+2))**2)/dx = 2y**2 * (x+2)
(deriv (make-exponentiation (make-product 'y (make-sum 'x 2)) 2) 'x)
(* 3 (** x 2)) (* 2 x) 1 (* (* 2 (* y (+ x 2))) y)
Part 4: We just have to switch the order of the tags, it's trivial, here's the diff:
0a1
>
91c92
< (else ((get 'deriv (operator exp))
---
> (else ((get (operator exp) 'deriv)
95c96
< (put 'deriv '+
---
> (put '+ 'deriv
100c101
< (put 'deriv '*
---
> (put '* 'deriv
109c110
< (put 'deriv '**
---
> (put '** 'deriv
Insatiable Enterprises, Inc., is a highly decentralized conglomerate company consisting of a large number of independent divisions located all over the world. The company's computer facilities have just been interconnected by means of a clever network-interfacing scheme that makes the entire network appear to any user to be a single computer. Insatiable's president, in her first attempt to exploit the ability of the network to extract administrative information from division files, is dismayed to discover that, although all the division files have been implemented as data structures in Scheme, the particular data structure used varies from division to division. A meeting of division managers is hastily called to search for a strategy to integrate the files that will satisfy headquarters' needs while preserving the existing autonomy of the divisions.
Show how such a strategy can be implemented with data-directed programming. As
an example, suppose that each division's personnel records consist of a single
file, which contains a set of records keyed on employees' names. The structure
of the set varies from division to division. Furthermore, each employee's
record is itself a set (structured differently from division to division) that
contains information keyed under identifiers such as address and
salary. In particular:
1. Implement for headquarters a get-record procedure that retrieves a
specified employee's record from a specified personnel file. The procedure
should be applicable to any division's file. Explain how the individual
divisions' files should be structured. In particular, what type information
must be supplied?
2. Implement for headquarters a get-salary procedure that returns the
salary information from a given employee's record from any division's personnel
file. How should the record be structured in order to make this operation
work?
3. Implement for headquarters a find-employee-record procedure. This
should search all the divisions' files for the record of a given employee and
return the record. Assume that this procedure takes as arguments an employee's
name and a list of all the divisions' files.
4. When Insatiable takes over a new company, what changes must be made in order to incorporate the new personnel information into the central system?
Kind of a weird problem, let's use
(define (lookup given-key records) ...) from exercise 2.66.
lookup function of question ch 2.66, we can use ((get 'get-record filetype) employee-name file-contents). This requires each division to implement and install a get-record function that accepts an employee name. Let's say it returns a record tagged with the division name. Let's be more precise to prepare for part 3:;;Assume this returns false if no record exists.
(define (lookup-employee employee-name file)
(let ((filetype (car file)) (file-contents (cdr file)))
((get 'get-record filetype) employee-name file-contents)))
get-salary dispatchable function. Then we call (apply-generic 'get-salary tagged-record).(list filetype filecontents). (define (find-employee-record employee-name tagged-files)
(if (null? tagged-files) #f
(let ((employee-record (lookup-employee employee-name (car tagged-files))))
(if employee-record
employee-record
(find-employee-record employee-name (cdr tagged-files))))))
'get-record
and get-salary functions as defined earlier in the chapter.Implement the constructor
make-from-mag-ang in message-passing style. This procedure should be
analogous to the make-from-real-imag procedure given above.
#lang sicp
(define (make-from-mag-ang r a)
(define (dispatch op)
(cond ((eq? op 'real-part) (* r (cos a)))
((eq? op 'imag-part) (* r (sin a)))
((eq? op 'magnitude) r)
((eq? op 'angle) a)
(else
(error "Unknown op:
MAKE-FROM-MAG-ANGLE" op))))
dispatch)
(define (apply-generic op arg) (arg op))
(define my-c (make-from-mag-ang (sqrt 2) (/ 3.14159 4)))
(apply-generic 'real-part my-c)
(apply-generic 'imag-part my-c)
1.0000006633972283 0.9999993366023316
As a large system with generic operations evolves, new types of data objects or new operations may be needed. For each of the three strategies---generic operations with explicit dispatch, data-directed style, and message-passing-style---describe the changes that must be made to a system in order to add new types or new operations. Which organization would be most appropriate for a system in which new types must often be added? Which would be most appropriate for a system in which new operations must often be added?
Generic operations with explicit dispatch: This works well when we can be certain we don't have to add new types and operations.
Data-directed: Works extremely well when we have lot of different types, or have functions that deal with arguments of many different types. So this would work best when we have to add a bunch of different types.
Message-passing: Makes adding new functions very easy. We still have the flexibility to add new types quite easily, but it might not be as explicit as the data directed approach. So message-passing would be preferable when new operations must often be added.