(sicp38)m3.24~m3.26

3.24

equal?以外の述語をとるようにする。
関数を受け取るようにしてみた。

(define (make-table . key)
  (let ((local-table (list '*table*))
        (same-key? equal?))
    (define (assoc key records)
      (cond ((null? records) #f)
            ((same-key? key (caar records)) (car records))
            (else (assoc key (cdr records)))))
    (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))))
    (when (not (null? key))
      (set! same-key? (car key)))
    (print same-key?)
    dispatch))

(define t (make-table (lambda (x y) #t)))
((t 'insert-proc!) 'a 'b 2)
((t 'lookup-proc) 'a 'b)
((t 'insert-proc!) 'c 'd 9)
((t 'lookup-proc) 'b 'c)
	;; 75:user> #<closure #f>
	;; => t
	;; 76:user> => ok
	;; 77:user> => 2
	;; 78:user> => ok
	;; 79:user> => 9

3.25

任意個のキーをとれるレコード

(define (make-table . key)
  (let ((local-table (list '*table*))
        (same-key? equal?))
    (define (assoc key records)
      (cond ((null? records) #f)
            ((same-key? key (caar records)) (car records))
            (else (assoc key (cdr records)))))
    (define (inspect)
      (print local-table))
    (define (lookup keys)
      (define (loop keys table)
        (if (null? keys)
            (cdr table)
            (let* ((key (car keys))
                   (rest-keys (cdr keys))
                   (sub-table (assoc key (cdr table))))
              (if sub-table
                  (loop rest-keys sub-table)
                  #f))))
      (loop keys local-table))
    (define (insert! keys value)
      (define (loop keys table)
        (if (null? keys)
            (set-cdr! table value)
            (let* ((key (car keys))
                   (rest-keys (cdr keys))
                   (sub-table (assoc key (cdr table))))
              (if sub-table
                  (loop rest-keys sub-table)
                  (let ((new-table (cons key '())))
                    (set-cdr! table
                              (cons (loop rest-keys new-table)
                                    (cdr table)))))))
        table)
      (loop keys local-table)
      'ok)
    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
            ((eq? m 'insert-proc!) insert!)
            ((eq? m 'inspect-proc) inspect)
            (else (error "Unknown operation -- TABLE" m))))
    (when (not (null? key))
      (set! same-key? (car key)))
    (print same-key?)
    dispatch))
(define t (make-table))
((t 'insert-proc!) '(a b d) 1)
((t 'insert-proc!) '(a b c) 2)
((t 'insert-proc!) '(b c) 'b)
((t 'inspect-proc))
((t 'lookup-proc) '(a b d))
	;; 27:user> => make-table
	;; 28:user> #<subr equal?>
	;; => t
	;; 29:user> => ok
	;; 30:user> => ok
	;; 31:user> => ok
	;; 32:user> (*table* (b (c . b)) (a (b (c . 2) (d . 1))))
	;; => #<undef>
	;; 33:user> => 1