[Common Lisp] loop collect でのクロージャ

loop を使ったものの結果が (B B) になるのはやはり仕様でしょうか？

(mapcar #'funcall
        (loop for i in '(a b)
           collect #'(lambda () i)))
;; => (B B)

(mapcar #'funcall
        (let (x)
          (dolist (i '(a b))
            (push  #'(lambda () i) x))
          x))
;; => (B A)

(mapcar #'funcall
        (mapcar #'(lambda (x)
                    #'(lambda () x))
                '(a b)))
;; => (A B)

[Common Lisp] Lisp チュートリアル

Common Lisp のチュートリアル。
lisp チュートリアル
lisp tutorial
Practical Common Lisp です。

アーロンチェアとミラチェアの比較

最初に座って一番感じたことは、太股にかかる圧力の差です。
アーロンチェアの方がミラチェアより太股にかかる圧力が大きい感じがします。
ミラチェアは割と普通の椅子と同じような感じですが、アーロンチェアの座面はお尻の部分が下ていて太股の部分がもり上っているような感じです。
もしくはミラチェアに比べてアーロンチェアは通常状態で少しリクライニングしているような感じです。
これについては、アーロンチェア歴の方が長いためか、アーロンチェアの方がしっくりきます。

アーロンチェアの背もたれはメッシュですが、ミラチェアの背もたれはプラスチックのようなソフトビニールのような素材です。
私が痩せすぎのせいかTシャツ一枚だとミラチェアの背もたれは少しごつごつするような感じです。
ミラチェアの背もたれはアーロンチェアのものより大きいです。
アーロンチェアで両手を上に上げて大きくリクライニングすると、背もたれの端っこに肩甲骨が当って違和感がありますが、ミラチェアではそんなときも背中全体をサポートしてくれます。

機能的なところではアーロンチェアよりもミラチェアの方が調整できる箇所が多く、かつ調整が容易になっています。
特に肘掛けの高さの調整はミラチェアの方が使い易いです。

次は、長時間座ってみた感じです。
私は肉が薄くて骨ばっている体型なので、木の椅子とかだとお尻が痛くて座っていられません。
アーロンチェアはミラチェアより座面が若干固めなため長時間座っているとお尻が痺れたような感じになるのですが、ミラチェアではそれがありませんでした。

さて思いつくままに書いてきましたが、どちらがいいかと問われれば、やはりアーロンチェアの方がいいなと思います。
単にアーロンチェア歴の方が長いからかもしれませんが、座ったときにしっくりくる感じがアーロンチェアは秀逸なのです。おぉ、これだって感じです。

鬱です

鬱です。
客観的にみれば原因はくだらないことなんだろうけど、鬱です。
ちょっとたちなおるのに時間がかかりそうな雰囲気です。
ごめんなさい。

[Common Lisp] らき☆すた の記念に

らき☆すた の記念に。

(let ((gf (symbol-function 'print-object)))
  (loop for method in (sb-mop:generic-function-methods gf)
     do (sb-mop:remove-method gf method)))

(defmethod print-object (x stream)
  (write-string "≡ω≡." stream))

(inspect (find-class 't))

≡ω≡.

らき☆すた
素晴しかった。
チョココロネからチアダンスまで最高に素晴しかった。
最終回をむかえとても寂しい。
卒業式みたいな気持だ。
らき☆すたは私にとって最高の作品です。
ありがとう、らき☆すた。

携帯変更

携帯を DoCoMo から SoftBank にかえました。
私はほとんど携帯を使わないのでホワイトプランみたいなのがちょうどいいです。
機種は 707SCII で S!ベーシックプランもつけずに980円携帯です。
ミラチェアの分、節約しないと。

[Common Lisp][MOP] サブクラスのリストを取得する

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

#+sbcl (use-package :sb-mop)

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

ミラチェア注文

ミラチェアを注文してしまいました。
色は Shadow frame/Cappuccino/Cappuccino です。
自宅ではアーロンチェアを使っているので、ミラチェアは仕事場用です。会社に持ち込みます。
これでもうしばらく何も買えません。ごめんなさい ＞ 家族

[Common Lisp][MOP] ダイレクトスロットを取得する

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

(use-package :sb-mop)

(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 のスロット

[Common Lisp][MOP] スロットのリストを取得する

class-slots によりスーパークラスのスロットを含めたスロット（standard-effective-slot-definition のインスタンス）のリストを取得できます。
SBCL ですが、何故かインスタンスを生成しないとスロットのリストが取得できませんでした。

(use-package :sb-mop)         ; MOP のパッケージを使えるようにしておく

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

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

(make-instance 'bar) ; インスタンスを作成しないとうまく class-slots が動かない
(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)

[Common Lisp][MOP] (制服セーラーふくだからです)結論 ラベル付きのスロットを作成してみる

compute-effective-slot-definition-initargs は AMOP にはないようです。OpenMCL にもありませんでした。なので、compute-effective-slot-definition-initargs はやめにして compute-effective-slot-definition を使うように戻します。
ごめんなさい。
direct-slot-definition と effective-slot-definition の件ですが、結局は次のようなことろです。
direct-slot-definition は defclass のスロット定義でスーパークラスのスロットは含まず、class-direct-slots で取得できる。
effective-slot-definition はスーパークラスのスロットを含めたそのクラスで使用できるスロットの定義で、compute-effective-slot-definition で作成され class-slots で取得できる。

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

(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))
#| OpenMCL では compute-effective-slot-definition-initargs は使われない。
AMOP にもない。
(defmethod compute-effective-slot-definition-initargs
    ((class labeled-slot-class) direct-slotds)
  "スロットの初期化引数を求めます。"
  (let ((std-initargs (call-next-method))
        (label nil)
        (labelp nil))
    (dolist (slotd direct-slotds)
      (when slotd
        (unless labelp
          (when (slot-definition-label slotd)
            (setf label (slot-definition-label slotd)
                  labelp t)))))
    (append std-initargs
            `(,@(if labelp `(:label ,label))))))
|#
  
(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)))

[Common Lisp][MOP] 再 ラベル付きのスロットを作成してみる

何か違う。もしくは何かたりない。

もう一度 MOP でラベル付きのスロット作成です。
compute-effective-slot-definition のかわりに compute-effective-slot-definition-initargsを再定義して defclass の :label がスロットに設定さるようにしました。
labeled-slot-mixin の label のアクセサも slot-definition-label に変更しました。

direct-slot-definition と effective-slot-definition の件ですが、direct は defclass でのスロット定義を保持し、effective は親クラスのスロットを含めてそのインスタンスが持っているスロットになるような気がします。
あれ？ direct はクラスで effective はインスタンス？
あとはラベルのアクセサが欲しいです。

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

(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-initargs
    ((class labeled-slot-class) direct-slotds)
  "スロットの初期化引数を求めます。"
  (let ((std-initargs (call-next-method))
        (label nil)
        (labelp nil))
    (dolist (slotd direct-slotds)
      (when slotd
        (unless labelp
          (when (slot-definition-label slotd)
            (setf label (slot-definition-label slotd)
                  labelp t)))))
    (append std-initargs
            `(,@(if labelp `(:label ,label))))))
    
(defun get-slot-definition (class slot-name)
  "スロットを取得します。class が labeled-slot-class を継承していれば
labeled-direct-slot-definition のインスタンスが返ってきます。"
  (loop for slot in (class-direct-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-slot-definition class slot-name)))
    (if (null slot-definition)
        (values (slot-missing class object slot-name 'slot-label))
        (slot-value slot-definition 'label))))

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

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

[Common Lisp][MOP] ラベル付きのスロットを作成してみる

CLOS のスロットは値を持ちます。
defclass の中で :documentation を指定することによりドキュメントを持つこともできます。
これを defclass の中で :label を指定して、スロットがラベルを持つように MOP で拡張してみようと思います。
ソースは次のとおり（処理系は SBCL です）。
standard-direct-slot-definition と standard-effective-slot-definition をまだよく理解していませんが、何とか動くようにできました。

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

(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 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)
                                              name
                                              dslotds)
  "call-next-method で通常のスロット定義を行った後、ラベルを設定します。"
  (let ((slot-definition (call-next-method)))
    (setf (label slot-definition) (label (car dslotds)))
    slot-definition))

(defun get-slot-definition (class slot-name)
  "スロットを取得します。class が labeled-slot-class を継承していれば
labeled-direct-slot-definition のインスタンスが返ってきます。"
  (loop for slot in (class-direct-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-slot-definition class slot-name)))
    (if (null slot-definition)
        (values (slot-missing class object slot-name 'slot-label))
        (slot-value slot-definition 'label))))

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

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

いや、ほんとうにらき☆すたはおもしろいです。

[Common Lisp][MOP] スーパークラスのリストを取得する

スーパークラスのリストを取得するには MOP の class-precedence-list を使用しますが、処理系により class-precedence-list のパッケージが異なります。
OpenMCL の場合は ccl パッケージです。

CL-USER> (defclass foo () ())
#<STANDARD-CLASS FOO>
CL-USER> (defclass bar (foo) ())
#<STANDARD-CLASS BAR>
CL-USER> (ccl:class-precedence-list (find-class 'bar))
(#<STANDARD-CLASS BAR> #<STANDARD-CLASS FOO> #<STANDARD-CLASS STANDARD-OBJECT> #<BUILT-IN-CLASS T>)
CL-USER> (ccl:class-precedence-list (find-class 'list))
(#<BUILT-IN-CLASS LIST> #<BUILT-IN-CLASS SEQUENCE> #<BUILT-IN-CLASS T>)

PC 発注

Dell™ Inspiron™ 1720 を発注しました。
だって、黄色なんだもん。
それはともかく(いや黄色が最も大切)ノートPCの液晶で 1920x1200 の解像度ってすごい。
ThinkPad は全然壊れなかったのにその後別の2台が連続して壊れたので、4年間の保証も付けました。
届いたらフォーマットして Debian をインストールしよっ♪