計算機プログラムの構造と解釈[第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.5(汎用演算システム)、2.5.2(異なる型のデータの統合)、問題2.81-a.を解いてみる。
その他参考書籍
- Instructor's Manual to Accompany Structure & Interpretation of Computer Programs
- プログラミングGauche (Kahuaプロジェクト (著), 川合 史朗 (監修), オライリージャパン)
- Scheme手習い
問題2.81-a.
コード(Emacs)
(begin
(define print (lambda (x) (display x) (newline)))
(define error (lambda (message value)
(display message) (display " ") (display value) (newline)))
(define for-each
(lambda (proc items)
(if (not (null? items))
(begin (proc (car items))
(for-each proc (cdr items))))))
(define gcd
(lambda (a b)
(if (= b 0)
a
(gcd b (remainder a b)))))
(define inc (lambda (n) (+ n 1)))
(define square (lambda (x) (* x x)))
(define sqrt
(lambda (x)
(define sqrt-iter
(lambda (guess x)
(if (good-enough? guess x)
guess
(sqrt-iter (improve guess x)
x))))
(define good-enough?
(lambda (guess x)
(< (abs (- (square guess) x)) 0.001)))
(define improve
(lambda (guess x)
(average guess (/ x guess))))
(sqrt-iter 1.0 x)))
(define average (lambda (x y) (/ (+ x y) 2)))
(define abs (lambda (x) (if (< x 0)
(* -1 x)
x)))
(define map
(lambda (proc items)
(if (null? items)
(quote ())
(cons (proc (car items))
(map proc (cdr items))))))
(define accumulate
(lambda (combiner null-value term a next b)
(define inner
(lambda (x result)
(if (> x b)
result
(inner (next x)
(combiner (term x)
result)))))
(inner a null-value)))
(define expt
(lambda (base n)
(define (iter n result)
(if (= n 0)
result
(iter (- n 1)
(* result base))))
(iter n 1)))
(define (factorial n)
(define (iter product counter)
(if (> counter n)
product
(iter (* counter product)
(+ counter 1))))
(iter 1 1))
(define sin
(lambda (x)
(accumulate + 0.0 (lambda (n)
(let ((a (+ (* 2 n) 1)))
(* (/ (expt -1 n)
(factorial a))
(expt x a))))
0 inc 10)))
(define cos
(lambda (x)
(accumulate + 0.0 (lambda (n)
(let ((a (* 2 n)))
(* (/ (expt -1 n)
(factorial a))
(expt x a))))
0 inc 10)))
(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 attach-tag
(lambda (type-tag contents)
(if (eq? type-tag (quote scheme-number))
contents
(cons type-tag contents))))
(define type-tag
(lambda (datum)
(cond ((number? datum) (quote scheme-number))
((pair? datum) (car datum))
(error "Bad tagged datum -- TYPE-TAG" datum))))
(define contents
(lambda (datum)
(cond ((number? datum) datum)
((pair? datum) (cdr datum))
(else error "Bad tagged datum -- CONTENTS" datum))))
(define type-table (make-table))
(define get-coercion (type-table (quote lookup-proc)))
(define put-coercion (type-table (quote insert-proc!)))
(define scheme-number->complex
(lambda (n)
(make-complex-from-real-imag (contents n) 0)))
(define scheme-number->scheme-number (lambda (n) n))
(define complex->complex (lambda (z) z))
(put-coercion (quote scheme-number) (quote scheme-number)
scheme-number->scheme-number)
(put-coercion (quote complex) (quote complex)
complex->complex)
;; 可変個引数の手続きの定義はまだ kscheme に実装してないから、明示的にリストを渡す
(define apply-generic
(lambda (op args)
;; 無限ループすることを確認
(print "apply-generic")
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(if (= (length args) 2)
(let ((type1 (car type-tags))
(type2 (cadr type-tags))
(a1 (car args))
(a2 (cadr args)))
(let ((t1->t2 (get-coercion type1 type2))
(t2->t1 (get-coercion type2 type1)))
(cond (t1->t2
(apply-generic op (list (t1->t2 a1) a2)))
(t2->t1
(apply-generic op (list a1 (t2->t1 a2))))
(else
(error "No method for these types"
(list op type-tags))))))
(error "No method for these types"
(list op type-tags))))))))
(define add (lambda (x y) (apply-generic (quote add) (list x y))))
(define sub (lambda (x y) (apply-generic (quote sub) (list x y))))
(define mul (lambda (x y) (apply-generic (quote mul) (list x y))))
(define div (lambda (x y) (apply-generic (quote div) (list x y))))
(define equ? (lambda (x y) (apply-generic (quote equ?) (list x y))))
(define =zero? (lambda (x) (apply-generic (quote =zero?) (list x))))
(define real-part (lambda (z) (apply-generic (quote real-part) (list z))))
(define imag-part (lambda (z) (apply-generic (quote imag-part) (list z))))
(define magnitude (lambda (z) (apply-generic (quote magnitude) (list z))))
(define angle (lambda (z) (apply-generic (quote angle) (list z))))
(define make-from-real-imag
(lambda (real imag)
((get (quote make-from-real-imag) (quote complex)) real imag)))
(define make-from-mag-ang
(lambda (mag ang)
((get (quote make-from-mag-ang) (quote complex)) mag ang)))
(define install-scheme-number-package
(lambda ()
(put (quote add) (quote (scheme-number scheme-number))
(lambda (x y) (+ x y)))
(put (quote sub) (quote (scheme-number scheme-number))
(lambda (x y) (- x y)))
(put (quote mul) (quote (scheme-number scheme-number))
(lambda (x y) (* x y)))
(put (quote div) (quote (scheme-number scheme-number))
(lambda (x y) (/ x y)))
(put (quote equ?) (quote (scheme-number scheme-number))
(lambda (x y) (= x y)))
(put (quote =zero?) (quote (scheme-number))
(lambda (x) (= x 0)))
(quote done)))
(define install-rational-package
(lambda ()
(define numer car)
(define denom cdr)
(define make-rat
(lambda (n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g)))))
(define add
(lambda (x y)
(make-rat (+ (* numer x) (denom y)
(* (numer y) (denom x)))
(* (denom x) (denom y)))))
(define sub
(lambda (x y)
(make-rat (- (* numer x) (denom y)
(* numer y) (denom y))
(* (denom x) (denom y)))))
(define mul
(lambda (x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y)))))
(define div
(lambda (x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y)))))
(define equ?
(lambda (x y)
(and (= (numer x) (numer y))
(= (denom x) (denom y)))))
(define =zero?
(lambda (x)
(and (= (numer x) 0))))
(define tag
(lambda (x) (attach-tag (quote rational) x)))
(put (quote add) (quote (rational rational))
(lambda (x y) (tag (add x y))))
(put (quote sub) (quote (rational rational))
(lambda (x y) (tag (sub x y))))
(put (quote mul) (quote (rational rational))
(lambda (x y) (tag (mul x y))))
(put (quote div) (quote (rational rational))
(lambda (x y) (tag (div x y))))
(put (quote make) (quote rational)
(lambda (n d) (tag (make-rat n d))))
(put (quote equ?) (quote (rational rational)) equ?)
(put (quote =zero?) (quote (rational)) =zero?)
(quote done)))
(define make-rational
(lambda (n d)
((get (quote make) (quote rational)) n d)))
(define install-rectangular-package
(lambda ()
(define real-part (lambda (z) (car z)))
(define imag-part (lambda (z) (cdr z)))
(define make-from-real-imag (lambda (x y) (cons x y)))
(define magnitude
(lambda (z)
(sqrt (+ (square (real-part z))
(square (imag-part z))))))
(define angle
(lambda (z)
(atan (imag-part z) (real-part z))))
(define make-from-mag-ang
(lambda (r a)
(cons (* r (cos a)) (* r (sin a)))))
(define equ?
(lambda (z1 z2)
(and (= (real-part z1) (real-part z2))
(= (imag-part z1) (imag-part z2)))))
(define =zero?
(lambda (z) (and (= (real-part z) 0)
(= (imag-part z) 0))))
(define tag (lambda (x) (attach-tag (quote rectangular) x)))
(put (quote real-part) (quote (rectangular)) real-part)
(put (quote imag-part) (quote (rectangular)) imag-part)
(put (quote magnitude) (quote (rectangular)) magnitude)
(put (quote angle) (quote (rectangular)) angle)
(put (quote make-from-real-imag) (quote rectangular)
(lambda (x y) (tag (make-from-real-imag x y))))
(put (quote make-from-mag-ang) (quote rectangular)
(lambda (r a) (tag (make-from-mag-ang r a))))
(put (quote equ?) (quote (rectangular rectangular)) equ?)
(put (quote =zero?) (quote (rectangular)) =zero?)
(quote done)))
(define install-polar-package
(lambda ()
(define magnitude (lambda (z) (car z)))
(define angle (lambda (z) (cdr z)))
(define make-from-mag-ang (lambda (r a) (cons r a)))
(define real-part
(lambda (z)
(* (magnitude z) (cos (angle z)))))
(define imag-part
(lambda (z)
(* (magnitude z) (sin (angle z)))))
(define make-from-real-imag
(lambda (x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x))))
(define equ?
(lambda (z1 z2)
(and (= (real-part z1) (real-part z2))
(= (imag-part z1) (imag-part z2)))))
(define =zero?
(lambda (z)
(and (= (real-part z) 0)
(= (imag-part z) 0))))
(define tag (lambda (x) (attach-tag (quote polar) x)))
(put (quote real-part) (quote (polar)) real-part)
(put (quote imag-part) (quote (polar)) imag-part)
(put (quote magnitude) (quote (polar)) magnitude)
(put (quote angle) (quote (polar)) angle)
(put (quote make-from-real-imag) (quote polar)
(lambda (x y) (tag (make-from-real-imag x y))))
(put (quote make-from-mag-ang) (quote polar)
(lambda (r a) (tag (make-from-mag-ang r a))))
(put (quote equ?) (quote (polar polar)) equ?)
(put (quote =zero?) (quote (polar)) =zero?)
(quote done)))
(define install-complex-package
(lambda ()
(define make-from-real-imag
(lambda (x y)
((get (quote make-from-real-imag) (quote rectangular)) x y)))
(define make-from-mag-ang
(lambda (r a)
((get (quote make-from-mag-ang) (quote polar)) r a)))
(define add-complex
(lambda (z1 z2)
(make-from-real-imag (+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2)))))
(define sub-complex
(lambda (z1 z2)
(make-from-real-imag (- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2)))))
(define mul-complex
(lambda (z1 z2)
(make-from-mag-ang (* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2)))))
(define div-complex
(lambda (z1 z2)
(make-from-mag-ang (/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2)))))
(define equ?
(lambda (z1 z2)
(and (= (real-part z1) (real-part z2))
(= (imag-part z1) (imag-part z2)))))
(define =zero?
(lambda (z)
(and (= (real-part z) 0)
(= (imag-part z) 0))))
(define tag (lambda (z) (attach-tag (quote complex) z)))
(put (quote add) (quote (complex complex))
(lambda (z1 z2) (tag (add-complex z1 z2))))
(put (quote sub) (quote (complex complex))
(lambda (z1 z2) (tag (sub-complex z1 z2))))
(put (quote mul) (quote (complex complex))
(lambda (z1 z2) (tag (mul-complex z1 z2))))
(put (quote div) (quote (complex complex))
(lambda (z1 z2) (tag (div-complex z1 z2))))
(put (quote make-from-real-imag) (quote complex)
(lambda (x y) (tag (make-from-real-imag x y))))
(put (quote make-from-mag-ang) (quote complex)
(lambda (r a) (tag (make-from-mag-ang r a))))
(put (quote real-part) (quote (complex)) real-part)
(put (quote imag-part) (quote (complex)) imag-part)
(put (quote magnitude) (quote (complex)) magnitude)
(put (quote angle) (quote (complex)) angle)
(put (quote equ?) (quote (complex complex)) equ?)
(put (quote =zero?) (quote (complex)) =zero?)
(quote done)))
(install-scheme-number-package)
(install-rational-package)
(install-rectangular-package)
(install-polar-package)
(install-complex-package)
;; 型で表に見つからない手続きに対して呼び出されると、同じ型への強制型変換が見つかって、
;; 再帰的に同じ型で型でひょうに見つからない手続きを探すことになり、循環する
(define exp (lambda (x y) (apply-generic (quote exp) (list x y))))
(put (quote exp) (quote (scheme-number scheme-number))
(lambda (x y) (attach-tag (quote scheme-number) (expt x y))))
(define z1 (make-from-real-imag 1 2))
(define z2 (make-from-real-imag 3 4))
(print (exp (attach-tag (quote scheme-number) 2)
(attach-tag (quote scheme-number) 10)))
;; 手続きを探す -> 見つからない ->
;; 複素数(complex) を 複素数に強制型変換する手続きを見つける(t1->t2) ->
;; 強制型変換 -> apply-generic 手続き -> 最初に戻る ・・・無限ループ
(print (exp z1 z2))
(quote done))
入出力結果(Terminal(kscheme), REPL(Read, Eval, Print, Loop))
$ kscheme sample81_a.scm apply-generic 1024 apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic apply-generic C-c C-c $
0 コメント:
コメントを投稿