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 |

2010-12-11

メタプログラミングRuby的CLOS (2)

| 21:49 | メタプログラミングRuby的CLOS (2) - わだばLisperになる を含むブックマーク はてなブックマーク - メタプログラミングRuby的CLOS (2) - わだばLisperになる

メタプログラミングRubyで見掛けたものを考えることの2回目

同じコードを何度も書くのが面倒臭いですしおすし

こういう場合は、CLの場合、クラスは関係なしで、そのものずばりマクロかなと思いました。

(macrolet ((define-component (name)
             `(let ((info ...)
                   (price ...))
                (def ...))))
  (define-component mouse)
  (define-component cpu)
  (define-component keyword))

のような。

もっとクラスの情報をクラス定義自体から引き出して動的に生成したい、ということになると構文上での操作ではなく、クラスオブジェクトの操作になってくるんだと思いますが、構文上の操作だけなら、やっぱりマクロが簡単だと思います。

3回目につづく

2010-12-10

メタプログラミングRuby的CLOS (1)

| 19:43 | メタプログラミングRuby的CLOS (1) - わだばLisperになる を含むブックマーク はてなブックマーク - メタプログラミングRuby的CLOS (1) - わだばLisperになる

巷では、メタプログラミングRubyの評判が高い様子ですが、Common LispもCLOSという動的なオブジェクト指向システムを持っているぞ、ということでこの本で取り上げられている手法にちまちま対抗意識を燃やしてチャレンジしてみることにしました。

といっても全部やるのも大変なので目についたところを適当に再現して遊んでみます。

まず、RubyとCLOSで違うのは、CLOSはクラスの中でメソッドが定義されているわけではない、というところ。

この辺りのギャップが結構あります。

それはさておき、適当に真似てみます。

下準備

(defclass my-class () ())

;; make-instanceが長いので、newという別名を付けてみる
(setf (fdefinition 'new)
      (symbol-function 'make-instance))

(defvar *c* (new 'my-class))

メソッドを動的に呼ぶ

とりあえず普通の書き方
(defmethod my-method ((self my-class) arg)
  (* 2 arg))

(my-method *c* 8)
;=> 16
動的と思われる書き方
(let ((meth #'my-method))
  (funcall meth
           *c*
           8))
;=> 16

メソッドがファーストクラスなので変数に入れて呼べます。

メソッド名を文字列等から作成
;; MY-METHODという名前のシンボルを文字列から作成して呼び出し
(funcall (intern (concatenate 'string "MY" "-" "METHOD"))
         *c*
         8)
;=> 16

メソッドを動的に作る

作る方ですが、お手軽に行くならEVAL、他にはメソッドオブジェクトを色々直接操作という感じになると思います

定義する式を作成してEVAL
(let ((name (intern (concatenate 'string "MY" "-" "METHOD"))))
  (eval
   `(defmethod ,name ((self my-class) arg)
      (* 3 arg))))

(my-method *c* 3)
;=> 9
まるごと無名でも行けるぜ、ヒャッハーみたいな
(let* ((gf (new 'standard-generic-function))
       (meth (new 'standard-method
                  :function (lambda (args ignore)
                              (destructuring-bind (self arg)
                                                  args
                                (* arg 3)))
                  :lambda-list '(self arg)
                  :specializers (list (find-class 'my-class)
                                      (find-class t)))))
  (add-method gf meth)
  (funcall gf *c* 3))
;=> 9

まあ、長いですけども…

次回につづく

2009-06-06

bit別冊Common Lispオブジェクトシステム-CLOSとその周辺

| 21:38 | bit別冊Common Lispオブジェクトシステム-CLOSとその周辺 - わだばLisperになる を含むブックマーク はてなブックマーク - bit別冊Common Lispオブジェクトシステム-CLOSとその周辺 - わだばLisperになる

書評というよりメモです。

この本は、復刊ドットコムでも100票以上を獲得していたりするのですが、

果して復刊したりするのか!、古本屋で見付けた方は保護して愛読するか、Amazonのマーケットプレイスにでも是非出品を!

自分は幸運なことに近所の図書館で借りられるのですが、ひさびさに借りたついでにちょっとエントリにすることにしました。

とりあえず、この本の大体の構成ですが、

※(3章はMOPについて(X3J13 88-003)で含まれていない。)

という感じです。内容が翻訳でかつPDFでネットから入手可能なものはリンクをつけてみました。

333ページの本書ですが、第II部と、5章 共通例題による他の言語との比較+実装のソースコードで約250ページを占めています。

その第II部の CLOSの仕様 CLOS仕様書(X3J13 88-002R)ですが、これは、CLtL2日本語訳の28章の元となっていて、若干違うもの中身は大体一緒。

CLOSメタオブジェクトカーネル現状報告」も英語の元の論文はPDFで入手可能です。

「5章 共通例題による他の言語との比較」は面白い企画で、

にある例題Grapherを様々な言語で実装してみせるという内容。

TAOや、CommonObjects、Flavors、ESP等レアな言語での実装が載っています。

1〜3はCLOSの情報をググったり当時メジャーだった大元の論文を読んだりすれば大体カバーできるんじゃないかと思います。

まとめ

言語のオブジェクトシステムを設計するような方には参考になるかもしれませんが、普通のユーザがCLOSを知りたくて読んでも、実装やその仕様が決まってゆくプロセスを報告している割合が大き過ぎてなんだか良く分からない本である気がしないでもありません。

CLOSや、MOPについては、日本語に限らず書籍は少ないようなのですが、個人的には、本書や、Amazon CAPTCHAあたりの内容をカバーするような本を新刊で黒田さんが書いてくれたりしたら最高なのになあと思ったりしています。

CLOS MOPだけだと市場的に厳しいかもしれませんが、「MOP全般を元祖CLOS MOPを軸に解説」みたいな感じで実際のところはCLOSの本という感じならどうにかならないだろうか…(´▽`*)…ならないか…。

2008-11-16

MOPでFizzBuzz (2)

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

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

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

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

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

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

MOPでFizzBuzz (1.5)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

2008-11-13

MOPでFizzBuzz

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

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

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

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

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

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

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

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

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

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

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

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

2008-11-12

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

| 00:24 | メソッドコンビネーションでFizzBuzz (2.5) - わだばLisperになる を含むブックマーク はてなブックマーク - メソッドコンビネーションでFizzBuzz (2.5) - わだばLisperになる

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

これでも、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
...

2008-11-11

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

| 23:19 | メソッドコンビネーションでFizzBuzz (2) - わだばLisperになる を含むブックマーク はてなブックマーク - メソッドコンビネーションでFizzBuzz (2) - わだばLisperになる

前回、メソッド修飾子を数値で表現して、それで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))))))))

2008-11-10

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

| 13:22 | メソッドコンビネーションでFizzBuzz - わだばLisperになる を含むブックマーク はてなブックマーク - メソッドコンビネーションでFizzBuzz - わだばLisperになる

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

2008-10-29

ContextLを使ってみよう

| 12:08 | ContextLを使ってみよう - わだばLisperになる を含むブックマーク はてなブックマーク - ContextLを使ってみよう - わだばLisperになる

先日開催されたLisp50で作者のPascal Costanza氏によってデモされたこともあって、ちょっと話題になり気味のContextL。

以前から存在は知っていたのですが、コンテクスト指向とか、アスペクト指向というのがさっぱり理解できなかったので放置していました。

しかし、自分は、最近MOPづいているので、これは試してみた方が良いだろうということでとりあえず触ってだけはみることにしました。

インストールは、(asdf-install:install :contextl)のみでOK。

test/demo3.lispになんとなくの使い方と、本家サイトに論文があるので、それを眺めれば筋の良い人は理解できるんだと思います。

どうやらコンテクストという名のレイヤで階層を分けて、特定のレイヤで呼び出すとそのコンテクストに応じたメソッドが呼び出されるという仕組みのようです。

自分は筋が悪いので、良く分からないながらも適当に思い付いた利用法を書き散らかしてみることにしました。

とりあえず、クラスは定義しないで、メソッドのみを実行して遊んでみています。

(require :contextl)

(in-package :contextl-user)

;; 総称関数(defgenericみたいなもの)
(define-layered-function fib (number))

;; 基本
(define-layered-method fib ((n integer))
  (if (< n 2)
      n
      (+ (fib (1- n))
         (fib (- n 2)))))

;; 型宣言してみる/optimize-speedレイヤ
(deflayer optimize-speed)

(define-layered-method fib
  :in optimize-speed ((n integer))
  (declare (fixnum n))
  (if (< n 2)
      n
      (+ (fib (1- n))
         (fib (- n 2)))))

;; 末尾再帰で実装したもの/tail-recurレイヤ
(deflayer tail-recur)

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

;; 無理矢理まぜてみたもの/mixedレイヤ
(deflayer mixed)

(define-layered-method fib
  :in mixed ((n integer))
  (declare (fixnum n))
  (if (< n 2)
      n
      (+ (with-active-layers (tail-recur)
           (fib (1- n)))
         (with-active-layers (optimize-speed)
           (fib (- n 2))))))

;; 試してみる
(progn
  (time (fib 30))

  (time 
   (with-active-layers (optimize-speed)
     (fib 30)))
  
  (time 
   (with-active-layers (tail-recur)
     (fib 30)))
  
  (time 
   (with-active-layers (mixed)
     (fib 30))))

;; >>>
Evaluation took:
  0.231 seconds of real time
  0.228015 seconds of total run time (0.228015 user, 0.000000 system)
  98.70% CPU
  554,444,019 processor cycles
  365,728 bytes consed
  
Evaluation took: optimize-speed
  0.179 seconds of real time
  0.180011 seconds of total run time (0.180011 user, 0.000000 system)
  100.56% CPU
  430,328,007 processor cycles
  219,808 bytes consed
  
Evaluation took: tail-recur
  0.000 seconds of real time
  0.000000 seconds of total run time (0.000000 user, 0.000000 system)
  100.00% CPU
  8,469 processor cycles
  3,008 bytes consed
  
Evaluation took: mixed
  0.039 seconds of real time
  0.040002 seconds of total run time (0.040002 user, 0.000000 system)
  102.56% CPU
  93,135,816 processor cycles
  0 bytes consed

まだ、レイヤが入れ子になった場合にどのレイヤが有効になるのか等、詳しく分っていませんが、なかなか面白そうです。

とか書いてみたんですが、さらに眺めてみると、fibonacci-test.lispというもっと高度なことをやってるファイルがありました…。

2008-06-20

無限小/大との比較

| 16:42 | 無限小/大との比較 - わだばLisperになる を含むブックマーク はてなブックマーク - 無限小/大との比較 - わだばLisperになる

bit別冊 Common Lisp オブジェクトシステム - CLOSとその周辺を眺めていたところ、無限小や、無限大を定義し、総称関数でラップすることによって、数値の無限大/小との比較ができるだろう、というような文を読んで、「なるほど!、面白そうだ」と思ったので、早速試してみました。

  • inf.0 +inf.0という表現は、R6RSから、拝借しましたが、なんとなくキーワードにしました。
(defgeneric binary> (object1 object2)
  (:documentation "object1 object2 ==> boolean"))

(defmethod binary> ((obj1 (eql :+inf.0)) (obj2 (eql :-inf.0))) 'T)
(defmethod binary> ((obj1 (eql :+inf.0)) (obj2 (eql :+inf.0))) NIL)
(defmethod binary> ((obj1 (eql :-inf.0)) (obj2 (eql :-inf.0))) NIL)
(defmethod binary> ((obj1 number)        (obj2 (eql :-inf.0))) 'T)
(defmethod binary> ((obj1 (eql :-inf.0)) (obj2 number))        NIL)
(defmethod binary> ((obj1 number)        (obj2 number))        (> obj1 obj2))
(defmethod binary> ((obj1 (eql :-inf.0)) (obj2 (eql :+inf.0))) NIL)
(defmethod binary> ((obj1 number)        (obj2 (eql :+inf.0))) NIL)

;; LEXPR版
(defmethod g> (obj &rest objs)
  (loop :for prev := obj :then item
        :for item :in objs
         :always (binary> prev item)))

という感じで、割とごちゃごちゃな定義です。binary>という名前は、S式Dylanから拝借しましたが、面倒なので他の述語を作る気にはなれませんでした(;´Д`)

使い方

(defun max-number (lst)
  (flet ((pick-greater (a b)
           (if (binary> a b) a b)))
    (reduce #'pick-greater lst :initial-value :-inf.0)))

(max-number (list  1 :-inf.0 most-negative-long-float))
;=> 1

という風に、使えるんだと思います。

関数版

Dylanは、=等は総称関数で、文字列との比較にも使えますが、数値に限定するなら、関数でも良いかなと思って試してみました。

(deftype number* ()
  `(or number (member :-inf.0 :+inf.0)))

(defun bin> (x y)
  (declare (number* x y))
  (cond ((eql x y) NIL)
        ((eql :-inf.0 x) NIL)
        ((eql :-inf.0 y) 'T)
        ('T (> x y))))

(bin> most-negative-fixnum :-inf.0)
;=> t

という感じで、あっさり書けてしまいました…。

総称関数の場合、定義を生成してくれるマクロを書くと良いのかもしれません。

2008-06-13

CLOSでL-99 (P26 指定した個数を抜き出す組み合わせ)

| 18:14 | CLOSでL-99 (P26 指定した個数を抜き出す組み合わせ) - わだばLisperになる を含むブックマーク はてなブックマーク - CLOSでL-99 (P26 指定した個数を抜き出す組み合わせ) - わだばLisperになる

call-next-methodの連鎖で行くと、stringの次は、vectorになってしまって面倒臭いので、combination1という共通の補助メソッドを作成して呼んでいるわけなのですが、一番特定度の低いメソッドを呼び出す定番の方法があったりするんでしょうか?

再帰と、call-next-methodと、ディスパッチが混ざると、大分スパゲッティな感じです…。

再帰の度にlengthが呼ばれるのもどうしたものかと…。

(combination 3 '(a b c d e f))
;==> ((A B C) (A B D) (A B E) (A B F) ...

(combination 3 #(a b c d e f))
;==> (#(A B C) #(A B D) #(A B E) #(A B F) ...

(combination 3 "abcdef")
;==> ("abc" "abd" "abe" "abf" "acd" "ace" "acf" ...

(defgeneric COMBINATION (n sequence)
  (:documentation 
   "P26 (**) Generate the combinations of K distinct objects 
chosen from the N elements of a list"))

(defmethod COMBINATION :around ((n integer) (sequence sequence))
  (if (not (<= 1 n (length sequence)))
      ()
      (call-next-method)))

(defmethod COMBINATION ((n integer) (sequence string))
  (combination1 n sequence 'string))
(defmethod COMBINATION ((n (eql 1)) (sequence string))
  (map 'list #'string sequence))

(defmethod COMBINATION ((n integer) (sequence vector))
  (combination1 n sequence 'vector))
(defmethod COMBINATION ((n (eql 1)) (sequence vector))
  (map 'list #'vector sequence))

(defmethod COMBINATION ((n integer) (sequence list))
  (combination1 n sequence 'list))
(defmethod COMBINATION ((n (eql 1)) (sequence list))
  (map 'list #'list sequence))

(defmethod COMBINATION1 ((n integer) (sequence sequence) type)
  `(,@(mapcar (lambda (i) (concatenate type (subseq sequence 0 1) i))
              (COMBINATION (1- n) (subseq sequence 1)))
      ,@(COMBINATION n (subseq sequence 1))))

2008-06-09

CLOSでL-99 (P25 ランダムに並び換え)

| 00:29 | CLOSでL-99 (P25 ランダムに並び換え) - わだばLisperになる を含むブックマーク はてなブックマーク - CLOSでL-99 (P25 ランダムに並び換え) - わだばLisperになる

以前に作ったものを組み合わせて解答せよとのことなのですが、以前に作ったremove-atが予期せぬ動きをしていたため、はまってしまいました。

原因は、

(concatenate (class-of '(a)) () ())

のような処理の個所で、class-ofでは、consと判定されるのですが、結果は、()なので、クラスはCONSではなくなってしまうということでした。

LISTならば、CONS+NULLなので大丈夫ですがLISTとCONSの扱いの違いで割とはまることが多いです(;´Д`)

(rnd-permu '(a b c d e f))
;==> (E A D F C B)
(rnd-permu #(a b c d e f))
;==> #(F E A C B D)
(rnd-permu "abcdef")
;==> "fdbaec"

(defgeneric RND-PERMU (sequence)
  (:documentation 
   "P25 (*) Generate a random permutation of the elements of a list."))

(defmethod RND-PERMU ((sequence sequence))
  (RND-SELECT sequence (length sequence)))

;; 修正版
(defmethod REMOVE-AT ((sequence sequence) (position integer))
  (let ((class (if (listp sequence) 'list (class-of sequence))))
    (values (concatenate class
                         (subseq sequence 0 (1- position)) 
                         (subseq sequence position))
            (elt sequence (1- position)))))

2008-05-30

CLOSでL-99 (P24 ロトくじ)

| 23:54 | CLOSでL-99 (P24 ロトくじ) - わだばLisperになる を含むブックマーク はてなブックマーク - CLOSでL-99 (P24 ロトくじ) - わだばLisperになる

以前に作成したrangeと、rnd-selectを組み合わせる、というお題です。

あまり必要ないけれどメソッド結合。

どうやら数が大きくなってしまう場合は、このお題の方法より、シャッフルして先頭のN個を取得、という風にした方が速いみたいです…。

(defgeneric lotto-select (n range)
  (:documentation
   "P24 (*) Lotto: Draw N different random numbers from the set 1..M.
 The selected numbers shall be returned in a list."))

(defmethod lotto-select :around ((n integer) (range integer))
  (and (<= 1 n range)
       (call-next-method)))

(defmethod lotto-select ((n integer) (range integer))
  (rnd-select (coerce (vec-from-1-to range) 'list) n))

(defun vec-from-1-to (end)
  (declare ((integer 1 *) end))
  (loop :with res := (make-array end)
        :for i :from 0 :below end 
        :do (setf (svref res i) (1+ i))
        :finally (return res)))

2008-05-24

CLOSでL-99 (P23 ランダムに指定した個数を選択)

| 13:08 | CLOSでL-99 (P23 ランダムに指定した個数を選択) - わだばLisperになる を含むブックマーク はてなブックマーク - CLOSでL-99 (P23 ランダムに指定した個数を選択) - わだばLisperになる

P20で定義したREMOVE-ATを使えとありますが、L-99の元になったP-99では、REMOVE-ATが結果と残りのリストの両方を結果として返すものなので、このお題で使えるということのようです。

ということで、REMOVE-ATを修正して使ってみました。

しかし無駄に長いなあ…。

(rnd-select '(a b c d e f g h) 3)
;=> (G A F)

(rnd-select #(a b c d e f g h) 3)
;=> #(D E G)

(rnd-select "abcdefgh" 3)
;=> "gbc"

(defgeneric RND-SELECT (sequence number)
  (:documentation
"P23 (**) Extract a given number of randomly selected elements from a list.
    The selected items shall be returned in a list." ))

(defmethod RND-SELECT :around ((sequence sequence) (count integer))
  (let ((len (length sequence)))
    (cond ((zerop len) sequence)
          ((or (> 1 count) (< len count)) 
           (MAKE-EMPTY-SEQUENCE sequence))
          ('T (call-next-method sequence count)))))

(defmethod RND-SELECT ((sequence sequence) (count integer))
  (loop :with seq := sequence
        :with res := ()
        :for len := (length seq) :then (1- len) 
        :for i :from count :downto 1 :when (> 1 count) :do (loop-finish)
        :do (multiple-value-bind (s item) (REMOVE-AT seq (1+ (random len)))
              (push item res)
              (setq seq s))
        :finally (return (coerce res (class-of sequence))))))

(defgeneric REMOVE-AT (sequence position)
  (:documentation "P20 (*) Remove the K'th element from a list."))

(defmethod REMOVE-AT ((sequence sequence) (position integer))
  (values (concatenate (class-of sequence)
                       (subseq sequence 0 (1- position)) 
                       (subseq sequence position))
          (elt sequence (1- position))))

(defgeneric make-empty-sequence (obj))
(defmethod make-empty-sequence ((obj list)) 
  () )
(defmethod make-empty-sequence ((obj vector))
  (make-array 0))
(defmethod make-empty-sequence ((obj string))  
  (make-string 0))

2008-05-18

CLOSでL-99 (P22 指定した範囲の数列のリスト)

| 03:52 | CLOSでL-99 (P22 指定した範囲の数列のリスト) - わだばLisperになる を含むブックマーク はてなブックマーク - CLOSでL-99 (P22 指定した範囲の数列のリスト) - わだばLisperになる

色々な型に対応しつつ、コードの重複を避けるように考えているのですが、いまいちCLOS流というのが掴めていません…。

今回は、フロントに総称関数を置いて共通部分は、関数に括り出すという感じにしてみました。

;(range 4 9)
;=> (4 5 6 7 8 9)

;(mapc #'princ (range #\あ #\お))
;=> あぃいぅうぇえぉお

(defgeneric RANGE (start end)
  (:documentation
   "P22 (*) Create a list containing all integers within a given range."))

(defmethod RANGE ((start integer) (end integer))
  (RANGE1 start end #'values))

(defmethod RANGE ((start character) (end character))
  (let ((start (char-code start))
        (end (char-code end)))
    (RANGE1 start end #'code-char)))

(defun RANGE1 (start end fn)
  (declare (integer start end))
  (if (< start end)
      (loop :for i :from start :to end :collect (funcall fn i))
      (loop :for i :from start :downto end :collect (funcall fn i))))