#lang racket
(require (only-in srfi/41 stream-drop-while stream-from))
;; 素数列
(define primes
(stream-cons
2
(stream-filter prime? (stream-from 3))))
(define (prime? n)
(let loop ((ps primes))
(let ((x (stream-first ps)))
(or (> (expt (stream-first ps) 2) n)
(and ((compose1 not zero?) (remainder n x))
(loop (stream-rest ps)))))))
;; メルセンヌ素数(の一部)のテーブル(12個のみ)
(define *mersenne-primes*
(vector 3 7 31 127 8191 131071 524287 2147483647 2305843009213693951
618970019642690137449562111 162259276829213363391578010288127
170141183460469231731687303715884105727))
;; キーと値のペアを形作る構造体
(struct entry (key value) #:transparent)
;;; ハッシュテーブル生成関数
(define make-ht
(case-lambda
((n)
(let ((bucket (make-vector n '())))
;;; 多項式ローリングハッシュ関数
(define hashval
(case-lambda
((s ht p)
(let ((s (map char->integer (string->list s))))
(modulo
(apply +
(map (lambda (i s)
(* (expt p i) s))
(range (length s))
s))
(vector-length ht))))
((s ht)
(hashval s ht (vector-ref *mersenne-primes* 2)))
((s)
(hashval s bucket))))
;;; ハッシュテーブル操作関数
;; 検索
(define (lookup key)
(let ((lst (vector-ref bucket (hashval key))))
(and ((compose1 not null?) lst)
(entry-value
(car
(member key lst
(lambda (x y)
(string=? x (entry-key y)))))))))
;; 削除
(define (delete key)
(let ((hv (hashval key)))
(vector-set! bucket hv
(remove key
(vector-ref bucket hv)
(lambda (x y)
(string=? x (entry-key y)))))))
;; 挿入
(define insert
(case-lambda
((vec key val flag)
(let ((hv (hashval key vec)))
(when flag
(delete key))
(vector-set! vec hv
(cons (entry key val) (vector-ref vec hv)))))
((vec key val)
(insert vec key val #f))
((key val)
(when (check-size?)
(rehash))
(insert bucket key val #t))))
;; キーのリストを返す
(define (getkeys)
(get-entries entry-key))
;; 値のリストを返す
(define (getvalues)
(get-entries entry-value))
;;; ユーティリティ
;; エントリを返す
(define get-entries
(case-lambda
((proc)
(map proc (get-entries)))
(()
(flatten (vector->list bucket)))))
;; ハッシュテーブルを占めるデータの割合を計算する
(define check-size?
(case-lambda
((threshold)
(> (/ (length (get-entries)) (vector-length bucket)) threshold))
(()
(check-size? 0.8))))
;; リハッシュ
(define (rehash)
(let* ((n (vector-length bucket))
(v (make-vector
(stream-first
(stream-drop-while
(lambda (x)
(< x (* 2 n))) primes)) '())))
(for-each (lambda (key val)
(insert v key val)) (getkeys) (getvalues))
(set! bucket v)))
;; デバッグ用
(define (print)
(display bucket)
(newline))
;; *ディスパッチ関数*
;; ここでオブジェクト外に「公開する」メソッドと「隠蔽する」メソッド
;; に分かれる(登録すると「公開」される)。
;; 通常のOOPで言う"public"と"private"だ。
(define (dispatch message)
(case message
((delete) delete)
((getkeys) getkeys)
((getvalues) getvalues)
((insert) insert)
((lookup) lookup)
;; デバッグ用
;; ((check-size?) check-size?)
;; ((get-entries) get-entries)
;; ((print) print)
;; ((rehash) rehash)
(else (error "Unknown request --MAKE-HT" message))))
dispatch
))
(() (make-ht (stream-ref primes 25)))))
;; メッセージ送信
; 「オブジェクト指向の理論的モデル」で書くと
; ((object message) arg0 arg1 ...)
; と面倒臭い形式で関数記述を行わないとならない。
; それを避け、「objectにmessageをsendする」と言う
; 明解な「形式」に語順を変える。
(define (send object message . args)
(apply (object message) args))
; 以下の関数は send を利用して object の外部で「フツーの関数」として
; 定義されている。
;; 削除関数
(define (delete object key)
(send object 'delete key))
;; キーのリストを得る
(define (getkeys object)
(send object 'getkeys))
;; 値のリストを得る
(define (getvalues object)
(send object 'getvalues))
;; 挿入関数
(define (insert object key val)
(send object 'insert key val))
;; 検索関数
(define (lookup object key)
(send object 'lookup key))