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

計算機プログラムの構造と解釈[第2版]
原著

開発環境

• macOS Sierra - Apple (OS)
• Emacs (Text Editor)
• Scheme (プログラミング言語)
• kscheme (ksi)(github) (処理系)

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

その他参考書籍

• Instructor's Manual to Accompany Structure & Interpretation of Computer Programs

問題2.73.

コード(Emacs)

((lambda ()
  (load "procedures.scm")
  (newline)
  (define (p obj) (display obj) (newline))

  (p 2.73)
  (p 'a.)
  (p "scheme の基盤の基本型で、抽象データのようにリストで表現されていなく、型タグを持たないから")

  (p 'b.)
  (define (make-table)
    ((lambda (local-table)
       (define (lookup key-1 key-2)
         ((lambda (subtable)
            (if subtable
                ((lambda (record)
                   (if record
                       (cdr record)
                       #f))
                 (assoc key-2 (cdr subtable)))
                #f))
          (assoc key-1 (cdr local-table))))
       (define (insert! key-1 key-2 value)
         ((lambda (subtable)
            (if subtable
                ((lambda (record)
                   (if record
                       (set-cdr! record value)
                       (set-cdr! subtable
                                 (cons (cons key-2 value)
                                       (cdr subtable)))))
                 (assoc key-2 (cdr subtable)))
                (set-cdr! local-table
                          (cons (list key-1
                                      (cons key-2 value))
                                (cdr local-table))))
            'ok)
          (assoc key-1 (cdr local-table))))
       (define (dispatch m)
         (if (eq? m 'lookup-proc)
             lookup
             (if (eq? m 'insert-proc!)
                 insert!
                 (error "unknown operation -- table" m))))
       dispatch)
     (list '*table*)))

  (define operation-table (make-table))
  (define get (operation-table 'lookup-proc))
  (define put (operation-table 'insert-proc!))

  (define (variable? exp) (symbol? exp))
  (define (deriv exp var)
    (if (number? exp)
        0
        (if (variable? exp)
            (if (same-variable? exp var)
                1
                0)
            ((get 'deriv (operator exp))  (operands exp) var))))

  (define (operator exp) (car exp))
  (define (operands exp) (cdr exp))
  (define (same-variable? v1 v2) (and (variable? v1) (variable? v2) (eq? v1 v2)))

  (define (=number? exp num)
    (and (number? exp) (= exp num)))
  
  (define (install-sum-package)
    (define (make-sum a1 a2)
      (if (=number? a1 0)
          a2
          (if (=number? a2 0)
              a1
              (if (and (number? a1) (number? a2))
                  (+ a1 a2)
                  (list '+ a1 a2)))))
    (define (addend s) (car s))
    (define (augend s) (cadr s))
    (define (deriv-sum exp var)
      (make-sum (deriv (addend exp) var)
                (deriv (augend exp) var)))

    (put 'make '+ make-sum)
    (put 'deriv '+ deriv-sum)
    'done)
  
  (define (install-product-package)
    (define (make-product m1 m2)
      (if (or (=number? m1 0) (=number? m2 0))
          0
          (if (=number? m1 1)
              m2
              (if (=number? m2 1)
                  m1
                  (if (and (number? m1) (number? m2))
                      (* m1 m2)
                      (list '* m1 m2))))))
    (define (multiplier p) (car p))
    (define (multiplicand p) (cadr p))

    (define (deriv-product exp var)
      ((get 'make '+)
       (make-product (multiplier exp)
                     (deriv (multiplicand exp) var))
       (make-product (deriv (multiplier exp) var)
                     (multiplicand exp))))
    
    (put 'make '* make-product)
    (put 'deriv '* deriv-product)
    'done)

  (install-sum-package)
  (install-product-package)

  (p (deriv '(+ x 3) 'x))
  (p (deriv '(* x y) 'x))
  (p (deriv '(* (* x y) (+ x 3)) 'x))

  (p 'c.)
  (define (install-expt-package)
    (define (make-expt base exp)
      (if (= exp 0)
          1
          (if (= exp 1)
              base
              (list '** base exp))))
    (define (base e) (car e))
    (define (exponent e) (cadr e))

    (define (deriv-expt exp var)
      ((get 'make '*)
       ((get 'make '*)
        (exponent exp)
        (make-expt (base exp)
                   ((get 'make '+)
                    (exponent exp)
                    -1)))
       (deriv (base exp) var)))
    
    (put 'make '** make-expt)
    (put 'deriv '** deriv-expt)
    'done)

  (install-expt-package)
  (p (deriv '(** x 10) 'x))
  (p (deriv '(** x 0) 'x))
  (p (deriv '(** x 1) 'x))

  (p 'd.)
  (define operation-table (make-table))
  (define get (operation-table 'lookup-proc))
  (define put (operation-table 'insert-proc!))

  (define (deriv exp var)
    (if (number? exp)
        0
        (if (variable? exp)
            (if (same-variable? exp var)
                1
                0)
            ((get (operator exp) 'deriv)  (operands exp) var))))

  (define (install-sum-package)
    (define (make-sum a1 a2)
      (if (=number? a1 0)
          a2
          (if (=number? a2 0)
              a1
              (if (and (number? a1) (number? a2))
                  (+ a1 a2)
                  (list '+ a1 a2)))))
    (define (addend s) (car s))
    (define (augend s) (cadr s))
    (define (deriv-sum exp var)
      (make-sum (deriv (addend exp) var)
                (deriv (augend exp) var)))

    (put '+ 'make make-sum)
    (put '+ 'deriv deriv-sum)
    'done)

  (install-sum-package)
  (p (deriv '(+ x 3) 'x))
  
  'done))

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

$ ksi < sample73.scm
ksi> 
2.73
a.
scheme の基盤の基本型で、抽象データのようにリストで表現されていなく、型タグを持たないから
b.
1
y
(+ (* x y) (* y (+ x 3)))
c.
(* 10 (** x 9))
0
1
d.
1
=> done
ksi> $