fuyuki

なんの役に立つのかわからんが書いてみるシリーズ。

alist-table

SLIBに同名のものがあるけど方向性がちがう。 こっちは単なるhash-tableもどき。

(use srfi-1)
(use gauche.collection)

(define-class <alist-table> (<collection>)
  ((key= :getter key=-of :init-keyword :key= :init-value eq?)
   (alist :accessor alist-of :init-value '())))

(define (make-alist-table . maybe-key=)
  (make <alist-table> :key= (get-optional maybe-key= eq?)))

(define-method alist-table-get ((self <alist-table>) key . maybe-default)
  (cond ((assoc key (alist-of self) (key=-of self)) => cdr)
        ((null? maybe-default)
         (error "alist table doesn't have an entry for key" key))
        (else (car maybe-default))))

(define-method alist-table-put! ((self <alist-table>) key val)
  (cond ((assoc key (alist-of self) (key=-of self))
         => (lambda (kv) (set-cdr! kv val)))
        (else (push! (alist-of self) (cons key val)))))

(define-method alist-table-exists? ((self <alist-table>) key)
  (if (assoc key (alist-of self) (key=-of self)) #t #f))

(define-method alist-table-delete! ((self <alist-table>) key)
  (receive (kv alist) (assoc+delete1! key (alist-of self) (key=-of self))
    (if kv
        (begin (set! (alist-of self) alist)
               #t)
        #f)))

(define-method call-with-iterator ((self <alist-table>) proc . args)
  (let1 p (alist-of self)
    (proc (lambda () (null? p))
          (lambda () (pop! p)))))

(define (find-tail+prev pred lis)
  (let loop ((lis lis)
             (prev '()))
    (if (null? lis)
        (values #f #f)
        (if (pred (car lis))
            (values lis prev)
            (loop (cdr lis) lis)))))

(define (assoc+delete1! key alist . args)
  (let1 = (get-optional args eq?)
    (receive (tail prev) (find-tail+prev (lambda (elt) (= (car elt) key))
                                         alist)
      (if tail
          (if (null? prev)
              (values (car tail) (cdr alist))
              (begin
                (set-cdr! prev (cdr tail))
                (values (car tail) alist)))
          (values #f alist)))))

(use gauche.test)
(test "" '((a . 1) ((b . 2) (c . 3)))
      (lambda () (receive r (assoc+delete1! 'a '((a . 1) (b . 2) (c . 3))) r)))
(test "" '((b . 2) ((a . 1) (c . 3)))
      (lambda () (receive r (assoc+delete1! 'b '((a . 1) (b . 2) (c . 3))) r)))
(test "" '((c . 3) ((a . 1) (b . 2)))
      (lambda () (receive r (assoc+delete1! 'c '((a . 1) (b . 2) (c . 3))) r)))
(test "" '(#f ((a . 1) (b . 2) (c . 3)))
      (lambda () (receive r (assoc+delete1! 'd '((a . 1) (b . 2) (c . 3))) r)))

(define a (make-alist-table))
(alist-table-put! a 'a 1)
(alist-table-put! a 'b 2)
(alist-table-put! a 'c 3)
(alist-table-put! a 'a 4)
(test "" #t (lambda () (alist-table-delete! a 'b)))
(test "" #f (lambda () (alist-table-delete! a 'b)))
(test "" 4 (lambda () (alist-table-get a 'a)))
(test "" #f (lambda () (alist-table-get a 'b #f)))
(test "" #t (lambda () (alist-table-exists? a 'a)))

Shiro 2003/01/11 21:07:02 PST: prevが必要なのって、callerがset-cdr!したいから ですよね。srfi-1はわりと関数型のアプローチに見えるので、そういう副作用を 前提とするアプローチは避けたんじゃないでしょうか。srfi-1には確かに!付き 手続きも多数定義されていますが、あくまで「実装は渡されたリストのセルを 再利用してもよい」というadvisoryな仕様であって、純粋に副作用無しで 実装することも許していますね。

write barrier使った世代別GCで、 新しいセルはstack allocationするような処理系だと、もしかするとset-cdr!より セルをコピーした方が速いなんてことはあるんでしょうか。 ありそうな気もするけど、そのへんちゃんと測ったこと無いのでわかりません。

あとfind等で2つ値を返すようにするのはCommonLispなんかで良くありますが、 CLでは使わない返り値が無視できるのに対し、Schemeでは受け手もきっちり 同じ数で受けなきゃならないので、嫌ったのかも。


memoizeといろいろ

そもそもmemoizeとはなにか

memoize。いわゆるひとつのmemoize。 テキストや論文にはよく出てくるくせに 実際に使われているのをめったに見ない謎の関数。 くわしくはこっち。

http://www.geocities.co.jp/SiliconValley-PaloAlto/7043/#memoize

(ていうかぜんぜん説明してないやろ、自分)

なお、PerlやRubyにもmemoizeモジュールがある。 でもってやっぱりあんまり使われていないみたい。

Schemeで書いてあるなかでいちばん凝ってそうなのがこれ。

http://www.mit.edu/afs/sipb/project/mechanics/scmutils/src/general/memoize.scm

まずは自分で書いてみる

R5RSだとこんな感じ。

;; In R5RS
(define (memoize fn)
  (let ((cache '()))
    (lambda args
      (apply values (or (cond ((assoc args cache) => cdr)
                              (else #f))
                        (call-with-values (lambda () (apply fn args))
                          (lambda result
                            (set! cache (cons (cons args result) cache))
                            result)))))))

どこにでもあるmemoize。 多値を扱えるのが特徴といえば特徴。

でもハッシュがあるならやっぱりそっちを使いたいよね。

Gaucheだとこんなん。

;; In Gauche
(define (memoize fn)
  (let1 cache (make-hash-table 'equal?)
    (lambda args
      (apply values (or (hash-table-get cache args #f)
                        (receive result (apply fn args)
                          (hash-table-put! cache args result)

                          result))))))

使う

よくある例。

(define (fib n)
  (cond ((= n 0) 0)
        ((= n 1) 1)
        (else (+ (fib (- n 1)) (fib (- n 2))))))

(set! fib (memoize fib))

(fib 100) => 354224848179261915075

よくない例。

(use srfi-27)

(set! random-real (memoize random-real)) ;memoized random

(random-real) => 0.9575068354342976
(random-real) => 0.9575068354342976
(random-real) => 0.9575068354342976

疑問をいだく

引数にキーワードが入ってると 「equal?じゃないけど意味的にはいっしょ」 な場合がありえるんですけどどうしたらいいですかせんせー。

ほっとけ。引数をどう扱うかなんてそんなもん関数の勝手だ。 気にせんでよろしい。

いじる

上のmemoizeはバックエンドがハッシュに固定されているので おもしろくない。 変えられるようにしてみる。

まずは単純に可変要素を引数にした例。

(define (memoize fn . args)
  (let-optionals* args ((init (make-hash-table 'equal?))
                        (put! hash-table-put!)
                        (get (lambda (cache args)
                               (hash-table-get cache args #f))))
    (let1 cache init
      (lambda args
        (apply values (or (get cache args)
                          (receive result (apply fn args)
                            (put! cache args result)
                            result)))))))

意味もなくキューをキャッシュにしてみる。

(use util.queue)
(set! fib
      (memoize fib
               (make-queue)
               (lambda (cache args result)
                 (queue-push! cache (cons args result)))
               (lambda (cache args)
                 (cond ((find-in-queue
                         (lambda (e) (equal? (car e) args)) cache)
                        => cdr)
                       (else #f)))))

もっといじる

上の例はこんなふうに書いたほうがよりScheme的かもしれない。

(define (memoize fn put! get)
  (lambda args
    (apply values (or (get args)
                      (receive result (apply fn args)
                        (put! args result)
                        result)))))

(use util.queue)
(define (memoize-queue fn)
  (let1 cache (make-queue)
    (define (put! args result)
      (queue-push! cache (cons args result)))
    (define (get args)
      (cond ((find-in-queue
              (lambda (e) (equal? (car e) args)) cache)
             => cdr)
            (else #f)))
    (memoize fn put! get)))

(set! fib (memoize-queue fib))

なお、memoizeを上のようにしておけば、 キューなんてもちださなくてもassocで素直に書ける。

(define (memoize-assoc fn)
  (let1 cache '()
    (define (put! args result)
      (set! cache (acons args result cache)))
    (define (get args)
      (cond ((assoc args cache) => cdr)
            (else #f)))
    (memoize fn put! get)))

(set! fib (memoize-assoc fib))

ハッシュ版はこう。

(define (memoize-hash fn)
  (let1 cache (make-hash-table 'equal?)
    (define (put! args result)
      (hash-table-put! cache args result))
    (define (get args)
      (hash-table-get cache args #f))
    (memoize fn put! get)))

(set! fib (memoize-hash fib))

結論(なんの)

むかしのLispの教科書だとこのへんで「おおLispの拡張性はすばらしい」 となるのかもしらんが、 いまどきこれで感心してくれる人はいないと思う。

次回は(つづくんかい)OO的なアプローチについて。

memoizeとうろうろ

混迷の現代をうろうろ切る(迷惑)。

前回のあらすじ

いやーmemoizeってけっこうえらかったのね。 てきとうに 検索にひっかかったやつ を読んでたら、 memoizeの源流は1968年のNatureに載った記事にさかのぼるらしい。 Natureって、あのNatureだよねえ?

残酷なOが支配する(こともある)

Schemeだとget, put!はクロージャとして渡すところだけど、 今のプログラマーなら 「get, put!というふたつのメッセージを受け取るオブジェクトを渡す」 と考える人のほうが圧倒的に多いと思う。 少なくともOO系言語ならそうする。現にRubyのmemoizeはそうなってる。

Gaucheだと、次のようにすれば <hash-table>がget, put!メッセージを受け取る感じになる。

(define-method get ((self <hash-table>) key)
  (hash-table-get self key #f))

(define-method put! ((self <hash-table>) key val)
  (hash-table-put! self key val))

(define h (make-hash-table))
(put! h 'a 1)
(get h 'a) => 1

で、memoizeをキャッシュとなるオブジェクトを取るように書き直す。

(define (memoize fn cache)
  (lambda args
    (apply values (or (get cache args)
                      (receive result (apply fn args)
                        (put! cache args result)
                        result)))))

(set! fib (memoize fib (make-hash-table 'equal?)))

Gaucheのメソッドディスパッチはあまり速くないらしいが、 この場合クロージャ渡し版と比べてたいした差は見られない。

クロージャ版。

;(time (fib 10000))
; real  23.829
; user  23.711
; sys    0.047

OO版。

;(time (fib 10000))
; real  24.581
; user  24.500
; sys    0.047

ということでいとも簡単に終わってしまったので、 別のネタをひねり出すことにする。

Soft Objects

「Lispだとオブジェクトシステムがほうらこんなに簡単」みたいなのは いろいろ見たけど、そのなかでは Soft Objects がいちばんのお気に入り。なにしろ単純でいい。 ちなみにCGの世界でいうsoft objectsとは全然関係なし。 どんなもんかというと、

つまりここでは「階級制を打破して大いなる一者に回帰すべし」という まことに日本人ごのみというかドイツ人ごのみというかな 思想が表明されているわけだ(ちがう)。 クラスがないあたりちょっと Self に似てなく もない。

まあうだうだ説明するより現物を見てもらったほうが早いと思う。 ミニマムな実装を論文から抜いてきた。

;; Taken from:
;; Ken Hasse, "Soft Object: A Paradigm for Object Orient Programming"
;; (ftp://publications.ai.mit.edu/ai-publications/pdf/AIM-1014.pdf)

(define (make-new-object old-object handlers)
  (define (new-object message . arguments)
    (if (eq? message 'handle) (make-new-object new-object arguments)
        (let ((local-handler (mget message handlers)))
          (if local-handler (apply local-handler arguments)
              (apply old-object message arguments)))))
  new-object)

(define (mget message handlers)
  (if (null? handlers) #F
      (if (eq? (car handlers) message) (cadr handlers)
          (mget message (cddr handlers)))))

(define (ignoramus message . arguments)
  (error "Can't handle message" message arguments))

(define ur-object (make-new-object ignoramus ()))

こんだけ。なにそれ。

変容のオブジェクト

いちおう上のコードを説明する。 "ur" はドイツ語から来た語でprimaryみたいな意味。 "ignoramus" はラテン語から来た語で「ものしらず」。 ってコードの説明じゃないけど、つまずきそうなのはこれくらいのもんでしょ。 なお、 EDICT でignoramusを引くと、「盲」「不束者」と出る。そう読みかえるのも一興。

例を見ないとようわからんという向きのために(おれだ)実際に使ってみる。 キャッシュオブジェクトを定義する。

(define cache
  (let1 h (make-hash-table 'equal?)
    (ur-object 'handle
               'get (lambda (key) (hash-table-get h key #f))
               'put! (lambda (key val) (hash-table-put! h key val)))))

ここではur-objectを変形してcacheというオブジェクトを生成している。 オブジェクトが括弧の先頭に来るのがいいやね。

let1の下をいんちきOO言語で書くと、

ur-object.handle('get => (lambda (key) (hash-table-get h key #f)),
                 'put! => (lambda (key val) (hash-table-put! h key val)))

といったところか。 つまり、ur-objectに対して 「これこれこういうメッセージを処理するオブジェクトを作ってね。 getが来たらこう、put!が来たらこう」という指令を出しているわけだ。 いいかえれば、原初の一を棒でつつくとたちどころに懐胎し、 光のアムダを産み落とすという筋書き。

アムダ(もういいって)をさらにつついてみる。

(cache 'put! 'a 1)
(cache 'get 'a) => 1

逆襲のmemoize

上で定義したcacheを取るようにmemoizeを書き換える。

(define (memoize fn cache)
  (lambda args
    (apply values (or (cache 'get args)
                      (receive result (apply fn args)
                        (cache 'put! args result)
                        result)))))

(set! fib (memoize fib cache))

あんまり変わんないね。 スピードはさすがに遅くなるだろうと思ったら、こっちもたいして変わらない。

;(time (fib 10000))
; real  23.403
; user  23.336
; sys    0.031
More ...