KOGURO Naoki
naoki****@kogur*****
2003年 1月 26日 (日) 01:10:42 JST
小黒です。
call-with-iterator を実装してみるために、簡単なハッシュを作ってみまし
た (長ったらしいコードですみません) 。
ただ、データの追加に関しては、 call-with-builder を作って、そいつにま
かせた方がよいと思ったので、 (cursor 'insert! key val) は実装していま
せん。
代わりに、 call-with-builder のキーワード引数 :dictionary というのを作
りました。これを指定すると「与えられた dictionary に値を追加する」とい
う動作になります。
At Thu, 23 Jan 2003 15:44:30 +0900,
Kimura Fuyuki wrote:
> 1. call-with-iterator に与えられた keys から重複を取り除くのはけっこう
> めんどう or 重たい処理かもしれない。
これは実装しませんでした。 call-with-iterator がここまで面倒を見る必要
はないと思います。
> 2. 空のディクショナリに insert! する素直な手段がないような。
これは、call-with-builder で解決するのではないでしょうか。
> 5. 「現在の要素は削除されているか」みたいな状態を押さえておくのが面倒。
言いだしっぺですが、これは手を抜きました。(^^;
(define-class <mock-hash-meta> (<class>)
())
(define-class <mock-hash> ()
((table :accessor table-of :init-value #f)
(size :accessor table-size-of :init-value 7))
:metaclass <mock-hash-meta>)
(define-method initialize ((self <mock-hash>) initargs)
(next-method)
(set! (table-of self) (make-vector (table-size-of self) '(#f))))
(define-method table-position ((self <mock-hash>) key)
(define (hash-value str)
(call-with-input-string str (lambda (in)
(port-fold (lambda (c val)
(+ (char->integer c) val))
0
(lambda ()
(read-char in))))))
(modulo (hash-value key) (table-size-of self)))
(define-method call-with-builder ((class <mock-hash-meta>) proc . options)
(let-keywords* options ((dictionary #f))
(let ((dict (or dictionary (make <mock-hash>))))
(proc (lambda (key value)
(let ((pos (table-position dict key)))
(vector-set! (table-of dict) pos
(append (vector-ref (table-of dict) pos)
(list (cons key value))))))
(lambda () dict)))))
(define-method call-with-iterator ((self <mock-hash>) iteratee seed . keys)
(define (all-keys)
(let1 all-keys '()
(dotimes (i (table-size-of self) all-keys)
(dolist (p (cdr (vector-ref (table-of self) i)))
(push! all-keys (car p))))))
(define (find-key key)
(let ((lst (vector-ref (table-of self)
(table-position self key))))
(let loop ((prev lst)
(cur (cdr lst)))
(cond ((null? cur) (values #f #f))
((equal? key (caar cur)) (values prev cur))
(else (loop cur (cdr cur)))))))
(let loop ((keys (if (null? keys) (all-keys) keys))
(seed seed))
(if (null? keys)
seed
(receive (prev cur) (find-key (car keys))
(define (cursor method . args)
(case method
((next) (loop (cdr keys) (car args)))
((get) (values (caar cur) (cdar cur)))
((update!) (set-cdr! (car cur) (car args)))
((delete!) (set-cdr! prev (cdr cur)))))
(if cur
(iteratee cursor seed)
(cursor 'next seed))))))
;;;; demos
(define (show-all-keys dict)
(format #t "keys = ~a~%"
(call-with-iterator dict (lambda (cursor seed)
(receive (key _) (cursor 'get)
(push! seed key))
(cursor 'next seed))
'())))
(define dict (call-with-builder <mock-hash>
(lambda (add! get)
(add! "foo" "bar")
(add! "fov" "baz")
(add! "hoge" "piyo")
(get))))
(define-method length ((self <mock-hash>))
(define (iteratee cursor seed)
(cursor 'next (+ seed 1)))
(call-with-iterator self iteratee 0))
(format #t "length = ~a~%" (length dict))
(define-method remove! ((self <mock-hash>) pred)
(define (iteratee cursor seed)
(receive (key val) (cursor 'get)
(when (pred key val) (cursor 'delete!)))
(cursor 'next seed))
(call-with-iterator self iteratee 0))
(show-all-keys dict)
(remove! dict (lambda (key val) (string=? "foo" key)))
(show-all-keys dict)
(define-method put! ((self <mock-hash>) key val)
(or (call-with-iterator self
(lambda (cursor seed)
(cursor 'update! val)
#t)
#f key)
(call-with-builder <mock-hash>
(lambda (add! get)
(add! key val))
:dictionary self)))
(define-method get! ((self <mock-hash>) key)
(define (iteratee cursor seed)
(receive (_ val) (cursor 'get)
val))
(call-with-iterator self iteratee #f key))
(put! dict "aaa" "bbb")
(show-all-keys dict)
(format #t "aaa -> ~a~%" (get! dict "aaa"))
(define-method exist? ((self <mock-hash>) key)
(call-with-iterator self
(lambda (cursor seed)
#t)
#f
key))
(format #t "'aaa' is exist? -> ~a~%" (exist? dict "aaa"))
(format #t "'bbb' is exist? -> ~a~%" (exist? dict "bbb"))
----------------------------------------------------
小黒 直樹 (KOGURO, Naoki)
E-mail: naoki****@kogur***** / kogur****@dd*****
----------------------------------------------------