2015年6月29日月曜日

開発環境

計算機プログラムの構造と解釈[第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.1(汎用算術演算子)、問題2.78.を解いてみる。

その他参考書籍

問題2.78.

コード(Emacs)

(begin 
  (newline)
  (define print (lambda (x) (display x) (newline)))
  (define error (lambda (message value)
                  (display message) (display " ") (display value) (newline)))
  (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)
      (if (eq? type-tag (quote scheme-number))
          contents
          (cons type-tag contents))))
  (define type-tag
    (lambda (datum)
      (cond ((number? datum) (quote scheme-number))
            ((pair? datum) (car datum))
            (error "Bad tagged datum -- TYPE-TAG" datum))))
  (define contents
    (lambda (datum)
      (cond ((number? datum) datum)
            ((pair? datum) (cdr datum))
            (else error "Bad tagged datum -- CONTENTS" datum))))

  ;; 可変個引数の手続きの定義はまだ 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))
              (error "No method for these types -- APPLY-GENERIC"
                     (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 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 rectangular)) real imag)))
  (define make-from-mag-ang
    (lambda (mag ang)
      ((get (quote make-from-mag-ang) (quote rectangular)) mag ang)))

  (define install-scheme-number-package
    (lambda ()
      (put (quote add) (quote (scheme-number scheme-number))
           (lambda (x y) (+ x y)))
      (put (quote sub) (quote (scheme-number scheme-number))
           (lambda (x y) (- x y)))
      (put (quote mul) (quote (scheme-number scheme-number))
           (lambda (x y) (* x y)))
      (put (quote div) (quote (scheme-number scheme-number))
           (lambda (x y) (/ x y)))
      (quote done)))
  
  (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 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))))
      (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 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))))
      (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 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)
      (quote done)))

  (install-scheme-number-package)
  (install-rectangular-package)
  (install-rectangular-package)
  (install-complex-package)  

  (define make-complex-from-real-imag
    (lambda (x y)
      ((get (quote make-from-real-imag) (quote complex)) x y)))

  (define z (make-complex-from-real-imag 3 4))
  (print z)

  (print (magnitude z))
  
  (print (add 5 10))
  (print (sub (magnitude z) (magnitude z)))

  (quote done))

入出力結果(Terminal(kscheme), REPL(Read, Eval, Print, Loop))

$ kscheme < sample78.scm
kscm> 
(complex rectangular 3 . 4)
0.500002317825394900579e1
15
0.e0
done
kscm> $

0 コメント:

コメントを投稿