Scheme - データによる抽象の構築(抽象データの多重表現(データ主導プログラミングと加法性(記号微分, 和, 積)))

計算機プログラムの構造と解釈[第2版]
(翔泳社)
ハロルド エイブルソン (著) ジュリー サスマン (著)
ジェラルド・ジェイ サスマン (著)
Harold Abelson (原著) Julie Sussman (原著)
Gerald Jay Sussman (原著) 和田 英一 (翻訳)

開発環境

• OS X Yosemite - Apple (OS)
• Emacs(Text Editor)
• Scheme (プログラミング言語)
• kscheme, Gauche, GNU Guile (処理系)

計算機プログラムの構造と解釈[第2版](ハロルド エイブルソン (著)、ジュリー サスマン (著)、ジェラルド・ジェイ サスマン (著)、Harold Abelson (原著)、Julie Sussman (原著)、Gerald Jay Sussman (原著)、和田 英一 (翻訳)、翔泳社、原書: Structure and Interpretation of Computer Programs (MIT Electrical Engineering and Computer Science)(SICP))の2(データによる抽象の構築)、2.4(抽象データの多重表現)、2.4.3(データ主導プログラミングと加法性)、問題2.73-a, b.を解いてみる。

その他参考書籍

• Instructor's Manual to Accompany Structure & Interpretation of Computer Programs
• プログラミングGauche (Kahuaプロジェクト (著), 川合 史朗 (監修), オライリージャパン)
• Scheme手習い

問題2.73-a, b.

コード(Emacs)

;; a. 数値や変数は、型タグがない表現を使っているから。

;; b.
;; error 手続きは kscheme に まだ未実装だからとりあえず
(begin 
  (define error
    (lambda (message value)
      (display message)
      (display " ")
      (display value)
      (newline)))

  (define print
    (lambda (x)
      (display x)
      (newline)))

  (define equal?
    (lambda (a b)
      (if (and (pair? a) (pair? b))
          (and (eq? (car a) (car b))
               (equal? (cdr a) (cdr b)))
          (eq? a b))))

  (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 'lookup-proc) lookup)
                  ((eq? m '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 variable? (lambda (s) (symbol? s)))
  (define same-variable?
    (lambda (v1 v2)
      (and (variable? v1)
           (variable? v2)
           (eq? v1 v2))))

  (define deriv
    (lambda (exp var)
      (cond ((number? exp) 0)
            ((variable? exp)
             (if (same-variable? exp var)
                 1
                 0))
            (else ((get (quote deriv)
                        (operator exp))
                   (operands exp)
                   var)))))

  (define operator (lambda (exp) (car exp)))
  (define operands (lambda (exp) (cdr exp)))
  (define =number?
    (lambda (x n)
      (and (number? x)
           (= x n))))


  (define install-sum-package
    (lambda ()
      (define make-sum
        (lambda (a1 a2)
          (cond ((=number? a1 0) a2)
                ((=number? a2 0) a1)
                ((and (number? a1)
                      (number? a2))
                 (+ a1 a2))
                (else (list (quote +) a1 a2)))))
      (define addend (lambda (exp) (car exp)))
      (define augend (lambda (exp) (cadr exp)))
      (define sum-deriv
        (lambda (exp var)
          (make-sum (deriv (addend exp) var)
                    (deriv (augend exp) var))))

      (put (quote make) (quote +) make-sum)
      (put (quote deriv) (quote +) sum-deriv)
      (quote sum-package-is-installed)))

  (define install-product-package
    (lambda ()
      (define make-product
        (lambda (m1 m2)
          (cond ((or (=number? m1 0)
                     (=number? m2 0))
                 0)
                ((=number? m1 1) m2)
                ((=number? m2 1) m1)
                ((and (number? m1)
                      (number? m2))
                 (* m1 m2))
                (else (list (quote *) m1 m2)))))
      (define multiplier (lambda (exp) (car exp)))
      (define multiplicand (lambda (exp) (cadr exp)))
      (define product-deriv
        (lambda (exp var)
          ((get (quote make) (quote +))
           (make-product (multiplier exp)
                         (deriv (multiplicand exp)
                                var))
           (make-product (deriv (multiplier exp)
                                var)
                         (multiplicand exp)))))    
      (put (quote deriv) (quote *) product-deriv)
      (quote product-package-is-installed)))

  (newline)
  (print (install-sum-package))
  (print (install-product-package))
  (define var (quote x))
  (print (deriv (quote (+ x 1))
                var))
  (print (deriv (quote (* x y))
                var))
  (print (deriv (quote (* (* x y)
                          (+ x 3)))
                var))
  (quote done))

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

$ kscheme < sample73.scm
kscm> 
sum-package-is-installed
product-package-is-installed
1
y
(+ (* x y) (* y (+ x 3)))
done
kscm> $