## 2015年7月11日土曜日

### Scheme - データによる抽象の構築(汎用演算システム(異なる型のデータの統合(raise 演算, 型の強制変換, 塔とレベル)))

その他参考書籍

コード(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) ;; kscheme の remainder 手続きの実装に問題があるっぽい (display "a: ") (print a) (display "b: ") (print 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)) (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 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 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 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 (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 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 20)) (define n2 (make-rational 5 10)) (print (add n1 n2)) (quote done)) ```

```\$ kscheme sample84.scm
a: 5
b: 10
a: 10
b: 5
a: 5
b: 0
a: 20
b: 1
a: 1
b: 0
a: 41
b: 2
a: 2
b:
(rational 41/2 . 1)
done
\$ gosh sample84.scm
a: 5
b: 10
a: 10
b: 5
a: 5
b: 0
a: 20
b: 1
a: 1
b: 0
a: 41
b: 2
a: 2
b: 1
a: 1
b: 0
(rational 41 . 2)
\$ guile < sample84.scm
GNU Guile 2.0.11
Copyright (C) 1995-2014 Free Software Foundation, Inc.

Guile comes with ABSOLUTELY NO WARRANTY; for details type `,show w'.
This program is free software, and you are welcome to redistribute it
under certain conditions; type `,show c' for details.

Enter `,help' for help.
;;; <stdin>:151:6: warning: possibly unbound variable `make-complex-from-real-imag'
a: 5
b: 10
a: 10
b: 5
a: 5
b: 0
a: 20
b: 1
a: 1
b: 0
a: 41
b: 2
a: 2
b: 1
a: 1
b: 0
(rational 41 . 2)
\$1 = done
scheme@(guile-user)>
\$ kscheme
kscm>   (define print (lambda (x) (display x) (newline)))
kscm>   (define gcd
(lambda (a b)
;; kscheme の remainder 手続きの実装に問題があるっぽい
(display "a: ")
(print a)
(display "b: ")
(print b)
(if (= b 0)
a
(gcd b (remainder a b)))))
kscm> (gcd 2 1)
a: 2
b: 1
a: 1
b: 0
1
kscm> (gcd 4 1)
a: 4
b: 1
a: 1
b: 0
1
kscm> (gcd 100 1)
a: 100
b: 1
a: 1
b: 0
1
kscm> (gcd 100 2)
a: 100
b: 2
a: 2
b: 0
2
kscm> (gcd 100 5)
a: 100
b: 5
a: 5
b: 0
5
kscm> (gcd 100 7)
a: 100
b: 7
a: 7
b: 2
a: 2
b: 1
a: 1
b: 0
1
kscm> \$
```