SICPを読む(107) 問題 3.24,3.25,3.26 - 多次元キー

SICPも大変だ。

問題 3.24,3.25

equal?以外にも対応し、多次元のキーに対応せよ。という問題。

手続きの連鎖にしてみた。

keyとvaluesの位置を変えて引数を可変長にしてみたけど、applyがいっぱい必要になってしまった。ちと失敗。

getとsetのAPIはそのまま使えるようにした。

(define (make-table . search-method)
  (letrec
    ((local-table (list '*table*))
     (search (if (null? search-method)
                 assoc
                 (car search-method)))

     (lookup (lambda keys
               (let ((res (search (car keys) (cdr local-table))))
                     (if (or (not res)
                             (null? (cdr keys))
                             (not (procedure? (cdr res))))
                         res
                         (apply ((cdr res) 'lookup) (cdr keys))))))
     (insert!  (lambda (value . keys)
                  (let* ((record (lookup (car keys)))
                         (next (not (null? (cdr keys))))
                         (new-entry! (lambda (e)
                                       (set-cdr! local-table (cons (cons (car keys) e)
                                                                   (cdr local-table)))))
                         (next-insert! (lambda (n)
                                         (apply (n 'insert!) value (cdr keys)))))
                    (if record
                        (if next
                            (if (procedure? (cdr record))
                                (next-insert! (cdr record))         ; 下へ
                                (let ((new (make-table search)))    ; 値をテーブルに上書き
                                  (set-cdr! record new)
                                  (next-insert! new)))
                            (set-cdr! record value))                ; 値で上書き
                        (if next
                            (let ((new (make-table search)))        ; 新しくテーブルを作って下へ
                              (new-entry! new)
                              (next-insert! new))
                            (new-entry! value)))                    ; ふつうに挿入
                    local-table))))
    (lambda (m)
      (case m
            ('insert! insert!)
            ('lookup lookup)
            (else local-table)))))

テスト。

(define tbl (make-table assq))
(insert! tbl "new entry" 'hoge)                             ; (*table* (hoge . new entry))
((tbl 'insert!) "new entry2" 'moge)                         ; (*table* (moge . new entry2) (hoge . new entry))

((tbl 'insert!) "over write test" 'hoge)                    ; (*table* (moge . new entry2) (hoge . over write test))
((tbl 'lookup) 'hoge)                                       ; (hoge . over write test)

((tbl 'insert!) "table over write test1" 'hoge 'moge)       ; (*table* (moge . new entry2) (hoge . #<procedure>))
((tbl 'insert!) "table over write test2" 'hoge 'moge 'hoge) ; (*table* (moge . new entry2) (hoge . #<procedure>))

((tbl 'lookup) 'hoge 'moge)                                 ; (moge . #<procedure>)
((tbl 'lookup) 'hoge 'moge 'hoge)                           ; (hoge . table over write test2)
((tbl 'lookup) 'hoge 'moge 'moge)                           ; #f


(define *operation-table* (make-table))
(define (get key)
  (let ((res (apply (*operation-table* 'lookup) key)))
    (and res (cdr res))))
(define (set key value)
  (apply (*operation-table* 'insert!) (cons value key)))


(set '(pakage1 +) +)                           ; (*table* (pakage1 . #<procedure>))
((get '(pakage1 +)) 1 2)                       ; 3

(set '(system out printLine) display)          ; (*table* (system . #<procedure>) (pakage1 . #<procedure>))
((get '(system out printLine)) "Hello, world") ; Hello, world

(set '((Int +)) +)                             ; (*table* ((Int +) . #<primitive:+>) (system . #<procedure>) (pakage1 . #<procedure>))
(set '((String +)) string-append)              ; (*table* ((String +) . #<primitive:string-append>) ((Int +) . #<primitive:+>) (system . #<procedure>) (pakage1 . #<procedure>))

((get '((String +))) "Hello, " "Class.")       ; Hello, Class.
(get '(hoge))                                  ; #f

案外大変だった。

あ、型は(Int Int) +だったっけ・・・ま、動くと思うのでいいや。

バグ

上書き判定にprocedure?を使っているので、

(set '(pakage1 +) +)
(set '(pakage1 + +) +) ; エラー

ということは出来ないというバグあり。

あと、

(set '() +) ; エラー

keyの引数ゼロの時の処理は書いてない。

問題 3.26

ちと2進木を用意するのが大変そうなので前に作ったハッシュで。

殆どAPIを変えずに移行することが出来た。

殆どAPIが変わってないということは、バグも持ち越してる訳ですが・・・。

(define (make-multi-hash)
  (letrec
    ((local-table (make-hash))

     (lookup (lambda keys
               (let ((res (hash-value local-table (car keys))))
                     (if (or (not res)
                             (null? (cdr keys))
                             (not (procedure? (cdr res))))
                         res
                         (apply ((cdr res) 'lookup) (cdr keys))))))
     (insert!  (lambda (value . keys)
                  (let* ((record (lookup (car keys)))
                         (next (not (null? (cdr keys))))
                         (new-entry! (lambda (e)
                                       (hash-set! local-table (car keys) e)))
                         (next-insert! (lambda (n)
                                         (apply (n 'insert!) value (cdr keys)))))
                    (if record
                        (if next
                            (if (procedure? (cdr record))
                                (next-insert! (cdr record))          ; 下へ
                                (let ((new (make-multi-hash)))       ; 値をテーブルに上書き
                                  (hash-set! local-table record new)
                                  (next-insert! new)))
                            (new-entry! value))                      ; 上書き
                        (if next
                            (let ((new (make-multi-hash)))           ; 新しくテーブルを作って下へ
                              (new-entry! new)
                              (next-insert! new))
                            (new-entry! value)))))))
    (lambda (m)
      (case m
            ('insert! insert!)
            ('lookup lookup)
            (else local-table)))))

元々上書き出来るのでアレなんですが。

Schemeでも、ちゃんと継承できるようにしないと・・・。