計算機プログラムの構造と解釈[第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.3(例: 記号代数)、問題2.89.を解いてみる。
その他参考書籍
- Instructor's Manual to Accompany Structure & Interpretation of Computer Programs
- プログラミングGauche (Kahuaプロジェクト (著), 川合 史朗 (監修), オライリージャパン)
- Scheme手習い
問題2.89.
コード(Emacs)
(begin
(define >= (lambda (x y) (or (> x y) (= x y))))
(define repeat (lambda (x n)
(if (= n 0)
(quote ())
(cons x (repeat x (- n 1))))))
(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 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))
(apply-generic op (raise-same-type a1 a2))))
(error "No method for these types"
(list op type-tags))))))))
(define negate (lambda (x) (apply-generic (quote negate) (list x))))
(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 sine (lambda (x) (apply-generic (quote sine) (list x))))
(define cosine (lambda (x) (apply-generic (quote cosine) (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 project
(lambda (x) (apply-generic (quote project) (list x))))
(define levels (quote (complex real rational integer)))
(define higher-type
(lambda (type1 type2)
(define iter
(lambda (levels)
(if (null? levels)
(error "Not found -- HIGHER-TYPE" (list type1 type2))
(let ((type (car levels)))
(if (or (eq? type1 type)
(eq? type2 type))
type
(iter (cdr levels)))))))
(iter levels)))
(define raise-same-type
(lambda (x y)
(let ((x-type (type-tag x))
(y-type (type-tag y)))
(let ((type (higher-type x-type y-type)))
(define iter
(lambda (o)
(if (eq? type (type-tag o))
o
(iter (raise o)))))
(if (eq? x-type type)
(list x (iter y))
(list (iter x) y))))))
(define drop
(lambda (x)
(let ((proc (get (quote project) (list (type-tag x)))))
(if proc
(let ((n (proc (contents x))))
(if (equ? x (raise n))
(drop n)
x))
x))))
(define install-integer-package
(lambda ()
(define negate (lambda (n) (* -1 n)))
(define sine (lambda (n) (sin n)))
(define cosine (lambda (n) (cos n)))
(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 negate) (quote (integer))
(lambda (x) (tag (negate x))))
(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))))
(put (quote sine) (quote (integer))
(lambda (x) (tag (sine x))))
(put (quote cosine) (quote (integer))
(lambda (x) (make-real (cosine x))))
(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
(lambda (n) (car n)))
(define denom
(lambda (n) (cdr n)))
(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 sine (lambda (n) (sin n)))
(define cosine (lambda (n) (cos n)))
(define negate (lambda (n) (* -1 n)))
(define tag
(lambda (x) (attach-tag (quote rational) x)))
(define project
(lambda (x)
(make-integer (round (* 1.0 (/ (numer x)
(denom x)))))))
(put (quote raise) (quote (rational)) raise)
(put (quote project) (quote (rational)) project)
(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?)
(put (quote sine) (quote (rational))
(lambda (x) (make-real (sine x))))
(put (quote cosine) (quote (rational))
(lambda (x) (make-real (cosine x))))
(put (quote negate) (quote (rational))
(lambda (x) (tag (negate x))))
(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)))
(define project (lambda (x) (make-rational (round x) 1)))
(define sine (lambda (n) (sin n)))
(define cosine (lambda (n) (cos n)))
(define negate (lambda (n) (* -1 n)))
(put (quote make) (quote real) (lambda (n) (tag n)))
(put (quote raise) (quote (real)) raise)
(put (quote project) (quote (real)) project)
(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))))
(put (quote sine) (quote (real))
(lambda (x) (tag (sine x))))
(put (quote cosine) (quote (real))
(lambda (x) (tag (cosine x))))
(put (quote negate) (quote (real))
(lambda (x) (tag (negate x))))
(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 negate
(lambda (z) (add (mul (make-integer -1) (real-part z))
(mul (make-integer -1) (imag-part z)))))
(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?)
(put (quote negate) (quote (rectangular))
(lambda (z) (tag (negate z))))
(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 negate
(lambda (z)
(add (mul (make-integer -1) (real-part z))
(mul (make-integer -1) (imag-part z)))))
(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?)
(put (quote negate) (quote (polar))
(lambda (z) (tag (negate z))))
(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 project (lambda (z) (make-real (real-part z))))
(define tag (lambda (z) (attach-tag (quote complex) z)))
(put (quote project) (quote (project)) project)
(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)))
(define install-polynomial-package
(lambda ()
(define make-poly (lambda (variable term-list) (cons variable term-list)))
(define variable (lambda (p) (car p)))
(define term-list (lambda (p) (cdr p)))
(define variable? (lambda (x) (symbol? x)))
(define same-variable? (lambda (v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2))))
(define negate-poly
(lambda (poly)
(make-poly (variable poly)
(negate-termlist (term-list poly)))))
(define (adjoin-term term term-list)
(if (=zero? (coeff term))
term-list
(let ((o (order term)))
(define iter
(lambda (n terms)
(cond ((> o n)
(cons (coeff term)
(append (repeat 0 (- o (+ n 1)))
terms)))
((= o n)
(cons (+ (coeff term)
(first-term terms))
rest-terms))
(else
(cons (first-term terms)
(iter (- n 1)
(rest-terms terms)))))))
(iter (- (length term-list) 1) term-list))))
(define (the-empty-termlist) (quote ()))
(define (first-term term-list) (car term-list))
(define (rest-terms term-list) (cdr term-list))
(define (empty-termlist? term-list) (null? term-list))
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(define negate-term
(lambda (term) (make-term (order term)
(negate (coeff term)))))
(define negate-termlist
(lambda (termlist)
(map (lambda (term)
(make-term (order term)
(negate (coeff term))))
termlist)))
(define add-terms
(lambda (L1 L2)
(cond ((empty-termlist? L1) L2)
((empty-termlist? L2) L1)
(else
(let ((t1 (first-term L1)) (t2 (first-term L2)))
(cond ((> (order t1) (order t2))
(adjoin-term
t1 (add-terms (rest-terms L1) L2)))
((< (order t1) (order t2))
(adjoin-term
t2 (add-terms L1 (rest-terms L2))))
(else
(adjoin-term
(make-term (order t1)
(add (coeff t1) (coeff t2)))
(add-terms (rest-terms L1)
(rest-terms L2))))))))))
(define (add-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(add-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var -- ADD-POLY"
(list p1 p2))))
;; 問題 2.88
(define sub-poly
(lambda (p1 p2)
(add-poly p1 (negate-poly p2))))
(define (mul-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(mul-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var -- MUL-POLY"
(list p1 p2))))
;; 問題 2.87
(define poly-=zero?
(lambda (p)
(define iter
(lambda (terms)
(cond ((null? terms) #t)
((=zero? (first-term terms))
(iter (rest-terms terms)))
(else #f))))
(iter (term-list p))))
(define tag (lambda (p) (attach-tag (quote polynomial) p)))
(put (quote add) (quote (polynomial polynomial))
(lambda (p1 p2) (tag (add-poly p1 p2))))
(put (quote sub) (quote (polynomial polynomial))
(lambda (p1 p2) (tag (sub-poly p1 p2))))
(put (quote mul) (quote (polynomial polynomial))
(lambda (p1 p2) (tag (mul-poly p1 p2))))
(put (quote make) (quote polynomial)
(lambda (var terms) (tag (make-poly var terms))))
(put (quote =zero?) (quote (polynomial)) poly-=zero?)
(quote done)))
(define make-polynomial
(lambda (var terms)
((get (quote make) (quote polynomial)) var terms)))
(install-integer-package)
(install-rational-package)
(install-real-package)
(install-rectangular-package)
(install-polar-package)
(install-complex-package)
(install-polynomial-package)
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(define (first-term term-list) (car term-list))
(define (rest-terms term-list) (cdr term-list))
(define =zero? (lambda (n) (= n 0)))
(define (adjoin-term term term-list)
(if (=zero? (coeff term))
term-list
(let ((o (order term)))
(define iter
(lambda (n terms)
(cond ((> o n)
(cons (coeff term)
(append (repeat 0 (- o (+ n 1)))
terms)))
((= o n)
(cons (+ (coeff term)
(first-term terms))
(rest-terms terms)))
(else
(cons (first-term terms)
(iter (- n 1)
(rest-terms terms)))))))
(iter (- (length term-list) 1) term-list))))
(define t1 (make-term 5 1))
(define t2 (make-term 4 2))
(define t3 (make-term 2 3))
(define t4 (make-term 1 -2))
(define t5 (make-term 0 -5))
(define term-list (quote ()))
(for-each (lambda (term)
(set! term-list (adjoin-term term term-list)))
(list t1 t2 t3 t4 t5))
(print term-list)
(quote done))
入出力結果(Terminal(kscheme), REPL(Read, Eval, Print, Loop))
$ kscheme sample89.scm (1 2 0 3 -2 -5) done $
0 コメント:
コメントを投稿