直行形式と極形式
;実部と虚部
(make-from-real-imag (real-part z) (imag-part z))
; 絶対値と偏角
(make-from-mag-ang (magnitude z) (angle z))
(define (add-complex z1 z2)
(make-from-real-imag
(+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag
(- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang
(* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang
(/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
; 実部と虚部で実装
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-real-imag x y) (cons x y))
(define (make-from-mag-ang r a) (cons (* r (cos a)) (* r (sin a))))
; 絶対値と偏角で実装
(define (real-part z) (* (magnitude z) (cos (angle z))))
(define (imag-part z) (* (magnitude z) (sin (angle z))))
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
(define (make-from-mag-ang r a) (cons r a))
2.4.2 タグ付きデータ
; Type tag とContents手続き
(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)
これらの手続きを使って、直交形式と極形式をそれぞれ識別する述語 rectangular?,
polar? を定義
; 直行形式と極形式を識別するタグ
(define (rectangular? z)
(eq? (type-tag z) 'rectangular))
(define (polar? z)
(eq? (type-tag z) 'polar))
2.4.1の手続きをタグを使ったものに修正
; 直行形式
(define (real-part-rectangular z) (car z))
(define (imag-part-rectangular z) (cdr z))
(define (magnitude-rectangular z)
(sqrt (+
(square (real-part-rectangular z))
(square (imag-part-rectangular z)))))
(define (angle-rectangular z)
(atan
(imag-part-rectangular z)
(real-part-rectangular z)))
(define (make-from-real-imag-rectangular x y)
(attach-tag 'rectangular (cons x y)))
(define (make-from-mag-ang-rectangular r a)
(attach-tag 'rectangular (cons (* r (cos a)) (* r (sin a)))))
; 極形式
(define (real-part-polar z)
(* (magnitude-polar z) (cos (angle-polar z))))
(define (imag-part-polar z)
(* (magnitude-polar z) (sin (angle-polar z))))
(define (magnitude-polar z) (car z))
(define (angle-polar z) (cdr z))
(define (make-from-real-imag-polar x y)
(attach-tag 'polar
(cons (sqrt (+ (square x) (square y)))
(atan y x))))
(define (make-from-mag-ang-polar r a)
(attach-tag 'polar (cons r a)))
(define (make-from-real-imag x y)
(make-from-real-imag-rectangular x y))
それぞれの手続きが、タグを確認して必要な手続きを行う
; 手続きでタグを確認する
(define (real-part z)
(cond
((rectangular? z) (real-part-rectangular (contents z)))
((polar? z) (real-part-polar (contents z)))
(else (error "Unknown type: REAL-PART" z))))
(define (imag-part z)
(cond
((rectangular? z) (imag-part-rectangular (contents z)))
((polar? z) (imag-part-polar (contents z)))
(else (error "Unknown type: IMAG-PART" z))))
(define (magnitude z)
(cond
((rectangular? z) (magnitude-rectangular (contents z)))
((polar? z) (magnitude-polar (contents z)))
(else (error "Unknown type: MAGNITUDE" z))))
(define (angle z)
(cond
((rectangular? z) (angle-rectangular (contents z)))
((polar? z) (angle-polar (contents z)))
(else (error "Unknown type: ANGLE" z))))
2.4.3 データ主導プログラミングと加法性
データの型をチェックし適切な手続きを呼ぶ一般的な戦略は型によるディスパ
ッチ (dispatching on type) と呼ばれる
これによる弱点
- 型が増えたときに手続きは全ての型を知る必要がある
- 型が増えたときに名前空間を衝突させられない
==> データ主導プログラミングというテクニック
２つの手続き
(put ⟨op⟩ ⟨type⟩ ⟨item⟩) は、テーブルの ⟨op⟩ と ⟨type⟩ が指すところに
⟨item⟩ を入れる。
(get ⟨op⟩ ⟨type⟩) は、テーブルから ⟨op⟩, ⟨type⟩ の項目を検索し、そこ
で見つかった項目を返す。見つからなければ、get は false を返す。
Ex 2.73
(print "===Ex 2.73===")
; 必要そうなのもってきた
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
(define (=number? exp num)
(and (number? exp) (= exp num)))
(define (deriv exp var)
(cond
((number? exp) 0)
((variable? exp)
(if (same-variable? exp var) 1 0))
((sum? exp)
(make-sum
(deriv (addend exp) var)
(deriv (augend exp) var)))
((product? exp)
(make-sum
(make-product
(multiplier exp)
(deriv (multiplicand exp) var))
(make-product
(deriv (multiplier exp) var)
(multiplicand exp))))
;⟨more rules can be added here⟩
(else (error "unknown expression type: DERIV" exp))))
;このプログラムは、微分する式の型によってディスパッチを実行
;していると捉えることもできる。この場合、データの “タイプタグ” は代数演算記号 (+ など) で、行う演算は deriv ということになる。
;基本的な微分を行う手続きを次のように書き直すと、プログラムをデータ主導スタイルに変形できる。
(define (deriv exp var)
(cond
((number? exp) 0)
((variable? exp)
(if (same-variable? exp var) 1 0))
(else
((get 'deriv (operator exp)) (operands exp) var))))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
; put/get の実装 by hioさん
(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)
(error "no such object: GET:" key))
((equal? key (car (car rest)))
(cdr (car rest)))
(else
(iter key (cdr rest)))))
(iter (cons op type) registory))
a.
上で何をしているか説明せよ。手続き number? と variable?は、
なぜデータ主導ディスパッチとして取り込むことができないのだろうか。
現状の実装では数値や変数をpairでタグをつけて表現していないから。
b.
上記実装を実現できるようにするためのコード
和と積の実装
;和の実装
;((sum? exp)
; (make-sum
; (deriv (addend exp) var)
; (deriv (augend exp) var)))
(define (install-sum-package)
(define (addend s) (car s))
(define (augend s) (cadr s))
(define (make-sum a1 a2) ;;2.3.2あたり
(cond
((=number? a1 0) a2)
((=number? a2 0) a1)
((and (number? a1) (number? a2)) (+ a1 a2))
(else (list '+ a1 a2))))
(define (deriv-sum exp var)
(make-sum
(deriv (addend exp) var)
(deriv (augend exp) var)))
;; インタフェース
(put 'make '+ make-sum)
(put 'deriv '+ deriv-sum)
'done)
;((product? exp)
; (make-sum
; (make-product
; (multiplier exp)
; (deriv (multiplicand exp) var))
; (make-product
; (deriv (multiplier exp) var)
; (multiplicand exp))))
(define (install-product-package)
; install-sum-packageに依存している
(define (multiplier s) (car s))
(define (multiplicand s) (cadr s))
(define (make-product m1 m2)
(cond
((or (=number? m1 0) (=number? m2 0)) 0)
((=number? m1 1) m2)
((=number? m2 1) m1)
((and (number? m1) (number? m2)) (* m1 m2))
(else
(list '* m1 m2))))
(define (deriv-product exp var)
(print "multiplier" (multiplier exp))
(print "multiplicand" (multiplicand exp))
((get 'make '+)
(make-product
(multiplier exp)
(deriv (multiplicand exp) var))
(make-product
(deriv (multiplier exp) var)
(multiplicand exp))))
; インタフェース
(put 'make '* make-product)
(put 'deriv '* deriv-product)
'done)
;; install
(install-sum-package)
(install-product-package)
;; test
(print ((get 'make '+) 1 3)) ; 4
(define prod-sample ((get 'make '*) 'x 'y))
(print (deriv prod-sample 'x)) ;y
c.指数の実装
(define (install-exponentiation-package)
; install-sum-packageに依存している
(define (base v) (car v))
(define (exponent v) (cadr v))
(define (make-exponentiation base exponent)
(cond
((=number? exponent 0) 1)
((=number? exponent 1) base)
((and (number? base) (number? exponent)) (expt base exponent))
(else (list '** base exponent))))
(define (exponentiation? v)
(and (pair? v) (eq? '** (car v))))
(define (deriv-exponentiation exp var)
((get 'make '*)
((get 'make '*)
(exponent exp)
(make-exponentiation (base exp) (- (exponent exp) 1)))
(deriv (base exp) var)))
; インタフェース
(put 'make '** make-exponentiation)
(put 'deriv '** deriv-exponentiation)
'done)
(print "===c: exponentiation===")
(install-exponentiation-package)
(print (deriv '(** x 2) 'x)) ; (* 2 x)
Ex 2.74
問題：
事務所ファイルはすべて Scheme のデータ構造として実装されているのに、
使われている個々のデータ構造は事業所ごとに違う.
各事業所の人事記録は単独のファイルからなり、
従業員の名前をキーとしたレコードの集合を持っているとする。
集合の構造は事業所ごとに異なる。さらに、各従業員のレコードはそれ自身が (事業所ごとに異なる構造を持つ) 集合で、addressとsalary のような識別子をキーとした情報を含んでいるとする。
A社とB社のデータがそれぞれあるとする。
;; サンプルデータ
(define (make-employee-record-A name salary address)
(list name salary address))
(define A-employees
(list
(make-employee-record-A "a1" 500 1)
(make-employee-record-A "a2" 600 2)
)
)
;; B社
(define (make-employee-record-B name address salary)
(list name address salary))
(define B-employees
(list
(make-employee-record-B "b1" 11 700)
(make-employee-record-B "b2" 12 400)
)
)
(print "A-employees: " A-employees)
(print "B-employees: " B-employees)
これを本部側でいじることはできない。
まずは下準備
;; 0, nilの定義
(define nil '())
;; 1. 事業所の定義
(define offices (list 'A 'B))
;; 2.各要素のgetterを定義
(define (install-A-data)
(define (get-name record)
(car record))
(define (get-salary record)
(cadr record))
(put 'get-name 'A get-name)
(put 'get-salary 'A get-salary)
'done)
(define (install-B-data)
(define (get-name record)
(car record))
(define (get-salary record)
(caddr record))
(put 'get-name 'B get-name)
(put 'get-salary 'B get-salary)
'done)
a. 任意の事業所を指定する get-record 手続きを本部向けに実装せよ。
(print "--a--")
(install-A-data)
(install-B-data)
(define (get-record data tag name)
(if
(null? data)
nil
(let
((record (car data)))
(if
(string=? ((get 'get-name tag) record) name)
(attach-tag tag record)
(get-record (cdr data) tag name))
)
)
)
(print "get-record: " (get-record A-employees 'A "a1"))
(print "get-record: " (get-record B-employees 'B "a1"))
;;get-record: (A a1 500 1)
;;get-record: ()
b. 任意の事業所の職員のレコードから給与情報を返す get-salary 手続きを本部向けに実装せよ。
(print "--b--")
(define (get-salary record tag)
((get 'get-salary (type-tag record)) (contents record))
)
(define record-A (get-record A-employees 'A "a1"))
(print "get-salary A: " (get-salary record-A))
(define record-B (get-record B-employees 'B "b1"))
(print "get-salary B: " (get-salary record-B))
;; get-salary A: 500
;; get-salary B: 700
c. find-employee-record 手続きを実装せよ。
全事業所のファイルから与えられた従業員を検索し、該当レコードを返す。
引数として、従業員名と全事業所のファイルのリストを取るとせよ。
;; 事業所リストを作る
(print "--c--")
(define office-employees
(list
(list 'A A-employees)
(list 'B B-employees)
)
)
(define (find-employee-record name office-employees-list)
(if
(null? office-employees-list)
nil
(let
((data (car office-employees-list)))
(let
((record (get-record (cadr data) (car data) name)))
(if
(null? record)
(find-employee-record name (cdr office-employees-list))
record
)
)
)
)
)
(print "find-employee-record: " (find-employee-record "b1" office-employees))
d. 新しい事業所が増えたときにすること
- (install-XX-data)と同様の、要素のwrapperを定義
- office-employees (c.より)に事業所リストを追加する
メッセージパッシング
(define (make-from-real-imag x y)
(define (dispatch op)
(cond
((eq? op 'real-part) x)
((eq? op 'imag-part) y)
((eq? op 'magnitude) (sqrt (+ (square x) (square y))))
((eq? op 'angle) (atan y x))
(else (error "Unknown op: MAKE-FROM-REAL-IMAG" op))))
dispatch)
(define (apply-generic op obj) (obj op))
Ex 2.75
コンストラクタ make-from-mag-ang をメッセージパッシングスタイルで実装せよ。
(print "==Ex.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-REAL-IMAG" op)))
)
dispatch)
(define mag-ang-obj1 (make-from-mag-ang 10 5))
(print (apply-generic 'real-part mag-ang-obj1)) ;2.836621854632263
(print (apply-generic 'magnitude mag-ang-obj1)) ;10
Ex 2.76
ジェネリック演算を使った⼤きなシステムが発展するにつれ、新しいデータオブジェクトの型や新しい演算が必要になることがある。
三つの戦略 (明⽰的ディスパッチによるジェネリック演算、データ主導スタイル、メッセージパッシングスタイル) それぞれについて、新しい型や新しい演算を追加するために必要な変更を記述せよ。
新しい型がよく追加されるシステムでは、どの組み⽴て⽅が最も適しているだろうか。
新しい演算を追加するシステムでは、どれが最も適しているだろうか。
ジェネリック演算
演算 ●----∈ 型
データ主導スタイル
型 ●----∈ 演算
メッセージパッシング
型 ●----∈ 演算
なので、
| タイプ | 型の追加に必要な作業 | 演算の追加に必要な作業 |
|---|---|---|
| 明⽰的ディスパッチ | 全ての演算に新規の型での挙動を追加 | 演算をそのまま１つ追加 |
| データ主導 | 型をそのまま１つ追加 | 全ての方にその演算の挙動を追加 |
| メッセージパッシング | 型をそのまま１つ追加 | 全ての方にその演算の挙動を追加 |
新規の型が追加されることが多い場合: データ主導/メッセージパッシング
新規に演算の追加が多い場合: 明⽰的ディスパッチ
ただ データ主導スタイルは、
演算 ●----∈ 型
みたいな実装も可能な気がする。
でもそうすると「データ主導」じゃなくなるか。