問題2.74

問題2.74 – SICP（計算機プログラムの構造と解釈）その85

2009年01月29日

事業所レコードの構造を次のようにする。

; 事業所レコードの構造（東京事業所）
(type-tag (record1) (record2) ...)
(tokyo (isono nakano1-2 150000) (nakajima setagaya2-1 250000) ...)

; 従業員レコードの構造（東京事業所）
(name address salary)
(isono nakano1-2 150000)
(nakajima setagaya2-1 250000)

事業所レコードの構造に基づきパッケージを定義する。

(define (install-tokyo-company-package)
  ;; 内部手続き
  (define (make-employee-record name address salary)
    (list name address salary))
  (define (make-company-record record-list)
    (cons 'tokyo record-list))
  (define (name record) (car record))
  (define (address record) (cadr record))
  (define (salary record) (caddr record))
  (define (get-record company-record employee-name)
    (let ((records (cdr company-record)))
         (define (get-rcd records)
           (if (null? records)
               #f
               (let ((record (car records)))
                    (cond ((equal? employee-name (name record)) record)
                          (else (get-rcd (cdr records)))))))
         (get-rcd records)))
  ;; 外部とのインターフェース
  (put 'get-name 'tokyo name)
  (put 'get-address 'tokyo address)
  (put 'get-salary 'tokyo salary)
  (put 'make-employee-record 'tokyo make-employee-record)
  (put 'make-company-record 'tokyo make-company-record)
  (put 'get-record 'tokyo get-record)
  'done)

(install-tokyo-company-package)

東京事業所のデータベースを作る。

(define (make-tokyo-employee-record name address salary)
  ((get 'make-employee-record 'tokyo) name address salary))

(define tokyo-db
  ((get 'make-company-record 'tokyo)
   (list
     (make-tokyo-employee-record 'isono 'nakano1-2 150000)
     (make-tokyo-employee-record 'nakajima 'setagaya2-1 250000))))

問題a.

各事業所を識別するためのタイプタグが必要となる。
各事業所に get-record に対応した手続きを用意する。

(define (get-record company-record name)
  ((get 'get-record (type-tag company-record)) company-record name))

(get-record tokyo-db 'isono)
gosh> (isono nakano1-2 150000)
(get-record tokyo-db 'nakajima)
gosh> (nakajima setagaya2-1 250000)
(get-record tokyo-db 'yamada)
gosh> #f

問題b.

各事業所を識別するタイプタグが必要となる。
各事業所に get-salary に対応した手続きを用意する。

(define (get-salary company-record name)
  (let ((employee-record (get-record company-record name)))
       (if employee-record
           ((get 'get-salary (type-tag company-record)) employee-record)
           (error "Not found data -- GET-SALARY: " name))))

(get-salary tokyo-db 'isono)
gosh> 150000
(get-salary tokyo-db 'nakajima)
gosh> 250000
(get-salary tokyo-db 'yamada)
gosh> *** ERROR: Not found data -- GET-SALARY:  yamada

次の問題のために追加の事業所レコードの構造を次のようにする。

; 事業所レコードの構造（大阪事業所）
(type-tag (address phone) (record1) (record2) ...)
(osaka ('nakanoshima2-1 06-5524-88xx) (fuguta 200000 kitaku2-1) (hanazawa 180000 sakai3-2) ...)

; 従業員レコードの構造（大阪事業所）
(name salary address)
(fuguta 200000 kitaku2-1)
(hanazawa 180000 sakai3-2)

大阪事業所のパッケージを用意する。

(define (install-osaka-company-package)
  ;; 内部手続き
  (define (make-employee-record name salary address)
    (list name salary address))
  (define (make-company-record company-address phone record-list)
    (cons 'osaka (cons '(company-address phone) record-list)))
  (define (name record) (car record))
  (define (salary record) (cadr record))
  (define (address record) (caddr record))
  (define (get-record company-record employee-name)
    (let ((records (cdr company-record)))
         (define (get-rcd records)
           (if (null? records)
               #f
               (let ((record (car records)))
                    (cond ((equal? employee-name (name record)) record)
                          (else (get-rcd (cdr records)))))))
         (get-rcd records)))
  ;; 外部とのインターフェース
  (put 'get-name 'osaka name)
  (put 'get-salary 'osaka salary)
  (put 'get-address 'osaka address)
  (put 'make-employee-record 'osaka make-employee-record)
  (put 'make-company-record 'osaka make-company-record)
  (put 'get-record 'osaka get-record)
  'done)

(install-osaka-company-package)

大阪事業所のデータベースを用意する。

(define (make-osaka-employee-recode name salary address)
  ((get 'make-employee-record 'osaka) name salary address))

(define osaka-db
  ((get 'make-company-record 'osaka) 'nakanoshima2-1 '06-5524-88xx
   (list (make-osaka-employee-recode 'fuguta 200000 'kitaku2-1)
         (make-osaka-employee-recode 'hanazawa 180000 'sakai3-2))))

(get-record osaka-db 'fuguta)
gosh> (fuguta 200000 kitaku2-1)
(get-record osaka-db 'hanazawa)
gosh> (hanazawa 180000 sakai3-2)
(get-salary osaka-db 'fuguta)
gosh> 200000
(get-salary osaka-db 'hanazawa)
gosh> 180000

問題.c

(define (find-employee-record whole-record-list name)
  (if (null? whole-record-list)
      (error "Record not Found. -- FIND-EMPLOYEE-RECORD: " name)
      (let ((record-list (car whole-record-list)))
           (let ((record ((get 'get-record (type-tag record-list)) record-list name)))
                (if record
                    record
                    (find-employee-record (cdr whole-record-list) name))))))

(define wrl (list tokyo-db osaka-db))
; ((tokyo (isono nakano1-2 150000) (nakajima setagaya2-1 250000)) (osaka (company-address phone) (fuguta 200000 kitaku2-1) (hanazawa 180000 sakai3-2)))

(find-employee-record wrl 'isono)
gosh> (isono nakano1-2 150000)
(find-employee-record wrl 'nakajima)
gosh> (nakajima setagaya2-1 250000)
(find-employee-record wrl 'fuguta)
gosh> (fuguta 200000 kitaku2-1)
(find-employee-record wrl 'hanazawa)
gosh> (hanazawa 180000 sakai3-2)
(find-employee-record wrl 'namino)
gosh> *** ERROR: Record not Found. -- FIND-EMPLOYEE-RECORD:  namino

問題d.

上で大阪事業所を追加したのと同じようにパッケージを追加する。

計算機プログラムの構造と解釈

posted with amazlet at 08.11.07

ジェラルド・ジェイサスマンジュリーサスマンハロルドエイブルソン
ピアソンエデュケーション
売り上げランキング: 6542

Amazon.co.jp で詳細を見る