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-09-29

SLIMEばつ牛ン (1) slime-eval-defun

| 23:11 | SLIMEばつ牛ン (1) slime-eval-defun - わだばLisperになる を含むブックマーク はてなブックマーク - SLIMEばつ牛ン (1) slime-eval-defun - わだばLisperになる

KMRCLも難しいファイルを後回しにしていたので、だんだん解説が難しくなってきたので、逃げ道の開拓ということで、SLIMEの機能を適当に探ってみることにしました。(LISP365完了の12月まで毎日書けるような軽いネタが必要なため…)

今回は、 slime-eval-defun です。

キーバインド

デフォルトのキーバインドは、c-m-x。

ちなみに私は、c-m-xは押しにくいし、Lispマシンと同じキーバインドにしたかったので、c-sh-e*1にしてみています。

使い方

評価したい式の上で、実行します。

(slime-)eval-defunということで、基本的に関数定義を評価するためのものだと思うのですが、大雑把にフォームを評価するもの、という感じです。

数引数を付けると、結果をバッファ内に挿入してくれるオマケ機能があります。

(+ 3 3 3)
<ここで実行>9

定義は

;; elisp
(defun slime-eval-defun ()
  "Evaluate the current toplevel form.
Use `slime-re-evaluate-defvar' if the from starts with '(defvar'"
  (interactive)
  (let ((form (slime-defun-at-point)))
    (cond ((string-match "^(defvar " form)
           (slime-re-evaluate-defvar form))
          (t
           (slime-interactive-eval form)))))

こんな感じですが、defvarを特別扱いしていて、defvarの場合は、値をセットしなおしてくれるというさらなるオマケ機能があります。

defvarの挙動が面倒でdefparameterにしている人には嬉しい機能ですね。(望んでない人もいるかもしれませんが…)

私は以前、Lispマシンのマニュアルを眺めていて、Evaluate Region Hack(c-m-sh-e)という同様の動きをする関数をみつけて、感心して早速自作してみたことがあったのですが、SLIMEにもあったのを後で知りました。歴史は繰り返すのか、文化が連綿と受け継がれているのか…。

数引数があれば、slime-interactive-evalが呼ばれて、結果としてバッファに評価結果が挿入されます(この辺りを追い掛けて行くと芋蔓できりがなさそうなので、この辺にしておきます…。)

このブログを書いていると評価する式と評価結果を併せて書いたりすることが多いのですが、

(+ 3 3 3)
9

から一歩進んで、

(+ 3 3 3)
;; => 9

としてくれると嬉しいのにな、と思ったりもします。

そんなことをぼやいていたら、quekさんに自作のユーティリティを教えてもらいました。

;; elisp
;; 評価した結果をバッファ内に ;;=> 結果 という形で挿入
;; quekさん作
(defun slime-que-print-last-expression (string)
  "Evaluate sexp before point; print value into the current buffer"
  (interactive (list (slime-last-expression)))
  (insert "\n;; => ")
  (slime-eval-print string))

これは便利ですね!

*1:shはシフト

2010-09-28

KMRCLを眺める(207) CMSG

| 23:24 | KMRCLを眺める(207) CMSG - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める(207) CMSG - わだばLisperになる

random.lispも眺め終えたので、今回は、KMRCLのconsole.lispからCMSGです。

console.lispはその名の通りコンソールでなにかするため(主にログを出力したり)のユーティリティの用です。

CMSGの定義は、

(defvar *console-msgs* t)

(defun cmsg (template &rest args)
  "Format output to console"
  (when *console-msgs*
    (setq template (concatenate 'string "~&;; " template "~%"))
    (apply #'format t template args)))

となっていて、*CONSOLE-MSGS*の値で出力したりしなかったりを制御できるようにしてあり、あとは先頭にコメントの;; を付けるというシンプルなものです。

(kl:cmsg "Hello, World!")
->
;; Hello, World!

FORMATに投げているので、FORMATのオプションも色々使えます。

(progn
  (kl:cmsg "~37,,,'*A" "")
  (kl:cmsg "~37:@<~A~>" "Hello, World!")
  (kl:cmsg "~37,,,'*A" ""))
;⇒ NIL
;->
;; *************************************
;;             Hello, World!            
;; *************************************

こういう風にFORMATに丸投げする際には、オプションも渡せるようにしてFORMATの高機能を生かすというパターンは良くみかける気がします。

2010-09-26

KMRCLを眺める(206) RANDOM-CHOICE

| 22:39 | KMRCLを眺める(206) RANDOM-CHOICE - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める(206) RANDOM-CHOICE - わだばLisperになる

今回は、KMRCLのrandom.lispからRANDOM-CHOICEです。

使い方は、マクロ展開してみると分かりやすいですが、

(kl:random-choice 1 2 3 4 5)
;%=>
(CASE (RANDOM 5)
  (0 1)
  (1 2)
  (2 3)
  (3 4)
  (4 5))

となっていて、引数の式をランダムに選択して実行するというのが良くわかります。

定義は、

(defmacro random-choice (&rest exprs)
  `(case (random ,(length exprs))
     ,@(let ((key -1))
         (mapcar #'(lambda (expr)
                     `(,(incf key) ,expr))
                 exprs))))

となっています。

MAPCARの中で副作用のあるINCFしてるのがちょっと気持ち悪い…という人もいそうです。

自分なら

(defmacro random-choice (&rest exprs)
  `(case (random ,(length exprs))
     ,@(loop :for i :from 0
             :for e :in exprs
             :collect (list i e))))

みたいに書くかもしれません。まあ、Schemeではなくて、CLの話なので趣味の問題ではありますが…。

2010-09-25

Shibuya.lisp Hackathon #1 2010/10/24開催!

| 23:05 | Shibuya.lisp Hackathon #1 2010/10/24開催! - わだばLisperになる を含むブックマーク はてなブックマーク - Shibuya.lisp Hackathon #1 2010/10/24開催! - わだばLisperになる

Shibuya.lisp参加者の方にアンケートをとったりすると、Hackathonをやってみたいという声がちらほらあったのですが、こないだのSmiley Hackathon #9の会場となった日本オラクルさんの会場が電源、無線LAN、椅子机、プロジェクター完備ということでHackathonをするにはうってつけの会場でした。

日本オラクルさんは会場を勉強会などに積極に提供されているとのことだったので、これは良いことを聞いたとばかりにShibuya.lisp MLでこの会場でのHackathonを提案したところ d:id:yshigeru さんに仕切り役に立候補してもらえて、色々調整して頂き、開催日決定まで辿り着きました。

これまで、LISPの話を聞くイベントや勉強会はありましたが、LISPを書く集まりというのは、あまりなかったように思います。

ぶっちゃけたところ、どれ位LISPのコードを書いたりしてる人がいるのか、どういう人がLISPのコードを書いているのか、どういう需要でLISPのコードを書いてることが多いのか、色々と興味深いことが発見できるんじゃないかなあと思っています。

などと自分は言っていますが、LISP関係の雑談でも、SICPやPAIPの勉強でも、LISPにこじつけてあればなんでもOKでゆるく参加してもらえたら良いなと思います。

いまのところ、52/80名の方が参加する予定になっていますが、あと30枠くらい余っていますので、折角なので是非ご参加ください!

自分は、この機会にShibuya.lispの運営関係のルーチンワークをまとめてテンプレ化して運営の省力化を考えたり、過去の活動のウェブ上の情報をまとめて整理して後から参照しやすくしたりしようかなと思っています。

Shibuya.lispサイトでの告知:

2010-09-24

大文字でコードを書くようになって丸1年経過しました

| 00:39 | 大文字でコードを書くようになって丸1年経過しました - わだばLisperになる を含むブックマーク はてなブックマーク - 大文字でコードを書くようになって丸1年経過しました - わだばLisperになる

私が大文字でコードを書くようになったのは、ZmacsのElectric Shift LockモードがEmacsで再現されているのを発見したときからで、そのエントリーをブログに書いてから1年経過しました。

大文字で一年書いてみて発見できた長所ですが、Lが大文字だと他の文字と区別が付きやすい

(defun fool1 (l)
  (if (null l)
      1
      (list l)))
;; vs

(DEFUN FOOL1 (L)
  (IF (NULL L)
      1
      (LIST L)))

という1点のみでした。

あとは、コードの見た目が逞しくなる、昔の大文字で書かれたコードを読んでもなんの違和感がない等のメリットがあるでしょうか。

デメリットとしては、ブログの例にあるコードが読み難いという声を頂くことがあり、d:id:miyamuko さんには、自前で小文字版のRSSフィードを作って読んでいると教えて頂きました。

ありがとうございますw

また、小文字に戻そうかなあとも思いますが、せっかく大文字で書くのに馴れたので、ちょっと寂しいですし、今度は、混在スタイルや、先頭は大文字にするスタイルを試してみようかなあと思っています。

;; 混在スタイル
(defun FOO (N)
  ...)

;; 先頭大文字スタイル
(Defun Foo (N)
  ...)

そういえば、先日の数理システムのセミナーで竹内先生が、黒田さんのno titleを読んで、CLの大文字小文字を区別しないのが良いというところにこだわりがあるのに感心した、というお話を思い出しました。

TAOでも大文字小文字を区別しないようですが、出力は、小文字にしているそうです。大文字で出力されると読みにくくて嫌とのことでした。

2010-09-23

KEYで再帰的に自分を呼ぶ

| 20:34 | KEYで再帰的に自分を呼ぶ - わだばLisperになる を含むブックマーク はてなブックマーク - KEYで再帰的に自分を呼ぶ - わだばLisperになる

(MYSUM '(1 (2 ((3) 4)) (5 6 7) 8 9 0))
;⇒ 45

こういうのを考える場合に、FLATTENして、(APPLY #'+)かなとも思うのですが、

(DEFUN MYSUM (TREE)
  (REDUCE #'+ TREE :KEY (LAMBDA (X)
                          (IF (CONSP X) (MYSUM X) X))))

こういうのはどうでしょう。

もっと汎用的にして、

(DEFUN KEY* (FN)
  (LAMBDA (X)
    (IF (CONSP X) (FUNCALL FN X) X)))

(DEFUN MYSUM (TREE)
  (REDUCE #'+ TREE :KEY (KEY* #'MYSUM)))

という風にしたら、REDUCE以外にも使えて便利!!

…と思ったのですが、そうでもありませんでした。

数理システム Common Lisp セミナ 2010-09-21 (2)

| 15:44 | 数理システム Common Lisp セミナ 2010-09-21 (2) - わだばLisperになる を含むブックマーク はてなブックマーク - 数理システム Common Lisp セミナ 2010-09-21 (2) - わだばLisperになる

今回の数理システム Common Lisp セミナには竹内郁雄先生が参加者として参加されていました。

休憩等の合間で、皆でお話を伺う機会があったのでメモ

今、取り掛かっているx86アーキテクチャ上のLISP処理系について

プリミティブな部品に分解していって、下層レイヤーのLISP処理系を提供したい。

TAO/SILENTでは、TAOは、SILENT(LISPマシン)の機械語という位置付けだった。

こういう下層レイヤーのLISP処理系の上に皆が好きに処理系を作ってもらえたら面白いだろうなと思っている。

他にも色々あったのですが、メモしてなかったのでエントリーできるところまでまとめられませんでした…。

2010-09-21

数理システム Common Lisp セミナ 2010-09-21

| 23:10 | 数理システム Common Lisp セミナ 2010-09-21 - わだばLisperになる を含むブックマーク はてなブックマーク - 数理システム Common Lisp セミナ 2010-09-21 - わだばLisperになる

今日は、数理システム Common Lisp セミナでした。

会社の同僚のCLerであるquekさんと勇んで参加。

以下つらつらと感想を書きます。

(1) CLML (Common Lisp Machine Learning) の紹介

講師: 黒田寿男 (Mathematical Systems Inc.)

時間: 13:30 〜 13:45

黒田さんによるCLMLの概略の説明。

RやS-Plusがあるのに、なぜ、新たに開発したかというと、CLからネイティブに使えることなどが、CLerには嬉しいとのこと。

実際にRと比較のベンチをとり説明していました。

今のところチューニング等に課題があり、平均したところではRより性能はでていないとのこと。

ただ、規模が大きくなってくると性能的には大分Rに近付いて来るようです。

パフォーマンスが今後の課題だそうですが、現状でもCLの環境全部をひっくるめると使い勝手は良いものになっているそうです。

(2) CLMLを使ったトピック抽出

講師: 阿部祐介 (Mathematical Systems Inc.)

時間: 13:45 〜 14:30

阿部さんによるデータマイニングにCLMLを使った説明。

こちらの資料を元にお話されていたようです。

文書集合の(コーパス)の単語出現頻度は、時期などの影響を受けて変動するそうですが、トピックとは、この単語出現頻度を変動させる(潜在的な)要因とのことらしいです。

教師なし学習法であるNMFを用いたそうで、NMFはPCAの代替手法として注目されているとのこと。

NMFを使って嬉しいところは、次元縮約できることだそうで、顔の画像から特徴を抽出して、再度合成したり、あれこれしたものをデモされていました。

阿部さんは去年数理システムに入社するまで数学を専門にされていてプログラム等は書いたことがなかったそうですが、PAIPを2ヶ月でこなすように指示され、それをこなした後に書いたものがこのトピック抽出のプログラムだそうです。いやはや凄いですね

(3) Cocurrency Building Blocks in Common Lisp

講師: 黄澗石 (Mathematical Systems Inc.)

時間: 14:45 〜 15:30

黄さんによるCLにおける並列化の問題点等のお話。

プログラムを並列で動かすのに一番苦労しない方法は、プロセッサ間でデータを共有しないこと、から始まり、現実問題として解くべき問題は、ほぼ何かしらの形でプロセッサ間でデータが共有されることになること、それがもたらす複雑さについて、具体的なプログラムや処理系内部のコード(SBCLのスピンロックのコード等)を解説されていました。

(4) Writing Lisp codes in AllegroGraph & Visual Query in Gruff

講師: Jans Aasman (Franz Inc.)

時間: 15:30 〜 16:30

恒例になっているような、AllegroGraphの解説とデモで、今回は、GUIで色々とクエリが実行できることをデモされていました。

対象から線を引っ張って行き述語を選んでくつけると、SPARQLや、Alegro Prologのクエリが生成/実行されていました。

検索結果として出てきたトリプルを色々と繰り返しで処理する方法として、Prolog風だったり、LISPのmap処理だったり、拡張されたLOOPマクロだったりできるようです。

個人的には、拡張されたLOOPが興味深いと思いました。

かなり内容的に濃いものでかつ半分は英語ということもあり、ほぼ理解できませんでしたが、色々と興味深いことが多かったです。

また、個人的に色々な方とお会いできて少しですがお話できたのが良かったです。

11月には通例の2日まるごとLISPセミナーもあるようなので、これまた楽しみです!

2010-09-20

KMRCLを眺める(205) SEED-RANDOM-GENERATOR

| 23:05 | KMRCLを眺める(205) SEED-RANDOM-GENERATOR - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める(205) SEED-RANDOM-GENERATOR - わだばLisperになる

equal.lispも眺め終えたので、今回は、KMRCLのrandom.lispからSEED-RANDOM-GENERATORです。

定義は、

(defun seed-random-generator ()
  "Evaluate a random number of items"
  (let ((randfile (make-pathname
                   :directory '(:absolute "dev")
                   :name "urandom")))
    (setf *random-state* (make-random-state t))
    (if (probe-file randfile)
        (with-open-file
            (rfs randfile :element-type 'unsigned-byte)
          (let*
              ;; ((seed (char-code (read-char rfs))))
              ((seed (read-byte rfs)))
            ;;(format t "Randomizing!~%")
            (loop
                for item from 1 to seed
                do (loop
                       for it from 0 to (+ (read-byte rfs) 5)
                       do (random 65536))))))))

となっています。

/dev/urandomから1バイト読み出して得た0〜255の数値の回数(内側は+5)でループを回してRANDOMを実行し乱数の種を変化させるもののようです。

実行例は、

(SEED-RANDOM-GENERATOR)
;⇒ NIL

ですが、副作用目的になります。

2010-09-19

Common Lispメモ

| 22:43 | Common Lispメモ - わだばLisperになる を含むブックマーク はてなブックマーク - Common Lispメモ - わだばLisperになる

そういえば、こういう書き方もできるのか

(TYPECASE 3
  ((SATISFIES EVENP) 'EVEN)
  ((SATISFIES ODDP) 'ODD))
;⇒ ODD

簡単なSWANKの拡張で適当補完

| 02:11 | 簡単なSWANKの拡張で適当補完 - わだばLisperになる を含むブックマーク はてなブックマーク - 簡単なSWANKの拡張で適当補完 - わだばLisperになる

slime-complete-formというコマンドがあるのですが、これは文脈に応じて実行すると、

;; ■ = カーソル
(EVAL-WHEN ■)
;->
(EVAL-WHEN (:compile-toplevel :load-toplevel :execute) body...)

と補完してくれるというものです。

そんなに活躍するところもないのですが、ぴったりはまる場所では便利です。(eval-whenとか、(declare (optimize))とか)

そんな slime-complete-form の実装を眺めてみたのですが、なにかを補完したい場合には流用できそうだったので、試しにお決まりのパターンを補完するようなものをでっち上げてみました(コードは文末)

かなり適当なコードですが、

(MAPCAR ■)
;->
(MAPCAR (LAMBDA ()))
(DEFPACKAGE ■)
;->
(DEFPACKAGE :FOO
  (:USE :CL))
(REDUCE #'+ FOO■)
;->
(REDUCE #'+ FOO :INITIAL-VALUE)
(SET-DISPATCH-MACRO-CHARACTER ■)
;->
(SET-DISPATCH-MACRO-CHARACTER #\# #\? (LAMBDA (STREAM SUBCHAR ARG) (DECLARE (IGNORE SUBCHAR ARG)) ))

位のことはできます。

補完した後にカーソルも適切な場所に移動したりできたら、それなりに便利にはなりそうではあります。

ちなみに、SWANKを眺めていたら、パターンマッチのユーティリティが取り込まれていたので使ってみました。

Stephen Adams氏作で、

http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/lisp/code/match/miranda/select.cl

のものと同一だと思われます。

以前、Chaton COMMON LISP JP部屋でshiroさんにCLを書く時に使っているライブラリを伺ったときに、パターンマッチがないとやってられないので、これを改造して利用していると伺った覚えがあります。

SWANKに付いてくるので、自分がCLを使っている時は常時読み込まれていますし、しばらく積極的に使ってみようかなと思っています。

コード

emacs側
(progn
  (defun slime-my-complete-form ()
    (interactive)
    ;; Find the (possibly incomplete) form around point.
    (let ((buffer-form (slime-parse-form-upto-point)))
      (let ((result (slime-eval `(swank:my-complete-form ',buffer-form))))
        (if (eq result :not-available)
            (error "Could not generate completion for the form `%s'" buffer-form)
          (progn
            (just-one-space (if (looking-back "\\s(" (1- (point)))
                                0
                              1))
            (save-excursion
              (insert result)
              (let ((slime-close-parens-limit 1))
                (slime-close-all-parens-in-sexp)))
            (save-excursion
              (backward-up-list 1)
              (indent-sexp)))))))

  (define-key slime-mode-map [(control ?c) (control shift ?s)]
     'slime-my-complete-form))
SWANK側
(IN-PACKAGE :SWANK)

(DEFSLIMEFUN MY-COMPLETE-FORM (RAW-FORM)
  (FLET ((STRING-UPCASE-SAFE (X)
           (IF (STRINGP X) (STRING-UPCASE X) X)))
    (MATCH (MAPCAR #'STRING-UPCASE-SAFE RAW-FORM)
      (("MAPCAR" . REST) "(LAMBDA ())")
      (("SET-MACRO-CHARACTER" . REST) 
       "#\\ (LAMBDA (STREAM CHAR) (DECLARE (IGNORE CHAR)))")
      
      (("SET-DISPATCH-MACRO-CHARACTER" . REST)
       "#\\ #\\ (LAMBDA (STREAM SUBCHAR ARG) (DECLARE (IGNORE SUBCHAR ARG)) )")

      (("EVAL-WHEN" (":COMPILE-TOPLEVEL" ":LOAD-TOPLEVEL" ":EXECUTE") . REST) 
       ":?")
      
      (("EVAL-WHEN" . REST) 
       "(:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)")

      (("LOOP" . REST) 
       ":FOR X :FROM 0 :TO 100 :COLLECT X")

      (("LET" ("" %CURSOR-MARKER%) . REST) 
       "(X X)")
      
      (("LET" . REST) 
       "()")

      (("DEFPACKAGE" . REST)
       ":FOO (:USE :CL)")

      (("REDUCE" #:_ #:_ %cursor-marker%)
       ":INITIAL-VALUE")

      (("REDUCE" #:_ #:_ "" %cursor-marker% . REST)
       ":INITIAL-VALUE")

      (OTHER :NOT-AVAILABLE))))

2010-09-18

(47)“日本語上手”なCommon Lisp ~LispマシンExplorerでの実現~(1987)

| 19:40 | (47)“日本語上手”なCommon Lisp ~LispマシンExplorerでの実現~(1987) - わだばLisperになる を含むブックマーク はてなブックマーク - (47)“日本語上手”なCommon Lisp ~LispマシンExplorerでの実現~(1987) - わだばLisperになる

これまで、CiNiiを漁っていましたが、情報処理学会 電子図書館でも論文がPDFで公開されていて、さらにCiNiiで見付からない論文もあるので、CiNiiと合せて漁ってみることにしました。

今回は、

です。

Explorerとは、MITのCADRの流れのLispマシンですが、LMIのマシンから枝分かれしたもので、TIが開発し販売していました。

このTI Explorerを日本では、日本ユニバック(現日本ユニシス)(ググっても詳細が見付からないので間違ってるかも)が代理店となってKS-301という名前で販売していたようです。

この論文は、元々日本語を扱うことを考慮されていないTI Explorerで日本語を扱うことをテーマにしています。

文字の種類の多い日本語を扱えるようにした方法そのですが、主なところとしては、CLtL1時代まで仕様にあった、文字のフォント属性のビットをあれこれ工夫して実装したようです。

また、表示だけでなく、日本語の全角文字とシンボルの関係など意味論的にも色々と試行錯誤があって面白いです。

(eq 'lisp 'lisp)
;⇒ T

この日本語化された処理系は、Nippongo Common Lisp(NCL)とのこと。

ちなみに、この論文自体も日本語化されたTI Explorerで書かれたらしく、最後のページに日本語化されたZmacsのスクリーンショットで確認できます。

2010-09-17

ディスパッチ・マクロ文字の引数の思いがけない使い方を知りたい

| 23:29 | ディスパッチ・マクロ文字の引数の思いがけない使い方を知りたい - わだばLisperになる を含むブックマーク はてなブックマーク - ディスパッチ・マクロ文字の引数の思いがけない使い方を知りたい - わだばLisperになる

ディスパッチ・マクロ文字は、十進の引数が取れるのですが、無視されることも多いです。

最も有名なディスパッチ・マクロ文字は#'だと思いますが、これも引数を取れます。

(MAPCAR #1234567890'/
        '(1 2 3 4))
;⇒ (1 1/2 1/3 1/4)

これを、なにか画期的なことに使えないでしょうか。

自分がちょっと考えてみたところでは、

  • アメリカなどで使われている数字とアルファベットの対応づけ
;; 34963 => FIXME 
(MAPCAR #34963'(lambda (x) x) '(1 2 3 4))
  • 数字が読みづらいので10進での数値をコメント的に付ける
#10xa
;⇒ 10

#10o12
;⇒ 10

#10922b10101010101010
;⇒ 10922

全然役に立ちそうもないですね。

自分が以前に考えたものでは、Gaucheの#?で引数を使って、デバッグ出力の目印に使ってみる、というのがありました

;; Gaucheの#?=
;; http://cadr.g.hatena.ne.jp/g000001/20070917
(defmacro debug-print (obj &optional name (stream *debug-io*))
  `(let ((hr "** ----------------------------------------")
	 (name (if ,name ,name 0)))
     (format ,stream "~A~%** Debug: #~A | ~A => ~A | ~S~%~0@*~A~%" 
	     hr name ',obj ,obj (type-of ,obj))
     ,obj))

(set-dispatch-macro-character #\# #\?
                              (lambda (stream char arg)
                                (declare (ignore char))
                                (if (char= #\= (peek-char t stream))
                                    (read-char stream))
                                (list 'debug-print (read stream t nil t) arg t)))

;; (DOTIMES (I 3) #77777?=I)
;; ** ----------------------------------------
;; ** Debug: #77777 | I => 0 | BIT
;; ** ----------------------------------------
;; ** ----------------------------------------
;; ** Debug: #77777 | I => 1 | BIT
;; ** ----------------------------------------
;; ** ----------------------------------------
;; ** Debug: #77777 | I => 2 | (INTEGER 0 1152921504606846975)
;; ** ----------------------------------------
;; ⇒ NIL

ちなみに、#10()とするとSBCLやAllegro CLでは、

#10()
;⇒ #(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)

(LENGTH #10() )
;⇒ 10

となるようです。これは処理系の拡張なのでしょうか。

2010-09-16

超リードマクロに対して超普通

| 21:03 | 超リードマクロに対して超普通 - わだばLisperになる を含むブックマーク はてなブックマーク - 超リードマクロに対して超普通 - わだばLisperになる

この前、Twitterで深町さんがCLer同士のブログエントリーへのツッコまなさ加減を嘆いていました。

思いあたるところも多いですし、積極的にツッコんで行くのも面白いかもしれないのでこれからはツッコんで行ってみます。

深町さんのエントリーの趣旨はREADを上書きして、

'(1..10)
;⇒ '(1 2 3 4 5 6 7 8 9)

と書けるようにするというアイデアです。

自分は、これくらいだったら色々な方面のバランスを考えるとREADを改造するまでもないかな、思いました。

費用対効果を考えると、quekさんの

(N.. 2 5)
;⇒ (2 3 4 5)

(1... 10)
;⇒ (1 2 3 4 5 6 7 8 9)

が良い感じです。

自分だったら、どう書くかというと、quekさんと似た感じですが、

(DEFUN LIST.. (START END)
  (LOOP :FOR I :FROM START :TO END :COLLECT I))

(DEFUN VECTOR.. (START END)
  (ATAP (MAKE-ARRAY (1+ (- END START)))
    (LOOP :FOR IDX :FROM 0 
          :FOR VAL :FROM START :TO END
          :DO (SETF (AREF IT IDX) VAL))))

(DEFUN QUOTE.. (START END)
  `',(LOOP :FOR I :FROM START :TO END :COLLECT I))
(LIST.. 1 10)
;⇒ (1 2 3 4 5 6 7 8 9 10)

(QUOTE.. 1 10)
;⇒ '(1 2 3 4 5 6 7 8 9 10)

(VECTOR.. 1 10)
;⇒ #(1 2 3 4 5 6 7 8 9 10)

くらいかなあと思いました。

他にリーダーマクロで実装するとしたら、☺等をマクロ文字にして、

(☺1..5PRINT ..)

が、

(PROGN
  (PRINT 1)
  (PRINT 2)
  (PRINT 3)
  (PRINT 4)
  (PRINT 5))

;; もしくはちょっと自動解析して
(LOOP :FOR #:G1 :FROM 1 :TO 5 :DO (PRINT #:G1))

のように展開されるようにするかもしれないなと思いました。

あと、READを再定義するところまで行くとすると、

(1..5)だけでなくて、

(let ((start 10) (end 100))
  (start..end))

とも書きたくなりそうです。

ともあれ、READを再定義というのは面白いと思いましたので、これからもどんどんREADやEVALを再定義してみて欲しいです!

2010-09-15

OKI ISLispがislisp.orgにて再公開!

| 08:09 | OKI ISLispがislisp.orgにて再公開! - わだばLisperになる を含むブックマーク はてなブックマーク - OKI ISLispがislisp.orgにて再公開! - わだばLisperになる

ELIS復活祭の懇親会で、Tachyon CLを作っていた沖電気の長坂さんとお話することができたのですが、その時に、Tachyon CLだけでなく同じく沖電気で作っていたISLispの実装である OKI ISLispも再度公開したいとのお話を伺っていました。

この時のお話を覚えていて下さったのか、OKI ISLispの再公開にあたり長坂さんよりメールで再公開を教えて頂けました。ありがとうございます!

ISLispは、ISO規格のLISPでベースとなった言語はCommon Lisp。Schemeやヨーロッパで使われていたEuLisp、Le Lisp等を参考にしつつ仕様はコンパクトで一貫性のあるものを目指して制定されたそうです。

islisp.orでは、いまのところ、OKI ISLispのWindows 32ビット版のみの公開ですが、自分は、Ubuntu 10.4(64 bit)上のwineで動かしてみました。

$ wine ISLisp.exe
> ISLisp  Version 0.80 (1999/02/25)
>
ISLisp>

(defun fib (n)
 (if (< n 2)
     n
     (+ (fib (- n 1))
        (fib (- n 2)))))

(compile 'fib)

(time (fib 40))

ISLisp>>Elapse time = 46.325 sec.
>GC: 0  Stack Used: 241
>CONS: 0 (GC: 0)
>SYMBOL: 0 (GC: 0)
>HEADER: 20 (GC: 0)
>VECTOR: 60 (GC: 0)
102334155

(defglobal foo 33)
(defglobal bar (lambda () foo))

(let ((foo 100))
  (funcall 
   (let ((foo 42))
     (lambda ()
       (list (funcall bar)
             foo)))))
;⇒ (33 42)

;; 参考 GNU CLISP 2.47 でコンパイルして 38.35 sec.

Linuxの32ビット版も公開予定とのことです。

また、リリースノートや入門マニュアルも今後公開されてゆくとのことです。

今後の動向に期待です!

2010-09-14

コンスセルのアスキーアート

| 00:05 | コンスセルのアスキーアート - わだばLisperになる を含むブックマーク はてなブックマーク - コンスセルのアスキーアート - わだばLisperになる

以前、lisppasteで、良い感じのコンスセルのAAを見掛けました。

+-------------------------------------------------------+
|                                                       |
|                                                       |
| +---+---+   +---+---+   +---+---+   +---+---+   +---+ |
| | * | * |-->| * | * |-->| * | * |-->| * | * |-->| 5 | |
| +---+---+   +---+---+   +---+---+   +---+---+   +---+ |
|   |           |           |           |               |
|   v           |           v           v               |
| +---+         |         +---+---+   +---+             |
| | 1 |         |         |NIL|NIL|   | 4 |             |
| +---+         |         +---+---+   +---+             |
|               v                                       |
|             +---+---+   +---+---+                     |
|             | * | * |-->| * |NIL|                     |
|             +---+---+   +---+---+                     |
|               |           |                           |
|               v           v                           |
|             +---+       +---+---+                     |
|             | 2 |       | * |NIL|                     |
|             +---+       +---+---+                     |
|                           |                           |
|                           v                           |
|                         +---+                         |
|                         | 3 |                         |
|                         +---+                         |
+-------------------------------------------------------+

のようなものなのですが、どうも専用の関数で描画している様子。

CLikiに登録されているライブラリでもなく、そのうち探してみようと思ってすっかり忘れていました。

今日ふと思い出したので、ググったりしてソースを見付けました。

作者は、comp.lang.lispの常連でもある、<PJB> Pascal J. Bourguignonさんで、Bourguignonさんのユーティリティ集の中に含まれているようです。

導入方法(例)

$ darcs get http://darcs.informatimago.com/darcs/public/lisp common-lisp
$ ln -s system.asd asdf:*central-registry*のディレクトリ

論理パスを設定

;; /share/sys/cl/src/にcom/informatimago/common-lispとして設置した場合
;; (つまり、/share/sys/cl/src/com/informatimago/common-lisp に置いた場合)
(setf (logical-pathname-translations "packages")
      `(("**;*.*.*" "/share/sys/cl/src/**/*.*")))

;; (TRANSLATE-LOGICAL-PATHNAME "PACKAGES:COM;INFORMATIMAGO;COMMON-LISP;HTML401.LISP")
;; 等で動作確認

SBCLの場合、 SB-IMPL::*EXTERNAL-FORMATS* の仕様が古いもの(リスト)になっていて現在(ハッシュ)と形式が違うのでちょっと修正。

;; common-lisp/character-sets.lisp"
(defparameter *lisp-encodings*
  #+clisp (group-charset-aliases)
  #+(OR) (mapcar (lambda (x) (mapcar 'string-upcase (first x)))
                   SB-IMPL::*EXTERNAL-FORMATS*)
  #+sbcl (LET (ANS)
           (MAPHASH (LAMBDA (K V) 
                      (DECLARE (IGNORE K))
                      (PUSHNEW (MAPCAR #'STRING-UPCASE (SB-IMPL::EF-NAMES V))
                               ANS
                               :TEST #'EQUALP))
                    SB-IMPL::*EXTERNAL-FORMATS*)
           ANS)
  #+cmu   '(("ISO-8859-1"))          ; :iso-latin-1-unix ;  what else?
  #-(or clisp sbcl cmu)
  (progn
    (warn "What are the available external formats in ~A ?"
          (lisp-implementation-type))
    '(("US-ASCII"))))

そして、

(asdf:oos 'asdf:load-op :com.informatimago.common-lisp)

のようにして導入。

色々なものが入ります。

動作は、

(IMPORT 'COM.INFORMATIMAGO.COMMON-LISP.CONS-TO-ASCII:DRAW-LIST)

(DRAW-LIST (LIST* '(1 2) 3 4))
;⇒
+-------------------------------+
|                               |
|                               |
| +---+---+   +---+---+   +---+ |
| | * | * |-->| * | * |-->| 4 | |
| +---+---+   +---+---+   +---+ |
|   |           |               |
|   |           v               |
|   |         +---+             |
|   |         | 3 |             |
|   |         +---+             |
|   v                           |
| +---+---+   +---+---+         |
| | * | * |-->| * |NIL|         |
| +---+---+   +---+---+         |
|   |           |               |
|   v           v               |
| +---+       +---+             |
| | 1 |       | 2 |             |
| +---+       +---+             |
+-------------------------------+

こんな感じ。

Bourguignonさんの書くソースはコーディング規約的なものがきっちりしていて職人的な香りがします。

ちなみに、自分がloopで、loopキーワードをキーワードシンボルで書くのはBourguignonさんの真似です。

2010-09-13

このブログのKMRCLのエントリーをSLIMEから検索する(2)

| 00:30 | このブログのKMRCLのエントリーをSLIMEから検索する(2) - わだばLisperになる を含むブックマーク はてなブックマーク - このブログのKMRCLのエントリーをSLIMEから検索する(2) - わだばLisperになる

anything.elとの連携は、日付をまたいで次のエントリーにしよう(LISP365のため)と思っていたのですが、そんな風にぼーっとしている間に d:id:kitokitoki さんに光速でanything.elのソースを作って頂けました!

同じものを載せるわけにも行かないので、ちょっと機能を追加しましたw

  1. (setq anything-c-source-なんとか)というのがどうも馴染めないのでdefanythingというマクロを書きました。
  2. Googleソースコード検索もおまけで付けました

defanythingは、define-anything-c-sourceのようにanything-c-sourceに限定した方が良いかもしれないですね。

anything側で絞りこまないで外に丸投げする方法が分からなかったので、anything-inputの中身を読むようにしたんですが、これで良いんでしょうか。

thing-at-pointで拾えないときは候補に出ないんですよね…。まあ良いか。

こうなったら

等、あらゆる物を検索対象にしたいですね。

;; Emacs lisp
(defmacro unless-defined (def name args &rest body)
  (unless (fboundp name)
    `(,def ,name ,args ,@body)))

(unless-defined defun mkstr (&rest args)
  "writes args into a string and returns that string"
  (apply #'concat (mapcar (lambda (x) (format "%s" x))
                          args)))
(unless-defined defun symb (&rest args)
  "creates a new symbol from args"
  (intern (apply #'mkstr args)))

(unless-defined defun cl-symbol-name (symbol-or-name)
  (let* ((name (format "%s" symbol-or-name))
         (pos (search ":" name :from-end t)))
    (substring name (if pos (1+ pos) 0))))

(defmacro* defanything ((name type) &rest source)
  `(setq ,(symb "anything-" type "-" name)
         ',(mapcar (lambda (x) (cons (car x) (cadr x)))
                   source)))

(defun google-code-search-lisp-lookup (symbol-name)
  "シンボルをGoogle Codeで検索(lisp決め打ち)"
  (interactive)
  (browse-url
   (format "http://www.google.com/codesearch?q=%s\\++lang:%s+file:\\.%s$&hl=ja&num=20"
           symbol-name "lisp" "lisp")))

(eval-after-load "anything"
  '(progn
     (defanything (hyperspec c-source)
       (name "Lookup Hyperspec")
       (candidates (lambda ()
                     (let ((symbols () ))
                       (mapatoms #'(lambda (sym) (push (symbol-name sym) symbols))
                                 common-lisp-hyperspec-symbols)
                       symbols)))
       (action (("Show Hyperspec" . hyperspec-lookup))))

     (defanything (cltl2 c-source)
       (name "Lookup CLtL2")
       (candidates (lambda ()
                     (let ((symbols () ))
                       (mapatoms #'(lambda (sym) (push (symbol-name sym) symbols))
                                 cltl2-symbols)
                       symbols)))
       (action (("Show CLTL2" . cltl2-lookup))))

     (defanything (g000001-kmrcl c-source)
       (name "Lookup G000001-KMRCL")
       (candidates (lambda ()
                     (let ((symbols () ))
                       (mapatoms #'(lambda (sym) (push (symbol-name sym) symbols))
                                 g000001-kmrcl-symbols)
                       symbols)))
       (action (("Show G000001-KMRCL" . g000001-kmrcl-lookup))))

     (defanything (google-code-search-lisp-lookup c-source)
       (name "Google Code Search (LISP)")
       (candidates (lambda () (list anything-input))) ;anything-input
       (action (("Google Code Search (LISP)" . google-code-search-lisp-lookup))))
     
     (defun anything-cl-lookup ()
       (interactive)
       (anything (list anything-c-source-hyperspec 
                       anything-c-source-google-code-search-lisp-lookup
                       anything-c-source-cltl2
                       anything-c-source-g000001-kmrcl )
                 (cl-symbol-name (thing-at-point 'symbol))))))

(define-key slime-mode-map [(control ?c) (control ?d) ?l] 'anything-cl-lookup)

2010-09-12

このブログのKMRCLのエントリーをSLIMEから検索する

| 21:12 | このブログのKMRCLのエントリーをSLIMEから検索する - わだばLisperになる を含むブックマーク はてなブックマーク - このブログのKMRCLのエントリーをSLIMEから検索する - わだばLisperになる

今日、はてなブログを読んでいて、cltl2.elが割と力技で作られていることを思い出しました。

そして力技で良いんだったら、このブログのKMRCLを読むエントリーも引けるようになるんじゃないか、ということで、誰得なelispを書いてみました。

誰得ついでにanythingのソースも作成中です。

2010-09-11

ZetalispのPKG-BIND

| 23:47 | ZetalispのPKG-BIND - わだばLisperになる を含むブックマーク はてなブックマーク - ZetalispのPKG-BIND - わだばLisperになる

LispマシンのLISPであるZetalisp/Lisp machine lispには、PKG-BINDというのがあって

(PKG-BIND "FOO"
  (DEFUN FOO (N) N))

のように指定した範囲だけパッケージが指定できます。

パッケージの仕組みからして違うのでそもそもCLで再現できるのか分からないのですが、今日Twitterでやりとりをしている中でS式を一旦文字列にしてREAD-FROM-STRINGすれば良いかと思い

(DEFMACRO PKG-BIND (&WHOLE WHOLE PKG &BODY BODY)
  (LET ((PKG-BIND-PKG (PACKAGE-NAME (SYMBOL-PACKAGE (CAR WHOLE)))))
    `(LET ((*PACKAGE* (FIND-PACKAGE ,PKG)))
       (EVAL
        (READ-FROM-STRING
         ,(WRITE-TO-STRING 
           `(PROGN 
              (IMPORT (READ-FROM-STRING
                       ,(FORMAT NIL 
                                "~A::PKG-BIND"
                                PKG-BIND-PKG)))
              ,@BODY)))))))

みたいなものを作成しました。

ZetalispのPKG-BINDが入れ子にできるのかどうか不明なのですが、とりあえず入れ子に対応。

(DEFPACKAGE :FOO (:USE :CL))
(PKG-BIND :FOO
  (DEFUN FOO (N) N)

  (DEFPACKAGE :BAR (:USE :CL))
  (PKG-BIND :BAR
    (DEFUN BAR (N) N)

    (DEFPACKAGE :BAZ (:USE :CL))
    (PKG-BIND :BAZ
      (DEFUN BAZ (CL-USER::N) CL-USER::N))))

(LIST (FOO::FOO 8)
      (BAR::BAR 8)
      (BAZ::BAZ 8))
;⇒ (8 8 8)

EVALを使うので外部のレキシカルな変数は取り込めないのですが、この方法以外でインターンするシンボルを選り分けるのは、なかなか面倒なので、まあ、これで良いかなと妥協。

以前はボディを走査してシンボルのパッケージを書き換えるという方法を試してみていました。

書き方が悪かった所為で上手く行かなかったような気もするので、シンボルを操作する方法でも書いてみたいと思います。

2010-09-10

KMRCLを眺める(204) GENERALIZED-EQUAL

| 23:05 | KMRCLを眺める(204) GENERALIZED-EQUAL - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める(204) GENERALIZED-EQUAL - わだばLisperになる

今回は、KMRCLのequal.lispからGENERALIZED-EQUALです。

GENERALIZED-EQUALは、これまで眺めたequal.lispで定義されている関数群の集大成です。

定義は、

(defun generalized-equal (obj1 obj2)
  (if (not (equal (type-of obj1) (type-of obj2)))
      (progn
        (terpri)
        (describe obj1)
        (describe obj2)
        nil)
    (typecase obj1
      (double-float
       (let ((diff (abs (/ (- obj1 obj2) obj1))))
         (if (> diff (* 10 double-float-epsilon))
             nil
           t)))
      (complex
       (and (generalized-equal (realpart obj1) (realpart obj2))
            (generalized-equal (imagpart obj1) (imagpart obj2))))
      (structure-object
       (generalized-equal-fielded-object obj1 obj2))
      (standard-object
       (generalized-equal-fielded-object obj1 obj2))
      (hash-table
       (generalized-equal-hash-table obj1 obj2))
      (function
       (generalized-equal-function obj1 obj2))
      (string
       (string= obj1 obj2))
      (array
       (generalized-equal-array obj1 obj2))
      (t
       (equal obj1 obj2)))))

となっていて、それぞれの型に応じて切り分けられています。

型が一致していなかった時にDESCRIBEしてみせるというのが面白いですね。

動作は、

(KL:GENERALIZED-EQUAL 'CL:PROGN 1)
;->
COMMON-LISP:PROGN
  [symbol]

PROGN names a special operator:
  Lambda-list: (&REST FORMS)
  Documentation:
    PROGN form*
    
    Evaluates each FORM in order, returning the values of the last form. With no
    forms, returns NIL.
  Source file: SYS:SRC;COMPILER;IR1-TRANSLATORS.LISP

Symbol-plist:
  LTD::CVT-FN -> #<FUNCTION (LAMBDA (EXP)) {1000..
  CL-IRREGSEXP::SIMPLIFIER -> #S(CL-IRREGSEXP::SIMPLIFIER..
  SERIES::SCAN-TEMPLATE -> (SERIES::Q . #1=(SERIES::E . #1..
  SB-WALKER::WALKER-TEMPLATE -> (NIL SB-WALKER::REPEAT (EVAL))
1
  [fixnum]

というところ。

総じて言えることとしてはGENERALIZED-EQUAL-FUNCTIONが処理系によっては上手く機能しないというのが残念ですね。

2010-09-09

KMRCLを眺める(203) STRUCTURE-SLOT-NAMES

| 13:18 | KMRCLを眺める(203) STRUCTURE-SLOT-NAMES - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める(203) STRUCTURE-SLOT-NAMES - わだばLisperになる

今回は、KMRCLのequal.lispからSTRUCTURE-SLOT-NAMESです。

クラスのスロット名を取得するものは眺めましたが、今回は構造体用の物です。

定義は、


(defun structure-slot-names (s-name)
  "Given a STRUCTURE-NAME, returns a list of the slots in the structure."
  #+allegro (class-slot-names s-name)
  #+lispworks (structure:structure-class-slot-names
               (find-class s-name))
  #+(or sbcl cmu) (mapcar #'kmr-mop:slot-definition-name
                          (kmr-mop:class-slots (kmr-mop:find-class s-name)))
  #+scl (mapcar #'kernel:dsd-name
                (kernel:dd-slots
                 (kernel:layout-info
                  (kernel:class-layout (find-class s-name)))))
  #+(and mcl (not openmcl))
  (let* ((sd (gethash s-name ccl::%defstructs%))
               (slots (if sd (ccl::sd-slots sd))))
          (mapcar #'car (if (symbolp (caar slots)) slots (cdr slots))))
  #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl)))
  (declare (ignore s-name))
  #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl)))
  (error "structure-slot-names is not defined on this platform")
  )

となっているのですが、#+(or sbcl cmu)では CLASS-SLOT-NAMES と同一の定義です。

動作は、

(DEFSTRUCT FOO X Y Z)

(KL::STRUCTURE-SLOT-NAMES 'FOO)
;⇒ (X Y Z)

しかし、折角定義されているこの関数ですが、どこからも呼ばれていないのが謎です。

CLASS-SLOT-NAMESで間に合ってしまうということなのでしょうか。

2010-09-08

KMRCLを眺める(202) GENERALIZED-EQUAL-FIELDED-OBJECT

| 12:51 | KMRCLを眺める(202) GENERALIZED-EQUAL-FIELDED-OBJECT - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める(202) GENERALIZED-EQUAL-FIELDED-OBJECT - わだばLisperになる

今回は、KMRCLのequal.lispからGENERALIZED-EQUAL-FIELDED-OBJECTです。

今回も、名前からしてクラス/構造体の同値性を判定するものと思われます。

定義は、

(defun generalized-equal-fielded-object (obj1 obj2)
  (block test
    (when (not (equal (class-of obj1) (class-of obj2)))
      (return-from test nil))
    (dolist (field (class-slot-names (class-name (class-of obj1))))
      (unless (generalized-equal (slot-value obj1 field) (slot-value obj2 field))
        (return-from test nil)))
    (return-from test t)))
  1. CLASS-OF でクラスを判定して一致していなかったら脱出
  2. 次に前回眺めたCLASS-SLOT-NAMESで各スロットの名前をとりだし、SLOT-VALUEで取り出した値を再帰的にGENERALIZED-EQUALですべてを比較

という感じでしょうか。

動作は、

(DEFSTRUCT FOO X Y Z)

(DEFCLASS BAR ()
  ((A :INITARG :A)
   (B :INITARG :B)
   (C :INITARG :C)))

(KL::GENERALIZED-EQUAL-FIELDED-OBJECT (MAKE-FOO :X 1 :Y 2 :Z 3)
                                      (MAKE-FOO :X 1 :Y 2 :Z 3))
;⇒ T

(KL::GENERALIZED-EQUAL-FIELDED-OBJECT (MAKE-INSTANCE 'BAR :A 1 :B 2 :C 3)
                                      (MAKE-INSTANCE 'BAR :A 1 :B 2 :C 4))
;⇒ NIL

というところ。

2010-09-07

KMRCLを眺める(201) CLASS-SLOT-NAMES

| 22:21 | KMRCLを眺める(201) CLASS-SLOT-NAMES - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める(201) CLASS-SLOT-NAMES - わだばLisperになる

今回は、KMRCLのequal.lispからCLASS-SLOT-NAMESです。

名前からするとクラスのスロット(他の言語でいうメンバー変数のことをLISP系ではスロットと呼ぶ)の名前を取得するもののようです。

(defun class-slot-names (c-name)
  "Given a CLASS-NAME, returns a list of the slots in the class."
  #+(or allegro cmu lispworks sbcl scl)
  (mapcar #'kmr-mop:slot-definition-name
          (kmr-mop:class-slots (kmr-mop:find-class c-name)))
  #+(and mcl (not openmcl))
  (let* ((class (find-class c-name nil)))
    (when (typep class 'standard-class)
      (nconc (mapcar #'car (ccl:class-instance-slots class))
             (mapcar #'car (ccl:class-class-slots class)))))
  #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl)))
  (declare (ignore c-name))
  #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl)))
  (error "class-slot-names is not defined on this platform")
  )

定義の内容としては、

(MAPCAR #'closer-mop:SLOT-DEFINITION-NAME 
        (closer-mop:CLASS-SLOTS (FIND-CLASS 'FOO)))

というのが本体で、MOPの領域になりますが、

  1. FIND-CLASSでCLASSを取り出して
  2. CLASS-SLOTSでSLOTを取り出して(リスト)
  3. SLOT-DEFINITION-NAMEで名前を得る

という感じです。

動作は、

(DEFSTRUCT FOO X Y Z)
(KL::CLASS-SLOT-NAMES 'FOO)
;⇒ (X Y Z)

(DEFCLASS BAR ()
  (A B C))

(CLOSER-MOP:FINALIZE-INHERITANCE (FIND-CLASS 'BAR))

(KL::CLASS-SLOT-NAMES 'FOO)
;⇒ (A B C)

というところ

2010-09-06

KMRCLを眺める(200) GENERALIZED-EQUAL-HASH-TABLE

| 22:21 | KMRCLを眺める(200) GENERALIZED-EQUAL-HASH-TABLE - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める(200) GENERALIZED-EQUAL-HASH-TABLE - わだばLisperになる

今回は、KMRCLのequal.lispからGENERALIZED-EQUAL-HASH-TABLEです。

KMRCLを眺めつづけてとうとう200回になってしまいました。まだ残りは結構あります…。

今回も引き続きで、名前からしてハッシュテーブルの同値性を判定するものと思われます。

定義は、

(defun generalized-equal-hash-table (obj1 obj2)
  (block test
    (when (not (= (hash-table-count obj1) (hash-table-count obj2)))
      (return-from test nil))
    (maphash
     #'(lambda (k v)
         (multiple-value-bind (value found) (gethash k obj2)
           (unless (and found (generalized-equal v value))
             (return-from test nil))))
     obj1)
    (return-from test t)))

HASH-TABLE-COUNT でサイズを勘定して比較し同じでないなら脱出。サイズが同じなら今度は再帰的にハッシュの要素について GENERALIZED-EQUAL で判定、ということで前回のGENERALIZED-EQUAL-ARRAYと同じ構成です。

(LET ((TAB1 (MAKE-HASH-TABLE))
      (TAB2 (MAKE-HASH-TABLE :TEST 'EQUAL)))
  (KL::GENERALIZED-EQUAL-HASH-TABLE TAB1 TAB2))
;⇒ T
(G000001::AUTO-IMPORT 'ALIST->HASH-TABLE)
;⇒ (:FARE-UTILS)

(LET ((TAB1 (ALIST->HASH-TABLE 
             '((:A . 1)
               (:B . 2)
               (:C . 3))))
      (TAB2 (ALIST->HASH-TABLE 
             '((:A . 1)
               (:B . 2)
               (:c . 3)))))
  (KL::GENERALIZED-EQUAL-HASH-TABLE TAB1 TAB2))
;⇒ T

2010-09-04

KMRCLを眺める(199) GENERALIZED-EQUAL-ARRAY

| 22:47 | KMRCLを眺める(199) GENERALIZED-EQUAL-ARRAY - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める(199) GENERALIZED-EQUAL-ARRAY - わだばLisperになる

今回は、KMRCLのequal.lispからGENERALIZED-EQUAL-ARRAYです。

名前からしてArrayの同値性を判定するものと思われます。

定義は、

(defun generalized-equal-array (obj1 obj2)
  (block test
    (when (not (= (array-total-size obj1) (array-total-size obj2)))
      (return-from test nil))
    (dotimes (i (array-total-size obj1))
      (unless (generalized-equal (aref obj1 i) (aref obj2 i))
        (return-from test nil)))
    (return-from test t)))

というところ。

まず、ARRAY-TOTAL-SIZE を知らべて大きさが違うならば脱出(ちなみに、(NOT (= ...))は(/= ...)と書けますよね)。

次にArrayの要素一つ一つに対してGENERALIZED-EQUALで判定(つまり再帰的に)という風になっています。

その、GENERALIZED-EQUALは、equal.lispで定義されている親玉というか、GENERALIZED-EQUAL-ARRAYのような物を合体したもっとも汎用的なものです。

動作的には、EQUALPとどういう風に違うのか、equal.lispを眺め終える時に確認したいと思います。

動作は、

(KL::GENERALIZED-EQUAL-ARRAY `#(() ,#'CAR ,(LAMBDA (X) 8)) 
                             `#(() ,#'CAR ,(LAMBDA (X) 8)))
;⇒ T ;Allegro CL/CLISP
;⇒ NIL ;SBCL/Clozure CL

;; 比較 EQUALP
(EQUALP `#(() ,#'CAR ,(LAMBDA (X) 8)) 
        `#(() ,#'CAR ,(LAMBDA (X) 8)))
;⇒ NIL

2010-09-02

KMRCLを眺める(198) GENERALIZED-EQUAL-FUNCTION

| 21:10 | KMRCLを眺める(198) GENERALIZED-EQUAL-FUNCTION - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める(198) GENERALIZED-EQUAL-FUNCTION - わだばLisperになる

今回は、KMRCLのequal.lispからGENERALIZED-EQUAL-FUNCTIONです。

名前からすると同じ関数かどうかを判定するものと思われます。

定義は、

(defun generalized-equal-function (obj1 obj2)
  (string= (function-to-string obj1) (function-to-string obj2)))

前回眺めたFUNCTION-TO-STRINGを使っていて、結果をSTRING=で比較したりしているのですが、FUNCTION-TO-STRINGの大本となるFUNCTION-LAMBDA-EXPRESSIONが処理系依存の動作なため、処理系により上手く結果がでないようです。

(恐らくAllegro CL、CLISPでは多分意図した通り動く)

(KL::GENERALIZED-EQUAL-FUNCTION #'CAR #'CAR)
;⇒ T ;SBCL/CLISP/Allegro CL


(KL::GENERALIZED-EQUAL-FUNCTION (LAMBDA (X) (CAR X))
                                (LAMBDA (X) (CADR X)))
;⇒ NIL ;Allegro CL/CLISP
;⇒ T   ;SBCL

SBCL/Clozure CLではこういうのはどう書いたら良いのか…。

2010-09-01

重なったフィルターをLISPで左から右に簡潔で読み易く書きたい

| 22:28 | 重なったフィルターをLISPで左から右に簡潔で読み易く書きたい - わだばLisperになる を含むブックマーク はてなブックマーク - 重なったフィルターをLISPで左から右に簡潔で読み易く書きたい - わだばLisperになる

以前から良く考える問題ではあるのですが、今日、

(defun PARENTHIZE (str)
  (let ((rstr (reverse str)))
    (ppcre:regex-replace-all 
     "\\s"
     (write-to-string 
      (reduce (lambda (acc x)
                (cons x (list acc)))
              (subseq rstr 1)
              :initial-value (list (char rstr 0)))
      :pretty nil
      :escape nil)
     "")))
(PARENTHIZE "いろはにほへとちりぬるを")
;⇒ "(い(ろ(は(に(ほ(へ(と(ち(り(ぬ(る(を))))))))))))"

という非常にどうでも良い関数を書いていて、処理の流れが括弧の内側から外側に向っていくのが、やっぱりよみにくいかなあと思い、上手く書ける記法はないかと、色々考えてみました。

こんな風に書けば良いのか

(defun PARENTHIZE (str)
  (let* ((* (reverse str))
         (* (reduce (lambda (acc x)
                       (cons x (list acc)))
                     (subseq * 1)
                     :initial-value (list (char * 0))))
         (* (write-to-string * :pretty nil :escape nil))
         (* (ppcre:regex-replace-all "\\s" * "")))
    *))

こんなマクロを書いてみれば良いのか

(defmacro SEQ (&body body)
  `(LET* (,(mycl-util:group body 2))
     ,(car (last body 2))))
(defun PARENTHIZE (str)
  (seq
    * (reverse str)
    * (reduce (lambda (acc x)
                (cons x (list acc)))
              (subseq * 1)
              :initial-value (list (char * 0)))
    * (write-to-string * :pretty nil :escape nil)
    * (ppcre:regex-replace-all "\\s" * "")))

いや、やっぱりこう書けた方が編集には都合が良いか

(defun PARENTHIZE (str)
  (seq
    (* (reverse str))
    (* (reduce (lambda (acc x)
                 (cons x (list acc)))
               (subseq * 1)
               :initial-value (list (char * 0))))
    (* (write-to-string * :pretty nil :escape nil))
    (* (ppcre:regex-replace-all "\\s" * ""))))

いやいや、いっそこう書けた方が良いか

(defun PARENTHIZE (str)
  (seq
    (reverse str) => *
    (reduce (lambda (acc x)
              (cons x (list acc)))
            (subseq * 1)
            :initial-value (list (char * 0))) => *
    (write-to-string * :pretty nil :escape nil) => *
    (ppcre:regex-replace-all "\\s" * "")))

こういうフィルターを順次重ねてゆく感じの場面で、左から右に良い感じで記述できるような記法/マクロがあったら教えて欲しいです。