わだばLisperになる

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

Design Patterns, Common Lisp | 01:35 |

今回はAdapterパターンです。

体系の違うものをアダプタを介し、アダプタで差異を吸収することによって統一的に扱えるようにするパターンのようです。変換コネクタとかそういう感じでしょうか。

no titleの社長と社員の給与体系の違いを扱う方法が分かりやすかったのでこの例を元にしました。

Adapterにはクラスを継承するパターンと、委譲を使うパターンがあるようなのですが、総称関数ベースだとどちらとも微妙に違う感じになってしまいます。今回の例で言えば、shachoクラスに特定化したget-kyuyoを書いてしまえば、そもそもアダプタは不要になってしまうのですが、とりあえず例に沿ってみました。

(defclass shain () 
  ((jikyu :initform 0 :initarg :jikyu :accessor get-jikyu)
   (jikan :initform 0 :initarg :jikan :accessor get-jikan))
  (:documentation "時給と時間を保持"))

(defgeneric get-kyuyo (class)
  (:method ((class shain))
    (* (get-jikyu class)
       (get-jikan class)))
  (:documentation "時給x時間で給与を計算する"))

;; 動作
(get-kyuyo (make-instance 'shain :jikyu 1000 :jikan 140))
;=> 140000

;; 給与体系が、時給x時間ではなく固定給な社長を扱う必要性がでた。
(defclass shacho () 
  ((koteikyu :initform 0 :initarg :koteikyu :accessor get-koteikyu))
  (:documentation "固定給を保持"))

;; Adapterを作成(shainとshachoを継承)
(defclass shacho-adapter (shain shacho) 
  ()
  (:documentation "時給x時間で計算するget-kyuyoのためのアダプタ"))

;; 固定給(時給) x 1(時間)と見立てることで、get-kyuyoに適合させる
(defmethod get-jikyu ((class shacho-adapter))
  (get-koteikyu class))

(defmethod get-jikan ((class shacho-adapter))
  1)

(get-kyuyo (make-instance 'shacho-adapter :koteikyu 200000))
;=> 200000
;; get-kyuyoは変更しなくて済んだ。

■

ツイートする

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

Design Patterns, Common Lisp | 01:18 |

今回はObserverパターンです。

最初にObserverパターンの説明を読んでいて内容的には、メソッドにフックが掛けられれば、それで解決できてしまうのではないかと思ったのですが、Norvig氏のDesign Patterns in Dynamic Programming でも、メソッドコンビネーション(:after)で解決していました。

:afterのフックを掛ける方が便利だとは思いましたが、クラスだけのバージョンを作ってみました。比較の為にメソッドコンビネーション版も作ってみています。

説明ですが、大域変数*numlist*に数をプッシュしてゆくpush-numがあり、push-numがプッシュするたびに全部の数を掛けたものと足したものを表示します。

メソッドコンビネーション版は、push-num2はプッシュした後:afterで、observerに通知をしています。attachとdetachの実装はしておらず関数名のリストを渡しています。

Norvig氏の説明によれば、メソッドコンビネーションであれば、subjectクラスの用意もいらないだろうとのこと。

(defclass observer () ())
(defclass sum (observer) ())
(defclass mult (observer) ())

(defgeneric update (obs)
  (:method ((obs observer))))

(defmethod update ((obs sum))
  (format T "sum: = ~A~%" (apply #'+ *numlist*)))

(defmethod update ((obs mult))
  (format T "mult: = ~A~%" (apply #'* *numlist*)))

(defclass subject () 
  ((observers :initform ())))
(defun make-subject ()
  (make-instance 'subject))

(defgeneric attach (sub obs)
  (:method ((sub subject) (obs observer))
    (pushnew obs (slot-value sub 'observers))))

(defgeneric detach (sub obs)
  (:method ((sub subject) (obs observer))
    (with-slots ((observers observers)) sub
      (setf observers
            (delete-if (lambda (x) (eq x obs))
                       observers)))))

(defgeneric notify (sub)
  (:method ((sub subject))
    (map nil #'update (slot-value sub 'observers))))

(defvar *numlist* () )

(defun push-num (sub num)
  (push num *numlist*)
  (notify sub)))

;; 動作
(defparameter *ob1* (make-instance 'sum))
(defparameter *ob2* (make-instance 'mult))
(defparameter *sub* (make-subject)))

(attach *sub* *ob1*)
(attach *sub* *ob2*)

(push-num *sub* 2)
;>>>
sum: = 2
mult: = 2
...
sum: = 10
mult: = 32

;; メソッドコンビネーション(:after)版
(defvar *numlist2* () )

(defmethod push-num2 (sub (n number))
  (push n *numlist2*))

(defmethod push-num2 :after (sub (n number))
  (map nil #'funcall sub))

(defun sum ()
  (format T "sum: = ~A~%" (apply #'+ *numlist2*)))

(defun mult ()
  (format T "mult: = ~A~%" (apply #'* *numlist2*)))

;; 動作
(push-num2 '(sum mult) 2)
;>>>
sum: = 2
mult: = 2
...
sum: = 10
mult: = 32

ツイートする

古えのnet.lang.lispからの拾い物

*standard-output* | 20:23 |

古いネットニュースをgooglegroupsで眺めていたら、comp.〜になる前の、net.lang.lispが保存されているのを見付けました。

最古のものは、1982年。もう四半世紀前です。

流量も少ないので年間通して読めてしまうのですが、1983年の投稿で、Franz LispのリーダーマクロでUNIXのパイプみたいな書法を考えた!

• Google グループ

という投稿が面白そうだったので真似して遊んでみることにしました。

元は、

(print person/mother/father/name/last/car)
;=> (print (car (last (name (father (mother (person)))))))

という風に展開されます。

どうやら、Franz Lispには、中置記法的なものを展開するリーダーマクロの書式/機能があるようなのですが、詳細は不明なのでCLでできそうな風に変更してみました。

#/というリーダーマクロを定義しているのですが、やはりちょっと残念です。

どなたかオリジナルと同じように書ける方法をご存知の方は是非教えて下さい!!

…ちなみに、この書法自体は、あんまり実用的でもなさそうですね(笑)

(defun pipeop (q)
  (labels ((pipeop-n (expr rest)
             (let ((expr (read-from-string expr)))
               `(,@(if (numberp expr)
                       `(nth ,(1- expr))
                       (list expr))
                   ,@(if rest (list rest) rest))))
           (recur (q acc)
             (let* ((cmds (string q))
                    (pos (position #\/ cmds)))
               (if pos
                   (recur (subseq cmds (1+ pos))
                          (pipeop-n (subseq cmds 0 pos) acc))
                   (pipeop-n cmds acc)))))
    (recur q () )))

(set-dispatch-macro-character #\# #\/
                              (lambda (str char arg)
                                (declare (ignore char arg))
                                (pipeop (read str nil nil nil))))

;; 動作
(progn
  #/person/car/father/name/last/1)
;展開 => (PROGN (NTH 0 (LAST (NAME (FATHER (CAR (PERSON)))))))

■

ツイートする

今がチャンス!

*standard-output* | 17:04 |

数日前より逆引きCommon Lisp、逆引きSchemeを立ち上げてみています。

まだまだ、ぽつぽつ登録されているというところなので、今後便利に活用できるように育ってゆくと良いなあと思っています。皆さんも是非、ネタ提供/加筆の程、よろしくお願いします!

それでWiLiKiは、RSSリーダーで講読可能なので、RSSリーダーで眺めていて気付いたのですが、1項目1エントリなので、日々更新されるエントリを適当に眺めているだけでもCL/Schemeの知識が増えるという御利益があることに気付きました。

ということで、CL/Schemeの基礎体力の強化の為にも是非ご講読を!!

• 逆引きCLのRSS

http://tips.lisp-users.org/common-lisp/index.cgi?c=rss

• 逆引きSchemeのRSS

http://tips.lisp-users.org/scheme/index.cgi?c=rss

■

ツイートする

MOP-IN-ONE-DAY-2008回想 (4)

MOP-IN-ONE-DAY-2008 | 17:00 |

A. CLのコードを書く上でお手本となるようなコードはどこで入手できますか

Q. AMOPのClosetteのコードにしろ、PAIPのコードにしろインターネットで公開されているので手本にできるコードは多く入手も簡単。

また、黒田さん個人としては、CLtL2で例となっているコードをお手本にしているとのこと。

上述のコードURL

• Paradigms of AI Programming Source Code
• Index of /afs/cs/project/ai-repository/ai/lang/lisp/oop/clos/closette

■

ツイートする

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

Design Patterns, Common Lisp | 20:24 |

今回はIteratorパターンです。

Iteratorパターンは、理解しやすいということで入門書籍のトップになることが多いらしいのですが、Norvig氏のIteraton Protocolの提案(Dylanで実現)等があるので、この辺を押えてから纏めたいなと思っていました。

しかし、纏められそうもないのでとりあえず簡単なパターンを演習してみることにしました。

ちなみに、Greg Sullivan氏のGOF Design Patterns in a Dynamic OO Languageによればファースト・クラスの関数と内部イテレータの組み合わせ(map、dolist等)は非常に柔軟で応用範囲も広い、とのことなのですが、デザインパターンは外部イテレータのようなのでそれで行くことにしました。

基本的に、現在位置のアイテムを取得する、CurrentItem、位置をリセットするFirst、終わりかどうかを判定する、IsDone、次に進めるNextがあればOKのようで、これらを応用したものが色々あるようです。

今回は、平坦な構造(ベクタや、リスト)を先頭から見て行くことしか考慮してませんが、ツリー構造等もmake-iteratorの方を工夫すればどうにかなるのでしょう。

(defclass iterator () 
  ((obj :initform () :initarg :obj)
   (index :initform 0)
   (size :initform 0)
   (accessor :initform #'elt :initarg :accessor)))

(defmethod initialize-instance :after ((iter iterator) &key)
  (with-slots ((obj obj) (size size)) iter
    (setf size (length obj))))

(defgeneric make-iterator (obj)
  (:method (obj) 
    (make-instance 'iterator :obj obj)))

(defmethod make-iterator ((obj list))
  (make-instance 'iterator :obj obj 
                 :accessor (lambda (obj index)
                             (nth index obj))))

(defmethod make-iterator ((obj vector))
  (make-instance 'iterator :obj obj :accessor #'aref))

;; iterator関数群
(defgeneric first! (iter)
  (:method ((iter iterator))
    (setf (slot-value iter 'index) 0)))

(defgeneric next! (iter)
  (:method ((iter iterator))
    (incf (slot-value iter 'index))))

(defgeneric done? (iter)
  (:method ((iter iterator))
    (with-slots ((index index) (size size)) iter
      (>= index size))))

(defgeneric current-item (iter)
  (:method ((iter iterator))
    (with-slots ((obj obj) 
                 (index index)
                 (accessor accessor)) iter
      (funcall accessor obj index))))

;; 動作
(do ((iter (make-iterator '(1 2 3 4)))
     ans)
    ((done? iter) ans)
  (push (current-item iter) ans)
  (next! iter))

;; 面倒臭いのでマクロ定義/イテレータ定義は外に出した方が良いかも
(defmacro doiter ((var iter &optional result) &body body)
  (let ((g (gensym)))
    `(do ((,g (make-iterator ,iter)))
         ((done? ,g) (let (,var) ,result))
       (let ((,var (current-item ,g)))
         ,@body
         (next! ,g)))))

(doiter (i '(1 2 3 4))
  (print i))

(doiter (i #(a c d e))
  (print i))

(doiter (i "abcde")
  (print i))
;-> #\a 
    #\b 
    #\c 
    #\d 
    #\e 
;=> nil

■

ツイートする

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

勉強会 | 22:49 |

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

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

今回は、Gary King氏のユーティリティ集 Metatilitiesを眺める でした。

反省点

なんとなく漠然とした感じになってしまいました。深くつっこむわけでもなし、浅く広くでもなし。

良かったところ

CLのライブラリ全般についてのスタンダード不在について議論ができたところは良かったと思いました。

ログ:

• http://www.lingr.com/room/common-lisp-jp/archives/2008/11/22#msg-52959362

謝辞:

• scheme-users.jp - さん

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

• IT 勉強会カレンダーさん

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

ツイートする

パッケージ名を使って関数名を短くする試み

*standard-output* | 21:55 |

;; 動作
(map:car (f:x y z list x y z)
          '(1 2 3 4)
          '(a b c d)
          '(one two three four))

;=> ((1 A ONE) (2 B TWO) (3 C THREE) (4 D FOUR)) 

;; 定義
(defpackage :map (:use :cl)
  (:shadow :car)
  (:export :car))

(in-package :map)

(setf (symbol-function 'car) #'cl:mapcar)

(defpackage :f (:use :cl)
  (:export :x))

(in-package :f)

;; 無理矢理気味
(defmacro x (&rest args)
  (do ((a args (cdr a))
       (vars (list (intern "X")) (cons (car a) vars)))
      ((or (fboundp (car a))
           (endp a))
       `(lambda (,@(nreverse vars))
          ,a))))

ツイートする

MOP-IN-ONE-DAY-2008回想 (3)

MOP-IN-ONE-DAY-2008 | 20:06 |

黒田さんの原稿(おそらく進行用)が括弧で囲まれていてS式風でした。

(1. 総称関数)
(2. ...)
(3. ...)

Emacsだとすいすい移動できていて便利そうでした。

■

ツイートする

CLで日記更新 + Outputzで文字数記録

LISP引きこもり生活 | 18:11 |

このはてなグループでの日記は、CL + SLIME + simple-hatena-mode.elで投稿しているのですが、今日、OutputzがAPIを公開されたそうなので、日記更新と連動させてみることにしました。

• Outputz API を公開しました - higepon blog

といっても、上のページにGaucheでのサンプルがあるので、それをDRAKMAに翻訳しただけという感じで

(let ((uri "http://cadr.g.hatena.ne.jp/g000001/")
      (size xxxx)
      (key "復活の呪文"))
  (http-request (apply #'format nil
                       "http://outputz.com/api/post?uri=~A&size=~D&key=~A" 
                       (mapcar #'hunchentoot:url-encode (list uri size key)))
                       :method :post))
...

のようなコードを投稿プログラムに組み込んで文字数をカウントした結果をAPIに送るという感じです。

ということで、記念カキコです。

■

ツイートする

MOP-IN-ONE-DAY-2008回想 (2)

MOP-IN-ONE-DAY-2008 | 09:30 |

Q. メソッドは、関数より重くないですか?

A. 殆どの場合、メソッドで大丈夫。

メソッドの利用が速度的なネックになることは経験上あまりない。

defmethodと、クラスの組み合わせをdefstructと、関数に書き換えたことも全くなかった訳ではないが、非常に稀。

ただし、商用のCLの処理系は、色々と最適化にノウハウが蓄積されていて、メソッドと関数では速度的に大差ないが、フリーの処理系の場合、PCL(Portable CommonLoops)がベースになっていることが多く、PCLは効率の良い実装はされていないので遅くなっている傾向がある。

ACL(Allegro Common Lisp)では非常に効率良く実装されていて、ストリーム、スレッド等もCLOSで組まれている。

この辺のCLOSのパフォーマンスについては、商用メーカーの自社技術になっているので、具体的にどういうことが行なわれているのか、外部からは分からないことが多い。

また、パフォーマンスについては、Amazon CAPTCHAでも解説されている。

ちなみに、スタイルの問題として、

(defmethod my-append ((x null) y)
  y)

(defmethod my-append ((x cons) y)
  (cons (car x) (my-append (cdr x) y)))

こういうのは、IFを使わず書けて綺麗ではあるが、さすがに書かず、関数で書く。

ちなみに…

個人的には、SBCLを利用しているだけにショックでした(笑)

CLを大規模に利用していることで有名なITA Software社は、現在SBCLとClozure CLを基幹に利用していて、かつCLOSを駆使したプログラムとのことなので、SBCLとかでも頑張れるんじゃないかと思ったりするのですが、具体的にベンチを取って比較してみないとなんとも言えないですね(^^;

ともあれCLOS的なスタイルで書いて、パフォーマンスが出なかったら、商用の処理系も検討できるというのもCLらしくて良いかなとも思います。

また、Object-Oriented Programming: The Clos Perspectiveは日本のAmazonでみると無闇に高いのですが、海外から買うと、$40位で買えるようです。

■

ツイートする

11/22 第24回 慢性的CL勉強会@Lingr8時だョ!全員集合告知

勉強会 | 11:50 |

今回は、趣向をちょっと変えてライブラリを読んで内容について議論してみたいと思います。

読んだ上での議論になるので今回は、事前準備必須でよろしくお願います!

といっても準備の程度は個々人で自由です。ざっと眺めおいてもらうだけでもOKです。

今回読むライブラリですが、今回は、Gary KingさんのMetatilitiesにしたいと思います。

http://common-lisp.net/project/metatilities/

今回が良い感じならば、Arnesiや、KMRCL等も俎上にのせてみたいなと考えています。

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

• Lingr: Common Lisp部屋

■

ツイートする

CommonORBITでデザインパターン - Template Method

Common Lisp, CommonORBIT, Design Patterns | 08:06 |

MOPの良い資料や教材がないかネットを漁っているのですが、CMUのLISPリポジトリにはお宝が埋れていることが多く、AMOPの5、6章のPostScriptファイルが埋まっていたりするのですが、今日は、それ以外にも面白いものをみつけたので遊んでみることにしました。

CLといえば、やはりCLOSなのですが、CLOSに至るまでに、Flavors、CommonLoops、CommonObjects、ObjectLisp、等々、色々な団体やメーカーが各々のシステムをつくっていました。

それぞれ、背景となる思想が違ったりして面白いのですが、自分がMOPを学ぶモチベーションとして、これらを今の処理系で動かして遊ぶというのがあります。

それはさておき、お題のCommonORBITなのですが、こちらはちょっと毛色が変ったものらしく、20年位前に作成されていたプロトタイプベースのシステムのようです。

• Package: lang/lisp/oop/non_clos/corbit/

このページでは、教材用のBOOPSとCommonORBIT(CORBIT)があるのですが、どちらも簡単に動かして遊ぶことができました。(BOOPSは、ファイルをコンパイルするのに補助関数をeval-whenでコンパイル時に評価するようにする必要あり)

とりあえず、オジェクト指向プログラミングの練習だとどうも馬鹿のひとつおぼえでTemplate-Methodばっかりやってしまうのですが、CORBITでもやってみました。

簡単に内容を説明すると、

template

templateがテンプレートで、op1とop2、templateというメソッドを持っていて、プロトタイプでは、op1とop2を組み合わせた雛型がtemplateです。

defobjectでの定義では関数を一緒に定義する必要はなく、defaspectで後で付けても良いのですが、templateでは、一緒に定義してみています。

concrate-1

templateを雛型にしたconcrate-1を作成し、op1と、op2のを作成します。

これで、(template 'concrate-1 "foo bar baz")のとすると、"**FOO BAR BAZ**"が返ってきます。

concrate-2

CORBITでは、CLOSにはないような機能が割と沢山あるのですが、:delegateを指定することによって、委譲もできます。

ということで、op1は、concrate-1に委譲していて、op2は、新しく定義、templateは、継承してくる、という感じになっています。

プロトタイプベースのものや、委譲などは自分は全然知らない世界だったのですが、面白い機能だと思いました。

ちなみにCLOSの上に構築されたものではないので競合はせず、同時に混ぜて使うことも可能です。

;; テンプレ
(defobject template
  (op1 :function (self str) "")
  (op2 :function (self str) "")
  (template 
   :function (self str) (op2 self (op1 self str))))

;; concrate-1作成
(defobject concrate-1 template)

(defaspect op1 'concrate-1
  :function (self str) (string-upcase str))

(defaspect op2 'concrate-1
  :function (self str) (format nil "**~A**" str))

;; concrate-2作成
(defobject concrate-2 template
  (op1 :delegate 'concrate-1)
  (op2 :function (self str) (format nil "//~A//" str)))

(template 'concrate-1 "foo bar baz")
;=> "**FOO BAR BAZ**"

(template 'concrate-2 "foo bar baz")
;=> "//FOO BAR BAZ//"

■

ツイートする

MOP-IN-ONE-DAY-2008回想 (1)

MOP-IN-ONE-DAY-2008 | 03:10 |

先週開催されたMOP-IN-ONE-DAY-2008ですが、纏めようにもMOPの部分は自分も全然理解できてないので、もうちょっとAMOP本を読んで理解してからでないと纏められそうにもありません(^^;

ただ、それだと面白くないので、間に挟まれた小話的な黒田さんと受講者との質疑応答を思い出したところから書いて行くことにしてみました。

Q. defclassでスロットの定義が面倒臭くないですか。簡単に書けるマクロを使ったりしないのですか。

質問を解説すると、CLOSのクラスの定義は

(defclass foo ()
  ((foo :initarg :foo :initform () :accessor foo)
   (bar :initarg :bar :initform () :accessor bar)
   (baz :initarg :baz :initform () :accessor baz)
   (zot :initarg :zot :initform () :accessor zot)))

みたいになることが多く、実際に面倒臭いなと自分も感じます。

A. defclassをそのまま手書する人もいるし、マクロを使っている人もいる。

黒田さんは、手書派。Emacsの補完があるのでそんなに面倒ではない、とのことでした。

また略語作るための道具としてのマクロには否定的だそうです。

ちなみに…

ここからは黒田さんの回答とは無関係なのですが、defclassの記述が面倒というのは割と昔からあるようで、Flavaorsのdefflavor風に書けたり、defstruct風に書けたり色々です。

一例として、Metatilitiesのdefclass*を紹介してみます。

• Macro Defclass* [Tinaa]

(defclass* foo ()
  (x y z)
  :automatic-accessors
  :automatic-initargs
  (:name-prefix))

;=> 
(defclass foo ()
  ((x :initarg :x :accessor foo-x)
   (y :initarg :y :accessor foo-y)
   (z :initarg :z :accessor foo-z)))

(foo-x (make-instance 'foo :x 33))
;=> 33

■

ツイートする

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

Design Patterns, Common Lisp | 08:02 |

今回はCommandパターンです。

このパターンもまたNorvig氏とGreg Sullivan氏のGOF Design Patterns in a Dynamic OO Languageによればファースト・クラスの関数がある言語ならばクラスをつかわなくてもできるでしょうとのこと。

確かに関数とデータを何らかのデータに一緒に閉じ込めて、後で取り出したりして実行というのは簡単にできます。

また、テンプレート的なところは、内部で動作する関数を引数に取れる関数を定義してやれば良かったりするんでしょう。

とはいえ、それでは面白くもないので、クラスでやりくりで書いてみました。

今回は、22．Commandパターン | TECHSCORE(テックスコア)の食塩の飽和濃度を調べる手順をCLOSで真似てみました。

水に塩を加えて飽和濃度を調べる実験と、塩に水を加えて調べる実験との2種類を作成。

それぞれの方式がクラスで表現されていて、類似の実験方法を後で簡単に追加できるのが、ポイントのようです。

作ってみた感想ですが、引数に関数を渡せる言語では、継承のメリットが全面に押し出されたような状況でもなければ、関数を渡した方が見通しが良さそうな気もしました。

;; 実験セット
(defclass beaker () 
  ((water :initarg :water :initform 0 :accessor beaker.water)
   (salt :initarg :salt :initform 0 :accessor beaker.salt)))

(defun make-beaker (water salt)
  (make-instance 'beaker :water water :salt salt))

;; 食塩を加える
(defgeneric add-salt (beaker salt)
  (:method ((beaker beaker) (salt number))
    (incf (beaker.salt beaker) salt)))

;; 水を加える
(defgeneric add-water (beaker water)
  (:method ((beaker beaker) (water number))
    (incf (beaker.water beaker) water)))

;; 濃度
(defgeneric concentration (beaker)
  (:method ((beaker beaker))
    (with-accessors ((salt beaker.salt)
                     (water beaker.water)) beaker
      (float (* 100 (/ salt (+ water salt)))))))

;; 記録
(defgeneric note (beaker)
  (:method ((beaker beaker))
    (with-accessors ((water beaker.water)
                     (salt beaker.salt)) beaker
      (format 'T 
              "水:~Ag~%食塩:~Ag~%濃度:~A%"
              water
              salt
              (float (* 100 (/ salt (+ water salt))))))))

;; コマンド
(defclass command () 
  ((beaker :initform (make-beaker 0 0)
           :initarg :beaker
           :accessor beaker)))

(defgeneric execute (command)
  (:method ((command command))))

;; 食塩を加える方向での実験
(defclass add-salt-command (command) ())

(defun make-add-salt-command ()
  (make-instance 'add-salt-command))

(defmethod execute ((command add-salt-command))
  (with-accessors ((b beaker)) command
    (loop :while (> 26.4 (concentration b)) ;20℃での飽和濃度 26.4%
          :do (add-salt b 1))
    (format 'T "~&--- 食塩を1gずつ加える実験 ---~%")
    (note b)))

;; 水を加える方向での実験
(defclass add-water-command (command) ())

(defun make-add-water-command ()
  (make-instance 'add-water-command))

(defmethod execute ((command add-water-command))
  (with-accessors ((b beaker)) command
    (loop :while (< 24.6 (concentration b)) 
          :do (add-water b 10))
    (format 'T "~&--- 水を10gずつ加える実験 ---~%")
    (note b)))

;; 実験をする生徒
(defclass student () ())

(defmethod experiment ((s student))
  (let ((add-salt (make-add-salt-command))
        (add-water (make-add-water-command)))
    ;; ビーカーをセットする
    (setf (beaker add-salt) (make-beaker 100 0))
    (setf (beaker add-water) (make-beaker 0 10))
    ;; 飽和食塩水を作る実験
    (execute add-salt)
    (execute add-water)))

;; 実験
(experiment (make-instance 'student))

;>>>
; --- 食塩を1gずつ加える実験 ---
; 水:100g
; 食塩:36g
; 濃度:26.470589%
; --- 水を10gずつ加える実験 ---
; 水:40g
; 食塩:10g
; 濃度:20.0%

■

ツイートする

MOPでFizzBuzz (2)

MOP, CLOS | 21:03 |

コメントにて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)

MOP, CLOS | 02:49 |

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

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

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

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

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

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

• Closer Project: Closer to MOP.

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

;; メタクラス
(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>
...

ツイートする

MOPでFizzBuzz

CLOS, MOP | 23:17 |

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

• no title

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

■

ツイートする

メソッドコンビネーションでFizzBuzz (2.5)

CLOS | 00:24 |

前回の例だと、メソッド修飾子での実行順番と、クラスの継承の順番が同じだったのでいまいちかなと思い、百個のクラスの継承関係をシャッフルしてみました。

これでも、1から順番に実行されます。

この場合、継承されている一連の集合体であることだけが必須で、実行の順番は修飾子で決定されクラス側が持つ優先順位ではないことが分かります。(継承は百個連続している必要あり)

(defgeneric fizzbuzz (cls)
  (:method-combination fizzbuzz))

;; 指定した範囲のランダムに混ざった数列のベクタを返す関数
(defun bingo (n)
  (loop :with nums := (make-array 0 :adjustable 'T :fill-pointer 'T)
        :for i :from 1 :to n :do (vector-push-extend i nums)
        :finally (return
                   (dotimes (j n nums)
                     (rotatef (aref nums j)
                              (aref nums (random n)))))))

;; クラスとメソッドを作成
(let ((nums (bingo 99)))
  (vector-push-extend 100 nums) ;; しっぽを100に
  (loop :for n :from 1
        :for b :across nums
        :and prev := (aref nums 99) :then b
        :do (eval
             `(progn
                (defclass ,#1=(make-roman-number-symbol b) 
                          ,(if (zerop (1- n)) () `(,(make-roman-number-symbol prev))) 
                          () )
                (defmethod fizzbuzz ,n ((cls ,#1#))
                  (format T ,@(typecase n
                                (fizzbuzz (list "Fizz Buzz~%"))
                                (buzz (list "Buzz~%"))
                                (fizz (list "Fizz~%"))
                                (otherwise (list "~A~%" n)))))))))

;; クラスの継承関係 (ランダムな一例)
;; The class is finalized; its class precedence list is:
  (|ONE HUNDRED| SEVENTY-SIX SIXTY-ONE NINETY-NINE EIGHT EIGHTY-NINE
   THIRTY-TWO FORTY-SEVEN FORTY-THREE FORTY-FIVE SIXTY-SIX NINETY-EIGHT
   FORTY-NINE EIGHTY TWENTY-FOUR SIXTY-NINE THIRTY-FOUR NINETY-FIVE SIXTY
   SIXTY-EIGHT FIFTY-SIX EIGHTY-SEVEN NINETY-SEVEN ONE NINETY-SIX
   FIFTY-FIVE FOURTEEN NINETY EIGHTEEN SIXTY-THREE TWENTY-SEVEN
   EIGHTY-FOUR FORTY-SIX THIRTY-ONE FIFTY-ONE FIFTY-FOUR NINETY-FOUR
   EIGHTY-EIGHT SIXTY-FIVE FORTY-FOUR SEVENTY-NINE SIXTY-FOUR FIFTY-SEVEN
   FORTY-EIGHT FIFTY-THREE EIGHTY-THREE THIRTY-EIGHT TWENTY-THREE
   THIRTY-THREE THIRTY-SEVEN FORTY FIFTY-EIGHT TEN FORTY-TWO EIGHTY-FIVE
   SEVENTY-SEVEN EIGHTY-TWO NINETY-THREE EIGHTY-ONE TWENTY-SIX
   SEVENTY-FIVE FIFTEEN TWENTY THREE NINETEEN FOUR TWO FIVE THIRTEEN NINE
   FIFTY-TWO SEVENTEEN THIRTY-NINE NINETY-ONE SIX FORTY-ONE SEVENTY-FOUR
   EIGHTY-SIX SIXTY-SEVEN SIXTY-TWO TWENTY-ONE SEVEN THIRTY-SIX
   SEVENTY-ONE ELEVEN SEVENTY THIRTY-FIVE THIRTY NINETY-TWO TWELVE
   SEVENTY-TWO TWENTY-TWO TWENTY-FIVE SEVENTY-THREE TWENTY-EIGHT SIXTEEN
   FIFTY-NINE SEVENTY-EIGHT FIFTY TWENTY-NINE STANDARD-OBJECT
   SB-PCL::SLOT-OBJECT T).

;; 実行
(fizzbuzz (make-instance '|ONE HUNDRED|))
;>>>
1
2
Fizz
4
Buzz
Fizz
7
8
Fizz
Buzz
11
Fizz
13
...

■

ツイートする

メソッドコンビネーションでFizzBuzz (2)

CLOS | 23:19 |

前回、メソッド修飾子を数値で表現して、それでFizzBuzzできるんじゃないかと考えてみましたが、CLtL2のdefine-method-combinationの説明用のコードが元ネタになります。

内容としては、まず、メソッド修飾子をmethod-qualifiersで集めて、修飾子が数値なので順番にソートしたものが優先順位として並べられるというものみたいです。

修飾子は、

(method-qualifiers (find-method #'fizzbuzz '(1) (list (find-class 'one))))

みたいにして取得できます。

それで、前回と比べてあまりかわりばえしないのですが、

(defclass one () ())
(defmethod fizzbuzz 1 ((obj one))
  (format t "~A~%" 1))

(defclass two (one) ())
(defmethod fizzbuzz 2 ((obj two))
  (format t "~A~%" 2))

みたいな定義を作って行くことになります。

しかし、クラスと修飾子の意味が被ってるので、ぱっとしないのがくやしい。

ちなみに、修飾子で順番を決めているので、:most-specific-firstであろうが、:most-specific-lastを指定しようが、1から順番に実行されます。

;;;
;;; 動作
;;;

;; 総称関数定義
(defgeneric fizzbuzz (cls)
  (:method-combination fizzbuzz))

(loop :for i :from 1 :to 100 :do (make-fizzbuzz#2 i))

;; 実行
(fizzbuzz (make-instance '|ONE HUNDRED|))

...
82
83
Fizz
Buzz
86
Fizz
88
89
Fizz Buzz
91
92
Fizz
94
Buzz
Fizz
97
98
Fizz
Buzz

;; メソッドコンビネーションの定義 CLtL2参照(というかそのまま)
(define-method-combination fizzbuzz () 
        ((methods positive-integer-qualifier-p)) 
  `(progn ,@(mapcar #'(lambda (method) 
                        `(call-method ,method ())) 
                    (stable-sort methods #'< 
                      :key #'(lambda (method) 
                               (first (method-qualifiers 
                                        method))))))) 

(defun positive-integer-qualifier-p (method-qualifiers) 
  (and (= (length method-qualifiers) 1) 
       (typep (first method-qualifiers) '(integer 0 *)))) 

;; 型で振り分けるので型を定義
(deftype fizz ()
  (let ((g (gensym)))
    (setf (symbol-function g) (lambda (x) (zerop (rem x 3))))
    `(satisfies ,g)))

(deftype buzz ()
  (let ((g (gensym)))
    (setf (symbol-function g) (lambda (x) (zerop (rem x 5))))
    `(satisfies ,g)))

(deftype fizzbuzz () '(and fizz buzz))

;; 99 -> NINETY-NINE みたいなものを作成する
(defun make-roman-number-symbol (n)
  (values (intern (format nil "~:@(~R~)" n))))

(defmacro make-fizzbuzz#2 (n)
  `(eval
    `(progn
       (defclass
             ,#1=(make-roman-number-symbol ,n) 
             ,(if (zerop (1- ,n)) () `(,(make-roman-number-symbol (1- ,n)))) 
             () )
       (defmethod fizzbuzz ,(eval ,n) ((cls ,#1#))
         (format T ,@(typecase ,n
                       (fizzbuzz (list "Fizz Buzz~%"))
                       (buzz (list "Buzz~%"))
                       (fizz (list "Fizz~%"))
                       (otherwise (list "~A~%" ,n))))))))

■

ツイートする

メソッドコンビネーションでFizzBuzz

CLOS | 13:22 |

CLOSにはメソッドコンビネーションがあり、総称関数に束ねられたメソッドの適用順序を任意に変更することができます。

標準では、通常のstandard以外に9種類ありますが、とりあえず使い方は何となく分かったものの一体何に使えるんだろうというものもあります。

という訳で、何か役に立ちそうなメソッドコンビネーションの例を考えていたのですが、とりあえず、役に立たない例としてFizzBuzzに挑戦してみることにしました。

prognコンビネーションは動作は分かりやすいく適用可能なメソッドを全部適用して行くものです。

適用の順番は、特定度の高いものから適用されますが、オプションで逆順にすることもできます(これはstandard等でも同じ)。

ということで、

(1) ONEから、|ONE HUNDRED|までのクラスを作成し

(2) TWOはONEを継承、THREEは、TWOを...と順に継承するクラス群を作成し、

(3) それぞれにメソッドを付け、

(4) このままだと100が一番先に実行されるので、:most-specific-lastで優先順位を逆転する指定

という風にしてみました。

さすがに手書はきびしいのでマクロです。

ちなみにdefine-method-combinationでメソッドコンビネーションに数字を使う定義もできるようなので、次はそれに挑戦してみたいと思います。

それだと、(defmethod fizzbuzz 3 (class) ..)のようになりそうです。

;; 総称関数を作成
(defgeneric fizzbuzz (class-num)
  (:method-combination progn :most-specific-last))

(loop :for i :from 1 :to 100 :do (make-fizzbuzz i))

;; 実行
(fizzbuzz (make-instance '|ONE HUNDRED|))
;>>>
1
2
Fizz
4
Buzz
Fizz
7
8
Fizz
Buzz
11
Fizz
13
14
Fizz Buzz
16
17
Fizz
19
...

;; 型を定義して型で振り分けてみる
(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))

;; 作成用マクロ
(defmacro make-fizzbuzz (n)
  `(eval
    `(progn
       (defclass
             ,#1=(intern (format nil "~:@(~R~)" ,n)) 
             ,(if (zerop (1- ,n)) () `(,(intern (format nil "~:@(~R~)" (1- ,n))))) 
             () )
       (defmethod fizzbuzz progn ((cls ,#1#))
         (format T ,@(typecase ,n
                       (fizzbuzz (list "Fizz Buzz~%"))
                       (buzz (list "Buzz~%"))
                       (fizz (list "Fizz~%"))
                       (otherwise (list "~A~%" ,n))))))))

ツイートする

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

勉強会 | 00:44 |

昨日、11/8 20:00から23回目の勉強会を開催させて頂きました!

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

今回は、どう書くorgを眺めるです。

反省点

ノープランだったのですが、ノープランすぎたようです(^^;

雑談でも良いから毎週開催した方が良いのか、やるならきっちりやった方が良いのか迷うところです。

ログ:

• http://www.lingr.com/room/common-lisp-jp/archives/2008/11/08#msg-51685419

謝辞:

• scheme-users.jp - さん

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

• IT 勉強会カレンダーさん

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

ツイートする

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

Design Patterns, Common Lisp | 14:25 |

Norvig氏もGreg Sullivan氏のGOF Design Patterns in a Dynamic OO Languageでもファースト・クラスの関数は、Strategyパターンより応用がきく、というようなことを書いてますが、関数がファースト・クラスでない場合にはStrategyパターンで対処することになるのでしょう。

ということで、LISP系言語のsort関数は比較関数を動作にとって動作を変えるのが極普通ですが、関数を直接引数に取らない縛りでqsortを書いてみました。

昇順と、降順の2つがそれぞれ戦略になります。もちろんqsort総称関数以外の戦略も追加すれば可能です。

感想としては、これもStateや、Template-Method等に似てるなあという感じですが、ずばりファースト・クラスの関数があればあまり使うこともないパターンかなとも思えました。

(defpackage :design-patterns (:use :cl))
(in-package :design-patterns)

(defclass gt () ())
(defclass lt () ())
(defun make-strategy (strategy)
  (make-instance strategy))

(defgeneric qsort (class numlist)
  (:method (class numlist) () ))

(defmethod qsort ((strategy lt) lst)
  (if (null lst)
      ()
      (destructuring-bind (p &rest rest) lst
        `(,@(qsort strategy 
                   (remove-if-not (lambda (x) (> p x)) rest))
            ,p
            ,@(qsort strategy
                     (remove-if-not (lambda (x) (<= p x)) rest))))))

(defmethod qsort ((strategy gt) lst)
  (if (null lst)
      ()
      (destructuring-bind (p &rest rest) lst
        `(,@(qsort strategy 
                   (remove-if-not (lambda (x) (< p x)) rest))
            ,p
            ,@(qsort strategy
                     (remove-if-not (lambda (x) (>= p x)) rest))))))

;; 動作
(qsort (make-strategy 'lt)
       '(2 1 3 4 5 5 5 5 5 100 -1))
;=> (-1 1 2 3 4 5 5 5 5 5 100) 

(qsort (make-strategy 'gt)
       '(2 1 3 4 5 5 5 5 5 100 -1))
;=> (100 5 5 5 5 5 4 3 2 1 -1) 

;; ここまででも良さそうなもの


;; さらに動作の切り替え
(defclass qsorter ()
  ((strategy :accessor strategy :initarg :strategy)))

(defun make-qsorter (&key strategy)
  (make-instance 'qsorter :strategy strategy))

(defgeneric qsorter (qsorter list)
  (:method ((qsorter qsorter) list)
    (qsort (strategy qsorter) list)))

;; 動作
(let ((qs (make-qsorter :strategy (make-strategy 'gt))))
  ;; 降順
  (print (qsorter qs '(2 1 3 4 5 5 5 5 5 100 -1)))

  ;; 昇順に切り替え
  (setf (strategy qs) (make-strategy 'lt))
  (print (qsorter qs '(2 1 3 4 5 5 5 5 5 100 -1))))

;>>>
(100 5 5 5 5 5 4 3 2 1 -1) 
(-1 1 2 3 4 5 5 5 5 5 100) 

;; 比較:ファースト・クラスの関数の場合
(defun qsort++ (lst compfn)
  (if (null lst)
      ()
      (destructuring-bind (p &rest rest) lst
        (let ((comp (lambda (x) (funcall compfn p x))))
          `(,@(qsort++ (remove-if-not comp rest) compfn)
              ,p
              ,@(qsort++ (remove-if comp rest) compfn))))))


(let* ((comp #'>)
       (qs (lambda (data) (qsort++ data comp))))
  ;; 降順
  (print (funcall qs '(2 1 3 4 5 5 5 5 5 100 -1)))
  
  ;; 昇順に切り替え
  (setq comp #'<)
  (print (funcall qs '(2 1 3 4 5 5 5 5 5 100 -1))))

;>>>
(-1 1 2 3 4 5 5 5 5 5 100) 
(100 5 5 5 5 5 4 3 2 1 -1) 

■

ツイートする

11/8 第23回 慢性的CL勉強会@Lingr8時だョ!全員集合告知

勉強会 | 20:33 |

今回は、先週時間が足らなくて見送りになった「どう書くorgを眺める」をお題にしてみたいと思います。

どう書くorgにも100を越えるCLのコードが蓄積されています。これらのコードを先頭からレビューしたりして眺めつつ勉強というのはどうかなという企画です。

解答されていない問題に挑戦してみるのもありかなと思いますが、簡単でないので解答されてないことが多いので時間的にちょっと厳しいんじゃないかなと思います。

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

• Lingr: Common Lisp部屋

■

ツイートする

ContextLとデザインパターン - Template Method

Design Patterns, ContextL | 01:19 |

ContextLの概要の説明を読んで、最初にぱっと思いついたのは、デザインパターンでのTemplate Method的な動きがContextLを使えば簡単に記述できるのではないかということでした。

デザインパターンでは、クラスを利用して色々な状況の切り換えパターンが紹介されています。

ContextLでは、クラスの代りにレイヤ機能によって色々と切り換えることができるのですが、その名前の通りコンテクストを切り換えるようなパターンには応用できそうだと思いました。

ということで記念カキコ。

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

(in-package :design-patterns)

(use-package :contextl)

;; テンプレート
(define-layered-function template (string)
  (:documentation "テンプレ"))
(define-layered-method template ((string string))
  (op2 (op1 string)))

(define-layered-function op1 (string)
  (:documentation "処理その1"))
(define-layered-method op1 ((string string))
  string)

(define-layered-function op2 (string)
  (:documentation "処理その2"))
(define-layered-method op2 ((string string))
  string)

;; テンプレに従った詳細な実装 その1
(deflayer concrete)

(define-layered-method op1 :in concrete ((string string))
  (string-upcase string))

(define-layered-method op2 :in concrete ((string string))
  (format t "~A~%" string)))

;; テンプレに従った詳細な実装 その2
(deflayer concrete2)

(define-layered-method op1 :in concrete2 ((string string))
  (string-capitalize string))

(define-layered-method op2 :in concrete2 ((string string))
  (princ string)
  (terpri)))

;; テンプレに従った詳細な実装 その2を継承したその3
(deflayer concrete3 (concrete2))

(define-layered-method op2 :in concrete3 ((string string))
  (princ "**")
  (princ string)
  (princ "**")                 
  (terpri))


;;; 動作

;; Tは一番下のルートレイヤ
(with-active-layers (t)
  (template "foo bar baz"))
;=> "foo bar baz"

(with-active-layers (concrete)
  (template "foo bar baz"))
;>>> FOO BAR BAZ
(with-active-layers (concrete2)
  (template "foo bar baz"))
;>>> Foo Bar Baz

(with-active-layers (concrete3)
  (template "foo bar baz"))
;>>> **Foo Bar Baz**

■

ツイートする

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

勉強会 | 22:49 |

昨日、11/1 20:00から22回目の勉強会を開催させて頂きました!

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

今回は、今週のCL的活動報告と、どう書くorgのCLコードレビューでした。CLコードレビューは時間が足りなかったため見送りになりました。

良かったところ

とりあえず、CL的活動報告というネタでも、1時間くらいは持つんだということが分かりました(笑)

普段皆さんが、CLでどういう活動をしているかが伺い知れて面白かったです。

またCLについての質問も受けつけてみたのですが、色々とためになることがありました。

反省点

時間が足りず、どう書くorgのレビューができませんでした。

ちょっとまったりムードになるかと思ったのですが、まったりしすぎたかもしれません。

ログ:

• http://www.lingr.com/room/common-lisp-jp/archives/2008/11/01#msg-51069484

謝辞:

• scheme-users.jp - さん

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

• IT 勉強会カレンダーさん

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

ツイートする

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

Design Patterns, Common Lisp | 14:25 |

次に学ぶ対象とするパターンを物色しているのですが、ざっと眺めてみても、まず概念がぱっと理解できないことが多く、随分逡巡しています。

そんなこんななのですが、昨日公開された(no title)を読んで何となくInterpreterパターンのコンセプトは理解できた気がしたので、早速CLで実習してみました。

とはいえ、Obj-Cの読み方が全然分からないので、何となくの雰囲気で写経しています。

とりあえず、一つの動作に一つのクラスを対応させてみるということが骨子なんでしょうか。

これまで、自分が眺めてみた3パターンは、どれも動作の切り替えにクラスを利用するもので、この系統しか理解できてない気もしますが、クラスってこういう風にも使って良いんだということを学べたのは収穫じゃないかと思っています。

でも、Interpreterパターンは、あんまり使わなそうですね…。

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

;; boole
(defclass boolean-exp () ())

(defgeneric evaluate (type context))
(defmethod evaluate ((type boolean-exp) context)
  :nop)

;; and
(defclass and-exp (boolean-exp)
  ((operand1 :initarg :operand1 :reader operand1)
   (operand2 :initarg :operand2 :reader operand2)))

(defun make-and-exp (op1 op2)
  (make-instance 'and-exp :operand1 op1 :operand2 op2))

;; or
(defclass or-exp (boolean-exp)
  ((operand1 :initarg :operand1 :reader operand1)
   (operand2 :initarg :operand2 :reader operand2)))

(defun make-or-exp (op1 op2)
  (make-instance 'or-exp :operand1 op1 :operand2 op2))

;; not
(defclass not-exp (boolean-exp)
  ((operand :initarg :operand :reader operand)))

(defun make-not-exp (op)
  (make-instance 'not-exp :operand op))

;; 定数
(defclass constant (boolean-exp)
  ((value :initarg :value :reader value)))

(defun make-constant (value)
  (make-instance 'constant :value value))

;; 変数
(defclass variable-exp (boolean-exp)
  ((name :initarg :name :reader name)))

(defun make-variable-exp (name)
  (make-instance 'variable-exp :name name))

;; 評価器
(defmethod evaluate ((type and-exp) context)
  (and (evaluate (operand1 type) context)
       (evaluate (operand2 type) context)))

(defmethod evaluate ((type or-exp) context)
  (or (evaluate (operand1 type) context)
      (evaluate (operand2 type) context)))

(defmethod evaluate ((type not-exp) context)
  (not (evaluate (operand type) context)))

(defmethod evaluate ((type constant) context)
  (value type))

(defmethod evaluate ((type variable-exp) context)
  (lookup/name context (name type)))

;; コンテクスト
(defclass context () 
  ((namedict :accessor namedict
             :initform (make-hash-table))))

(defgeneric lookup/name (context name))
(defmethod lookup/name ((c context) name)
  (gethash name (namedict c)))

(defgeneric assign-value (context name value))
(defmethod assign-value ((c context) name value)
  (setf (gethash name (namedict c)) value))

;;;
;;; 動作
;;;

;;; (YES and x) or (y and (not x)) の評価
(let* (
       ;; 変数'x'と'y'を作成する
       (x (make-variable-exp 'x))
       (y (make-variable-exp 'y))
       
       ;; 定数'YES'を作成する。
       (yes (make-constant 'T))   
       
       ;; 'not x'を表す式を作成する。
       (not-exp (make-not-exp x))
       
       ;; 'YES and x'を表す式を作成する。
       (and-exp1 (make-and-exp yes x))    
       
       ;; 'y and not(x)'を表す式を作成する。
       (and-exp2 (make-and-exp y not-exp))
       
       ;; '(YES and x) or (y and not(x))'を表す式を作成する。
       (exp (make-or-exp and-exp1 and-exp2))
       (context (make-instance 'context))
       )
  ;; 変数'x'にYESを、変数'y'にNOを設定する。
  (assign-value context 'x 'T)
  (assign-value context 'y nil)

  ;; 評価
  (evaluate exp context) )
;=> T

■

ツイートする