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 |

2011-03-30

CMU AIレポジトリ探検 (5) CommonORBIT

| 19:05 | CMU AIレポジトリ探検 (5) CommonORBIT - わだばLisperになる を含むブックマーク はてなブックマーク - CMU AIレポジトリ探検 (5) CommonORBIT - わだばLisperになる

今回は、CommonORBITの紹介です。

CommonORBITについては、2年ほど前に紹介したことがあるのですが、80年代中盤頃に作成されたCL上のオブジェクト指向システムです。

CommonORBITの特徴としては今でいうプロトタイプベースであるということが挙げられます。

同時期のCLのオブジェクト指向拡張であるLMIのObject Lispもプロトタイプベースだったようなのでプロトタイプベースのものも結構あったんだなというところです。

近頃だと、Sheepleのようなものもあります。

動作例ですが、手抜きで以前に紹介したものを再掲します。

(in-package :corbit)

(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//"

もっと色々できますので、興味を持った方はお試しあれ。

今回も紹介ついでにASDFに対応させgithubに上げてみました

git clone git@github.com:g000001/CommonORBIT.git

でソースを取得でき、適切に設定すれば、

(ql:quickload :commonorbit)

でロードできます。

2011-03-28

CMU AIレポジトリ探検 (4) Artificial Flavors

| 19:07 | CMU AIレポジトリ探検 (4) Artificial Flavors - わだばLisperになる を含むブックマーク はてなブックマーク - CMU AIレポジトリ探検 (4) Artificial Flavors - わだばLisperになる

特に決まった順番もなく彷徨っておりますが、今回は、CLOS関係の階層からArtificial Flavorsです。

Flavorsとは、CLOS以前のオブジェクト指向プログラミングの仕組みで、Smalltalkから影響を受けて作られました。

というよりもMITのLISPマシン自体がかなりAltoに影響を受けていたようですし、PARCとも交流があったようです。

Flavorsには、Smalltalkから強く影響を受けている初期のものと、80年代中後半CLにオブジェクト指向システムを加えようというときにSymbolicsが提案した総称関数ベースのNew Flavorsとがありますが、今回のArtificial Flavorsは、New Flavorsっぽい感じになります。

実際のところNew Flavorsっぽいというよりは、CLOSにちょっとマクロを被せただけ、という感じです。

Artificial Flavorsを使うとこんな感じに書けます。

(in-package :artificial-flavors)

(defflavor rectangle (height width) ()
  :readable-instance-variables
  :writable-instance-variables
  :initable-instance-variables)

(defmethod (area rectangle) ()
  (* (rectangle-height self)
     (rectangle-width self)))

;; => マクロ展開
(CL:DEFMETHOD AREA ((SELF RECTANGLE))
  (SYMBOL-MACROLET ((HEIGHT (SLOT-VALUE SELF 'HEIGHT))
                    (WIDTH (SLOT-VALUE SELF 'WIDTH)))
    (* (RECTANGLE-HEIGHT SELF) (RECTANGLE-WIDTH SELF))))

;; Flavorのスロット名で参照できるので短かくも書ける
(defmethod (area rectangle) ()
  (* height width))

(let ((rect (make-instance 'rectangle :height 3 :width 4)))
  (area rect))
;=> 12

deffravorの :readable-instance-variables、 :writable-instance-variables、 :initable-instance-variablesというのは、指定するとdefstructのようにセッターやゲッターの設定を自動でしてくれるというものです。

defmethodも少し書式が違っていて、ボディ内ではSELFやスロット名で変数を呼び出せたりできるようです。

紹介ついでにASDFに対応させ、処理系依存っぽいところは、Closer to MOPを使うように修正したものをgithubに上げてみました

適切に設定すれば、

(ql:quickload :artificial-flavors)

でロードできます。

ちなみに、Allegro CLには、より本格的なFlavorsが付いてくるようですので興味のある方は遊んでみると良いかなと思います。

2011-03-27

CMU AIレポジトリ探検 (3) Uranus

| 23:14 | CMU AIレポジトリ探検 (3) Uranus - わだばLisperになる を含むブックマーク はてなブックマーク - CMU AIレポジトリ探検 (3) Uranus - わだばLisperになる

Uranusについては以前も取り上げたことがありましたが、

これもAIレポジトリで配布されているので再度紹介してみることにしました。

Uranusとは多重世界機構というものを持つS式で記述するPrologです

もともとの実装は、UtiLisp上で動くものでProlog/KRという名称だったようですが、Lispマシン(Zetalisp)上に移植したのを機にUranusと名称を変更したようです。

Prolog/KRについては書籍も発行されていて詳しく知ることができます

自分もAmazonで買って読んでみましたがUranus以外のことも色々書いてあって興味深い内容でした。

このUranusですが、

からダウンロードできるようになっています。

CLtL1までは対応しているようなのですが、紹介ついでに以前Zetalisp的なところをCL風にしてasdファイルをつけてSBCLで動くようにしたものをgithubに上げてみました。

適切に設定すれば、

(ql:quickload :uranus)

でロードできます。

元のソースには、Zmacs用のUranusモード等も付いてくるのでSLIMEで再現してみたいなーなどと思いつつまったく進んでいません…。

妙な変更を加えてしまっているところもあると思いますのでみつけたら教えて頂けると嬉しいです。

2011-03-25

バッククォート式のSETF

| 20:26 | バッククォート式のSETF - わだばLisperになる を含むブックマーク はてなブックマーク - バッククォート式のSETF - わだばLisperになる

ぼーっとCADR LispマシンのSystem 99(割と後期のバージョンで80年代中期?)のソースを眺めていたのですが、SETF関係の定義のところで見慣れないものをみつけました。

;;;  CADR System 99 sys2;setf.lisp.1

;;; Handle SETF of backquote expressions, for decomposition.
;;; For example, (SETF `(A ,B (D ,XYZ)) FOO)
;;; sets B to the CADR and XYZ to the CADADDR of FOO.
;;; The constants in the pattern are ignored.

;;; Backquotes which use ,@ or ,. other than at the end of a list
;;; expand into APPENDs or NCONCs and cannot be SETF'd.

;;; This was used for making (setf `(a ,b) foo) return t if
;;; foo matched the pattern (had A as its car).
;;; The other change for reinstalling this
;;; would be to replace the PROGNs with ANDs
;;; in the expansions produced by (LIST SETF), etc.
;;;(DEFUN SETF-MATCH (PATTERN OBJECT)
;;;  (COND ((NULL PATTERN) T)
;;;	((SYMBOLP PATTERN)
;;;	 `(PROGN (SETQ ,PATTERN ,OBJECT) T))
;;;	((EQ (CAR PATTERN) 'QUOTE)
;;;	 `(EQUAL ,PATTERN ,OBJECT))
;;;	((MEMQ (CAR PATTERN)
;;;	       '(CONS LIST LIST*))
;;;	 `(SETF ,PATTERN ,OBJECT))
;;;	(T `(PROGN (SETF ,PATTERN ,OBJECT) T))))

(SETF `(A ,B (D ,XYZ)) FOO)というのはこれ如何に、何やら面白そう、ということでソースをCommon Lispで動くように少し修正して動かしてみたところ

(let ((foo (list 1 2 (list (list 3) 4 5)))
      a b c d e f)
  (setf `(,a ,b ((,c) ,d ,e)) foo)
  (list a b c d e))
;=> (1 2 3 4 5)

のようなことができるようです。これは便利そう。

上の式は、

(LET ((FOO (LIST 1 2 (LIST (LIST 3) 4 5))) A B C D E F)
  (MULTIPLE-VALUE-BIND (|g2543|)
                       FOO
    (PROGN
      (SETQ A (NTH 0 |g2543|))
      (SETQ B (NTH 1 |g2543|))
      (LET* ()
        (MULTIPLE-VALUE-BIND (|g2544|)
                             (NTH 2 |g2543|)
          (PROGN
            (LET* ()
              (MULTIPLE-VALUE-BIND (|g2545|)
                                   (NTH 0 |g2544|)
                (PROGN (SETQ C (NTH 0 |g2545|)))))
            (SETQ D (NTH 1 |g2544|))
            (SETQ E (NTH 2 |g2544|)))))))
  (list a b c d e))
;=> (1 2 3 4 5)

のように展開されます。

以下、ANSI CLで動くようにしたもの (SBCLのみ対応)

#+sbcl (import 'sb-ext:without-package-locks)

(defun car-safe (form)
  (if (consp form)
      (car form)
      form))

(defun setf-match (pattern object)
  (cond ((eq (car-safe pattern) 'quote)
	 nil)
	(t `(setf ,pattern ,object))))

(without-package-locks
  (define-setf-expander list (&rest elts)
    (let ((storevar (gensym)))
      (values nil nil (list storevar)
              (do ((i 0 (1+ i))
                   (accum)
                   (args elts (cdr args)))
                  ((null args)
                   (cons 'progn (nreverse accum)))
                (push (setf-match (car args) `(nth ,i ,storevar)) accum))
              `(incorrect-structure-setf list . ,elts)))))

#+sbcl
(without-package-locks
  (define-setf-expander sb-impl::backq-list (&rest elts)
    (let ((storevar (gensym)))
      (values nil nil (list storevar)
              (do ((i 0 (1+ i))
                   (accum)
                   (args elts (cdr args)))
                  ((null args)
                   (cons 'progn (nreverse accum)))
                (push (setf-match (car args) `(nth ,i ,storevar)) accum))
              `(incorrect-structure-setf list . ,elts)))))

(without-package-locks
  (define-setf-expander list* (&rest elts)
    (let ((storevar (gensym)))
      (values nil nil (list storevar)
              (do ((i 0 (1+ i))
                   (accum)
                   (args elts (cdr args)))
                  ((null args)
                   (cons 'progn (nreverse accum)))
                (cond ((cdr args)
                       (push (setf-match (car args) `(nth ,i ,storevar)) accum))
                      (t (push (setf-match (car args) `(nthcdr ,i ,storevar)) accum))))
              `(incorrect-structure-setf list* . ,elts)))))

#+sbcl
(without-package-locks
  (define-setf-expander sb-impl::backq-list* (&rest elts)
    (let ((storevar (gensym)))
      (values nil nil (list storevar)
              (do ((i 0 (1+ i))
                   (accum)
                   (args elts (cdr args)))
                  ((null args)
                   (cons 'progn (nreverse accum)))
                (cond ((cdr args)
                       (push (setf-match (car args) `(nth ,i ,storevar)) accum))
                      (t (push (setf-match (car args) `(nthcdr ,i ,storevar)) accum))))
              `(incorrect-structure-setf list* . ,elts)))))

(without-package-locks
  (define-setf-expander cons (car cdr)
    (let ((storevar (gensym)))
      (values nil nil (list storevar)
              `(progn ,(setf-match car `(car ,storevar))
                      ,(setf-match cdr `(cdr ,storevar)))
              `(incorrect-structure-setf cons ,car ,cdr)))))

#+sbcl
(without-package-locks
  (define-setf-expander sb-impl::backq-cons (car cdr)
    (let ((storevar (gensym)))
      (values nil nil (list storevar)
              `(progn ,(setf-match car `(car ,storevar))
                      ,(setf-match cdr `(cdr ,storevar)))
              `(incorrect-structure-setf cons ,car ,cdr)))))

(defmacro incorrect-structure-setf (&rest args)
  (error "You cannot SETF the place ~S~% in a way that refers to its old contents." args))

CADRでは、listや、list*にしかSETFは定義されていませんが、SBCLの場合は、リーダーマクロはBACKQ-LIST等に展開されるので、そちらも対処。

SETFが再帰的に展開されるというのも面白いですが、なによりバッククォート式やリストにSETFを定義するという発想が素晴しいですね。

他には、LETやPROGNなどのSETFも定義されています。 (ちなみに、CLISPでは、IFなどにもSETFが定義されているようです。)

2011-03-20

CMU AIレポジトリ探検 (2) Source Compare

| 10:59 | CMU AIレポジトリ探検 (2) Source Compare - わだばLisperになる を含むブックマーク はてなブックマーク - CMU AIレポジトリ探検 (2) Source Compare - わだばLisperになる

かれこれ20年程前のCMUでは、CLでポータブルに利用できる開発ツールがないことをどうにかしようというLisp-Utilitiesというプロジェクトがあったようです。

Symbolicsや、XeroxのLISPマシンでは当時でも色々揃っており、開発ツール自体がなかった訳ではないので処理系を跨いでポータブルであることが主眼だった様子。

Mark Kantrowitz氏が中心人物のようで、

CMU-CS-91-143

Portable Utilities for Common Lisp: User Guide & Implementation Notes

Mark Kantrowitz

May 1991

74 pages

というレポートに6つのツールの内容が纏められています(自分もどこから拾ってきたのか分かりませんが、現在はダウンロードできるリンクがみつけられませんでした)

上記のレポートによれば、このプロジェクトの成果物は一式でダウンロードできるようですが、現在まとまってダウンロードできるところは消滅している様子。

しかし探してみるとCMUのAIリポジトリでそれぞれのツールが単体で配布されていることをみつけました。

今回は、その内の一つであるSource Compareについてです。

内容は、このリンクから分かると思いますが、所謂diffです。

(sc:source-compare "cadr78/lispm2/let.lisp.1" "cadr99/sys2/let.lisp.1")

のようにすると、

===========================================================================
Source compare of cadr78/lispm2/let.lisp.1 with cadr99/sys2/let.lisp.1
===========================================================================
14c14
**** File cadr78/lispm2/let.lisp.1, After "(remprop 'let* 'source-file-name)"
< (defmacro let (pairs . body)
<        (do ((pairs pairs (cdr pairs))
---
**** File cadr99/sys2/let.lisp.1, After "(remprop 'let* 'source-file-name)"
> (defmacro let (pairs &body body)
>        (do ((pairs pairs (cdr pairs))
===========================================================================
115c115
**** File cadr78/lispm2/let.lisp.1, After "(defun let-macro-hair (pattern code cell)"
< (defmacro let* (pairs . body)
<        (do ((a (reverse pairs) (cdr a))
---
**** File cadr99/sys2/let.lisp.1, After "(defun let-macro-hair (pattern code cell)"
> (defmacro let* (pairs &body body)
>        (do ((a (reverse pairs) (cdr a))
===========================================================================
Done.

のように結果が出力されます。

LISPのコメントを無視できたりしてLISPフレンドリーなのが長所でしょうか。(オプションで挙動を変更できます)

ちなみに、同じファイルをdiff -uすると、

diff -u cadr78/lispm2/let.lisp.1 cadr99/sys2/let.lisp.1
--- cadr/lispm2/let.lisp.1       2009-01-03 09:28:22.000000000 +0900
+++ cadr99/sys2/let.lisp.1       2009-01-03 14:37:00.000000000 +0900
@@ -1,4 +1,4 @@
-;;;-*- Mode: Lisp; Package: System-Internals -*-
+;;;-*- Mode:LISP; Package:SYSTEM-INTERNALS; Base:8 -*-

 ;; Destructuring DEFUN must be added to this at some point.

@@ -11,7 +11,7 @@
 (remprop 'let 'source-file-name)
 (remprop 'let* 'source-file-name)

-(defmacro let (pairs . body)
+(defmacro let (pairs &body body)
        (do ((pairs pairs (cdr pairs))
            (vars nil)
            (let-macro-vals nil)
@@ -112,7 +112,7 @@
               (let-macro-get-last-var (car pattern))
               (let-macro-get-last-var (cdr pattern))))))

-(defmacro let* (pairs . body)
+(defmacro let* (pairs &body body)
        (do ((a (reverse pairs) (cdr a))
            (b body `((let (,(car a)) . ,b))))
           ((null a)

こんな感じになります。

紹介ついでに、ASDF対応にして、githubにアップしてみました。

適切な場所に、

git clone git://github.com/g000001/source-compare.git

すれば、

;; quicklisp
(ql:quickload :source-compare)

できると思います。

2011-03-18

CMU AIレポジトリ探検 (1) VGRIND

| 18:55 | CMU AIレポジトリ探検 (1) VGRIND - わだばLisperになる を含むブックマーク はてなブックマーク - CMU AIレポジトリ探検 (1) VGRIND - わだばLisperになる

もうかれこれ15年位は更新されている様子がないのですが、CMU Artificial Intelligence Repositoryというカーネギー・メロン大学が公開しているAI関係のレポジトリがあります。

ここにはAIレポジトリというだけあってLISP関係のものも多く眠っています。

以前からこれを一通り確認してみたいと思っていたので確認の記録をつけてみることにしました。

適当に目についたところから眺めてみようかなと思いますが、今回は、VGRINDというのを眺めてみます。

中身は、1つのファイルですが

http://www-2.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/lisp/util/vgrind/vgrind.txt

一体何に使うのか不明です。

とりあえずvgrindをググってみると、プログラムを整形するフォーマッタの一種の様子。

Ubuntuでvgrindを探してみてもそのものずばりはありませんでしたが、名前が似ているlgrindというのを発見。

とりあえずこれで良いだろうということでインストール

sudo apt-get install lgrind

lgrindのヘルプを読みつつ、vgrind.txtの内容から適当に使い方を推測し、

$ lgrind -d vgrind.txt -lclisp /tmp/foo.lisp > /tmp/foo.tex
$ latex /tmp/foo.tex
$ evince foo.dvi

のようにしてみると整形されたコードが表示されます。

TeXが好きな方には良いかもしれません。

2011-03-07

CLMを試してみる

| 19:47 | CLMを試してみる - わだばLisperになる を含むブックマーク はてなブックマーク - CLMを試してみる - わだばLisperになる

CLMは音響を色々操作できるパッケージだそうで以前から一度試してみたかったのですが、なんとなく面倒臭さそうだなと思っていて手を付けずにいました。ふと、気まぐれにサイトからソースをダウンロードしてみたところ、中に.asdファイルがあり、想像していたより簡単に導入できそうなので試してみました。

CLMのソースが微妙にCLの作法に則ってない様子でインストールでも妙な躓き方をしますが、とりあえずは導入できたので手順をメモ。

環境は、SBCL 1.0.46、ASDF2、Ubuntu 10.10 64bitです。

ソースを入手

https://ccrma.stanford.edu/software/snd/snd/clm.html

からCLM-4のソースを入手します。

適当なASDFでロードできるところに展開します。

音響系ライブラリの準備

ALSAを使うので開発ライブラリをインストールしておきます。

$ sudo apt-get install libasound2-dev

また、シェルの実行にcshが使われるのでcshもインストールしておく必要があるかもしれません。自分はソースの方を書き換えました。

ロード

どうやら現状ではライブラリをロードした環境(パッケージ)に色々撒き散らすようなので専用のパッケージを作成して、その中に読み込みます。

(defpackage :clm-user
  (:use :cl))

(in-package :clm-user)

;; ソースのディレクトリを指定
(setq clm-directory ".../clm-4/")

(asdf:load-system :clm)

という感じでロードされます。

色々こけたりするかもしれませんが、適当に手で直したりします。

音を鳴らしてみる

〜.insファイルというのが音源が定義されたもののようで、サンプルとしてヴァイオリンが付いてくるのでマニュアルの通りコンパイルしてみます。

(compile-file ".../clm-4/v.ins")
(load ".../clm-4/v.fasl")

適当にいじってみる

使い方は良く分かりませんが、ランダムに音を鳴らす位のことはすぐできました。

WITH-SOUNDマクロで囲んでやると式を評価して音声ファイルを書き出し、音を鳴らしてくれるようです。

;; R2D2的なもの
(with-sound ()
  (dotimes (start 400)
    (let ((r (expt (expt 2 1/12) (random 48))))
      (fm-violin (* start 1/8)
                 1/4
                 (* 110 r)
                 1/10)
      (fm-violin (/ start 8)
                 1/8
                 (* 110
                    (aref #(11/2 13/4 3/4 9/4) (random 4))
                    r)
                 1/10)
      (fm-violin (+ (/ start 8) 1/16)
                 1/8
                 (* 110
                    (aref #(2 3/2 5/2 7/4) (random 4))
                    r)
                 1/10))))
;; マザーコンピュータ的なもの
(with-sound ()
  (dotimes (start 400)
    (let ((r (expt (expt 2 1/12) (random 48))))
      (fm-violin (/ start 8)
                 1/8
                 (* 220 r)
                 1/10)
      ;;
      (fm-violin (+ (* start 1/8) 1/32)
                 1/32
                 (* 440 r)
                 1/10)
      ;;
      (fm-violin (/ start 8)
                 1/8
                 (* 110 (elt #(11/4 3/2 3/4 9/4) (random 4)) r)
                 1/10)
      ;;
      (fm-violin (+ (/ start 8) 1/16)
                 1/8
                 (* 110 (elt #(2 3/2 5/2 7/4) (random 4)) r)
                 1/10)
      ;;
      (fm-violin (/ start 8)
                 1/8
                 (/ 880 r)
                 1/10))))

7平均律や、19平均律など簡単に試してみることができそうです。

その他、CLM情報

Luke Gorrie氏がECLM 2005でSLIMEのデモでCLMを取り上げたことがあったようでいくつか関連の記事/資料をみつけました。

まとめ

SchemeのImpromptuのようにリアルタイムで操作できるものなのかは、調べ切れていないので分からないのですが、自動作曲的なことに使ったり自分用のソルフェージュのプログラムを書いて音感の訓練をしてみたりは手軽にできそうです。

読み書きの速度 (3)

| 18:08 | 読み書きの速度 (3) - わだばLisperになる を含むブックマーク はてなブックマーク - 読み書きの速度 (3) - わだばLisperになる

SBCLでSYMBOL-VALUEでの書き込みが異様に遅い原因

SBCLだと (SETF SYMBOL-VALUE)がどういうわけか異様に遅いということが分かったのですが、Twitterでぶつぶつ言っていたらdisassembleすると良いよ!と言われたので、なるほどと思い、とりあえず定義を追い掛けてみました。

SBCLの場合、(SETF SYMBOL-VALUE)は、SETへ展開されるようで、そのSETは、SB-IMPL::%SET-SYMBOL-VALUEとSB-IMPL::ABOUT-TO-MODIFY-SYMBOL-VALUEを呼ぶようです。

SB-IMPL::%SET-SYMBOL-VALUEが本体のようなので、とりあえずこれを前回と同じように一億回呼んで測定してみます。

  0.125 sec. %SET-SYMBOL-VALUE-1-WRITE
 78.712 sec. SYMBOL-VALUE-1-WRITE

なるほど、%SET-SYMBOL-VALUEだと圧倒的に速いようです。

ということは、ABOUT-TO-MODIFY-SYMBOL-VALUEが遅いのかということで、これだけで計測してみましたが予想通りこの関数が原因でした。

この関数はどんな関数なのかと眺めてみると、コメントに

;;; This function is to be called just before a change which would affect the
;;; symbol value. We don't absolutely have to call this function before such
;;; changes, since such changes to constants are given as undefined behavior,
;;; it's nice to do so. To circumvent this you need code like this:
;;;
;;;   (defvar foo)
;;;   (defun set-foo (x) (setq foo x))
;;;   (defconstant foo 42)
;;;   (set-foo 13)
;;;   foo => 13, (constantp 'foo) => t
;;;
;;; ...in which case you frankly deserve to lose.
(defun about-to-modify-symbol-value (symbol action &optional (new-value nil valuep) bind)

のようなことが書いてあります。コメントにあるコード例が、こんなことしても良かったのか、というような例ですがSBCLでは可能なようです。(他の処理系ではエラー;未定義動作らしいですが…)

面白い色機能ですが速度低下の原因になったりするとしたら微妙な気もします…。

2011-03-05

読み書きの速度 (2)

| 18:08 | 読み書きの速度 (2) - わだばLisperになる を含むブックマーク はてなブックマーク - 読み書きの速度 (2) - わだばLisperになる

前回の測定で何か足りない、と思っていたのですが、良く使うalistが抜けていたのに気付いたので再度測定。

お馴染のalistではありますが、リストだけに要素数が増えると遅かったりするんですね。

=========================== READ ===========================
  0.040 sec. CLOSURE-1-READ
  0.041 sec. SYMBOL-PLIST-1-READ
  0.041 sec. LEXICAL-PLIST-1-READ
  0.062 sec. LEXICAL-VECTOR-1-READ
  0.062 sec. GLOBAL-SPECIAL-1-READ
  0.063 sec. LEXICAL-VAR-READ
  0.063 sec. STRUCT-10-READ
  0.063 sec. LEXICAL-CONS-1-READ
  0.063 sec. STRUCT-1-READ
  0.063 sec. HASH-10-READ
  0.063 sec. LEXICAL-VECTOR-10-READ
  0.063 sec. HASH-1-READ
  0.063 sec. LOCAL-SPECIAL-1-READ
  0.064 sec. SYMBOL-PLIST-10-READ
  0.121 sec. SYMBOL-VALUE-1-READ
  0.146 sec. LEXICAL-PLIST-10-READ
  0.778 sec. CLASS-1-READ
  1.132 sec. LEXICAL-ALIST-1-READ
  1.228 sec. CLASS-10-READ
  2.685 sec. LEXICAL-CONS-10-READ
  3.882 sec. LEXICAL-ALIST-10-READ
========================== WRITE ===========================
  0.041 sec. LEXICAL-VAR-WRITE
  0.063 sec. CLOSURE-1-WRITE
  0.069 sec. LEXICAL-CONS-1-WRITE
  0.140 sec. STRUCT-10-WRITE
  0.143 sec. STRUCT-1-WRITE
  0.145 sec. LEXICAL-VECTOR-10-WRITE
  0.149 sec. LEXICAL-VECTOR-1-WRITE
  0.189 sec. GLOBAL-SPECIAL-1-WRITE
  0.226 sec. LOCAL-SPECIAL-1-WRITE
  0.727 sec. LEXICAL-PLIST-1-WRITE
  1.132 sec. LEXICAL-ALIST-1-WRITE
  1.146 sec. CLASS-1-WRITE
  1.159 sec. CLASS-10-WRITE
  1.371 sec. SYMBOL-PLIST-1-WRITE
  1.382 sec. HASH-1-WRITE
  1.924 sec. HASH-10-WRITE
  3.143 sec. LEXICAL-CONS-10-WRITE
  3.593 sec. LEXICAL-PLIST-10-WRITE
  3.952 sec. LEXICAL-ALIST-10-WRITE
  5.871 sec. SYMBOL-PLIST-10-WRITE
107.203 sec. SYMBOL-VALUE-1-WRITE
(defun lexical-alist-1-write ()
  (let ((x (acons :x 0 ())))
    (dotimes (i one-hundred-million)
      (setf (cdr (assoc :x x)) i))))

(defun lexical-alist-1-read ()
  (let ((x (acons :x 0 ())))
    (dotimes (i one-hundred-million)
      (values (cdr (assoc :x x))))))

(defun lexical-alist-10-write ()
  (let ((x (reverse (acons :x 0 (make-list 9 :initial-element (list (gensym) (gensym)))))))
    (dotimes (i one-hundred-million)
      (setf (cdr (assoc :x x)) i))))

(defun lexical-alist-10-read ()
  (let ((x (reverse (acons :x 0 (make-list 9 :initial-element (list (gensym) (gensym)))))))
    (dotimes (i one-hundred-million)
      (values (cdr (assoc :x x))))))

2011-03-03

読み書きの速度

| 21:25 | 読み書きの速度 - わだばLisperになる を含むブックマーク はてなブックマーク - 読み書きの速度 - わだばLisperになる

最近目にしたベンチで変数を含んだオブジェクトへのアクセス速度を計測していたのがありましたが、そういえば、普段良く使うデータ型へのアクセス速度については、漠然としたイメージでしか把握してないな、と思ったので実測してみることにしました。

処理系は、SBCL 1.0.46/Linux

測定のコードは下記に掲載しますが、どうも上手く測定できていない気がします。

自分的に予想外だったのは、SYMBOL-VALUEでの書き込みがかなり遅いこと、と、構造体が思っていたより速かったので、PLISTを使ったりするよりは、構造体を積極的に使ってみるのも良いのかな、という位でした。

他は、データ型の使われ方と性質によってくると思うので妥当なところでしょうか。

なんにしろ、もうちょっとしっかりと作られたベンチマークの結果が見てみたいところです。

=========================== READ ===========================
  0.040 sec. CLOSURE-1-READ
  0.042 sec. SYMBOL-PLIST-1-READ
  0.044 sec. LEXICAL-PLIST-1-READ
  0.062 sec. SYMBOL-PLIST-10-READ
  0.062 sec. LEXICAL-VECTOR-1-READ
  0.062 sec. LOCAL-SPECIAL-1-READ
  0.063 sec. LEXICAL-VAR-READ
  0.063 sec. STRUCT-10-READ
  0.063 sec. LEXICAL-CONS-1-READ
  0.063 sec. STRUCT-1-READ
  0.063 sec. HASH-10-READ
  0.063 sec. LEXICAL-VECTOR-10-READ
  0.063 sec. HASH-1-READ
  0.063 sec. GLOBAL-SPECIAL-1-READ
  0.123 sec. SYMBOL-VALUE-1-READ
  0.146 sec. LEXICAL-PLIST-10-READ
  0.772 sec. CLASS-1-READ
  1.255 sec. CLASS-10-READ
  2.321 sec. LEXICAL-CONS-10-READ
========================== WRITE ===========================
  0.062 sec. CLOSURE-1-WRITE
  0.063 sec. LEXICAL-VAR-WRITE
  0.067 sec. LEXICAL-CONS-1-WRITE
  0.145 sec. LEXICAL-VECTOR-10-WRITE
  0.147 sec. STRUCT-1-WRITE
  0.147 sec. LEXICAL-VECTOR-1-WRITE
  0.149 sec. STRUCT-10-WRITE
  0.188 sec. GLOBAL-SPECIAL-1-WRITE
  0.275 sec. LOCAL-SPECIAL-1-WRITE
  1.078 sec. LEXICAL-PLIST-1-WRITE
  1.144 sec. CLASS-1-WRITE
  1.152 sec. CLASS-10-WRITE
  1.383 sec. SYMBOL-PLIST-1-WRITE
  1.386 sec. HASH-10-WRITE
  1.386 sec. HASH-1-WRITE
  3.143 sec. LEXICAL-CONS-10-WRITE
  4.848 sec. LEXICAL-PLIST-10-WRITE
  5.866 sec. SYMBOL-PLIST-10-WRITE
109.004 sec. SYMBOL-VALUE-1-WRITE

測定コード

(defpackage :read-write-test (:use :cl))

(in-package :read-write-test)

(defconstant one-hundred-million 100000000)

(defun lexical-var-write ()
  (let ((x 0))
    (dotimes (i one-hundred-million)
      (setf x i))))

(defun lexical-var-read ()
  (let ((x 0))
    (dotimes (i one-hundred-million)
      (values x))))

(defun lexical-cons-1-write ()
  (let ((x (list 0)))
    (dotimes (i one-hundred-million)
      (setf (car x) i))))

(defun lexical-cons-1-read ()
  (let ((x (list 0)))
    (dotimes (i one-hundred-million)
      (values (car x)))))

(defun lexical-cons-10-write ()
  (let ((x (make-list 10 :initial-element 0)))
    (dotimes (i one-hundred-million)
      (setf (car (nthcdr 9 x)) i))))

(defun lexical-cons-10-read ()
  (let ((x (make-list 10 :initial-element 0)))
    (dotimes (i one-hundred-million)
      (values (car (nthcdr 9 x))))))

(defun lexical-vector-1-write ()
  (let ((x (make-array 1 :initial-element 0)))
    (dotimes (i one-hundred-million)
      (setf (aref x 0) i))))

(defun lexical-vector-1-read ()
  (let ((x (make-array 1 :initial-element 0)))
    (dotimes (i one-hundred-million)
      (values (aref x 0)))))

(defun lexical-vector-10-write ()
  (let ((x (make-array 10 :initial-element 0)))
    (dotimes (i one-hundred-million)
      (setf (aref x 9) i))))

(defun lexical-vector-10-read ()
  (let ((x (make-array 10 :initial-element 0)))
    (dotimes (i one-hundred-million)
      (values (aref x 9)))))

(defun lexical-plist-1-write ()
  (let ((x (list :x 0)))
    (dotimes (i one-hundred-million)
      (setf (getf x :x) i))))

(defun lexical-plist-1-read ()
  (let ((x (list :x 0)))
    (dotimes (i one-hundred-million)
      (values (getf x :x)))))

(defun lexical-plist-10-write ()
  (let ((x (append (make-list 18) (list :x 0))))
    (dotimes (i one-hundred-million)
      (setf (getf x :x) i))))

(defun lexical-plist-10-read ()
  (let ((x (append (make-list 18) (list :x 0))))
    (dotimes (i one-hundred-million)
      (values (getf x :x)))))

(defun symbol-plist-1-write ()
  (let ((x (gensym)))
    (dotimes (i one-hundred-million)
      (setf (get x :x) i))))

(defun symbol-plist-1-read ()
  (let ((x (gensym)))
    (dotimes (i one-hundred-million)
      (values (get x :x)))))

(defun symbol-plist-10-write ()
  (let ((x (gensym)))
    (setf (symbol-plist x)
          (append (make-list 18) (list :x 0)))
    (dotimes (i one-hundred-million)
      (setf (get x :x) i))))

(defun symbol-plist-10-read ()
  (let ((x (gensym)))
    (setf (symbol-plist x)
          (append (make-list 18) (list :x 0)))
    (dotimes (i one-hundred-million)
      (values (get x :x)))))

(defun closure-1-write ()
  (let ((fctn (let ((x 0))
                (lambda (n)
                  (setf x n)))))
    (dotimes (i one-hundred-million)
      (funcall fctn i))))

(defun closure-1-read ()
  (let ((fctn (let ((x 0))
                (lambda () (values x)))))
    (dotimes (i one-hundred-million)
      (values (funcall fctn)))))

(defstruct foo
  (x 0))

(defun struct-1-write ()
  (let ((s (make-foo)))
    (dotimes (i one-hundred-million)
      (setf (foo-x s) i))))

(defun struct-1-read ()
  (let ((s (make-foo)))
    (dotimes (i one-hundred-million)
      (values (foo-x s)))))

(defstruct foo10
  y z a b c d e f g (x 0))

(defun struct-10-write ()
  (let ((s (make-foo10)))
    (dotimes (i one-hundred-million)
      (setf (foo10-x s) i))))

(defun struct-10-read ()
  (let ((s (make-foo10)))
    (dotimes (i one-hundred-million)
      (values (foo10-x s)))))

(defclass bar ()
  ((x :initform 0 :accessor bar-x)))

(defun class-1-write ()
  (let ((o (make-instance 'bar)))
    (dotimes (i one-hundred-million)
      (setf (bar-x o) i))))

(defun class-1-read ()
  (let ((o (make-instance 'bar)))
    (dotimes (i one-hundred-million)
      (values (bar-x o)))))

(defclass bar10 ()
  #.(cons '(x :initform 0 :accessor bar10-x)
          (mapcar (lambda (x)
                    (list* (gensym) :initform 0 :accessor (gensym) x))
                  (make-list 9))))

(defun class-10-write ()
  (let ((o (make-instance 'bar10)))
    (dotimes (i one-hundred-million)
      (setf (bar10-x o) i))))

(defun class-10-read ()
  (let ((o (make-instance 'bar10)))
    (dotimes (i one-hundred-million)
      (values (bar10-x o)))))

(defun hash-1-write ()
  (let ((h (make-hash-table)))
    (setf (gethash :x h) 0)
    (dotimes (i one-hundred-million)
      (setf (gethash :x h) i))))

(defun hash-1-read ()
  (let ((h (make-hash-table)))
    (setf (gethash :x h) 0)
    (dotimes (i one-hundred-million)
      (values (gethash :x h)))))

(defun hash-10-write ()
  (let ((h (make-hash-table)))
    (setf (gethash :x h) 0)
    (dotimes (i 9)
      (setf (gethash (gensym) h) 0))
    (dotimes (i one-hundred-million)
      (setf (gethash :x h) i))))

(defun hash-10-read ()
  (let ((h (make-hash-table)))
    (setf (gethash :x h) 0)
    (dotimes (i 9)
      (setf (gethash (gensym) h) 0))
    (dotimes (i one-hundred-million)
      (values (gethash :x h)))))

(defun symbol-value-1-write ()
  (let ((sym (gensym)))
    (setf (symbol-value sym) 0)
    (dotimes (i one-hundred-million)
      (setf (symbol-value sym) i))))

(defun symbol-value-1-read ()
  (let ((sym (gensym)))
    (setf (symbol-value sym) 0)
    (dotimes (i one-hundred-million)
      (values (symbol-value sym)))))

(defvar *x* 0)

(defun global-special-1-write ()
  (dotimes (i one-hundred-million)
    (setf *x* i)))

(defun global-special-1-read ()
  (dotimes (i one-hundred-million)
    (values *x*)))

(defun local-special-1-write ()
  (let ((*ls*))
    (declare (special *ls*))
    (dotimes (i one-hundred-million)
      (setf *ls* i))))

(defun local-special-1-read ()
  (let ((*ls*))
    (declare (special *ls*))
    (dotimes (i one-hundred-million)
      (values *ls*))))

(defun find/writers ()
  (let ((ans () ))
    (do-symbols (s :read-write-test)
      (when (and (eq :internal (nth-value 1 (find-symbol (string s))))
                 (search "-WRITE" (string s)))
        (push s ans)))
    ans))

(defun find/readers ()
  (let ((ans () ))
    (do-symbols (s :read-write-test)
      (when (and (eq :internal (nth-value 1 (find-symbol (string s))))
                 (search "-READ" (string s)))
        (push s ans)))
    ans))

(defun run/writers ()
  (format t "~&~60,,,'=:@< ~A ~>~%" 'write)
  (format t
          "~:{~7,3F sec. ~A~%~}"
          (sort
           (mapcar (lambda (x)
                     (let ((t1 (get-internal-real-time)))
                       (funcall x)
                       (list (/ (- (get-internal-real-time) t1) internal-time-units-per-second)
                             x)))
                   (find/writers))
           #'<
           :key #'first)))

(defun run/readers ()
  (format t "~&~60,,,'=:@< ~A ~>~%" 'read)
  (format t
          "~:{~7,3F sec. ~A~%~}"
          (sort
           (mapcar (lambda (x)
                     (let ((t1 (get-internal-real-time)))
                       (funcall x)
                       (list (/ (- (get-internal-real-time) t1) internal-time-units-per-second)
                             x)))
                   (find/readers))
           #'<
           :key #'first)))

(progn
  (run/readers)
  (run/writers))

2011-03-01

with-output-to-browser

| 22:02 | with-output-to-browser - わだばLisperになる を含むブックマーク はてなブックマーク - with-output-to-browser - わだばLisperになる

with-output-to-stringのようにブラウザで中身を表示させたいな、ということが自分の場合結構あったのでマクロを書いてみました。

htmlで出力させて眺めてみたりと割と応用が効くかもしれません。自分的には便利に使えそうです。

(defmacro with-output-to-browser ((stream &key (browser "firefox")) &body body)
  (let ((filename (format nil "/tmp/~A" (gensym "TEMPFILE-"))))
    `(macrolet ((#0=#:command-output-status (form) `(nth-value 2 ,form)))
       (with-open-file (,stream ,filename :direction :output :if-exists :supersede)
         ,@body)
       (zerop (#0# (kl:command-output "~A ~A" ,browser ,filename))))))

ちなみに、マクロの内容とは関係ないですが#:command-output-statusというコメント的な局所マクロを定義してみています。

自分的に、nth-value 2とかいきなりでてきてもなんのことやら、という感じがするので、こういう風に書いてみたのですが、逆にうるさいかもしれません。

コメントを書くならコードで表現した方が良い、というのは良く聞きますが局所マクロが使える言語では、謎構文にエイリアスを付ける、という表現もありかもしれないなと思ったり。

(aliaslet ((command-output-status ...)) 
  ...)

のようなものを用意しても、もしかしたら便利かも知れません。