anything で 2ch のスレッドを開く

遅ればせながら、話題の anything.el を使い始めました。噂に違わぬ凄さです。感覚的には Mac OS X の右上のやつ (spotlight) みたいな感じで、Emacs が飛躍的に便利になります。

話は変わりますが、少し前にちょっと思い付いて 2ch の活動状況を監視するプログラムを書いたんです (Scheme で)。

新規スレッド、倉庫落ちスレッド、スレッド毎の単位時間あたりの書き込み数などが分かる、というものなんですが、Scheme の REPL が情報で埋め尽くされてしまう、という欠点があり (笑)、実用には問題がありました。

そこに anything との出会いがあったわけで、二つを組み合わせてみようと思い付くのは自然の成り行きでした。

基本的には元のプログラムを、標準出力ではなくファイルに出力するようにすれば良かったので簡単でした。その際、("スレッドタイトル" . "スレッドURL") というペアのリストとして出力することで、Emacs 側では (read) するだけでそのまま anything の情報源となります。

ちなみに以前、Scheme と emacs のリアルタイムな通信モデルを考えたんですが、これはファイルを介したオンデマンド通信、ということになるでしょうか。

スクリーンショット:

若干表示がおかしい (星印等が化けてる) ですが、気にしないで下さい。

anything ソース:

(defvar anything-c-2chinfo "~/.2chinfo")

(defvar anything-c-source-2ch
  '((name . "2ch threads")
    (candidates . (lambda ()
                    (with-current-buffer (find-file-noselect
                                          (expand-file-name
                                           anything-c-2chinfo))
                      (goto-char (point-min))
                      (let ((tmp (read (current-buffer))))
                        (kill-buffer (current-buffer))
                        tmp))))
    (action
     ("Browse url" . browse-url)
     ("Open with navi2ch" . (lambda (url)
                              (unless (and (boundp 'navi2ch-init)
                                            navi2ch-init)
                                 (navi2ch))
                              (navi2ch-goto-url url))))
    (delayed)))

デフォルトは外部ブラウザで開くようになってますが、もちろん順番を入れ替えても良いでしょう。

あとは以下を適当に走らせておくだけです。

Scheme ソース:

(require (lib "etc.ss")                 ;compose
         (lib "list.ss")                ;sort foldr
         (lib "url.ss" "net")
         (only (lib "selector.ss" "srfi" "1")
               take)
         (only (lib "filter.ss" "srfi" "1")
               partition!)
         (lib "2.ss" "srfi")            ;and-let*
         (lib "8.ss" "srfi"))           ;receive

(define debug #t)

;; EDIT THIS!
(define dotfile "c:/home/.2chinfo")

;;; General purpose utilities

(define (report . args)
  (apply printf args)
  (flush-output (current-output-port)))

(define (later minutes p)
  (thread (lambda ()
            (sleep (minutes->seconds minutes))
            (force p))))

(define (minutes->seconds interval)
  (let ((interval (* interval 60)))
    (if (< interval 60)
        60
        interval)))

(define (truncate-float float prec)
  (car (regexp-match
        (pregexp (format "^\\d+(?:\\.\\d{,~a})?" prec))
        (format "~a" float))))

(define (truncate-list lst num)
  (if (> (length lst) num)
      (take lst num)
      lst))

(define sjis->utf-8
  (let ((conv (bytes-open-converter "Shift-JIS" "UTF-8")))
    (lambda (bytes)
      (let-values (((x y z) (bytes-convert conv bytes)))
        x))))

;; Cited from: http://community.schemewiki.org/?port-utilities
(define (port-for-each fn reader)
  (let loop ()
    (let ((item (reader)))
      (cond ((not (eof-object? item))
             (fn item)
             (loop))))))

;;; 2ch utilities

(define (dat-info d t n)
  (lambda (m)
    (case m
      ((dat) (bytes->string/latin-1 d))
      ((key) (dat->key d))
      ((title) (bytes->string/utf-8 (sjis->utf-8 t)))
      ;; Number of articles
      ((num) (string->number (bytes->string/latin-1 n)))
      (else #f))))

(define (dat->key dat)
  (cond ((regexp-match #rx#"([0-9]+)\\.dat$" dat) =>
         (compose bytes->string/latin-1 cadr))))

(define (dat-url board dat)
  (string-append board "dat/" dat))

(define (thread-url board dat)
  (string-append
   (regexp-replace "([^/]+)/?$" board "test/read.cgi/\\1/")
   (regexp-replace ".dat$" dat "/l50")))

(define (iter-board url k)
  (call/input-url (string->url (string-append url "subject.txt"))
    get-pure-port
    (lambda (in)
      (let ((rx #rx#"^(.+?)<>(.+) \\(([0-9]+)\\)$")
            (rank 1))
        (port-for-each (lambda (l)
                         (let ((m (regexp-match rx l)))
                           (if m
                             (let ((info (apply dat-info (cdr m))))
                               (k (lambda (m)
                                    (case m
                                      ((rank) rank)
                                      ((dat-url)
                                       (dat-url url (info 'dat)))
                                      ((thread-url)
                                       (thread-url url (info 'dat)))
                                      (else (info m)))))
                               (set! rank (+ rank 1))))))
                       (lambda () (read-bytes-line in)))))))

(define (iter-dat url k)
  (call/input-url (string->url url)
    get-pure-port
    (lambda (in)
      (port-for-each k
                     (lambda () (read-bytes-line in))))))

(define (search-board board k)
  (call/input-url (string->url "http://menu.2ch.net/bbsmenu.html")
    get-pure-port
    (lambda (in)
      (let ((rx (byte-regexp
                 (string->bytes/latin-1
                  (format "(?i:<a href=(http://[^/]+/~a/)>(.+?)</a>)"
                          board)))))
        (port-for-each (lambda (l)
                         (cond ((regexp-match rx l) =>
                                (lambda (m)
                                  (let ((url (cadr m))
                                        (name (caddr m)))
                                    (report "Board found: ~a~%" url)
                                    (k (bytes->string/latin-1 url)
                                       (bytes->string/utf-8
                                        (sjis->utf-8 name))))
                                  #f))))
                       (cut read-bytes-line in))))))

;;; Application

(define (board-db url name)
  (let ((db (make-hash-table 'equal)))
    (hash-table-put! db 'name name)
    (hash-table-put! db 'time (current-seconds))
    (iter-board url
                (lambda (info)
                  (hash-table-put! db (info 'key) info)))
    db))

(define (board-name db)
  (hash-table-get db 'name))

(define (analyze-change current previous print)
  (let ((bname (board-name current)))
    (print bname "Dead" (dead-threads current previous))

    (receive (active silent)
        (threads-active/silent current previous)
      (print bname
             (lambda (info)
               (format "~appm"          ;posts per minute
                       (truncate-float
                        (activity/thread info current previous)
                        2)))
             (truncate-list active 10)))

    (print bname "New" (new-threads current previous))))

(define (thread-title bname header)
  (let ((header (if (procedure? header)
                    header
                    (lambda (_) header))))
    (lambda (info)
      (format "~a /~a/ ~a (~a)"
              bname (header info) (info 'title) (info 'num)))))

(define (print-threads bname header threads)
  (or (null? threads)
      (let ((title (thread-title bname header)))
        (for-each (lambda (info)
                    (report "~a~%~a~%"
                            (title info) (info 'thread-url)))
                  threads))))

(define dump-threads
  (let ((dumped '()))
    (lambda (bname header threads)
      (or (null? threads)
          (let ((title (thread-title bname header)))
            (set! dumped
                  (truncate-list
                   (append!
                    (map (lambda (info)
                           (cons (title info) (info 'thread-url)))
                         threads)
                    dumped)
                   50))
            (call-with-output-file dotfile
              (lambda (out)
                (write dumped out))
              'replace))))))

(define (just-threads db)
  (filter procedure?
          (hash-table-map db (lambda (k v) v))))

(define (filter-threads pred current previous)
  (filter (lambda (x)
            (pred (hash-table-get previous (x 'key) #f)))
          (just-threads current)))

(define (new-threads current previous)
  (filter-threads not current previous))

(define (dead-threads current previous)
  (new-threads previous current))

(define (inter-threads current previous)  ;intersection
  (filter-threads identity current previous))

(define (threads-active/silent current previous)
  (receive (active silent)
      (partition! (lambda (x)
                    (> (new-articles x previous) 0))
                  (inter-threads current previous))
    (values (sort! active
                   (lambda (x y)
                     (> (new-articles x previous)
                        (new-articles y previous))))
            (sort! silent
                   (lambda (x y)
                     (< (x 'rank) (y 'rank)))))))

(define (new-articles x previous)
  (- (x 'num)
     (or (and-let* ((y (hash-table-get previous (x 'key) #f)))
           (y 'num))
         0)))

(define (activity/thread x current previous)
  (/ (new-articles x previous)
     (/ (- (hash-table-get current 'time)
           (hash-table-get previous 'time))
        60.0)))

(define (activity/board current previous)
  (and debug (printf "[D] ~a: " (board-name current)))
  (/ (foldr +
            0
            (map (lambda (x)
                   (new-articles x previous))
                 (just-threads current)))
     (hash-table-count current)))

(define (adjust-interval rate interval)
  (and debug
       (report "~a posts/thread @ ~a min.~%"
               (truncate-float (* rate 1.0) 2)
               interval))
  (cond ((< rate 1/4)
         (+ interval 1))
        ((and (> rate 3/4)
              (> interval 1))
         (- interval 1))
        (else interval)))

(define watch-board
  (let ((watchlist '()))
    (lambda (board interval print)      ;XXX: board has to be symbol
      (or (memq board watchlist)
          (search-board
           board
           (lambda (url name)
             (letrec ((watch
                       (lambda (interval previous)
                         (later interval
                                (delay
                                  (let ((current (board-db url name)))
                                    (analyze-change current previous print)
                                    (watch (adjust-interval
                                            (activity/board current previous)
                                            interval)
                                           current)))))))
               (watch interval
                      (board-db url name)))
             ;; Remember what we are observing
             (set! watchlist (cons board watchlist))))))))

(define run
  (case-lambda
    ((boards interval)
     (run boards interval print-threads))
    ((boards interval print)
     (let lp ((boards boards))
       (unless (null? boards)
         (watch-board (car boards)
                      interval
                      print)
         (later 1
                (delay (lp (cdr boards)))))))))

(run '(newsplus unix scienceplus)   ; edit the list
     3
     dump-threads)