[Common Lisp] asdf で fasl のバージョンが古いとき自動的にリコンパイルする

処理系をアップデートしたあと、(require :xxx) するとよく fasl のバージョンがあってないよとデバッガがたちあがったりする。

そのとき自動的にリコンパイルする方法が CLiki にのってた。

~/.sbclrc とかに以下を追加しておく。

(defmethod asdf:perform :around ((o asdf:load-op) (c asdf:cl-source-file))
  (handler-case (call-next-method o c)
    (#+sbcl sb-ext:invalid-fasl
     #+allegro excl::file-incompatible-fasl-error
     #+lispworks conditions:fasl-error
     #+cmu ext:invalid-fasl
     #-(or sbcl allegro lispworks cmu) error ()
     (asdf:perform (make-instance 'asdf:compile-op) c)
     (call-next-method))))

[Common Lisp] swank-backend::openmcl-set-debug-switches

Clozure CL で SLIME するときは ~/.swank.lisp で swank-backend::openmcl-set-debug-switches を呼ぶとよさそう。

しかし、swank:*globally-redirect-io* の方が効いていない気がする。。。

~/.swank.lisp

(setq swank:*globally-redirect-io* t)

#+:ccl
(swank-backend::openmcl-set-debug-switches)

[Common Lisp] Clozure CL での日本語のための設定

Clozure CL での日本語のための設定はこんな感じでいいのかな。

~/ccl-init.lisp

(setf ccl:*default-external-format*
      (ccl:make-external-format :character-encoding :utf-8
                                :line-termination :unix)
      ccl:*default-file-character-encoding* :utf-8
      ccl:*default-socket-character-encoding* :utf-8)

[Common Lisp] Clozure CL の require で asdf:oos する

なぜか SBCL + SLIME が動かないので Clozure + SLIME に浮気してみた。コンパイルとロードが速い!!

で、ひとつ気になったのが SBCL のように require で asdf:*central-registry* にあるライブラリをロードしてくれないこと。

以前、MCL でなんかしたなぁ、というのを思い出しつつ ccl::*module-provider-functions* に pushnew してみた。

~/ccl-init.lisp

;;;; -*- lisp -*-

;;; 最適化
(declaim (optimize (debug 3) (safety 3) (speed 0) (space 0)
                   (compilation-speed 3)))
;;(declaim (optimize (debug 0) (safety 0) (speed 3) (space 0)
;;                   (compilation-speed 0)))


;;; 文字コード
(setf ccl:*default-external-format*
      (ccl:make-external-format :character-encoding :utf-8
                                :line-termination :unix)
      ccl:*default-file-character-encoding* :utf-8
      ccl:*default-socket-character-encoding* :utf-8)


;;; asdf
(require :asdf)

;; ~/letter/lib 以下の asd を登録する。
(loop for path in (directory (translate-logical-pathname
                                       "home:letter;lisp;lib;**;*.asd"))
      do (let ((pd (pathname-directory path)))
           (unless (member "_darcs" pd :test #'equal)
             (pushnew (make-pathname :directory pd)
                      asdf:*central-registry*
                      :test #'equal))))

;; clbuild
(pushnew (translate-logical-pathname "home:letter;lisp;clbuild;systems;")
         asdf:*central-registry*)

;; require で asdf:oos する
(defun asdf-module-provider-function (module)
  (when (asdf:find-system module nil)
    (asdf:oos 'asdf:load-op module)
    t))
(pushnew 'asdf-module-provider-function
         ccl::*module-provider-functions*)

[Common Lisp] [*scratch*] gray stream

なんかもうどうでもいいから、昔書いたコードをアップしたりする（笑

(defpackage :koto.iconv-stream
  (:nicknames :iconv-stream)
  (:use :cl :sb-gray)
  (:export
   :make-iconv-output-stream
   :make-iconv-input-stream
   ))

(in-package :iconv-stream)

(defclass iconv-stream-mixin ()
  ((external-format :initform "UTF-8" :initarg :external-format)
   (internal-format :initform "UTF-8" :initarg :internal-format)))

(defclass iconv-output-stream (fundamental-character-output-stream
                               iconv-stream-mixin)
  ((base-stream :initarg :base-stream)
   (buffer :initform (make-string 4096))
   (fill-pointer :initform 0)
   (column :initform 0)))

(defmethod stream-write-char ((stream iconv-output-stream) char)
  (with-slots (buffer fill-pointer column) stream
    (setf (schar buffer fill-pointer) char)
    (incf fill-pointer)
    (if (char= #\newline char)
        (setf column 0)
        (incf column))
    (if (= fill-pointer (length buffer))
        (force-output stream)))
  char)

(defmethod stream-line-column ((stream iconv-output-stream))
  (slot-value stream 'column))

(defmethod stream-force-output ((stream iconv-output-stream))
  (with-slots (buffer fill-pointer external-format internal-format base-stream)
      stream
    (unless (zerop fill-pointer)
      (let ((vector (sb-ext:string-to-octets buffer :end fill-pointer)))
        (write-sequence (iconv:iconv internal-format external-format vector)
                        base-stream))
      (setf fill-pointer 0)))
  nil)

(defmethod close ((stream iconv-output-stream) &key abort)
  (with-slots (base-stream) stream
    (stream-force-output stream)
    (close base-stream :abort abort)))

(defun make-iconv-output-stream (file external-format &key if-exists)
  (make-instance 'iconv-output-stream
                 :external-format external-format
                 :base-stream (open file
                                    :direction :output
                                    :if-exists if-exists
                                    :element-type '(unsigned-byte 8))))


(defclass iconv-input-stream (fundamental-character-input-stream
                              iconv-stream-mixin)
  ((base-stream :initarg :base-stream)
   (base-buffer :initform
                (make-array 4096
                            :element-type '(unsigned-byte 8)))
   (base-index :initform 0)
   (buffer :initform "")
   (index :initform 0)))

(defmethod stream-read-char ((stream iconv-input-stream))
  (with-slots (buffer index base-stream base-buffer base-index external-format
                      internal-format)
      stream
    (when (= index (length buffer))
      (let ((length (read-sequence base-buffer base-stream :start base-index)))
        (if (zerop length)
            (return-from stream-read-char :eof))
        (multiple-value-bind (out remain)
            (iconv:iconv external-format internal-format
                         (subseq base-buffer 0 length))
          (setf buffer (sb-ext:octets-to-string out)
                base-index (length remain)
                index 0)
          (loop for i from 0 below base-index
                do (setf (aref base-buffer i) (aref remain i))))))
    (prog1 (aref buffer index)
      (incf index))))

(defmethod stream-listen ((stream iconv-input-stream))
  (with-slots (buffer index) stream
    (< index (length buffer))))

(defmethod stream-unread-char ((stream iconv-input-stream) char)
  (with-slots (buffer index) stream
    (cond ((zerop index)
           (setf buffer (format nil "~a~a" char buffer)))
          (t
           (decf index)
           (setf (aref buffer index) char))))
  nil)

(defmethod stream-clear-input ((stream iconv-input-stream))
  (with-slots (buffer index base-index) stream
    (setf buffer ""
          index 0
          base-index 0))
  nil)

(defmethod stream-line-column ((stream iconv-input-stream))
  nil)

(defmethod close ((stream iconv-input-stream) &key abort)
  (with-slots (base-stream) stream
    (close base-stream :abort abort)))

(defun make-iconv-input-stream (file external-format)
  (make-instance 'iconv-input-stream
                 :external-format external-format
                 :base-stream (open file :element-type '(unsigned-byte 8))))

[日記] バレエ発表会

年末恒例のバレエ発表会が終った。娘は幼稚園組の真ん中で踊って、わずからがらソロもあった。よくがんばった。フレンチカンカンは楽しくてよかった。

ま、あと関係ないジャンクコードだけど

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :bordeaux-threads)
  (require :usocket)
  (require :cl-ppcre)
  (require :puri)
  (require :flexi-streams)
  (require :quek))

(defun start ()
  "プロキシサーバを開始する。"
  ;; スレッドで
  (threads:make-thread
   (lambda ()
     ;; ポート5555でリッスンする
     (usocket:with-socket-listener (socket "localhost" 5555)
       (loop
         ;; アクセプト
        (usocket:with-connected-socket (stream-socket
                                        (usocket:socket-accept
                                         socket
                                         :element-type '(unsigned-byte 8)))
          ;; ソケットとストリームを取り出してアクセプト時の処理を呼び出す
          (accept-handler (usocket:socket stream-socket)
                          (flexi-streams:make-flexi-stream
                           (usocket:socket-stream stream-socket)))))))
   ;; スレッドに名前を付けおく
   :name "プロキシで遊んでいるスレッド"))

(defun accept-handler (socket stream)
  "アクセプト時の処理"
  (declare (ignorable socket stream))
  ;; GET http://li31-15.members.linode.com/ HTTP/1.1 みたいなのを取り出す
  (ppcre:register-groups-bind (command url version)
      ("(.*) (.*) (.*)" (rcv-line stream))
    (declare (ignore version))
    ;; ヘッダをパースして
    (let ((headers (series:choose-if
                    (lambda (header)
                      (not (member (car header) '("Keep-Alive"
                                                  "Proxy-Connection")
                                   :test #'string=)))
                    (parse-header stream))))
      ;; リクエストを処理。めんどうなので HTTP/1.0 で
      (request command (puri:parse-uri url) "HTTP/1.0" headers stream))))

(defun parse-header (stream)
  "ヘッダをパースする"
  (#M(lambda (line)
       (ppcre:register-groups-bind (var value) ("(.*?): (.*)" line)
         (cons var value)))
     (read-header-part stream)))

(defun read-header-part (stream)
  "空行までのヘッダ部分を読み込む"
  (series:scan
   (series:collect ;  collect を入れないと scan-stream で何故かブロックしてしまう。
       (series:until-if
        (lambda (x) (string= x ""))
        (series:scan-stream stream #'rcv-line)))))

(defun request (command uri version headers client-stream)
  "本来のサーバにリクエストを投げてクライアントにレスポンスを返す"
  (let ((port (or (puri:uri-port uri) 80))
        (path (compute-path uri))
        (host (puri:uri-host uri)))
    (usocket:with-client-socket (server-socket
                                 server-stream
                                 host
                                 port
                                 :element-type '(unsigned-byte 8))
      (let ((server-stream (flexi-streams:make-flexi-stream server-stream)))
        ;; リクエストを送信
        (request-send server-stream command path version headers)
        ;; レスポンスを読み込みながらクライアントに返す
        (request-recieve server-stream client-stream)))))

(defun compute-path (uri)
  (q:string+
   (or (puri:uri-path uri) "/")
   (q:awhen (puri:uri-fragment uri)
     (q:string+ "#" q:it))
   (q:awhen (puri:uri-query uri)
     (q:string+ "?" q:it))))

(defun request-send (stream command path version headers)
  ;; 標準出力にもはきたいのでサーバのストリームに標準出力をくっつける
  (let ((out (make-broadcast-stream stream *standard-output*)))
    ;; GET / HTTP/1.1 みたいなのをサーバに送信
    (snd-line #"""#,command #,path #,version""" out)
    ;; ヘッダをサーバに送信
    (write-headers out headers)
    ;; ヘッダの終りを送信
    (snd-line "" out)
    ;; POST の場合
    (when (string-equal command "POST")
      nil)
    ;; ストリームをフラッシュ
    (force-output out)))

(defun request-recieve (server-stream client-stream)
  "サーバから受信してクライアントにそのまま送信する"
  ;; 標準出力にもはきたいのでクライアントのストリームに標準出力をくっつける
  (let ((out (make-broadcast-stream client-stream *standard-output*)))
    ;; レスポンスを読み込みながらクライアントに返す
    (snd-line (rcv-line server-stream) out) ; ステータス
    (let ((headers (parse-header server-stream)))
      (write-headers out headers)       ; ヘッダ
      (snd-line "" out)
      (if (text-content-p headers)
          ;; テキスト
          (series:collect-stream
           out (series:scan-stream server-stream #'read-char) #'write-char)
          ;; バイナリ
          (series:collect-stream
           client-stream (series:scan-stream server-stream #'read-byte)
           #'write-byte)))
    ;; ストリームをフラッシュ
    (force-output out)))

(defun write-headers (stream headers)
  (series:collect-stream stream
                         (#M(lambda (x)
                              #"""#,(car x): #,(cdr x)""")
                            headers)
                         #'snd-line))

(defun snd-line (value stream)
  "1行出力"
  (princ value stream)
  (princ #\Return stream)
  (princ #\Newline stream))

(defun rcv-line (stream &optional (eof-error-p nil) eof-value)
  "1行入力"
  (let ((line (read-line stream eof-error-p eof-value)))
    (when line
      (string-trim '(#\Return #\Newline) line))))

(defun text-content-p (headers)
  "内容がテキストか否か"
  nil)
;;  (q:awhen (series:collect-first
;;            (series:choose-if (lambda (x) (string= (car x) "Content-Type"))
;;                              headers))
;;    (member (cdr q:it)
;;            '("text")
;;            :test #'q:string-start-p)))

日記

友人が結婚した。意表をつかれた。おめでとう。

祖父の一回忌で帰省。近所に安い温泉があるのはいいな。

娘が長靴をはいて猫になった。上手だったよ。

なんか他にも書いておこうと思っていたことがいろいろあったように思うが、思い出せない。

三重の思う。

[Common Lisp] cl-win32ole が CLISP でも動くようになった

Matthew D. Swank さんがパッチを送ってくれて cl-win32ole が CLISP でも動くなった。ありがとう。

cffi と trivial-garbage が動けば他の処理系でも動くと思われる。

[Forth] Gforth 0.7.0 available

http://groups.google.com/group/comp.lang.forth/browse_thread/thread/f02069f0aca53a1b

いいね。がんばってるね。素晴しい。Unicode support とかもしてる。

あと、個人的に興味深いところで

• depth-changes.fs: report stack depth changes during interpretation
• regexp.fs for regular expressions (undocumented)
• complex.fs for complex numbers (undocumented)
• wf.fs, a Wiki implementation (undocumented)
• httpd.fs, a web server (undocumented)
• status.fs, show interpreter status in separate xterm (undocumented)

httpd ってのがすごいな。

[Java] Web フレームワーク何がいい？

SAStruts でいいよね？

使いたいオブジェクトが DI される。これに慣れるともうやめられないね。とっても楽。getter と setter 書かなくていい。あの大量の setter getter は意味ないよ。Struts と S2Cantainer を知っていれば学習コストはとても低く、いくらでも手を入れて改造できる。

S2JDBC も簡単でいい。

ね。SAStruts にしましょう。

[Commo Lisp] (require :mcclim-truetype) でエラー

SBCL をアップデートしたら（タイプチェックが厳しくなったのかしら？）、(require :mcclim-truetype) でエラーが発生するようになった。

zpb-ttf の cmap.lisp でのタイプ宣言がまずいらしい。次のように id-deltas を declare からとるとうまくいく。

作者の方にメールを出した。拙い英語が通じるであろうか。。。

diff --git a/cmap.lisp b/cmap.lisp
index 36ff366..85d6e95 100644
--- a/cmap.lisp
+++ b/cmap.lisp
@@ -122,7 +122,7 @@ FONT-LOADER, if present, otherwise NIL.")
           cmap
         (declare (type cmap-value-table
                        end-codes start-codes
-                       id-deltas id-range-offsets
+                       id-range-offsets
                        glyph-indexes))
         (dotimes (i (segment-count cmap) 1)
           (when (<= code-point (aref end-codes i))

[Common Lisp] (require :mcclim-truetype)

McCLIM の日本語表示 (require :mcclim-freetype) ではなく(require :mcclim-truetype) でも可能。

mcclim-freetype の方は libfreetype を使うが、mcclim-truetype の方は C のライブラリ等をつかわず 100% Common Lisp でフォントのレンダリングを行っているらしい。

あと、コメントに次のようにして読み込めると書いてあった。asdf もいろいろ使えるんだね。

 (defmethod asdf:perform :after ((o asdf:load-op)
                                 (s (eql (asdf:find-system :clim-clx))))
   (asdf:oos 'asdf:load-op :mcclim-freetype))

[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

[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 "タイムアウトした")

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)))

[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))))
|#

[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)))))

ここ数日のこと

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

[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))

[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 もできない。
|#

[Common Lisp] SQL

こんなふうに SQL を書くのはどうだろう？

(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|)


#q(select item, price, 'Hello ''World''' as hello from order-header)
;; => (SELECT ITEM YOU::|,| PRICE YOU::|,| "Hello 'World'" AS HELLO FROM ORDER-HEADER)

[Emacs] 使い捨てファイルだけど捨てるのがもったいない

いままで /tmp/a.lisp など tmp ディレクトリに使い捨てファイルを作ってたけど、再起動時にきれいさっぱり消えてしまうのはなんだかもったいない気がしてきた。

それで howm を参考に elisp で現在日時ファイルを作成する関数をつくった。

(defun open-lisp-junk-file ()
  (interactive)
  (let* ((file (expand-file-name
                (format-time-string
                 "%Y/%m/%Y-%m-%d-%H%M%S.lisp" (current-time))
                "~/letter/lisp/junk/"))
         (dir (file-name-directory file)))
    (make-directory dir t)
    (find-file file)))
(global-set-key [(control ?c) (control ?\()] 'open-lisp-junk-file)

[Common Lisp] 開発環境

第17回慢性的CL勉強会@Lingr 8時だョ!全員集合 に参加。お題は 開発環境 で各人に開発環境の発表。他の人が具体的にどんなふうに環境を構築しているかわかって有意義かつ楽しかった。

で、せっかくなので自分のをここにまとめておく。

OS

OS は Debian sid(unstable) x86_64

処理系

処理系は SBCL で Debian パッケージ。Debian の場合は common-lisp-controller も一緒にインストールされ SBCL のコアに組み込まれる。common-lisp-contoller は "/var/cache/common-lisp-controller/[uid]/[処理系]/[ソースのパス]/" ディレクトリにコンパイル済ファイル(fasl)を配置してくれる。複数ユーザ、複数処理系でも大丈夫。

あと hyperspec, sbcl-src パッケージもインストールしている。

ライブラリ

ライブラリの取得は clbuild を使用。./clbuild update --all-projects のコマンド一発で130以上のライブラリが常に最新にできるところが便利。ちなみに clbuild は ./clbuild run climacs とかすると Climacs を起動してくれたりもする。clbuild にあらかじめないライブラリも設定ファイルに記述することで取得対象に含めることができる。

自作ライブラリは ~/letter/lisp/lib の下に配置して ~/.sbclrc から asdf:*central-registry* に登録している。ソース管理は darcs を使用。

~/.sbclrc は↓

;;;;; -*-lisp-*-

;;デバッグ用セッティング
(declaim (optimize (debug 3)))
;;(declaim (optimize (debug 0) (safety 0) (speed 3) (space 0)
;;                   (compilation-speed 0)))

(setf (logical-pathname-translations "ancient")
      `(("**;*.*" "/home/ancient/letter/lisp/**/*.*")))

;; ~/letter/lib 以下の asd を登録する。
(loop for path in (directory (translate-logical-pathname
                                       "ancient:lib;**;*.asd"))
      do (let ((pd (pathname-directory path)))
           (unless (member "_darcs" pd :test #'equal)
             (pushnew (make-pathname :directory pd)
                      asdf:*central-registry*
                      :test #'equal))))

;; clbuild
(pushnew (translate-logical-pathname "ancient:clbuild;systems;")
         asdf:*central-registry*)

(defun climacs ()
  "Climacs を起動する。"
  (load (merge-pathnames ".climacs.lisp" (user-homedir-pathname))))

(defun maxima ()
  "Maxima を起動する。"
  (let ((*default-pathname-defaults*
         (translate-logical-pathname "ancient:clbuild;source;maxima;src;")))
    (load "maxima-build.lisp")
    (maxima-load)
    (cl-user::run)))

;;; If the first user-processable command-line argument is a filename,
;;; disable the debugger, load the file handling shebang-line and quit.
(let ((script (and (second *posix-argv*)
                   (probe-file (second *posix-argv*)))))
  (when script
    ;; Handle shebang-line
    (set-dispatch-macro-character #\# #\!
                                  (lambda (stream char arg)
                                    (declare (ignore char arg))
                                    (read-line stream)))
    ;; Disable debugger
    (setf *invoke-debugger-hook*
          (lambda (condition hook)
            (declare (ignore hook))
            ;; Uncomment to get backtraces on errors
            ;; (sb-debug:backtrace 20)
            (format *error-output* "Error: ~A~%" condition)
            (quit)))
    (load script)
    (quit)))

エディタ

Emacs から SLIME を使用。SBCL のコアファイルはいじらず Emacs から M-x slime として開発。

~/.emacs の SLIME まわりの設定は↓

;;;;;SLIME
(setq common-lisp-hyperspec-root "file:/usr/share/doc/hyperspec/")
(add-path "~/letter/lisp/clbuild/source/slime")
(add-path "~/letter/lisp/clbuild/source/slime/contrib")
(setq slime-backend (expand-file-name
                     "~/letter/lisp/clbuild/source/slime/swank-loader.lisp"))
(setq slime-communication-style :fd-handler)
(setq slime-lisp-implementations
      `((sbcl ("sbcl") :coding-system utf-8-unix)
        (clisp ("clisp") :coding-system utf-8-unix)
        (acl ("/home/ancient/local/opt/acl81_express/alisp")
             :coding-system utf-8-unix)
        (cmucl ("lisp"))))
(require 'slime-autoloads)
(add-hook 'lisp-mode-hook
          (lambda ()
            (cond ((not (featurep 'slime))
                   (require 'slime)
                   (normal-mode)))))
(setq slime-truncate-lines nil)
(setq slime-enable-evaluate-in-emacs t)
(add-hook
 'slime-mode-hook
 (lambda ()
   (global-set-key [(control ?\;)] 'slime-selector)
   (slime-define-key [(control ?c) ?\;] 'slime-insert-balanced-comments)
   (slime-define-key [(control ?u) (control ?c) ?\;]
                     'slime-remove-balanced-comments)
   (slime-define-key [(control ?c) ?\;] 'slime-insert-balanced-comments)
   (slime-define-key "\C-m" 'newline-and-indent)
   (slime-define-key "\C-i" 'slime-indent-and-complete-symbol)))
(add-to-list 'auto-mode-alist '("\\.asd$" . common-lisp-mode))
(eval-after-load "slime"
  '(progn
    (slime-setup '(slime-asdf
                   slime-fancy
                   slime-indentation
                   slime-references
                   slime-tramp
                   slime-banner))
    (setq slime-complete-symbol*-fancy t)
    (setq slime-complete-symbol-function 'slime-fuzzy-complete-symbol)))

キーボード

Kinesis で Dvorak 配列。Qwerty での W と E のキーを ( と ) にしている。括弧を打つのにシフトキーを押さなくていいのは快適♪

で http://bc.tech.coop/blog/060131.html にあるのと同じようにタッチパッドをくっつけて、膝の上においてタイプしてる。

[Common Lisp] Web フレームワークを作る。CLSQL

CLSQL を使えるようにしよう。

S 式で SQL を書けるようにしようかと思ったけどやめた。難しかったから(w SQL 文そのまんま文字列でいいんじゃないかなと。また後で SQL のパラメータの渡し方は考える。今回は検索結果の参照を実装。

SQL 文の select から from の間を CL-PPCRE で強引にパースして CLSQL の do-query マクロに展開するマクロを書いた。

(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))


(let ((scanner (cl-ppcre:create-scanner #"""select\s+(.*?)\s+from\b"""
                                        :case-insensitive-mode t
                                        :single-line-mode t)))
  (defun select-columns (query)
    (let (result)
      (cl-ppcre:register-groups-bind (columns) (scanner (string+ query " from"))
        (cl-ppcre:do-register-groups (column)
            (#"""(\w+)\s*,""" (string+ columns #\,))
          (push (string-upcase column) result)))
      (nreverse result))))

(defmacro loop-query (query &body body)
  `(clsql:do-query (,(mapcar #'intern (select-columns query)) ,query)
     ,@body))

(defmacro! with-query (query &body body)
  `(block ,g!block
      (clsql:do-query (,(mapcar #'intern (select-columns query)) ,query)
        (return-from ,g!block ,@body))))

HUNCHENTOOT のディスパッチャ部分で with-db する。

(defgeneric dispatch ()
  (:method ()
    (ppcre:register-groups-bind (package symbol-name)
        ((format nil "~a([^/]+)/([^?/]+)" *url-prefix*)
         (hunchentoot:request-uri))
      (with-output-to-string (*standard-output*)
        (with-db clsql-sys:*default-database*
          (call-action-by-symbol
           (find-symbol (string-upcase symbol-name)
                        (intern (string-upcase package) :keyword))))))))

使うときはこんな感じになる。

(defaction todo ()
  (default-template (:title "TODO リスト")
    (html (:h1 "TODO リスト")
          (:table :border 1
                  (loop-query "select id as no, content, done from todo"
                    (html (:tr (:td no)
                               (:td content)
                               (:td done))))))))

うぅん、やっぱり S 式で SQL 書かないと何かと不便かなぁ。。。

[Common Lisp] Web フレームワークを作る。テンプレート

Struts の tiles みたいなイメージのテンプレートを実装しようかと思った。でも S 式で HTML 出力するから、わざわざテンプレートの仕組みを実装する必要なんかなくって、マクロを1つ定義してしまえばおしまい。

こんな感じ。

(defmacro default-template ((&key (title "Arc Challenge")) &body body)
  `(html (:head (:title ,title))
        (:body ,@body)))

(defaction arc1 ()
  (default-template ()
    (error-messages)
    (:form :action :arc2
           "foo: " (:input :type :text :name :foo)
           (:input :type :submit))))

上の arc1 を適当にマクロ展開(Slime で C-c C-m)すると次のようになる。すごくべただ。

(PROGN
  (SETF (GET 'ARC1 :ACTION) T)
  (DEFMETHOD ARC1 NIL
    (PROGN
      (PROGN
        (PRINC "<")
        (PRINC "head")
        (PRINC ">")
        (PROGN
          (PROGN
            (PRINC "<")
            (PRINC "title")
            (PRINC ">")
            (PROGN (PRINC (>HTML "Arc Challenge")) (VALUES))
            (PRINC "</")
            (PRINC "title")
            (PRINC ">"))
          (VALUES))
        (PRINC "</")
        (PRINC "head")
        (PRINC ">"))
      (PROGN
        (PRINC "<")
        (PRINC "body")
        (PRINC ">")
        (PROGN (PRINC (>HTML (ERROR-MESSAGES))) (VALUES))
        (PROGN
          (PROGN
            (PRINC "<")
            (PRINC "form")
            (FORMAT T " ~a=\"~a\"" "action" (>HTML :ARC2))
            (PRINC ">")
            (PROGN (PRINC (>HTML "foo: ")) (VALUES))
            (PROGN
              (PROGN
                (PRINC "<")
                (PRINC "input")
                (FORMAT T " ~a=\"~a\"" "type" (>HTML :TEXT))
                (FORMAT T " ~a=\"~a\"" "name" (>HTML :FOO))
                (PRINC "/>"))
              (VALUES))
            (PROGN
              (PROGN
                (PRINC "<")
                (PRINC "input")
                (FORMAT T " ~a=\"~a\"" "type" (>HTML :SUBMIT))
                (PRINC "/>"))
              (VALUES))
            (PRINC "</")
            (PRINC "form")
            (PRINC ">"))
          (VALUES))
        (PRINC "</")
        (PRINC "body")
        (PRINC ">"))
      (VALUES))))

[Common Lisp] Web フレームワークを作る。validation

validation くらいは必要かな。

まず普通の関数だった各ページ表示関数をメソッドにする。そこに :around でバリデーションをかぶせる。

(defmacro defaction (name (&rest options) &body body)
  "options は権限的な何かに使えそう。"
  (declare (ignore options))
  `(progn
     (setf (get ',name :action) t)
     (defmethod ,name ()
       ,@body)))

(defmacro defvalidation (name (&key error-action) &body body)
  `(defmethod ,name :around ()
     (let ((*error-messages*
            (remove nil
                 (list ,@(mapcar (lambda (form)
                                   `(apply ',(second form)
                                           (hunchentoot:parameter
                                            ,(>html (first form)))
                                           (list ,@(cddr form))))
                                 body)))))
       (if *error-messages*
           (,error-action)
           (call-next-method)))))

(defun required (value &key (message "入力してください。"))
  (if (emptyp value)
      message))

というかんじで

(defaction arc1 ()
  (html (:body
         (error-messages)
         (:form :action :arc2
                (:input :type :text :name :foo)
                (:input :type :submit)))))

(defaction arc2 ()
  (html (:body (:a :href (>url :arc3 :foo @foo) "ここよ"))))

(defvalidation arc2 (:error-action arc1)
  (foo required :message "foo を入力してください。"))

(defaction arc3 ()
  (html (:body #"""you said: "#,@foo""""
               (:br)
               (:a :href 'arc1 '戻る))))

うむ、どうかな。。。

[Common Lisp] リストから2つずつ取り出したいとき

zip はないけど loop for on by #'cddr がある。

zip2 はないけど cdddr がある。

もちろん cddddr もある。

(loop for (a b) on '(1 2 3 4 5 6 7) by #'cddr
      collect (list a b))
;; ((1 2) (3 4) (5 6) (7 NIL))

(loop for (a b c) on '(1 2 3 4 5 6 7) by #'cdddr
      collect (list a b c))
;; ((1 2 3) (4 5 6) (7 NIL NIL))

(loop for (a b c d) on '(1 2 3 4 5 6 7) by #'cddddr
      collect (list a b c d))
;; ((1 2 3 4) (5 6 7 NIL))

Common Lisp の loop と C++ の STL どっちが。。。

[Common Lisp] Web フレームワークを作る

Common Lisp で Web フレームワークを作る、ってのに挫折すること幾年月。このごろはシンプルな方向でいってみようと思っている。最終的には実業務で使いたい。そうなると Weblocks も UCW も難しすぎる。ということでシンプルに。

まずは S 式を HTML にするマクロを作った。キーワードシンボルから始まるリストはタグに、@ で始まるシンボルはリクエストパラメータの参照にする。で Arc Challenge を書くと次のようになる。

(defun arc1 ()
  (html (:body
         (:form :action :arc2
                (:input :type :text :name :foo)
                (:input :type :submit)))))

(defun arc2 ()
  (html (:body (:a :href (format nil "arc3?foo=~a" @foo) "ここよ"))))

(defun arc3 ()
  (html (:body "you said: \"" @foo #\")))

まあ、シンプルじゃないかな。href のとこは何とかする必要があるけど。ソースは現状はパッケージ名と関数名を URL とする仕様で、Hunchentoot を使ってる。

(setf hunchentoot:*hunchentoot-default-external-format*
      (flexi-streams:make-external-format :utf-8)
      hunchentoot:*default-content-type* "text/html; charset=utf-8"
      hunchentoot:*show-lisp-errors-p* t
      hunchentoot:*show-lisp-backtraces-p* t)

(defvar *url-prefix* "/you/")
(defvar *port* 8888)

(defgeneric dispatch ()
  (:method ()
    (ppcre:register-groups-bind (package symbol-name)
        ((format nil "~a([^/]+)/([^?/]+)" *url-prefix*)
         (hunchentoot:request-uri))
      (with-output-to-string (*standard-output*)
        (funcall (symbol-function
                  (find-symbol (string-upcase symbol-name)
                               (intern (string-upcase package) :keyword))))))))

(defvar *dispatch*
  (hunchentoot:create-prefix-dispatcher *url-prefix* 'dispatch))

(pushnew *dispatch* hunchentoot:*dispatch-table*)

(defvar *server* (hunchentoot:start-server :port *port*))

;;;; ここからが html マクロ
(defmacro html (&body body)
  (let ((body (replace-html body)))
    `(progn
       ,@(mapcar #'to-html body))))

(defun replace-html (x)
  (cond ((and (symbolp x)
              (char= #\@ (char (symbol-name x) 0)))
         `(hunchentoot:parameter ,(string-downcase (subseq (symbol-name x) 1))))
        ((atom x)
         x)
        (t (cons (replace-html (car x))
                 (replace-html (cdr x))))))

(defun to-html (x)
  (if (or (atom x)
          (not (keywordp (car x))))
      `(princ (>html ,x))
      (to-keyword-html x)))

(defun to-keyword-html (x)
  (let ((tag (>html (car x))))
    (multiple-value-bind (attrs body) (split-attrs-body (cdr x))
      `(progn
         (princ "<")
         (princ ,tag)
         ,@(mapcar
            {`(format t " ~a=\"~a\"" ,(>html (car _)) (>html ,(cdr _)))}
            attrs)
         ,@(if body
               `((princ ">")
                 ,@(mapcar {`(html ,_)} body)
                 (princ "</")
                 (princ ,tag)
                 (princ ">"))
               `((princ "/>")))))))

(defun >html (x)
  (cond ((null x) "")
        ((symbolp x) (string-downcase (symbol-name x)))
        (t (princ-to-string x))))

(defun split-attrs-body (arg)
  (let (attrs body)
    (labels ((f (x)
               (cond ((null x)
                      nil)
                     ((atom x)
                      (setf body (list x)))
                     ((keywordp (car x))
                      (push (cons (car x) (cadr x)) attrs)
                      (f (cddr x)))
                     (t
                      (setf body x)))))
      (f arg)
      (values (reverse attrs) body))))

この html マクロを書くのにずいぶん時間がかかってしまった。もっと美しく書けるような気がする。Common Lisp を使ってるときって、他のどの言語を使っているときよりも、自分の頭の悪さを実感するんだよね。それだからこそ、ささいなコードでも Common Lisp で書くのは楽しい。

[Common Lisp] (directory "**/*.asd")

(directory "**/*.asd") のようにすると zsh みたいにサブディレクトリも検索してくれる。

いままで ~/.sbclrc の中で cl-fad を使って asd ファイルのあるディレクトリをasdf:*central-registry* に登録してたけど directory 関数で十分じゃないかと気づいた。

asdf-install を使わずに各リポジトリから最新を持ってきてたり、Windows でシンボリックリンクが使えなかったりという理由でディレクトリを走査して asdf:*central-registry* に登録している。

で、~/.sbclrc を修正

(setf (logical-pathname-translations "ancient")
      `(("**;*.*" "/home/ancient/letter/lisp/**/*.*")))

;; ~/letter/lib 以下の asd を登録する。
(loop for path in (directory (translate-logical-pathname
                                       "ancient:lib;**;*.asd"))
      do (let ((pd (pathname-directory path)))
           (unless (member "_darcs" pd :test #'equal)
             (pushnew (make-pathname :directory pd)
                      asdf:*central-registry*
                      :test #'equal))))
;;(require :cl-fad)
;;(cl-fad:walk-directory
;; (translate-logical-pathname "ancient:lib;")
;; #'(lambda (path)
;;     (let ((pd (pathname-directory path)))
;;       (unless (member "_darcs" pd :test #'equal)
;;         (pushnew
;;          (make-pathname :directory pd)
;;          asdf:*central-registry*
;;          :test #'equal))))
;; :test #'(lambda (path)
;;           (string-equal "asd" (pathname-type path))))

うん、よりシンプルになった。

Shibuya.lisp

結成おめでとうございます。

Lisp 生誕から50周年。すばらしいですね。

[Common Lisp] Q数を SERISE で

『ゲーデル、エッシャー、バッハ―あるいは不思議の環』に出てきた Q数 というのを SERIES で生成してみた。Q数というのは

n>2のときQ(n)=Q(n-Q(n-1))+Q(n-Q(n-2)),Q(1)=Q(2)=1

で、規則的に生成しているけど順番に増加せず増えたり減ったりしながら増加している。「非常に規則的なしかだで作り出される混沌」と表現されている。

次のコードは最初の1000個を出力する。

(require :series)
(use-package :series)
(subseries
 (scan-fn '(values integer integer list)
          (lambda () (values 1 2 '(1 1)))
          (lambda (a n list)
            (declare (ignore a))
            (let ((x (+ (nth (- n (nth (- n 1) list)) list)
                        (nth (- n (nth (- n 2) list)) list))))
              (values x
                      (1+ n)
                      (append list (list x))))))
 0 1000)

おもしろい。

[Common Lisp] Common Music

Common Music をいじってみた。Common Music とは "an object-oriented music composition environment".

他には OpenMusic というのもある。Common Lisp は Music が充実している。きっと MCL のおかげなんだろうな。

Common Music の全体像がまだ分からないけど、ひとまず MIDI で音を鳴らしてみた。音を鳴らすには timidity が必要。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :cm)
  (in-package :cm))
(events (process for i in '(c d e 0 c d e 0 g e d c d e c 0
                            g g e g a a g 0 e e d d c)
                 output (new midi :time (now) :keynum i)
                 wait 0.5) "b.midi")

とっかかりとしては Common Music Tutorials あたりがよさそう。

もうあきらめた

もう無理だよ。

もうやだ

ほんとに仕事やめたくなった。

Common Lisp から Maxima の関数を使う

(in-package :maxima)

#|
$plot2d に trace(C-c C-t) をかけておき、
plot2d(x^2, [x, -5, 5]); を実行すると
こんな引数で呼ばれるのが分かる。
  0: ($PLOT2D ((MEXPT SIMP) $X 2) ((MLIST SIMP) $X -5 5))
  0: $PLOT2D returned ""
|#

;; quit(); で Maxima からぬけて、
;; 2つの引数に ' を付けて実行すると、グラフが表示された。
($PLOT2D '((MEXPT SIMP) $X 2) '((MLIST SIMP) $X -5 5))


#|
http://cosmo.phys.hirosaki-u.ac.jp/wiki.cgi/maxima?page=Maxima+%A4%C7%A4%CE%A5%B0%A5%E9%A5%D5%C9%BD%BC%A8
を参考にして円をかく。

θ -> 0..2π
x -> cosθ
y -> sinθ
で円なのね。

(%i7) plot2d( [parametric, cos(t), sin(t), [t, 0, 2*%pi], [nticks, 50]],
              [gnuplot_preamble, "set size square"] )$
  0: ($PLOT2D
      ((MLIST SIMP) $PARAMETRIC ((%COS SIMP) $T) ((%SIN SIMP) $T)
       ((MLIST SIMP) $T 0 ((MTIMES SIMP) 2 $%PI)) ((MLIST SIMP) $NTICKS 50))
      ((MLIST SIMP) $GNUPLOT_PREAMBLE "set size square"))
|#

;; CL の repl から
($plot2d
 '((mlist simp) $parametric
   ((%cos simp) $t)
   ((%sin simp) $t)
   ((mlist simp) $t 0 ((mtimes simp) 2 $%pi))
   ((mlist simp) $nticks 50))
 '((mlist simp) $gnuplot_preamble "set size square"))



;;;; これを NLISP でやってみよう。
(require :nlisp)

(let* (($t (nlisp:.rseq 0 (* 2 pi) 50))
       ($x (nlisp:.cos $t))
       ($y (nlisp:.sin $t)))
  (nlisp:plot $x $y))

#|
できた。
↓のよりよくなった？
(let* ((x (.rseq -1 1 1000))
       (+y (.sqrt (.- 1 (.* x x))))
       (-y (.* -1 (.sqrt (.- 1 (.* x x))))))
  (plot (.concatenate +y -y)
        (.concatenate x x)))
|#