練習問題 2.74
ex-2.74. 各事業所のもつ人事情報の統合.
事務所ファイルはすべて Scheme のデータ構造として実装されているのに、使われている個々のデータ構造は事業所ごとに違うのだ。事業所長会議が急遽開かれ、事業所の独立性これまで通りに保ったままで、本部の要求を満たせるようにファイルを統合する戦略を探ることになった。
と設問の文章にはあったけれど, 「独立性をこれまで通りに保つ」というのは, 「個々のデータ構造は事業所毎に違う」ことを維持することというわけではない?
例として、各事業所の人事記録は単独のファイルからなり、従業員の名前をキーとしたレコードの集合を持っているとする。集合の構造は事業所ごとに異なる。さらに、各従業員のレコードはそれ自身が (事業所ごとに異なる構造を持つ) 集合で、
addressとsalaryのような識別子をキーとした情報を含んでいるとする。
すべての事業所でレコード情報が「addrss と salary のような識別子をキーとした情報を含んでいる」のならすべての事業所で同じ構造と言えるので, 「(レコードはそれ自身が) 事業所ごとに異なる構造を持つ」とは矛盾してると思うのだけれど…
ex-2.74 (a) get-record 手続きの実装
指定した人事ファイルから指定した従業員のレコードを取得する
get-record手続きを本部向けに実装せよ。この手続きは、任意の事業所のファイルに適用できる必要がある。個々の事業所のファイルはどのように構造化しなければならないか説明せよ。具体的には、どのような型情報を提供する必要があるだろうか。
まず外部ファイルをインタプリタ上に読み込む方法がいままで出てない気がする…?
個々の事業所名を型名として扱い, 本部で使用したい操作に対して個々の事業所のファイルからレコード情報と同時に操作用関数も登録する必要がある.
事業所名の一覧を all-divisions に定義し,
対応するファイル名の一覧を all-files に定義する.
(cons-cell の一覧を元データにして必要分を抜き出す関数にすればよかった…)
apply-generic の構造から, (get 'get-record '事業所名) で取り出せるような操作用関数を登録する必要がある.
そしてその関数からは (attach-tag '事業所名 record) とした値を返す必要がある.
ただ今回は (c) にてほぼ同等の find-employee-record 手続きを実装することになるため, それと重複する get-record の各事業所用の実装は省略してしまうことにする.
ex-2.74 (a) get-record 手続きの実装: 実装
今回は各事業所別にファイルを分割して用意してみた.
用意したファイルは "ins-alice.scm" と "inc-bob.scm" の 2 つ.
それに本部用に "ins-master.scm" も加えて全部で 3 つ.
(b) 本部向けの get-salary 手続きを実装と (c) 本部向けの find-employee-record 手続きを実装もまとめて実装してある.
; [ex-2.74.scm]
;
(define (ex-2.74)
(for-each load all-files)
(newline)
(print "(get-record \"Alice\" 'alice-div)")
(print ";==> " (get-record "Alice" 'alice-div))
(print "(get-salary (get-record \"Alice\" 'alice-div))")
(print ";==> " (get-salary (get-record "Alice" 'alice-div)))
(newline)
(print "(get-record \"Bob\" 'bob-div)")
(print ";==> " (get-record "Bob" 'bob-div))
(print "(get-salary (get-record \"Bob\" 'bob-div))")
(print ";==> " (get-salary (get-record "Bob" 'bob-div)))
(newline)
(print "(find-employee-record \"Alice\" all-divisions)")
(print ";==> " (find-employee-record "Alice" all-divisions))
(print "(find-employee-record \"Bob\" all-divisions)")
(print ";==> " (find-employee-record "Bob" all-divisions))
(print "(find-employee-record \"Carol\" all-divisions)")
(print ";==> " (find-employee-record "Carol" all-divisions))
#t)
(load "./ins-master")
(define all-divisions (list 'alice-div 'bob-div))
(define all-files (list "ins-alice" "ins-bob"))
本部用:
(define (get-record name division)
(let
((maybe-record ((get 'find-employee-record division) name)))
(if
maybe-record
maybe-record ; just a record.
(error "No such employee:" name))))
(define (get-salary record)
(apply-generic 'get-salary record))
(define (find-employee-record name all-divisions)
(define (iter name rest)
(cond
((null? rest)
#f)
(else
(let
((maybe-record ((get 'find-employee-record (car rest)) name)))
(if
maybe-record
maybe-record ; just a record.
(iter name (cdr rest)))))))
(iter name all-divisions))
; {{{ type-tag. sec-2.4.2 より.
(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)))
; }}} type-tag. sec-2.4.2 より.
; {{{ get/put. sec-2.4.3 より.
(define registory '())
(define (put op type item)
(let ((key (cons op type)))
(let ((pair (cons key item)))
(set! registory (cons pair registory)))))
(define (get op type)
(define (iter key rest)
(cond
((null? rest)
#f)
((equal? key (car (car rest)))
(cdr (car rest)))
(else
(iter key (cdr rest)))))
(iter (cons op type) registory))
(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))))))
; }}} get/put. sec-2.4.3 より.
事業所 Alice:
(define (install-ins-alice)
(define data
(list
(cons "Alice" (list (cons 'address "Tokyo") (cons 'salary 100)))
))
(define (find-employee-record name)
(define (iter name rest)
(cond
((null? rest)
#f)
((equal? name (car (car rest)))
(car rest))
(else
(iter name (cdr rest)))))
(iter name data))
(define (get-salary record)
(define (iter rest)
(cond
((null? rest)
(error "no salary field" record))
((eq? (car (car rest )) 'salary)
(cdr (car rest)))
(else
(iter (cdr rest)))))
(iter (cdr record)))
(define (attach-tag-or-false thing)
(cond
(thing (attach-tag 'alice-div thing))
(else #f)))
(put 'find-employee-record 'alice-div
(lambda (name) (attach-tag-or-false (find-employee-record name))))
(put 'get-salary (list 'alice-div)
(lambda (record) (get-salary record))))
(install-ins-alice)
事業所 Bob
(define (install-ins-bob)
(define data
(list
; name, address, salary.
(list "Bob" "Osaka" 200)
))
(define (find-employee-record name)
(define (iter name rest)
(cond
((null? rest)
#f)
((equal? name (car (car rest)))
(car rest))
(else
(iter name (cdr rest)))))
(iter name data))
(define (get-salary record)
(caddr record))
(define (attach-tag-or-false thing)
(cond
(thing (attach-tag 'bob-div thing))
(else #f)))
(put 'find-employee-record 'bob-div
(lambda (name) (attach-tag-or-false (find-employee-record name))))
(put 'get-salary (list 'bob-div)
(lambda (record) (get-salary record))))
(install-ins-bob)
ex-2.74 (a) get-record 手続きの実装: 実行結果
gosh> (ex-2.74)
(get-record "Alice" 'alice-div)
;==> (alice-div Alice (address . Tokyo) (salary . 100))
(get-salary (get-record "Alice" 'alice-div))
;==> 100
(get-record "Bob" 'bob-div)
;==> (bob-div Bob Osaka 200)
(get-salary (get-record "Bob" 'bob-div))
;==> 200
(find-employee-record "Alice" all-divisions)
;==> (alice-div Alice (address . Tokyo) (salary . 100))
(find-employee-record "Bob" all-divisions)
;==> (bob-div Bob Osaka 200)
(find-employee-record "Carol" all-divisions)
;==> #f
ex-2.74 (b) 本部向けの get-salary 手続きを実装
(a) にて実装済みなのでそちらを参照.
ex-2.74 (c) 本部向けの find-employee-record 手続きを実装
(a) にて実装済みなのでそちらを参照.
ex-2.74 (d) 新しい事業所が増えた場合に必要な手順
全事業所の一覧 (
all-divisions及びall-files) に追加.新しい事業所に対する
find-employee及びget-salary手続きを登録.
の 2 点を行えばよい.
せっかくなので Carol 事業所追加してみればよかった・ω・`