ファイルの変更監視を Series で

特定のディレクトリの下のファイル変更を監視したくて書いてみた。

;; /tmp の下をファイルの変更を 3 回だけ検知する。
(collect-ignore
 (subseries (format t "~&~a !!!!!!!!!!!!" (scan-file-change "/tmp/*.*"))
            0 3))

こんなふうに色々と scan-xxx にするとおもしろいかもしれない。

(defun collect-file-write-date-map (path)
  (let ((file (scan-directory path)))
    (collect-map file (file-write-date file))))

(series::defS scan-file-change (path &key (interval 1))
  "(scan-file-change path [:interval 1])"
  (series::fragl
   ;; args
   ((path) (interval))
   ;; rets
   ((file t))
   ;; aux
   ((map fset:map)
    (file t)
    (new-wirte-date t)
    (old-write-date t)
    (files t))
   ;; alt
   ()
   ;; prolog
   ((setq map (collect-file-write-date-map path))
    (sleep interval)
    (setq files (generator (scan-directory path))))
   ;; body
   (L
    (setq file (next-in files
                        (sleep interval)
                        (setq files (generator (scan-directory path)))
                        (next-in files)))
    (setq old-write-date (fset:@ map file))
    (setq new-wirte-date (file-write-date file))
    (if (and old-write-date (= old-write-date new-wirte-date))
        (go L)
        (setq map (fset:with map file new-wirte-date))))
   ;; epilog
   ()
   ;; wraprs
   ()
   ;; impure
   nil))

https://github.com/quek/info.read-eval-print.series-ext

fset:map も Series 化してみた

Series は sequence と hash-table は別関数なので FSet の場合でも map だけは別あつかいかな。

(series::defS scan-map (map)
  "(scan map)

Scans the entries of the fset:map and returns two series containing
the keys and their associated values.  The first element of key series
is the key of the first entry in the fset:map, and the first element
of the values series is the value of the first entry, and so on.  The
order of scanning the fset:map is not specified."
  (series::fragl ((map))               ; args
                 ((keys t) (values t)) ; rets
                 ((keys t) (values t)  ; aux
                  (mapptr t map))
                 ()                                          ; alt
                 ()                                          ; prolog
                 ((if (fset:empty? mapptr) (go series::end)) ; body
                  (multiple-value-bind (key val) (fset:arb mapptr)
                    (setq keys key)
                    (setq values val))
                  (setq mapptr (fset:less mapptr keys)))
                 ()                     ; epilog
                 ()                     ; wraprs
                 nil))

(series::defS collect-map (keys values &optional default-value)
  "(collect-map keys values)

Combines a series of keys and a series of values together into a map of fset.
default-value is defalt of fset:empty-map."
  (series::fragl ((keys t) (values t) (default-value t))
                 ((map))
                 ((map 'fset:map (fset:empty-map default-value)))
                 ()
                 ()
                 ((setq map (fset:with map keys values)))
                 ()
                 ()
                 nil)
  :trigger t)

;; キーと値をひっくり返した map を返す。
(multiple-value-bind (k v)
    (scan-map (fset:map ('a 1) ('b 2) ('c 3)))
  (collect-map v k 'not-found))
;;=> #{| (1 A) (2 B) (3 C) |}/NOT-FOUND

FSet を Series 化してみて思ったこと

FSet は Cliki の Current recommended libraries になっているコレクションライブラリ。そうなんだ。

確かになんかよさそう。

でも mapcar にあたる image は引数にコレクションを一つしかとれないの? という疑問に対して、たいして調べることなく scan-fset と collect-fset を定義して Series 化してみた。

FSet と Series と相性いいんじゃないかな。

(series::defS scan-fset (fset)
  "scan fset"
  (series::fragl ((fset))               ; args
                 ((items t))            ; rets
                 ((items t)             ; aux
                  (fsetptr t fset)
                  (seqp boolean))
                 ()                                           ; alt
                 ((setq seqp (fset:seq? fset)))               ; prolog
                 ((if (fset:empty? fsetptr) (go series::end)) ; body
                  (if seqp
                      (progn
                        (setq items (fset:first fsetptr))
                        (setq fsetptr (fset:less-first fsetptr)))
                      (progn
                        (setq items (fset:arb fsetptr))
                        (setq fsetptr (fset:less fsetptr items)))))
                 ()                     ; epilog
                 ()                     ; wraprs
                 nil))                  ; impure

(series::defS collect-fset (seq-type &optional (items nil items-p))
  "(collect-fset [type] series)"
  (let ()
    (unless items-p
      (setq items seq-type)
      (setq seq-type 'fset:bag))
    (cond ((eq seq-type 'fset:bag)
           (series::fragl ((items t)) ((bag))
                          ((bag 'fset:bag (fset:bag)))
                          ()
                          ()
                          ((setq bag (fset:with bag items)))
                          ()
                          ()
                          nil))
          ((eq seq-type 'fset:seq)
           (series::fragl ((items t)) ((seq))
                          ((seq 'fset:seq (fset:seq)))
                          ()
                          ()
                          ((setq seq (fset:with seq (fset:size seq) items)))
                          ()
                          ()
                          nil))
          ((eq seq-type 'fset:set)
           (series::fragl ((items t)) ((set))
                          ((set 'fset:set (fset:set)))
                          ()
                          ()
                          ((setq set (fset:with set items)))
                          ()
                          ()
                          nil))))
  :trigger t)

(collect-fset (* (scan-fset (fset:set 1 2 3))
                 (scan-fset (fset:seq 1 2 3))
                 (scan-fset (fset:bag 1 2 3))
                 (scan-fset (fset:map (1 'a) (2 'b) (3 'c)))))
;;=> #{% 1 16 81 %}

(collect-fset (scan-fset (fset:seq 1 2 2 3)))
;;=> #{% 1 (2 2) 3 %}
(collect-fset 'fset:bag (scan-fset (fset:seq 1 2 2 3)))
;;=> #{% 1 (2 2) 3 %}
(collect-fset 'fset:seq (scan-fset (fset:seq 1 2 2 3)))
;;=> #[ 1 2 2 3 ]
(collect-fset 'fset:set (scan-fset (fset:seq 1 2 2 3)))
;;=> #{ 1 2 3 }

Common Lisp で全文検索 Web システム

仕事で使えないかなと思って、 Common Lisp で全文検索 Web システムを作ってみたが、あまり速くなかった。

Montezuma に MeCab のトークナイザを付けて、 IOLib 使ったイベント方式の Web サーバでインターフェースを提供する実装。

Montezuma をファイルベースのインデックにすると厳しい。インメモリのインデックスならチューニングすればいけるかも。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload :montezuma)
  (ql:quickload :clsql)
  (ql:quickload :info.read-eval-print.series-ext)
  (ql:quickload :info.read-eval-print.mecab)
  (ql:quickload :info.read-eval-print.web-server))

(info.read-eval-print.series-ext:sdefpackage
 :fts (:use :cl :info.read-eval-print.mecab
            :info.read-eval-print.web-server))

(in-package :fts)


;;; tokenizer
(defclass mecab-tokenizer (montezuma::tokenizer)
  ((tokens :initform :unbound)
   (position :initform 0)))

(defmethod montezuma::next-token :before ((self mecab-tokenizer))
  (with-slots (montezuma::input tokens) self
    (when (eq tokens :unbound)
      (setf tokens
            (typecase montezuma::input
              (stream
               (mecab (collect 'string (scan-stream montezuma::input #'read-char))))
              (t
               (mecab montezuma::input)))))))

(defmethod montezuma::next-token ((self mecab-tokenizer))
  (with-slots (tokens position) self
    (let ((token (pop tokens)))
      (if token
          (let* ((表層形 (node-表層形 token))
                 (new-position (+ position (length 表層形)))
                 (token (or (node-原形 token) 表層形)))
            (prog1 (montezuma::make-token
                    (montezuma::normalize self token)
                    position new-position)
              (setf position new-position)))
          nil))))

(defmethod montezuma::normalize ((self mecab-tokenizer) str)
  str)

(defun search-full-text (query)
  (collect
      (montezuma:document-value
       (montezuma:get-document
        *index*
        (montezuma:doc
         (scan (montezuma::score-docs
                (montezuma:search *index* (format nil "text:~a" query)
                                  :num-docs 5000)))))
       "id")))
;;(search-full-text "京都")

(defun /search ()
  (let ((q (params :q)))
    (info.read-eval-print.web-server::make-response
     (if q
         (search-full-text q)
         ""))))

(defun search-by-id (id)
  (montezuma:search-each *index* (format nil "id:~a" id)
                         (lambda (doc score)
                           (declare (ignore score))
                           (print doc)
                           (return-from search-by-id doc)))
  nil)

(defun add-index (id text)
  (let ((doc-num (search-by-id id)))
    (if doc-num
        (montezuma:update *index* doc-num `(("text" . ,text)))
        (montezuma:add-document-to-index
         *index*
         `(("id" . ,id)
           ("text" . ,text))))
    (info.read-eval-print.web-server::make-response "ok")))

(defun /add ()
  (let ((id (params :id))
         (text (params :text)))
    (add-index id text)
    (info.read-eval-print.web-server::make-response "ok")))

(defun run ()
  (sb-thread:make-thread (lambda ()
                           (let ((*handler-package* :fts))
                             (start)))
                         :name "full text search"))


;;; analyzer
(defclass mecab-analyzer (montezuma::standard-analyzer)
  ())

(defmethod montezuma::token-stream ((self mecab-analyzer) field string-or-stream)
  (declare (ignore field))
  (reduce (lambda (acc x) (make-instance x :input acc))
          '(mecab-tokenizer
            montezuma::lowercase-filter
            montezuma::stop-filter)
          :initial-value string-or-stream))



;;; index 作成
(defparameter *index*
  (make-instance 'montezuma:index
                 :path "/tmp/montezuma" ; 指定しなければインメモリになる
                 :analyzer (make-instance 'mecab-analyzer)))


(defun make-initial-index ()
  (progn
    (clsql-sys:connect '("localhost" "outing_development" "root" "")
                       :database-type :mysql)
    (clsql-sys:execute-command "set names utf8"))
  (time
   (clsql:loop for (id name kana description address search-keyword prefecture-id)
           being the tuples of
         "select id name, kana, description, address, search_keyword, prefecture_id
from facilities"
         for text = (delete #\return (format nil "~@{~a~^ ~}" name kana description address search-keyword))
         do (print id)
         do (add-index id text))))


#|
http://localhost:8888/add?id=1&text=京都に行こう。
http://localhost:8888/add?id=2&text=東京都に行こう。
http://localhost:8888/add?id=3&text=京都府に行こう。
http://localhost:8888/search?q=京都

(time (labels ((f (q)
                 (cons q (search-full-text q))))
        (dotimes (i 100)
          (collect (f (scan '("京都" "東都" "京" "都" "子供")))))))

|#

Series でネストしたループはどう書けばいいんだろう

例えば次のようなのを Series ではどう書けばいいんだろう。

(loop for i in '(100 200 300)
      nconc (loop for j in '(10 20 30)
                  nconc (loop for k in '(1 2 3)
                              collect (+ i j k))))
;;=> (111 112 113 121 122 123 131 132 133 211 212 213 221 222 223 231 232 233 311
;;    312 313 321 322 323 331 332 333)

SERIES::*SERIES-IMPLICIT-MAP* を t にしているので、次のように書けるかと思ったがだめだった。

(collect-nconc
 (let ((x (scan '(100 200 300))))
   (collect-nconc
    (let ((y (scan '(10 20 30))))
      (collect (+ x y (scan '(1 2 3))))))))

素直に mapping で書けば動く。

(collect-nconc (mapping ((i (scan '(100 20 300))))
                 (collect-nconc (mapping ((j (scan '(10 20 30))))
                                  (collect (mapping ((k (scan '(1 2 3))))
                                             (+ i j k)))))))

しかし、どうしても implicit map で書きたい。

labels を使ってみた。動いた。可読性は。。。でも implicit map だ。

(labels ((f (x)
           (collect-nconc (ff x (scan '(10 20 30)))))
         (ff (x y)
           (collect (+ x y (scan '(1 2 3))))))
  (collect-nconc (f (scan '(100 200 300)))))

次のような感じでネストを指定できたらいいかもしれない。

(collect (+ (scan '(100 200 300))
            (#2Lscan '(10 20 30))
            (#3Lscan '(1 2 3))))

プログラミングコンテストチャレンジブック 第2版 1-6 Ants

「1-6 Ants」

今回のは Series っぽく書けた。 :IMPLICIT-MAP T してあるので明示的にループやマップを書かなくてもいい。

;;;; 1-6 Ants
(let ((l 10)
      (xs (scan '(2 6 7))))
  (values
   (collect-max (min xs (- l xs)))
   (collect-max (max xs (- l xs)))))

ThinkPad X220 を買った

ヤーンのいない暮らしの中、気をまぎらわすために ThinkPad X220 を買った。

Dell の 17 インチノート Inspiron 1720 を背負っての通勤に疲れたとう理由もあるが。今週二日自宅勤務なので ThinkPad X220 自宅用で、Inspiron 1720 は職場用にする。通勤が楽になった。

Inspiron 1720 と同様 ThinkPad X220 にも Debian sid をインストールした。正確には http://d-i.debian.org/daily-images/amd64/daily/netboot/netboot.tar.gz をインストールして sid に dist-upgrade した。 tftp から何の問題もなくネットワークインストールできた。

トラックポイントでのスクロールは gpointing-device-settings で ok なはずだが gnome3 になって(?)動かなくなったらしく、設定ファイルを書く必要があった。http://d.hatena.ne.jp/torazuka/20110611/scroll を参照。

起動時にワーニングが出るので sudo apt-get install firmware-intelwimax した。

やっぱり ThinkPad の X シリーズはいいな。 X20 以来なんだが、X20 のキーボードの方がよかったな。それだけが残念なところ。

OS は Debian sid が至高だと思う。 OS のアップグレードという無駄な作業なしに、常に最新の環境を使い続けられるから。

プログラミングコンテストチャレンジブック 第2版

ヤーンが死んでから1ヵ月以上経つが、ずっと無気力傾向にある。

そんななか近所の本屋さんブックスキタミに行ったら「プログラミングコンテストチャレンジブック 第2版」を見つけた。失礼ながらその本屋にまさかそんな本があるとは思っていなかった。買った。キタミ見直した。

どうも無気力なので、「プログラミングコンテストチャレンジブック」の例題を Series で解いてステップをとりもどしていきたいと思う。

パッケージは次のとおり。 info.read-eval-print.series-ext は https://github.com/quek/info.read-eval-print.series-ext

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :info.read-eval-print.series-ext))

(info.read-eval-print.series-ext:sdefpackage
 :programming-contest-charenge-book
 (:use :cl))

(in-package :programming-contest-charenge-book)

info.read-eval-print.series-ext:sdefpackage は (SERIES::INSTALL :PKG :PROGRAMMING-CONTEST-CHARENGE-BOOK :IMPLICIT-MAP T) をパッケージ宣言と同時に行いたがためのもの。 Series は是非とも :IMPLICIT-MAP T にすべき。

最初は「1-6 三角形」。

;;;; 1-6 三角形
(let ((a '(2 3 4 5 10)))
  (let ((ans 0))
    (iterate ((xs (scan-sublists a)))
      (iterate ((ys (scan-sublists (cdr xs))))
        (iterate ((z (scan (cdr ys))))
          (let* ((x (car xs))
                 (y (car ys))
                 (sum (+ x y z))
                 (max (max x y z)))
            (if (< max (- sum max))
                (setf ans (max ans sum)))))))
    ans))

全然 Series をいかせてない。もっとうまく書けないものか。