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

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

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

今回はProxyパターンです。

内部的に処理が違うものをプロキシを立てることによってユーザは意識せずに使えるようにするパターンの様です。

毎度例がfibばかりなのですが、Nが30より大きくなると高速版に切り換えるようなものを作成してみました。

例のための例という感じですが…。

とりあえず、今回で色々悩みつつ実習してきた「CLとデザインパターン」今回でGoFの23パターンを制覇できました。

感想としては、Norvig氏のDesign Patterns in Dynamic Programmingでも述べられていますが、生成に関しては、ファースト・クラスの型(クラス)、振舞いに関しては、ファースト・クラスの関数がある場合、実行したいことが分かっているならクラスの構成を色々工夫しなくてもストレートに表現できるかなと思いました。

また、ウェブで参照できる入門的なテキストは殆どJavaやC++なのでこれらの例を翻訳して考えるのに割と苦戦しました。

上記のNorvig氏のプレゼンでは、動的言語ならではのパターンというものが提案されているので、今後はこれをさらって行こうかと思います。

(defclass subject () ())

(defclass proxy (subject) ())
(defclass real-subject (subject) ())

(defgeneric fib (class n))
;; Proxy(基本的に低速 N > 30 で高速版に処理を投げる)
(defmethod fib ((class proxy) n)
  (let ((class 
         (if (< 30 n)
             (change-class class 'real-subject)
             class)))
    (if (< n 2)
        n
        (+ (fib class (1- n))
           (fib class (- n 2))))))
;; 高速版
(defmethod fib ((class real-subject) n)
  (labels ((*fib (n a1 a2)
             (if (< n 2)
                 a1
                 (*fib (1- n) 
                       (+ a1 a2)
                       a1))))
    (*fib n 1 0)))

;; 試してみる
(time (fib (make-instance 'proxy)
     100))
;   Evaluation took:
;     0.002 seconds of real time
;     0.000000 seconds of total run time (0.000000 user, 0.000000 system)
;     0.00% CPU
;     6 forms interpreted
;     3,022,236 processor cycles
;     31,856 bytes consed
;=> 354224848179261915075

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

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

今回はFlyweightパターンです。

Mementoと似た感じで違いが良く分からないのですが、インスタンスの生成に使うのがポイントなんでしょうか。

ということで、普通のフィボナッチ関数に無理矢理メモワイズ機能をつけてみました。

下記のfibクラスはフィボナッチ関数の結果を格納するだけの為に存在していて、要求の分だけインスタンスが作られますが、既に結果を含むインスタンスがあった場合は、それが使い回されます。

fibmeのaroundメソッドがFactoryな感じで考えています。

(defclass memento () 
  ((mementoes :initform (make-hash-table :test #'equal) 
              :accessor mementoes)))

(defclass fib () 
  ((ans :initarg :ans :accessor ans)))

(defgeneric fibme (memento n))
(defmethod fibme ((m memento) n)
  (if (< n 2)
      n
      (+ (fibme m (1- n))
         (fibme m (- n 2)))))

(defmethod fibme :around ((m memento) n)
  (symbol-macrolet ((mem (gethash n (mementoes m))))
    (if mem
        (ans mem)
        (let ((ans (call-next-method)))
          (setf mem (make-instance 'fib :ans ans))
          ans))))

(let ((m (make-instance 'memento)))
  (fibme m 100))
;=> 354224848179261915075

2008-12-21

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

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

今回はMementoパターンです。関数型言語でお馴染のMemorizeのように結果を記録して、それを再利用しようというパターンのようです。

とりあえず書いてみましたが、普通のMemorizeみたいになってしまいました…。

CLだと色々なものがファースト・クラスなのでハッシュに安直に登録してしまうというのが多いかもしれません。

Mementoの問い合わせについては、こじつけな感じですが:aroundメソッドを使ってみました。>

;; memento
(defclass memento () 
  ((mementoes :initform (make-hash-table :test #'equal) 
              :accessor mementoes)))

;; スナップショットを保持したりする
(defclass originator () 
  ((mem :initform (make-instance 'memento))))

(defgeneric get-memento (originator key))
(defmethod get-memento ((o originator) key)
  (gethash key (mementoes (slot-value o 'mem))))

(defgeneric set-memento (originator key val))
(defmethod set-memento ((o originator) key val)
  (setf (gethash key (mementoes (slot-value o 'mem)))
        val))


;;; 試してみる

;; とりあえず普通に定義(originatorを第1引数に)
(defmethod fibm ((o originator) n)
  (if (< n 2)
      n
      (+ (fibm o (1- n))
         (fibm o (- n 2)))))

;; mementoを確認して結果があれば、それを返し
;; 無ければ call-next-method
(defmethod fibm :around ((o originator) n)
  (or (get-memento o n)
      (print (set-memento o n (call-next-method)))))

;; 実行
(let ((o (make-instance 'originator)))
  (fibm o 30))
;>>>
1 
0 
1 
2 
3 
5 
8 
13 
21 
34 
55 
89 
144 
233 
377 
610 
987 
1597 
2584 
4181 
6765 
10946 
17711 
28657 
46368 
75025 
121393 
196418 
317811 
514229 
832040
;=> 832040

2008-12-20

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

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

今回はMediatorパターンです。

中央管制塔のように全体を統轄するMediatorを作成して部品(Colleague)間を管理することにより協調をとるパターンのようです。

Norvig氏のDesign Patterns in Dynamic Programmingでは、メソッドコンビネーションで実現できるようなことが書いてありました。Observerだと通知を:afterメソッドで実現してみましたが、確かに通知には使えるかもしれません。

毎回大体概念は分かるのですが、具体的に動く例を考えるのが難儀です。デザインパターンのドリルとかあると良いのですが…。

コードの解説ですが、colleagueクラスを継承したc1〜3を作成し、それぞれのメソッドは、0-9、0-5、0-3の範囲でそれぞれ乱数を返します。

Mediatorは、 Colleague のリストを持っており、各々の colleagueの返す乱数の結果が10を越えなければ、もう一度実行します。

なんとも無理矢理ですが、双方向通信ということでこんな風にしてみました。

(defclass colleague () ())
(defclass c1 (colleague) ())
(defclass c2 (colleague) ())
(defclass c3 (colleague) ())

(defclass mediator () 
  ((colleagues :initform () :initarg :colleagues :accessor colleagues)))

(defgeneric rand (class))
(defmethod rand ((c c1))
  (random 10))
(defmethod rand ((c c2))
  (random 5))
(defmethod rand ((c c3))
  (random 3))

(defgeneric mediator (class))
(defmethod mediator ((class mediator))
  (mapcar (lambda (c)
            ;; 合計が10を越えるまで繰り返し
            (loop :for x := (rand c) 
                  :until (> sum 10) 
                  :sum x :into sum
                  :collect x))
          (colleagues class)))


(rand (make-instance 'c3))
(let ((m (make-instance 'mediator 
                        :colleagues (list (make-instance 'c1)
                                          (make-instance 'c2)
                                          (make-instance 'c3)))))
  (mediator m))
;=> ((9 9) (2 2 3 3 1) (2 2 0 1 2 2 2))

2008-12-19

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

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

今回は、Facadeパターンです。

代表するクラスを作成して処理を集約しようというパターンのようです。

しかし、それだけだと何にでも当てはまってしまいそうなのですが、どうもそういうパターンのようです。

CLの場合、クラスを使わなくても関数で纏めたり、マクロで纏めたり色々できるかもしれません。

(defclass a1 () ())
(defclass a2 () ())
(defclass a3 () ())

(defgeneric do-someting1 (c))
(defgeneric do-someting2 (c))
(defgeneric do-someting3 (c))

(defmethod do-someting1 ((c a1))
  (print "a1"))
(defmethod do-someting2 ((c a2))
  (print "a2"))
(defmethod do-someting3 ((c a3))
  (print "a3"))

(defclass facade () ())

(defgeneric do-someting (c))
(defmethod do-someting ((c facade))
  (let ((a1 (make-instance 'a1))
        (a2 (make-instance 'a2))
        (a3 (make-instance 'a3)))
    (do-someting1 a1)
    (do-someting2 a2)
    (do-someting3 a3)))

;; 試してみる
(do-someting (make-instance 'facade))

;-> "a1" 
;   "a2" 
;   "a3" 
;=> "a3"

2008-12-18

CLとデザインパターン - Chain of Responsibility

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

今回はChain of Responsibilityパターンです。

メソッドが処理可能かを調べて順繰りに処理可能なメソッドを探して起動というパターンのようです。

説明を読んだ限りでは、メソッドコンビネーションのorが使えるような気がしたので、それで書いてみました。

メソッドコンビネーションのorは、特定度の高いところから結果が非nilになるまでメソッドを探して実行するもので、まさにピッタリという気がしたのですが、Norvig氏のDesign Patterns in Dynamic Programmingでも、Greg Sullivan氏のGOF Design Patterns in a Dynamic OO Languageでもメソッドコンビネーションに触れられてはいませんでした。自分は何か勘違いしているのかも…。

(defclass level-1 () ())
(defclass level-2 (level-1) ())
(defclass level-3 (level-2) ())

(defgeneric action-1 (class)
  (:method-combination or))
(defmethod action-1 or ((class level-1))
  (print "level-1!"))

(defgeneric action-2 (class)
  (:method-combination or))
(defmethod action-2 or ((class level-3))
  (print "level-3!"))

(defgeneric action-3 (class)
  (:method-combination or))
(defmethod action-3 or ((class level-2))
  (print "level-2!"))
(defmethod action-3 or ((class level-1))
  (print "level-1!"))

(let ((inst (make-instance 'level-3)))
  (action-1 inst)
  (action-2 inst)
  (action-3 inst))
;-> "level-1!" 
;   "level-3!" 
;   "level-2!" 

メソッドコンビネーションを使うからには、クラスの優先順位で状態が移行して行くわけで、クラスの優先順位は関係なく起動したいという場合を考えて、優先順位を付けるためだけに別にクラスを定義して対応するというのも考えてみました。これには多重継承の仕組みを利用していて、基本設定では、左に記述されているものが優先されることを利用して優先度を記述します。

(defclass foo () ())
(defclass bar () ())
(defclass baz () ())

(defclass handler (foo bar baz) ())

(defgeneric foo (class)
  (:method-combination or))
(defmethod foo or ((class foo))
  (print "foo"))

(defgeneric baz (class)
  (:method-combination or))
(defmethod baz or ((class baz))
  (print "baz"))

(defgeneric bar (class)
  (:method-combination or))
(defmethod bar or ((class bar))
  (print "bar"))
(defmethod bar or ((class baz))
  ;; bar クラスの定義があると実行されない
  (print "baz"))

;;; 実行例
(let ((inst (make-instance 'handler)))
  (foo inst)
  (bar inst)
  (baz inst))
;-> "foo" 
;   "bar" 
;   "baz" 

;; 優先順位を変更したものを作成
(defclass handler2 (baz foo bar) ())

(let ((inst (make-instance 'handler2)))
  (foo inst)
  (bar inst)
  (baz inst))
;-> "foo" 
;   "baz" 
;   "baz" ;handlerのケースとは逆転した

2008-12-17

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

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

今回はVisitorです。

Norvig氏のDesign Patterns in Dynamic Programmingでは、ファーストクラスの関数で対処可能。Greg Sullivan氏のGOF Design Patterns in a Dynamic OO Languageによれば、多重ディスパッチで解決できるとのこと。自分の感じだと、どちらかというとVisitorという名前からしてファースト・クラスの関数を引数に与えて内部で実行という方がしっくり来ます。

とりあえず、普通のものと、多重ディスパッチのものと2つ書いてみました。

;; aceptor
(defclass fruit-shop () 
  ((fruit :initform '("リンゴ" "ミカン" "バナナ") :reader fruit)))

(defclass fruit-shop2 (fruit-shop) 
  ((fruit :initform '("いちご" "キウイ" "メロン") :reader fruit)))

;; visitor
(defclass salesman () 
  ((fruit-shop :accessor fruit-shop)))

(defgeneric bargain-sale (salesman)
  (:method ((salesman salesman))
    (format T "~{~Aが安いよ!~%~}" (fruit (fruit-shop salesman)))))

(defgeneric ask-visitor (fruit-shop salesman))

;; single dispatch
(defmethod ask-visitor ((fruit-shop fruit-shop) salesman)
  (setf (fruit-shop salesman) fruit-shop)
  (bargain-sale salesman))

(defclass salesman2 (salesman) ())

(defmethod bargain-sale ((salesman salesman2))
  (format T "~{~Aがとんでもなく安いよ!~%~}" (fruit (fruit-shop salesman))))

;;; 実行してみる
(let ((fs (make-instance 'fruit-shop))
      (v (make-instance 'salesman)))
  (ask-visitor fs v))
;-> リンゴが安いよ!
;   ミカンが安いよ!
;   バナナが安いよ!
;=> NIL

(let ((fs (make-instance 'fruit-shop))
      (v (make-instance 'salesman2)))
  (ask-visitor fs v))

;-> リンゴがとんでもなく安いよ!
;   ミカンがとんでもなく安いよ!
;   バナナがとんでもなく安いよ!
;=> NIL

(let ((fs (make-instance 'fruit-shop2))
      (v (make-instance 'salesman2)))
  (ask-visitor fs v))
;-> いちごがとんでもなく安いよ!
;   キウイがとんでもなく安いよ!
;   メロンがとんでもなく安いよ!
;=> NIL

;; ==========================
;; 多重ディスパッチ版
(defclass fruit-shop () 
  ((fruit :initform '("リンゴ" "ミカン" "バナナ") :reader fruit)))

(defclass fruit-shop2 (fruit-shop) 
  ((fruit :initform '("いちご" "キウイ" "メロン") :reader fruit)))

(defclass salesman-md () ())
(defclass salesman-md2 (salesman-md) ())

(defgeneric bargain-sale-md (salesman-md fruit-shop))
(defmethod bargain-sale-md ((s salesman-md) (fs fruit-shop))
  (format T "~{~Aが安いよ!~%~}" (fruit fs)))
(defmethod bargain-sale-md ((s salesman-md2) (fs fruit-shop))
  (format T "~{~Aがとんでもなく安いよ!~%~}" (fruit fs)))
(defmethod bargain-sale-md ((s salesman-md) (fs fruit-shop2))
  (format T "~{~Aが新鮮だよ!~%~}" (fruit fs)))
(defmethod bargain-sale-md ((s salesman-md2) (fs fruit-shop2))
  (format T "~{~Aがとんでもなく新鮮だよ!~%~}" (fruit fs)))

(let ((fs (make-instance 'fruit-shop))
      (s (make-instance 'salesman-md)))
  (bargain-sale-md s fs))
;-> リンゴが安いよ!
;   ミカンが安いよ!
;   バナナが安いよ!
;=> NIL

(let ((fs (make-instance 'fruit-shop2))
      (s (make-instance 'salesman-md2)))
  (bargain-sale-md s fs))
;-> いちごがとんでもなく新鮮だよ!
;   キウイがとんでもなく新鮮だよ!
;   メロンがとんでもなく新鮮だよ!
;=> NIL

2008-12-16

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

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

今回はDecoratorパターンです。

無闇に継承で派生クラスを作成するのではなく派生機能拡張用のDecoratorクラスを作成してより柔軟に対応しようということらしいです。

今回は12. Decorator パターン | TECHSCORE(テックスコア)のアイスクリームの例を真似てみました。

Greg Sullivan氏のGOF Design Patterns in a Dynamic OO Languageによれば、メソッドコンビネーション(around等)で解決できるようなことが書いてありましたが、そっちの方が難しい気がしたので、今回はとりあえず装飾したいクラスをDecoratorクラスのスロットに格納してそれのメソッドを呼び出すことにしました。

(defclass icecream () ())

(defgeneric name (class))
(defgeneric how-sweet (class))

;; 基本タイプ
(defclass vanilla-icecream (icecream) ())

(defmethod name ((self vanilla-icecream))
  "バニラアイスクリーム")

(defmethod how-sweet ((self vanilla-icecream))
  "バニラ味")

(defclass greentea-icecream (icecream) ())

(defmethod name ((self greentea-icecream))
  "抹茶アイスクリーム")

(defmethod how-sweet ((self greentea-icecream))
  "抹茶味")

;; トッピング (Decorator)
(defclass cashew-nuts-topping-icecream (icecream)
  ((icecream :initarg :icecream)))

(defmethod name ((self cashew-nuts-topping-icecream))
  (format nil "カシューナッツ~A" (name (slot-value self 'icecream))))

(defmethod how-sweet ((self cashew-nuts-topping-icecream))
  (how-sweet (slot-value self 'icecream)))

;;; 動作
(let ((x (make-instance 'cashew-nuts-topping-icecream :icecream (make-instance 'vanilla-icecream))))
  (list (name x)
        (how-sweet x)))
;=> ("カシューナッツバニラアイスクリーム" "バニラ味")

(let ((x (make-instance 'cashew-nuts-topping-icecream :icecream (make-instance 'greentea-icecream))))
  (list (name x)
        (how-sweet x)))
;=> ("カシューナッツ抹茶アイスクリーム" "抹茶味")

2008-12-15

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

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

今回は Composite パターンです。

入れ物と要素を同一のものとみなし、同様のインターフェースで再帰的に処理できるようなパターンとのことです。

再帰的な構造といえばLISPではリストが代表格かと思いますが、今回は容器(sequence/string除く)と要素(atom)の両方に対して適用できるメソッドを定義して、ちょっとした応用として sequence 全般(といってもlistとvectorですが)に適用できるflattenを作成してみました。

今回のコードでは、結果の型が一番最後に処理した型になってしまいますが、とりあえず良しとします。型の指定も工夫できると思います。

ということで、クラスはビルトインのものを利用しているのみで自前で定義していません。sequence より一般的なクラスを定義しても良いかと思います。

;;; sequence(容器)と要素(atom)の両方に対して適用できるメソッドを定義
(defgeneric empty? (obj))
(defgeneric concat (obj1 obj2))
(defgeneric container? (obj)
  (:method (obj) nil))
(defgeneric head (obj))
(defgeneric tail (obj))
(defgeneric construct (elt obj))

;;; flatten を作ってみる
(defgeneric generic-flatten (obj)
  (:method (obj)
    (cond ((empty? obj) obj)
          ((not (container? obj)) obj)
          ((container? (head obj))
           (concat (generic-flatten (head obj))
                   (generic-flatten (tail obj))))
          ('T (construct (head obj)
                         (generic-flatten (tail obj)))))))

;; sequence 全般
(defmethod empty? ((obj sequence))
  (zerop (length obj)))
(defmethod concat ((sequence1 sequence) (sequence2 sequence))
  (let ((type (class-of sequence1)))
    (concatenate type sequence1 sequence2)))
(defmethod container? ((obj sequence))
  (and (typep obj 'sequence) (not (stringp obj))))
(defmethod head ((obj sequence))
  (elt obj 0))
(defmethod tail ((obj sequence))
  (subseq obj 1))
(defmethod construct (elt (obj sequence))
  (let ((type (class-of obj)))
    (concatenate type 
                 (make-sequence type 1 :initial-element elt)
                 obj)))

;; list に特定化
(defmethod empty? ((obj list))
  (null obj))
(defmethod concat ((list1 list) (list2 list))
  (append list1 list2))
(defmethod container? ((obj list))
  (listp obj))
(defmethod head ((obj list))
  (car obj))
(defmethod tail ((obj list))
  (cdr obj))
(defmethod construct (elt (obj list))
  (cons elt obj))

;; vector にちょっと特定化
(defmethod head ((obj vector))
  (aref obj 0))

;;; 動作
(generic-flatten '(5 (6 7 8 9) 10))
;=> #(5 6 7 8 9 10)
(generic-flatten #(5 #(6 7 8 9) 10))
;=> (1 2 3 4)
(generic-flatten '(1 2 3 4))
;=> #(1 2 3 4 5 6 7 8 9 10)
(generic-flatten '(1 2 3 4 (5 #(6 7 8 9) 10)))
;=> (1 2 3 4 5 6 7 8 9 10)
(generic-flatten #(1 2 3 4 #(5 (6 7 8 9) 10)))
;=> (1 2 3 4 5 6 7 8 9 10)
(generic-flatten #(1 2 3 4 (5 "6 7 8 9" 10)))
;=> (1 2 3 4 5 "6 7 8 9" 10)

2008-12-12

ContextLとデザインパターン - Bridge

| 17:16 | ContextLとデザインパターン - Bridge - わだばLisperになる を含むブックマーク はてなブックマーク - ContextLとデザインパターン - Bridge - わだばLisperになる

昨日書いた私が考えるBridgeパターンの例では、機能追加側は一つの定義で良いものの追加された機能のクラスをいちいち継承してやる必要があり、いまいち釈然としなかったのですが、こういう場合は、ContextLが使えるんじゃないかということで、ContextLを使って書いてみました。

  1. 機能の追加は、クラスの継承関係で
  2. 実装の違いはレイヤの違い(継承関係)で

という風にしてみました。もちろん、レイヤとクラスを逆にしても構いません。

これなら、実装と機能追加の双方は独立に追加して行けます。

なんだか、AOPとかリフレクションみたいになってしまいましたが、委譲が良く分かっていない人が書くとBridgeパターンはこうなるのかもしれません。

眺めてみて思うのですが、MOP(ContextL)を使わないということになると、やはりマルチメソッドを使うことになるのかなと思います。

(require :contextl)

(defpackage :design-patterns
  (:use :cl :contextl))

(in-package :design-patterns)

;; time付き用のクラス
(defclass with-time () ())

;; ベース(空実装)
(define-layered-function fib (class n))

;; time付き(ベースを呼んで味付け)
(define-layered-method fib ((class with-time) n)
  (time (call-next-method)))

;; 末尾再帰レイヤ
(deflayer tail)

(define-layered-method fib :in tail (class n)
  (labels ((*fib (n a1 a2)
             (if (< n 2)
                 a1
                 (*fib (1- n) 
                       (+ a1 a2)
                       a1))))
    (*fib n 1 0)))

;; 普通の再帰レイヤ
(deflayer recur)

(define-layered-method fib :in recur (class n)
  (labels ((*fib (n)
             (if (< n 2)
                 n
                 (+ (*fib (1- n))
                    (*fib (- n 2))))))
    (*fib n)))

;;; 動作

;; 普通の再帰
(with-active-layers (recur)
  (let ((n 30))
    (format T "普通:~A~%" (fib 'T n))
    (format T "time付き:~A~%" (fib (make-instance 'with-time) n))))

;;>>>
;; 普通:832040
;; Evaluation took:
;;   0.074 seconds of real time
;;   0.072004 seconds of total run time (0.072004 user, 0.000000 system)
;;   97.30% CPU
;;   178,337,061 processor cycles
;;   114,608 bytes consed
;;  
;; time付き:832040

;; 末尾再帰
(with-active-layers (tail)
  (let ((n 30))
    (format T "普通:~A~%" (fib 'T n))
    (format T "time付き:~A~%" (fib (make-instance 'with-time) n))))
;;>>>
;; 普通:832040
;; Evaluation took:
;;   0.000 seconds of real time
;;   0.000000 seconds of total run time (0.000000 user, 0.000000 system)
;;   100.00% CPU
;;   3,447 processor cycles
;;   0 bytes consed
;;  
;; time付き:832040

2008-12-11

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

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

今回は、Bridgeパターンです。

機能と実装を分けるためのパターンとのことですが、CLOSのような総称関数ベースのOOPだとBridgeが解決しようとしている問題にどうアプローチするものなのかが良く分かりませんでした。

問題は何点か考えられて

  1. クラスにメソッドが属してないので、そもそも橋渡ししなくても外から使える。
  2. マルチメソッドなので引数に条件を指定すれば、色々な条件でディスパッチできる。つまり「機能」と「実装」それぞれでディスパッチできる。
  3. 総称関数ベースのOOPと委譲の関係がいまいち自分が理解できていない(総称関数ベースのOOPでは「委譲」という言葉自体あまり聞かない気がします)

等々なので今回はいつにも増してまるで間違ったことを書いてる可能性が高いのですが、とりあえず書いてみました。

実装側は、fib-implを作成して、それを継承したfib-tailと、fib-recurを作成し、それぞれにメソッドを付けています。

機能付加の側では、fib/timerクラスを作成し、メソッドは付加機能で囲った後にスーパークラスのメソッドを呼んでいます。

しかし、これだと、枝葉のクラスをそれぞれ継承しないといけないので面倒なです。

やはり引数を2つに増して多重ディスパッチが良いのでしょうか。良い解決策をご存知の方は是非教えて下さい!

(defclass fib-impl () ())
(defclass fib-tail (fib-impl) ())
(defclass fib-recur (fib-impl) ())

(defgeneric fib (class n))

(defmethod fib ((class fib-tail) n)
  (labels ((*fib (n a1 a2)
             (if (< n 2)
                 a1
                 (*fib (1- n) 
                       (+ a1 a2)
                       a1))))
    (*fib n 1 0)))

(defmethod fib ((class fib-recur) n)
  (labels ((*fib (n)
             (if (< n 2)
                 n
                 (+ (*fib (1- n))
                    (*fib (- n 2))))))
    (*fib n)))

(defclass fib/timer () ())
(defclass fib-recur/timer (fib/timer fib-recur) ())
(defclass fib-tail/timer (fib/timer fib-tail) ())

(defmethod fib ((class fib/timer) n)
  (time (call-next-method)))

;;; 実行

;; 普通
(fib (make-instance 'fib-tail)
     40)
;=> 102334155

;; 時間計測つき
(fib (make-instance 'fib-recur/timer)
     40)
;-> 
;Evaluation took:
;  11.768363 seconds of real time
;  11.755267 seconds of thread run time
;  11.815329 seconds of process run time
;  11.772736 seconds of user run time
;  0.004 seconds of system run time
;  0 page faults
;  0 bytes consed by this thread and
;  73,728 total bytes consed.
;=> 102334155

2008-12-08

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

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

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

お題としては、今回も8. AbstractFactory パターン | TECHSCORE(テックスコア)の鍋を作る例をCLで再現。

Norvig氏のDesign Patterns in Dynamic Programmingでは、Abstract Factoryはファーストクラスのクラスがあると容易に実現できるような事を書いていますが、確かにクラスをそのまま渡すことができれば簡単な気がします。

今回は、クラスをファーストクラス扱いしないお題をそのまま写したmainと、クラスを渡したmain2と、インスタンスの生成にフックを掛けてみたパターンを作成してみました。

Factory Methodの時にも思ったのですが、インスタンスの生成に関係するパターンは、ずばりmake-instanceに細工をする方がCLOS的なのかもしれません。

;; 鍋
(defclass hotpot ()
  ((pot :initform () :accessor hotpot.pot)
   (soup :initform () :accessor hotpot.soup)
   (protein :initform () :accessor hotpot.main)
   (vegetables :initform ()  :accessor hotpot.vegetables)
   (other-ingredients :initform () :accessor hotpot.other-ingredients)))

;; factory
(defclass factory () ())
(defgeneric get-soup (factory))
(defgeneric get-main (factory))
(defgeneric get-vegetables (factory))
(defgeneric get-other-ingredients (factory))

;; factoryそれぞれ
(progn
  ;; 水炊き
  (defclass mizutaki-factory (factory) ())
  (defmethod get-soup ((fact mizutaki-factory)) 
    "鳥ガラスープ")
  (defmethod get-main ((fact mizutaki-factory)) 
    "鶏肉")
  (defmethod get-vegetables ((fact mizutaki-factory)) 
    (list "白菜" "長ネギ" "春菊"))
  (defmethod get-other-ingredients ((fact mizutaki-factory))
    (list "その他")))

(progn
  ;; キムチ鍋
  (defclass kimuchi-factory (factory) ())
  (defmethod get-soup ((fact kimuchi-factory))
    "鳥ガラスープ")
  (defmethod get-main ((fact kimuchi-factory))
    "鶏肉")
  (defmethod get-vegetables ((fact kimuchi-factory))
    (list "白菜" "長ネギ"))
  (defmethod get-other-ingredients ((fact kimuchi-factory))
    (list "キムチ")))

(progn
  ;; すき焼き
  (defclass sukiyaki-factory (factory) ())
  (defmethod get-soup ((fact sukiyaki-factory))
    "昆布だし")
  (defmethod get-main ((fact sukiyaki-factory))
    "牛肉")
  (defmethod get-vegetables ((fact sukiyaki-factory))
    (list "白菜"))
  (defmethod get-other-ingredients ((fact sukiyaki-factory))
    (list  "豆腐" "しらたき")))

(defun create-factory (name)
  (case name
    (kimuchi (make-instance 'kimuchi-factory))
    (sukiyaki (make-instance 'sukiyaki-factory))
    (otherwise (make-instance 'mizutaki-factory))))

;; 鍋をつくるメイン
(defun main (arg)
  (let ((hotpot (make-instance 'hotpot))
        (factory (create-factory arg)))
    (with-accessors ((soup hotpot.soup)
                     (main hotpot.main)
                     (vegetables hotpot.vegetables)
                     (other-ingredients hotpot.other-ingredients)) hotpot
      (setf soup (get-soup factory)
            main (get-main factory)
            vegetables (get-vegetables factory)
            other-ingredients (get-other-ingredients factory))
      hotpot)))

;; 実行
(describe (main 'nil))
;; Instance: #<HOTPOT {400723BA12}>
;; Class: #<STANDARD-CLASS HOTPOT {4002421AD2}>
;;  The following slots have :instance allocation:
;;   POT                 NIL
;;   SOUP                "鳥ガラスープ"
;;   PROTEIN             "鶏肉"
;;   VEGETABLES          ("白菜" "長ネギ" "春菊")
;;   OTHER-INGREDIENTS   ("その他")

(describe (main 'sukiyaki))
;; Instance: #<HOTPOT {4007332A12}>
;; Class: #<STANDARD-CLASS HOTPOT {4002421AD2}>
;;  The following slots have :instance allocation:
;;   POT                 NIL
;;   SOUP                "昆布だし"
;;   PROTEIN             "牛肉"
;;   VEGETABLES          ("白菜")
;;   OTHER-INGREDIENTS   ("豆腐" "しらたき")

クラスはファーストクラスなので、直に渡してみました版

(defun main2 (type)
  (let ((hotpot (make-instance 'hotpot))
        (factory (make-instance type)))
    (with-accessors ((soup hotpot.soup)
                     (main hotpot.main)
                     (vegetables hotpot.vegetables)
                     (other-ingredients hotpot.other-ingredients)) hotpot
      (setf soup (get-soup factory)
            main (get-main factory)
            vegetables (get-vegetables factory)
            other-ingredients (get-other-ingredients factory))
      hotpot)))

;; 実行
(describe (main2 'sukiyaki-factory))
;; Instance: #<HOTPOT {40077B7A12}>
;; Class: #<STANDARD-CLASS HOTPOT {4002421AD2}>
;;  The following slots have :instance allocation:
;;   POT                 NIL
;;   SOUP                "昆布だし"
;;   PROTEIN             "牛肉"
;;   VEGETABLES          ("白菜")
;;   OTHER-INGREDIENTS   ("豆腐" "しらたき")

インスタンスを作成するときにfactoryも指定できるのでは版

(defclass hotpot2 ()  ; hotpotと全く同じ
  ((pot :initform ()  :accessor hotpot.pot)
   (soup :initform () :accessor hotpot.soup)
   (protein :initform () :accessor hotpot.main)
   (vegetables :initform ()  :accessor hotpot.vegetables)
   (other-ingredients :initform () :accessor hotpot.other-ingredients)))

(defmethod initialize-instance :after ((inst hotpot2) &key factory)
  (with-slots (pot soup (main protein) vegetables other-ingredients) inst
    (let ((factory (make-instance factory)))
      (setf soup (get-soup factory)
            main (get-main factory)
            vegetables (get-vegetables factory)
            other-ingredients (get-other-ingredients factory)))
    inst))

(describe (make-instance 'hotpot2 :factory 'kimuchi-factory))
;; Instance: #<HOTPOT2 {4006F90CF2}>
;; Class: #<STANDARD-CLASS HOTPOT2 {4002EA3DB2}>
;;  The following slots have :instance allocation:
;;   POT                 NIL
;;   SOUP                "鳥ガラスープ"
;;   PROTEIN             "鶏肉"
;;   VEGETABLES          ("白菜" "長ネギ")
;;   OTHER-INGREDIENTS   ("キムチ")

2008-12-07

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

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

今回はBuilderパターンです。

自分はデザインパターンにはTemplate Methodが変化したものが多いような気がして来たのですが、今回のBuilderもそんな感じに思えました。

お題としては、7. Builder パターン | TECHSCORE(テックスコア)の食塩水を作成する例をCLで再現。

Norvig氏のDesign Patterns in Dynamic Programmingでは、Builderは、マルチメソッドがあれば、Directorか、Builderのどっちかは不要だろう、ということなのですが、確かにマルチメソッドだと引数それぞれでディスパッチでき、切り換えたい項目をそのまま引数の項目として表現できるので、Builerパターンを意識することもあまりないのかもしれません。

(defclass saltwater ()
  ((salt :initform 0 :initarg :salt :accessor saltwater.salt) 
   (water :initform 0 :initarg :water :accessor saltwater.water)))

(defclass builder () ())

(defgeneric add-solute (builer soulte-amount))
(defgeneric add-solvent (builder solvent-amount))
(defgeneric abandon-solution (builder solution-amount))
(defgeneric get-result (builder))

(defclass director () 
  ((builder :initarg :builder)))

(defgeneric construct (director)
  (:method ((dir director))
    (with-slots (builder) dir
      (add-solvent builder 100)         ;溶媒を100加える
      (add-solute builder 40)           ;溶質40を加える
      (abandon-solution builder 70)     ;70捨てる
      (add-solvent builder 100)         ;溶媒を100加える
      (add-solute builder 15))))        ;溶質を15加える

(defclass saltwater-builder (builder) 
  ((saltwater :initform (make-instance 'saltwater :water 0 :salt 0)
              :accessor saltwater)))

(defmethod add-solute ((builder saltwater-builder) (salt-amount number))
  (incf (saltwater.salt (saltwater builder)) salt-amount))

(defmethod add-solvent ((builder saltwater-builder) (water-amount number))
  (incf (saltwater.water (saltwater builder)) water-amount))

(defmethod abandon-solution ((builder saltwater-builder) (saltwater-amount number))
  (with-accessors ((w saltwater.water)
                   (s saltwater.salt)) (saltwater builder)
    (setq s (float (* s (- 1 (/ saltwater-amount (+ w s)))))
          w (float (* w (- 1 (/ saltwater-amount (+ w s))))))
    builder))

(defmethod get-result ((builder saltwater-builder))
  (saltwater builder))

(let* ((b (make-instance 'saltwater-builder))
       (dir (make-instance 'director :builder b)))
  (construct dir)
  (describe (get-result b)))
;-> #<SALTWATER {100B562B51}> is an instance of class #<STANDARD-CLASS SALTWATER>.
;   The following slots have :INSTANCE allocation:
;    SALT     35.0
;    WATER    141.66667

マルチメソッド版

(defclass saltwater ()
  ((salt :initform 0 :initarg :salt :accessor saltwater.salt) 
   (water :initform 0 :initarg :water :accessor saltwater.water)))

(defclass builder () ())

(defgeneric add-solute (builer soulte-amount))
(defgeneric add-solvent (builder solvent-amount))
(defgeneric abandon-solution (builder solution-amount))
(defgeneric get-result (builder))

(defclass job-flow () ())

(defgeneric construct-mm (job-flow builder))
(defmethod construct-mm ((jf job-flow) (builder saltwater-builder))
  (add-solvent builder 100)             ;溶媒を100加える
  (add-solute builder 40)               ;溶質40を加える
  (abandon-solution builder 70)         ;70捨てる
  (add-solvent builder 100)             ;溶媒を100加える
  (add-solute builder 15))              ;溶質を15加える

(defclass saltwater-builder (builder) 
  ((saltwater :initform (make-instance 'saltwater :water 0 :salt 0)
              :accessor saltwater)))

(defmethod add-solute ((builder saltwater-builder) (salt-amount number))
  (incf (saltwater.salt (saltwater builder)) salt-amount))

(defmethod add-solvent ((builder saltwater-builder) (water-amount number))
  (incf (saltwater.water (saltwater builder)) water-amount))

(defmethod abandon-solution ((builder saltwater-builder) (saltwater-amount number))
  (with-accessors ((w saltwater.water)
                   (s saltwater.salt)) (saltwater builder)
    (setq s (float (* s (- 1 (/ saltwater-amount (+ w s)))))
          w (float (* w (- 1 (/ saltwater-amount (+ w s))))))
    builder))

(defmethod get-result ((builder saltwater-builder))
  (saltwater builder))

;; 実行
(let* ((b (make-instance 'saltwater-builder))
       (jf (make-instance 'director)))
  (construct-mm jf b)
  (describe (get-result b)))
;-> #<SALTWATER {100B562B51}> is an instance of class #<STANDARD-CLASS SALTWATER>.
;   The following slots have :INSTANCE allocation:
;    SALT     35.0
;    WATER    141.66667

2008-12-05

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

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

今回はPrototypeパターンです。

インスタンスをコピーできるような仕組みを準備して便利に使おう、というパターンのようです。

Smalltalkでは、標準でコピーできるのだそうです。CLにもありそうでしたが、無いので自作しました。

新しいインスタンスを作ってスロットの内容をコピーするという素朴なものです。

総称関数ベースなのでどうもクラスがコピー関数を提供するというよりは、コピー可能属性をprototype-mixinで付与する位の感覚になっていますが、そもそも、prototype-mixinを作るまでもなく全部に総称関数を適用すればOKです。もしくは、普通の関数でコピーする機能を実装しても良いんじゃないかとも思うのですが、どうなのでしょう。

コピーには浅いコピーと深いコピーがあるようなのですが、slot-valueを使用すると浅いコピーになるようなので下記のコードも浅いコピーです。

この辺は、slot-value-deep-copyを作ってみたり、deep-copy-mixinクラスを作ってディスパッチしたりできそうですが、CLの場合、使う時に利用者の判断でコピーしたりする気もします。

(defclass prototype-mixin () ())

(defgeneric clone (inst))
(defmethod clone ((inst prototype-mixin))
  (let* ((class (class-of inst))
         (new (make-instance class)))
    (map nil (lambda (x) 
               (setf (slot-value new x)
                     (slot-value inst x)))
         (mapcar #'c2mop:slot-definition-name
                 (c2mop:class-slots class)))
    new))

(defclass foo (prototype-mixin)
  ((x :initarg :x)
   (y :initarg :y)
   (z :initarg :z)))

(defclass bar (foo)
  ((a :initform 0)))

(defclass baz (bar)
  ((b :initform 1)))

(let ((x (make-instance 'baz :x 10 :y 20 :z 30)))
  (map nil #'describe (list x (clone x))))

;=> #<BAZ 2008C12B> is a BAZ
;   B      1
;   A      0
;   X      10
;   Y      20
;   Z      30
;=> #<BAZ 2008BFB7> is a BAZ
;   B      1
;   A      0
;   X      10
;   Y      20
;   Z      30

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