Scheme - データによる抽象の構築(抽象データの多重表現(データ主導プログラミングと加法性(異なるデータ構造, レコード, 構造化)))

計算機プログラムの構造と解釈[第2版]
(翔泳社)
ハロルド エイブルソン (著) ジュリー サスマン (著)
ジェラルド・ジェイ サスマン (著)
Harold Abelson (原著) Julie Sussman (原著)
Gerald Jay Sussman (原著) 和田 英一 (翻訳)

開発環境

• OS X Yosemite - Apple (OS)
• Emacs(Text Editor)
• Scheme (プログラミング言語)
• kscheme, Gauche, GNU Guile (処理系)

計算機プログラムの構造と解釈[第2版](ハロルド エイブルソン (著)、ジュリー サスマン (著)、ジェラルド・ジェイ サスマン (著)、Harold Abelson (原著)、Julie Sussman (原著)、Gerald Jay Sussman (原著)、和田 英一 (翻訳)、翔泳社、原書: Structure and Interpretation of Computer Programs (MIT Electrical Engineering and Computer Science)(SICP))の2(データによる抽象の構築)、2.4(抽象データの多重表現)、2.4.3(データ主導プログラミングと加法性)、問題2.74-b.を解いてみる。

その他参考書籍

• Instructor's Manual to Accompany Structure & Interpretation of Computer Programs
• プログラミングGauche (Kahuaプロジェクト (著), 川合 史朗 (監修), オライリージャパン)
• Scheme手習い

問題2.74-b.

コード(Emacs)

(begin
  (newline)
  (define error
    (lambda (message value)
      (display message)
      (display " ")
      (display value)
      (newline)))

  (define print
    (lambda (x)
      (display x)
      (newline)))

  (define equal?
    (lambda (a b)
      (if (and (pair? a) (pair? b))
          (and (eq? (car a) (car b))
               (equal? (cdr a) (cdr b)))
          (eq? a b))))

  (define make-table
    (lambda ()
      (let ((local-table (list (quote *table*))))
        (define assoc
          (lambda (key records)
            (cond ((null? records) #f)
                  ((equal? key (caar records))
                   (car records))
                  (else (assoc key (cdr records))))))
        (define lookup
          (lambda (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!
          (lambda (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)))))
            (quote ok)))
        (define dispatch
          (lambda (m)
            (cond ((eq? m (quote lookup-proc)) lookup)
                  ((eq? m (quote insert-proc!)) insert!)
                  (else (error "Unknown operation -- TABLE" m)))))
        dispatch)))

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

  (define install-division1-package
    (lambda ()
      (define make-record (lambda (name address salary)
                            (list name address salary)))
      (define name (lambda (record) (car record)))
      (define address (lambda (record) (cadr record)))
      (define salary (lambda (record) (caddr record)))
      (define make-personnel-file
        (lambda (records)
          (cons (quote division1) records)))
      (define division (lambda (personnel-file) (car personnel-file)))
      (define records (lambda (personnel-file) (cdr personnel-file)))
      
      (define get-record
        (lambda (personnel-file employee-name)
          (define iter
            (lambda (records)
              (if (null? records)
                  (quote not-found)
                  (let ((record (car records)))
                    (if (eq? (name record) employee-name)
                        record
                        (iter (cdr records)))))))
          (iter (records personnel-file))))
      (define get-salary
        (lambda (name personnel-file)
          (let ((record (get-record personnel-file name)))
            (if (eq? record (quote not-found))
                (quote not-found)
                (salary record)))))

      (put (quote make-record) (quote division1) make-record)
      (put (quote make-personnel-file) (quote division1) make-personnel-file)
      (put (quote division) (quote division1) division)
      (put (quote get-record) (quote division1) get-record)
      (put (quote get-salary) (quote division1) get-salary)
      (quote install-division1-package-done)))

  (define make-record
    (lambda (name address salary division)
      ((get (quote make-record) division) name address salary)))
  (define make-personnel-file
    (lambda (records division)
      ((get (quote make-personnel-file) division) records)))
  (define get-record
    (lambda (name personnel-file division)
      ((get (quote get-record) division)
       personnel-file
       name)))
  (define division (lambda (personnel-file) (car personnel-file)))
  (define get-salary
    (lambda (name personnel-file)
      ((get (quote get-salary) (division personnel-file))
       name personnel-file)))
  
  (print (install-division1-package))
  (define record1 (make-record (quote kamimura1)
                               (quote tokyo)
                               1
                               (quote division1)))
  (define record2 (make-record (quote kamimura2)
                               (quote tokyo)
                               2
                               (quote division1)))
  (define records (list record1 record2))
  (define personnel-file-division1 (make-personnel-file records
                                                        (quote division1)))
  
  (print (get-salary (quote kamimura1)
                     personnel-file-division1))
  (print (get-salary (quote kamimura)
                     personnel-file-division1))
  (print (get-salary (quote kamimura2)
                     personnel-file-division1))
  (quote done))

入出力結果(Terminal(kscheme), REPL(Read, Eval, Print, Loop))

$ kscheme < sample74_b.scm
kscm> 
install-division1-package-done
1
not-found
2
done
kscm> $