[Common Lisp][UCW] UnCommon Web で Hello World

先日はサンプルを動かすところまでだった UCW（UnCommon Web）ですが、今回は Hello Wold アプリを作成してみます。
ソースは次のとおりです。5行目の load の引数は UCW のインストール先にあわせて変更してください。
おおまかには次のような感じになっています。

1. cookie-session-application のインスタンス生成でアプリケーションを作成。


2. register-application でアプリケーションのデフォルトサーバに登録。


3. defentry-point でエントリポイントの作成。


4. defcomponent でページを定義。


5. defmethod render でページの表示の仕方を定義。

UCW は継続ベースです。URL が各ページに1対1に対応しているわけではありません。エントリポイント（入口）を定義する必要があります。今回は1ページだけなので、全然イメージができないかもしれませんが…

;; ucw がロードされていなければロードする。
(eval-when (:load-toplevel :compile-toplevel :execute)
  (unless (find-package :ucw)
    ;; UCW の start.lisp をロードする。
    (load "/home/ancient/letter/lisp/ucw/ucw-boxset/start.lisp")))

;; ucw のユーザ用パッケージ。
;; 簡単なアプリケーションならこのパッケージを使うのが簡便。
(in-package :it.bese.ucw-user)

;; アプリケーションの作成。
(defvar *hello-world-application*
  (make-instance 'cookie-session-application
                 ;; http://localhost:8080/hello/ でこのアプリケーションの
                 ;; アクセスできるようにする。
                 :url-prefix "/hello/"      ; / で終ること
                 ))

;; アプリケーションをサーバに登録する。
(register-application *default-server* *hello-world-application*)

;; エントリポイントの作成。
;; http://localhost:8080/hello/index.ucw で
;; hello-world-window の render メソッドが呼ばれる。
(defentry-point "index.ucw" (:application *hello-world-application*)
    ()
  (call 'hello-world-window))

;; hello-world-window の定義。
;; simple-window-component を継承する。
(defcomponent hello-world-window (simple-window-component)
  ()
  (:default-initargs :title "ハローワールド")) ; title の設定。

;; 表示用のメソッドの定義
(defmethod render ((hello hello-world-window))
  (<:p "ハローワールド"))

次回はページ遷移をしてみましょう。

括弧の位置

括弧の位置をまた変更しました。
もっと打ち易い位置に。
Qwerty でいうと W と E の位置に括弧を割り当てました。
S-( で , S-) で . を入力します。S-9 で < S-0 で > です。
やっぱり括弧は多用するから打ち易い位置で Shift なしで入力できないとね。
ということで、Windows 環境での mayu の設定は次のとおりです。Lisp のコードを書くときはかなり快適になりました。

## かっこ
def subst S-*_9      = $LESS-THAN_SIGN
def subst S-*_0      = $GREATER-THAN_SIGN
def subst ~S-*Comma  = $LEFT_PARENTHESIS
def subst ~S-*Period = $RIGHT_PARENTHESIS
def subst S-*Comma   = $COMMA
def subst S-*Period  = $FULL_STOP

Linux 環境の ~/.xmodmap はこうです。

keycode 0x12 =  9       less
keycode 0x13 =  0       greater
keycode 0x3B =  parenleft       comma
keycode 0x3C =  parenright      period

[Erlang] 待ち行列問題

情報処理試験でよくでてくる待ち行列問題を Erlang でシミュレートしようと思ってやってみました。
でも、ポアソン分布を理解してないためか、思ったような結果になりまんでした。また今度勉強しなおして挑戦してみます。
とりあず、コードは次のとおり。このてのものは Erlang だと書きやすいですね。

-module(wait).
-compile(export_all).

-define(SIZE, 200).

start() ->
    case whereis('行列') of
        undefined ->
            ok;
        _ ->
            unregister('行列')
    end,
    register('行列', spawn(?MODULE, '行列', [[]])),
    spawn(?MODULE, '窓口', []),
    List = lists:map(
             fun(_) ->
                     Sleep = random:uniform(100),
                     io:format("間隔 ~p~n", [Sleep]),
                     timer:sleep(Sleep),
                     spawn(?MODULE, 'お客さん', [self()])
             end,
             lists:seq(1, ?SIZE)),
    Avg = lists:foldl(fun(X, Acc) ->
                              receive 
                                  {Time, X} ->
                                      Time + Acc
                              end
                      end,
                      0,
                      List) / ?SIZE,
    io:format("平均 ~p~n", [Avg]).

'お客さん'(From) ->
    Start = now(),
    '行列' ! {'並ぶ', self()},
    receive
        'おつかれさま' ->
            ok
    end,
    Time = timer:now_diff(now(), Start),
    io:format("~p~n", [Time]),
    From ! {Time, self()}.

'行列'([]) ->
    io:format("行列の長さ 0~n"),
    receive
        {'並ぶ', From} ->
            '行列'([From])
    end;
'行列'(Queue) ->
    io:format("行列の長さ ~p~n", [length(Queue)]),
    receive
        {'次の方', From} ->
            Last = lists:last(Queue),
            From ! Last,
            '行列'(Queue -- [Last]);
        {'並ぶ', From} ->
            '行列'([From|Queue])
    end.

'窓口'() ->
    '行列' ! {'次の方', self()},
    receive
        From ->
            timer:sleep(40),
            From ! 'おつかれさま'
    end,
    '窓口'().

[Common Lisp] UnCommon Web

ひさしぶりに UnCommon Web の最新をダウンロードして動かしてみました。
UnCommon Web は継続ベースの Web フレームワークです。
コンポーネント指向で、設定一つで画面上の全ての要素にインスペクトするリンクを表示することができます。
必要なライブラリ一式をセットにした UCW boxset が配布されているので、簡単にサンプルを動かすところまでいけます。
http://common-lisp.net/project/ucw/download.html から UCW boxset をダウンロードします。
解凍したら、start.lisp をロードします。
http://localhost:8080/ にアクセスするとサンプルページが表示されます。
しばらくみないうちに、すっかり UTF-8 対応がなされているようです。
とりあえず、今日はここまで。時間があるときに何かサンプルプログラムを作ってみましょう（と、自分に伏線をはっておく）。

[Common Lisp] series

series ってあまり使われてないのでしょうか？
CLtL2 の付録に載っています。
遅延評価を提供していてなかなか面白いのにな。
collect-file と scan-file の引数の external-format を追加しようとして挫折しました。
時間があるときにまたチャレンジしてみます。

それはさておき、ファイルの内容を標準出力に出すコードです。体裁を気にしないのなら (series:scan-file "cookbook.html" #'read-line) だけで各行が要素になっている頭に #Z が付いたリストが返ってきます。#Z はシリーズのディスパッチングマクロ文字になります。
シリーズは遅延評価されるので、ファイル全体を読み込んで出力ではなく、ちゃんと1行毎に read-line, write-line が行われます。

(require :series)
(series:collect-stream 
 *standard-output*
 (series:scan-file "cookbook.html" #'read-line)
 #'write-line)
;; この方が分かりやすいでしょうか
(let ((in (series:scan-file "cookbook.html" #'read-line)))
  (series:collect-stream *standard-output* in #'write-line))

ちなみに、上の方のコードをマクロ展開すると次のようになります。tagbody と go が出てきました。CL です。

(LET* (#:ITEMS-1924 (#:DONE-1925 (LIST NIL)))
  (WITH-OPEN-FILE (#:FILE-1922 "cookbook.html" :DIRECTION :INPUT)
    (TAGBODY
     #:LL-1928
      (IF
       (EQ
        (SETQ #:ITEMS-1924 (FUNCALL #'READ-LINE #:FILE-1922 NIL #:DONE-1925))
        #:DONE-1925)
       (GO SERIES::END))
      (FUNCALL #'WRITE-LINE #:ITEMS-1924 *STANDARD-OUTPUT*)
      (GO #:LL-1928)
     SERIES::END))
  NIL)

下の方のコードをマクロ展開すると次のようになります。let でいったん束縛しているので、generator なるものが出てきます。使われ方によって異なる展開のされ方をするマクロなんてすごいですよね。このあたりが external-format 追加挫折の原因ではありますが。。。

(LET ((IN (SERIES:SCAN-FILE "cookbook.html" #'READ-LINE)))
  (LET* ((#:OUT-1931 IN))
    (LET ((#:GENERATOR-1934 (SERIES:GENERATOR #:OUT-1931)) #:ITEMS-1929)
      (DECLARE (TYPE SERIES:GENERATOR #:GENERATOR-1934))
      (TAGBODY
       #:LL-1935
        (SETQ #:ITEMS-1929
                (SERIES::DO-NEXT-IN #:GENERATOR-1934
                                    #'(LAMBDA () (GO SERIES::END))))
        (FUNCALL #'WRITE-LINE #:ITEMS-1929 *STANDARD-OUTPUT*)
        (GO #:LL-1935)
       SERIES::END)
      NIL)))

トラックバック

トラックバックってどうやって投げればいいのでしょう？

足し算

もうすぐ5歳の娘が足し算をおぼえたようです。
「8 たす 3 は」ときくと、「11。頭の中で数えたんだよ」と答えます。
でも、「3 たす 8 は」ときくと、「わかんない」と半分怒りながら答えます。
頭の中で 3 を起点として 8 カウントするのは難しいのでしょう。
「3 たす 8 と 8 たす 3 は同じだよ」と言って何度か練習するうちに、3 たす 8 も答えられるようになりました。
なかなか興味深いです。

[Common Lisp][SBCL] Bivalent Stream

Common Lisp では open の :element-type でバイナリストリームかキャラクタストリームが決定します。read-byte と read-char の両方を使えるストリームを作ることができません。
SBCL の拡張機能に Bivalent Stream があります。:element-type :default を指定することで、character と (unsigned-byte 8) のどちらでも入出力が可能になります。read-byte と read-char の両方を使うことができるストリームが作成できるのです。

CL-USER> (let ((file "/tmp/a.txt"))
  (with-open-file (out file
                       :direction :output :external-format :utf-8
                       :if-exists :supersede
                       :element-type :default) ; これで Bivalent Stream になる
    (write-char #\あ out)
    (map nil #'(lambda (byte)
                 (write-byte byte out))
         (string-to-octets "い" :external-format :utf-8)))
  (with-open-file (in file
                      :element-type :default) ; これで Bivalent Stream になる
    (loop repeat 3
         do (print (read-byte in)))
    (print (read-line in))))

227 
129 
130 
"い" 
"い"

ちなみに、他の拡張として Gray Stream と Simple Stream もあります。

Common Lisp FTP でファイルをアップロードする

ホームページにファイルをアップロードするのに Common Lisp を使ってみようと思いました。
まず、CL-FTPを試してみたのですが、うまく動かない。それじゃちょっと自分で作るか、と思い次のようなコードを書きました。
実装は SBCL です。upload.lisp

#!/usr/bin/sbcl --noinform

(defpackage :toko.ftp
  (:nicknames :ftp)
  (:use :common-lisp)
  (:shadow quit type))

(in-package :toko.ftp)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :usocket)
  (require :cl-ppcre))

(defvar *stream*)

(defun rcv (&optional (stream *stream*))
  (loop for c = (read-char stream nil nil)
     with out = (make-string-output-stream)
     if (char= #\Return c)
     do (progn
          (read-char stream nil nil)
          (return (print (get-output-stream-string out))))
     else
     do (write-char c out)))

(defun rcv-code (expected-code &optional (stream *stream*))
  (let ((line (rcv stream))
        (code (princ-to-string expected-code)))
    (if (string= code line :end2 (length code))
        line
        (error (format nil "unexpected response: ~a" line)))))

(defun snd (cmd &optional (stream *stream*))
  (print cmd)
  (format stream "~a~c~c" cmd #\Return #\Linefeed)
  (force-output stream))

(defmacro def-simple-cmd (cmd args success-code)
  (let ((lambda-list args)
        (code (prin1-to-string success-code)))
    `(defun ,cmd (,@lambda-list &key (stream *stream*) (response-fn #'identity))
       (snd 
        (format nil "~a~@{~^ ~a~}" ,(string-upcase (string cmd)) ,@lambda-list)
        stream)
       (funcall response-fn (rcv-code ,code stream)))))

(def-simple-cmd user (user) 331)
(def-simple-cmd pass (passwd) 230)
(def-simple-cmd quit () 221)
(def-simple-cmd cwd (remote-dir) 250)
(def-simple-cmd type (binary-or-ascii) 200)
(def-simple-cmd pasv () 227)

(defun put (file)
  (binary)
  (cl-ppcre:do-register-groups 
      (ip1 ip2 ip3 ip4 (#'parse-integer port1) (#'parse-integer port2))
      ("(\\d+),(\\d+),(\\d+),(\\d+),(\\d+),(\\d+)" (pasv))
    (let ((ip (format nil "~@{~a~^.~}" ip1 ip2 ip3 ip4))
          (port (+ (* port1 256) port2)))
      (snd (format nil "STOR ~a" file))
      (with-open-file (in file :element-type '(unsigned-byte 8))
        (usocket:with-client-socket (socket stream ip port
                                            :element-type '(unsigned-byte 8))
          (rcv-code 150)
          (loop for b = (read-byte in nil nil)
             while b
             do (progn
                  (write-byte b stream)))))))
  (rcv-code 226))

(defun ascii ()
  (type "A"))

(defun binary ()
  (type "I"))

(defmacro with-ftp-connection ((host user passwd &key (port 21)) &body body)
  (let ((sock (gensym)))
    `(usocket:with-client-socket (,sock *stream* ,host ,port)
       (rcv)
       (user ,user)
       (pass ,passwd)
       ,@body
       (quit))))
    
(with-ftp-connection ("s6.xrea.com" "user" "passwd")
  (setf *default-pathname-defaults* #p"/home/user/public_html/lisp/")
  (cwd "/public_html/lisp")
  (put "cookbook.html")
  (put "cookbook.css")
  (put "index.html"))

最近は usocket がポータブルなソケットライブラリの定番のようです。
これをシェルから動かすために、SBCL のマニュアルにあるように ~/.sbclrc に次のコードを書いておきます。
これで ./upload.lisp とすればアップロードできます。

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

Common Lisp iconv

[lisp]iconv発見 で 「文字列→文字列で文字コード変換きるやつないのかな。」ということですが、処理系がその文字コードをサポートしていないと vector を文字列に変換でいないのです。あれ？ 違ったかな？ Slime がだめだったかな？ それとも SBCL がユニコードサポートになって駄目になったんだっけか？ 忘れてしまいました。。。
むしろ、external-format で入出力時に変換できるべき、ということで gray stream とかを作った痕跡もある。。。
とにかく SBCL が UTF-8, EUC, SJIS をサポートするようになったんで使わなくなり、Hans Huebner さんがもっとまともな iconv をリリースしてくれる話にもなったんで、完全に忘却してました。Hans さんどうしちゃったんだろう？
おまけに会社のサーバが入れ替えになってリンク切れにもなってたんですね。新しいサーバにはファイルを置きにくいんですよねえ。
うぅん、どうしようかあ。。。

リンクだけは直しておきました。

飲み会

久し振りに飲み会に行った。
やっぱ行くんじゃなかったかな。
食事が乱れる。睡眠が乱れる。生活のリズムが乱れる。
タバコくさい。
お酒飲めないし。
人と話するのは好きじゃないし。
素直に殻にこもるかな。

SBCL external-format

SBCL の external-format のデフォルト値は sb-impl::*default-external-format* と sb-alien::*default-c-string-external-format* に設定されています。
Linux の場合は :utf-8 に、Windows の場合は :cp932 に設定するといいでしょう。
日本語のファイル名等もあつかえます。

; SLIME 2007-05-24
CL-USER> sb-impl::*default-external-format*
:UTF-8
CL-USER> sb-alien::*default-c-string-external-format*
:UTF-8
CL-USER> (directory "/tmp/未タイトルのフォルダ/*")
(#P"/tmp/未タイトルのフォルダ/新しいファイル" #P"/tmp/未タイトルのフォルダ/未タイトルのフォルダ/")
CL-USER> (with-open-file (in (car *) :external-format :cp932)
           (print (read-line in)))

"あいうえお" 
"あいうえお"

Windows では次のように ~/.sbclrc の中で設定しています。

(setf sb-impl::*default-external-format* :cp932)
(setf sb-alien::*default-c-string-external-format* :cp932)

Common Lisp 最適化

optimize 宣言により最適化の仕方をコンパイラに指示できます。
標準的に指定可能なのは次のとおりです。

speed

実行時の性能

space

コードの大きさと実行時のメモリ使用量

safety

実行時のエラーチェック

compilation-speed

コンパイルの速さ

debug

デバッグのしやすさ

これら0〜3の値を指定します。0は重要ではない。3はとても重要。1は普通。2はちょっとがんばって、というところでしょうか。
これらを指定するには、declare, locally, proclaim, daclaim を使用します。

;;デバッグ用にグローバルな指定を行う
(declaim (optimize (debug 3) (safety 3)
                   (speed 0) (space 0) (compilation-speed 0)))

(defun fib (n)
  ;; 局所的な最適化
  (declare (optimize (speed 3) (debug 0) (safety 0)))
  (cond ((or (= n 1) (= n 2))
         1)
        (t
         (+ (fib (1- n )) (fib (- n 2))))))

この他に型を指定する最適化もありますが、それはまた今度。

Common Lisp ステップ実行、オプティマイズ宣言

Common Lisp にはステップ実行を行う step というマクロがあります。
言語仕様にステップ実行が含まれるなんて、さすが Common Lisp です。

SBCL で step 実行を行うには、debug が > (max speed space compilation-speed) となるようなオプティマイズ宣言を行う必要があります。
次のように declaim でグローバルに宣言をしておくとよいかもしれません。

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

ステップ実行するには

(step (foo 3))

のようにします。

もちなおしてきた

近頃すっかり無気力になっていました。
そんなとき『数学ガール』を読み、少しもちなおしてきました。
Erlang は少しおいておきます。
Common Lisp と数学を（私なりに）きちんとやってみようかと思います。
結城さんにはいつも勇気づけられます。ありがとうございます。

Common Lisp をやるにあたり、キーボードのレイアウトを見直します。
見直すのは括弧。
Kinesis で Dvorak 配列を使っています。
括弧を打ち易い位置に移動します。
悩んだあげく、Shift+, と Shift+.
QWERTY でいうと Shift + w と Shift + e に移動します。
ではなくて、[]と入れ替えます。
QWERTY でいうと . と / の下が ( と ) になります。
移動には xkeycaps を使って次の .xmodmap を作成しました。

keycode 0x12 =  9       bracketleft
keycode 0x13 =  0       bracketright
keycode 0x22 =  parenleft       braceleft
keycode 0x23 =  parenright      braceright

さて、らき☆すたでもみるか。-> 見た。おもしろかった。小中のかがみが