Common Lisp クエックブック

素敵な断片

数値のコンマ編集
標準出力を束縛する
アナフォリックマクロ

シンボル

プロパティ

文字列

文字列を数値に変換する
デフォルトの文字コード（external-format）を指定する
文字列のリストを連結する

数値

数値を16進数で表記
数値をn進数で表記
数値を文字列に変換する
数値をコンマ編集する

アレイ

拡張可能のベクタ

ファイル

ファイルの内容を出力する
パスの操作
ホームディレクトリを取得する

例外処理

エラーを無視する

loop

リストから2個ずつ処理する

ネットワーク

クライアントソケット
Web クライアント

パッケージ

パッケージのニックネームを変える

CLOS

メソッドを削除する
スーパークラスのリストを取得する
サブクラスのリストを取得する
スロットのリストを取得する
ダイレクトスロットを取得する
ラベル付きのスロットを作成してみる

コンパイラ

最適化

デバッグ

ステップ実行する

GUI

McCLIM
LTK

素敵な断片

Common Lisp の素敵な断片です。

数値のコンマ編集

(format nil "~:D" 1000000)
;; ==> "1,000,000"

標準出力を束縛する

(with-output-to-string (*standard-output*)
  (write-string "Hello ")
  (format t "~{~a~^, ~}" '(1 2 3)))
;; ==> "Hello 1, 2, 3"

アナフォリックマクロ

Anaphora より抜粋。マクロを定義するマクロ。it を予約語であるかのように使う。

(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 のシンボルはプロパティを持ちます。 get で取得 (setf get) で設定 symbol-plist で一覧です。 remf で削除も可能です。

CL-USER> (symbol-plist 'foo)
NIL
CL-USER> (get 'foo 'a)
NIL
CL-USER> (setf (get 'foo 'a) 'hello)
HELLO
CL-USER> (get 'foo 'a)
HELLO
CL-USER> (get 'foo 'aa 'ないよ)
ないよ
CL-USER> (setf (get 'foo 'aa) 'あるよ)
あるよ
CL-USER> (symbol-plist 'foo)
(AA あるよ A HELLO)
CL-USER> (remf (symbol-plist 'foo) 'a)
T
CL-USER> (symbol-plist 'foo)
(AA あるよ)

文字列

文字列を数値に変換する

CL-USER> (parse-integer "123")
123
3
CL-USER> (parse-integer "-10")
-10
3

デフォルトの文字コード（external-format）を指定する

;; ファイルIOの文字コード
(setf sb-impl::*default-external-format* :cp932)
;; 外部関数呼び出しの文字コード
(setf sb-alien::*default-c-string-external-format* :cp932)

文字列のリストを連結する

Common Lisp は最強の format 関数を備えています。それを使いましょう。

CL-USER> (format nil "~{~a~^, ~}" '("あいう" "Hello" "それでは"))
"あいう, Hello, それでは"
CL-USER> (format nil "~{~{~a~^, ~}~^; ~}" '(("こんにちは" "みなさん") ("Hello" "World")))
"こんにちは, みなさん; Hello, World"

数値

数値を16進数で表記

CL-USER> #16R10
16
CL-USER> #XA1
161

数値をn進数で表記

2進数から36進数まで表記可能です。

CL-USER> #2r101
5
CL-USER> #3R211
22
CL-USER> #36Rzz
1295

数値を文字列に変換する

CL-USER> (princ-to-string 123)
"123"
CL-USER> (princ-to-string 123)
"123"
CL-USER> (princ-to-string -123)
"-123"
CL-USER> (princ-to-string #16r10)
"16"
CL-USER> (princ-to-string #36R0z)
"35"

数値をコンマ編集する

(format nil "~:d" 1000000)      ; "1,000,000"

アレイ

拡張可能のベクタ

CL-USER> (defparameter a (make-array 0 :adjustable t :fill-pointer t))
A
CL-USER> a
#()
CL-USER> (vector-push-extend 'abc a)
0
CL-USER> a
#(ABC)
CL-USER> (vector-push-extend 'xyz a)
1
CL-USER> a
#(ABC XYZ)

ファイル

ファイルの内容を出力する

シリーズ、結構好きです。

;; Common Lisp 標準
(with-open-file (in "cookbook.html")
  (loop for l = (read-line in nil nil)
     while l
     do (write-line l)))

;; シリーズを使う
(require :series)
(series:collect-stream
 *standard-output*
 (series:scan-file "cookbook.html" #'read-line)
 #'write-line)

パスの操作

(make-pathname :defaults "/a/b/c.xxx" :type "yyy") ; #P"/a/b/c.yyy"
(make-pathname :defaults "/a/b/c.xxx" :name "kkk") ; #P"/a/b/kkk.xxx"
(make-pathname :defaults "/a/b/c.xxx" :directory "k/j") ; #P"/k/j/c.xxx"

ホームディレクトリを取得する

CL-USER> (user-homedir-pathname)
#P"/home/ancient/"
14
CL-USER> (merge-pathnames "bin/emacs" (user-homedir-pathname))
#P"/home/ancient/bin/emacs"

例外処理

エラーを無視する

通常、エラーが発生した場合デバッガが起動しますが、それを抑止するには ignore-errors を使用します。 ignore-errors はエラーが発生した場合、単に nil とエラー（コンディション）の多値を返します。

(ignore-errors (+ 3 1))
;; => 4
(ignore-errors (+ 3 'a))
;; => nil
;;    #<TYPE-ERROR {100337A741}>

loop

リストから2個ずつ処理する

loop for on by でリストから2個ずつ取り出して処理できます。 2個ずつなら cddr, 3個ずつなら cdddr, 4個ずつなら 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))

ネットワーク

クライアントソケット

最近のポータブルなソケットライブラリの定番は usocket のようです。クライアントソケットは with-client-socket マクロを使うと便利です。

(required :usocket)

(usocket:with-client-socket (socket stream "www.example.com" 80)
  (format stream "GET / HTTP/1.0~c~c~2:*~c~c" #\Cr #\Lf)
  (force-output stream)
  (loop for line = (read-line stream nil nil)
     while line
     do (write-line line)))

Web クライアント

Drakma がいいかと思います。

(drakma:http-request "http://www.yahoo.co.jp/")

使用上の注意です。

*drakma-default-external-format* で external-format を指定しておく。
text/* 以外の Content-Type をテキストとして扱いたいときは、 *text-content-types* に追加する。
Content-Length は省略すると文字数でカウントされるため、バイト数で明示的に指定する。
charset=Shift_JIS だとバイナリでしか取得できない。これは Drakma が使っている FLEXI-STREAMS がサポートしていないためです。

(use-package :drakma)

;; UTF-8
(setq *drakma-default-external-format* :utf-8)

;; application/atom+xml をバイナリではなくテキストとして扱う。
(pushnew (cons "application" "atom+xml") *text-content-types*
         :test #'equal)

;; Content-Length はバイトサイズで指定する。
(http-request "http://www.example.com/"
              :method :post
              :content post-data
              :content-length (length (sb-ext:string-to-octets
                                       post-data :external-format :utf-8)))

パッケージ

パッケージのニックネームを変える

rename-package を使います。

(defun set-package-nicknames (package &rest nicknames)
  (rename-package package (package-name package) nicknames))

(defpackage :foo
  (:nicknames :bar))

(values (package-name :foo) (package-nicknames :foo))
;;=> "FOO"
;;   ("BAR")

(set-package-nickname :foo :baz :baha)
;;=> #<PACKAGE "FOO">

(values (package-name :foo) (package-nicknames :foo))
;;=> "FOO"
;;   ("BAHA" "BAZ")

(set-package-nickname :foo)
;;=> #<PACKAGE "FOO">

(values (package-name :foo) (package-nicknames :foo))
;;=> "FOO"
;;   NIL

CLOS

MOP の関数等は各実装によりそのパッケージが異ります。 SBCL の場合は sb-mop パッケージです。以下では (use-package :sb-mop) を前提とします。 SBCL 以外の処理系ではそれぞれに応じたパッケージを use-package してください。

メソッドを削除する

メソッドを削除するには find-method でメソッドを検索し、remove-method でジェネリックファンクションから検索したメソッドを削除します。

(defclass a ()
  ())

(defmethod foo ((a a) arg)
  (declare (ignore arg))
  (format t  " foo primary.~%"))

(defmethod foo :before ((a a) arg)
  (declare (ignore arg))
  (format t "foo before."))

(foo (make-instance 'a) "arg")          ; foo before. foo primary.

(let* ((generic-function (symbol-function 'foo))
       (method (find-method generic-function
                            '(:before) (list (find-class 'a) t))))
  (remove-method generic-function method))

(foo (make-instance 'a) "arg")          ;  foo primary.

スーパークラスのリストを取得する

スーパークラスのリストを取得するには MOP の class-precedence-list を使用します。

finalize-inheritance をコールしておかないと class-precedence-list は動作しません。 make-instance でインスタンスを作成すると内部で finalize-inheritance がコールされます。

(defclass foo () ())

(defclass bar (foo) ())

(finalize-inheritance (find-class 'bar))

(class-precedence-list (find-class 'bar))
;;=> (#<STANDARD-CLASS BAR> #<STANDARD-CLASS FOO> #<STANDARD-CLASS STANDARD-OBJECT> #<SB-PCL::SLOT-CLASS SB-PCL::SLOT-OBJECT> #<BUILT-IN-CLASS T>)

(class-precedence-list (find-class 'list))
;;=> (#<BUILT-IN-CLASS LIST> #<BUILT-IN-CLASS SEQUENCE> #<BUILT-IN-CLASS T>)

サブクラスのリストを取得する

直接のサブクラスを取得するには class-direct-subclasses を使います。 class-direct-subclasses を再帰的に呼出すことにより全てのサブクラスを取得することができます。 COLS では全てのクラスは t を継承しているので、t のサブクラスを求めることによって、定義されている全クラスを取得することができます。 SBCL では655個、OpenMCL では520個のクラスが定義されていました。

(defclass foo ()
  ())

(defclass bar (foo)
  ())

(defclass baz (bar)
  ())

(class-direct-subclasses (find-class 'foo))
;; => (#<STANDARD-CLASS BAR>)

(labels ((subclasses (class)
           (cons class
                 (mapcan #'subclasses (class-direct-subclasses class)))))
  ;; cdr で自分自身を除きます。
  ;; foo のかわりに t を指定するば t を除く全クラスが返ってきます。
  (cdr (remove-duplicates (subclasses (find-class 'foo)))))
;; => (#<STANDARD-CLASS BAR> #<STANDARD-CLASS BAZ>)

スロットのリストを取得する

class-slots によりスーパークラスのスロットを含めたスロット（standard-effective-slot-definition のインスタンス）のリストを取得できます。 finalize-inheritance（もしくは make-instance）をコールしておかないと class-slots は動作しません。

(defclass foo ()
  ((foo-slot)))

(defclass bar (foo)
  ((bar-slot)))

(make-instance 'bar) ; インスタンスを作成することにより finalize-inheritance をコール
(class-slots (find-class 'bar))
;; => (#<STANDARD-EFFECTIVE-SLOT-DEFINITION FOO-SLOT>
;;     #<STANDARD-EFFECTIVE-SLOT-DEFINITION BAR-SLOT>)

;; スロット名のリストを取得する
(mapcar #'slot-definition-name (class-slots (find-class 'bar)))
;; => (FOO-SLOT BAR-SLOT)

ダイレクトスロットを取得する

class-slots でスーパークラスのスロットを含めたスロットを取得できますが、スーパークラスのスロットを含まずそのクラスで直に定義されたスロット（direct-slot）だけを取得するには class-direct-slots を使用します。なお、スロットはインスタンスではなくクラスにくっついているものなので、スロット単体からはスロットの値を取得することはできません。 slot-definition-name でスロットからスロット名を取得して slot-value で値を取得します。もちろん、スロット名が最初からわかっていれば (slot-value instance 'bar-slot) かアクセッサで (bar-slot instance) とすればよいです。

(defclass foo ()
  ((foo-slot :accessor foo-slot
             :initform "foo のスロット")))

(defclass bar (foo)
  ((bar-slot :accessor bar-slot
             :initform "bar のスロット")))

(let* ((instance (make-instance 'bar))
       (direct-slots (class-direct-slots (class-of instance))))
  (format t "direct-slots => ~a~%" direct-slots)
  (format t "スロットの値 => ~a~%"
          (slot-value instance (slot-definition-name (car direct-slots)))))
;; 出力結果
;; direct-slots => (#<STANDARD-DIRECT-SLOT-DEFINITION BAR-SLOT>)
;; スロットの値 => bar のスロット

ラベル付きのスロットを作成してみる

スロットは値を持ちます。スロットもオブジェクトです。ということで、値の他にラベルを持つスロットを作成してみます。スロットには direct-slot-definition と effective-slot-definition という2つの定義があります。 direct-slot-definition は defclass のスロット定義でスーパークラスのスロットは含まず、class-direct-slots で取得できます。 effective-slot-definition はスーパークラスのスロットを含めたそのクラスで使用できるスロットの定義で、compute-effective-slot-definition で作成され class-slots で取得できます。

ラベルを持つスロットのためのミクスイン（labeled-slot-mixin）を定義し、labeled-direct-slot-definition と labeled-effective-slot-definition を作成します。

compute-effective-slot-definition の中で defclass 時に :label で指定した値をスロットに設定します。

;;;; スロットは値を持ちますが、値の他にラベルも持つようなメタクラスを定
;;;; 義してみます。

(eval-when (:load-toplevel :compile-toplevel :execute)
  #+sbcl (use-package :sb-mop))

(defclass labeled-slot-class (standard-class)
  ()
  (:documentation "standard-class を継承してメタクラスを作ります。"))

(defmethod validate-superclass ((class labeled-slot-class)
                                (super standard-class))
  "standard-class が有効なスーパークラスです。"
  t)

(defclass labeled-slot-mixin ()
  ((label :accessor slot-definition-label
          :initarg :label
          :initform nil
          :documentation "スロットのラベルです。"))
  (:documentation "ラベルを持つスロットのためのミクスインです。"))

(defclass labeled-direct-slot-definition
    (labeled-slot-mixin standard-direct-slot-definition)
  ()
  (:documentation "labeled-slot-mixin を継承しラベルを持てるようにします。
このクラスは defclass によるスロット定義で使用されるクラスでしょうか。"))

(defclass labeled-effective-slot-definition
    (labeled-slot-mixin standard-effective-slot-definition)
  ()
  (:documentation "labeled-slot-mixin を継承しラベルを持てるようにします。
このクラスは定義済のクラスがスロットの情報を保持するためのクラスでしょうか。"))


(defmethod direct-slot-definition-class ((class labeled-slot-class)
                                         &rest initargs)
  "defclass で :label キーワードを使えるように
labeled-direct-slot-definition を返します。"
  (declare (ignore initargs))
  (find-class 'labeled-direct-slot-definition))

(defmethod effective-slot-definition-class ((class labeled-slot-class)
                                            &rest initargs)
  "スロットがラベルを保持できるように
labeled-effective-slot-definition を返します。"
  (declare (ignore initargs))
  (find-class 'labeled-effective-slot-definition))

(defmethod compute-effective-slot-definition
    ((class labeled-slot-class) slot-name direct-slot-definitions)
  (declare (ignore slot-name))
  (let ((effective-definition (call-next-method))
        (labelp nil))
    (dolist (definition direct-slot-definitions)
      (when definition
        (unless labelp
          (when (slot-definition-label definition)
            (setf (slot-definition-label effective-definition)
                  (slot-definition-label definition)
                  labelp t)))))
    effective-definition))

(defun get-effective-slot-definition (class slot-name)
  "effective slot definition を取得します。"
  (loop for slot in (class-slots class)
     if (eq slot-name (slot-definition-name slot))
     do (return slot)))

(defun slot-label (object slot-name)
  "スロットのラベルを取得します。"
  (let* ((class (class-of object))
         (slot-definition (get-effective-slot-definition class slot-name)))
    (if (null slot-definition)
        (values (slot-missing class object slot-name 'slot-label))
        (slot-definition-label slot-definition))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; こんな感じで、使います。
(defclass labeled ()
  ((slot1 :accessor slot1 :initform "スロット1の値"
          :label "スロット1のラベル")
   (slot2 :accessor slot2 :initform "スロット2の値"
          :label "スロット2のラベル"))
  (:metaclass labeled-slot-class))

(let ((x (make-instance 'labeled)))
  (format t "スロット1の値: ~a, ラベル: ~a~%スロット2の値: ~a, ラベル: ~a~%"
          (slot1 x) (slot-label x 'slot1)
          (slot2 x) (slot-label x 'slot2)))

コンパイラ

最適化

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

次のようにして現在の値を取得することができます（SBCL依存）。

(sb-ext:describe-compiler-policy)
;;->   Basic qualities:
;;   COMPILATION-SPEED = 1
;;   DEBUG = 3
;;   SAFETY = 3
;;   SPACE = 1
;;   SPEED = 1
;;   INHIBIT-WARNINGS = 1
;;     Dependent qualities:
;;   SB-C::CHECK-CONSTANT-MODIFICATION = 1 -> 3 (yes)
;;   SB-C::TYPE-CHECK = 1 -> 3 (full)
;;   SB-C::CHECK-TAG-EXISTENCE = 1 -> 3 (yes)
;;   SB-C::LET-CONVERSION = 1 -> 0 (off)
;;   SB-C:VERIFY-ARG-COUNT = 1 -> 3 (yes)
;;   SB-C::MERGE-TAIL-CALLS = 1 -> 0 (no)
;;   SB-C::INSERT-DEBUG-CATCH = 1 -> 3 (yes)
;;   SB-C::RECOGNIZE-SELF-CALLS = 1 -> 0 (no)
;;   SB-C::FLOAT-ACCURACY = 1 -> 3 (full)
;;   SB-C:INSERT-STEP-CONDITIONS = 1 -> 3 (full)
;;   SB-C::COMPUTE-DEBUG-FUN = 1 -> 3 (yes)
;;   SB-C::PRESERVE-SINGLE-USE-DEBUG-VARIABLES = 1 -> 3 (yes)
;;   SB-C::INSERT-ARRAY-BOUNDS-CHECKS = 1 -> 3 (yes)
;;   SB-C::STORE-XREF-DATA = 1 -> 3 (yes)
;;   SB-C:STORE-COVERAGE-DATA = 1 -> 0 (no)
;;
;;=>

(sb-cltl2:declaration-information 'optimize)
;;=> ((COMPILATION-SPEED 1) (DEBUG 3) (SAFETY 3) (SPACE 1) (SPEED 1)
;;    (INHIBIT-WARNINGS 1) (SB-C::CHECK-CONSTANT-MODIFICATION 1)
;;    (SB-C::TYPE-CHECK 1) (SB-C::CHECK-TAG-EXISTENCE 1) (SB-C::LET-CONVERSION 1)
;;    (SB-C:VERIFY-ARG-COUNT 1) (SB-C::MERGE-TAIL-CALLS 1)
;;    (SB-C::INSERT-DEBUG-CATCH 1) (SB-C::RECOGNIZE-SELF-CALLS 1)
;;    (SB-C::FLOAT-ACCURACY 1) (SB-C:INSERT-STEP-CONDITIONS 1)
;;    (SB-C::COMPUTE-DEBUG-FUN 1) (SB-C::PRESERVE-SINGLE-USE-DEBUG-VARIABLES 1)
;;    (SB-C::INSERT-ARRAY-BOUNDS-CHECKS 1) (SB-C::STORE-XREF-DATA 1)
;;    (SB-C:STORE-COVERAGE-DATA 1))

デバッグ

ステップ実行する

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

のようにします。

GUI

McCLIM

Common Lisp の GUI といえば Common Lisp Interface Manager(CLIM) です。 CLIM のオープンソースでの実装である McCLIM を使って Hello World してみます。 mcclim/Experimental/freetype/mcclim-freetype.asd を require すれば日本語表示も可能です。

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

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

日本語入力は mcclim-uim で。

LTK

LTK は Tk のバインディングです。日本語の入出力も普通にできます。

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