Common Lisp で OLE ライブラリを作りはじめる

Common Lisp の OLE ライブラリ（Ruby の Win32OLE みたいなの）がなかったので作りはじめてみました。
ここ数日せっせとハックしてます。

自宅には Windows マシンがないので OS インストールからでした。
Linux マシンの qemu/kvm に Vista をインストール。
ついで Cygwin, Meadow, SBCL, SLIME, VS2008C++Express, WIN32SDK をインストール。

そしてようやく開発開始です。
C ではコードを書かず、cffi を使って Lisp のコードだけで作成する方針でいきます。
VARIANT の union にやられながら、とりあず BOOL, BST, IDispatch だけを実装して、次のコードが動くようになりました。
IE でページを表示してタイトルを取得しています。
Excel のサンプルを作りたいところですが、Excel を持っていないので。。。とても古いバージョンがどっかにあったかなぁ。

(let ((ie (create-instance "InternetExplorer.Application")))
  (property ie :visible t)
  (invoke ie :navigate "http://sbcl.sourceforge.net/")
  (loop while (property ie :busy)
     do (sleep 0.5))
  (let ((document (property ie :document)))
    (format t "document title is \"~a\".~%" (property document :title)))
  (sleep 3)
  (invoke ie :quit))

やっぱり名前は cl-win32ole ですよね。

バレエ発表会 くるみ割り人形

昨日は娘のバレエ発表会でした。
第1部、第2部とあり。なんと第2部はくるみ割り人形の全幕。
一番驚いたのは小学4年生のレベルが高いこと。なんだかとても綺麗で上手でした。去年はそんな印象はなかったのですが、これは来年、再来年とますます期待できそうです。
うちの娘も1回間違えたものの上手に踊っていました。
表情も一番いい笑顔でしたよ。

[Common Lisp] iconv をアップデート ver 0.4

iconv のまたバージョンアップしました。
UTF-32 等に変換するとバッファが足りなくなるので、errno E2BIG を見るようにしました。
errno を見る方法ですが、SBCL なら sb-alien:get-errno、CMUCL なら unix:unix-errno、その他なら __errno_location を使うようにしました。
あとは CMUCL、32bit、64bit 環境で動かして見つけた不具合を修正。

[本] Paradigms of Artificial Intelligence Programming: Case Studies in Common Lisp

年末年始のおともに買いました。
amazon.com のレビューで「This book has been called "The best book on programming ever written". 」なんて書かれていましたので。

[Common Lisp] iconv をアップデート

iconv をアップデートしました。バージョン 0.3 です。
変更点は次のとおりです。

• UFFI をやめて CFFI を使うようにしました。


• ポータブルな参照方法が見つからなかったので、errno を見るのを止めました。


• error-p 引数を削除して、返り値の2番目で成功か否かを返すようにしました。


• from-code と to-code は symbol でも動くようにしました。

ほんとたいしたことのないライブラリなので trivial-iconv とかいう名前にしておけばよかったなぁ。
それはともかく、英語は難しいです。

[Common Lisp] LTK の味見

Common Lisp の Tk バインディングである LTK をちょっと味見してみました。
CLIM にくらべるとずっと手軽な感じです。
Debian の UTF-8 な環境ですが、日本語の入出力も普通にできました。
最近なんだか Web ばかりですが、GUI のプログラミングも楽しいですね♪

#|
http://www.peter-herth.de/ltk/
(require :asdf-install)
(asdf-install:install :ltk)
|#
(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :ltk))

(in-package :ltk)

;;デモ
;;(ltktest)
;;(ltk-eyes)

(defun main ()
  (setf *debug-tk* nil)
  (with-ltk ()
    (let ((btn (make-instance
              'button
              :text "やあ、LTK♪"
              :command (lambda ()
                         (do-msg "それでは。" "ハローワールド!")
                         (setf *exit-mainloop* t))))
          (txt (make-instance 'text)))
      (pack btn)
      (pack txt))))

(main)

再 CLIM(McCLIM) で Hello World! まで

McCLIM の Wiki(McCliki)にある "A Guided Tour of the Common Lisp Interface Manager" を読んでいます。それにのっていた Hello World ですが、"Hello World!" を真ん中に表示するための次のコードがとても気に入りました。
(floor w 2) (floor h 2) :align-x :center :align-y :center
今日はただそれだけです。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :mcclim))

(in-package :clim-user)

(define-application-frame hello-world ()
  ((greeting :initform "Hello World!"
             :accessor greeting))
  (:pane (make-pane 'hello-world-pane)))

(defclass hello-world-pane (clim-stream-pane)
  ())

(defmethod handle-repaint ((pane hello-world-pane) region)
  (let ((w (bounding-rectangle-width pane))
        (h (bounding-rectangle-height pane)))
    (draw-rectangle* pane 0 0 w h
                     :filled t
                     :ink (pane-background pane))
    (draw-text* pane
                (greeting *application-frame*)
                (floor w 2) (floor h 2) :align-x :center :align-y :center)))

(defun run ()
  (run-frame-top-level
   (make-application-frame 'hello-world :width 300 :height 200)))

;;(run)

Common Lisp で Brainf*ck コンパイラ

どう書く？org の「BFコンパイラー」をやってみました。
Common Lisp での回答はすでに出ていますが、今回はマクロキャラクタを使ってやってみます。
お題は「BFで書かれたソースを、同じ言語に変換するコンパイラー」ですが、マクロキャラクタでリードテーブル（*readtable*）を拡張し言語（Common Lisp）自体が Brainf*ck のソースそのままをロード（load）、コンパイル（compile-file）できるようにします（といっても、セットしたマクロキャラクタにしたがいリーダーが自動的に CL に変換してくれているのですが）。。
SBCL のコンパイラはネイティブコードにコンパイルしてくれるので、Brainf*ck のソースもネイティブコードにコンパイルしている、と言えるのかもしれません;)

(defparameter *memory* nil  "メモリ")

(defparameter *ptr* 0 "ポインタ")

(defun init-bf-env ()
  "実行環境の初期化を行います。"
  (setf *memory*
        (make-array 1 :initial-element 0 :adjustable t :fill-pointer 1)
        *ptr* 0))

(define-symbol-macro *-*ptr* (aref *memory* *ptr*))

(defun make-bf-readtable ()
  (let ((*readtable* (copy-readtable nil)))
    (loop for (char . fun) in
         `((#\/ . ,#'(lambda (stream char)
                       (declare (ignore char))
                       (do () ((char= (read-char stream nil #\Newline t)
                                      #\Newline)))
                       (values)))
           (#\> . ,#'(lambda (stream char)
                       (declare (ignore stream char))
                       `(when (<= (length *memory*) (incf *ptr*))
                          (vector-push-extend 0 *memory*))))
           (#\< . ,#'(lambda (stream char)
                       (declare (ignore stream char))
                       `(decf *ptr*)))
           (#\+ . ,#'(lambda (stream char)
                       (declare (ignore stream char))
                       `(incf *-*ptr*)))
           (#\- . ,#'(lambda (stream char)
                       (declare (ignore stream char))
                       `(decf *-*ptr*)))
           (#\. . ,#'(lambda (stream char)
                       (declare (ignore stream char))
                       `(write-char (code-char *-*ptr*))))
           (#\, . ,#'(lambda (stream char)
                       (declare (ignore stream char))
                       `(setf *-*ptr* (char-code (read-char)))))
           (#\[ . ,#'(lambda (stream char)
                       (declare (ignore char))
                       `(loop until (zerop *-*ptr*)
                           do (progn ,@(read-delimited-list #\] stream t))))))
       do (set-macro-character char fun))
    (set-macro-character #\] (get-macro-character #\)) nil)
    *readtable*))

;; テスト。*readtable* を設定して load する。
(let ((*readtable* (make-bf-readtable)))
  (init-bf-env)           ;実行時には *memory* と *ptr* の初期化が必要
  (load #p"hello-world.bf"))

;; もちろんコンパイルもできます。
(let ((*readtable* (make-bf-readtable)))
  (compile-file #p"hello-world.bf"))

;; コンパイルしたものを実行。速いです!!
(progn (init-bf-env)      ;実行時には *memory* と *ptr* の初期化が必要
       (load "hello-world.fasl"))

実行前に (init-bf-env) が必要なのがちょっとわずらわしいですね。
dispatching macro character を使えばそのへんを含めた上で、Common Lisp のソースに Brainf*ck のソースを埋め込む、といったこともできるでしょう。

Common Lisp で Twitter API をたたいてみる

いまさらながら Twitter を再開しています。
そこで Common Lisp で Twitter API をたたいてみたいと思います。

REST なので Drakma で http-request すればできちゃいます。フォーマットは JSON を指定して、CL-JSON でデコードします。
デコードまでしてしまえば alist のリストが手に入るので、後は煮るなり焼くなり好きなように。なのですが、せっかくの Common Lisp なので無駄に with-selector なんていうマクロを書いて遊んでいます。

次のページを参考にさせていただきました。ありがとうございます。
観測気球さんのTwitter API 仕様書 (勝手に日本語訳シリーズ)
Twitter Development Talk API Documentation

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

;; 文字コードは UTF-8 で
(setf drakma:*drakma-default-external-format* :utf-8)

;; ボディを文字列で取得するために、テキストとして判定される Content-Type を追加
(pushnew '("application" . "json") drakma:*text-content-types* :test #'equal)

(defparameter *basic-authorization*
  (with-open-file (in (merge-pathnames #p".twitter.lisp" (user-homedir-pathname)))
    (read in))
  "Basic 認証のパラメータを取得する。~/.twitter.lisp の中身は (\"username\" \"password\")")

(defun public-timeline ()
  "public_timeline を取得する。"
  (json:decode-json-from-string
   (drakma:http-request "http://twitter.com/statuses/public_timeline.json"
                        :basic-authorization *basic-authorization*)))

(defmacro select (accessor data)
  "各フィールドへ assoc でアクセスするマクロ。"
  `(reduce #'(lambda (acc key)
               `(cdr (assoc ,key ,acc)))
           ,accessor
           :initial-value ,data))

(defmacro with-selector (fields from &body body)
  "レスポンスボディの各フィールドへのアクセスマクロ。
(loop for each in (public-timeline)
     do (with-selector ((user :user :screen_name)
                        (text :text))
            each
          (format t \"~15a ~a~%\" user text)))"
  (let ((data (gensym)))
    `(let ((,data ,from))
       (let ,(mapcar #'(lambda (x)
                         (list (car x) (select (cdr x) data)))
                     fields)
         ,@body))))

;; public_timeline を取ってきてスクリーンネームとテキストを表示する。
(loop for each in (public-timeline)
     do (with-selector ((user :user :screen_name)
                        (text :text))
            each
          (format t "~15a ~a~%" user text)))

Common Lisp のシンボルの美しさについて

Common Lisp のシンボル（Symbol）は次の属性を持っています。

• 名前: symbol-name


• ホームパッケージ: symbol-package


• プロパティリスト: symbol-plist


• 値: symbol-value


• 関数: symbol-function

(defvar sym 'あたい)

(defun sym ()
  '関数)

(setf (get 'sym 'キー1) '値1)

(macrolet ((p (&body body)
              `(progn ,@(mapcar #'(lambda (arg)
                                    `(format t "~30a ; => ~a~%" ',arg ,arg))
                                body))))
  (p sym
     (sym)
     (get 'sym 'キー1)
     (symbol-name 'sym)
     (symbol-package 'sym)
     (symbol-plist 'sym)
     (symbol-value 'sym)
     (symbol-function 'sym)))

シンボル sym は変数であり関数でありプロパティリストであり、自分の名前とパッケージを知っています。
Common Lisp のシンボルはこのようにきちんとした構造を持った一つのオブジェクトなのです。
そして、Lisp ではこのようなシンボルを変数のように使います。
他の言語の変数は、それ自体では実態がなく、他の何かの参照のようなものです。
しかし Lisp の変数は、シンボルというオブジェクトです。
これは Lisp の美しさの一つだと思います。
他の言語の変数が何か特殊でいびつなもののように思えます。
I love Common Lisp.

FON La Fonera

ずっと FON の La Fonera が安定稼動してくれませんでした。ブチブチ接続が切れてしまうのです。

調べてみました。
FoN まとめ Wikiに
「La Foneraでインターネット接続は出来るのですが、2～3分おきに再起動が必要になります」
「10MBイーサネット、半二重設定で使用されている場合に発生する」
とあるのを見ました。これが原因でしょうか？

さっそく、Amazon で PLANEX 5ポート10M/100Mスタンディングスイッチングハブ FX-05ST を購入し、それ経由で La Fonera を繋いでみることにしました。
これで La Fonera は100M接続になるので改善するはずです。

安定稼動しました。
うん、よかった。

[Common Lisp] マクロを定義するマクロ（Anaphora より）

Anaphora はアナホォリックマクロを集めたライブラリです。
その中でマクロを定義するマクロが使われています。
if や and ごとに直接アナフォリックマクロを定義するのではなく、アナフォリックマクロを定義するマクロ anaphoric を定義した上で、それを利用して if や and のアナフォリックマクロ（aif, aand, etc.）を定義しています。
Lisp ならではの素敵なコードです。

On Lisp でもアナフォリックマクロとマクロを定義するマクロが解説されています。

Anaphora の anaphora.lisp より抜粋です。

(defmacro anaphoric (op test &body body)
  `(let ((it ,test))
     (,op it ,@body)))

(defmacro aif (test then &optional else)
  `(anaphoric if ,test ,then ,else))

(defmacro aand (first &rest rest)
  `(anaphoric and ,first ,@rest))

(aif (car '("Hello" "World"))
     (format nil "~a World!" it))
;; ==> "Hello World!"

(aand (cdr '(1 2 3)) (cdr it) (cdr it))
;; ==> 3

[Common Lisp][UCW][Elephant] UCW で作った TODO リストアプリケーションに永続化機能を追加する

以前 CUW で作成した TODO リストアプリケーション は todo オブジェクトをメモリ上に持っているだけでした。
今回は Elephant を使って todo オブジェクトを永続化してみます。
Elephant は Common Lisp のオブジェクトデータベースです。
バックエンドとして Berkeley DB、CL-SQL 経由の PostgreSQL or SQLite3 が使用可能です。Postmodern も使えるようになっているかもしれません。

elephant:open-store でデータストアをオープンします。
バックエンドで Berkeley DB を使う場合は、あらかじめディレクトリを作成しておく必要があります（ensure-directories-exist を使えばいいと思います）。

永続化するクラスは elephant:defpclass で作成します。
クラスオプションの :index に t を指定するとインスタンスは自動的に永続化されます。

elephant:defpclass で作成したクラスはユニークな識別子となる oid スロットを持ちます。

永続化したクラスの全インスタンスを取得するには elephant:get-instances-by-class を使います。

データストアからインスタンスを削除するには elephant:drop-instances を使います。

以下、ソースです。メモリ上にリストで保持していたときよりも少しシンプルになりました。

;; ucw がロードされていなければロードする。
(eval-when (:load-toplevel :compile-toplevel :execute)
  (require :elephant)                   ; Elephant
  (unless (find-package :ucw)
    ;; UCW の start.lisp をロードする。パスは環境にあわせて修正してください。
    (load (merge-pathnames "letter/lisp/ucw/ucw-boxset/start.lisp"
                           (user-homedir-pathname)))))

(in-package :it.bese.ucw-user)

;; Elephant のストアをオープンする。バックエンドは Berkeley DB を使います。
(elephant:open-store `(:BDB ,(ensure-directories-exist #p"/tmp/todo/")))

(defvar *todo-list-application*
  (make-instance 'cookie-session-application
                 :url-prefix "/todo/"   ; / で終ること
                 :charset :utf-8        ; 文字コードを UTF-8 に設定
                 :debug-on-error t)     ; エラー時にはデバッガを起動
  "アプリケーションの作成。")

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

;; エントリポイントの作成。http://localhost:8080/todo/index.ucw
(defentry-point "index.ucw" (:application *todo-list-application*)
    ()
  (call 'top-window))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; モデル
(elephant:defpclass todo ()
  ((content :initarg :content :accessor content)
   (done :initform nil :accessor done))
  (:index t)                            ; 自動的に永続化されます。
  (:documentation "TODO クラス"))

(defmethod print-object ((todo todo) stream)
  "debug のために"
  (print-unreadable-object (todo stream :type t :identity t)
    (format stream "~a: ~a" (elephant::oid todo) (content todo))))

(defun delete-todo (todo)
  "TODO を削除します。"
  (elephant:drop-instances (list todo)))

(defun get-all-todo ()
  (elephant:get-instances-by-class 'todo))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ビュー
(defcomponent top-window (simple-window-component)
  ((body :initarg :body
                  :accessor body
                  :component todo-list-view))
  (:default-initargs :title "TODO リスト")
  (:documentation "トップウィンドウ。
body に一覧や編集のコンポーネントをセットして画面表示を行う。"))

(defmethod render ((top top-window))
  (<:h1 "TODO リスト")
  ;; body の表示
  (render (body top)))

(defcomponent todo-list-view ()
  ()
  (:documentation "TODO の一覧コンポーネント"))

(defmethod render ((self todo-list-view))
  "TODO の一覧を表示する。"
  (<ucw:a :action (call 'todo-create-view) "新規作成")
  (<:table
   :border 1
   (<:tr (<:th "完了") (<:th "TODO") (<:th "削除"))
   (loop for each in (get-all-todo)
      do (let* ((todo each))
           (<:tr
            (<:td (<:as-html
                   (if (done todo)
                       "済"
                       (<ucw:a
                        :action (done-todo-action self todo)
                        "完了する"))))
            (<:td (<:as-html (content todo)))
            (<:td (<ucw:a :action (delete-todo-action self todo)
                          "削除する")))))))

(defaction done-todo-action ((self todo-list-view) todo)
  "TODO を完了する。"
  (setf (done todo) t))

(defaction delete-todo-action ((self todo-list-view) id)
  "TODO を1件削除する。"
  (delete-todo id))

(defcomponent todo-create-view ()
  ((content
    :accessor content
    :initform (make-instance 'string-field)))
  (:documentation "TODO を新規作成するためのコンポーネント"))

(defmethod render ((self todo-create-view))
  "TODO 新規作成画面"
  (<ucw:form
   :action (create-todo self)
   "TODO" (render (content self))
   (<:submit :value "新規作成"))
  (<ucw:a :action (ok self) "キャンセル"))

(defaction create-todo ((self todo-create-view))
  "画面からの入力により TODO を新規作成する。"
  (make-instance 'todo :content (value (content self)))
  (ok self))

CLIM(McCLIM) で Hello World! まで

McCLIM とは CLIM(Common Lisp Interface Manager) のオープンソースの実装です。
CLIM はユーザインターフェイスを構築するためのポータブルの機能階層提供する Lisp をベースとしたプログラミングインターフェースです。
具体的にはウィンドウ、グラフィック、ストリーム指向の入出力などの機能を提供します。

では、Hello World! です。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :clx)
  (require :mcclim))

(in-package :clim-user)

(define-application-frame hello-frame ()
  ()
  (:pane (make-pane 'application-pane :display-function #'display-hello ))
  (:geometry :width 400 :height 200))

(defmethod display-hello ((hello-frame hello-frame) stream)
  (format stream "Hello World!"))

(run-frame-top-level (make-application-frame 'hello-frame))

define-application-frame でトップレベルのウィンドウを定義します。
ウィンドウ内の部品はペイン（pane）と呼ばれ、application-pane を作り、表示関数に format を使って "Hello World!" を表示するメソッドを指定しています。
CLIM では入出力がストリームベースとなっているため、format のような普通の入出力関数をこのようなところで使うことができるようです。

次のようにしてデモを起動することができます。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :clx)
  (require :mcclim)
  (require :clim-examples))
(clim-demo::demodemo)