## 2015年7月19日日曜日

### Scheme - データによる抽象の構築(汎用演算システム(例: 記号代数(多項式, 零))))

その他参考書籍

コード(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 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 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 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 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 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)))) (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))) (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)))) (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 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 (adjoin-term term term-list) (if (=zero? (coeff term)) term-list (cons term 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 (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)))) (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 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 p1 (make-polynomial (quote x) (list (make-integer 0) (make-integer 2)))) (define p2 (make-polynomial (quote x) (list (make-integer 0) (make-integer 0)))) (print (=zero? p1)) (print (=zero? p2)) (quote done)) ```

```\$ kscheme sample87.scm
#f
#t
done
\$
```