SICP 2.5 exercises cont. 5

2.91

Made some heavy changes to the dense polynomial package to get it working. A bit frustrating, but this was great to get back into the groove. I only implemented division for dense polynomials, maybe I’ll go back and do sparse polynomials in the future.

(define (install-dense-polynomial-package)
  (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 (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))))

  (define (div-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
        (make-poly (variable p1)
                   (div-terms (term-list p1)
                              (term-list p2)))
        (error "Polys not in same var -- DIV-POLY"
               (list p1 p2))))

  ;; internal procedures
  ;; representation of poly
  (define (make-poly variable term-list)
    (cons variable term-list))
  (define (variable p) (car p))
  (define (variable? x) (symbol? x))
  (define (term-list p) (cdr p))
  (define (same-variable? v1 v2)
    (and (variable? v1) (variable? v2) (eq? v1 v2)))

  (define (adjoin-term term term-list)
    (cons term term-list))
  (define (the-empty-termlist) '())
  (define (first-term term-list)
    (make-term (length 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-terms L1 L2)
    (cond ((empty-termlist? L1) L2)
          ((empty-termlist? L2) L1)
          ((> (length L1) (length L2)) (adjoin-term (coeff (first-term L1)) (add-terms (rest-terms L1) L2)))
          (( (order t2) (order t1))
            (list (the-empty-termlist) L1)
          (let ((new-c (div (coeff t1) (coeff t2)))
                (new-o (- (order t1) (order t2))))
            (display t1) (display t2) (display new-o) (display (term2terms (make-term new-o new-c))) (newline) (newline)
            (let ((rest-of-result
                   (div-terms (trim (add-terms L1 (negate-terms (mul-terms (term2terms (make-term new-o new-c)) L2)))) L2)))
              (list (add-terms (car rest-of-result) (term2terms (make-term new-o new-c)))
                    (cadr rest-of-result))))))))

  (define (negate-poly p)
    (make-poly (variable p) (negate-terms (term-list p))))
  ;; interface to rest of the system
  (define (tag p) (attach-tag 'dense p))
  (put 'add '(dense dense)
       (lambda (p1 p2) (tag (add-poly p1 p2))))
  (put 'mul '(dense dense)
       (lambda (p1 p2) (tag (mul-poly p1 p2))))
  (put 'div '(dense dense)
       (lambda (p1 p2) (tag (div-poly p1 p2))))
  (put 'make 'dense
       (lambda (var terms) (tag (make-poly var terms))))
  (put '=zero? '(dense) (lambda (p) (zero-terms? (term-list p))))
  (put 'negate '(dense) (lambda (p) (tag (negate-poly p))))
  'done)

(define (negate x) (apply-generic 'negate x))

(define (sub x y)
  (add x (negate y)))

(define (install-polynomial-package)
  (define (make-dense-proc var terms)
    ((get 'make 'dense) var terms))
  (define (make-sparse-proc var terms)
    ((get 'make 'sparse) var terms))
  (define (tag p) (attach-tag 'polynomial p))
  (put 'add '(polynomial polynomial)
       (lambda (p1 p2) (tag (add p1 p2))))
  (put 'mul '(polynomial polynomial)
       (lambda (p1 p2) (tag (mul p1 p2))))
  (put 'div '(polynomial polynomial)
       (lambda (p1 p2) (tag (div p1 p2))))
  (put 'sub '(polynomial polynomial)
       (lambda (p1 p2) (tag (sub p1 p2))))
  (put 'negate '(polynomial) (lambda (p) (tag (negate p))))
  (put 'make-dense 'polynomial
       (lambda (var terms) (tag (make-dense-proc var terms))))
  (put 'make-sparse 'polynomial
       (lambda (var terms) (tag (make-sparse-proc var terms)))))
Advertisements

SICP 2.5 exercises cont. 3

2.89

(define (install-dense-polynomial-package)
  (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 (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))))

  ;; internal procedures
  ;; representation of poly
  (define (make-poly variable term-list)
    (cons variable term-list))
  (define (variable p) (car p))
  (define (variable? x) (symbol? x))
  (define (term-list p) (cdr p))
  (define (same-variable? v1 v2)
    (and (variable? v1) (variable? v2) (eq? v1 v2)))

  (define (adjoin-term 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-terms L1 L2)
    (cond ((empty-termlist? L1) L2)
          ((empty-termlist? L2) L1)
          ((> (length L1) (length L2)) (adjoin-term (first-term L1) (add-terms (rest-terms L1) L2)))
          ((< (length L1) (length L2)) (adjoin-term (first-term L2) (add-terms L1 (rest-terms L2))))
          (else
           (let ((t1 (first-term L1)) (t2 (first-term L2)))
             (adjoin-term (+ t1 t2) (add-terms (rest-terms L1) (rest-terms L2)))))))

  (define (mul-terms L1 L2)
    (if (empty-termlist? L1)
        (the-empty-termlist)
      (add-terms (mul-term-by-all-terms (length L1) (car L1) L2)
                 (mul-terms (rest-terms L1) L2))))

  (define (mul-term-by-all-terms t1-order t1-coeff L)
    (cond ((and (= t1-order 1) (empty-termlist? L)) (the-empty-termlist))
          ((empty-termlist? L) (cons 0 (mul-term-by-all-terms (- t1-order 1) t1-coeff L)))
          (else (cons (* t1-coeff (car L)) (mul-term-by-all-terms t1-order t1-coeff (cdr L))))))

  (define (zero-terms? term-list)
    (cond ((empty-termlist? term-list) #t)
          ((not (= 0 (coeff (first-term term-list)))) #f)
          (else (zero-terms? (rest-terms term-list)))))

  (define (negate-terms term-list)
    (if (empty-termlist? term-list)
        (the-empty-termlist)
        (cons (- (first-term term-list))
              (negate-terms (rest-terms term-list)))))
  (define (negate-poly p)
    (make-polynomial (variable p) (negate-terms (term-list p))))
  ;; 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))))
  (put '=zero? '(polynomial) (lambda (p) (zero-terms? (term-list p))))
  (put 'negate '(polynomial) negate-poly)
  'done)

Slow progress now, but these are challenging exercises and I’m behind on a lot of real life work.


SICP 2.5 exercises cont. 2

2.87

  (define (zero-terms? term-list)
    (cond ((empty-termlist? term-list) #t)
          ((not (= 0 (coeff (first-term term-list)))) #f)
          (else (zero-terms? (rest-terms term-list)))))
  (put '=zero? '(polynomial) (lambda (p) (zero-terms? (term-list p))))

Decently straightforward.

2.88
Define subtraction in terms of generic add and generic negate. Then implement the negation for polynomials.

(define (sub x y)
  (add x (negate y)))

(define (negate-terms term-list)
    (if (empty-termlist? term-list)
        (the-empty-termlist)
        (cons (make-term (order (first-term term-list))
                         (- (coeff (first-term term-list))))
              (negate-terms (rest-terms term-list)))))
(define (negate-poly p)
    (make-polynomial (variable p) (negate-terms (term-list p))))

It’s Chinese New Year so I had some stuff to do, like eating lots.


SICP 2.5 exercises cont.

2.81

a) apply-generic will continue to call itself because at the coercion step, it will call itself with the exact same values as before.

b) There is no need to do anything because apply-generic will either raise an error if there is no procedure that deals with the type, or it will apply the procedure that was found on the arguments.

c)

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

I don’t really get the point of this problem though.

2.82
This is extremely confusing even to me, but it works. Basically two helper procedures are defined. One is for coercing a list of numbers to a target type. The second procedure uses the first to coerce the list to the type of each argument. If there isn’t an available coercion procedure, then skip. When everything is coerced, attempt to apply the generic procedure on the new list immediately. This is in order to prevent an infinite loop.

(define (apply-generic op . args)
  (define (coerce-to target arguments)
    (cond ((null? arguments) '())
          ((eq? (type-tag (car arguments)) target) (cons (car arguments) (coerce-to target (cdr arguments))))
          (else (let ((coerce-proc (get-coercion (type-tag (car arguments)) target)))
                  (if coerce-proc
                      (cons (coerce-proc (car arguments))
                            (coerce-to target (cdr arguments)))
                      (cons (car arguments) (coerce-to target (cdr arguments))))))))
  (define (coerce-all arguments targets-left)
    (if (null? targets-left) arguments
      (coerce-all (coerce-to (car targets-left) arguments) (cdr targets-left))))
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
          (apply proc (map contents args))
        (let ((coerced-args (coerce-all args type-tags)))
          (if coerced-args
              (let ((coerce-proc (get op (map type-tag coerced-args))))
                (if coerce-proc
                    (apply coerce-proc coerced-args)
                    (error "No method for these types"
                         (list op type-tags))))))))))

I found a very good (but different) answer here. The part I cheated was in answering the discussion question about when the above procedure fails. Point 2 I find especially interesting. When there is only a (complex complex) operation defined, it should be possible to coerce a (scheme-number scheme-number) to it and then use the operation. However the above apply-general procedure does not do that.

2.83

The following go in the relevant install procedures. I skipped implementing real numbers because it isn’t in the examples and probably isn’t trivial. I suppose the raise function would not be hard to implement, but it’s no fun when it isn’t testable.

(define (scheme-number->rational n)
    (make-rational (contents n) 1))
(put 'raise '(scheme-number) scheme-number->rational)  
(define (rational->complex n)
    (make-complex-from-real-imag (/ (numer n)
                                    (denom n))
                                 0))
(put 'raise '(rational) rational->complex)

2.84

(define (apply-generic op . args)
  (define (level-iter n current-level)
    (if (not (get 'raise (list (type-tag n))))
        current-level
      (level-iter (raise n) (+ 1 current-level))))
  (define (level n)
    (level-iter n 0))
  (define (coerce args target-level)
    (cond ((null? args) '())
          ((> (level (car args)) target-level)
           (coerce (cons (raise (car args)) (cdr args)) target-level))
          (else (cons (car args) (coerce (cdr args) target-level)))))
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
          (apply proc (map contents args))
        (let ((target-level (apply min (map level args))))
          (let ((coerced-args (coerce args target-level)))
            (let ((coerce-proc (get op (map type-tag coerced-args))))
              (if coerce-proc
                  (apply apply-generic (cons op coerced-args))
                (error "No method for these types"
                       (list op type-tags))))))))))

This doesn’t deal with the issue in 2.83, but it’s enough to answer the question.

2.85

As above, the specific project procedures go inside their respective install procedures.

(put 'project '(rational) (lambda (x) (quotient (numer x) (denom x))))
(put 'project '(complex) (lambda (z) (make-rational (real-part z) 1)))

(define (project n) (apply-generic 'project n))
(define (drop n)
  (if (not (get 'project (list (type-tag n))))
      n
    (if (not (equ? n (raise (project n))))
        n
        (drop (project n)))))

Once again real numbers are ignored. It’s also kind of silly because complex numbers never drop down to rational numbers without dropping to scheme-number in my code, because they are simply represented as pairs of integers. I feel I understand the general idea of this section though and I really want to move on.

2.86

Never mind my comments above! Turned out that the silliness was part of the exercise.

(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))))
  (define (equ?-complex z1 z2)
    (and (equ? (real-part z1) (real-part z2))
         (equ? (imag-part z1) (imag-part z2))))
  (define (=zero?-complex z)
    (and (equ? (real-part z) 0)
         (equ? (imag-part z) 0)))

(define (install-rational-package)
  ;; internal procedures
  (define (numer x) (car x))
  (define (denom x) (cdr x))
  (define (make-rat n d)
    (if (and (integer? n) (integer? d))
        (let ((g (gcd (inexact->exact n) (inexact->exact d))))
          (cons (/ n g) (/ d g))))
    (cons n d))
  (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))
  (define (equ?-rational x y)
    (= (/ (numer x) (denom x)) (/ (numer y) (denom y))))
  (define (rational->complex n)
    (make-complex-from-real-imag (tag n)
                                 0))
  (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 'equ? '(rational rational) equ?-rational)
  (put '=zero? '(rational) (lambda (x) (= 0 (numer x))))
  (put 'add-3 '(rational rational rational)
       (lambda (z1 z2 z3) (tag (add-rat (add-rat z1 z2) z3))))
  (put 'raise '(rational) rational->complex)
  (put 'project '(rational) (lambda (x) (quotient (inexact->exact (numer x)) (inexact->exact (denom x)))))
  (put 'cosine '(rational) (lambda (x) (cos (/ (numer x) (denom x)))))
  (put 'sine '(rational) (lambda (x) (sin (/ (numer x) (denom x)))))
  'done)

(define (install-scheme-number-package)
  (define (tag x)
    (attach-tag 'scheme-number x))
  (define (scheme-number->rational n)
    (make-rational (contents n) 1))
  (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)))
  (put 'equ? '(scheme-number scheme-number)
       (lambda (x y) (= x y)))
  (put '=zero? '(scheme-number)
       (lambda (x) (= x 0)))
  (put 'exp '(scheme-number scheme-number)
     (lambda (x y) (tag (expt x y)))) ; using primitive expt
  (put 'add-3 '(scheme-number scheme-number scheme-number)
       (lambda (x y z) (+ x y z)))
  (put 'raise '(scheme-number) scheme-number->rational)
  (put 'cosine '(scheme-number) cos)
  (put 'sine '(scheme-number) sin)
  'done)

(define (cosine x) (apply-generic 'cosine x))
(define (sine x) (apply-generic 'sine x))

Just posting everything because there where a range of changes. Mostly the packages now use the generic operators instead of the native guile ones. I had to use guile’s inexact->exact procedure to keep gcd happy. The cosine and sine generic procedures are straightforward. I also edited make-rat so that decimal numerators and denominators are allowed for simplicity.


SICP 2.5 exercises

2.77

When the user calls one of the procedures, such as (magnitude z), apply-generic is invoked and discovers the ‘(complex) tag. It looks in the table and discovers that the magnitude procedure needs to be run on the contents, which is (‘rectangular 3 . 4). The same magnitude procedure as before is called, which invoked apply-generic a second time. This time it sees the ‘(rectangular) tag and calls the magnitude procedure that was defined in install-rectangular-package on the contents, which is (3 . 4), and the result is 5.

2.78

(define (attach-tag type-tag contents)
  (if (number? contents)
      contents
      (cons type-tag contents)))

(define (type-tag datum)
  (cond ((number? datum) 'scheme-number)
        ((pair? datum)(car datum))
        (else (error "Bad tagged datum -- TYPE-TAG" datum))))

(define (contents datum)
  (cond ((number? datum) datum)
        ((pair? datum) (cdr datum))
        (else (error "Bad tagged datum -- CONTENTS" datum))))

Essentially we add a new condition in each procedure to deal with the special case when we’re dealing with a native number type. type-tag has to attach a scheme-number tag to keep the dispatch table happy.

2.79

Define procdures to deal with each data type and put them into the table. These are defined in their corresponding install procedures.

(put 'equ? '(scheme-number scheme-number)
       (lambda (x y) (= x y)))

(define (equ?-rational x y)
   (= (/ (numer x) (denom x)) (/ (numer y) (denom y))))
(put 'equ? '(rational rational) equ?-rational)
 
(define (equ?-complex z1 z2)
    (and (= (real-part z1) (real-part z2))
         (= (imag-part z1) (imag-part z2))))
(put 'equ? '(complex complex) equ?-complex)

The generic operation also needs to be defined.

(define (equ? a b) (apply-generic 'equ? a b))

2.80

Same thing is done as before in 2.79.

(put '=zero? '(scheme-number)
       (lambda (x) (= x 0)))
  
(put '=zero? '(rational) (lambda (x) (= 0 (numer x))))
 
(define (=zero?-complex z)
    (and (= (real-part z) 0)
         (= (imag-part z) 0)))
(put '=zero? '(complex) =zero?-complex)

(define (=zero? a) (apply-generic '=zero? a))

Comments:: Quite disappointed in my own progress lately. A mix of obligations for school/work and being unable to concentrate and understand what the chapter was talking about. One thing I’ve noticed about this book is that it requires a lot of concentration to understand the content even though it seems short and simple at first.


SICP 2.4 exercises cont. 3

2.75

(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-ANG" op))))
  dispatch)

(define (apply-generic op arg) (arg op))

Easy enough, but implementing this gave a much clearer idea of what the book meant by message passing.

2.76

Generic operations with explicit dispatch
New Type – For each operation, create procedures that deal with the new type. For each generic operation, add a conditional statement that tests if the tag corresponds to the new type and calls the correct procedure that was just defined.
.
New Operation – For each type, create a procedure that deals with the new operation. Create a new generic operation that deals with each type currently in the system correctly using conditional statements.

Data Directed Style
New Type – Create procedures for the new type for each operation and put them into the table indexed by the procedure name and the type name.
New Operation – Create procedures for the new operation for each type and put them into the table indexed by the procedure name and type name.

Message Passing Style
New Type – Create a new procedure/data object which deals with existing operations through conditional statements and returns a correct procedure representing the type.
New Operation – For each data object defined, create a new conditional statement that handles the new operation.

Message passing is most appropriate when new types are added frequently, because it only requires defining one new procedure.

Data Directed is most appropriate for when new operations are added frequently as new values can be placed into the table as needed.

Comments
Finally finished section 2,4! This took much longer than expected thanks to the start of school and all the obligations that came with it. Still, my time management can be improved. Hopefully I can work through the book more consistently from now on.


SICP 2.4 exercises cont. 2

2.74

Full code listing below for all 4 parts. The annoying thing about this problem was I needed to implement two different representation of the files and records. I just did something simple, where the name-information pairs in the records are represented by cons in the alpha division and list in the beta division.

a) Individual division’s file need to have their division name tagged to the front of the records so that the generic get-record procedure can identify which specific get-record procedure to use.

b) Each record should be tagged with the division name in front of the name and the information pairs.

c) Can be implemented in terms of the procedures in a) and b)

d) When a new division is added, all it’s records and files need to be tagged. Functions need to be defined for getting the salary from records and the records from files and then put into the table.

My procedures were a little bit hackish in that the individual get-record and get-salary procedures need to deal with the tag in the records. This is invisible to the user of the generic procedures however.

(define (make-record-beta name . pairs)
  (define (make-info kv-pair)
    (if (null? kv-pair)
        '()
        (cons (list (car kv-pair) (cadr kv-pair)) (make-info (cddr kv-pair)))))
  (list name (make-info pairs)))

(define (get-record-beta name file)
  (cond ((null? file) #f)
        ((eq? (caar file) name) (car file))
        (else (get-record-beta name (cdr file)))))

(define (get-salary-beta record)
  (define (retrieve pairs)
    (if (eq? (caar pairs) 'salary)
        (cadar pairs)
        (retrieve (cdr pairs))))
  (retrieve (cadr record)))

(define (get-tag tagged-file)
  (car tagged-file))

(define (contents tagged-file)
  (cdr tagged-file))

(define (tag-file tag file)
  (cons tag file))

(define (make-record-alpha name . pairs)
  (define (make-info kv-pair)
    (if (null? kv-pair)
        '()
      (cons (cons (car kv-pair) (cadr kv-pair))
            (make-info (cddr kv-pair)))))
  (tag-file 'alpha (cons name (make-info pairs))))

(define (make-file-alpha . records)
  (tag-file 'alpha records))

(define (make-file-beta . records)
  (tag-file 'beta records))

(define (install-division-alpha)
  (define (get-record-alpha name file)
    (cond ((null? file) #f)
          ((eq? name (cadar file)) (car file))
          (else (get-record-alpha name (cdr file)))))

  (define (get-salary-alpha record)
    (define (retrieve pairs)
      (if (eq? (caar pairs) 'salary)
          (cdar pairs)
        (retrieve (cdr pairs))))
    (retrieve (cdr record)))
  (put 'get-record 'alpha get-record-alpha)
  (put 'get-salary 'alpha get-salary-alpha))

(define (install-division-beta)
  (define (get-record name file)
    (cond ((null? file) #f)
          ((eq? name (cadar file)) (car file))
          (else (get-record name (cdr file)))))
  (define (get-salary record)
    (define (retrieve pairs)
      (if (eq? 'salary (car pairs))
          (cadr pairs)
          (retrieve (cddr pairs))))
    (retrieve (cdr record)))
  (put 'get-record 'beta get-record)
  (put 'get-salary 'beta get-salary))

(define (get-record name file)
  ((get 'get-record (get-tag file)) name (contents file)))

(define (get-salary record)
  ((get 'get-salary (get-tag record)) (contents record)))

(define (find-employee-record name files)
  (if (null? files)
      #f
    (let ((result (get-record name (car files))))
      (if result result
        (find-employee-record name (cdr files))))))

Comments: Skipped two days, which is too bad, Despite there being so few problems in this chapter, I seem to be taking a very long time. I suppose that is what happens when there are other obligations to meet.