SICP 読み (81) 2.5.3 例: 記号代数

scheme SICP

_大仕事_に着手してみる。

問題 2.90

とりあえず、依存する手続きを以下にまとめて。

2.90/lib/2.5.1.scm

(define (assoc key records)
  (cond ((null? records) #f)
	((equal? key (caar records)) (car records))
	(else (assoc key (cdr records)))))

(define (make-table)
  (let ((local-table (list '*table*)))
    (define (lookup 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! 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)))))
      'ok)
    (define (dispatch 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 'lookup-proc))
(define put (operation-table 'insert-proc!))

(define (attach-tag type-tag contents)
  (cons type-tag contents))
(define (type-tag datum)
  (cond ((number? datum) 'scheme-number)
	((pair? datum) (car datum))
	(else
	 (error "Bad tagged datum -- TYPE TAG" datum))))
(define (contents datum)
  (cond ((number? datum) datum)
	((pair? datum) (cdr datum))
	(else
	 (error "Bad tagged datum -- CONTENTS" datum))))

(define (apply-generic 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 x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (=zero? x) (apply-generic '=zero? x))

(define (install-scheme-number-package)
  (put 'add '(scheme-number scheme-number) +)

  (put 'sub '(scheme-number scheme-number) -)

  (put 'mul '(scheme-number scheme-number) *)

  (put 'div '(scheme-number scheme-number) /)

  (put '=zero? '(scheme-number) zero?)

  (put 'make 'scheme-number
       (lambda (x) x))
  'done)

(define (make-scheme-number n)
  ((get 'make 'scheme-number) n))

試験もイチから書く。ちなみに上記の手続きな試験は略。基本的に_項リスト_関連の手続きをパケジにしてしまえ、という事だと思っているので、それより上位に位置する手続き達は纏める事ができるハズ。
がしかし、項リストの取扱いはちょっと検討が必要だな。
p.113 の図 2.24 な手法で良いのかどうか。

  • 引数が term-list 一発の手続きは楽そげ
    • first-term
    • rest-terms
    • empty-termlist?
  • the-empty-termlist も tag 付けて '() 返却で良いのか?
  • term なソレが微妙 (つってもタダのリスト)
    • make-term
    • order
    • coeff
  • 一番微妙なのが adjoin-term でどうしたものか
    • apply-generic で処理するのであれば term にも tag 打つ必要あり?
    • 違う。apply-generic で手続きを返して term を渡すんか?
(define (adjoin-term term-list)
  (lambda (term)
    (if (=zero? (coeff term))
	term-list
	(cons term term-list))))

とか

(define (adjoin-term term-list)
  (lambda (term)
    (let f ((term-list term-list))
      (if (> (order term) (length term-list))
	  (f (cons 0 term-list))
	  (cons (coeff term) term-list)))))

みたいな?

う。make-polynomial も修正必要だな。ふたつに分けるんかな? make-sparse-polynomial とか make-dense-polynomial とか。