2015年7月10日金曜日

開発環境

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

その他参考書籍

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

コメントを投稿