計算機プログラムの構造と解釈 第二版 P108 問題2.74

あんまり工夫なく問題をやってみました。
基本的にP106とかの(install-ほにゃらら-package)
を参考にしながら書く。

ポイントとしては、自分なりにデータ形式を想定して作ると解きやすいと思う。

a
はファイルに事業署名とかのタグをつけておけば良い。

b
はレコードにsalaryとかいうタグをつけておけばいいんだろうけど、
問題文にキーをつけた情報を含んでいるって書いてあるし、
そもそも共通の仕様なのかなと思ってあらかじめそんな感じでやってしまった。
あんまり良いコードじゃない。

c
夢とガッツと希望。
まあ何とかなるもんだ。

d
データ構造に対応した、他の事業書と共通の名前の手続きのパッケージも組み込んでおけば良いのではないかな？

実装

#!/usr/local/bin/gosh
;; -*- coding: utf-8 -*-

(use ggc.debug.trace)
(use math.mt-random)


(define nil '())
(define nl newline)
(define disp display)
(define (square x)
  (* x x))


;;; 3.3.3 put & get
(define (make-table)
  (let ((local-table (list '*table*)))
    (define (lookup key-1 key-2)
      (let ((subtable (assoc key-1 (cdr local-table))))
        (if subtable
          (let ((record (assoc key-2 (cdr subtable))))
            (if record
              (cdr record)
              #f))
          #f)))
    (define (insert! key-1 key-2 value)
      (let ((subtable (assoc key-1 (cdr local-table))))
        (if subtable
          (let ((record (assoc key-2 (cdr subtable))))
            (if record
              (set-cdr! record value)
              (set-cdr! subtable
                        (cons (cons key-2 value)
                              (cdr subtable)))))
          (set-cdr! local-table
                    (cons (list key-1
                                (cons key-2 value))
                          (cdr local-table)))))
      'ok)
    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
            ((eq? m 'insert-proc!) insert!)
            (else (error "Unknown operation -- TABLE" m))))
    dispatch))


(define operation-table (make-table))

(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))


;; data with type tag
(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 (install-honbu-package)
  ;;内部手続き
  (define (get-record file name)
    (cond ((null? file) nil)
          ((equal? name (caar (record file)))
           (car (record file)))
          (else (get-record (cdr (record file)) name))))

  (define (record? file)
    (cond ((null? file) #f)
          ((not (pair? (car file))) #f)
          (else #t)))

  (define (record file)
    (if (record? file)
      file
      (cdr file)))


  (define (salary rec)
    (cond ((null? rec) nil)
          ((equal? 'salary (caar (content rec)))
           (cadar (content rec)))
          (else (salary (cdr (content rec))))))

  (define (get-salary file name)
    (salary (get-record file name)))

  (define (content rec)
    (if (pair? (car rec))
      rec
      (cdr rec)))

(define (find-employee-record file name)
  (cond ((null? file) nil)
        ((null? (get-record (car file) name))
         (find-employee-record (cdr file) name))
        (else (get-record (car file) name))))




  ;;システムの他の部分とのインターフェース
  (define (tag x)
    (attach-tag 'honbu x))
  (put 'get-record 'honbu get-record)
  (put 'get-salary 'honbu get-salary)

  (put 'find-employee-record 'honbu find-employee-record)
  'done)



(define honbu-file
  '(honbu (t-uesugi (address sancha) (salary 5)) (s-tanno (address mishuku) (salary 500))))

(define zenjigyosyo-file
  '((honbu (t-uesugi (address sancha) (salary 5)) (s-tanno (address mishuku) (salary 500)))
    (tokyo (unlearned (address shibuya) (salary 2)) (asawanemui (address taishido) (salary 1)))
    (us (lifeloveregret (address sandiego) (salary 1000)))))

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

(define (get-salary file name)
  ((get 'get-salary (type-tag file)) file name))

(define (find-employee-record file name)
  ((get 'find-employee-record 'honbu) file name))




;; main
(define (main args)
  (install-honbu-package)


  (disp "honbu-file: ")
  (disp honbu-file)
  (nl)
  (disp "zenjigyosyo-file ")
  (disp zenjigyosyo-file)
  (nl)

  (disp "(get-record honbu-file 's-tanno): ")
  (disp (get-record honbu-file 's-tanno))
  (nl)

  (disp "(get-salary honbu-file 's-tanno): ")
  (disp (get-salary honbu-file 's-tanno))
  (nl)

  (disp "(find-employee-record zenjigyosyo-file 'lifeloveregret): ")
  (disp (find-employee-record zenjigyosyo-file 'lifeloveregret))
  (nl)

  0)

実行

honbu-file: (honbu (t-uesugi (address sancha) (salary 5)) (s-tanno (address mishuku) (salary 500)))
zenjigyosyo-file ((honbu (t-uesugi (address sancha) (salary 5)) (s-tanno (address mishuku) (salary 500))) (tokyo (unlearned (address shibuya) (salary 2)) (asawanemui (address taishido) (salary 1))) (us (lifeloveregret (address sandiego) (salary 1000))))
(get-record honbu-file 's-tanno): (s-tanno (address mishuku) (salary 500))
(get-salary honbu-file 's-tanno): 500
(find-employee-record zenjigyosyo-file 'lifeloveregret): (lifeloveregret (address sandiego) (salary 1000))

ぐうぬ。