計算機プログラムの構造と解釈[第2版]
(翔泳社)
ハロルド エイブルソン (著) ジュリー サスマン (著)
ジェラルド・ジェイ サスマン (著)
Harold Abelson (原著) Julie Sussman (原著)
Gerald Jay Sussman (原著) 和田 英一 (翻訳)
開発環境
- OS X Yosemite - Apple (OS)
- Emacs(Text Editor)
- Scheme (プログラミング言語)
- kscheme, Gauche, MIT/GNU Scheme, 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.82.を解いてみる。
その他参考書籍
- Instructor's Manual to Accompany Structure & Interpretation of Computer Programs
- プログラミングGauche (Kahuaプロジェクト (著), 川合 史朗 (監修), オライリージャパン)
- Scheme手習い
問題2.82.
コード(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) (cons type-tag contents)))
(define type-tag
(lambda (datum)
(if (pair? datum)
(car datum)
(error "Bad tagged datum -- TYPE-TAG" datum))))
(define contents
(lambda (datum)
(if (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->rational
(lambda (n) (make-rational (contents n) 1)))
(put-coercion (quote scheme-number) (quote complex) scheme-number->complex)
(put-coercion (quote scheme-number) (quote rational) scheme-number->rational)
;; b. 同じ型の引数の強制型変換について何かをすべきだというLouis は正しくない
;; 可変個引数の手続きの定義はまだ kscheme に実装してないから、明示的にリストを渡す
(define apply-generic
(lambda (op args)
(let ((type-tags (map type-tag args)))
(define iter1
(lambda (args types type)
(if (null? args)
(quote ())
(let ((t (type-tag (car args))))
(if (eq? t type)
(cons (car args) (iter1 (cdr args) (cdr types) type))
(let ((t->type (get-coercion t type)))
(if t->type
(cons (t->type (car args))
(iter1 (cdr args) (cdr types) type))
(quote ()))))))))
(define iter
(lambda (args types)
(if (null? types)
(error "No method for these types"
(list op type-tags))
(let ((type (car types)))
(let ((args1 (iter1 args types type)))
(if (= (length args) (length args1))
(let ((proc (get op (map type-tag args1))))
(if proc
(apply proc (map contents args1))
(iter args (cdr types))))
(iter args (cdr types))))))))
(iter args 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 mul3 (lambda (x y z) (apply-generic (quote mul3) (list x y z))))
(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 ()
(define tag (lambda (x) (attach-tag (quote scheme-number) x)))
(put (quote add) (quote (scheme-number scheme-number))
(lambda (x y) (tag (+ x y))))
(put (quote sub) (quote (scheme-number scheme-number))
(lambda (x y) (tag (- x y))))
(put (quote mul) (quote (scheme-number scheme-number))
(lambda (x y) (tag (* x y))))
(put (quote div) (quote (scheme-number scheme-number))
(lambda (x y) (tag (/ 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)))
(put (quote exp) (quote (scheme-number scheme-number))
(lambda (x y) (tag (expt x y))))
(put (quote make) (quote scheme-number)
(lambda (x) (tag x)))
(quote done)))
(define make-scheme-number
(lambda (n) ((get (quote make) (quote scheme-number)) n)))
(define exp (lambda (x y) (apply-generic (quote exp) (list x y))))
(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 mul3
(lambda (x y z)
(make-rat (* (* (numer x) (numer y))
(numer z))
(* (* (denom x) (denom y))
(denom z)))))
(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 mul3) (quote (rational rational rational))
(lambda (x y z) (tag (mul3 x y z))))
(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 r1 (make-rational 1 2))
(define r2 (make-rational 3 4))
(define r3 (make-rational 5 6))
(print (mul3 r1 r2 r3)) ; 1/2 * 3/4 * 5/6 = 5/16
(print (mul3 r1 r2 (make-scheme-number 10))) ; 1/2 * 3/4 * 10 = 15/4
(print (mul3 r1 (make-scheme-number 10) r3)) ; 1/2 * 10 * 5/6 = 25/6
(print (mul3 (make-scheme-number 10) r2 r3)) ; 10 * 3/4 * 5/6 = 25/4
(quote done))
;; 出力結果が意図した通りではなかった。。kscheme の実装に問題があるっぽい.
;; ただ、Gauche でもエラーが発生したから、この scheme のコード自体にも問題があるかも。
;; とりあえず先に進むことに。
;; この戦略は、拡大型に高めるのではなく、降ろすことにより演算できる場合は、まだ十分に一般的ではない。
入出力結果(Terminal(kscheme), REPL(Read, Eval, Print, Loop))
$ kscheme sample82.scm (rational 5/16 . 1) (rational 15/4 . 1) (rational 25/6 . 1) (rational 25/4 . 1) done $ gosh sample82.scm (rational 5 . 16) (rational 15 . 4) (rational 25.0 . 6.0) gosh: "error": pair required, but got () $
0 コメント:
コメントを投稿