2015年7月13日月曜日

開発環境

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

その他参考書籍

問題2.85.

コード(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 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 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)))
      (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?)
      (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)))
      (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))))
      (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)))
  
  (install-integer-package)
  (install-rational-package)
  (install-real-package)
  (install-rectangular-package)
  (install-polar-package)
  (install-complex-package)

  (define n1 (make-integer 10))
  (define n2 (make-rational 20 5))
  (print n1)
  (print (drop n1))
  (print n2)
  (print (drop n2))
  (define n3 (add n1 n2))
  (print n3)
  (print (drop n3))
  (quote done))

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

$ kscheme sample85.scm
(integer . 10)
(integer . 10)
(rational 4 . 1)
(integer . 0.4e1)
(rational 14 . 1)
(integer . 0.14e2)
done
$

0 コメント:

コメントを投稿

Comments on Google+: