2010-12-09
radikoスケジューラー
聴きたい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
2010-11-05
2010-06-24
Scheme で定数定義
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 便利！
2010-06-04
Scheme から Racket へ
ユーザーなのに気づくのが遅れたんですが、PLT Scheme の名称が Racket に変更されるそうです。
http://racket-lang.org/new-name.html
http://news.ycombinator.com/item?id=1221374
メーリングリストで時々 Racket という単語を見かけてはいたんですが、特に気にしてなかったんですよねー。何気なくググってみて真相を知り、一瞬びっくりしたんですが、すぐに「良いじゃん」という気持ちになりました。
今後私は Schemer ではなく Racketeer と呼ばれることになります（笑）。
2010-05-24
MPEG-4、ツリー探索、autovivification
近ごろ動画や音声データの読み書きを 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) を追加するにはこの自動生成の機能が欠かせません。
2010-05-23
多値アクセス構文
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 はあくまでもマクロであることを強調しておきます。
2010-03-28
PLT SchemeのREPLで直前の値を参照できるようにする
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")