Hatena::Groupcadr

わだばLisperになる このページをアンテナに追加 RSSフィード

2004 | 12 |
2005 | 01 | 02 | 07 | 10 | 11 |
2006 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2007 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2008 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2009 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2010 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2011 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 11 |

2008-12-03

CLとデザインパターン - Factory Method

| 18:42 | CLとデザインパターン - Factory Method - わだばLisperになる を含むブックマーク はてなブックマーク - CLとデザインパターン - Factory Method - わだばLisperになる

今回はFactory Methodパターンです。

Template Methodに良く似たパターンというか、インスタンス生成をTemplate Method化したようなパターンです。

Template Method内でインスタンスの生成する場合に、インスタンスの種類を決め打ちにしたくない場合に使えたりするようです。

ということで動作は理解できたのですが、上手い表現が思い付かず、例のための例という感じになってしまいました。

  1. なんらかの種類の容器を作成して、
  2. なんらかの内容で埋めて、
  3. なんらかの方法で要素を表示

というテンプレを作って、テンプレに沿って2種類作ってみています。

上記の「なんらかの種類のシーケンスを作成して、」のところが、Factory Methodに当たる部分です。

(defclass template () ())

;; テンプレ
(defgeneric template (class)
  (:method ((class template))
    (let ((seq (make-container class)))
      (fill-container class seq)
      (print-elements class seq))))

(defgeneric make-container (class))
(defgeneric fill-container (class seq))
(defgeneric print-elements (class seq))

;; その1
(defclass concrete-1 (template) ())

(defmethod make-container ((type concrete-1))
  (make-list 10))

(defmethod fill-container ((class concrete-1) seq)
  (mapl (lambda (x) (setf (car x) (random 10)))
        seq)
  seq)

(defmethod print-elements ((class concrete-1) seq)
  (dolist (e seq)
    (princ e))
  (terpri))

;; その2
(defclass concrete-2 (template) ())

(defmethod make-container ((type concrete-2))
  (make-array 10))

(defmethod fill-container ((class concrete-2) seq)
  (map-into seq (lambda (x) (declare (ignore x)) (gensym))
            seq))

(defmethod print-elements ((class concrete-2) seq)
  (map nil #'princ seq)
  (terpri))

;; その1 実行例
(template (make-instance 'concrete-1))
;-> 1563867922
;=> nil

;; その2 実行例
(template (make-instance 'concrete-2))
;-> G2637G2638G2639G2640G2641G2642G2643G2644G2645G2646
;=> nil

2008-12-02

CLとデザインパターン - Singleton

| 15:35 | CLとデザインパターン - Singleton - わだばLisperになる を含むブックマーク はてなブックマーク - CLとデザインパターン - Singleton - わだばLisperになる

今回はSingletonパターンです。

一つのクラスにつきインスタンスを一つしか作らないことを保証するようなパターンとのこと。

GaucheのMOP周りを眺めていて、MOPでSingletonを実現している例があったので(gauche.mop.singleton) これを移植しつつ考えてみることにしました。

内容としては、 Singleton用のメタクラスを作成して、そのスロットに一つだけのインスタンスが保持されるようにする、というものでCLでもそのまま行けそうです。

しかし、大まかには真似できたんですが、Gaucheでは、毎回メタクラスの指定をしなくても良いようにmixin用のsingleton-mixinというクラスを提供しているのですが、これが再現できませんでした…。

どうやら ensure-class-using-class を定義すれば良さそうなのですが、どうもややこしいのでマクロで逃げました。

:metaclassの指定回避の定番の方法を知ってる方は是非教えて下さい!

(defclass singleton-meta (standard-class)
  ((%the-singleton-instance :initform () )))

(defmethod make-instance ((class singleton-meta) &key)
  (with-slots (%the-singleton-instance) class
    (if %the-singleton-instance
        %the-singleton-instance
        (let ((ins (call-next-method)))
          (setf %the-singleton-instance ins)
          ins))))

(defmethod c2mop:validate-superclass ((class singleton-meta)
                                      (super standard-class))
  'T)

(defmacro define-singleton-class (name supers &rest args)
  (and (assoc :metaclass args)
       (error "Metaclass already specified."))
  `(defclass ,name ,supers ,@args
     (:metaclass singleton-meta)))

(define-singleton-class quux-singleton () ())

;; 動作
(eq (make-instance 'quux-singleton)
    (make-instance 'quux-singleton))
;=> T

(defmethod instance-of ((class singleton-meta) &rest initargs)
  (apply #'make-instance class initargs))

(instance-of (find-class 'quux-singleton))

2008-11-16

MOPでFizzBuzz (2)

| 21:03 | MOPでFizzBuzz (2) - わだばLisperになる を含むブックマーク はてなブックマーク - MOPでFizzBuzz (2) - わだばLisperになる

コメントにてquekさんにカウンタのリセットの方法を教えてもらいました!

なるほど、なるほど、find-classして、それのスロットにアクセスすれば良いのですね。

ということで、その部分だけ修正。

(defun reset-fizzbuzz-counter ()
  (setf (slot-value (find-class 'foo) 'counter) 0))

(defmethod print-object ((obj foo) stream)
  (print-unreadable-object (obj stream)
    (format stream "~A ~A" (type-of obj)
            (slot-value (find-class 'foo) 'counter))))

MOPでFizzBuzz (1.5)

| 02:49 | MOPでFizzBuzz (1.5) - わだばLisperになる を含むブックマーク はてなブックマーク - MOPでFizzBuzz (1.5) - わだばLisperになる

非常にどうでも良いところなのですが、前回のmake-instanceでFizzBuzzでは、

  1. counterを外からリセットできない
  2. 数値が確認できない

という心残りがありました。

という訳で、色々策を考えてみたのですが、メタクラスのスロットをクラス変数にして、インスタンス間で共有し、それをいじることにしてみました。

それと数値の確認については、print-objectを設定。

また、MOPについては、ANSI CLで決まっていないだけに、処理系依存なところもあるのですが、これを吸収するようなパッケージがあるので利用してみました。

カウンタのリセットについては、もっと真っ当な方法がある気がしてならないのですが、なんにしろ真面目なプログラムではないので、ちゃんとした例が書けるようになりたいです(笑)

;; メタクラス
(defclass fizzbuzz-meta (standard-class)
  ((counter :initform 0 :allocation :class)))

;; 型を定義して型で振り分けてみる
(defun fizzp (n) (zerop (rem n 3)))
(deftype fizz () '(satisfies fizzp))
(defun buzzp (n) (zerop (rem n 5)))
(deftype buzz () '(satisfies buzzp))
(deftype fizzbuzz () '(and fizz buzz))

(defmethod make-instance :around ((metaclass fizzbuzz-meta) &key)
  (with-slots (counter) metaclass
    (incf counter)
    (typecase counter
      (fizzbuzz "Fizz Buzz")
      (fizz "Fizz")
      (buzz "Buzz")
      (otherwise (call-next-method)))))

(defmethod c2mop:validate-superclass ((class fizzbuzz-meta)
                                      (super standard-class))
  'T)

(defclass foo () ()
  (:metaclass fizzbuzz-meta))

(let ((cnt (make-instance 'fizzbuzz-meta)))
  (defmethod print-object ((obj foo) stream)
    (print-unreadable-object (obj stream)
      (format stream "~A ~A" (type-of obj)
              (slot-value cnt 'counter))))
  (defun reset-fizzbuzz-counter ()
    (setf (slot-value cnt 'counter) 0)))

;; 実行
(dotimes (i 100)
  (format T "~A~%" (make-instance 'foo)))

;; カウンタリセット
(reset-fizzbuzz-counter)

;>>>
#<FOO 1>
#<FOO 2>
Fizz
#<FOO 4>
Buzz
Fizz
#<FOO 7>
#<FOO 8>
Fizz
Buzz
#<FOO 11>
Fizz
#<FOO 13>
#<FOO 14>
Fizz Buzz
#<FOO 16>
#<FOO 17>
Fizz
#<FOO 19>
Buzz
Fizz
#<FOO 22>
#<FOO 23>
...

2008-11-13

MOPでFizzBuzz

| 23:17 | MOPでFizzBuzz - わだばLisperになる を含むブックマーク はてなブックマーク - MOPでFizzBuzz - わだばLisperになる

今日は、数理システムユーザーコンファレンス2008の一日目、MOP (Metaobject Protocol) in One Dayに参加してきました。

6時間に渡ってMOPを解説するという稀にみるに濃いセミナーでしたが、この濃いセミナーに40人もの人が集まっていました。凄い!

内容としては、丁寧に進められて行った感じなのでMOPに興味のある方には非常に有意義だったのではないかと思います。

また、量が多いので一度では無理ですが、自分の中で今回のセミナーの内容を纏めて随時エントリに書いて行こうかなとも思っています。

とりあえず、記念にMOPでFizzBuzzを書いてみました。

ちなみに、カウンタのリセットの方法が分かりません。

;; 補助定義
;; 型を定義して型で振り分けてみる(MOPに関係なし)
(defun fizzp (n) (zerop (rem n 3)))
(deftype fizz () '(satisfies fizzp))
(defun buzzp (n) (zerop (rem n 5)))
(deftype buzz () '(satisfies buzzp))
(deftype fizzbuzz () '(and fizz buzz))
;; メタクラスの作成
(defclass fizzbuzz-meta (standard-class)
  ((counter :initform 1)))

;; fizz buzzに応じてmake-instanceの挙動が変わるように定義
(defmethod make-instance :around ((metaclass fizzbuzz-meta) &key)
  (with-slots (counter) metaclass
    (prog1 (typecase counter
             (fizzbuzz "Fizz Buzz")
             (fizz "Fizz")
             (buzz "Buzz")
             (otherwise (call-next-method)))
      (incf counter))))

;; SBCLでは、validate-superclassの定義が必要
(defmethod sb-mop:validate-superclass ((class fizzbuzz-meta)
                                       (super standard-class))
  'T)

;; 通常のclassのようにfooを定義(ただしメタクラスは、fizzbuzz-meta)
(defclass foo () ()
  (:metaclass fizzbuzz-meta))
;; 実行/3と5の倍数以外でしか正常に機能しないmake-instanceが完成
(dotimes (i 100)
  (format T "~A~%" (make-instance 'foo)))

;>>>
#<FOO {100AA33881}>
#<FOO {100AA34471}>
Fizz
#<FOO {100AA35881}>
Buzz
Fizz
#<FOO {100AA37821}>
#<FOO {100AA38471}>
Fizz
Buzz
#<FOO {100AA3A361}>
Fizz
#<FOO {100AA3B821}>
#<FOO {100AA3C471}>
Fizz Buzz
#<FOO {100AA3D881}>
#<FOO {100AA3E471}>
Fizz
...