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

lisp2 vs lisp1

| 17:46 | lisp2 vs lisp1 - わだばLisperになる を含むブックマーク はてなブックマーク - lisp2 vs lisp1 - わだばLisperになる

Common Lispは、変数用のセルと関数用のセルが別々にあり、こういうのをlisp2と呼び、セルが分かれてないSchemeのようなタイプをlisp1と呼びますが、古いネットニュースを読んでいたら、lisp2のようにセルを分けるようになったのはいつ頃か、という一連のスレがありました。

このスレの中でlisp2の由来らしきことが書いてある議論が引用されているのですが、最初にセルを分けることにした方々も参加している議論なので面白いです。

興味深いところは、

  1. 変数用のセルと関数用のセルを分けた最初の実装は、BBN-LISP(INTERLISPの前進)で、1965年頃でなないか(ピーター・ドイチュ氏)
  2. BBN-LISPで変数用のセルと関数用のセルを分けたのは私。変数と関数では呼ばれ方の意味合いも変わってくるし(ダニエル・ボブロウ氏)
  3. (fun ...)は固定的、(funcall fun ...)はfunが環境によって変わってくる、ということを明示できるのがイイ。(ダニエル・ボブロウ氏)
  4. セルを分けたのは、大域変数が多用されるような当時の実用上では効率的で成功だったけれどセマンティクス的には誤った選択じゃなかろうか(ピーター・ドイチュ氏)

(以上、適当な意訳)

等々から徐々にlisp1 vs lisp2な話になってしまい収拾がつかなくなって終りますが、いづれにせよ、Lisp2の父は、ダニエル・ボブロウ氏だったかもしれないというのが興味深いです。

ちなみに、ボブロウ氏は、CLOSの策定での中心人物でもあります。

2008-12-30

+foo+ vs $foo

| 13:40 |  +foo+ vs $foo - わだばLisperになる を含むブックマーク はてなブックマーク -  +foo+ vs $foo - わだばLisperになる

Common Lispでは、defconstantで宣言したものには、+foo+のように変数名に+を付けるのが慣習とか言われています。

しかし、全くの個人的な趣味なのですが、自分は、+foo+は見た目が嫌いで$fooだったら良いのになとか良く思っていました。

$foo等で定数を表わすのは、Dylanでは標準なのですが、Schemeでもたまに見掛けますし、CLでもたまに見掛けます。

$fooは、どこが発祥かは良く分からないのですが、発祥といえば、+foo+も割と謎なのです。

そもそも、CLに標準で用意されている定数は、pi、most-positive-fixnumのように+は付いておらず、また古いソースには+foo+という表現は見当たらないので、+foo+は比較的新しい表現なんじゃないかと思っています。HyperSpecや、CLtLにもその表現は見当らず、古い処理系では、*foo*と書いてることもあったりします。ちなみに強いてCL標準の表現規則性を挙げれば、pi以外の定数はやたら変数名が長い、位だと思います。

というわけで+foo+否定派の自分は現状をリサーチすべくGoogle code searchで$fooと+foo+を検索して数を比較してみました。

検索キーワードは、

lang:lisp defconstant\ \$
lang:lisp defconstant\ \+

です。結果は、

$foo → 390
+foo+ → 3000

なんと予想より$fooも使われているではないですか。

ということで、個人的に+foo+は大嫌いなので$fooスタイルで行こうかと思います!(ここにこだわってる人もいないと思いますが)

今年一年をふりかえる

| 13:05 | 今年一年をふりかえる - わだばLisperになる を含むブックマーク はてなブックマーク - 今年一年をふりかえる - わだばLisperになる

年末だけに色々まとめエントリが出たりしています。

自分も真似をして、引きこもった今年一年のエントリを眺めて一体自分は何をしていたのかを確認してみることにしましたが、なんだかだらだら列記しただけになりました。

1月

前年から引き続き引きこもり

  • 今年は、LISP50生誕50年ということで、1月1日にdoukaku.orgにLISP 1.5のコードを投稿。
    • 受けるかと思ったら全然受けませんでした。そういえば、今年は、LISP 1.5で色々書いてみようとか思ってました。(思っただけ)
  • Arcが発表真近らしいということで、2001年の時点でのArcのアイディアをCLで真似てみました。
    • 実際にArcが発表されてみると、2001年の時点のアイディアそのままのところが多かったのが意外でした。
  • Practical Common Lispを読んでました。
    • 途中で翻訳が出ると聞いてやめました(´▽`*)
  • CLではどんなライブラリがあるのか知る機会が少ないということで、ライブラリ紹介をして行こうと思い、そういうエントリを何回か書きました。
    • やる気切れ
  • TI-Explorer等のLispマシンのエミュレータを紹介して行こうと思っていました。
    • もっと紹介して行きたいです。
  • LISPの歴史的なところを紹介して行こうと思っていました。
    • もっと紹介して行きたいです。
  • LISPの基本はやはりリスト操作だと思うのですが、L-99前半はリスト処理の問題が多いのでお勧め記事を書いたりしてました。
  • *Lispをいじり始めました。
  • (多分)Richard Gabriel氏の末尾再帰的に書いたコードをループに変換するアイディアを紹介してみてました。
    • これは、Let Over Lambdaでも同じアイディアが載ってたりして面白いなと思います。
  • Arcが公開されたのでどう書くorgに早速投稿したりしました

2月

  • Arcの手習いということで、L-99を再開。
  • Lispならではのアイディアを見付けたら紹介して行こうと思い Lisperのたのしみ というとかの続きもの企画しました。
    • ネタ切れ。
  • S式だった頃のDylanのマニュアルを発見し喜んでいました。
  • LISPの歴史的なところを紹介してました。
  • hayamizさんが、higeponさんと私に会って話がしてみたいというエントリを書いたことがきっかけで、Gauche.night開催に合せて皆で集まることになり、Gauche.nightに行ってみることにしました。
    • ぶっちゃけ引きこもりだけにGauche.nightには行く気はなかったのですが、折角なので行くことしたのでした。この後の展開を考えると、hayamizさんが集まりたいと言い出さなければ、自分は、Shibuya.lispに参加してなかったのかもしれません。人生とは不思議なものです。
  • 3-LISPのリフレクションに興味を持ち始めたようです。
  • Utilispを触ったりしてました。
  • 生活環境をできるだけLispマシンに近付けようとしはじめてました。
    • はてな日記をSLIMEから更新するようになった位で挫折。

3月

  • 昔のLISPのソースコードの統計を取ってonep(1と比較するための専用関数)の存在意義を問いかけてみていました。
  • Gauche Nightで色々な方に会ってお話できました。
    • ひきこもりで恐らく1年位まともに人と会話してなかっただけに、すぐに声が涸れて声にならない状態になりました(笑) この後にLISP系の方々と交流することになるきっかけになった気もします。
  • 古いものから新しいLISPのソースコードを比較してコーディングスタイルを比較してみたりしてました。
  • 「プログラミングGauche」をCLで学んで行こうという企画を開始しました。
    • しかし停滞中
  • 一人でHackathonしてみました。
    • Hackathonという名前を付けると一人だと予想以上に寂しく感じることが分かりました。

4月

  • L-99 度合がひどくなり始めました。対象言語はQi、GOO、Dylan、pfc、LISP 1.5等々。
  • 突発的にCL勉強会がやりたいとか言い始めました。
    • 参加者を募集したところ全員で4名集ったのでSLIME勉強会@新宿が開催されました。これのお蔭でSLIMEに少しは詳しくなりました。SLIME勉強会はまたやりたいです。

5月

  • 自分は、引きこもりなので、オンラインでの勉強会がやりたいとか言い始めました。
    • その一環として、Lingrにcommon-lisp-jpというCL部屋を作りました。間も無くhigeponさんがIRCにlisp_scheme部屋を作ったため、これならCL部屋は閉じてIRCに一本化すれば良いんじゃないかなと思いましたが、それなりに棲み分けができて今に至ります。
  • オンラインでの勉強会「突発性CL勉強会@Lingr 8時だョ!全員集合」を開催し始めました

6月

  • CLについて情報交換できないものかと思いCLのメーリングリストとか作りました。
    • ちなみに未だにあんまり活溌ではありません。
  • 何故かループ用の構文に熱中していました。loopを使うことをメインにL-99の問題を解いたりしていました。
    • 多分、L-99の前半40問位をloopを使って書けば、loopも使えるようになるんじゃないかと思いますので、loopを克服したいという方にはお勧めです。

7月

  • 引き続きループ用の構文に熱中していて、ITERATE、SERIESでL-99をやったりしてました。
  • この辺から勉強会に集まってくれる方も定着してもらえたようです。
  • 実践Common Lispが発売になりました。
    • 発売後もっとCLの波がどっかんどっかん来ると思っていたのですが、どっかんどっかんとまでは行かなかったようです。でも、CLで何か書くならば、この1冊をちゃんとやれば、かなりできるようになると思いますので、実践Common Lispはお勧めです。必読です。ちなみに、CL勉強会でも実践Common Lispを読んでいますので良かったら参加してみて下さい。

8月

  • 勉強会に力を入れていたためか、夏バテか、ブログエントリは減り、勉強会の告知を反省ログだけという感じでした。

9月

  • Let Over Lambdaをはてなハイクで読んで行こう、とか言い始めました。(しかし頓挫)
  • ANSI Common Lisp、On Lisp、Successful Lispも序でにハイク!とかとか言い出しました。(しかし頓挫)
  • JLUGのサイトが更新されていないので、ハブサイトとしてリニューアルされたら面白いのではないかと考え、JLUG事務局に問合せてみたりしました。
    • 活動は停滞しているとのこと。
  • Shibuya.lispが発足しました。
  • EusLispを知ったので試したりしてました。
  • Clojureに熱中し始めました。
  • Shibuya.lispの準備が忙しいのか、CL勉強会の気力が減少していた様子。
  • 何をとち狂ったのか、Let Over Lambda、PAIP、Object Oriented Programming in Common Lisp、AMOPをAmazonでまとめて買ってしまいました。
    • 未だにPAIPは1ページも読んでません。

10月

  • CLでは、デザインパターンはどう実現されるのかを試し始めました。
  • Let Over Lambda読了。変態な本だなと思いました。
  • Shibuya.lisp TT#1が開催されました。
    • 発起人のくせに懇親会に参加しなかったので、Gauche.nightのように色々な方とお会いして話すということはありませんでした(^^;
  • LISP系言語MDLのmapfをCLで書いてみるお題とか出してみてました。

11月

  • AMOPセミナーの為にObject Oriented Programming in Common Lisp読了。
    • CLOS入門には必ず読むべきじゃないかと思いました。AMOP読了は、セミナーには間に合わず、というより未だに読み終らず。
  • デザインパターンに熱中している様子。
  • Shibuya.lisp開催で疲れたのか、CL勉強会でやる気とネタ切れ
  • デザインパターンはOOP気味なのでCLOSに熱中し始めました。
  • 数理システムさんのAMOPセミナーに参加しました。
  • AMOPセミナーの影響で、MOP、MOP言い始めました。
    • しかし、現状具体的には何も作れません(´▽`*)
  • 逆引きLispが作りたいと言い始め、逆引きCommon Lisp、逆引きScheme立ち上げました。
    • 今後利用者が増えて育って行くと良いなと思います。

12月

  • 逆引きCL/SchemeのMLが欲しいとか言い出して、勝手に作りました。
  • 最初はさっぱりだったデザインパターンもコードを書いてるうちに何となく雰囲気は掴めてきた様子でデザインパターンのことばかり書いていました。
  • CL勉強会ももっと盛り上がって欲しいということで、とりあえず毎週開催だけはして様子を伺うことにしました。

まとめ

どうやら今年前半は一人で色々実験、後半はコミュニティ的活動で色々という感じでしたが、個人的には自分は一人で色々やってた方が面白いことをするのかなと思いました。

LISPの歴史的な考察等ももう少し深追いしたいところです。

コミュニティといえば、LISP系のコミュニティはまだまだ参加者のコミットが足らない状況ではないかと思えました。

コミットが足らないというよりも、まず人数が足らないようで如何ともし難いところはあります。

それだけに、何かすればすぐ目立てますので目立ちたい方にはLISP系コミュニティは穴場だと思いますので征服してみては如何でしょうか(笑)

来年への展望

引きこもりがもう維持できないのでどうにかする必要があり来年生きてるのかも良く分からないのですが、

  • CommonObject、Flavors、ObjectLispをMOPの勉強を兼ねてANSI CLに移植したい

と実力的に無謀なことを考えています。

それと、Shibuya.lispは、2月の開催は決定していますが、今のところ年3回位のペースで考えられているので、6月、10月位にも開催できたら良いなと思います。その頃コミットできてるのかは謎ですが(笑)

2008-12-29

Getting Started in *LISP (17)

| 00:12 | Getting Started in *LISP (17) - わだばLisperになる を含むブックマーク はてなブックマーク - Getting Started in *LISP (17) - わだばLisperになる

今回は3.5から再開です。

3.5 Parallel Data Transformation in *Lisp

*Lispは大規模なデータの変形をサポートするオペレーションを提供しているとのことで、グリッド全体の総和を取ったり特定のグリッドに沿ってデータを累積したり色々できるとのこと。このセクションではその様なオペレーションの方法を解説。

データを変形するオペレーションは*Lispには

  1. 累積オペレーション
  2. ランキングとソート
  3. スキャン

等がある

3.5.1 Parallel Prefixing (Scanning)

上記のスキャンの方法には選択したグリッドのpvarを横断して作用するもので、scan!!が代表的。

scan!!は拡張性があり、値を掛け算したり、最大値や最小値を取ったり論理的and、or、xorが取れたり、グリッド間で値をコピーすることが可能。

全プロセッサーに2を設定し、+!!を作用させる例(pvarの表現として(!! 2)は2と書ける。)

(ppp (scan!! 2 '+!!) :end 20)
;>>> 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30 32 34 36 38 40
;=> NIL

scan!!は :include-self 引数が取れ、各自のプロセッサが自分の値を含めるかを指定できる

(ppp (scan!! 2 '+!! :include-self nil) :end 20)
NIL 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30 32 34 36 38 NIL ; テキストだと先頭が0の筈なんだけれど…

:include-selfは一つシフトさせる用途にも使えることが分かる

scan!!特有の機能として、pvarをセグメントに分けてのオペレーションがある

これには、 :segment-pvar を使用する

;; セグメントの設定: 4つ置きにTを設定し他はnil
(*defvar segments (zerop!! (mod!! (self-address!!) 4)))

;; 確認
(ppp segments :end 16)
;>> T NIL NIL NIL T NIL NIL NIL T NIL NIL NIL T NIL NIL NIL 
;=> NIL

このセグメントにscan!!を作用させてみる

(ppp (scan!! 1 '+!! :segment-pvar segments) :end 16)
;>> 1 2 3 4 1 2 3 4 1 2 3 4 1 2 3 4
;=> NIL

:segment-pvar を与えられたscan!!は、Tを開始地点と見做し作用することが分かる

次回 3.5.2から再開

2008-12-27

第26回慢性的CL勉強会@Lingr8時だョ!全員集合まとめ

| 23:53 | 第26回慢性的CL勉強会@Lingr8時だョ!全員集合まとめ - わだばLisperになる を含むブックマーク はてなブックマーク - 第26回慢性的CL勉強会@Lingr8時だョ!全員集合まとめ - わだばLisperになる

12/27 20:00から26回目の勉強会を開催させて頂きました!

発言して頂いた方約5名、observer(ROM)の方約5前後で、大体10名前後を推移しつつでした。

今回は、実践Common Lispを読む、で2章を読みました。

反省点

年末にしては集って頂けたかと思いました。今回はちょっと準備をしていたので割と良いペースだったかと思います。

開発環境ネタというのも良かったのかもしれません。

ログ:

謝辞:

ページへの勉強会のロゴ設置ありがとうございます!

今回も勉強会の一員に加えて頂いてありがとうございます!

2008-12-26

Getting Started in *LISP (16)

| 21:53 | Getting Started in *LISP (16) - わだばLisperになる を含むブックマーク はてなブックマーク - Getting Started in *LISP (16) - わだばLisperになる

3.4.2 Bulk Data Movement-Array/Pvar Conversions

前回の続きでフロントエンドとConnection Machineのデータ転送について

今回は、アレイとpvarとの変換用関数を使う方法を紹介。

そのままな名前の

  • array-to-pvar
  • pvar-to-array

があり、これで転送する。

;; フロントエンド側でアレイを定義
(defvar data-array #(1 2 3 4 5 6))

;; Connection Machine側で空pvarを定義
(*defvar data-pvar 0)

フロントエンド(アレイ)→Connection Machine

;; array-to-pvarでは:endによって終わりを示す
(array-to-pvar data-array data-pvar :end 6)

(ppp data-pvar :end 12)
;>>> 1 2 3 4 5 6 0 0 0 0 0 0
;=>  NIL

アレイが対応するpvarに設定されたことが分かる

Connection Machine→フロントエンド(アレイ)

;; :array-offsetは受け手のアレイの開始オフセット、:start、:endはpvar側
(pvar-to-array data-pvar data-array :array-offset 3
                                    :start 0 :end 3)

(let ((*print-array* t))
  (print data-array))
;=> #(1 2 3 1 2 3)

次回 3.5から再開

2008-12-25

Getting Started in *LISP (15)

| 19:30 | Getting Started in *LISP (15) - わだばLisperになる を含むブックマーク はてなブックマーク - Getting Started in *LISP (15) - わだばLisperになる

書いてる本人も*Lispはマニアック過ぎる気がしてみました。*Lispのシミュレータいじって遊んでる人って果して日本に何人いるんでしょうか。

Clozure CL、Allegro CL、CLISP等で動きますし、結構面白いので是非とも試してみて下さい!

ダウンロードは

からできます。

それはさておき続きです。

3.4 Front-End/CM Communication

フロントエンド(UNIXワークステーションやLispM)とConnection Machine(CM)のデータのやりとりについて

CMは単体で動作するものではなくフロントエンドに接続して利用する形態でした。この章はその方法について

方法は3種類で

  1. !!オペレータによるもの
  2. pvarの値を一つずつ読み出しては返すような方法
  3. アレイをpvarに変換する関数があるのでそれを利用

等があるとのこと

3.4.1 Funnels for Data-Global Communication Functions

まず3つのうちの一番最初の全プロセッサに一気に伝達する系統のものの解説

!!系のオペレータは全プロセッサに同時に作用します。

(in-package :*lisp)
;; 256 x 256プロセッサを利用
(*cold-boot :initial-dimensions '(256 256))

(*defvar numbers (random!! 10))

(*sum numbers)
;=> 295439

*whenやif!!を利用して該当するプロセッサを選択することも可能

;; 全プロセッサに1を設定して合計 => プロセッサの数
(*sum 1)
;=> 65536

;; プロセッサ番号が偶数のものだけに*sumが作用
(*when (evenp!! (self-address!!))
  (*sum 1))
;=> 32768

他に似たものとして *max、*minがあり

;; プロセッサ番号で最も大きい数
(*max (self-address!!))
;=> 65535

述語としては、*or、*andがあります

;; 全プロセッサT
(*or t!!)
;=> T

(*when nil!! (*or t!!))
;=> NIL

;; 全プロセッサに対する
;; (when nil (or t))

次回、3.4.2から再開

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

第25回慢性的CL勉強会@Lingr8時だョ!全員集合まとめ

| 20:05 | 第25回慢性的CL勉強会@Lingr8時だョ!全員集合まとめ - わだばLisperになる を含むブックマーク はてなブックマーク - 第25回慢性的CL勉強会@Lingr8時だョ!全員集合まとめ - わだばLisperになる

12/20 20:00から25回目の勉強会を開催させて頂きました!

発言して頂いた方約3名、observer(ROM)の方約5前後で、大体8名前後を推移しつつでした。

今回は、実践Common Lispを読む、で1章を読みました。

反省点

告知が少なかったためか、久しぶりのためか、人が少なく閑散としていました(笑)

もう自分の挑戦もこれまでか、とも思いましたが、とりあえず続けたいと思います。

多分、毎週継続していけば、どうにかなるでしょうと思いたいところ。根本的になにか間違っているのかもしれませんが(笑)

ログ:

謝辞:

ページへの勉強会のロゴ設置ありがとうございます!

今回も勉強会の一員に加えて頂いてありがとうございます!

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

12/20〜1/13 第25〜31回 慢性的CL勉強会@Lingr8時だョ!全員集合告知

| 10:33 | 12/20〜1/13 第25〜31回 慢性的CL勉強会@Lingr8時だョ!全員集合告知 - わだばLisperになる を含むブックマーク はてなブックマーク - 12/20〜1/13 第25〜31回 慢性的CL勉強会@Lingr8時だョ!全員集合告知 - わだばLisperになる

一ヶ月ぶりの告知です。

開催が停滞していましたが、毎週土曜日に集って頂ける方は一定数いらっしゃり、開催しないのももったいないので毎週開催することとしてみました。

ということで1月末までどかんと、第31回目までの告知です。

12/20 第25回

12/27 第26回

1/ 3 第27回

1/10 第28回

1/17 第29回

1/24 第30回

1/31 第31回

という風に年末年始も世間の流れとは関係なく開催致します!

大体の構成ですが、序盤30分から1時間は、実践(Practical) Common Lispを読むこととしたいと思います。

後半の1時間程度は、都度変えていこうかと思います。

場所:Lingr: Common Lisp部屋
日時12/20〜1/31(土)まで毎週土曜 20:00から21:00位まで(途中参加/離脱/ROM歓迎)
お題実践(Practical) Common Lispを読む+α
勉強会の目標CLに関して一つ位賢くなった気になること

勉強会のネタがあれば、このブログにコメント頂くか、Lingr等に書き置きしてみて下さい。好きなテーマを持ち込んでみて頂くというのも大歓迎です!

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

逆引きCL/SchemeのMLを作りました

| 22:53 | 逆引きCL/SchemeのMLを作りました - わだばLisperになる を含むブックマーク はてなブックマーク - 逆引きCL/SchemeのMLを作りました - わだばLisperになる

Shibuya.lispのMLでは既に告知をしたのですが、逆引きCL/SchemeのMLを作ってみました。

主に逆引きCL/Schemeを書いてる方への業務連絡等と、リクエスト募集の窓口にとも考えています(ネタのリクエストはWiliki上でも可能なので業務連絡が主になってしまうかも知れませんが…)

逆引きCL/Schemeを編集されている方は是非ともご参加頂けると嬉しいです!

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

MooseをCLで再現してみたい

| 22:34 | MooseをCLで再現してみたい - わだばLisperになる を含むブックマーク はてなブックマーク - MooseをCLで再現してみたい - わだばLisperになる

今年はPerlでMooseという言葉を良く聞いたのですが、一体どんな感じなのだろうということで、CLで再現してみようと思い立ちました。

ちゃんとやればMOPの練習になるかもしれません。

それはさておき、外見だけ真似てみました。

package Point;
use strict;
use warnings;
use Moose;

has 'x' => (is => 'rw', isa => 'Int');
has 'y' => (is => 'rw', isa => 'Int');
sub clear {
  my $self = shift;
  $self->x(0);
  $self->y(0);
}

package Point3D;
use strict;
use warnings;
use Moose;
extends 'Point';
has 'z' => (is => 'rw', isa => 'Int');
after 'clear' => sub {
  my $self = shift;
  $self->z(0);
};

こういうのを

(defmoose point ()
  (:has x :is rw :isa integer)
  (:has y :is rw :isa integer)
  (:sub clear ()
        (setf (x self) 0
              (y self) 0)))

(defmoose point-3d (point)
  (:has z :is rw)
  (:after clear ()
          (setf (z self) 0)))

こう書いたらどうかと。

;; 試す
(let ((p (make-instance 'point-3d)))
  (clear p)
  (setf (x p) 30)
  (describe p))
;>>>
;#<POINT-3D #x30004287806D>
;Class: #<STANDARD-CLASS POINT-3D>
;Wrapper: #<CLASS-WRAPPER  #x3000426FB8FD>
;Instance slots
;X: 30
;Y: 0
;Z: 0

当初は、やはり矢印が格好良いので矢印を活かしたかったんですが、

(defmoose point-3d (point)
  (:has z => ((:is => 'rw)
              (:isa => 'integer)))
  (:after clear
          => (sub clear ()
                  (setf (-> self z) 0))))

どうも矢印を書くのが面倒なので普通のplistにしてしまいました。

ちなみに、今のところマクロで変形しているだけでMOPの鱗片さえありません(´▽`*)

メッセージセンドでもなく普通の総称関数です。

一応:afterメソッドにも対応してみました。変形してるだけですが…。

(defpackage :moose
  (:use :cl))

(in-package :moose)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun get-hases (attributes)
    (remove :has attributes :key #'car :test-not #'eq))

  (defun get-subs (attributes)
    (remove :sub attributes :key #'car :test-not #'eq))
  
  (defun ensure-has-attributes (class-name attributes)
    (declare (ignore class-name))
    (mapcar (lambda (x)
            (let ((has (getf x :has))
                  (is (getf x :is))
                  (isa (getf x :isa)))
              `(,has
                ,@(and is (list 
                           (case is
                             (rw :accessor)
                             (ro :reader)
                             (otherwise (error "malformed attributes")))
                                        ;(intern (format nil "~:@(~A.~A~)" class-name has))
                           has
                           ))
                ,@(and isa (list :type isa)))))
            (get-hases attributes)))
  
  (defun ensure-sub-attributes (class-name attributes)
    (mapcar (lambda (x)
              (let* ((args (cdr x)))
                `(defmethod ,(first args) ((self ,class-name) ,@(second args)) ,@(cddr args))))
            (get-subs attributes)))
  
  (defun get-afters (attributes)
    (remove :after attributes :key #'car :test-not #'eq))
  
  (defun ensure-after-attributes (class-name attributes)
    (mapcar (lambda (x)
              (let ((args (cdr x)))
                `(defmethod ,(first args) :after ((self ,class-name) ,@(second args)) ,@(cddr args))))
            (get-afters attributes))))

;; 本体
(defmacro defmoose (name (&rest extends) &rest attributes)
  `(progn
     (defclass ,name ,extends
       ,(ensure-has-attributes name attributes))
     ,@(ensure-sub-attributes name attributes)
     ,@(ensure-after-attributes name attributes)))

2008-12-09

Getting Started in *LISP (14)

| 20:55 | Getting Started in *LISP (14) - わだばLisperになる を含むブックマーク はてなブックマーク - Getting Started in *LISP (14) - わだばLisperになる

実に3ヶ月半ぶりなのですが、*Lispのチュートリアルです。

*Lispとは、65536個もCPUがあるConnection Machine用のLISPで、この日記では、それのシミュレータがあるので動かしてみています。\*LISPセクションがありますので興味がある方は是非一緒に遊んでみて下さい(*'-')

この3ヶ月半の間にAllegro CLとCLISP以外ではシミュレータが動かなかったのが型宣言をANSI CLでもコンパイルできるように書き直すことで動くようになりました。

type-system-deftypes.lisp の

(deftype pvar (&optional (element-type '*))
  ;; I have to return a satisfies type with a closure so that typep can work.
  ;; But, returning a closure will blow up both subtypep and the compiler on lucid.
  (let ((closure (*lisp-i::pvar-type-predicate 
                  (cadr (*lisp-i::canonical-pvar-type `(pvar ,element-type))))))
    `(satisfies ,closure)))

が、 satisfies に lambda 式を渡してしまっているのが原因でコンパイルできなかったので

(defvar *pvar-satisfy-tem* '*)

(defun pvar-satisfy-func (&rest args)
  (apply (*lisp-i::pvar-type-predicate 
          (cadr (*lisp-i::canonical-pvar-type `(pvar ,*pvar-satisfy-tem*))))
         args))

(deftype pvar (&optional (element-type '*))
  (let ((*pvar-satisfy-tem* element-type))
    `(satisfies pvar-satisfy-func)))

のように satisfies に渡す関数を大域で定義して大域変数を間に挟んで対処しました。

deftype の中で関数を作成しても良いとは思いますが、SBCLだと関数が複数生成されるようなのでこの方法にしました。この辺ちょっと謎です。

他にもっと良い方法があったら是非教えて下さい!

シミュレータの動作状況ですが、Clozure CLではいまのところ問題ないようですが、SBCLでは、pvarの値を上手くセットできなかったりでいまいちです。自分はSBCLをメインに使ってるのでどうにか対処したいところです。

3.3.5 An Example of Grid Communication

さて、いきなりですが、グリッドタイプのコミュニケーションの説明です。

どうやら前回きりが良くないところで終りにしたみたいで中途半端です。

内容としては、*newsを使ってグリッドの方を動かしてしまおうという内容です。

;; 8x8で初期化
(*cold-boot :initial-dimensions '(8 8))

;; 0で埋める
(*defvar data-pvar 0)

;; 値をセット
(*setf (pref data-pvar (grid 0 2)) 2)
(*setf (pref data-pvar (grid 0 3)) 3)
(*setf (pref data-pvar (grid 0 4)) 4)

;; 確認
(ppp data-pvar :mode :grid :end '(8 8))
;;      DIMENSION 0 (X)  ----->

;; 0 0 0 0 0 0 0 0 
;; 0 0 0 0 0 0 0 0 
;; 2 0 0 0 0 0 0 0 
;; 3 0 0 0 0 0 0 0 
;; 4 0 0 0 0 0 0 0 
;; 0 0 0 0 0 0 0 0 
;; 0 0 0 0 0 0 0 0 
;; 0 0 0 0 0 0 0 0 
;; NIL

ここで前回定義したzig-zag(Getting Started in *LISP (13) - わだばLisperになる - cadr group参照)

で地面をずらしてみます。(zig-zagは、東へ3歩、北へ1歩動かします)

8x8桝で、四方が繋っている(位置の数値が(mod 8)的)ので、こんな感じになります。

(zig-zag data-pvar)

(ppp data-pvar :mode :grid :end '(8 8))
;;      DIMENSION 0 (X)  ----->

;; 0 0 0 0 0 0 0 0 
;; 0 0 0 0 0 2 0 0 
;; 0 0 0 0 0 3 0 0 
;; 0 0 0 0 0 4 0 0 
;; 0 0 0 0 0 0 0 0 
;; 0 0 0 0 0 0 0 0 
;; 0 0 0 0 0 0 0 0 
;; 0 0 0 0 0 0 0 0 
;; NIL

次回 3.4から再開

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