2008/10/30

[Common Lisp] McCLIM で日本語入力

Common Lisp の GUI といえば CLIM で、その open source implementation である McCLIM がある。ただ残念ながら McCLIM では現状日本語入力ができない。そこでなんとか日本語入力できないものかと、もがいてみた。 Factor のときみたに XOpenIM とかすればいいかと思ったが、McCLIM では Xlib は使われていない。 Xlib の Common Lisp 版といえる clx が使われている。それじゃどうすりゃいいのと、適当に悩んだあげく uim(libuim)を CFFI で呼ぶことにした。

で、まあなんとか日本語が入力できるようになった。

# 試してみたいという方は次のように darcs で取得してみてください。 (require :mcclim-uim) すれば ok です。それとは別に McCLIM で日本語表示するためには (require :mcclim-freetype) も必要です。

git clone git://github.com/quek/mcclim-uim.git
https://github.com/quek/mcclim-uim

2008/10/22

[Common Lisp] [*scratch*] Erlang のまねっこ

[*scratch*] と題して、適当なコードをはりつける試み(笑)

ハードと OS の進歩によって、そのうち普通のスレッドでも Erlang なみの並列処理ができるようになることを期待しつつ。

(in-package :quek)

(import 'sb-thread:*current-thread*)

(export '(spawn ! @ *exit* *current-thread*))

(defvar *processes* (make-hash-table :weakness :key))

(defvar *processes-mutex* (sb-thread:make-mutex))

(defvar *exit* (gensym "*exit*"))

(defclass process ()
((name :initarg :name :accessor name-of)
(mbox :initform nil :accessor mbox-of)
(waitqueue :initform (sb-thread:make-waitqueue) :accessor waitqueue-of)
(mutex :initform (sb-thread:make-mutex) :accessor mutex-of)
(childrent :initform nil :accessor children-of)))

(defgeneric kill-children (process)
(:method ((process process))
(loop for i in (children-of process)
do (! i *exit*))))

(defun get-process (&optional (thread sb-thread:*current-thread*))
(sb-thread:with-mutex (*processes-mutex*)
(sif (gethash thread *processes*)
it
(setf it (make-instance 'process
:name (sb-thread:thread-name thread))))))

(defun spawn% (function)
(let* ((thread (sb-thread:make-thread
function
:name (symbol-name (gensym "quek.pid"))))
(current-process (get-process sb-thread:*current-thread*)))
(push thread (children-of current-process))
thread))

(defmacro spawn (&body body)
`(spawn% (lambda ()
,@body)))

(defgeneric ! (reciever message))

(defmethod ! ((thread sb-thread:thread) message)
(! (get-process thread) message))

(defmethod ! ((process process) message)
(if (eq message *exit*)
(progn
(kill-children process)
(sb-thread:with-mutex (*processes-mutex*)
(maphash (_ (when (and (eq _v process)
(sb-thread:thread-alive-p _k))
(sb-thread:terminate-thread _k)))
*processes*)))
(sb-thread:with-mutex ((mutex-of process))
(setf (mbox-of process)
(append (mbox-of process) (list message)))
(sb-thread:condition-notify (waitqueue-of process)))))

(defun @ (&key timeout timeout-value)
(with-accessors ((waitqueue waitqueue-of)
(mutex mutex-of)
(mbox mbox-of)) (get-process)
(let (timeout-p)
(when timeout
(spawn (sleep timeout)
(sb-thread:with-mutex (mutex)
(setf timeout-p t)
(sb-thread:condition-notify waitqueue))))
(sb-thread:with-mutex (mutex)
(unless (or mbox timeout-p)
(sb-thread:condition-wait waitqueue mutex))
(if mbox
(pop mbox)
timeout-value)))))


#+test
(let ((thread (spawn (labels ((f (rev)
(case rev
('quit
(print "quit!"))
(t (print rev)
(force-output)
(f (@))))))
(f (@))))))
(! thread 'hello)
(sleep 1)
(! thread 'world)
(sleep 1)
(! thread 'quit))


#+test
(let ((th (spawn
(print "start...")
(print (@ :timeout 0.1 :timeout-value "タイムアウトした"))
(print "end...")
(force-output))))
(sleep 1)
(! th "おわり"))

;;(@ :timeout 0 :timeout-value "タイムアウトした")

2008/10/20

Shibuya.lisp テクニカルトーク #1

Shibuya.lisp テクニカルトーク #1 に参加してきた。個人的には JLUG Meeting 2000 以来だ。

JLUG は Franz 社がいてアカデミックな雰囲気だったが、Shibuya.lisp は完全にユーザの手作りのイベントだった。それにもかかわらず、いいかげんな感じなところはなく、くだけた話あり、とても深くテクニカルな話ありと、いいベントだった。みなさんありがとうございました。

本、イベント、オンラインと Lisp 的にいい流れになっているのを感じる。

[Commo Lisp] mapf

わだばLisperになる(g000001さん)のお題 【どう書く】MDL/Muddleのmapfを作る をやってみた。

ちなみに g000001 さんの回答と、onjo さんの回答が公開されてる。そっか、throw catch を使うのね。思いつかなかった。prog* がいかにも g000001 さんらしい。onjo さんのリストが省略された場合循環リストを使うのはエレガントだ。効率もちゃんと考えられているし。

throw catch は思いつかなかった結果、defvar したものをループの度に cond で判定してる。日頃からあまりにもエラーハンドリングを無視しすぎかな。

(defvar *mapleave* nil)
(defvar *mapret* nil)
(defvar *mapstop* nil)

(defun mapf (final-function loop-function &rest lists)
(let (collect)
(if lists
;; lists 指定あり
(loop for i in (apply #'mapcar #'list lists)
do (let (*mapleave* *mapret* *mapstop*)
(let ((ret (apply loop-function i)))
#1=(cond (*mapleave*
(return-from mapf (car *mapleave*)))
(*mapret*
(loop for i in (car *mapret*)
do (push i collect)))
(*mapstop*
(push (car *mapstop*) collect)
(return-from mapf (nreverse collect)))
(t
(push ret collect))))))
;; lists 指定なし
(loop (let (*mapleave* *mapret* *mapstop*)
(let ((ret (funcall loop-function)))
#1#))))
(if final-function
(apply final-function (nreverse collect))
(car lists))))

(defun mapleave (x)
(setf *mapleave* (list x)))

(defun mapret (&rest args)
(setf *mapret* (list args)))

(defun mapstop (x)
(setf *mapstop* (list x)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; 以下テスト
(assert (equal (mapf #'list #'identity '(1 2 3 4))
'(1 2 3 4)))

(defun mappend (fn &rest lists)
(apply #'mapf #'append fn lists))

(assert (equal (mappend #'list
'(1 2 3 4 5)
'(a b c d e))
'(1 A 2 B 3 C 4 D 5 E)))

(defun first-nonzero (list)
(mapf ()
(lambda (x)
(when (not (zerop x)) (mapleave x)))
list))

(assert (= (first-nonzero '(0 0 0 0 9 0 0))
9))

(defun odd-list (list)
(mapf #'list
(lambda (x) (if (oddp x)
x
(mapret)))
list))

(assert (equal (odd-list '(1 2 3 4 5))
'(1 3 5)))

(defun odd-list2 (list)
(mapf #'list
(lambda (x) (if (oddp x)
x
(mapret 'e 'ven)))
list))

(assert (equal (odd-list2 '(1 2 3 4 5))
'(1 E VEN 3 E VEN 5)))

(defun first-ten (list)
(let ((cnt 10))
(mapf #'list
(lambda (x)
(when (zerop (decf cnt)) (mapstop 10))
x)
list)))

(assert (equal (first-ten '(1 2 3 4 5 6 7 8 9 10 11 12))
'(1 2 3 4 5 6 7 8 9 10)))

(defun lnum (n &aux (cnt 0))
(mapf #'list
(lambda ()
(if (<= n (incf cnt))
(mapstop n)
cnt))))

(assert (equal (lnum 10)
'(1 2 3 4 5 6 7 8 9 10)))

2008/10/17

[Common Lisp] Lingr API

Common Lisp で Lingr API をたたいてみた。とりあえず observe できればいいかな、というレベルで。

(eval-when (:compile-toplevel :load-toplevel :execute)
(require :quek)
(require :drakma)
(require :cl-json)
(use-package :quek)
(use-package :drakma))

(defpackage for-with-json)

(defmacro! with-json (o!json &body body)
(let* (($-symbols (collect-$-symbol body))
(json-symbols (mapcar #'to-json-symbol $-symbols)))
`(json:json-bind ,json-symbols ,g!json
(let ,(mapcar #`(,_a (if (stringp ,_b) (remove #\cr ,_b) ,_b))
$-symbols json-symbols)
,@body))))

(eval-always
(defun $-symbol-p (x)
(and (symbolp x)
(char= #\$ (char (symbol-name x) 0))))

(defun to-json-symbol (symbol)
(intern (substitute #\_ #\-
(subseq (symbol-name symbol) 1))
:for-with-json))

(defun collect-$-symbol (body)
(let ($-symbols)
(labels ((walk (form)
(if (atom form)
(when ($-symbol-p form)
(pushnew form $-symbols))
(progn
(walk (car form))
(walk (cdr form))))))
(walk body))
$-symbols))
)

(defvar *key* "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx")

(defun check-status (res)
(let ((json (json:decode-json-from-string res)))
(with-json res
(when (string/= "ok" $status)
(error "~a" res)))
json))

(defun session-create (&optional (key *key*))
(with-json
(http-request "http://www.lingr.com/api/session/create"
:method :post
:parameters `(("api_key" . ,key)
("format" . "json")))
$session))

(defvar *session* nil)

(defun room-enter (id nickname &key (session *session*))
(with-json
(http-request "http://www.lingr.com/api/room/enter?format=json"
:method :post
:parameters `(("session" . ,session)
("id" . ,id)
("nickname" . ,nickname)))
$ticket))

(defun room-get-messages (ticket counter &key
user-messages-only
(session *session*))
"observe を使いましょう。"
(check-status
(http-request
"http://www.lingr.com/api/room/get_messages?format=json"
:parameters `(("session" . ,session)
("ticket" . ,ticket)
("counter" . ,(princ-to-string counter))
("user_messages_only" . ,(if user-messages-only
"true"
"false"))))))

(defun room-observe (ticket counter &key (session *session*))
(check-status
(http-request "http://www.lingr.com/api/room/observe?format=json"
:parameters `(("session" . ,session)
("ticket" . ,ticket)
("counter" . ,(princ-to-string counter))))))

(defmacro! do-observe ((room nickname) &body body)
`(let* ((*session* (session-create))
(,g!ticket (room-enter ,room ,nickname)))
(with-json (room-get-messages ,g!ticket -1)
(loop with ,g!counter = $counter
do (with-json (room-observe ,g!ticket ,g!counter)
(when $counter ; ((:status "ok")) のみの場合があるので
,@body
(setf ,g!counter $counter)))))))


#|
(do-observe ("room" "nickname")
(loop for i in $messages
do (with-json i
(format t "~&~a: ~a" $nickname $text))))
|#

2008/10/05

[Common Lisp] SQL その2

結局のところこんなふうになった。

(defaction todo ()
(default-template (:title "TODO リスト")
(html (:h1 "TODO リスト do-query #q")
(:form
(:input :type :text :name :q))
(:table :border 1
(do-query
((append #q(select * from todo)
(when @q #q(where content like :param)))
:param (string+ "%" @q "%"))
(html (:tr (:td $id)
(:td $content)
(:td $done))))))))

#q リーダマクロで SQL をそのまま書けるようにした。懐かしの埋め込み SQL だ。コンマとシングルクォートを set-macro-character しただけだが、結構 SQL をまともに read できそう。さすが Common Lisp.

SQL 中のパラメータはキーワードシンボルにして、キーワード引数で指定する。

検索結果は alist にしておいて $ で始まるシンボルで参照する。なので $ で始まるシンボルは (ASSOC "CONTENT" #:ASSOC1320 :TEST #'STRING-EQUAL) な感じにマクロ展開する。

  • SQL 文は入力によって検索条件が変わるので実行時でないとクエリが確定しない。
  • select * を使うと検索結果の列名はクエリ実行でないと分からない。

というような理由で実行時にがんばってしまうコードをはくマクロとなってしまった。効率悪そう。でも某フレームワークでは eval 使いまくっているって噂だから、まあいいか。

(defmacro with-db (var &body body)
`(clsql:with-database (,var *connection-spec*
:database-type *database-type*
:if-exists :new
:pool t
:make-default nil)
,@body))

(defun |#q-quote-reader| (stream char)
(declare (ignore char))
(with-output-to-string (out)
(loop for c = (read-char stream t nil t)
until (and (char= #\' c)
(char/= #\' (peek-char nil stream nil #\a t)))
do (progn
(write-char c out)
(when (char= c #\')
(read-char stream))))))

(defun |#q-reader| (stream sub-char numarg)
(declare (ignore sub-char numarg))
(let ((*readtable* (copy-readtable nil)))
(set-macro-character #\, {(declare (ignore _x _y)) :|,|})
(set-macro-character #\' #'|#q-quote-reader|)
`(quote ,(read stream t nil t))))

(set-dispatch-macro-character #\# #\q #'|#q-reader|)

(defgeneric >sql (x)
(:method (x)
(princ-to-string x))
(:method ((x string))
(string+ #\' (cl-ppcre:regex-replace-all "'" x "''") #\'))
(:method ((x symbol))
(substitute #\_ #\- (symbol-name x))))

(defun sexp>sql (sexp)
(with-output-to-string (out)
(loop for i in sexp
do (typecase i
(symbol (princ (>sql i) out))
(list
(princ "(" out)
(princ (sexp>sql i) out)
(princ ")" out))
(t (princ (>sql i) out)))
do (princ " " out))))

(defun substitute-query-parameters (query parameters)
(if parameters
(substitute-query-parameters
`(substitute ,(cadr parameters) ,(car parameters) ,query)
(cddr parameters))
query))

(defun make-query-result-assoc (row fields)
(loop for r in row
for f in fields
collect (cons f r)))

(defmacro! do-query ((query &rest params) &body body)
(labels ((result-symbol-p (x)
(and (symbolp x) (head-p x "$")))
(key-string (x)
(subseq (symbol-name x) 1))
(walk-body (body assoc)
(if (atom body)
(if (result-symbol-p body)
`(cdr (assoc ,(key-string body) ,assoc
:test #'string-equal))
body)
(cons (walk-body (car body) assoc)
(walk-body (cdr body) assoc)))))
`(multiple-value-bind (,g!result ,g!field-names)
(clsql-sys:query (sexp>sql
,(substitute-query-parameters query params)))
(loop for ,g!row in ,g!result
for ,g!assoc = (make-query-result-assoc ,g!row ,g!field-names)
do ,@(walk-body body g!assoc)))))

ここ数日のこと

  • カオマイカンを作った。ひさしぶりのダッチオーブンは錆びてなかった。よかった。美味しかった。
  • 幼稚園最後の運動会。すっかりその気でおどってましたな。
  • 栗御飯を作った。秋ですな。
  • 体調は回復したと思う。

2008/10/03

[Commo Lisp] POP3 でのメール削除

全く使ってなかたプロバイダのメールをひさしぶりにチェックしてみたら4000通以上のメールがたまっていた。メーラーは Opera を使っているのだが、メールのフェッチ途中で落ちてしまう。どうせ SPAM メールばかりだから全部容赦なく消してしまうことにした。

さっぱりした。複数行のレスポンスは考慮してないし、認証もプレーンテキストなので。。。

(defparameter *host* "xxx")
(defparameter *user* "xxx")
(defparameter *pass* "xxx")

(require :usocket)

(defun snd (stream &rest message)
(let ((message (format nil "~{~a~^ ~}~c~c" message #\cr #\lf)))
(print (remove #\cr message))
(write-string message stream)
(force-output stream)))

(defun rev (stream)
(print (remove #\cr (read-line stream nil))))

(usocket:with-client-socket (socket stream *host* 110)
(rev stream)
(snd stream :USER *user*)
(rev stream)
(snd stream :PASS *pass*)
(rev stream)
(snd stream :STAT)
(destructuring-bind (state count size)
(read-from-string (concatenate 'string "(" (rev stream) ")"))
(loop for i from 1 to count
do (snd stream :DELE i)
do (rev stream)))
(snd stream :QUIT)
(rev stream))

2008/10/02

[Common Lisp] アトムをコンスセルで繋いだソースと実行時表現とは無関係なんだ!(by onjo さん)

先日のことですが、どうしても次のような関数が作れなくって、Wassr に投下してみました。

(let ((x 1) (y 2) (q1 "x") (q2 "y"))
(list (xxx q1) (xxx q2)
(let ((x 10) (y 20))
(list (xxx q1) (xxx q2)))))
;; => (1 2 (10 20)) となる関数 xxx

g000001 さんから こんなのこんな 回答をもらい、さらに COMMON LISP JP(at Lingr) への投下を勧められたので投下してみました。
それでもらった回答が これ です。
その中でも onjo さんの「アトムをコンスセルで繋いだソースと実行時表現とは無関係なんだ!」という言葉が印象ぶかかったです。さすがですよね。
色々と考えてくださったみなさん、どうもありがとうございました。

[Common Lisp] with-ca/dr

わだばLisperになるさんのことでとりあげてもらったマクロ。実装はこんなふう。

defmacro! は Let Over Lambda に出てくるマクロで、o! で始まるシンボルは once-only マクロ、g! で始まるシンボルは with-gensym マクロと同じになる。

(defmacro! with-ca/dr (o!var &body body)
`(let ((car (car ,g!var))
(cdr (cdr ,g!var)))
,@body))

[Common Lisp] with-[]

わだばLisperになる(g000001)さんの添字的symbol-macroletがおもしろかったので、symbol-macrolet を使わないバージョンを書いてみた。Let On Lambda に出てきそうなやつ。

残念ながら h[foo] としてシンボル foo 自体をキーとすることができない。foo の値がキーになる。あと、setf もできない。

(require :cl-ppcre)

(defgeneric access-[] (obj index)
(:method ((obj list) index)
(nth index obj))
(:method ((obj sequence) index)
(elt obj index))
(:method ((obj hash-table) index)
(gethash index obj)))

(defmacro with-[] (&body body)
(labels (([]-p (x)
(when (symbolp x)
(cl-ppcre:register-groups-bind (symbol index)
("(.+)\\[(.+)\\]$" (symbol-name x))
(values symbol index))))
(map-form (form)
(cond ((atom form)
(multiple-value-bind (symbol index) ([]-p form)
(if symbol
`(access-[] ,(find-symbol symbol)
,(read-from-string index))
form)))
(t
(cons (map-form (car form))
(map-form (cdr form)))))))
`(progn ,@(map-form body))))

(with-[]
(let ((n 2)
(l '(1 2 3))
(s "hello")
(h (make-hash-table)))
(setf (gethash n h) "ハッシュ")
(list l[n] s[n] h[n])))
;; => (3 #\l "ハッシュ")

#|
h[foo] とかして シンボル foo をキーにするのはできない。
setf もできない。
|#