計算機プログラムの構造と解釈[第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.83.を解いてみる。
その他参考書籍
- Instructor's Manual to Accompany Structure & Interpretation of Computer Programs
- プログラミングGauche (Kahuaプロジェクト (著), 川合 史朗 (監修), オライリージャパン)
- Scheme手習い
問題2.83.
コード(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)
(cond ((pair? datum) (car datum))
(error "Bad tagged datum -- TYPE-TAG" datum))))
(define contents
(lambda (datum)
(cond ((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 integer->complex
(lambda (n)
(make-complex-from-real-imag (contents n) 0)))
;; b. 同じ型の引数の強制型変換について何かをすべきだというLouis は正しくない
;; 可変個引数の手続きの定義はまだ kscheme に実装してないから、明示的にリストを渡す
(define apply-generic
(lambda (op args)
(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)))
;; c. 同じ型の引数については強制型変換を試みない
(if (eq? type1 type2)
(error "No method for these types"
(list op type-tags))
(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 raise
(lambda (x) (apply-generic (quote raise) (list x))))
(define install-integer-package
(lambda ()
(define tag (lambda (x) (attach-tag (quote integer) x)))
(define raise (lambda (n) (make-rational n 1)))
(put (quote make) (quote integer) (lambda (n) (tag n)))
(put (quote raise) (quote (integer)) raise)
(put (quote add) (quote (integer integer))
(lambda (x y) (tag (+ x y))))
(put (quote sub) (quote (integer integer))
(lambda (x y) (tag (- x y))))
(put (quote mul) (quote (integer integer))
(lambda (x y) (tag (* x y))))
(put (quote div) (quote (integer integer))
(lambda (x y) (tag (/ x y))))
(put (quote equ?) (quote (integer integer))
(lambda (x y) (= x y)))
(put (quote =zero?) (quote (integer))
(lambda (x) (= x 0)))
(put (quote exp) (quote (integer integer))
(lambda (x y) (tag (expt x y))))
(quote done)))
(define make-integer
(lambda (n)
((get (quote make) (quote integer)) 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 raise
(lambda (x)
(make-real (* 1.0 (/ (numer x)
(denom x))))))
(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 raise) (quote (rational)) raise)
(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-real-package
(lambda ()
(define tag (lambda (x) (attach-tag (quote real) x)))
(define raise (lambda (x) (make-from-real-imag x 0)))
(put (quote make) (quote real) (lambda (n) (tag n)))
(put (quote raise) (quote (real)) raise)
(put (quote add) (quote (real real))
(lambda (x y) (tag (+ x y))))
(put (quote sub) (quote (real real))
(lambda (x y) (tag (- x y))))
(put (quote mul) (quote (real real))
(lambda (x y) (tag (* x y))))
(put (quote div) (quote (real real))
(lambda (x y) (tag (/ x y))))
(put (quote equ?) (quote (real real))
(lambda (x y) (= x y)))
(put (quote =zero?) (quote (real))
(lambda (x) (= x 0)))
(put (quote exp) (quote (real real))
(lambda (x y) (tag (expt x y))))
(quote done)))
(define make-real
(lambda (n)
((get (quote make) (quote real)) n)))
(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-integer-package)
(install-rational-package)
(install-real-package)
(install-rectangular-package)
(install-polar-package)
(install-complex-package)
(define n1 (make-integer 10))
(print n1)
(print (raise n1))
(newline)
(define n2 (make-rational 5 10))
(print n2)
(print (raise n2))
(newline)
(define n3 (make-real 5.6))
(print n3)
(print (raise n3))
(quote done))
入出力結果(Terminal(kscheme), REPL(Read, Eval, Print, Loop))
$ kscheme sample83.scm (integer . 10) (rational 10 . 1) (rational 1 . 2) (real . 0.5e0) (real . 0.56e1) (complex rectangular 0.56e1 . 0) done $
0 コメント:
コメントを投稿