3.3.3 Representing Tables

テーブル、連想リスト。

3.24 (same-key?を指定できるテーブル)

(define (make-table same-key?)
  (let ((local-table (list '*table*)))
    (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))))
    dispatch))

3.25

(define (make-table)
  (let ((*table* '()))
    (define (lookup key)
      (let ((pair (assoc key *table*)))
        (and pair (cdr pair))))
    (define (insert! key value)
      (let ((pair (assoc key *table*)))
        (if pair
          (set-cdr! pair value)
          (set! *table*
                (cons (cons key value)
                      *table*)))))
    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
            ((eq? m 'insert-proc!) insert!)
            (else (error "Unknown operation -- TABLE" m))))
    dispatch))

以上、試してない。

3.26 (木構造でテーブルを実装)

(define (tree-content t)
  (list-ref t 0))

(define (tree-left t)
  (list-ref t 1))

(define (tree-right t)
  (list-ref t 2))

(define (make-tree t)
  (list t '() '()))

(define (tree-set-left! t l)
  (set-car! (cdr t) l))

(define (tree-set-right! t r)
  (set-car! (cddr t) r))

(define (make-table)
  (let ((*tree* '()))
    (define (tree-assoc key tree)
      (cond ((null? tree) #f)
            ((< key (car (tree-content tree))) (tree-assoc key (tree-left tree)))
            ((> key (car (tree-content tree))) (tree-assoc key (tree-right tree)))
            (else (tree-content tree))))
    (define (tree-insert! item tree)
      (cond ((null? tree) (error "tree is null"))
            ((< (car item) (car (tree-content tree)))
             (if (null? (tree-left tree))
               (tree-set-left! tree (make-tree item))
               (tree-insert! item (tree-left tree))))
            ((> (car item) (car (tree-content tree)))
             (if (null? (tree-right tree))
               (tree-set-right! tree (make-tree item))
               (tree-insert! item (tree-right tree))))
            (else (error "key exists"))))
    (define (lookup key)
      (let ((pair (tree-assoc key *tree*)))
        (and pair (cdr pair))))
    (define (insert! key value)
      (let ((pair (tree-assoc key *tree*)))
        (cond (pair (set-cdr! pair value))
              ((null? *tree*) (set! *tree* (make-tree (cons key value))))
              (else (tree-insert! (cons key value) *tree*)))))
    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
            ((eq? m 'insert-proc!) insert!)
            (else (error "Unknown operation -- TABLE" m))))
    dispatch))

3.27

関数のメモ化とか。

うーん、雑だ。