(new Hatena).blog()

radikoスケジューラー

Thu, 09 Dec 2010 00:00:00 +0900

聴きたいradikoの番組を聴き逃さないために、時間になったら自動的に番組を再生してくれるプログラムを作ってみました。

再生にはブラウザを使用するので、Schemeで番組表APIを叩いて検索、番組データをJSON化してブラウザに渡す、という流れになります。

ブラウザとSchemeの通信に関して、JSONPを使うかどうか悩んだんですが、Racket（PLT Scheme）のテンプレート・システムでHTMLデータを生成する方法を選びました。

メイン関数

(fun (radiko info)
  (aand (filter-map (find-progs info)
                    ((sxpath '(radiko stations station)) (timetable)))
        (progs.json it)
        (serve it)))

(radiko '((pfm "山里亮太")))

のように呼び出します。pfm（performer）やtitle等の検索項目の後に文字列のリストを並べると、OR検索が行われるようにしています。

ちなみに、個々の番組情報は以下のようなXMLデータです。

(prog
 (@
  (dur "7200")
  (ft "20101202010000")
  (ftl "2500")
  (to "20101202030000")
  (tol "2700"))
 (title "<![CDATA[ＪＵＮＫ〜山里亮太の不毛な議論〜]]>")
 (pfm "<![CDATA[山里亮太（南海キャンディーズ）]]>")
 (url "<![CDATA[http://abc1008.com]]>"))

TBSの番組なのにテレ朝系でネットされているという...。ラジオって自由で良いですね。

検索関数

(fun (find-progs info station)
  (aand (filter (finder info)
                ((sxpath '(prog)) station))
        (cons (station-id station) it)))

(fun (finder info)
  (apply orf
         (filter-map (fn ((cons key ref))
                       (aand (lookup key info)
                             (matcher ref it)))
                     `((pfm   . ,prog-pfm)
                       (title . ,prog-title)
                       (desc  . ,prog-desc)
                       (info  . ,prog-info)))))

(fun (matcher ref target prog)
  (set rx (regexp (string-join #\| target)))
  (aand (ref prog) (regexp-match? rx it)))

finder関数によって、ユーザーが与えた全ての検索条件が1つの検索関数にまとめられます。orf:

(fun (orf . fns)
  (if (ormap [eqv? (procedure-arity _) 1]
             fns)
      (fn (x)
        (ormap [_ x] fns))
      (fn args
        ((afn (fns)
           (and fns
                (or (apply (car fns) args)
                    (self (cdr fns)))))
         fns))))

JSON化関数

(fun (progs.json data)
  (aand (append-map (fn ((cons stid progs))
                      (map (fn (prog)
                             (make-immutable-hasheq
                              `((station . ,stid)
                                (start   . ,(prog-start prog))
                                (end     . ,(prog-end prog))
                                (pfm     . ,(prog-pfm prog))
                                (title   . ,(prog-title prog)))))
                           progs))
                    data)
        (filter [< (current-seconds) (hash-ref _ 'end)] it)
        (sort [< (hash-ref _1 'start) (hash-ref _2 'start)] it)
        (call-with-output-string [write-json it _])))

既に放送が終わっているものは削除したり、放送順に並べたりもしています。

HTML生成＋ブラウザ起動関数

(fun (serve progs)
  (send-url/contents (include-template "radiko.tmpl")))

include-templateというのはweb-server/templatesというライブラリのマクロで、コンパイル時にテンプレート・ファイルの解析を行います。

テンプレート中に、この例の場合@progsというシンボルがあると、スコープ内のprogsという変数の中身と置き換えられる仕組みです。

net/sendurlライブラリのsend-url/contents関数は、HTML文字列をファイル化してデフォルトのブラウザに開かせる、というものです。

その他

(fun (api path)
  (format "http://radiko.jp/~a" path))

(fun (area)
  (get-url (api "area")
    [regexp-match1 #rx"class=\"(.+?)\"" _]))

(fun (epg when)
  (sxml:document
   (api
    (format "epg/newepg/epgapi.php?area_id=~a&mode=~a" (area) when))))

(fun (timetable)
  (epg "today"))

(fun (nowplaying)
  (epg "now"))

(set cdata (regexp-match1 #rx"^<!\\[CDATA\\[(.+?)\\]\\]>$"))

(fun (string.path path)
  [aand ((sxpath path) _)
        (sxml:string it)
        (or (cdata it) it)])

(set station-id (string.path '(@ id)))

(set prog-pfm (string.path '(pfm)))
(set prog-title (string.path '(title)))
(set prog-desc (string.path '(desc)))
(set prog-info (string.path '(info)))

(fun (prog-time param prog)
  (time-second
   (date->time-utc
    (string->date ((string.path `(@ ,param)) prog) "~Y~m~d~H~M"))))

(set prog-start (prog-time 'ft))
(set prog-end (prog-time 'to))

いろいろと俺々なライブラリに依存しまくっていて申し訳ないんですが、ポータブルなコードよりもコンセプトの提示の方に関心がある、ということの表れなのでご容赦ください。

テンプレート：radiko.tmpl

今、日本でお気に入りされているYoutube動画

Fri, 05 Nov 2010 00:00:00 +0900

を一覧できるスクリプトを書いてみました。
jYoulike
ダウンロード

Twitterの検索APIを用いて、Youtubeのお気に入りボタンと連携して投稿されたツイートを検索し、サムネイル化します。

サムネイルをクリックするとインラインで動画が開きます。

常に最新の、画面に表示しきれるだけのサムネイルしか表示しない仕組みになっています。

Windowsの方は、HTMLファイルをダウンロードしてデスクトップの壁紙にするのがおすすめの使い方です（あ、その場合アイコンは非表示にした方が良いかもしれません）。

Scheme で定数定義

Thu, 24 Jun 2010 00:00:00 +0900

define がそろそろ長くて面倒になってきたので　(遅いですか？)、こういうマクロを作ってみました。

(define-syntax set
  (syntax-rules ()
    ((set id x) (define id x))))

これならタイプするのも簡単です。

Racket であれば

(define-syntax set (make-rename-transformer #'define))

で define のエイリアスを作ることも可能なんですが、変数定義用の限定版ということで、上のでも良いかなと思います。

発展形として、set で導入された id を再定義できなくする方法も考えてみました。

(define-syntax set
  (syntax-rules ()
    ((set id e)
     (begin
       (define id~ e)
       (define-syntax id
         (syntax-id-rules (set!)
           ((set! id _) (error 'id "is not modifiable."))
           ((id . es) (id~ . es))
           (id id~)))))))

> (set x 1)
> x
1
> (set! x 2)
x: is not modifiable.

syntax-id-rules 便利！

Scheme から Racket へ

Fri, 04 Jun 2010 00:00:00 +0900

ユーザーなのに気づくのが遅れたんですが、PLT Scheme の名称が Racket に変更されるそうです。

http://racket-lang.org/new-name.html
http://news.ycombinator.com/item?id=1221374

メーリングリストで時々 Racket という単語を見かけてはいたんですが、特に気にしてなかったんですよねー。何気なくググってみて真相を知り、一瞬びっくりしたんですが、すぐに「良いじゃん」という気持ちになりました。

今後私は Schemer ではなく Racketeer と呼ばれることになります（笑）。

MPEG-4、ツリー探索、autovivification

Mon, 24 May 2010 00:00:00 +0900

近ごろ動画や音声データの読み書きを Scheme でしているんですが、MPEG-4 の処理が個人的にかなり楽しかったので少し書きます。

MPEG-4 のデータはこのようなツリー構造になっており、お馴染みのツリー探索のテクニックが活躍しそうな雰囲気です。

(define structure
  '((moov . (mvhd trak udta iods))
    (trak . (mdia tkhd))
    (mdia . (minf mdhd hdlr))
    (minf . (stbl vmhd smhd dinf))
    (dinf . (dref))
    (stbl . (stsd stsc stts ctts stco co64 stss stsz))
    (udta . (meta cprt))
    (meta . (ilst id32))))

(全てを網羅したものではありません。例えば子ノード (box) を持たないトップレベル box はこの図には入っていません。)

MP4 のツリー構造にはルートノードというものは無く、トップレベルの box が複数並んでいる構成のため、box を構造体 (下記) で表し、それらをリストでまとめるという方法で扱っていきます。

(define-struct box
  (size type ext-size data))

size は 32 ビットの符号無し整数で、box のサイズがそれを超える場合は size を 1 とし、64 ビットの ext-size フィールドを使う仕様になっています。

data にはバイト列か、サブツリーとして box のリストを入れます。なお、メディア本体の場合はバイト列に変換せず、入力ポートをそのまま置くこととします。

ツリーの読み込みは前述のように、トップレベル box をリストで集めるだけです。

(fun (mp4-boxes in)
  (let loop ((t '()))
    (receive (x done) (read-box in)
      ((if done reverse loop) (cons x t)))))

動画サイトの MP4 を扱う前提なので、メディア本体のデータは最後に来ることを想定しています。この順序は必ず保たなければいけません。

個々の box は以下で読み込みます。

(fun (read-box in)
  (receive (size type ext-size) (box-head in)
    (if (eq? type 'mdat)
        (values (make-box size type ext-size in) #t)
        (values (let ((dsize (data-size size ext-size)))
                  (make-box size type ext-size
                            (if (eq? type 'meta)
                                 (meta-tag dsize in)
                                (parent? type)
                                 (box-kids dsize in)
                                (read-bytes dsize in))))
                #f))))

(fun (box-kids size in)
  (let loop ((size~ 0) (kids '()))
    (if (= size~ size)
        (reverse kids)
        (receive (kid done) (read-box in)
          ;; `done' must not be #t here
          (loop (+ (box-size~ kid) size~)
                (cons kid kids))))))

parent? で子 box を持つタイプかどうかを判別します。最初の structure の左のコラムがそうです。

(define parent?
  [memq _ (map car structure)])

parent? は読み込みの際に必要ですが、ツリーの検索や更新をする場合には逆に、子からその親を調べる関数が必要になることに気づきました。

(fun (parent type)
  (ormap (fn ((cons par kids))
           (and (memq type kids) par))
         structure))

type を子に持つ親 box のシンボルを返します。#f が返った場合はトップレベル box だと判断します。

ここからが本題で、読み込んだツリー構造を更新する関数を作ります。タイトルを付けたりカバーアートを埋め込んだりする際に使うものです。

(fun (insert-box box boxes)
  (let ((par (parent (box-type box))))
    (if par
        (if (find-tree (is-box? par) boxes)
            (map-tree (fn (x)
                        (if (is-box? par x)
                          (update-box
                           x
                           (append (filter (negate
                                            (is-box? (box-type box)))
                                           (box-data x))
                                   (list box)))))
                      boxes)
            (insert-box (new-box par
                                 (if (eq? par 'meta)
                                     (list null-space box)
                                     (list box)))
                        boxes))
        (cons box boxes))))

;; Helper functions

(fun (fold-tree f s t)
  (let loop ((t t) (s s))
    (aif (f t s)
          it
         (box? t)
          (loop (box-data t) s)
         (pair? t)
          (loop (cdr t) (loop (car t) s))
         s)))

(fun (find-tree p? t)
  (prompt
    (fold-tree (lambda (x _)
                 (if (p? x) (control k x)))
               #f
               t)))

(define weight
  (fold-tree (lambda (x s)
               (if (box? x)
                    (+ (box-head-size x)
                       (weight (box-data x))
                       s)
                   (meta-box? x)
                    (+ (meta-box-size x) s)
                   (meta-data? x)
                    (+ (meta-data-size x) s)
                   (bytes? x)
                    (+ (bytes-length x) s)))
             0))

(define ext-size? [>= _ (expt 2 32)])

(define (update-box abox data)
  (let* ((size (+ (weight data) 8))
         (ext? (ext-size? size)))
    (struct-copy box abox
                 (size (if ext? 1 size))
                 (ext-size (and ext? (+ size 8)))
                 (data data))))

(fun (new-box type data)
  ;; using update-box to auto compute the size
  (update-box (make-box 0 type #f #f) data))

box をツリー内の狙った位置に投入したいということで、まず親を探して (find-tree)、もしあればその中に追加する (map-tree, update-box)、無ければ親 box を作る、という流れです。

妙なこだわりで、"!" の付く構文を一切使いたくないというのがあるせいで、find-tree と map-tree で同じ検索を2度してしまうことになるのが残念です。

ここで思い出しました。必要無い時はコンスしない map の定義方法です。

(fun (map-tree f t)
  (aif (f t)
        it
       (pair? t)
        ;; To cons less often.  See:
        ;; http://okmij.org/ftp/Scheme/zipper-in-scheme.txt
        (let ((a (car t)) (d (cdr t)))
          (let ((a~ (map-tree f a)) (d~ (map-tree f d)))
            (if (and (eq? a a~) (eq? d d~))
                t
                (cons a~ d~))))
       (box? t)
        (let* ((x (box-data t))
               (x~ (map-tree f x)))
          (if (eq? x x~)
              t
              (update-box t x~)))
       t))

これに基づいて変更したバージョンが以下です。

(fun (insert-box box boxes)
  (let ((par (parent (box-type box))))
    (if par
        (let ((boxes~
               (map-tree (fn (x)
                           (if (is-box? par x)
                             (update-box
                              x
                              (append (filter (negate
                                               (is-box? (box-type box)))
                                              (box-data x))
                                      (list box)))))
                         boxes)))
          (if (eq? boxes boxes~)    ;not modified == par box not found
              (insert-box (new-box par
                                   (if (eq? par 'meta)
                                       (list null-space box)
                                       (list box)))
                          boxes)
              boxes~))
        (cons box boxes))))

find-tree を無くすことができました。

試しに使ってみましょう。空の box のリストに box を挿入しようとすると、

> (pp (insert-box (new-box 'ilst #f) '()))
(#(struct:box
   36
   moov
   #f
   (#(struct:box
      28
      udta
      #f
      (#(struct:box
         20
         meta
         #f
         (#"\0\0\0\0" #(struct:box 0 ilst #f #f))))))))

となり、自動的にツリー構造が生成されていることが分かります。(サイズ計算もばっちり)

検索して挿入する場合もこの通り、

> (pp
   (insert-box (new-box 'ilst #f)
               (insert-box (new-box 'cprt #f) '())))
(#(struct:box
   44
   moov
   #f
   (#(struct:box
      36
      udta
      #f
      (#(struct:box 8 cprt #f #f)
       #(struct:box
         20
         meta
         #f
         (#"\0\0\0\0" #(struct:box 8 ilst #f #f))))))))

うまく行っています。

ニコニコ動画の MP4 には udta の下に cprt (コピーライト) の box しか無いので、メタ情報 (ilst box) を追加するにはこの自動生成の機能が欠かせません。

多値アクセス構文

Sun, 23 May 2010 00:00:00 +0900

ML(やHaskell)のプログラマがタプルを使うような文脈でSchemerは多値を使うと思うんですが、値が一つだけ欲しいという場合に多値はちょっと不便なんですよね。

MLだとfstやsndというアクセサが使えるんですが、それに相当するものが無いなと思って、作ってみました。

(define (pos x)
  (or (string->number
       (substring (symbol->string (syntax-e x)) 1))
      1))

(define (positional-args var)
  (let loop ((n 1)
             (l (list (cons (pos var) var)))
             (r '()))
    (cond ((null? l)
           (let ((vars (reverse (map cdr r))))
             (append vars (gensym))))
          ((= (caar l) n)
           (loop (add1 n)
                 (cdr l)
                 (cons (car l) r)))
          (else
           (loop n
                 (cons (cons n (gensym)) l)
                 r)))))

(define-syntax (def-valref stx)
  (syntax-case stx ()
    ((def-valref ref _n)
     (with-syntax ((args (positional-args #'_n)))
       (syntax/loc stx
         (begin
           (define ref~ (lambda args _n))
           (define-syntax ref
             (syntax-id-rules ()
               ((ref v)
                (call-with-values (lambda () v) ref~))
               (ref ref~)))
           (provide ref)))))))

(def-valref fst _1)
(def-valref snd _2)

positional-argsは、例えば _3 というシンボルを与えると (g97 g98 _3 . g99) というリストを返す関数です。これをそのままラムダのパラメータ位置に置けば、目的の位置引数に変数をバインドできるわけです。

利用例です。このように、関数を置けない所で関数呼び出しっぽいスタイルで値を取り出すことができます。

> (fst (values 1 2 3))
1

こういう使い方も可能です。

> (call-with-values (lambda () (values 1 2 3))
    fst)
1

[追記]

後から気づきましたが、PLT Scheme の compose は多値を返す関数にも対応しているので、

(map (compose fst multi-valued-func) lst)

という使い方もできますね。

なお、fst はあくまでもマクロであることを強調しておきます。

PLT SchemeのREPLで直前の値を参照できるようにする

Sun, 28 Mar 2010 00:00:00 +0900

CLの処理系にも似たようなのがあると思いますが、HaskellのGHCiで、直前に評価された値にitでアクセスできるというのがあったので、真似してみました。

#lang scheme/base

(provide it)

(define it~ '())
(define eval~ (current-eval))

(define-syntax it
  (syntax-id-rules (set!)
    ((set! it _) (error 'it "is not modifiable."))
    ((it e ...) ((car it~) e ...))
    (it (apply values it~))))

(current-eval
 (lambda (x)
   (call-with-values (lambda () (eval~ x))
     (lambda results
       (unless (or (null? results)
                   ;; retain the old value if the new one was void
                   (and (null? (cdr results))
                        (void? (car results))))
         (set! it~ results))
       (apply values results)))))

デフォルトのevalをオーバーライドし、evalの結果 (results) を保存する処理を挟んでいます。resultsは多値をリスト化したものなので、それを改めて多値に変換するマクロとしてitを定義してあります。

itの定義にはsyntax-id-rulesを使っています。変数のように扱えるマクロを作るマクロです。変数的な振る舞いは3番目の節で定義しています。

関数適用の形でも使えるようにするには2番目の定義が必要です。順番が重要です。これを後に持ってきてしまうと関数適用の形式が捕捉できなくなるので注意しましょう。

あと細かいですが、GHCiではlet構文で変数束縛を行った後でも古いitが残るみたいなので、それも真似てみました (PLTではdefineの結果voidが返る、という挙動に基づいています)。

実行例

> (+ 1 2)
3
> it
3
> (+ it 4)
7
> list
#<procedure:list>
> (it 1 2 3)
(1 2 3)
> (thread
   (lambda ()
     ((lambda (f) (f f))
      (lambda (f)
        (display ".") (f f)))))
#<thread>
> .....................................(kill-thread it)
..........>

スレッドなど、readできない形式の値をグローバル変数にバインドし忘れた場合でもアクセスが可能になるので便利ですね。

なお、こういったREPLの拡張機能は次のようにコマンドライン引数で自動的に読み込まれるようにすると良いです。

(setq scheme-program-name "mzscheme -t /path/to/init/file -i")

Clojure風の無名関数構文

Wed, 17 Feb 2010 00:00:00 +0900

Arcには角括弧で無名関数を作る構文があります。

例:

> (map [if _ (+ 1 _) 1] '(1 -1 nil))
(2 0 1)

便利そうなのでマクロで模倣して喜んでいたんですが、1引数の関数しか作れないのが不便に感じることもありました。

で、最近Clojureにはその多変数版みたいなものがあるらしいのを知り、取り入れてみることにしました。

方針としては、従来のアンダースコアのみの識別子に加えて、その後に数字が付いているものも有効な変数と見なすようにします。

(define (underscore? stx)
  (and (identifier? stx)
       (let ((s (symbol->string (syntax-e stx))))
         (and (positive? (string-length s))
              (char=? (string-ref s 0) #\_)
              (let ((t (substring s 1)))
                (or (zero? (string-length t))  ; _
                    (string->number t)))))))   ; _[0-9]+

そして、マクロ展開時にコードからアンダースコア変数を抽出し、必要となる位置引数を調べます。この際、最初の引数を _1 に対応させることとします。

これらを数字の順番に並べてラムダのパラメータにすれば完成、となるはずです。

その作業を行うのがこちらです。

(define (pos x)
  (or (string->number
       (substring (symbol->string (syntax-e x)) 1))
      1))

(define (positional-vars vars)
  (let loop ((n 1)
             (l (sort (map (lambda (v)
                             (cons (pos v) v))
                           vars)
                      (lambda (x y)
                        (< (car x) (car y)))))
             (r '()))
    (cond ((null? l)
           ;; append rest parameter
           (append (reverse (map cdr r)) (gensym)))
          ((= (caar l) n)
           (loop (add1 n)
                 (cdr l)
                 (cons (car l) r)))
          (else
           (loop n
                 (cons (cons n (gensym)) l)
                 r)))))

アンダースコア変数が例えば _3 だけ、ということもあり得るので、抜けている変数は gensym で補うようにします。

positional-vars の返り値はドット対で、そのままラムダのパラメータ位置に埋め込まれます。

あまり普段はしない使い方だと思いますが、append の最後の引数が非リストの場合はドット・リストが作られます。ドットの後のシンボルがちょうど残余パラメータの役割を果たしてくれるわけです。

これにより、例えばこんな関数が定義できるようになります。

(define second [values _2])  ; values as identity

> (second 'a 'b 'c)
b
> (call-with-values (lambda () (values 'a 'b 'c))
    second)
b

有りそうで無かった感じがしません？

続き。マクロ本体

(define-syntax (make-brackets-funny stx)
  (syntax-case stx (as)
    ((make-brackets-funny (orig as name))
     (with-syntax ((tmp
                    (string->symbol (format "tmp-~a" (syntax-e #'orig)))))
       (syntax/loc stx
         (begin
           (define-syntax (tmp stx~)
             (syntax-case stx~ ()
               ((tmp . expr)
                (bracketed? stx~)
                (with-syntax ((vars
                               (positional-vars
                                (uniq-ids
                                 (filter underscore?
                                         (stx-filter
                                          (lambda (x)
                                            (or (identifier? x)
                                                (bracketed? x)))
                                          (unbracket #'expr)))))))
                  (syntax/loc stx~
                    (lambda vars (orig . expr)))))
               ((tmp . expr)
                (syntax/loc stx~ (orig . expr)))))
           (provide (rename-out (tmp name)))))))
    ((make-brackets-funny orig)
     (syntax/loc stx
       (make-brackets-funny (orig as orig))))
    ((make-brackets-funny orig . rest)
     (syntax/loc stx
       (begin (make-brackets-funny orig)
              (make-brackets-funny . rest))))))

色々省略しましたが、大枠は以上です。

アンダースコア変数を取り出す際に、ネストされている角括弧構文は探索しないようにするのがポイントです (stx-filterの部分)。

(make-brackets-funny #%app if ...)

のようにして利用します。Arcのようにリーダーに手を入れているわけではないので (そうすべきなのかも知れませんが)、無名関数化したい構文ごとに構文を再定義する必要があるんです。

ファイル:
arcfun.ss mlfun.ss

環境を汚さないrequire

Thu, 07 Jan 2010 00:00:00 +0900

トップレベルで作業をする時に、どうしてもライブラリを利用したくなりますが、その時にrequireで幾つもロードしていると、何となくREPLを汚してしまってるような気分になります。

実際それで困ることはまず無いんですが、たまに基本構文のセマンティクスが変わって戸惑うこともあったりします。

そこで思い出したのが名前空間です。

PLT Schemeでは名前空間が第一級オブジェクトなので、式評価の環境を自在に作ったり変更したりできるんです。

例えば

> (current-namespace (make-empty-namespace))

とするとREPLの環境がまっさらな状態になる、という具合です (関数適用すらできなくなります)。

これを利用して、ローカルな環境の中だけでライブラリを読み込む構文を作ってみました。

(begin-for-syntax
  (define req-specs
    (append '(for-meta for-syntax for-template for-label just-meta)
            '(only prefix all-except prefix-all-except rename)))

  (define (req-spec? spec)
    (or (module-path? spec)
        (and (pair? spec)
             (memq (car spec) req-specs)))))

(define-syntax (with-require stx)
  (syntax-case stx ()
    ((with-require mod . body)
     (req-spec? (syntax->datum #'mod))
     #'(with-require (mod) . body))
    ((with-require (mod ...) . body)
     (andmap req-spec? (syntax->datum #'(mod ...)))
     #'(parameterize ((current-namespace (make-base-namespace)))
         (for-each namespace-require '(mod ...))
         (eval '(begin . body))))))

例

> (with-require "prelude.ss"
    (aif 0 (add1 it)))
1
> aif
reference to undefined identifier: aif

参考:
http://docs.plt-scheme.org/guide/eval.html
http://docs.plt-scheme.org/guide/mk-namespace.html

Purely Functional Red-Black Tree

Thu, 03 Dec 2009 00:00:00 +0900

ちょっと思い立って作ってみました。

最初はProgramming Praxisで示されている実装から出発したんですが、結果的にはHaskell版の実装に近い形に変化していきました。

アルゴリズム等の解説はWikipediaに譲ることにして、ここではマクロを活用して煩雑なパターンマッチをHaskellっぽく簡潔に行う方法など、テクニック的な話題や応用例を紹介したいと思います。

ツリー構文

まず、ツリーの構造を定義します。

(define-struct tree (color left node right))

(define empty (make-tree 'black #f (cons #f #f) #f))
(define (empty? t) (eq? t empty))

キーと値は cons で纏めて node として一体的に扱うことにします (最初は別々にしていたんですが、あまりにもコーディングが煩雑になったので…)。

構造体を利用する際に便利なのが match 構文です。

> (match (make-tree 'black empty '(1 . #f) empty)
    ((struct tree ('black (? empty?) x (? empty?)))
     "This is a black tree with both subtrees empty."))
"This is a black tree with both subtrees empty."

このように、アクセサ関数を使わずとも色の判定ができたりして、コードが簡潔になります。

でも、もっと簡潔にすることはできないでしょうか？

例えば

(match (T B E '(1 . #f) E)
  ((T B E x E)
   "This is a black tree with both subtrees empty."))

のように書ければ素晴らしいですよね。

define-match-expander というマクロを使うと、それが可能になります。

(define-match-expander T
  (lambda (stx)
    (syntax-case stx ()
      ((T C a x b)
       (syntax/loc stx
         (struct tree (C a x b))))))
  (lambda (stx)
    (syntax-case stx ()
      ((T C a x b)
       (syntax/loc stx
         (make-tree C a x b))))))

最初のラムダがマッチ構文内での展開形、2番目は式として呼ばれた場合の展開形の定義です。

色

(define-match-expander R
  (lambda (stx)
    (syntax-case stx ()
      (R (syntax 'red))))
  (lambda (stx)
    (syntax-case stx ()
      (R (syntax 'red)))))

(define-match-expander B
  (lambda (stx)
    (syntax-case stx ()
      (B (syntax 'black))))
  (lambda (stx)
    (syntax-case stx ()
      (B (syntax 'black)))))

空ツリー

(define-match-expander E
  (lambda (stx)
    (syntax-case stx ()
      (E (syntax/loc stx (? empty?)))))
  (lambda (stx)
    (syntax-case stx ()
      (E (syntax/loc stx empty)))))

R、B、E が、マクロでありながら値のように扱えることを確認してみましょう。

> (list R B E)
(red black #s(tree black #f (#f . #f) #f))

構文の準備ができると、例えば赤い木を黒くする関数が、このように書けるようになります。

(fun (blacken (and t (T B _ _ _))) t
  \| (blacken (T _ a x b))         (T B a x b))

パターンマッチとツリーの生成とが同じ形式になっていますね (2行目)。

1行目は、木が既に黒ければそのまま返すというパターンです。and が ML や Haskell の as パターンと同じ意味で使えるということです。

もちろんネスティングも可能です。

> (match (T R E '(1) (T B (T R E '(2) E) '(3) E))
    ((T R _ x (T B (T R _ y _) z _))
     (append x y z)))
(1 2 3)

このHaskell風の構文糖衣が無ければいかに煩雑なコードになるか、想像に難くないでしょう。

キーの比較

ツリーのバランスを保ったり、要素を検索したりする上で必要なのが、キーの比較関数です。

数値や文字列、シンボルなど、比較可能なものであれば何でもキーにできるようにしたいんですが、比較方法を利用側で指定するのはやや面倒なんですね。

そこで、型変換ライブラリと同じような要領で、予め既知のデータ型については比較関数を用意しておいて、キーが与えられた時にそれに合ったものを選ぶ、という方式を考えました。

(fun (hany f h)
  (prompt
    (hash-for-each h
                   (fn (k v)
                     (aif (f k v)
                       (control _ it))))
    #f))

(fun (cmp = < x y)
  (if (= x y) '=
      (< x y) '<
              '>))

(define-values (install-cmp comparator)
  (let ((h (make-hasheq)))
    (values (fn (? = <)
              (hash-set! h ? (cmp = <)))
            (fn (x)
              (hany (fn (? cmp)
                      (and (? x) cmp))
                    h)))))

データ型に応じた比較関数を以下のようにインストールしておきます。

(install-cmp number? = <)
(install-cmp symbol? eq? (fn (x y)
                           (string<? (symbol->string x)
                                     (symbol->string y))))
...

テスト

> (let ((cmp ((comparator 0) 0)))
    (values (cmp 1) (cmp 0) (cmp -1)))
<
=
>

これにより、ユーザーに対して具体的な比較方法を意識させない仕方でツリー生成関数を提供できることになります。すなわち、比較関数ではなく代表的なキーの値を与えさせるわけです。

(fun (make-tree~ k) (cons (comparator k) empty))

(make-tree は構造体の生成関数なので、ライブラリ中ではチルダを付けておいて、エクスポート時にチルダを外すようにします)

ツリーの利用者はこのインターフェース関数を呼び出して空のツリーと比較関数を (無意識に) 作ります。

なおライブラリ側では、全てのツリー操作を通じて最初に作られた比較関数を使い回すようにすべきでしょう。

> (let* ((l '(4 1 2 5 3))
         (t (make-tree (car l))))
    (eq? (car (foldl (lambda (x t)
                       (tree-set t x '()))
                     t
                     l))
         (car t)))
#t

ツリー更新

ツリーに新しいノードを追加するための基本関数を、このように定義してみました。

(fun (tree-set~ reduce (cons cmp t) k v)
  (cons cmp
        (blacken
         (let loop (((and t
                          (T C a (and x (cons k~ v~)) b))
                     t))
           (if (empty? t)
               (T R E (cons k v) E)
               (case (cmp k k~)
                 (< (if (black? t)
                        (balance (loop a) x b)
                        (T R (loop a) x b)))
                 (= (T C a (cons k (reduce k v~ v)) b))
                 (> (if (black? t)
                        (balance a x (loop b))
                        (T R a x (loop b))))))))))

既に同じキーの要素が存在した場合の対応をパラメータ化することで (reduce)、以下のように自在に派生関数を作り出すことができます。

上書き版

(define tree-set (tree-set~ (fn (k old new) new)))

更新版

(fun (tree-add + t k v)
  (tree-set~ (fn (k old new) (+ old new)) t k v))

追加版

(fun (tree-cons t k v)
  (tree-add append t k (list v)))

なお balance 関数は、Haskell 版そのまんまです。

(define-syntax defmatch
  (syntax-rules ()
    ((defmatch name ((pat ...) . body) ...)
     (define name
       (match-lambda** ((pat ...) . body) ...)))))

(defmatch balance
  (((T R a x b) y (T R c z d))
   (T R (T B a x b) y (T B c z d)))
  (((T R (T R a x b) y c) z d)
   (T R (T B a x b) y (T B c z d)))
  (((T R a x (T R b y c)) z d)
   (T R (T B a x b) y (T B c z d)))
  ((a x (T R b y (T R c z d)))
   (T R (T B a x b) y (T B c z d)))
  ((a x (T R (T R b y c) z d))
   (T R (T B a x b) y (T B c z d)))
  ((a x b)
   (T B a x b)))

応用例 (素因数分解)

tree-add を利用する例として、同じオブジェクトの出現回数を数える、というケースが考えられます。ここでは整数を素因数のリストに変換して、それをさらにSchemeの数式に変換する、という問題を解きます。

(fun (factorize~ n)
  (let loop ((n n) (d 2) (l '()))
    (if (< (/ n d) d)
        (cons n l)
        (receive (q r) (quotient/remainder n d)
          (if (zero? r)
              (loop q d (cons d l))
              (loop n (+ (if (= d 2) 1 2) d) l))))))

中身はあまり重要ではないので結果だけ見てください。

> (factorize~ 1984)
(31 2 2 2 2 2 2)

これにシンボル * を cons すればそのまま掛け算の式になりますが、そうではなく、同じ数の掛け算は指数の形に変換したいです。

こんな時、tree-add が使えます。

(fun (factorize n)
  (let ((l (map (fn ((cons n p))
                  (if (= p 1) n `(expt ,n ,p)))
                (tree->alist
                 (foldl (fn (x t)
                          (tree-add + (or t (make-tree x)) x 1))
                        #f
                        (factorize~ n))))))
    (if (null? (cdr l))
        (car l)        ; prime number
        (cons '* l))))

いちおう検算

> (apply values
         (map ((fn (x f) (f x)) 1984)
              (list factorize~
                    factorize
                    (compose eval factorize))))
(31 2 2 2 2 2 2)
(* (expt 2 6) 31)
1984

2番目の値がツリーの活用の成果です。細かいですが、2の指数の項が先に来ているのは偶然ではなく、キーの並び順通りにリスト化された結果です。

なお、ツリーからリストへの変換は以下のように定義しています。

(fun (tree-fold (cons _ t) f seed)
  (let loop (((and t
                   (T _ a (cons k v) b))
              t)
             (seed seed))
    (if (empty? t)
        seed
        (loop a
              (f k v (loop b seed))))))

(fun (tree-map f t)
  (tree-fold t (fn (k v l) (cons (f k v) l)) '()))

(define tree-keys (tree-map (fn (k _) k)))
(define tree-values (tree-map (fn (_ v) v)))
(define tree->alist (tree-map cons))

既存ノードの更新

キーが既に存在する場合のみ値を更新したい、という要求が生じることもあります。

これを単純に、ツリーを検索して見つかれば tree-set で更新、というやり方にしてしまうと、同じ検索を2回繰り返すという無駄が生じます。

また、見つからなければ何もしない、というのは tree-set~ では表現できないことなので、別な関数が必要になります。

(fun (tree-reset new (cons cmp t) k)
  (cons cmp
        (or (let loop (((and t
                             (T C a (and x (cons k~ v)) b))
                        t))
              (if (empty? t)
                  #f
                  (case (cmp k k~)
                    (< (aif (loop a) (T C it x b)))
                    (= (T C a (cons k (new v)) b))
                    (> (aif (loop b) (T C a x it))))))
            t)))

ツリーが空になった (キーが見つからなかった) 場合に、#f の代わりに空ツリーを返すようにすれば or や aif は不要になるんですが、不要なツリー生成をしないためにこのように工夫してあります。

マクロ: anaphora.ss arcfun.ss arcif.ss letfun.ss mlfun.ss

連想リストを適用可能にするために必要なこと

Mon, 16 Nov 2009 00:00:00 +0900

連想リストから値を検索する際に、このように lookup 関数を毎度毎度呼び出すのが面倒だなーと思うことがあります。

(let ((al '((a . 1) (b . 2) (c . 3))))
  (list (lookup 'a al) (lookup 'b al) (lookup 'c al)))

これを、

(al 'a)

のように書けたら楽ですよね。(特に、データの提供者と利用者とを分離して、データを集めて提供する側でこのように適用可能な形にして返してくれるのが理想的だと思います。)

ここで、キーとオブジェクトの順序が lookup の呼び出しとは逆になっていることに着目すると、

(lambda (al) (lambda (k) (lookup k al)))

lookup の上に、引数を逆順に受け取るようにして lambda を被せてやれば良いことが分かります。

この操作を一般化したものを Haskell では flip と呼びます。

定義

(fun (flip f x y) (f y x))

実行例

> (let ((obj (flip lookup '((a . 1) (b . 2) (c . 3)))))
    (list (obj 'a) (obj 'b) (obj 'c)))
(1 2 3)

他のものでも試してみましょう。

例えばリストですが、list-ref は語順が lookup と逆なので、flip で適用可能にすることはできません。

でも、flip の2乗ならば？

> (define flip^2 (compose flip flip))
> (let ((obj ((flip^2 list-ref) '(a b c))))
    (list (obj 0) (obj 1) (obj 2)))
(a b c)

できました。vector-ref や string-ref 等でも同様です。

fun マクロによって flip が (ひいては f が) 部分適用可能になることで、適用可能なオブジェクトが自動的に作られている、というのが今回の要点です。

いずれにせよ2引数関数にしか使えない技ですが。

ifのセマンティクスをarc風にする試み

Mon, 28 Sep 2009 00:00:00 +0900

anaphoric ifを使っていて時々感じるんですが、やはり空リストが偽として扱われない Scheme の意味論は、実用上どうしても不便なことが多いです。

例えば、cdr が空でなければループを続ける

(if (pair? (cdr l))
    (loop (cdr l))
    ...)

というパターンを

(aif (cdr l)
     (loop it)
     ...)

と書けないようでは、aif の魅力も半減と言わざるを得ません。

そこで、if 及び関連の構文を arc 風のものに大胆に置き換えることで、上記のようなプログラミングができるようにしようと考えました。

まず、どの値を偽とするかを決めます。

(define (ar-false? x)
  (or (not x) (null? x)))

シンボルの nil は、もともと使ってないので偽としては扱わないことにします。代わりに、

(define-values (t nil) (values #t #f))

として nil の意味をブール値の偽と定めます。

空リストとしては使えませんが、元来の if に基づいて書かれた関数群 (filter とか) とも共存する必要があるため、この決定はやむを得ません。

以上に基づいて、arc 風 if はこのように再帰的に定義することができます。

(defarc-syntax ar-if
  (syntax-rules ()
    ((ar-if) nil)
    ((ar-if expr) expr)
    ((ar-if test then . else)
     (if (ar-false? test) (ar-if . else) then))))

(defarc-syntax は ar-if を if にリネームしてエクスポートするマクロです)

MzScheme の if はelse部を省略できない3引数の構文ですが、これはゼロ引数以上のいわゆる variadic な構文です。ちなみにこれのおかげで arc には cond がありません。

その他

(defarc-syntax ar-and
  (syntax-rules ()
    ((ar-and) t)
    ((ar-and expr) expr)
    ((ar-and expr . rest)
     (ar-if expr (ar-and . rest)))))

(defarc-syntax ar-or
  (syntax-rules ()
    ((ar-or) nil)
    ((ar-or expr) expr)
    ((ar-or expr . rest)
     (let ((val expr))
       (ar-if val val (ar-or . rest))))))

(defarc-syntax ar-when
  (syntax-rules ()
    ((ar-when test . body)
     (ar-if test (begin . body)))))

(defarc-syntax ar-unless
  (syntax-rules ()
    ((ar-unless test . body)
     (ar-if test nil (begin . body)))))

評価例:

> (require "arcif.ss")
> (if)
#f
> (if (values 1 2))
1
2
> (if nil
       (/ 1 0)
      (cdr '(x))
       ((lambda (x) (x x))
        (lambda (x) (x x)))
      t)
#t

自分のモジュールに恐るおそるこれらの構文を導入してみて、エラーが出まくるかなと心配したんですが、案外すんなりと新しい (いや、古い、ですね) パラダイムに移行できたように思います。もう元の世界には戻れないかも知れません。

追記:

if のインデント用のelispを書いてみました。引数が2の場合は when と同様に、4引数以上の場合は cond っぽくインデントします。

(defun arc-indent-if (state indent-point normal-indent)
  (let* ((containing-form-start (elt state 1))
         (count+pos (count-sexp-args containing-form-start
                                     indent-point)))
    (when count+pos
      (let ((count (car count+pos))
            (pos (cdr count+pos)))
        (cond ((= count 2)
               (goto-char containing-form-start)
               (+ (current-column) lisp-body-indent))
              ((= count 3) normal-indent)
              ((> count 3)
               (setq normal-indent
                     (progn (goto-char containing-form-start)
                            (forward-char 1)
                            (forward-sexp 1)
                            (1+ (current-column))))
               (list (if (evenp pos)
                         (1+ normal-indent)
                       normal-indent)
                     containing-form-start)))))))

(defun count-sexp-args (containing-form-start indent-point)
  (goto-char containing-form-start)
  (let ((end
         (condition-case ()
             (save-excursion
               (forward-sexp 1)
               (backward-char 1)
               (skip-chars-backward " \t")
               (point))
           (error nil)))
        (count 0)
        (pos nil))
    (when end
      (condition-case ()
          (progn
            (forward-char 1)
            (forward-sexp 1)
            (while (< (point) end)
              (forward-sexp 1)
              (setq count (1+ count))
              (unless (or pos (< (point) indent-point))
                (setq pos count)))
            (cons count pos))
        (error nil)))))

(mapc (lambda (symbol)
        (put symbol 'scheme-indent-function 'arc-indent-if))
      '(if aif))

ファイル:
arcif.ss arcfun.ss mlfun.ss anaphora.ss

Threaded OR (in PLT Scheme)

Wed, 16 Sep 2009 00:00:01 +0900

ある必要があって、複数のリソースから最初に返答の得られたものを値として採用する、という構文を作ってみました。

実装:

(define-syntax spawn
  (syntax-rules ()
    ((spawn . e)
     (thread (lambda () . e)))))

;; cf: http://scheme.com/tspl4/examples.html#./examples:h11

(define (any-true thunks)
  (let ((cust (make-custodian)))
    (let loop ((engs
                (parameterize ((current-custodian cust))
                  (map (lambda (t)
                         (let ((c (make-channel)))
                           (spawn (channel-put c (t)))
                           (handle-evt c (lambda (v) (or v c)))))
                       thunks))))
      (and (pair? engs)
           (let ((v (apply sync engs)))
             (if (channel? v)
                 (loop (remove v engs))
                 (begin (custodian-shutdown-all cust)
                        v)))))))

(define-syntax por                      ;paralell or
  (syntax-rules ()
    ((por e ...)
     (any-true (list (lambda () e) ...)))))

書いている時は意識しなかったんですが、TSPL の「エンジン」の例で出てくる por という構文とそっくりだったので、そのようにリネームしました。

(sync evt ...)

で最も反応の早かったイベント (の値) が得られるんですが、それが #f だった場合は他のイベントを待つ必要があります。そのために handle-evt という関数で、値が #f の時は値でなくイベント自体を返すように工夫をしています。

例:

;; Don't try this at home ;-)
> (por ((lambda (x) (x x)) (lambda (x) (x x)))
       (begin (sleep (expt 2 32)) 1))
1

flet & labels in Scheme

Wed, 16 Sep 2009 00:00:00 +0900

ループ処理を書く時などに、全く同じ関数呼び出しを複数回書くことがあると思うんですが、それがどうも面倒*1なので、ローカル関数を手軽に作る構文を書いてみました。

マクロ:

(require "mlfun.ss")

(define-syntax define-flet
  (syntax-rules ()
    ((define-flet flet let)
     (define-syntax flet
       (syntax-rules ()
         ((flet ((name params . expr) (... ...)) . body)
          (let ((name (fn params . expr)) (... ...)) . body)))))))

(define-flet flet let)
(define-flet flet* let*)
(define-flet fletrec letrec)            ;`labels' in CL

(関数は lambda でも良いんですが、自動カリー化とかパターンマッチを組み込んである自作の fn を使っています)

例:

(fun (read-header in)
  (fletrec ((line () (read-line in 'any))
            (loop (l r)
              (if (string=? l "")
                  (reverse r)
                  (loop (line) (cons l r)))))
    (loop (line) '())))

追記:

let での変数のバインディングと flet のそれとではアリティーが違うことに着目して、変数と関数を両方バインドできるようにしてみました。

(define-syntax define-flet
  (syntax-rules ()
    ((define-flet flet let)
     (define-syntax (flet stx)
       (syntax-case stx ()
         ((flet loop . rest)
          (and (identifier? #'loop)
               (eq? (syntax->datum #'let) 'let))
          (syntax/loc stx
            (let loop . rest)))
         ((flet (bind (... ...)) . body)
          (quasisyntax/loc stx
            (let #,(map (lambda (x)
                          (syntax-case x ()
                            ((v e) x)
                            ((v p . e)
                             (syntax/loc x
                               (v (fn p . e))))))
                        (syntax->list #'(bind (... ...))))
              . body))))))))

モジュールのエクスポート時に flet を let にリネームすれば、let と flet の構文を統合することが出来ますね。

追記2:

let で関数束縛の構文を使った際に emacs でラムダっぽくインデントするようにしてみました。

(defadvice scheme-indent-function (after flet-hack activate)
  (unless ad-return-value
    (setq ad-return-value
          (scheme-indent-flet (ad-get-arg 0) (ad-get-arg 1)))))

(defun scheme-indent-flet (indent-point state)
  (goto-char (elt state 2))
  (when (and (eq (char-after) ?\()                 ;start of params
             (< (progn (forward-sexp 1) (point))   ;end of params
                indent-point))
    (condition-case ()
        (progn
          (backward-up-list 3)
          (forward-char 1)
          (when (and (looking-at "\\=let")
                     (< indent-point
                        ;; end of binding
			(progn (forward-sexp 2) (point))))
            (goto-char (elt state 1))
            (+ (current-column) lisp-body-indent)))
      (error nil))))

実は cl-indent.el で flet をどうやってインデントしているか調べようとしたんですが、難し過ぎて諦めかけました。

ライブラリ:
mlfun.ss

*1:インターナルdefineを使う方も多いと思うんですが、それだとdefineを何度も書くのが面倒、letだとlambdaを書くのが面倒、ということです

ルート探索を用いた型変換

Sun, 26 Jul 2009 00:00:00 +0900

Scheme のような、強い型付けがされた言語でプログラミングしていると、型変換の作業が面倒になることがあると思います。あるいは、複数の型のデータが流れ込んできて、それらを統一的に扱いたいというケースもあるかも知れません。

ということで、型変換の関数を自分で作ることにしたんですが、できるだけ面倒の無いように、変換の方法をプログラムが勝手に調べてくれれば楽だなぁと思いました。

そこで、次のような方法を考えてみました。

まず、隣接する型同士の変換関数を洗いざらいリストアップしておきます。型変換のリクエストがあると、2つの型を繋ぐルートを調べます。そのルート上にある関数を順に合成することで、離れた型同士の変換関数が自動的に生成される、という要領です。

以下、定義です。

(fun (hany f h)
  (reset0
    (hash-for-each h
                   (fn (k v)
                     (awhen (f k v)
                       (shift0 _ it))))
    #f))

ハッシュ表を活用するので、ハッシュ検索の関数を作ってみました。脱出のために部分継続を使ってあります。

(define-values (install-type type-of)
  (let ((h (make-hasheq)))
    (values (fn (a a?) (hash-set! h a a?))
            (fn (x)
              (hany (fn (a a?)
                      (and (a? x) a))
                    h)))))

型名を登録する関数と、型名を調べる関数です。何となくハッシュ表をグローバルに置きたくなかったのでちょっと妙な定義方法になっています。ローカル変数を複数の関数で共有したい場合の Scheme 流のやり方です。

(define-values (relate-types make-search)
  (let ((h (make-hasheq)))
    (values (let ((a-hash
                   [hash-ref! h _ (fn () (make-hasheq))]))
              (fn (a b a->b)
                (hash-set! (a-hash a) b a->b)))
            (fn (a path)
              (aand (hash-ref h a #f)
                    (fn (b)
                      (or (hash-ref it b #f)
                          (hany (fn (a~ a->a~)
                                  (aand (not (memq a~ path))
                                        (relation a~ b path)
                                        (compose it a->a~)))
                                it))))))))

型同士の関係 (変換関数) を登録する関数と、それをルート探索で調べる関数です。

探索のアルゴリズムは深さ優先と幅優先をミックスしたような感じになっています。が、常に最短経路が見つかるわけではないので、ちょっと回りくどい変換関数が作られてしまうことがあるかも知れません。

引数の path は、例えば vector と list の間をぐるぐるループしたりしないように、これまでの経路を覚えておくためのものです。

(fun (relation from to path)
  (cond ((eq? from to) values)
        ((make-search from (cons from path)) => [_ to])
        (else #f)))

(fun (coerce type x)
  (or (aand (type-of x) (relation it type '()) (it x))
      (error 'coerce "coercion method not known for ~s to ~a" x type)))

relation は2つの型の関係を返す関数です。これはメモ化した方が良いでしょうね。

coerce が型変換のインターフェースとなります。type-of でデータの型名を得て、relation でそれと対象の型との関係を調べます。あとはそれをデータに適用すれば良いだけです (aand 超便利！)。

ちなみに、CL や Arc の coerce とは引数の順番が逆になっていますが、自動カリー化が行われる言語ではこういう順番にするのが一般的です。

関数の定義は以上です。

型と型変換の定義はこのように分けて行います。

(for-each [apply install-type _]
          `((char   ,char?)
            (bytes  ,bytes?)
            (number ,number?)
            (string ,string?)
            (symbol ,symbol?)
            (vector ,vector?)
            (list   ,list?)))

(for-each [apply relate-types _]
          `((char    string  ,string)
            (char    number  ,char->integer)
            (bytes   list    ,bytes->list)
            (bytes   string  ,bytes->string/utf-8)
            (number  string  ,number->string)
            (string  bytes   ,string->bytes/utf-8)
            (string  number  ,string->number)
            (string  symbol  ,string->symbol)
            (string  list    ,string->list)
            (symbol  string  ,symbol->string)
            (vector  list    ,vector->list)
            (list    string  ,list->string)
            (list    vector  ,list->vector)))

内容的にはまだまだ不十分ですが、まぁテスト段階なのでこんなものです。本当なら数値型をもっとちゃんと定義したいところです。

また、バイト列から文字列への変換を、文字コードを自動検知して変換するようにすれば、例えばポートから文字列まで、文字コードのことを考えることなく変換できるようになるなぁとか、いろいろ想像と期待が膨らみます。

もちろんユーザー定義の型も登録可能です。が、注意すべきなのは

;; wrong
(install-type 'atom (negate pair?))

のような一般的な型を登録してしまうと、型の検知 (type-of) がうまく機能しなくなるということです。したがって、常に他のデータ型と重ならない、ユニークな型を登録する必要があります。

ただし、hany の代わりに hmany のような複数の型候補を返す関数を作って、それぞれについて平行して対象との relation を調べるようなシステムに変更すれば、この問題は解決されるんじゃないかと思います。

あと、リストから文字列への変換は以下のように定義した方が良いかもしれません。

(relate-types 'list
              'string
              [list->string (map (coerce 'char) _)])

実行例:

> (map (coerce 'symbol)
       (coerce 'list #"abc"))
(a b c)

バイト列からリストへの変換は一発なんですが、その要素 (整数) からシンボルまでは探索しなければ辿り着けませんね。

> (coerce 'symbol (coerce 'list #"abc"))
abc

これは数値のリストから文字列、さらにシンボルへと変換されています (たぶん)。リストから文字列への変換が list->string のままだとエラーが生じているはずです。

追記 (探索方式の見直し)

上で、この型システムにはオーバーラップする型を含められない制限があると言ったんですが、それだと一般の数値から整数への変換なども出来ないことに気付きました。ということで、atom の例えの所で思い付いた hmany 関数というのを作って、複数の型の候補から経路を探索できるようにしてみます。

(fun (hmany f h)
  (reset0
    (hash-for-each h
                   (fn (k v)
                     (awhen (f k v)
                       (shift0 cont
                         (cons it (cont))))))
    '()))

(fun (one-or-many l)
  (cond ((null? l) #f)
        ((null? (cdr l)) (car l))
        (else l)))

(define-values (install-type type-of)
  (let ((h (make-hasheq)))
    (values (fn (a a?) (hash-set! h a a?))
            (fn (x)
              (aand (one-or-many
                     (hmany (fn (a a?)
                              (and (a? x) a))
                            h))
                    (if (pair? it)
                        (sort-types it)
                        it))))))

type-of は、このバージョンでは #f か型 (シンボル) か、型のリストを返すようになります。

(define-values (order<types sort-types)
  (let ((h (make-hasheq)))
    (values (fn (lo hi)
              (hash-set! h hi (adjoin lo (hash-ref h hi '()))))
            (fn (l)
              (sort l
                    (afn (x y)
                      (aand (hash-ref h y #f)
                            (or (memq x it)
                                (ormap (self x) it)))))))))

型のリストを返す場合は、型階層の低い順から並ぶようにします (e.g. (integer number))。経路を全探索した時に、その結果から辺の数が最少のものを正しい経路として採用するんですが、たまに等しい距離の経路が並んでしまうことがあるので、その場合に備えて優先順位を付けるんです。

型階層は

(define-values (raise-type reduce-type)
  (values (fn (lo hi raise)
            (order<types lo hi) (relate-types lo hi raise))
          (fn (hi lo reduce)
            (order<types lo hi) (relate-types hi lo reduce))))

(reduce-type 'number 'integer (compose inexact->exact round))

のようにして定義します。型システム全体は階層の無いネットワークなんですが、その中に numerical tower のような階層構造を部分グラフとして組み込むというイメージです。

次に型システムの実装です。

(fun (make-graph)
  (let* ((h (make-hasheq))
         (a-hash [hash-ref! h _ (fn () (make-hasheq))]))
    (case-lambda
      ((a) (hash-ref h a #f))
      ((a b) (aand (hash-ref h a #f) (hash-ref it b #f)))
      ((a b a->b) (hash-set! (a-hash a) b a->b) a->b))))

初めのバージョンを作った時に、型の集合と型同士の変換の集合がグラフ構造を成すことに気付いたので、このような関数を作ってみました。型システムの定義と、経路探索のメモ化に使用します。

(define-values (relate-types search-paths)
  (let ((g (make-graph)))
    (values (fn (a b a->b) (g a b a->b))
            (afn (a b path)
              (if (eq? a b)
                  '(())
                  (aand (g a)
                        (apply append
                               (hmany (fn (a~ a->a~)
                                        (aand (not (memq a~ path))
                                              (self a~ b (cons a path))
                                              (map [append _ `(,a->a~)]
                                                   it)))
                                      it))))))))

search-paths は少々ややこしいですが、型 a から b への経路のリストを返す関数です。self で再帰呼び出しすることで深さ優先、hmany を使うことで全探索となっています。

(fun (sorted-car < l)
  (and (pair? l) (car (sort l <))))

(define least-cdr
  (sorted-car (fn ((cons _ x) (cons _ y)) (< x y))))

(fun (map-types from to)
  (aand (least-cdr
         (map [cons _ (length _)]
              (search-paths from to '())))
        (cons (apply compose (car it))
              (cdr it))))

map-types は2つの型の間の全ての経路のうち最短のものを選ぶ関数です。

この経路というのは隣接する型同士の変換関数のリストなので、compose を適用するとそのまま from から to への変換関数になってくれます。

返り値はその変換関数と経路の長さのペアとなっています。

メモ化バージョン。

(define-values (map-types remap-types)
  (let ((g (make-graph)))
    (values (fn (from to)
              (or (g from to)
                  (aand (least-cdr
                         (map [cons _ (length _)]
                              (search-paths from to '())))
                        (g from to
                           (cons (apply compose (car it))
                                 (cdr it))))))
            (fn (from to)
              (set! g (make-graph))
              (map-types from to)))))

型システムは実行時に自由に変更可能なため、いちおうルートの再計算ができるようにしておきます。

(fun (relation from to)
  (aand (if (and (symbol? from) (symbol? to))
            (map-types from to)
            (least-cdr
             (cond ((symbol? from)
                    (filter-map (map-types from) to))
                   ((symbol? to)
                    (filter-map [map-types _ to] from))
                   (else
                    (append-map [filter-map (map-types _) to]
                                from)))))
        (car it)))

(fun (coerce type x)
  (or (aand (type-of x) (relation it type) (it x)) x))

relation は map-types の car を取り出す関数となります。

探索の始点と終点が1対1の場合もあれば、下の例みたいに coerce の第1引数に type-of を使うと多対多となることもあるので、場合分けが必要です。

1対1以外の場合は、変換関数と辺の数のペアのリストが得られるので、その中から least-cdr で最少辺のものを選んでいます。

(fun (inc n x)
  (coerce (type-of x)
          (+ (coerce 'integer x) (or n 1))))

ライブラリ:
mlfun.ss arcfun.ss anaphora.ss

ML や Haskell でよく見る ' (プライム) 記号がうらやましかった件について

Wed, 24 Jun 2009 00:00:00 +0900

数学でよく使われる記号だと思うんですが、ML系のプログラムとか論文を読んでいると、1重引用符が識別子の後に付けられているのをよく見かけます。

ある関数の変種とか、ある変数に基づいて一時変数を作る時などに、いちいち新しい名前を考えなくて済むので便利なんですよね。

でも Scheme や Lisp では、この記号は quote の省略形という特別な意味を持っているので、使いたくても使えません。

で、何か良い案は無いものかとずっと思っていたんですが、ついに思い付きました。

チルダです。

(define (map~ f l)
  (cond ((null? l) l)
        ((f (car l))
         => (lambda (x)
              (cons x (map~ f (cdr l)))))
        (else
         (let* ((t (cdr l))
                (t~ (map~ f t)))
           (if (eq? t t~)
               l
               (cons (car l) t~))))))

emacs の一時ファイルみたいで、まさにぴったりという感じですよね。何で今まで気付かなかったんだろう…

部分継続について本気出して考えてみた

Tue, 23 Jun 2009 00:00:00 +0900

以前何度か部分継続について書いたことがあるんですが、当時は表面的な振る舞いを観察して何となく分かった気になった程度の拙い説明しか出来ませんでした。

その上、最近のプログラミングでもほとんど活用しておらず、改めて理解し直す必要を感じてきた次第です。

そこで今回は、部分継続の概念的な理解を目指し、基礎的な事柄を中心にまとめていきたいと思います。

基本的に PLT Scheme (MzScheme) の評価モデルに即して書いていくため、Scheme 一般に当てはまる話になっていない部分もあるかも知れません。その点ご了承ください。

Redex と継続

Scheme の評価モデルにおいて、

(+ 1 (+ 2 0))

という式を評価するとき、まず

(+ 2 0)

の部分が評価され、その結果の値に対して

(+ 1 [])

という残りの計算が行われます。

ここで角括弧で示した部分を reducible expression (redex) と言います。簡約 (単純化) 可能な式、という意味です。そして、もうそれ以上簡約できないところまで簡約を続けて値を得ることを「評価」と呼ぶわけです。

一方、角括弧を包む「残りの計算」の部分を「継続」と言います。

つまり、redex のある所には常に継続があるのです。両者が対概念と言うか、相補的な関係にあるものだということが分かりますね。

この redex と継続という、プログラムの評価中に当然に存在して、なおかつ分かちがたく合わさっているもののうち、継続を第一級オブジェクトとして取り出すのが Scheme の call/cc 関数です。

継続は関数なり

ここで

(+ 1 [])

という継続の意味を考えてみましょう。

角括弧で示された穴の部分には、何らかの値 (数値) が入ることが期待されます。そこで継続を、この穴の前後の文脈だと考えることができます。

しかし別の見方をすると、この「文脈」は、値を与えられるとそれに応じて値を返す働きをするわけですから、数学的な意味での関数そのものであるとも言えますね。

したがって、これは本質的に

(lambda (x) (+ 1 x))

という関数に等しいと考えられるわけです。

普通の継続と合成可能な継続

call/cc に触れる前に、MzScheme のプリミティブである call-with-composable-continuation 関数を紹介しておきます。

> (define c #f)
> (+ 1 (+ 2 (call-with-composable-continuation
             (lambda (k)
               (set! c k)
               0))))
3

ここで、call-with-composable-continuation を呼び出した位置がちょうど redex の位置で、それを包む式が継続ということになります。この場合は

(+ 1 (+ 2 []))

という文脈が k として返されます (c として保存)。

これに 0 を与えてみると、当然ながら

> (c 0)
3

という値が得られることになります。

また、c の呼び出しの外側を別の式で包むと

> (+ 1 (c 0))
4

となり、さらに続きの計算が行われています。

一方、伝統的な call-with-current-continuation (call/cc) はどうでしょうか？

> (+ 1 (+ 2 (call-with-current-continuation
             (lambda (k)
               (set! c k)
               0))))
3

> (c 0)
3

ここまでは同じです。

が、次の式は

> (+ 1 (c 0))
3

となります。c を呼び出した時点で脱出が起こるため、この式における継続そのものは破棄されてしまうんです。

この「脱出」が起こるというのが伝統的な継続の振る舞いであり、脱出を起こさない前者の継続のことは composable continuation と呼びます (他の継続と組み合わせたり、普通の関数と合成することも可能なため)。

もう一度、その非脱出性を確認しておきましょう。

> (+ 1 (+ 2 (call-with-composable-continuation
             (lambda (k)
               (k 0)))))
6

となって、

(+ 1 (+ 2 []))

という計算が、k が呼ばれた場所とその外側で2回行われていることが分かりますね。

部分継続とは

脱出が起こる起こらないという話をしましたが、では起こる場合、一体どこに向かって脱出するのでしょうか？

次の例を見てください。

> (+ 1 (+ 2 (call-with-current-continuation
             (lambda (k)
               (k 0)))))
3

composable の方を使った時は 6 が返ってきた計算ですが、こちらでは k を適用した時点で脱出が起こって、call-with-current-continuation 自体の継続が破棄されているんです。

で、どこに脱出したかということですが、結論から言うと、トップレベルに向かって脱出しています。

しかし、これは裏を返せば call/cc がトップレベルからの継続を捉えていたからだと言えるんです。

実は MzScheme における継続というのは全て部分継続 (delimited continuation) と呼ばれる種類のものです。

部分継続とは、継続全体のうち、プロンプトという特殊な継続フレーム (後述) で delimit された、つまり、区切られた部分のことです (このことから、プロンプトのことをデリミタと呼ぶ流儀もあります)。

上の例では REPL 自体が暗黙的にプロンプトに包まれているので、それと call/cc 呼び出しとの間が部分継続として切り取られていたことになります。

そして、部分継続における脱出というのは対応する (直近の) プロンプトに対して行われるので、この場合は REPL を包んでいるプロンプトに向かって脱出したというわけです。

プロンプトというものを理解するために、明示的なプロンプトを導入して実験してみましょう。

> (require scheme/control)
> (+ 1
     (prompt
       (+ 2 0)))
3

ただ導入しただけでは begin と何の変わりもありません。

脱出してみます。

> (+ 1
     (prompt
       (+ 2 (abort 0))))
1

トップレベルではなく prompt の位置までの脱出なので、その先の継続はちゃんと評価されていますね。

当然ながら prompt を外すと

> (+ 1
     (+ 2 (abort 0)))
0

となります。

また、

> (define c #f)
> (+ 1
     (prompt
       (+ 2
          (call-with-current-continuation
           (lambda (k)
             (set! c k)
             0)))))
3

c は prompt までの継続なので、その外側の継続は入っていません。ゆえに、

> (c 0)
2

となります。

継続フレーム

MzScheme において継続は、継続フレームという構成単位の連続として実装されています。

通常の評価過程においても継続フレームは増えたり減ったりしているんですが、これを明示的に操作することで、部分継続やエラー処理などの応用的な制御構造が作られるのです。

プロンプトというのも継続フレームの一種で、プロンプト・タグという目印によって、部分継続を切り取る際の区切りを示します。

また、現在の継続を任意のプロンプトに置き換えると、その時の続きの計算は破棄され、制御がプロンプトの位置に移ります。これが脱出のメカニズムというわけです。

基本的な制御オペレータ - prompt/control, reset/shift

いちいち call-with- なんちゃらとタイプするのは面倒なので、MzScheme ではプロンプトの設定や継続の取り出しのためのオペレータが scheme/control ライブラリで提供されています。

既にその内 prompt と abort を使ったんですが、さらに幾つか例を示していくのでぜひ慣れていってください。

> (+ 1 (prompt (+ 2 (control k 0))))
1

control で部分継続 (k) を取り出している例です。このように prompt で区切られた部分継続は control で捕捉するのが通例となっています。

control の呼び出しにより、部分継続が取り出されると同時に control 式本体の継続がプロンプトに移ります (つまり、脱出します)。

ここでは 2 を加える計算を取り出したわけですが、使わずに捨てているので単に abort したのと同じです。

k を使うと

> (+ 1 (prompt (+ 2 (control k (k 0)))))
3

となります。

繰り返し適用することもできます。

> (+ 1 (prompt (+ 2 (control k (k (k 0))))))
5

これは脱出を伴う call/cc では出来ないんでしたね。

> (+ 1 (prompt
         (+ 2 (call-with-current-continuation
               (lambda (k)
                 (k (k 0)))))))
3

最初に k を適用したところで脱出が起こるためです。

control の場合、あくまでも control の呼び出しにおいて脱出が起こるだけで、取り出された k 自体は脱出を起こさない、composable な継続だということが分かります。

次に、独習 Scheme のツリー・マッチングの問題を解いてみましょう。

prompt/control と似たペアで、reset/shift というのを使います。

(define (tree->generator t)
  (reset
    (let loop ((t t))
      (cond ((not (list? t))
             (shift k (cons t k)))
            ((pair? t)
             (loop (car t))
             (loop (cdr t)))
            (else #f)))))

リーフの列挙関数が既に存在した場合は、このように定義することもできます。

(define (tree->generator t)
  (reset
    (for-each-leaf (lambda (x)
                     (shift k (cons x k)))
                   t)
    ;; Mark the end of traversal
    #f))

すっきりしましたね。いずれにしてもループが回っている途中の状態が k として取り出され、リーフの値と共に外に放出されます。

shift が一時停止ボタン、k が再生ボタンと考えると分かりやすいかも知れません。取り出されたデータを保存しておいて、(それこそトイレ休憩をはさみつつ) REPL で手作業で回していくことだって可能です。

ループが回りきると #f が返り、終了が通知されます。

(define (same-fringe? t1 t2)
  (let loop ((x (tree->generator t1))
             (y (tree->generator t2)))
    (or (not (or x y))
        (and x y (eqv? (car x) (car y))
             (loop ((cdr x) 'next)
                   ((cdr y) 'next))))))

> (same-fringe? '(1 2 3 4 5)
                '(1 (((2 ((3)))) (4 (((5)))))))
#t

ちなみに。tree->generator を再掲しますが

(define (tree->generator t)
  (reset
    (let loop ((t t))
      (cond ((not (list? t))
             (shift k (cons t k)))
            ((pair? t)
             (loop (car t))
             (loop (cdr t)))
            (else #f)))))

これは深さ優先探索のアルゴリズムを実装したものです。ところが、これにちょっとした変更を加えるだけで、幅優先バージョンが作れてしまうんです (Biernacki et al.)。

(define (tree->generator/bf t)
  (reset
    (let loop ((t t))
      (cond ((not (list? t))
             (shift k (cons t k)))
            ((pair? t)
             (control k
               (k #f)
               (loop (car t))
               (loop (cdr t))))
            (else #f)))))

pair? の節に2行加えただけですよ。

では確かめてみましょう。

> (define (gen-for-each f g)
    (when g
      (f (car g))
      (gen-for-each f ((cdr g) #f))))
> (define t '(1 (((2 ((3)))) (4 (((5)))))))
> (gen-for-each (lambda (x)
                  (display x) (newline))
                (tree->generator t))
1
2
3
4
5
> (gen-for-each (lambda (x)
                  (display x) (newline))
                (tree->generator/bf t))
1
2
4
3
5

これはかなり凄いことなんじゃないでしょうか？

control と shift の違い

control で部分継続を捕捉する時は prompt で区切りを設定、shift を使うときは reset で、という風に、決まった組み合わせで使うのが慣例となっているんですが、実は prompt と reset は同じものの別名に過ぎません。

一方 control と shift は、次のような等式が成り立つ関係にあります。

(shift k k)  =  (control k (lambda (x) (prompt (k x))))

つまり shift は、k が適用される時にその場にプロンプトを設定するという性質があるんです。

以下の例でその効果の違いを見ることができます。

> (reset
    (for-each (lambda (x)
                (shift k
                  (cons x (k 'next))))
              '(1 2 3))
    '())
(1 2 3)
> (prompt
    (for-each (lambda (x)
                (control k
                  (cons x (k 'next))))
              '(1 2 3))
    '())
(3 2 1)

いずれの場合も、k が for-each ループを最後まで回して、その先にある空リストを捉えるという動作をする点では同じです。

ではなぜ結果が異なるのか、それを理解するために、評価ステップを書き出してみましょう。

reset/shift を使った方は

(reset
  (for-each (lambda (x)
              (shift k
                (cons x (k 'next))))
            '(1 2 3))
  '())
(reset
  (cons 1
        ((lambda (v)
           (reset
             (for-each (lambda (x)
                         (shift k
                           (cons x (k 'next))))
                       '(2 3))
             '()))
         'next)))
(reset
  (cons 1
        (reset
          (for-each (lambda (x)
                      (shift k
                        (cons x (k 'next))))
                    '(2 3))
          '())))
(reset
  (cons 1
        (reset
          (cons 2
                ((lambda (v)
                   (reset
                     (for-each (lambda (x)
                                 (shift k
                                   (cons x (k 'next))))
                               '(3))
                     '()))
                 'next)))))
(reset
  (cons 1
        (reset
          (cons 2
                (reset
                  (for-each (lambda (x)
                              (shift k
                                (cons x (k 'next))))
                            '(3))
                  '())))))
(reset
  (cons 1
        (reset
          (cons 2
                (reset
                  (cons 3
                        ((lambda (v)
                           (reset
                             (for-each (lambda (x)
                                         (shift k
                                           (cons x (k 'next))))
                                       '())
                             '()))
                         'next)))))))
(reset
  (cons 1
        (reset
          (cons 2
                (reset
                  (cons 3
                        (reset
                          (for-each (lambda (x)
                                      (shift k
                                        (cons x (k 'next))))
                                    '())
                          '())))))))
(reset
  (cons 1
        (reset
          (cons 2
                (reset
                  (cons 3
                        (reset '())))))))

のようになります。

冒頭の継続と redex の議論でいくと、redex の位置に継続が埋め込まれていくという、逆のことが起こっているようにも見えますね。

ここで重要なのは、ループごとに次の shift の脱出先が設定されているということです。言い換えると、ネストする shift の呼び出しにおいて、先行する shift で区切られた領域を後続の shift は超えられないようになっているのです。

この性質が、ローカル変数で言うところのレキシカル (静的) スコープに似ているということから、shift のことを静的な制御オペレータと呼ぶ場合があります。

後者では、ループ毎に同じ prompt の位置に脱出しますから cons の呼び出しが常に左側に積み上がっていくことになります。

(prompt
  (for-each (lambda (x)
              (control k
                (cons x (k 'next))))
            '(1 2 3))
  '())
(prompt
  (cons 1
        ((lambda (v)
           (for-each (lambda (x)
                       (control k
                         (cons x (k 'next))))
                     '(2 3))
           '())
         'next)))
(prompt
  (cons 1
        (let ()
          (for-each (lambda (x)
                      (control k
                        (cons x (k 'next))))
                    '(2 3))
          '())))
(prompt
  (cons 2
        ((lambda (v)
           (cons 1
                 (let ()
                   (for-each (lambda (x)
                               (control k
                                 (cons x (k 'next))))
                             '(3))
                   '())))
         'next)))
(prompt
  (cons 2
        (cons 1
              (let ()
                (for-each (lambda (x)
                            (control k
                              (cons x (k 'next))))
                          '(3))
                '()))))
(prompt
  (cons 3
        ((lambda (v)
           (cons 2
                 (cons 1
                       (let ()
                         (for-each (lambda (x)
                                     (control k
                                       (cons x (k 'next))))
                                   '())
                         '()))))
         'next)))
(prompt
  (cons 3
        (cons 2
              (cons 1
                    (let ()
                      (for-each (lambda (x)
                                  (control k
                                    (cons x (k 'next))))
                                '())
                      '())))))
(prompt
  (cons 3
        (cons 2
              (cons 1
                    '()))))

やはりここでも shift と同様の議論が成り立って、ネストする control 呼び出しにおいて1つの領域が共有される点が、変数の動的スコープ (dynamic extent) に似ているということで、control のことを動的な制御オペレータと呼びます。

その他のオペレータ

プロンプトを毎回新たに設定する・しないという話をしましたが、実はさらに、直前に設定されたプロンプトを保つ・保たないというバリエーションもあり得るんです。このことから、次の4つのオペレータの組を得ることができます (Shan)。

reset/shift
prompt/control
reset0/shift0
prompt0/control0

後の2組がプロンプトを保たないバージョンです。

例えば前節の例で reset0/shift0 を使うと

(reset0
  (for-each (lambda (x)
              (shift0 k
                (cons x (k 'next))))
            '(1 2 3))
  '())

経過は略しますが

(cons 1
      (cons 2
            (cons 3
                  (reset '()))))

のように評価され、結果的には同じリストが作られます。ただ、プロンプトが消えてしまうため、shift のような静的な性質は完全には保たれないことになります。

まぁ、このことに一体どんな便利な応用があり得るのかは、まだ良く分かっていない (研究されていない) んじゃないかと思います。

ただ、プロンプトを除去することが、保つことに比べて効率的だという実装面での理由があれば、このように結果が変わらない場合には 0 のバージョンを選択できる、という点ではメリットと言えるかも知れません。

[追記]

reset0/shift0 の用例を1つだけ思い付きました。Zipper というデータ構造の基本的なイテレーション関数 (fold-zipper) があるんですが、これを reset0/shift0 で定義しておくと

(define (fold-zipper kons knil zipper)
  (reset0
   (traverse-zipper (lambda (zipper)
                      (shift0 k (kons zipper (k #f))))
                    zipper)
   knil))

それに基づく関数で簡単に値の取り出し (脱出) が出来るようになるんです。

(define (find-zipper p? zipper)
  (reset0
    (fold-zipper (lambda (zipper _)
                   (and (p? (zipper-node zipper))
                        (shift0 k zipper)))
                 #f
                 zipper)))

これは reset/shift を使用した場合は無理です。そう考えると結構便利ですよね。認識不足でした。

参考文献

PLT Scheme Reference:
1.1 Evaluation Model
9.4 Continuations

Shan, Chung-chieh. Shift to Control
Biernacki, Dariusz., et al. On the Dynamic Extent of Delimited Continuations

もっと！ ML/Haskell っぽい関数構文

Wed, 27 May 2009 00:00:00 +0900

ML や Haskell では、関数を定義する時に、変数だけでなくリテラルやデータ・コンストラクタなどでパターンマッチをすることができますね。

PLT Scheme にも、それによく似た構文があります。

> (require scheme/match)
> (match '(1 . 2)
    ((cons x y) (list x y)))
(1 2)

これを利用して、以前の ML風および Haskell風関数構文を、より本物っぽくする方法を考えてみました。

結果から言うと、こういう関数定義ができるようになります。

> (fact 0 := 1
        n := (* n (fact (- n 1))))
> (fact 5)
120

(Haskell の文法とは少し異なる点に注意してください。関数名を繰り返さなくて済むというメリットを重視したものですが、後述のようにデメリットもあります)

まず、無名関数をパターンマッチに対応させるところから始めましょう。

PLT の match 構文では1つのデータに対するパターンマッチしか定義できないので、2変数以上の関数をパターンマッチ対応にするのはちょっと苦労しそうです。

と思ったんですが、match-let という派生構文と generate-temporaries という関数を使えば簡単でした。

(define-syntax (fn stx)
  (syntax-case stx ()
    ((fn () . expr)
     (syntax/loc stx (begin . expr)))
    ((fn params . expr)
     (stx-every identifier? #'params)
     (curry (syntax/loc stx (lambda params . expr))))
    ((fn (param ...) . expr)
     (with-syntax (((g ...) (generate-temporaries #'(param ...))))
       (curry
        (syntax/loc stx
          (lambda (g ...)
            (match-let ((param g) ...) . expr))))))))

パターンを直接 lambda の変数リストの中に置くことはできないので、一旦パターンに対応する一時変数を用意しておき (generate-temporaries)、それを lambda の変数リストにするんです。

そして match-let により、元のパターンと受け取った引数の組のリストを平行してマッチしていきます。

テスト

> ((fn ((cons x y))
     (list x y))
   '(1 . 2))
(1 2)

cons によるパターンマッチを関数のパラメータとしている例です。Haskell だと \(x:y) -> という風に書くところですね。

もちろん普通の変数をパラメータにすることもできます。

> ((fn ((cons x y) z)
     (list x y z))
   '(1 . 2) 3)
(1 2 3)
> (((fn ((cons x y) z)
      (list x y z))
    '(1 . 2))
   3)
(1 2 3)

(カリー化もばっちり！)

さて次に関数定義の構文なんですが、これまで導入を見送ってきた複数の節でのパターンマッチをサポートしてみましょう (Haskell 風構文との整合性もあるので fn ではサポートしません)。

節の区切りには ML と同じく縦棒を使いたいんですが、Scheme (Lisp) ではこれは特別な意味を持つ文字なので、そのまま使うことはできません。

> (string->symbol "|")
\|

というわけで、バックスラッシュでエスケープする必要がありますね。

(fun (fact 0) 1
  \| (fact n) (* n (fact (- n 1))))

という定義ができるようにしましょう。

(define-syntax fun
  (let ((vbar? (same-id? '\|))
        (cl:name
         (lambda (clause)
           (car (syntax-e (car clause)))))
        (cl:params
         (lambda (clause)
           (cdr (syntax-e (car clause)))))
        (cl:body cdr))
    (lambda (stx)
      (syntax-case stx ()
        ((fun . clauses)
         (stx-any vbar? #'clauses)
         (let ((clauses (stx-break* vbar? #'clauses)))
           (with-syntax ((name
                          (cl:name
                           (foldl (lambda (x y)
                                    (or (and (= (length (cl:params x))
                                                (length (cl:params y)))
                                             (free-identifier=? (cl:name x)
                                                                (cl:name y))
                                             y)
                                        (raise-syntax-error
                                         #f "malformed definition" stx)))
                                  (car clauses)
                                  (cdr clauses))))
                         (temps
                          (generate-temporaries (cl:params (car clauses)))))
             (quasisyntax/loc stx
               (define name
                 (fn temps
                   #,(let loop ((cl (car clauses))
                                (rest (cdr clauses)))
                       (let ((binds
                              (map list
                                   (cl:params cl)
                                   (stx->list #'temps)))
                             (body (cl:body cl)))
                         (if (stx-every identifier? (cl:params cl))
                             ;; No error handlers needed; ignore rest of
                             ;; clauses, if any
                             #`(let #,binds #,@body)
                             #`(with-handlers ((exn:misc:match?
                                                (lambda (x)
                                                  #,(if (pair? rest)
                                                        (loop (car rest)
                                                              (cdr rest))
                                                        #'(raise x)))))
                                 (match-let #,binds
                                   #,@body)))))))))))
        ((fun (name . params) . expr)
         (syntax/loc stx
           (define name (fn params . expr))))))))

最初の節でマッチに失敗したら例外を捕えて次の節を試す、という流れをお馴染みの再帰で組み立てています。

以下は縦棒で区切られた節を集める関数です (stx-break*)。

(require (only-in srfi/1 break))

(define (stx-break p? stx)
  (receive (l r)
      (break p? (if (syntax? stx)
                    (syntax->list stx)
                    stx))
    (values l
            ;; remove separator
            (if (pair? r) (cdr r) '()))))

(define (stx-break* p? stx)
  (let loop ((l stx) (r '()))
    (if (stx-null? l)
        (reverse r)
        (receive (x y) (stx-break p? l)
          (loop y (cons x r))))))

これで ML 版の関数構文は完成です。

次に Haskell 版ですが、これは元々 ML 版の糖衣構文だったので楽勝だろうと思いきや、以外とてこずってしまいました。

無名関数は変更無しなので関連部分のみ示します。

(require (only-in scheme/list add-between))

(define declare? (same-id? ':=))

(define-syntax (app-fun stx)
  (syntax-case stx ()
    ((app-fun n . e)
     (stx-any declare? #'e)
     ;; Convert
     ;;   (fact 0 := 1
     ;;         n := (* n (fact (- n 1))))
     ;; =>
     ;;   (fun (fact 0) 1
     ;;     \| (fact n) (* n (fact (- n 1))))
     (quasisyntax/loc stx
       (fun
           #,@(apply append
                     (add-between
                      (map (lambda (x)
                             (list (cons #'n (car x))
                                   (cdr x)))
                           (let loop ((l (syntax->list #'e)) (r '()))
                             (if (null? l)
                                 (reverse r)
                                 (receive (v e) (stx-break declare? l)
                                   (if (null? e)
                                       (raise-syntax-error
                                        #f "Malformed definition" stx)
                                       (loop (cdr e)
                                             (cons (cons v (car e))
                                                   r)))))))
                      '(\|))))))
    [snip]))

中置記法の := では上で作った stx-break* が役に立たないことに気付き、愕然としたのがてこずった理由です。

また、ML 版と違い、関数のボディーには1つの式しか置けないという制限も生じました (前の実装には無かった制限です)。ボディー部分と次の節の変数リストとの区切りが無いため、やむを得ない措置です。

ファイル:
mlfun.ss
hasfun.ss
hasfun-helper.ss
arcfun.ss

Anaphoric If

Wed, 13 May 2009 00:00:00 +0900

Arc の aif のように、意図的な変数キャプチャ (マクロ定義の中で作られた変数をマクロユーザーが参照できるようにすること) を用いたマクロを作る時、Scheme では一般に datum->syntax という関数を使います。

(define-syntax (aif stx)
  (syntax-case stx ()
    ((aif expr then else)
     (with-syntax ((it (datum->syntax #'aif 'it)))
       #'(let ((it expr))
           (if it then else))))))

datum->syntax の第1引数で、第2引数が有効になる範囲を指定します (ここでは aif 構文内)。なお、この場合 syntax-rules ではなく syntax-case で定義する必要があります。

これで、

> (aif (assq 'a '((a . 1) (b . -2)))
       (cdr it)
       0)
1

it によって (assq...) の値が参照できるようになるわけです。

さて、こちらは PLT Scheme のコミュニティーで知られている方法なんですが、

(require scheme/stxparam)

(define-syntax-parameter it
  (lambda (stx)
    (raise-syntax-error #f "can only be used inside anaphora" stx)))

(define-syntax aif
  (syntax-rules ()
    ((aif expr then else)
     (let ((val expr))
       (if val
           (syntax-parameterize ((it
                                  (make-rename-transformer #'val)))
             then)
           else)))))

構文パラメータというものによって、syntax-case や datum->syntax を使わずに特別な識別子を導入することができます。

この aif に基づいて、派生マクロが以下のようにいとも簡単に書けます。

(define-syntax awhen
  (syntax-rules ()
    ((awhen expr . body)
     (aif expr (begin . body) (void)))))

(define-syntax aand
  (syntax-rules ()
    ((aand) #t)
    ((aand expr) expr)
    ((aand expr . rest)
     (aif expr (aand . rest) #f))))

(define-syntax acond
  (syntax-rules (else)
    ((acond) (void))
    ((acond (else . body))
     (begin . body))
    ((acond (expr) . rest)
     (or expr (acond . rest)))
    ((acond (expr . body) . rest)
     (aif expr (begin . body) (acond . rest)))))

構文パラメータを使わないバージョンの aif ではこれは不可能です。上述の datum->syntax の第1引数云々の事情により、it が有効になる場所が元の aif 構文の中だけに限定されてしまうため、派生構文の中では it が使えないのです (実際には不可能ではないらしいんですが、分かりにくい方法なので紹介しないでおきます)。

さてここで、前回作った Arc の角括弧構文が使えるようにしてみましょう。モジュールを跨いで構文を拡張するのは若干気が引けますが

(require (only-in "arcfun.ss" make-brackets-funny))
(make-brackets-funny aif awhen aand acond)

> (map [aand (cdr _) (abs it)]
       '((a . 1) (b . -2) (c . #f)))
(1 2 #f)

あっさり出来ました。

追記:

モジュールを跨いでマクロを拡張するのは云々という不安の背景について、少し技術的な補足をいたします。

カリー化関数構文の部分評価の処理において、local-expand を使って式をフルに展開している箇所があります。

コードの分析のため、核構文のみの形にする必要があるからなんですが、そうすると、マクロ展開された式の中に、モジュールでエクスポートされていない識別子やローカル変数などが出てくる場合があるんです。

マクロが定義されているモジュールの外からそのような識別子にアクセスされることは、モジュールの安全性を脅かす事態です。というわけで、MzScheme では syntax certificate というものを問題のある識別子に付与し、アクセス権限の無い文脈でのアクセスがあるとコンパイル・エラーを発する仕組みになっています。

これが実は悩みの種で、以前の実装では、例えば fun 構文の中で aif 構文を使うと

compile: reference is more certified than binding in: val

のようなエラーが出てしまっていました。val は anaphora モジュールの中の aif 構文の定義に出てくるローカル変数であるため、サードパーティーのマクロ (まぁどっちも自分で作ってるんですが) からのアクセスが許可されないわけです。

悩み抜いた結果、ようやく解決方法が分かったのでここに書いておきます。

(define (collect-certs stx)
  (let loop ((stx stx) (certs '()))
    (cond ((syntax? stx)
           (loop (syntax-e stx) (cons stx certs)))
          ((pair? stx)
           (loop (cdr stx) (loop (car stx) certs)))
          (else certs))))

(define (stx-recertify stx)
  (let ((certs (collect-certs stx))
        (insp (current-code-inspector)))
    (lambda (stx)
      (let loop ((certs certs) (stx stx))
        (if (null? certs)
            stx
            (loop (cdr certs)
                  (syntax-recertify stx (car certs) insp #f)))))))

(define (stx->tree stx stop? (certify values))
  (let loop ((stx stx))
    (cond ((stop? stx) (certify stx))
          ((syntax? stx)
           (loop (syntax-e stx)))
          ((pair? stx)
           (cons (loop (car stx))
                 (loop (cdr stx))))
          (else stx))))

collect-certs により、expand して得られた構文オブジェクト (stx) に含まれる全ての syntax certificate を集めます。保護された識別子だけでなく、それを包む式に付与されたものも含めてです。実際に集めているのは構文オブジェクトなんですが、それに certificate が含まれています。

そして stx-recertify によって、個別に取り出された識別子に対し、集められた certificate を全て与えてしまいます (syntax-recertify)。

呼び出し方

(stx->tree expanded-syntax
           identifier?
           (stx-recertify expanded-syntax))

後はツリーのトラバーサル関数を使って自由にコード変形をすることができます。

一般に、1つのコードには複数のモジュールに由来するマクロの呼び出しがあるものなので、識別子の出自に関わらず全ての certificate を付与してしまうこの方法は少々乱暴な気もするんですが、エラーが出なくなったので取り敢えず良しとしておきます。

ファイル:
anaphora.ss arcfun.ss hasfun-helper.ss mlfun.ss

参考文献:
On Lisp - Anaphoric Macros
PLT Scheme Blog - Dirty Looking Hygiene

マクロを書くマクロで Arc の角括弧構文

Mon, 04 May 2009 00:00:00 +0900

Haskellっぽいカリー化関数の構文で、「Haskellっぽい」と言いながらも Arc の角括弧みたいな構文を導入しました。

実際にはそれにも偽りがありまして、見た目は Arc っぽいんですが実体は SRFI-26 の cut の糖衣構文に過ぎなかったわけです (次のように変換されます)

[+ _ 1]
; =>
(cut + <> 1)

個人的に cut は見た目が美しくないと感じるので全く使ってなかったんですが、この構文ならスマートですよね。

ただ、Arc のコードを見ていると、こんな用法もあることに気付きます。

[is (cadr _) name]
[if _ (+ _ 1) 1]

cut とはまるで別物です。_ で受けた値に関数を適用したり、if 文までも関数化したりしています。

前者はともかくとして、後者は関数適用の構文をハックする前回の手法ではどうしようもありません。

便利そうなのでやってみたいんですが、Arc のように reader に手を入れるのは何となく気が引けます (やったことが無いので)。

あきらめかけたところ、これも何となくなんですが、マクロを1つ書けば良いだけなんじゃ？という閃きがあり、その通りにしてみたら、驚くほど簡単に実現できました。

先に実装を示します:

(define (syntax->tree src-stx stop?)
  (define (cert stx)
    (syntax-recertify stx src-stx (current-code-inspector) #f))
  (let loop ((stx src-stx))
    (cond ((stop? stx) (cert stx))
          ((syntax? stx)
           (loop (syntax-e stx)))
          ((pair? stx)
           (cons (loop (car stx))
                 (loop (cdr stx))))
          (else stx))))

;; Adapted from: http://okmij.org/ftp/Scheme/zipper-in-scheme.txt
(define (map* f l)
  (if (not (pair? l))
      l
      (cons (f (car l)) (map* f (cdr l)))))

(define (depth-first handle tree)
  (cond ((handle tree))
        ((pair? tree)
         (map* (lambda (kid)
                 (depth-first handle kid))
               tree))
        (else tree)))

(define (bracketed? stx)
  (and (syntax? stx)
       (eq? (syntax-property stx 'paren-shape) #\[)))

(define (unbracket stx)
  (syntax-property stx 'paren-shape #f))

(define (underscore? stx)
  (and (syntax? stx) (eq? (syntax-e stx) '_)))

(define-syntax (make-brackets-funny stx)
  (syntax-case stx ()
    ((make-brackets-funny orig)
     (with-syntax ((new
                    (string->symbol
                     (format "new-~a" (syntax-e #'orig)))))
       (syntax/loc stx
         (begin
           (define-syntax (new stx)
             (syntax-case stx ()
               ((new . e)
                (bracketed? stx)
                (let ((g (gensym)))
                  (quasisyntax/loc stx
                    (lambda (#,g)
                      (orig . #,(depth-first
                                 (lambda (x)
                                   (and (underscore? x) g))
                                 (syntax->tree (unbracket #'e)
                                               (lambda (x)
                                                 (or (identifier? x)
                                                     (bracketed? x))))))))))
               ((new . e)
                (syntax/loc stx (orig . e)))))
           (provide (rename-out (new orig)))))))
    ((make-brackets-funny orig rest ...)
     (syntax/loc stx
       (begin (make-brackets-funny orig) (make-brackets-funny rest ...))))))

(make-brackets-funny #%app if or and)

関数適用や if 等の構文で角括弧が使われていた場合に、Arc 同様1変数のラムダに変換するという macro-generating macro です (make-brackets-funny)。すなわち、例えば

[if _ (+ _ 1) 1]
; =>
(lambda (g)
  (if g (+ g 1) 1))

という変換が行われるように任意の構文を拡張するマクロを書くマクロです。

syntax->tree でコードをコンスのツリー構造に変換、ツリー探索 (depth-first) によりアンダースコアを探して実際の変数 (g) で置き換えていきます。

ただしその際、角括弧がネストできるように内側の角括弧の _ を置き換えてしまわないよう注意しなければなりません。

syntax->tree の第2引数はこのための対策で、コード分解を途中で止めるための停止条件を与えています。角括弧の式はバラさないでおくことで、内側の _ を置き換えから保護しているわけです。

用例を幾つか示しましょう。

cdr 部が 0 のコンスを探す

> (findf [= (cdr _) 0] '((a . 1) (b . 2) (c . 0)))
(c . 0)

絶対値関数はこのように書けます。

> (my-abs := [if (negative? _) (- _) _])
> (my-abs 1)
1
> (my-abs -1)
1

ネストの例

> ([map [+ _ 1] _] (1 .. 3))
(2 3 4)

thunk を呼ぶ例1

> (for-each [newline] (1 .. 3))



>

thunk を呼ぶ例2

> (map [_]
       (list (lambda () 1)
             (lambda () 2)
             (lambda () 3)))
(1 2 3)

ファイル:
hasfun.ss hasfun-helper.ss mlfun.ss arcfun.ss

Haskellっぽいカリー化関数の構文

Fri, 24 Apr 2009 00:00:00 +0900

以前作ったMLっぽいカリー化関数の構文を使って、今度はHaskellっぽいのを作ってみました。

こういうことが出来るようになります。

関数定義:

> (add x y := (+ x y))
> (add 1 2)
3
> ((add 1) 2)
3

ラムダ式:

> (map (x -> (+ x 1))
       '(1 2 3))
(2 3 4)
> (map (x y -> (+ x y))
       '(1 2 3) '(4 5 6))
(5 7 9)

セクション、と言うか Arc の角括弧:

> (map [+ _ 1] '(1 2 3))
(2 3 4)
> (map (+ _ 1) '(1 2 3))
(2 3 4)

以下、実装です。関数適用のフォームの評価をインターセプトし、新たな構文規則を追加するという、かなり過激なハックとなっています。

(provide (rename-out (my-app #%app)))

(define-syntax (my-app stx)
  (syntax-case stx ()
    ((my-app n . e)
     (stx-any declare? #'e)
     (receive (v e) (stx-break declare? #'e)
       (quasisyntax/loc stx
         (fun (n #,@v) #,@e))))
    ((my-app . e)
     (stx-any lambda? #'e)
     (receive (v e) (stx-break lambda? #'e)
       (quasisyntax/loc stx
         (fn #,v #,@e))))
    ((my-app . e)
     (stx-any hole? #'e)
     (quasisyntax/loc stx
       (cute
        #,@(map (lambda (stx)
                  (if (hole? stx) (syntax/loc stx <>) stx))
                (syntax->list #'e)))))
    ((my-app . e)
     (syntax/loc stx (#%app . e)))))

ユーティリティ:

(begin-for-syntax
  (fun (same-id? id stx) (eq? id (syntax-e stx)))

  (define-values (declare? lambda? hole?)
    (values (same-id? ':=) (same-id? '->) (same-id? '_)))

  (define (stx-any p? stx)
    (ormap p? (syntax->list stx)))

  (define (stx-break p? stx)
    (receive (l r) (break p? (syntax->list stx))
      (values l (cdr r)))))

構文展開系によって関数適用と見なされた式を捕らえ、特殊な識別子を含むかどうかチェックしています。

:= を含んでいれば関数定義、-> があればラムダ式、という風に分岐して振る舞いを変えるわけです。

Haskell みたく = を関数定義のために使いたかったんですが、そうすると関数としての = を引数として渡すことが不可能になるため、:= にしました。

追記:

Haskellの [i .. j] の構文を加えてみました。

数値

> (1 .. 10)
(1 2 3 4 5 6 7 8 9 10)
> (1 3 .. 10)
(1 3 5 7 9)

文字

> (#\a .. #\c)
(#\a #\b #\c)
> (#\a #\c .. #\z)
(#\a #\c #\e #\g #\i #\k #\m #\o #\q #\s #\u #\w #\y)

関数構文と

> (map [+ _ 1] (1 3 .. 10))
(2 4 6 8 10)

実装

(define (stop? start stop)
  (let ((cmp (if (> stop start) > <)))
    (lambda (x) (cmp x stop))))

(define (succ start next stop)
  (cond (next
	 (let ((step (- next start)))
	   (lambda (x) (+ x step))))
	((> stop start) add1)
	(else sub1)))

(define (unfold-args value number start next stop)
  (receive (start next stop)
      (values (number start) (and next (number next)) (number stop))
    (values (stop? start stop) value (succ start next stop) start)))

(define (accum start next stop)
  (call-with-values
      (lambda ()
	(cond ((number? start)
	       (unfold-args values values start next stop))
	      ((char? start)
	       (unfold-args integer->char char->integer start next stop))))
    unfold))

(define-syntax (app-range stx)
  (define (stx-every p? l)
    (andmap p? (map syntax-e l)))

  (define (literal? . l)
    (or (stx-every number? l)
        (stx-every char? l)))

  (syntax-case* stx (..)
      (lambda (x y) (eq? (syntax-e x) (syntax-e y)))
    ((app-range i .. j)
     (literal? #'i #'j)
     (quasisyntax/loc stx
       '#,(accum (syntax-e #'i) #f (syntax-e #'j))))
    ((app-range i .. j)
     (syntax/loc stx (accum i #f j)))
    ((app-range i j .. k)
     (literal? #'i #'j #'k)
     (quasisyntax/loc stx
       '#,(accum (syntax-e #'i) (syntax-e #'j) (syntax-e #'k))))
    ((app-range i j .. k)
     (syntax/loc stx (accum i j k)))
    ((app-range . e)
     (syntax/loc stx (app-fun . e)))))

リテラルが与えられた場合、コンパイル時にリスト生成が行われるのがポイントです:

> (syntax->datum (expand '(1 3 .. 10)))
(quote (1 3 5 7 9))

iota とかを使うよりも効率が良いわけです。

変数を含んでいる場合はこのようになります:

> (syntax->datum
   (expand
    '(let ((next 3)) (1 next .. 10))))
(let-values (((next) (quote 3))) (#%app accum (quote 1) next (quote 10)))

なお、リスト生成には iota ではなく、同じく SRFI-1 の unfold という関数を使っています。あまりポピュラーな関数ではないと思うんですが、なかなか奥が深そうです。

ファイル:
mlfun.ss
hasfun.ss
hasfun-helper.ss

参考文献:
Fun with paran-shape

Unix シェル的なバックグラウンドでのタスク処理

Sun, 01 Mar 2009 00:00:01 +0900

bash> command &

みたいに、バックグラウンドで関数を呼び出して、値が必要になった時に表に戻す、というイディオムを思い付きました。

(define (& t)
  (let ((c (make-channel)))
    (thread
     (lambda ()
       (channel-put c (t))))
    (lambda (k)
      (k (channel-get c)))))

使い方

(let ((%
       (& (lambda () some hard work))))
  ...
  (% values))

ごちゃごちゃしがちなスレッドの同期処理がスッキリ書けて良いと思います。

追記:

lambda が面倒なので、マクロにしてみました:

(define-syntax &
  (syntax-rules ()
    ((& e)
     (let ((c (make-channel)))
       (thread (lambda () (channel-put c e)))
       (lambda (k) (k (channel-get c)))))
    ((& e1 e2 ...)
     ;; Concurrent version of `begin'
     (let ((l (list (& e1) (& e2) ...)))
       (lambda (k)
         (let loop ((l l))
           ((car l)
            (lambda (v)
              (if (null? (cdr l))
                  (k v)
                  (loop (cdr l)))))))))))

式が複数有る場合、それぞれをスレッド下で処理するようにしています。begin と同様に、最後の式の値だけ得られるようになってます。

ニコ動のコメントをREPLで

Sun, 01 Mar 2009 00:00:00 +0900

最近ニコ動に上がっている作業用BGMとか、音声だけで楽しめるものをWinampで聴く、ということをしているんですが

(Scheme でローカルサーバー -> localhost:2525/?id=VIDEO_ID 的なURLをWinampで再生 -> にこさうんど or にこみみのキャッシュを探す -> mp3をWinampに転送、という流れで。タイトルにダブルクォートが付いているのがウェブ上のリソースという印です。Content-Disposition の filename フィールドを表示しています)

コメントが見れないのがちょっと寂しくなってきたので、REPLに表示してみました:

(上のとは別の動画です)

コメントXMLのタイミング情報の単位がちょっと変わっていて (10ミリ秒) 戸惑いました。あと、XMLの取得に若干時間がかかってしまい、再生から少し送れて表示されてしまうという欠点があるんですが、プレイヤー側で時間調整すれば一応時間通りに表示することができます。

追記:

コメントの出力形式を変えてみました。歌詞職人のコメだけ抽出、みたいなことも出来たり…

あと、コメント表示が再生開始のタイミングと同期できない問題は、カリー化関数の部分評価の機能により思いがけず解決しました。

(fun (nico-comment-disp ignore? chats)
  (let ((start (current-milliseconds)))
    (let loop ((chats chats))
      (if (pair? chats)
          (receive (vpos chat)
              (values (* (caar chats) 10) (cdar chats))
            (cond ((ignore? chat)
                   (loop (cdr chats)))
                  ((<= vpos (- (current-milliseconds) start))
                   (cout #\; (ms->time vpos)
                         #\space (sxml:string chat)
                         " \"" (user-id chat) #\" nl)
                   (loop (cdr chats)))
                  (else (sleep 0.333) (loop chats))))
          (cout "; end of comments" nl)))))

この関数を、先に第1引数に適用してからXMLを取りに行くようにしたところ、startの値がその時点 (再生開始時) でのミリ秒に固定されるので、フルに適用されるまでの時間幅が吸収されるようになったんです。

まぁ、startの値を関数のパラメータにしておけば良かった話なんですが…

Scheme から Emacs のコマンドを実行

Wed, 18 Feb 2009 00:00:00 +0900

私はよく Scheme のプログラムを Emacs 上で実行するんですが、elscreen で裏に回していたりして *scheme* バッファが見えない時に、何かユーザーの注意や介入が必要な事態が起こっていることがあります (入力を促す、等)。

そんな時、外部プログラムを起動するとか、ffi で CD トレイを開くとか、その旨を知らせる方法はいくらでも有るわけですが、せっかく Emacs がそこにあるんだから (beep) の一つも eval 出来ないでどうする、ということで考えてみました。

Scheme と Emacs の間には接続が張られているわけですから、そこにコマンドを流し込み、フック関数でモニターすれば良い、ということで、出来たのがこちら:

(add-hook 'inferior-scheme-mode-hook
          (lambda ()
            (add-hook 'comint-preoutput-filter-functions
                      (lambda (s)
                        (if (string-match "^(tell-emacs \\(.*\\))" s)
                            (save-excursion
                              (prin1
                               (eval
                                (car
                                 (read-from-string (match-string 1 s)))))
                              "> ")
                          s))
                      nil t)))

目的のフックがすぐ見つかったので案外易しかったです。"(tell-emacs " で始まる行を見つけたらS式を文字列として取り出し、read-from-string で S式化してから eval します。

さらに、Scheme 以外でも使えるようにマクロ化してみました (elisp にはクロージャが無いので):

(eval-when (load)
  (defmacro connect-to-emacs (prompt)
    `(add-hook 'comint-preoutput-filter-functions
               (lambda (s)
                 (if (string-match "^(tell-emacs \\(.*\\))" s)
                     (save-excursion
                       (prin1
                        (eval
                         (car
                          (read-from-string (match-string 1 s)))))
                       ,prompt)
                   s))
               nil t)))

プロンプトを言語ごとに設定できるようになっています:

(add-hook 'inferior-scheme-mode-hook
          (lambda () (connect-to-emacs "> ")))
(add-hook 'shell-mode-hook (lambda () (connect-to-emacs "")))

上記を .emacs に追加しておくと、Scheme プログラム中で

(display '(tell-emacs (beep)))

のように出力するか、あるいはプロンプトで

> '(tell-emacs (beep))

と評価することで、任意の Lisp 式を Emacs に送信できるようになります。

当然ながら

'(tell-emacs
  (comint-send-string (scheme-proc)
                      "'(tell-emacs (beep))"))

てなことも出来ます。

なお、Lisp 系以外の場合は式を文字列としてプリントする方法を取ってください。シェルモードの例:

echo "(tell-emacs (comint-send-string (scheme-proc) \"'(tell-emacs (beep))\"))" | cat

もっと騒がしい通知の例 (Scheme + Cygwin):

'(tell-emacs
  (comint-send-string (save-window-excursion (shell))
                      "cat /dev/urandom > /dev/audio\n"))

一見回りくどいですが、Windows 上の MzScheme からシェルを呼び出すよりちょっと楽だったりします。

ぜひお試しあれ。

Implicit Function Currying with Automatic Partial Evaluation

Tue, 27 Jan 2009 00:00:00 +0900

関数の部分適用と部分評価を自動的に行うマクロの実装を、日本語と Scheme で示していきます。

動機

前回 fun と fn という、Standard ML ライクなカリー化関数の構文をご紹介しました。とても便利で既に多用しているんですが、一つどうしても気になるのは、コードが無駄にコピーされてしまう点です。

例えば

(fn (x y z)
  (* (+ x y) z))

という関数は次のように展開されてしまいます:

(case-lambda
 ((x)
  (case-lambda
   ((y)
    (lambda (z)
      (* (+ x y) z)))
   ((y z)
    (* (+ x y) z))))
 ((x y)
  (lambda (z)
    (* (+ x y) z)))
 ((x y z)
  (* (+ x y) z)))

元の定義の本体部分があちこちに散らばっていますよね。これだとせっかく部分適用ができても、完全に適用されるまで本体の評価が持ち越されることになります。

この関数の場合、x と y が与えられた時点で (+ x y) は計算可能ですから、その部分は評価しちゃって欲しいところです。このままだと部分適用した関数を map 等で何度も利用する場合にあまり嬉しくありません。

具体的には、こういう式展開をしてくれれば良いなと思うわけです:

(case-lambda
 ((x)
  (case-lambda
   ((y)
    (let ((g1 (+ x y)))
      (lambda (z)
        (* g1 z))))
   ((y z)
    (* (+ x y) z))))
 ((x y)
  (let ((g2 (+ x y)))
    (lambda (z)
      (* g2 z))))
 ((x y z)
  (* (+ x y) z)))

方針

まず何をどうするかが問題ですが、基本的には上の展開例のように、与えられた引数のみに依存する式を関数本体から探し出し、評価し、その値で置き換えてやれば良いと思われます。

ただ、実際には評価を行うのは実行時なので、評価を行うための let 構文を埋め込むというコード変形を行うことになります。

例えば g1 の部分に注目していただくと、そこのスコープでは x と y が参照可能ですから、本体から x と y の計算式を抜き取り、ラムダの外に追い出して評価しています。これで一度だけの評価で済みますね。

この一度だけというのがポイントで、もし if 文の中にあってプログラム実行中に一度も評価されない可能性がある式は、部分評価の対象外とすべきでしょう。

実装

ところで、Lisp のプログラムと言えばリスト (ツリー) ですよね。ツリーの探索や置換と言えば、zipper を思い出します。ということで、zipper で使ったツリー探索の仕組みをコード変形に適用することにします。

こういうのです:

;; Adapted from: http://okmij.org/ftp/Scheme/zipper-in-scheme.txt
(define (map* f l)
  (if (not (pair? l))
      l
      (cons (f (car l)) (map* f (cdr l)))))

(define (depth-first handle tree)
  (cond ((not (pair? tree)) tree)       ; an atom
        ((handle tree) => values)
        (else                    ; the node was not handled -- descend
         (map* (lambda (kid)
                 (depth-first handle kid))
               tree))))

depth-first を使って式を探索し、置換可能な部分が見つかればその都度変数で置き換えていく、というのが基本戦略となります。

ただ、関数本体はマクロのパターンマッチで取得するので、初めはシンタックス・オブジェクトというデータ型になっています。それをツリー構造に展開する関数が必要です:

(define (syntax->tree x stop?)
  (cond ((stop? x) x)
        ((syntax? x)
         (syntax->tree (syntax-e x) stop?))
        ((pair? x)
         (cons (syntax->tree (car x) stop?)
               (syntax->tree (cdr x) stop?)))
        (else x)))

使用例:

> (syntax->tree #'(* (+ x y) 1) identifier?)
(#<syntax::229>
 (#<syntax::232> #<syntax::234> #<syntax::236>)
 1)

depth-first とは別に、ツリー内部を検索する関数も必要になります:

(define (stx-search p? stx)
  (cond ((p? stx) #t)
        ((stx-pair? stx)
         (or (stx-search p? (stx-car stx))
             (stx-search p? (stx-cdr stx))))
        (else #f)))

(stx-pair? とかは PLT Scheme のライブラリ関数です)

「まだ与えられていない引数」および「関数本体で導入されるレキシカル変数」は参照することが出来ないため、これらに依存する式は評価できません (コンパイル時に unbound variable エラーになります)。

なので、置換可能な式を探索する際に、式の中に参照不可能な変数が含まれていないかチェックしなければなりません。

そしてそのチェックのためには、予めレキシカル変数をコードから抽出しておく必要があります:

(define (match-vars stx)
  (kernel-syntax-case stx #f
    ((define-values (v ...) e ...)
     (syntax->list #'(v ...)))
    ((#%plain-lambda (v ...) e ...)
     (syntax->list #'(v ...)))
    ((case-lambda (v e ...) ...)
     (append-map syntax-e (syntax->list #'(v ...))))
    ((let-values ((v x) ...) e ...)
     (append-map syntax-e (syntax->list #'(v ...))))
    ((letrec-values ((v x) ...) e ...)
     (append-map syntax-e (syntax->list #'(v ...))))
    ((set! v e) (list #'v))
    (else '())))

(define (collect-vars stx)
  (cond ((pair? stx)
         (append (collect-vars (car stx))
                 (collect-vars (cdr stx))))
        ((syntax? stx)
         (append (match-vars stx)
                 (collect-vars (syntax-e stx))))
        (else '())))

関数本体のコードに collect-vars を適用すると、再帰的にレキシカル変数のリストが得られるようになっています。set! で変更される変数もついでに捕捉しておきます。

メイン部分に入っていきましょう。

(define-syntax (fn stx)
  (syntax-case stx ()
    ((fn params . exp)
     (kernel-syntax-case
         (call-with-values
             (lambda ()
               (syntax-local-expand-expression #'(lambda params . exp)))
           (lambda (stx _) stx))
         #f
       ((#%plain-lambda params . exp)
        (make-cases (cons #'begin
                          (map (lambda (e)
                                 ;; Keep protected exp intact
                                 (if (protected? e)
                                     e
                                     (syntax->tree e identifier?)))
                               (syntax->list #'exp)))
                    (syntax->list #'params)
                    (collect-vars #'exp)))))))

前のバージョンとの違いの一つは、パターンマッチで得た関数本体 (exp) を local-expand でフル展開しているところです。これは、receive とか and-let* のような派生構文を全て展開してコアの構文のみにするためです。おかげで match-vars の定義が楽になります。

ただ、これには少し厄介な問題も伴います。フルにマクロ展開をしてしまうと、モジュール内部のエクスポートされていない識別子が展開形の中に出てきてしまう場合があるのです。

この問題に対し、PLT Scheme では、そのような識別子を含む構文オブジェクトに封印のような仕掛けを施しており、少しでも手を加えると封印が破れたことが検知され、コンパイル・エラーが出るようになっています (参照: Fwd: module security)。

というわけで、封印の掛かっている構文オブジェクトは次の関数でチェックし、部分評価の対象から外さなければいけません。

(define (protected? stx)
  (stx-search (lambda (x)
                (and (syntax? x)
                     (syntax-property x 'protected)))
              stx))

カリー化定義の本体はこのようになりました:

(define (make-cases exp params locals)
  (cond ((null? params) exp)
        ((null? (cdr params))
         #`(lambda #,params #,exp))
        (else
         #`(case-lambda
             #,@(map (lambda (i)
                       (let-values (((bound-params rest-params)
                                     (split-at params (+ i 1))))
                         (if (null? rest-params)
                             #`(#,bound-params #,exp)
                             (let*-values
                                 (((residue ev-binds)
                                   (peval exp (append rest-params locals)))
                                  ((exp2)
                                   (make-cases residue rest-params locals)))
                               #`(#,bound-params
                                  #,(if (pair? ev-binds)
                                        #`(let #,ev-binds #,exp2)
                                        exp2))))))
                     (iota (length params)))))))

peval という関数を呼び出している点が前回と異なります。residue と ev-binds という2値を返す関数です。後者はその部分適用の時点で評価可能な式と、それに束縛される変数の組のリストです。前者は部分評価をした後の、小さくなった関数本体を表します。

peval を再帰的に呼び出す度に残りの計算が少なくなっていく、ということが期待できるわけです。

(define (peval exp unbound)
  (let ((binds '()))
    (values (depth-first
             (lambda (e)
               (cond ((ignore-form? e) e)          ;avoid descent
                     ((side-effect? e) #f)         ;just descend
                     ((free-from? e unbound)
                      (let ((g (gensym)))
                        (set! binds (cons #`(#,g #,e) binds))
                        g))
                     (else #f)))
             exp)
            (reverse binds))))

ここで depth-first の使い方を説明しておきましょう。

第1引数の関数で第2引数に含まれるノードを順次受け取っていきます。そして返値として #f を返せばノードに変更を加えず、それ以外の値を返すとノードがその値で置き換えられる仕組みです。

いずれの場合もそれ以降の探索は続行されるんですが、#f の場合はそのノードの下位ノードへと降りていくのに対し、#f 以外の場合は次のノードに進むという違いがあります。

peval においては、構文木の中から簡約可能な式を見つける上で、その下降とかスキップを適宜行っているわけです (if 文は無視して次に進む、等)。

そして簡約可能な式が見つかると、部分評価のためのバインディング #`(#,g #,x) を記録しつつ変数 g で置き換えていきます。

以下 depth-first 中の条件判断の関数です:

(define (operator exp)
  (and (pair? exp)
       (let ((x (car exp)))
         (and (identifier? x)
              (pair? (identifier-binding x))
              (syntax-e x)))))

(define (application? exp)
  (cond ((operator exp)
         => (lambda (op)
              (and (eq? op '#%app)
                   (let ((proc (cadr exp)))
                     (if (syntax? proc)
                         (syntax-e proc)
                         proc)))))
        (else #f)))

(define (free-from? exp unbound)
  (and (application? exp)
       (not
        (stx-search (lambda (id)
                      (and (identifier? id)
                           (ormap (lambda (ng)
                                    (or (bound-identifier=? ng id)
                                        (free-identifier=? ng id)))
                                  unbound)))
                    exp))))

(define (ignore-form? exp)
  (let ((forms-to-ignore
         '(if quote quote-syntax with-continuation-mark
           #%top #%variable-reference)))
    (cond ((operator exp)
           => (lambda (op) (memq op forms-to-ignore)))
          (else #f))))

(define (side-effect? exp)
  (let ((side-effecting-procs
         '(dynamic-require sleep thread kill-thread
           call/cc call-with-current-continuation
           call-with-continuation-prompt
           ;; and much more ...
           )))
    (stx-search (lambda (e)
                  (cond ((application? e)
                         => (lambda (op) (memq op side-effecting-procs)))
                        (else #f)))
                exp)))

実装は一応以上です。ソース: curry.ss

利用例

実例を手元で実際に動かしているものから抜粋します:

(fun (nicovideo user watch)
  (login (lookup 'mail user) (lookup 'pass user))
  (make-immutable-hasheq
   (let ((vid (video-id watch)))
     `((video_id . ,vid)
       ,@(let ((api-url (string->url (api vid))))
           (call/input-url api-url
             get-pure-port
             (lambda (in)
               ;; We need to extend cookie with view history prior to
               ;; further activities
               (view-page watch)
               (form-urlencoded->alist (port->string in)))
             (list (make-cookie-header api-url))))))))

これはニコ動ダウンローダの一部で、セッションIDを取得して動画の情報を得る関数です。実際の動画やコメントのダウンロードには別の関数を組み合わせて使います。

カリー化により第1引数 (ユーザー情報の連想リスト) が先に与えられると、その時点で最初のログインの式が評価されます。したがって、このように

(map (compose nico-download
              (nicovideo '((mail . "mail@address") (pass . "passwd"))))
     '("http://www.nicovideo.jp/watch/sm5003587"
       "http://www.nicovideo.jp/watch/sm2143250"
       "http://www.nicovideo.jp/watch/sm5008319"))

複数の動画を一気にダウンロードする時でも、ログインは1回で済むわけです。

部分評価が無ければ呼び出しの回数分だけログインしてしまうところですから、大きなメリットと言って良いでしょう。

問題点

最後に幾つか問題点を挙げておきます。

第1に、評価順の問題です。

begin のような構文であっても、式の並び順で評価が行われるとは限りません。簡約可能な式が後ろの方にあるとそれが先に評価されてしまう、という事が起こり得るわけです。

次に、副作用の問題があります。

ニコ動の例においては、ログインが1回で済むというのは一見望ましい振る舞いのように思えます。が、一般に副作用を起こす関数が1回の評価で良いのか、何度も評価されて欲しいのか、というのは実は非常に微妙な問題だと思います。

また、評価順の問題とも絡んで、副作用を伴う式が意図しない順序で評価されると、プログラムが正しく動作しなくなる事もあります。

第3に、継続や dynamic-wind 等の特殊な制御構造に干渉しないよう注意を払わなければなりません。

最後に、どこかで変更されるかもしれないグローバル変数やパラメータ、あるいはダイナミック変数をキャッシュしてしまう可能性も考慮する必要があるでしょう。

なお、これらは全てマクロの実装者側が留意すべき事柄であり、ユーザー側は何も考えなくても勝手に最適化が行われる、というのが理想です。

ML っぽいカリー化関数を定義するマクロ

Mon, 29 Dec 2008 00:00:00 +0900

ML とか Haskell のコードを読む時に私がどうしても憧れてしまうのが、自動的にカリー化定義される関数です。

Scheme にもカリー化関数を定義する構文自体は存在します (処理系にもよるでしょうが)。

例えば、このようなラムダ式のネストで定義された関数を

(define add3
  (lambda (a)
    (lambda (b)
      (lambda (c)
        (+ a b c)))))

次のようなスタイルで短く書くことができるんです:

(define (((add3 a) b) c)
  (+ a b c))

でも全然自動的ではないですし、必ず定義した通りに適用しなければいけません:

(((add3 1) 2) 3)

2番目と3番目の引数を同時に与える、とかは出来ないわけです。

そこでちょっと知恵をひねりまして、case-lambda を使って、あらゆる関数適用のパターンに応じたラムダ式をあらかじめ作っておく、という方法を考えてみました:

(define-syntax (fun stx)
  (define (make-cases vars body)
    #`(case-lambda
        #,@(for/list ((i (in-range (length vars))))
             (let-values (((hd tl) (split-at vars (+ i 1))))
               #`(#,hd
                  #,(if (null? tl)
                        body
                        (make-cases tl body)))))))
  (syntax-case stx ()
    ((fun (fn v ...) e ...)
     #`(define fn
         #,(make-cases (syntax->list #'(v ...))
                       #'(begin e ...))))))

これを使うと、

(fun (add3 a b c) (+ a b c))

という定義は以下のように展開されます:

(define add3
  (case-lambda
    ((a)
     (case-lambda
       ((b)
        (case-lambda
          ((c) (begin (+ a b c)))))
       ((b c) (begin (+ a b c)))))
    ((a b)
     (case-lambda
       ((c) (begin (+ a b c)))))
    ((a b c) (begin (+ a b c)))))

コードの重複が多少気になりますが、まぁとりあえず動かしてみましょう。

(((add3 1) 2) 3)
; => 6

((add3 1) 2 3)
; => 6

(add3 1 2 3)
; => 6

上手く行ってますね。

明示的な curry との併用なんかはどうでしょう？ MzScheme の scheme/function ライブラリで提供されているものを使います:

((curry add3 1) 2 3)
; => 6

((curry (add3 1) 2) 3)
; => 6

出来ました。

今度は compose プラス多値と組み合わせてみたり

((compose add3 (lambda (x) (values x 2 3)))
 1)
; => 6

((compose (add3 1) (lambda (x) (values x 3)))
 2)
; => 6

もいっちょ

((compose (curry add3 1) values)
 2 3)
; => 6

良い感じです。

[追記]

年を跨いで、より完全なバージョンを作ってみました。カリー化された無名関数を作るマクロ fn を加え、ライブラリとしての体裁も整えました:

#lang scheme/base

(require (for-syntax scheme/base
                     (only-in srfi/1 iota split-at)))

(provide fun fn)

(define-for-syntax (make-cases vars body)
  (cond ((null? vars) body)
        ((null? (cdr vars))
         #`(lambda #,vars #,body))
        (else
         #`(case-lambda
             #,@(map (lambda (i)
                       (let-values (((hd tl) (split-at vars (+ i 1))))
                         #`(#,hd
                            #,(make-cases tl body))))
                     (iota (length vars)))))))

(define-syntax (fn stx)
  (syntax-case stx ()
    ((fn (v ...) e ...)
     (make-cases (syntax->list #'(v ...))
                 #'(begin e ...)))))

(define-syntax fun
  (syntax-rules ()
    ((fun (f v ...) e ...)
     (define f (fn (v ...) e ...)))))

バージョン 4 以降の PLT Scheme では、マクロ展開のフェーズは実行時とは別環境になるので注意が必要です。例えばマクロ展開時にライブラリ関数を使いたい場合は (require (for-syntax ... )) として読み込む必要があります。マクロ用に関数を定義したい場合も、define-for-syntax で定義するか、begin-for-syntax で囲んで define するかしなければなりません。

そういう区別が特に無い処理系では define-for-syntax を普通に define に置き換えれば動くと思います。なお、case-lambda は大抵の処理系でプリミティブもしくは srfi-16 で提供されています。

上で言い忘れたんですが、あくまでも ML スタイル (ラムダ算法においてもそうですが、「全ての関数は1引数関数である」というもの) の模倣ですので、Lisp 的なオプショナル引数やキーワード引数、可変数引数はサポートしません。

マクロの定義上、零引数の関数も作れるようになっていますが、その場合は

(fn () 1)
; => 1

関数ではなく定数が返るようになっています。これは定数を零引数関数と見なす数学の考え方とも一致します。

[追記2]

fn を用いて、既存の関数をカリー化するマクロを作ってみました:

(define-syntax (make-curried stx)
  (syntax-case stx ()
    ((make-curried (f n) ...)
     #`(begin
         #,@(map (lambda (f n)
                   #`(define
                       #,(datum->syntax
                          f
                          (string->symbol (format "~a." (syntax-e f))))
                       #,(let ((args
                                (map (lambda (_) (gensym))
                                     (iota (syntax-e n)))))
                           #`(fn #,args (#,f #,@args)))))
                 (syntax->list #'(f ...))
                 (syntax->list #'(n ...)))))))

こういう風に、関数名と引数の数のペアを指定する方式です (複数可):

(make-curried (map 2)
              (+ 2))

(define map-add1 (map. (+. 1)))
(map-add1 '(1 2 3))
; => (2 3 4)

(元の関数と同名で定義したかったんですが、再バインドしようとするとエラーになってしまうのであきらめました)

元の関数の arity はどうあれ、指定した個数の引数しか受け取れない関数が作られます:

(+. 1 2)
; => 3

(+. 1 2 3)
; => procedure +.: no clause matching 3 arguments: 1 2 3

case-lambda がエラーを出していますね。

可変数引数やオプショナル引数等は捨てなければいけませんが、関数によってはかなり便利なんじゃないかと思います。

パーサーコンビネータの性能向上について

Fri, 12 Dec 2008 00:00:00 +0900

自前の XML パーサーやウェブ・スクレイピングなどにパーサーコンビネータ・ライブラリを使っているんですが、どうも実行速度が遅いのが気になってきたので、原因を考えてみました。

で、気付いたんですが、例えばこのようなパーサーを定義した時に、

(doP (char #\a) (char #\A) (char #\B))

パーサーを実行する度に (char #\a) のような関数適用が新たに評価されてしまうことが一つの原因ではないかと思いました。

そこで、関数適用の形になっているパーサーは1回だけ評価してキャッシュしておくことで、実行効率の向上を図ることにしました。

(以下 Gauche の PEG ライブラリの実装を参考にさせていただきましたが、少し工夫を加えた部分もあります。)

大まかなイメージとしては、上記のパーサーの場合

(let ((tmp1 (char #\a))
      (tmp2 (char #\A))
      (tmp3 (char #\B)))
  (lambda (input)
    ...))

のような形に展開し、入力ストリームを受け取るラムダの外側にパーサーをキャッシュしておけば良いわけです (内側だと毎回評価してしまいます)。

ただし、上と同じ意味のパーサーでも、次のように変数束縛を伴う定義の場合には問題が生じます。

(doP (a <- (char #\a))
     (A <- (char (char-upcase a)))
     (char (integer->char (+ (char->integer A) 1))))

同じように展開してしまうと

(let ((tmp1 (char #\a))
      (tmp2 (char a))
      (tmp3 (char (integer->char (+ (char->integer A) 1)))))
  (lambda (input)
    ...))

どこにもバインドされていない変数 (a, A) を参照することになり、エラーになってしまうんです。

話を具体的にするために、別の例を出しましょう。引用符に囲まれた文字列を取り出すパーサーを考えてみます:

(doP (q <- (one-of (string->list "\"'")))
     (s <- (many-till (none-of (list q))
                      (char q)))
     (return (list->string s)))

この場合、1行目のパーサーは意味が変わらないのでキャッシュしたいんですが、2つ目のパーサーは q の値によって意味が変わるので毎回評価しなければいけませんよね。

このように、キャッシュ出来るパーサーと出来ないパーサーがあるわけです。

この問題に対処するため、パーサー式を分析して、doP 構文内で束縛された変数を含む場合はキャッシュしないようにする方法を考えてみました。

bound-identifier=? という関数を使います。

(define (memvar exp vars)
  (and (pair? vars)
       (let bound? ((exp exp))
         (if (identifier? exp)
             (ormap (lambda (var)
                      (bound-identifier=? exp var))
                    vars)
             (let ((exps (syntax-e exp)))
               (and (pair? exps)
                    (ormap bound? exps)))))))

syntax-case マクロの中で呼び出す用の関数です。exp はパーサー式、vars は束縛変数のリストで、それぞれ型はシンタックス・オブジェクト、シンタックス・オブジェクトのリストです。

例えば exp として (char a) のような、変数を含む式を受け取った場合、変数 a が vars に含まれていれば #t を返します。

doP 構文を展開する際に束縛変数をリストに集めていき、パーサー式を見つける度に memvar 関数でそのリストと照合することで、束縛変数を参照しているかどうかが分かる仕組みです。

パーサー式が既に変数であるか、または束縛変数を参照していればそのままにしておき、それ以外であれば一時変数としてキャッシュする、という方針で doP 構文をこのように定義してみました:

(define-syntax (doP stx)
  (define (finish-body pre-binds var&parsers)
    (with-syntax
        ((parse-it
          (let loop ((input #'input) (var&parsers var&parsers))
            (if (null? (cdr var&parsers))
                (syntax-case (car var&parsers) (return)
                  ((return x) #`(values #f x #,input))
                  (p #`(p #,input)))
                (with-syntax ((input2 (gensym)))
                  (syntax-case (car var&parsers) (<-)
                    ((v <- p)
                     #`(receive (err v input2) (p #,input)
                         (if err
                             (values err v input2)
                             #,(loop #'input2 (cdr var&parsers)))))
                    (p
                     #`(receive (err v input2) (p #,input)
                         (if err
                             (values err v input2)
                             #,(loop #'input2 (cdr var&parsers)))))))))))
      #`(let #,pre-binds
          (lambda (input) parse-it))))
  (syntax-case stx ()
    ((doP p ...)
     (let loop ((pre-binds '())
                (var&parsers '())
                (bound-vars '())
                (clauses (syntax->list #'(p ...))))
       (if (null? clauses)
           (finish-body pre-binds (reverse var&parsers))
           (syntax-case (car clauses) (<- return)
             ((return x)
              (loop pre-binds
                    (cons #'(return x) var&parsers)
                    bound-vars
                    (cdr clauses)))
             ((v <- p)
              (if (or (identifier? #'p) (memvar #'p bound-vars))
                  (loop pre-binds
                        (cons #'(v <- p) var&parsers)
                        (cons #'v bound-vars)
                        (cdr clauses))
                  (with-syntax ((tmp (gensym)))
                    (loop (cons #'(tmp p) pre-binds)
                          (cons #'(v <- tmp) var&parsers)
                          (cons #'v bound-vars)
                          (cdr clauses)))))
             (p
              (if (or (identifier? #'p) (memvar #'p bound-vars))
                  (loop pre-binds
                        (cons #'p var&parsers)
                        bound-vars
                        (cdr clauses))
                  (with-syntax ((tmp (gensym)))
                    (loop (cons #'(tmp p) pre-binds)
                          (cons #'tmp var&parsers)
                          bound-vars
                          (cdr clauses)))))))))))

以前の実装では doP 構文はモナドの >>= 関数への糖衣構文だったので、パーサーとは独立の純粋に抽象的な定義だったんですが、この変更により doP マクロの中でパーサー連結の詳細を記述しなければいけなくなったのがちょっと残念です。

同じ事の定義が別々の場所にあるのは不自然なので、>>= の定義を逆に doP 構文に依存させるように変更しました:

(define (>>= p f)
  (doP (x <- p) (f x)))

パーサーコンビネータで作るインタープリタ

Sun, 30 Nov 2008 00:00:00 +0900

ふと、パーサーコンビネータでパーサーを作ると、それをそのままインタープリタとして走らせられるんじゃないか、ということを思い付きました。

普通はファイルやネットワークの入力ポートを

(parse p input-port)

のようにして渡すことで (p はパーサー関数)、パースが行われます。

ここに (current-input-port) を渡してやれば、キー入力を受け取って解析してくれるインタープリタが即出来上がるんじゃないか、という思惑です。

が、実際やってみたところ、ちょっと上手くいきませんでした。

parse 関数の中でポートが遅延リスト (ストリーム) 化されるんですが、どうもそこで eof-object を受け取るまで入力を待ち続ける仕様であるために、パースが終了できないみたいです。

キーボードで eof-object を入力する方法があれば、あるいは、パースに成功したらその時点で入力を待つのを止められれば良いと思うんですが、ちょっとやり方が分かりませんでした。

ということで、単純に read-line で入力を受け取る方式でやってみました:

(require "parser.ss")

(define (prompt)
  (printf "~%>>> ")
  (flush-output (current-output-port))
  (read-line))

(define (repl p)
  (let loop ((input (prompt)))
    (printf "~s~%" (parse p input))
    (loop (prompt))))

これに、中置記法の四則演算をするパーサー (arith.ss) を与えてみると:

> (repl (dynamic-require "arith.ss" 'arith))
>>> 1 + 2
3

>>> 1 + 2 * 3
7

>>> (1 + 2) * 3
9

\(^o^)/

実にあっけないですが、パーサー自体が元々評価器としての機能を持っていたためにこういうことが可能なわけです。

ただし read-line を使っているため、1行で完結する式しか受け取れないのが欠点ですね。ちょっと工夫してみました:

(define (append-lines x y)
  (cond ((not x) y)
        ((not y) x)
        (else (string-append x (string #\newline) y))))

(define (read-input)
  (let loop ((input #f))
    (cond ((char-ready?)
           (loop (append-lines input (read-line))))
          ((and input (> (string-length input) 0))
           input)
          (else
           (sleep 0.5)
           (read-input)))))

read-line の所を read-input に置き換えると、Emacs だと CTRL-j で改行しながら入力できるようになります。

環境というものを持たないので本格的なプログラミング言語は動かせなさそうなのが問題かなと思いますが、解決可能かどうか考え中です。

なぜ JavaScripter が Schemer になったか

Sat, 15 Nov 2008 00:00:00 +0900

以前は JavaScript のことばかり書いていたのが信じられないくらい、Scheme のことばかり書いていることについての説明文です。

ホップ

当ダイアリーのタイトルからもお分かりかもしれませんが、私は元々 JavaScript について書きたくなって、ブログというものを始めました (ついでに言うと、はてなのアカウントを取った時点ではそんなつもりは1ミリも有りませんでした)。

ちょうど世界的に JavaScript の真価が理解されるようになった時期でもあり、個人的には Ruby のクラス・システムを JavaScript で模倣するというテーマに興味を持って色々と実験をしたものです。

それから、LDR との出会いという大きな経験もありました。プログラムの世界に深く沈潜するようなリーディング体験をしたのは、この時が初めてだったかもしれません。それまで考えもしなかったような発想や技術に溢れていました。

さらに、Mochikit というライブラリにも出会いました。後から考えると、これがその後の方向転換への助走となったように思います。

ステップ

Python プログラマによって書かれた Mochikit は、Python 風の関数プログラミングのイディオムを具備しています。ここにおいて初めて、関数プログラミングの概念にまともに衝突することになったのです。

思考のメタモルフォーゼとでも言いましょうか。それまでオブジェクト指向しか知らなかった人間にとって、使ったことの無い頭の使い方を強いられるという意味で、苦しい経験だったと言えます。

その経験を経て、私の興味の対象は関数型言語へと大きくシフトしました。そしてどれか一つ、関数型言語を選んで勉強しよう、と思ったんです。

調べた結果、Lisp 系の言語を選ぶことにしました。最初は Common Lisp が良いと思ったんですがちょっと難しそうなので後回しにして、より文法が簡単そうな Scheme を選択しました。

なぜ Lisp を選んだかと言いますと、ずっと私の中に Lisp に対する複雑な感情があったからなんです。

多くの Lisp 嫌いがそうであるように、「こんな括弧だらけの言語どうやって読み書きするんだ」とか、「読み書きできる連中の気が知れない」みたいな否定的な感情を持つ裏で、Lisp を理解できる気がしない自分は彼らより知的に劣っているんじゃないか、という劣等意識も持っていました。

そのことを認めたくないが為に Lisp を悪く言う、という典型的な Lisp 嫌いであったわけです。

関数型言語を勉強しようと思った時に、Lisp も関数型言語の一種であることを知り、じゃぁこれを機会に Lisp 嫌いを克服してみよう、と一直線に繋がった感じでした。

Scheme の勉強には主に次の2つのテキストを用いました:
Teach Yourself Scheme in Fixnum Days
Structure and Interpretation of Computer Programs

驚いたことに、難しい、分からないと思っていた部分 (大量の括弧) は、1 足す 2 を

(+ 1 2)

と書くということ、つまり、括弧で囲まれた式の最初の要素がオペレータ（関数）で、残りは引数である、というごくごく簡単な文法を理解した時点で氷解したように思います。

何だそんなことだったのか、と拍子抜けするような思いでした。もちろんマクロとか継続とか、難解な概念もたくさん在るわけですが、括弧への苦手意識はほとんど一瞬で消え去り、適切なテキストで初歩から丁寧に学んだことで、少しずつ Lisp を理解し受け入れていくことができました。

ジャンプ

SICP の Scheme コードの美しさに魅了され、JavaScript で Scheme っぽいプログラミングを試みたりしながらも、まだ Scheme でプログラムを書くには至らない状態が続きました。あくまで Scheme は勉強用で、実用のプログラムを書く言語ではないという認識に留まっていたのです。

と言うか Scheme は終えて Common Lisp の勉強に入っていました。

そんな折、とあるウェブサイトに遭遇したことが事態を一変させます。

これです。

スクロールして右下を見ると…

Gauche!?!?

これを見た時、心の中で叫びました。「いた！」と。「Scheme でプログラムを書いてる人がいた！」

その衝撃から、「よし、自分も」と発奮させられ、Scheme でプログラムを書くことを決意した、というわけです。2007年5月のことでした。

このサイトに出会っていなかったら Schemer になるのはずっと遅れていたか、あるいは、なっていなかったかもしれません。

何がきっかけになるか分からないもんですね、というお話でした。

恒等関数としての values

Fri, 07 Nov 2008 00:00:00 +0900

再び多値関連の小ネタです。

PLT Scheme のあるライブラリを見ていて、こんな values の使い方を発見しました。

(filter values (list ...))

一瞬 values が再定義されているのかな？と思って辺りを探したんですが何も無く、試しにやってみると

> (filter values '(1 2 #f 3 4 #f 5))
(1 2 3 4 5)

おお。

> (map values '(1 2 #f 3 4 #f 5))
(1 2 #f 3 4 #f 5)

なるほど。

前回驚いた時と同様、「多値」イコール「2つ以上の値」という固定観念から抜け出せていなかったようです。このように1つの値に適用された場合は、ただの恒等関数 (\x = x) として機能するわけですね。

じゃぁ0値の場合はどうなるんでしょうか？

> (values)
>

REPL での見かけ上は void 値を評価した時と同じです:

> (void)
>

ということは？

> (void? (values))
context expected 1 value, received 0 values

 === context ===
d:\MzScheme\collects\scheme\private\misc.ss:68:7

おぉ、void ですら無い、と。

じゃぁこんな風に0引数関数を呼ぶこともできる、ということですね

> (call-with-values
      (lambda () (values))
    (lambda () 'nullary))
nullary

理解しました。

応用すると、適当に値を集めてきてその数によって分岐処理をする、みたいな事も可能になるわけです:

(call-with-values
    (lambda ()
      (apply values variable-length-list))
  (case-lambda
    (() 'nullary)
    ((x) 'unary)
    ((x y) 'binary)))