sheepleでオブジェクトを作る
CLikiのRecent Changesを購読していると、色々なプログラムの更新が分かります。
今日はsheepleというオブジェクトシステムについての記事が更新されていました。
http://www.cliki.net/Sheeple
http://common-lisp.net/project/sheeple/
asdf-installでインストールもできます。
sheepleでのオブジェクトの作りかた
objectもしくはcloneで新しいオブジェクトを作ります。
オブジェクトはpropertyを持ち、property-valueでアクセスできます。また、property-valueはsetf可能です。
propertyはCLOSのslotにあたるものですね。
propertyはCLOSとは異なり、オブジェクト作成後、勝手に追加できます。
propertyに関するメタ情報も取得できます。
available-propertiesでオブジェクトが使用できるpropertyのリストを得られます。
direct-propertiesでそのオブジェクトが直接持っているpropertyのリストを得られます。
;; 点オブジェクトを作る (defvar *point* (object)) (setf (property-value *point* 'x) 10) ;; => 10 (setf (property-value *point* 'y) 20) ;; => 20 (direct-properties *point*) ;; => (Y X) (available-properties *point*) ;; => (Y X SHEEPLE::NICKNAME) ;; 点オブジェクトを元に点2を作る(delegationで) (defvar *point2* (object :parents (list *point*))) (direct-properties *point2*) ;; => NIL (available-properties *point2*) ;; => (Y X SHEEPLE::NICKNAME) ;; property X Yへのアクセスは*point*へdelegateされる (property-value *point2* 'x) ;; => 10 (setf (property-value *point* 'x) 15) ;; => 15 (property-value *point2* 'x) ;; => 15 ;; プロパティを更新(Xのdelegateがshadowされる) (setf (property-value *point2* 'x) 30) ;; => 30 (property-value *point2* 'x) ;; => 30 (property-value *point* 'x) ;; => 15 (direct-properties *point2*) ;; => (X) (available-properties *point2*) ;; => (Y X SHEEPLE::NICKNAME) ;; 点オブジェクトを元に点3を作る(cloneで) (defvar *point3* (clone *point*)) (property-value *point3* 'x) ;; => 15 (property-value *point3* 'y) ;; => 20 (direct-properties *point3*) ;; => (Y X) (available-properties *point3*) ;; => (Y X SHEEPLE::NICKNAME)
with-slotsに似た、with-propertiesもあります。
(with-properties (x y) *point* (list x y)) ;; => (15 20)
ディスパッチ機構は、またの機会に。
CLOSでslotにアクセス
自分は、CLOSでメソッドを書いてるとwith-slots/with-accessorを多用します。
slotが増えてくるとめんどいので、with-all-slotsなるモノがあればいいなと妄想。
sbclで実装してみました。
slotを確定させるためにクラスを明にfinalize-inheritanceしないとならないのが難点。
(defmacro with-all-slots ((obj class &optional prefix) &body body) (let ((all-slots (mapcar #'sb-mop:slot-definition-name (sb-mop:class-slots (find-class class))))) `(with-slots (,@(mapcar #'(lambda (slot) (list (intern (concatenate 'string (string (or prefix "")) (string slot))) slot)) all-slots)) ,obj ,@body))) (eval-when (:compile-toplevel :load-toplevel :execute) (defclass hoge () (a b c)) (defclass huga (hoge) (d e f)) (sb-mop:finalize-inheritance (find-class 'hoge)) (sb-mop:finalize-inheritance (find-class 'huga))) (defun aa (hu1 hu2) (with-all-slots (hu1 huga hu1.) (with-all-slots (hu2 huga hu2.) (setf hu1.f 'f hu2.f 'ff) (setf hu1.a hu2.f)))) (let ((h1 (make-instance 'huga)) (h2 (make-instance 'huga))) (aa h1 h2) (slot-value h1 'a)) ;; => FF
ClojureのtrampolineをCLで
Programing Clojureを読んでいたところ、相互再帰のためのツールとしてtrampolineという関数が紹介されていました。クロージャが返される限り、返されたクロージャを呼び続ける関数のようです。
現状のClojureは末尾呼び出しの最適化を行わないため、trampolineが必要なようです。
CLで書くとこんな感じでしょうか？
(defun trampoline (func &rest args) (loop :for result = (apply func args) :then (funcall result) :unless (functionp result) :do (return result))) (defun odd-p (n) (if (= n 0) nil (lambda () (even-p (- n 1))))) (defun even-p (n) (if (= n 0) t (lambda () (odd-p (- n 1)))))
Mac OS X 10.5.7上のCCL-1.3での結果です。
CL-USER> (time (trampoline #'even-p 1000000))
(TRAMPOLINE #'EVEN-P 1000000) took 242,967 microseconds (0.242967 seconds) to run
with 2 available CPU cores.
During that period, 176,438 microseconds (0.176438 seconds) were spent in user mode
33,438 microseconds (0.033438 seconds) were spent in system mode
41,280 microseconds (0.041280 seconds) was spent in GC.
64,000,016 bytes of memory allocated.
T
CL-USER> (time (trampoline #'odd-p 1000000))
(TRAMPOLINE #'ODD-P 1000000) took 316,594 microseconds (0.316594 seconds) to run
with 2 available CPU cores.
During that period, 219,069 microseconds (0.219069 seconds) were spent in user mode
47,793 microseconds (0.047793 seconds) were spent in system mode
49,062 microseconds (0.049062 seconds) was spent in GC.
64,000,016 bytes of memory allocated.
NIL
CL-USER> ちゃんと動作しました。
ちなみに、以下のように普通に相互再帰として定義した場合、
(defun odd-p (n) (if (= n 0) nil (even-p (- n 1)))) (defun even-p (n) (if (= n 0) t (odd-p (- n 1))))
結果は、trampolineを使うよりかなり速くなりました。
CL-USER> (time (even-p 1000000))
(EVEN-P 1000000) took 9,237 microseconds (0.009237 seconds) to run
with 2 available CPU cores.
During that period, 5,285 microseconds (0.005285 seconds) were spent in user mode
98 microseconds (0.000098 seconds) were spent in system mode
T
CL-USER> (time (odd-p 1000000))
(ODD-P 1000000) took 7,651 microseconds (0.007651 seconds) to run
with 2 available CPU cores.
During that period, 7,327 microseconds (0.007327 seconds) were spent in user mode
57 microseconds (0.000057 seconds) were spent in system mode
NIL
CL-USER> disassembleの結果を見ると、CCLは末尾呼び出しを最適化してくれるようです。
悔しいので、末尾呼び出し最適化をしない処理系が無いか模索。
ACL8.1評価版で試してみます。
CL-USER> (time (odd-p 1000000))
デバッガが立ち上がりました。期待通りスタックオーバーフローしたようです。
Stack overflow (signal 1000) [Condition of type SYNCHRONOUS-OPERATING-SYSTEM-SIGNAL]
ここで先ほどのtrampolineを使うと…
CL-USER> (time (trampoline #'even-p 1000000)) ; cpu time (non-gc) 70 msec user, 0 msec system ; cpu time (gc) 30 msec user, 0 msec system ; cpu time (total) 100 msec user, 0 msec system ; real time 108 msec ; space allocation: ; 2 cons cells, 24,000,248 other bytes, 0 static bytes T CL-USER> (time (trampoline #'odd-p 1000000)) ; cpu time (non-gc) 60 msec user, 0 msec system ; cpu time (gc) 50 msec user, 0 msec system ; cpu time (total) 110 msec user, 0 msec system ; real time 109 msec ; space allocation: ; 2 cons cells, 24,000,024 other bytes, 0 static bytes NIL
ちゃんと計算出来ました。
なお、SBCL 1.0.28も末尾呼び出しの最適化をしてくれました。
ecl-0.9jは末尾呼び出しの最適化をしないようです。
リストの破壊的な操作
g000001さんの所のネタ。
http://cadr.g.hatena.ne.jp/g000001/20090521/1242909362
alistからplistへの破壊的な変換。
やってみたら、とっても直接的になった。
(defun nalist-to-plist (alist) (loop for x on alist by #'cddr do (let* ((cons1 x) (cons2 (car x)) (key (car cons2)) (elem (cdr cons2)) (rest (cdr x))) (setf (car cons1) key (cdr cons1) cons2 (car cons2) elem (cdr cons2) rest))) alist) (defun nplist-to-alist (plist) (loop for x on plist do (let* ((cons1 x) (cons2 (cdr x)) (key (car cons1)) (elem (car cons2)) (rest (cdr cons2))) (setf (car cons1) cons2 (cdr cons1) rest (car cons2) key (cdr cons2) elem))) plist) ;; CL-USER> (nplist-to-alist (nalist-to-plist (copy-list '((a . 1) (b . 1))))) ;; ((A . 1) (B . 1))
swank-gaucheを改良
Gauche用のSwankサーバ
Slimy hackathon#1には用事があって参加出来なかったのですが、何かやりたいなと思っていまして、gauche用のSwankサーバを書いてみることにしました。
mit-schemeのSwankやswank.lispのコード、あとは*slime-events*バッファへ表示される情報を基に、何とか遊べるレベルまでの実装にはなりました。
以下の様な機能を実装してあります。
- シンボルの補完 (c-p-c形式も)
- replでの評価 (read writeも可)
- 編集バッファでの評価(C-x C-e, C-c C-c どっちもやることは同じですが…)
以下のバージョンで確認しています。
- Slime 2009-03-09
- Gauche 0.8.13
以下の設定を.emacsに追加して、M-x gaucheでreplが起動出来ます。
(push "<path-to-slime-dir>/slime/contrib" load-path) (require 'slime-scheme) (slime-scheme-init) (setq slime-lisp-implementations '((gauche ("gosh") :init gauche-init))) (defun gauche-init (file encoding) (format "%S\n\n" `(begin (add-load-path "<path-to-swank-gauche-dir>") ;; add load path to swank-gauche.scm (require "swank-gauche") (import swank-gauche) (start-swank ,file)))) (defun gauche () (interactive) (slime 'gauche)) (defun find-gauche-package () (interactive) (let ((case-fold-search t) (regexp (concat "^(select-module\\>[ \t']*" "\\([^)]+\\)[ \t]*)"))) (save-excursion (when (or (re-search-backward regexp nil t) (re-search-forward regexp nil t)) (match-string-no-properties 1))))) (setq slime-find-buffer-package-function 'find-gauche-package)
試してみたい方は、こちら：
