2015年7月9日木曜日

開発環境

計算機プログラムの構造と解釈[第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.を解いてみる。

その他参考書籍

問題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 コメント:

コメントを投稿