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 |

2007-11-18

祝Multics Emacsのソース公開

| 04:56 | 祝Multics Emacsのソース公開 - わだばLisperになる を含むブックマーク はてなブックマーク - 祝Multics Emacsのソース公開 - わだばLisperになる

Multicsのソースが公開されたとのことで、Multicsといえば、PDP-10以外でMaclispが稼働していたプラットホームになります。

それと、有名?なところでは、Multics Emacsがあり、Maclispで書かれていて、そのMaclisp自体で拡張可能だったところが画期的だったとEmacsの歴史が語られる際には良く出てきます。

確か未だにMulticsは稼働するエミュレータがなかったと思いますがこれを機にMultics周辺が盛り上がって、エミュレータが動くようになると楽しいなと思います。

ということで、Multics Emacsのソースとか、Maclispのソースを探してみましたが、どっちも公開されていたので、若干無理矢理ながらMultics Emacsのコードをお題にしてみたいと思います。

ここのソースのe_~とか、emacs_~がEmacsのソースっぽいです。

今回のお題は、emacros_.listから抜き出していて、眺めた感じでは、A product of Greenberg, 3/78という記載があるので、1978年の3月に最初のバージョンが完成したようです。

お題

Multics-Emacs-if

暗記で再現

(defmacro Multics-Emacs-if (condition &body forms)
  (do (ifs
       elses
       (l forms (cdr l)))
      ((endp l)
       (cond (elses `(cond (,condition .,(nreverse ifs))
			   ('T .,(nreverse elses))))
	     ('T `(cond (,condition .,(nreverse ifs))))))
    (let ((form (car l)))
      (cond ((eq 'else form)
	     (setq elses (list nil )))
	    (elses (push form elses))
	    ('T (push form ifs))))))

できた。ifでelseというキーワードが使いたかったらしく、拡張したマクロ。Multics Emacsでは、これがifという名前で使えたようです。

then節もelse節も暗黙のprognになっています。else節には、毎回nilが先頭に来ますが結果に影響はないので、良いのでしょう。

また、マクロの中で、,@ではなくて、.,と書かれていますが、'(foo . (bar) ) => '(foo bar)ということでこういう風に書いているのでしょう。また、ドットとコンマの間に空白文字があってもなくてもOKなのでくっつけて書いているのでしょう。

Multics Emacsでは、全般的に,@ではなくて、.,を使うスタイルのようです。順番が逆の,.もあったりして色々紛らわしいです(*'-')

;; 動作
(multics-emacs-if (= 6 (+ 3 3))
  "おそらく3 + 3は"
  "6という結果になるに違いない"
  else
  "3 + 3が6以外になるなんて"
  "コンピュータは壊れているに違いない")
;=> "6という結果になるに違いない"

お題

do-times

(defmacro do-times (howmany &body forms)
	(let ((dovar (gensym)))
	     `(do ,dovar ,howmany (1- ,dovar) (< ,dovar 1)
		. ,forms)))

暗記で再現

(defmacro do-times (howmany &body forms)
  (let ((dovar (gensym)))
    `(do ((,dovar ,howmany (1- ,dovar)))
	 ((< ,dovar 1))
       . ,forms)))

できた。シンプルなdotimesといった感じ。オリジナルdoの書式が何だか変ですが、これはdoの一番古い形式なので、Common Lispの形式に変更しました。Common Lispで使われる形式は、2番目のパターンで、Maclispには、全部で3パターンの形式があります。

;; 動作
(do-times 5
  (print "Hello"))
;=> Hello
;Hello
;Hello
;Hello
;Hello

お題

do-forever

暗記で再現

(defmacro do-forever (&body forms)
  `(do () (nil) . ,forms))

できた。do-foreverは、多分LispMに由来するマクロ。Zetalispには、do-foreverが標準で存在しています。名前の通り本体部を繰り返すだけのもの。

;; 動作
(do-forever
  (print "hello")
  (return t))
; => "hello"

お題

(defmacro with-mark (mark &body forms)
	`(let ((,mark nil))
	      (unwind-protect
	        (progn (setq ,mark (set-mark))
		     . ,forms)
	        (and ,mark (release-mark ,mark)))))

暗記で再現:間違えた

(defmacro with-mark (&body forms)
  (let ((mark (gensym)))
    `(unwind-protect 
	  (progn (setq ,mark (set-mark))
		 . ,forms)
       (progn (setq ,mark (release-mark))))))

;; でっちあげ関数
(defun set-mark ()
  (random 1))

(defmacro release-mark (mark) 
  `(setq ,mark nil))

間違えた。save-excursionを読むため補助関数を先に。

markにはgensymを入れるわけではなく、全体の動きも把握できていなかった。

ポイント位置においてのletのようなものだろうか。

お題

save-excursion

(defmacro save-excursion (&body forms)
       (let ((mark (gensym)))
	  `(with-mark ,mark
		    (unwind-protect
		      (progn .,forms)
		      (go-to-mark ,mark)))))

暗記で再現:間違えた

(defmacro save-excursion (&body forms)
  (let ((mark (gensym)))
    `(unwind-protect 
	  `(with-mark ,mark
	     . ,forms
       (go-to-mark)))))

;; でっち上げ関数
(defun go-to-mark (mark)
  (format t "Go to ~A.~%" mark))

間違えた。全体の仕組を全然把握できてなかった。go-to-markはどこにカーソルを飛ばすのかな、などど悩みましたが、with-markとunwind-protectとの入れ子関係を間違ってただけでした。

Emacsでもお馴染みのsave-excursionがGNU Emacsより前からあったとは意外です。

;; 動作
(save-excursion
  (print "どうも")
  (print "こんにちは"))

;"どうも" 
;"こんにちは" Go to 0.

雑多なこと

save-excursionや現在でお馴染の関数が、かなりMultics Emacsに存在していたというのが意外でした。

非常にタイムリーですが、Multics Emacsに関連しては、最近ブログを始めた様子の、Dan Weinreb氏もエントリの中で言及しています。

このエントリは、RMSの講演の内容My Lisp Experiences and the Development of GNU Emacs- GNU Project - Free Software Foundationへの反論だそうで、内容は細かく色々ありますが、Multics Emacs関連ではLispで拡張できるEmacs系エディタとしては、Weinreb氏のLispM用のエディタ(ZWEI[最初は、EINE])が最初のもので、Multics Emacsではない、ということです。また、Emacsは、Guy Steel氏とDavid Moon氏が最初に作ったもので、RMSじゃない、とか。コメント欄で、Multics Emacsの作者Bernie Greenberg氏や、David Moon氏と思われるコメントもあるので、お好きな方はどうぞ…。

まあ、何にしろ、RMS抜きでは現在のEmacsは存在していないと思うし、今日のフリーソフトの盛況もなかったと思いますが…。

また、Lispで拡張できるEmacs系のエディタに関しては、Zmacs系と、GNU Emacs系があるように思います。コマンドの拡張方法や、バッファや行の表現方法等が違うので、この二つに大別できるような気がするのですが…。

  • Zmacs系
    • EINE、ZWEI、Zmacs
    • LispWorksのエディタ
    • Hemlock
    • Climacs(両者の中間っぽい?)
  • GNU Emacs系
    • Multics Emacs
    • GNU Emacs
    • Xyzzy

以上、細かい割には詳しく調べていないどうでも良い考察でした…。

2007-11-15

LispMの関数こまごま

| 16:33 | LispMの関数こまごま - わだばLisperになる を含むブックマーク はてなブックマーク - LispMの関数こまごま - わだばLisperになる

何となく古いコードを散策したかったので、Lispマシン(以下LispM)の関数を読んでみることにしました。

お題に使用したコードは、LMIのLambdaのシステム部分のもので、ウェブで公開されています。

お題

zl:everyと、zl:some

暗記で再現

(defun zl_every (pred list &optional (step #'cdr))
  (do ((tail list (funcall step tail)))
      ((endp tail) t)
    (unless (funcall pred (car tail))
      (return nil))))

(defun zl_some (pred list &optional (step #'cdr))
  (do ((tail list (funcall step tail)))
      ((endp tail) nil)
    (when (funcall pred (car tail))
      (return t))))

できた。zl:everyとなっているのは、Zetalispの定義がまとめてパッケージになっているため。Zetalispは、LispM用のLispでCommon Lispの直接の先祖です。Common Lispが登場すると、LispMのメーカーも基本的にCommon Lispを基盤とするようになりZetalispは互換性のため残されていたという風に見えます。ステップ用の関数を指定できたりするのが、意外というか、どういう時に役に立つのかあまり想像が付きません…。ちなみに、Lisp Machine Lispと、Zetalispの違いですが、「Evolution of Lisp」によれば、Lisp Machine Lispは元々のLispM用のLispでしたが、ハードウェアのシステムソフトを全面的にLispで記述するには、それでは弱かったので記述できるようにSymbolicsが強化したものをZetalispと命名したようです。しかし、LMIも、TIもZetalispと呼んでいて、なおかつマニュアルは、Lisp Machine LispとZetalispと共通ということなので、何が何だか分かりません。まあ、LispM用のLispはZetalispと呼んでおけば良いんでしょう。

;; 動作
(zl_every #'plusp '(1 2 3 4 5) #'cddr)
;=> T

お題

firstn

暗記で再現

(defun firstn (n list)
  (let ((new-list (make-list n)))
    (do ((list list (cdr list))
	 (new-list new-list (cdr new-list)))
	((or (endp list) (endp new-list)))
      (rplaca new-list (car list)))
    new-list))

SRFI-1のtakeと同じ機能。

PG氏のユーティリティにもあったんですが、PG氏オリジナルじゃなくて、LispM由来のものだったとは知りませんでした。

doの定番書式からすると、

(defun firstn (n list)
  (do ((list list (cdr list))
       (new-list (make-list n) (cdr new-list)))
      ((or (endp list) (endp new-list)) new-list)
    (rplaca new-list (car list))))

でも良いんじゃないかと思いましたが、doの中身で使われているnew-listとletでのnew-listは別物で、doの中身は、ポインタ移動用?で、letのは、先頭のポインタ保持用?なので、一緒にすると上手く機能しないという罠。

;; 動作
(firstn 3 '(1 2 3 4 5))
;=> (1 2 3)

お題

circular-list

暗記で再現

(defun circular-list (&rest args &aux tem)
  (when args
    (setq tem (copy-list args))
    (setf (cdr (last tem)) tem)
    tem))

できた。これまた、SRFI-1のcircular-listと同じ機能のもの。これもLispMに存在していたとは知りませんでした。

;; 動作
(mapcar #'list
	'(1 2 3 4 5 6 7 8)
	(circular-list 'a 'b))
;=> ((1 A) (2 B) (3 A) (4 B) (5 A) (6 B) (7 A) (8 B))

お題

暗記で再現

(defun zl_delete (item list &optional (times most-positive-fixnum) &aux ll pl)
  (prog ()
     A  (cond ((or (atom list) (zerop times))
	       (go R))
	      ((equal (car list) item)
	       (pop list)
	       (decf times)
	       (go A)))
        (setq ll list)
     B  (cond ((or (atom ll) (zerop times))
	       (go R))
	      ((equal (car ll) item)
	       (rplacd pl (cdr ll))
	       (decf times))
	      ((setq pl ll)))
        (pop ll)
	(go B)
     R	(return list)))

できた。これもリストのポインタ操作系で、ちょっとややこしい。

Aのセクションで、先頭から、itemが連続する場合を処理し、llにlistの先頭のポインタをコピーしてBに移行。Bでは、llは、ポインタ移動の役割で、plは、リストの継ぎ接ぎのために使われている模様。このパターンには色々見た目が違うコーディングが沢山あるようで、どうも覚えられない…。

;; 動作
(zl_delete 'b '(a b b c) 1)
;=> (a b c)

お題

delq

暗記で再現

(defun delq (item list &optional (times -1))
  (prog (ll pl)
    A   (cond ((or (atom list) (= times 0))
	       (return list))
	      ((eq item (car list))
	       (setq list (cdr list))
	       (setq times (1- times))
	       (go A)))
        (setq ll list)
    B   (cond ((or (atom ll) (= times 0))
	       (return list))
	      ((eq item (car ll))
	       (rplacd pl (cdr ll))
	       (setq times (1- times)))
	      ((setq pl ll)))
        (setq ll (cdr ll))
	(go B)))

deleteの要素の比較をeqで行なうdelq。

どうやら、こっちの方が定義が古いっぽい。理屈としては、上のzl:deleteと同じ。zl:deleteの方が意図が読み取り易かった。

;; 動作
(delq 'a '(a b c a a b c) 2)
;=> (B C A B C) 

お題

greaterp

暗記で再現

(defun greaterp (&rest numbers)
  (prog (a (b (cdr numbers)) c)
	(if (null b) (return t))
        (setq a (car numbers))
    again
	(setq c (car b))
	(if (<= a c) (return nil))
	(setq b (cdr b))
	(if (null b) (return t))
	(setq a c)
	(go again)))

できた。greaterpは、>の元祖。この定義だと、引数が無いときと1つの時は、Tを返すようになっている。Common Lispの>だと、0個の引数はエラー。

;; 動作
(greaterp 4 3 2 1)
(greaterp)
;; => t
(>)
;; error
(greaterp 8)
;; => t

お題

and

(defmacro (and alternate-macro-definition) (&rest expressions)
  (case (length expressions)
    (0 t)
    (1 (car expressions))
    (t (do* ((foo (cdr (reverse expressions)) (cdr foo))
             (result `(,(car (last expressions)))))
            ((null foo)
             (car result))
         (setq result `((if ,(car foo) . ,result)))))))

暗記で再現

(defmacro _and (&rest expressions)
  (case (length expressions)
    (0 t)
    (1 expressions)
    (otherwise 
     (do* ((foo (reverse expressions) (cdr foo))
	   (result `(,(car foo))))
	  ((endp foo) (car result))
       (setq result `((if ,(car foo) . ,result)))))))

全く同じではないけれどできた。caseで振り分けてるってのが何となく新鮮。オリジナルは、do*としているので、resultの初期化で、fooの結果が使える筈なんだけれど使ってなかったりするので、doでも良いんじゃないかと思ったりする。

お題

let-if

;;; LET-IF (gak)
(defmacro (let-if alternate-macro-definition) (condition binding-list &rest body)
  (let ((thunk (gensym)))
    (labels ((split-bindings (bindings variables values)
               (if (null bindings)
                   `(LET ((,thunk ,@body))
                      (IF ,condition
                          (PROGV ,variables ,values (FUNCALL ,thunk))
                          (FUNCALL ,thunk)))
                   (let ((this-binding (first bindings)))
                     (split-bindings (rest bindings)
                                     (cons (if (listp this-binding)
                                               (first this-binding)
                                               this-binding)
                                           variables)
                                     (cons (if (and (listp this-binding)
                                                    (cdr this-binding))
                                               (second this-binding)
                                               'nil)
                                           values))))))
      (split-bindings binding-list '() '()))))

暗記で再現

(defmacro let-if (condition binding-list &body body)
  (labels ((split-bindings (bindings variables values)
	     (if (null bindings)
		 `(if ,condition
		      (multiple-value-bind ,variables (values-list ',values) ,@body)
		      (progn ,@body))
		 (let ((this-binding (first bindings)))
		   (split-bindings (rest bindings)
				   (cons (if (consp this-binding)
					     (first this-binding)
					     this-binding)
					 variables)
				   (cons (if (and (consp this-binding)
						  (rest this-binding))
					     (second this-binding)
					     'nil)
					 values))))))
    (split-bindings binding-list '() '() )))

Common Lispで動くようにちょっと変更したけど、多分これで良いんじゃなかろうか。

(let-if cond ((変数 値)))

という形式で、condが真ならば、letの変数束縛が生きて、偽ならば、束縛は生きないというもの。

多分、

(defmacro let-if (condition binding-list &body body)
  `(if ,condition
       (let ,binding-list
	 ,@body)
       (let ()
	 ,@body)))

のような定義の動作で良いと思うんだけれども、progvの変数のバインディングに合せるために、複雑になっている模様。しかし、progvを使う必要はあるんだろうか。この辺、基本ダイナミックスコープなZetalispと、レキシカルスコープなCommon Lispで違ってきているような気がする。split-bindingsは関数として独立させてもマクロ等で便利に使えそう。

;; 動作
(let-if t ((foo 8) (bar 9))
  (list foo bar))
; => (8 9)

2007-11-02

Common Idioms (3)

| 15:09 | Common Idioms (3) - わだばLisperになる を含むブックマーク はてなブックマーク - Common Idioms (3) - わだばLisperになる

Brian Mastenbrook氏のCommon Idiomsを拾い読みしてみることの3回目

Common Idioms→CLiki: common-idioms

お題

run-tests

暗記で再現:間違えた

(defmacro run-tests (&rest tests)
  (let ((*print-case* :upcase))
    (with-gensyms (e j)
      `(let ((*print-case* :upcase))
	 (loop for ,j in ',(mapcar (lambda (test) 
				     (cons
				      test
				      (format nil "Test ~A: ~~A~%" test)))
				   tests)
	    for ,e = (apply #'funcall (car ,j))
	    do (format t (cdr ,j) ,e)
	    collect ,e)))))
;; 正解
(defmacro run-tests (&rest tests)
  "Run the functions named by the supplied TESTS (not evaluated),
printing and collecting their values."
  (let ((*print-case* :upcase))
    (with-gensyms (e j)
      `(let ((*print-case* :upcase))
         (loop for ,e in (list ,@(mapcar #'(lambda (test) (list 'cons `(function ,test) (format nil "Test ~A: ~~A~%" test))) tests))
            for ,j = (funcall (car ,e))
            do (format t (cdr ,e) ,j)
            collect ,j)))))

間違えた。テストの関数を実行するものだったのに式を実行するものと勘違いして随分悩んだ。(apply #'funcall)などとしているのはそのため。

;; 動作
(run-tests (lambda() (print "foo"))
	   (lambda() (print "bar"))
	   (lambda() (print "zot")))

=>
;Test (LAMBDA () (PRINT foo)): foo
;Test (LAMBDA () (PRINT bar)): bar
;Test (LAMBDA () (PRINT zot)): zot

お題

macroexpand-n

暗記で再現:間違えた

(defmacro macroexpand-n (n expr)
  (if (eql n 1)
      `(macroexpand-1 ,expr)
      `(macroexpand-1 (macroexpand-n ,(1- n) ,expr))))

;; 正解
(defmacro macroexpand-n (n form)
  "MACROEXPAND-1 FORM recursively N times."
  (if (eql n 1)
      `(macroexpand-1 ,form)
      `(macroexpand-n ,(1- n) (macroexpand-1 ,form))))

間違えた。再帰の部分で入れ子の順番を間違えた。しかし結果は一緒なんだけれど、これら2つ詳細な動作がどう違うのか/違わないのか、良く分からない…。

;; 動作
(defmacro pg (arg &rest body)
  `(prog (,arg)
      ,@body))

(macroexpand-n 1 '(pg () (print "hello")))
=>
(PROG (NIL) (PRINT "hello")) 

(macroexpand-n 2 '(pg () (print "hello")))
=>
(BLOCK NIL
  (LET (())
    (TAGBODY (PRINT "hello"))))

2007-10-31

Common Idioms (2)

| 23:10 | Common Idioms (2) - わだばLisperになる を含むブックマーク はてなブックマーク - Common Idioms (2) - わだばLisperになる

引き続きBrian Mastenbrook氏のCommon Idiomsを拾い読みしてみることの2回目

お題

map1

暗記で再現

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defmacro map1 (function list &rest constants)
    (let ((list-const (gensym)))
      `(mapcar (lambda (,l) (funcall ,function ,l ,@constants))
	       ,list))))

できた。mapcarの拡張版といった感じ。

eval-whenで囲まれているのはmacroexpandの動作のためなんでしょうか。

その辺があまり理解できていない。

;; 動作
(map1 #'cons '(1 2 3 4) (gensym))
;=> ((1 . #:G2935) (2 . #:G2936) (3 . #:G2937) (4 . #:G2938)) 

お題

aif

暗記で再現:間違い

(defmacro aif (pred conseq else)
  `(let ((it ,pred))
     (if it
	 ,conseq
	 (macrolet ((set-it (val) `(setf it ,val)))
	   ,else))))

;; 正解
(defmacro aif (test conseq &optional (else nil))
  `(let ((it ,test))
     (declare (ignorable it))
     (if it ,conseq
         (macrolet ((setf-it (val) (list 'setf ',test val)))
           ,else))))

大分間違えた。普通のaifかと思っていたら、else節に追加機能がついていた。setf-itというマクロでitに代入できたりする。

そのsetf-itのところで間違えた。それと、declare忘れ、else節をoptionalにするのを忘れたり。

;; 動作
(defparameter *special* '(nil hello))
(aif (car *special*) it (setf-it 42))
*special*
;=> '(42 hello)

お題

with-gensyms

暗記で再現

(defmacro with-gensyms ((&rest vars) &body body)
  `(let ,(map1 #'list vars '(gensym))
     ,@body))

できた。これもmap1を使用していたりしてひと捻りあったりする。

;; 動作
(with-gensyms (foo bar)
  foo)

;->(LET ((FOO (GENSYM)) (BAR (GENSYM)))
;  FOO)

お題

aif2

暗記で再現

(defmacro aif2 (test conseq &optional (else nil))
  (with-gensyms (v2)
    `(multiple-value-bind (it ,v2) ,test
       (if ,v2
	   ,conseq
	   (macrolet ((setf-it (val) 
                        (list 'setf ',test val)))
	     ,else)))))

できた。オリジナルは、(list 'setf ',test val)だけれども、`(setf ,',test ,val)と書いたらまずいんだろうか。

else節のsetf-itの動作でちょっと謎があって、setf-itの後でもitは前の値のままになっているので、

(let ((foo "foo") bar)
  (aif2 (values foo bar)
	(print it)
	(progn
	  (setf-it (values "new" "new"))
          (print it)))
  foo)
;"foo"と印字され"new"を返す。

というような動作をします。

(defmacro aif2 (test conseq &optional (else nil))
  (with-gensyms (v2)
    `(multiple-value-bind (it ,v2) ,test
       (if ,v2
	   ,conseq
	   (macrolet ((setf-it (val) 
			`(setq it (setf ,',test ,val))))
	     ,else)))))

なら、else節のitに再度代入するので、setf-itの後は更新された値にはなりますが、やっぱりitが更新されないってのは何らかの意図があってのことなんでしょうか。

2007-10-30

Common Idioms (1)

| 19:25 | Common Idioms (1) - わだばLisperになる を含むブックマーク はてなブックマーク - Common Idioms (1) - わだばLisperになる

どういうわけかAlexandriaは自分の好みに合わずあまり読む気がしないので後回しにして他のものを物色。

Brian Mastenbrook氏(編纂?)のユーティリティ集Common Idiomsを拾い読みしてみることにしました。

Common Idioms→CLiki: common-idioms

asdf-installも可能です。

お題

fconstantly

暗記で再現

;; common-idioms.lisp
(defmacro fconstantly (function &rest arguments)
  (let ((args (gensym)))
    `#'(lambda (&rest ,args)
	 (declare (ignore ,args))
	 (funcall ,function ,@arguments))))

できた。次のreducenで必要なので先にこちらを。constantlyの関数を返す版というところでしょうか。

(mapcar (fconstantly #'gensym) '(foo bar baz))
;=>(#:G1234 #:G1235 #:G1236)

というonce-onlyのようなマクロを作るときにマクロ内部で使う位しか使い道が思い浮かばないですが、もっと強力で便利な使い道があるのかもしれません。

お題

reducen

暗記で再現

;; common-idioms.lisp
(defmacro reducen (n fn l &rest initials)
  (if (not (= (length initials) n))
      (error "initialsの長さとnの数値は一致している必要があります。")
      (let ((ilist (mapcar (fconstantly #'gensym) initials))
	    (nlist (mapcar (fconstantly #'gensym) initials)))
	(with-gensyms (fnname e)
	  `(let ((,fnname ,fn)
		 ,@(mapcar #'list ilist initials))
	     (mapc (lambda (,e)
		     (multiple-value-bind 
			   ,nlist
			 (funcall ,fnname ,@ilist ,e)
		       (psetq ,@(reduce #'append (mapcar #'list ilist nlist)))))
		   ,l)
	     (values ,@ilist))))))

できた。多値を扱えるreduceとのこと。動作が思い描けず大分試行錯誤。このマクロの使い方自体、自分にとっては複雑ですぐ忘れてしまいそうです。

エラーが日本語なのは、エラーメッセージの文言を忘れてしまったためです…。

;; 動作
(reducen 2 
	 (lambda (a b e) (values (cons (1+ e) a) (cons (1- e) b)))
	 '(1 2 3 4)
	 nil nil)
;=> (5 4 3 2),(3 2 1 0)

2007-10-28

Alexandria (1)

| 01:21 | Alexandria (1) - わだばLisperになる を含むブックマーク はてなブックマーク - Alexandria (1) - わだばLisperになる

PG氏の余り物ユーティリティを読み終ったので、次は何にしようかと悩みましたが、とりあえず、定番ユーティリティ集の座を狙っているような、alexandriaのコードを読んでみることにしました。

名前からして、立派な図書館であったAlexandria図書館のようなライブラリを目指しているのであろうということは何となく分かります。

とりあえず、適当にぽつぽつと拾い読みしてみたいと思っています。

Alexandriaのページ:Alexandria

asdf-installも可能なようですが、プロジェクトの人が準備したものではないようです。

とりあえず自分は、公式ページの通りdarcsで取得して、手動でasdfに登録しました。

お題

features

暗記で再現

;--- features.lisp
(defun featurep (feature-expression)
  (etypecase feature-expression
    (symbol (not (null (member feature-expression *features*))))
    (cons   (ecase (first feature-expression)
	      (:and (every #'featurep (rest feature-expression)))
	      (:or  (some  #'featurep (rest feature-expression)))
	      (:not (not (featurep (second feature-expression))))))))

できた。carとcdrを使わないのに、cadrを使うのは謎なのでsecondにしてみた。

Emacs Lispではお馴染で、Emacs上でコードを編集しているとハイライト表示もされるしCommon Lisp標準の機能かと思いきや、標準ではなかったりするfeaturep。

後期Maclispにはあるようなので、その流れでEmacsにもあるのかもしれません。

これはCLRFIの1番で定義されているfeaturepとまったく同じコードなんですが、CLRFIとも関係あるのでしょうか。

;; 動作
(featurep :cffi)
;=> t
(featurep '(:not :cffi))
;=> nil
(featurep '(:and :sbcl :x86 :linux))
;=> t

お題

clamp

暗記で再現

;--- numbers.lisp
(declaim (inline clamp))
(defun clamp (number min max)
  (if (< number min)
      min
      (if (> number max)
	  max
	  number)))

できた。上限と下限を設定して、はみ出したものは上限か下限の値を返すというものらしい。

自分は何となく

(defun clamp (number min max)
  (cond ((< number min) min)
	((> number max) max)
	('T number)))

と書きたい派。

;; 動作
(clamp 101 1 100)
;=> 100

お題

iota

暗記で再現

;--- numbers.lisp
(declaim (inline iota))
(defun iota (n &key (start 0) (step 1))
  (declare (type (integer 0) n) (number start stop))
  (loop :repeat n 
        :for i = (+ start (- step step)) :then (+ i step)
        :collect i))

できた。これはおなじみSRFIのiota。しかし、startや、stepをキーワード引数として取るようにしているところが違う。

;; 動作
(iota 10 :start 1.5 :step 2)
;=> (1.5 3.5 5.5 7.5 9.5 11.5 13.5 15.5 17.5 19.5)

お題

map-iota

暗記で再現

;--- numbers.lisp
(declaim (inline map-iota))
(defun map-iota (n fn &key (start 0) (step 1))
  (declare (type (integer 0) n) (number start step))
  (loop :repeat n
        :for i = (+ start (- step step)) :then (+ i step)
        :do (funcall fn i))
  n)

できた。iotaの結果の各要素に関数を適用するという感じ。

PG氏のmap-intに非常に近いような気もするけれど、返り値は、結果のリストではなくて、引数のnを返したりするところが違う。

;; 動作
(map-iota #'princ 5 :start 1 :step 2)
->13579
;; 参考 PG氏のmap-int
(defun map-int (func n)
  "call FUNC on integers from 0 through N - 1, returning a list of the results."
  (let ((acc '()))
    (dotimes (i n)
      (push (funcall func i)
	    acc))
    (nreverse acc)))

雑感

今のところこのライブラリに含まれるマクロや関数の由来を記したドキュメントの類が全然ないんですが、手持ちの駒の重複を把握するためにもあると便利だなと感じました。

2007-10-25

Paul Graham氏のユーティリティ その12

| 17:22 | Paul Graham氏のユーティリティ その12 - わだばLisperになる を含むブックマーク はてなブックマーク - Paul Graham氏のユーティリティ その12 - わだばLisperになる

PG氏のユーティリティを読んでみることの12回目。

引き続き、文字列操作系のユーティリティ編です。

Lisp utilities that were not included in On Lisp or ANSI Common Lisp

お題

extruct-lines

暗記で再現

(defun extruct-lines (string &optional (pos 0))
  (if (= pos (length string))
      nil
      (let ((n (linebreak-pos string pos)))
	(if n
	    (cons (nonwhite-substring string pos n)
		  (extruct-lines string (1+ n)))
	    (list (nonwhite-substring string pos (length string)))))))

できた。extruct-paragraphsの兄弟みたいなもの。こっちは、行ごとに一区切りになる様子。

;; 動作
(extruct-lines "夏草や
    兵どもが
 夢の跡")
;=>("夏草や" "兵どもが" "夢の跡") 

お題

extruct-token-if

暗記で再現:間違えた

;; 間違い
(defun extruct-token-if (str sep-test &optional (start 0))
  (let ((p1 (position-if-not sep-test str :start start)))
    (if p1
	(let ((p2 (position-if-not sep-test str :start (1+ p1))))
	  (if p2
	      (cons (subseq str p1 (1- p2))
		    (extruct-token-if str sep-test p2))
	      (list (subseq str p1))))
	nil)))

;; 正解
(defun extruct-token-if (str sep-test &optional (start 0))
  (let ((p1 (position-if-not sep-test str :start start)))
    (if p1
	(let ((p2 (position-if sep-test str :start p1)))
	  (cons (subseq str p1 p2)
		(if p2
		    (extruct-token-if str sep-test p2)
		    nil)))
	nil)))

大分間違えてしまった。セパレータが連続している場合に対応できていなかった。

;; 動作
(extruct-token-if "や   ら   な   い   か" #'white?)
;=> ("や" "ら" "な" "い" "か") 

下準備

(defconstant whitechars '#(#\Space #\Tab #\Newline #\Return))

お題

separated-tokens

暗記で再現

(defun separated-tokens (str sep)
  (mapcar (lambda (tok) (string-trim whitechars tok))
	  (extruct-token-if str (lambda (c) (eql c sep)))))

できた。指定したセパレータで区切って、さらに空白文字をトリミングするというものらしい。

;; 動作
(separated-tokens "Lisperへの100の質問: ,001,   一番好きな戦車は?,  IV号戦車F型" #\,)
;=> ("Lisperへの100の質問:" "001" "一番好きな戦車は?" "IV号戦車F型") 

お題

extruct-tokens

暗記で再現

;; 間違い
(defun extruct-tokens (str &optional (start 0))
  (let ((p1 (position-if #'constituent str :start start)))
    (if p1
	(if (eql (char str p1) #\")
	    (let ((p2 (position #\" str :start (1+ p1))))
	      (if p2
		  (cons (subseq str (1+ p1) p2)
			(extruct-tokens str (1+ p2)))
		  (list (subseq str (1+ p1)))))
	    (let ((p2 (position-if-not #'constituent str :start p1)))
	      (cons (subseq str p1 p2)
		    (if p2
			(extruct-tokens str (1+ p2))
			nil))))
	nil)))

;; 正解
(defun extract-tokens (str &optional (start 0))
  (let ((p1 (position-if #'constituent str :start start)))
   (if p1
       (if (eql (char str p1) #\")
           (if (< p1 (- (length str) 1))
               (let ((p2 (position #\" str :start (1+ p1))))
                 (if (and p2 (< p2 (- (length str) 1)))
                     (cons (string-trim "\"" (subseq str p1 (1+ p2)))
                           (extract-tokens str (1+ p2)))
                     (list (string-trim "\"" (subseq str p1)))))
               nil)
           (let ((p2 (position-if-not #'constituent
                                      str :start p1)))
             (cons (subseq str p1 p2)
                   (if p2
                       (extract-tokens str p2)
                       nil))))
       nil)))

大分間違えた。どうもこの系統は記憶できない…。基本的に空白文字で区切るが、ダブルクオートでクオートされた部分の処理も追加している感じ。

;; 動作
(extruct-tokens "\"foo bar\" bar baz")
;=> ("foo bar" "bar" "baz")

お題

first-token

暗記で再現

(defun first-token (str &optional (start 0))
  (let ((p1 (position-if #'constituent str :start start)))
    (if p1
	(let ((p2 (position-if-not #'constituent str :start p1)))
	  (subseq str p1 p2))
	nil)))

できた。空白文字で囲まれた最初のトークンを切り出すというものの様子。

;; 動作
(first-token "壹 弐 参")
;=>"壹"

雑感

今回で、PG氏の冷蔵庫の残り物的ユーティリティは一通り読み終りました。暗記して転写するというだけですが、ただ眺めるよりはためになっている気はします。

2007-10-24

Paul Graham氏のユーティリティ その11

| 16:18 | Paul Graham氏のユーティリティ その11 - わだばLisperになる を含むブックマーク はてなブックマーク - Paul Graham氏のユーティリティ その11 - わだばLisperになる

PG氏のユーティリティを読んでみることの11回目。

文字列操作系のユーティリティ編です。

Lisp utilities that were not included in On Lisp or ANSI Common Lisp

お題

white?

暗記で再現

(defun white? (c)
  (in c #\Space #\Tab #\Newline #\Return))

できた。文字が空白文字かを判定する。

;; 動作
(with-input-from-string (str "foo bar	baz
quux")
  (do-chars c str
    (princ (if (white? c) "△" c))))
;->foo△bar△baz△quux

お題

constituent

暗記で再現

(defun constituent (c)
  (and (graphic-char-p c)
       (not (char= #\Space c))))

できた。制御文字か空白の場合NIL、普通の文字の文字の場合Tを返すものの様子。

(char= #\ #\Space)のようなので、判別しやすいように#\Spaceと書いてみた。。

;; 動作
(with-input-from-string (str "foo bar^Sbaz^Vquux^F日本語")
 (do-chars c str
   (princ (if (constituent c) c "△"))))
;->foo△bar△baz△quux△日本語

お題

linebreak-pos

暗記で再現

(defun linebreak-pos (string &optional (start 0))
  (or (position #\Newline string :start start)
      (let ((n (position #\Return string :start start)))
	(when n
	  (if (and (not (= n (1- (length string))))
		   (eql (char string (1+ n)) #\Newline))
	      (1+ n)
	      n)))))

できた。改行文字の位置を返すものの様子。LF、CR、CR+LFの3つの場合に対応。次の行の先頭の一つ前の位置を返す。

;; 動作
(let ((s "foo【CR】【LF】
bar"))
  (linebreak-pos s))
;=> 4

(let ((s "foo【LF】
bar"))
  (linebreak-pos s))
;=> 3

お題

blank-line

暗記で再現:失敗

;; 間違い
(defun blank-line (string &optional (start 0))
  (let ((n (linebreak-pos string start)))
    (if (= n (1- (length string)))
	(let ((n2 (linebreak-pos string (1+ n))))
	  (if (find-if-not #'white? string :start n :end n2)
	      (blank-line string n2)
	      nil))
	nil)))

;; 正解
(defun blank-line (string &optional (start 0))
  (let ((n (linebreak-pos string start)))
    (if (and n (not (= n (1- (length string)))))
        (let ((n2 (linebreak-pos string (1+ n))))
          (if n2
              (if (find-if-not #'white? string :start n :end n2)
                  (blank-line string n2)
                  n2)
              nil))
        nil)))

動作を理解していなかったため大分間違えた。空行を見つけ出して、その先頭のポジションを返すというものらしい。

;; 動作
(blank-line "foobar

")
;=> 7

お題

nonwhite-substring

暗記で再現

(defun nonwhite-substring (string start end)
  (if (find-if-not #'white? string :start start :end end)
      (progn
	(while (white? (char string start))
	  (incf start))
	(while (white? (char string (1- end)))
	  (decf end))
	(subseq string start end))
      ""))

できた。指定した範囲をsubseqで切り出すが、周囲の空白文字は除外するというものらしい。

;; 動作
(let ((str "  f o o "))
  (nonwhite-substring str 0 (length str)))
=>"f o o"

お題

extruct-paragraphs

暗記で再現:失敗

;; 間違い
(defun extruct-paragraphs (string &optional (pos 0))
  (if (= pos (length string))
      nil
      (let ((n (linebreak-pos string pos)))
	(if n
	    (cons (nonwhite-substring string pos n)
		  (extruct-paragraphs string (1+ n)))
	    (list (nonwhite-substring string pos (length string)))))))

;; 正解
(defun extruct-paragraphs (string &optional (pos 0))
  (if (= pos (length string))
      nil
      (let ((n (blank-line string pos)))
	(if n
	    (cons (nonwhite-substring string pos n)
		  (extruct-paragraphs string (1+ n)))
	    (if (find-if-not #'white? string :start pos)
		(list (nonwhite-substring string pos (length string)))
		nil)))))

これもコードから動作が思い描けず大分間違えた。文字列から段落を抜き出して、その要素をリストにして返すというものらしい。段落の区切りは空白行になっている。

;; 動作
(print (extruct-paragraphs 
 "NILが空リストだっていいじゃないか。

          Common Lispだもの。

               みつを"
))
;=> ("NILが空リストでもいいじゃないか。" "Common Lispだもの。" "みつを") 

2007-10-23

Paul Graham氏のユーティリティ その10

| 07:29 | Paul Graham氏のユーティリティ その10 - わだばLisperになる を含むブックマーク はてなブックマーク - Paul Graham氏のユーティリティ その10 - わだばLisperになる

PG氏のユーティリティを読んでみることの10回目。

エラーとデバック、日付のユーティリティ編です。

Lisp utilities that were not included in On Lisp or ANSI Common Lisp

お題

ero

暗記で再現:間違えた

(defun ero (args)     ;&restが抜けた。
  (print (if (cdr args) args (car args))
	 *error-output*))

間違えた。引数は、&restで受けることになっていた。

引数を*error-output*に出力するというものらしい。

;; 動作
(ero 'foo 'bar 'baz)
;=>(FOO BAR BAZ) 
(ero 'foo)
;=> FOO

お題

safely

暗記で再現

(defmacro safely (expr)
  (with-gensyms (ret err)
    `(bind (,ret ,err) (ignore-errors ,expr)
	 (if (typep ,err 'error)
	     nil
	     (values ,ret ,err)))))

できた。評価する式をくるんでエラーの場合でもnilを出力するだけにしたもの。

;; 動作
(safely 
 (bind (a (b) c) (values 1 2 3)
       (list a b)))
=>nil
;通常はパターンマッチに失敗するのでエラーとなる

お題

time-string

暗記で再現

(defun time-string ()
  (multiple-value-bind (s m h) (get-decoded-time)
    (format nil "~A:~2,,,'0@A:~2,,,'0@A" h m s)))

できた。その名の通り、現在時刻の文字列を返す。

;; 動作
(time-string)
;=>"6:54:05"

お題

date-string

暗記で再現

(defconstant months
  #("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))

(defun date-string ()
  (multiple-value-bind (ig no re d mo y) (get-decoded-time)
    (declare (ignore ig no re))
    (format nil "~A ~A ~A" d (svref months (1- mo)) y)))

できた。予めmonthsという月の名前の定数のベクタを定義しておいて、それを参照して日付の文字列を返すというもの。

全然関係ないけれど(declare (ignore ig no re))ってのが面白い。

;; 動作
(date-string)
;=>"23 Oct 2007

お題

date+time-string

暗記で再現

(defun date+time-string (&optional (u (get-universal-time)))
  (multiple-value-bind (s m h d mo y) (decode-universal-time u)
    (format nil "~A ~A ~A ~A:~2,,,'0@A:~2,,,'0@A" d (svref months (1- mo)) y h m s)))

できた。上記2つを合体させたもの。オプションで引数がとれるように拡張されている。

;; 動作
(date+time-string)
;=>"23 Oct 2007 7:10:46" 

2007-10-22

Paul Graham氏のユーティリティ その9

| 06:43 | Paul Graham氏のユーティリティ その9 - わだばLisperになる を含むブックマーク はてなブックマーク - Paul Graham氏のユーティリティ その9 - わだばLisperになる

PG氏のユーティリティを読んでみることの9回目。

ハッシュ操作のユーティリティ編です。

Lisp utilities that were not included in On Lisp or ANSI Common Lisp

お題

nonempty-ht

暗記で再現

(defun nonempty-ht (ht)
  (maphash (lambda (k v) (declare (ignore k v)) (return-from nonempty-ht t))
	   ht)
  nil)

できた。ハッシュが空かどうかを確認するものらしい。

オリジナルだと警告が出るので(declare (ignore~))を追加しています。

;; 動作
(setq foo (make-hash-table))
(nonempty-ht foo)
;-> nil
(setf (gethash 'foo foo) "foo!")
(setf (gethash 'bar foo) "bar!")
(nonempty-ht foo)
;-> T

お題

ht-car

暗記で再現:間違い

(defun ht-car (ht)
  (maphash (lambda (k v) (declare (ignore v)) (return-from ht-car k))
	   ht))

;; 正解
(defun ht-car (ht)
  (maphash (lambda (k v) (declare (ignore k)) (return-from ht-car v))
	   ht))

間違えた。返す値はキーじゃなくて値の方でした。

最初にヒットした値を返すというものらしい。

;; 動作
(ht-car foo)
;=> "foo!"

お題

hash-keys

暗記で再現

(defun hash-keys (ht)
  (let (acc)
    (maphash (lambda (k v) (declare (ignore v)) (push k acc))
	     ht)
    acc))

できた。ハッシュのキーを集めて返すというものらしい。

これも、declareを追加しています。また、オリジナルは、(let ((acc nil))~と丁寧に書いています。

(let ((acc nil))、(let ((acc))、(let (acc))と3つ位書き方があると思いますが、自分はなんとなく、(let (acc)~)派です。

そういえば、オリジナルは、#'(lambda(x)~)ですが、自分は(lambda (x)~)と書いてます。

これは、Emacs Lisp、Scheme、Common Lispで記法が統一できるので、なんとなく…。

;; 動作
(hash-keys foo)
;=> (BAR FOO)

お題

hash-vals

暗記で再現

(defun hash-vals (ht)
  (let (acc)
    (maphash (lambda (k v) (declare (ignore k)) (push v acc))
	     ht)
    acc))

できた。hash-keysの兄弟でキーか、値かの違いだけです。

;; 動作
(hash-vals foo)
;=> ("bar!" "foo!")

お題

hash-pairs

暗記で再現

(defun hash-pairs (ht)
  (let (acc)
    (maphash (lambda (k v) (push (cons k v) acc))
	     ht)
    acc))

できた。これも上記2つと同系統で、値とキーのalistをまとめて返すというもの。

;; 動作
(hash-pairs foo)
;=> ((BAR . "bar!") (FOO . "foo!")) 

お題

somehash

暗記で再現

(defun somehash (fn ht)
  (maphash (lambda (k v) (declare (ignore k)) 
		   (when (funcall fn v)
		     (return-from somehash v)))
	   ht)
  nil)

できた。その名の通りsomeのハッシュ版といったもの。

;; 動作
(somehash #'stringp foo)
;=>"foo"
(somehash #'symbolp foo)
;=> nil

お題

key-match

暗記で再現

(defun key-match (ht1 ht2)
  (maphash (lambda (k v) (declare (ignore v))
		   (when (gethash k ht2)
		     (return-from key-match k)))
	   ht1)
  nil)

できた。二つのハッシュテーブルに同じキーが存在するかを調べるものらしい。

;; 動作
(setq foo (make-hash-table)
      bar (make-hash-table))

(setf (gethash 'foo foo) "foo2"
      (gethash 'foo bar) "foo2")

(key-match foo bar)
;=> FOO

お題

write-hash

暗記で再現

(defun write-hash (ht str)
  (maphash (lambda (k v) (print (cons k v) str))
	   ht))

できた。ハッシュテーブルの内容をprintで指定したストリームに表示するというもの

;; 動作
(write-hash foo t)
;-> FOO

お題

read-hash

暗記で再現:間違えた。

(defun read-hash (ht str)
  (do-stream pair str
    (setf (gethash (car pair) ht)
	  (cdr pair)))
  nil)					;正しくはhtを返す

間違えた。処理の後には、ハッシュテーブルを返すところをnilにしてしまった。

read-hashとはなっているが、ストリームから読み込んだ、alistをハッシュテーブルに格納する動作に思える。

;; 動作
(setq quux (make-hash-table))

(with-input-from-string (str "(foo . fooo) (bar . barr) (baz . bazz)")
  (read-hash quux str))

(hash-pairs quux)
;=>((BAZ . BAZZ) (BAR . BARR) (FOO . FOOO)) 

2007-10-21

Paul Graham氏のユーティリティ その8

| 05:00 | Paul Graham氏のユーティリティ その8 - わだばLisperになる を含むブックマーク はてなブックマーク - Paul Graham氏のユーティリティ その8 - わだばLisperになる

PG氏のユーティリティを読んでみることの8回目。

文字列処理のユーティリティ編です。

Lisp utilities that were not included in On Lisp or ANSI Common Lisp

お題

read-as-string

暗記で再現

(defun read-as-string (in)
  (with-output-to-string (out)
    (do ((c (read-char in nil :eof) (read-char in nil :eof)))
	((eql c :eof))
      (write-char c out))))

できた。streamを文字列にして返すものらしい。

;; 動作
(with-input-from-string (str "fooooooooo barrrrr  bazzzz")
  (read-as-string str))
;=>"fooooooooo barrrrr  bazzzz"

お題

read-list-from-string

暗記で再現

(defun read-list-from-string (str &optional (start 0))
  (bind (var pos) (read-from-string str nil :eof :start start)
	(if (eql var :eof)
	    nil
	    (cons var (read-list-from-string str pos)))))

できた。文字列を読み込んでリストにして返すものらしい。

;; 動作
(read-list-from-string "foo bar baz quux zot")
;=>(FOO BAR BAZ QUUX ZOT) 

お題

read-numbers-from-string

暗記で再現

(defun read-numbers-from-string (str &optional (start 0))
  (bind (var pos) (ignore-errors 
		    (read-from-string str nil :eof :start start))
	(if (numberp var)
	    (cons var (read-numbers-from-string str pos))
	    nil)))

できた。文字列に現われた最初の数字群をリストにして返すものらしい。途中で数字以外が出現すると、そこで打ち切りとなる。

;; 動作
(read-numbers-from-string "foo bar baz 1 2 3 100")
=>nil
(read-numbers-from-string "1 2 3 100 foo 200")
=>(1 2 3 100) 

お題

read-number-from-string

暗記で再現

(defun read-number-from-string (str)
  (let ((n (ignore-errors (read-from-string str nil :eof)))) ; nilと、:eof不要
    (if (numberp n) n nil)))

今一歩。今度は最初の一文字を読むもの。最初の一文字を読めば良いので、(read-from-string str)だけで良かった。

;; 動作
(read-number-from-string "foo")
;=>nil
(read-number-from-string " 1 2 3")
;=> 1
(read-number-from-string "foo 1 2 3")
;=> nil

お題

string->hex

暗記で再現

(defun string->hex (str)
  (with-output-to-string (out)
    (dotimes (i (length str))
      (let ((c (char str i)))
	(format out "~2,'0X" (char-code c))))))

できた。文字列を16進のキャラクタコードの文字列にして返すもの。

;; 動作
(string->hex "a")
;=>"61"

お題

hex->string

暗記で再現

(defun hex->string (str)
  (if (evenp (length str))
      (let ((*read-base* 16))
	(with-output-to-string (out)
	  (dotimes (i (/ (length str) 2))
	    (princ (code-char (read-from-string str nil nil
						:start (* i 2)
						:end (+ (* i 2) 2)))
		   out))))
      (error "odd length hex string: ~A.~%" str)))

できた。その名の通りstring->hexの逆の動作をするもの。なかなかややこしい。

当然なのかもしれないけれど、これで日本語を扱うには少し問題があるっぽい。

;; 動作
(hex->string "61")
;=> "a"
(hex->string (string->hex "日本語 BAR baZ")))
"e〓g,&#138;&#158; BAR baZ" 

2007-10-20

Paul Graham氏のユーティリティ その7

| 02:53 | Paul Graham氏のユーティリティ その7 - わだばLisperになる を含むブックマーク はてなブックマーク - Paul Graham氏のユーティリティ その7 - わだばLisperになる

PG氏のユーティリティを読んでみることの7回目。

今回も引き続きファイルの読み書きユーティリティ編です。

Lisp utilities that were not included in On Lisp or ANSI Common Lisp

お題

do-lines

暗記で再現

(defmacro do-lines (var path &body body)
  (with-gensyms (str p)
    `(let ((,p (probe-file ,path)))
       (when ,p
	 (with-infile ,str ,p
	   (do ((,var (read-line ,str nil :eof) (read-line ,str nil :eof)))
	       ((eql ,var :eof))
	     ,@body))))))

できた。これの場合は、内部でitが参照まずいので、awhenは使われていない様子。

行毎に何かの処理をさせるためのものの様子。

お題

file-lines

暗記で再現

(defun file-lines (path)
  (let ((i 0))
    (do-lines line path
      (setq i (1+ i)))
    i))

とりあえずできたけれど、内部の変数名は、iじゃなくてオリジナルの様にcountの方が分かりやすさの点で好ましい。

動作テスト時にどうも無限ループになってしまうので、上のdo-linesのループ終了の判定を:eofにしたらすんなり動いた。eofを定数にするってのは、なかなか扱いが難しい気がするがどうなのだろう。

お題

暗記で再現:もうちょっと

(defmacro with-outfile (str fname &body body)
  (with-gensyms (f)
    `(let ((,f ,fname))
       (in-case-error 
	(with-open-file (,str ,f 
			      :direction :output
			      :if-exists :supersede)
	  ,@body)
	(format *error-output* "Error to writing ~S." ,f)))))

再現性が今一歩足りなかった。変数名が違ったのと、エラーのところで改行忘れた。

これもまた、with-infileと同様に余分なgensymがあるのが謎。

;; 動作
(with-outfile str "/tmp/foo.txt"
  (print "foooooooo" str))
;=>"foooooooo"という内容の/tmp/foo.txtというファイルができる。

お題

暗記で再現:失敗

(defmacro with-outfiles (pairs &body body)
  (if (null pairs)
      `(progn ,@body)
      `(with-outfile ,(car pairs) ,(cadr pairs)
	 (with-outfiles ,(cddr pairs)
	   ,@body))))

引数が奇数のときのエラー処理の判定を抜かしてしまった。

正解は、

(defmacro with-outfiles (pairs &body body)
  (if (null pairs)
      `(progn ,@body)
      (if (oddp (length pairs))
	  (error "Odd length arg to with-outfiles.")
	  `(with-outfile ,(car pairs) ,(cadr pairs)
	     (with-outfiles ,(cddr pairs)
	       ,@body)))))
;; 動作
(with-outfiles (foo "/tmp/foo.txt" bar "/tmp/bar.txt" baz "/tmp/baz.txt")
  (print "foo?" foo)
  (print "bar?" bar)
  (print "baz?" baz))
;=>それぞれ指定したファイルに指定した内容が書き込まれる。

お題

copy-file

暗記で再現:もうちょっと

(defun copy-file (from to)
  (with-open-file (in from :direction :input
		           :element-type 'unsigned-byte)
    (in-case-error 
     (with-open-file (out to :direction :output 
			     :element-type 'unsigned-byte)
       (do ((b (read-byte in nil -1)
	       (read-byte in nil -1)))
	   ((minusp b))
	   ;     ここに(declare (fixnum b)) が入る
	 (write-byte b out)))
     (format *error-output* "Error writing to ~S.~%" to))))

declareを抜かしてしまった。

これは、その名の通りファイルをコピーするユーティリティの様子。コピー先に同名ファイルが存在した場合は、エラーになる。

2007-10-19

Paul Graham氏のユーティリティ その6

| 03:16 | Paul Graham氏のユーティリティ その6 - わだばLisperになる を含むブックマーク はてなブックマーク - Paul Graham氏のユーティリティ その6 - わだばLisperになる

PG氏のユーティリティを読んでみることの6回目。

引き続きファイルの読み書きユーティリティ編です。

Lisp utilities that were not included in On Lisp or ANSI Common Lisp

お題

make-sb

暗記で再現

(defun make-sb ()
  (make-array '(0) :element-type 'base-char :adjustable 'T 
	      :fill-pointer 0))

とりあえずできた。sbって何の略だろう。string bufferとかだろうか…。

これもファイルの順番とは前後しますが後にでてくるfile-contentsが依存している関係で先にこなしています。

元のコードは、:element-typeがstring-charになっていますが、ANSIだと、base-charみたいなので直しました。

CTLT1では、string-charだったようです。手元で試した限りでは、clispでは、互換性が確保されている為か現状でもstring-charで通りました。

動作としては、後で追加できる文字列を作成するためのもののようです。

お題

sb-append

暗記で再現

(defmacro sb-append (as c)
  `(vector-push-extend (the character ,c) (the string ,as)))

とりあえずできた。make-sbで作った伸長可能な文字列に文字を追加するもののようです。

(let ((s (make-sb)))
  (sb-append s #\f)
  (sb-append s #\o)
  (sb-append s #\o)
  s)
;=> "foo"

お題

file-contents

暗記で再現

(defun file-contents (path)
  (awhen (probe-file path)
    (with-infile str it
      (let ((sb (make-sb)))
	(do-chars c str
	  (sb-append sb c))
	sb))))

とりあえずできた。ファイルから一文字ずつ読み込み結果を文字列にして返すというもののようです。

;; 動作
(file-contents "/tmp/foo.txt")
=>"foo bar baz"

お題

file-to-stream

暗記で再現

(defun file-to-stream (path &optional (out *standard-output*))
  (awhen (probe-file path)
    (with-infile str it
      (do-chars c str
	(princ c out)))))

とりあえずできた。file-contentsと殆ど同じで、結果をprincしているところが違うのみです。

お題

read-rest

暗記で再現

(defun read-rest (str)
  (let ((x (read str nil eof)))
    (if (eql x eof)
	nil
	(cons x (read-rest str)))))

とりあえずできた。ファイル(ストリーム)の内容をreadで読み込んでリストにして返すというもののようです。

;; 動作
(with-input-from-string (s "foo bar baz")
  (read-rest s))
;=>(FOO BAR BAZ)

お題

file-rest

暗記で再現

(defun file-rest (path)
  (awhen (probe-file path)
    (with-open-file (str it :direction :input)
      (read-rest str))))

;; with-infileで
(defun file-rest (path)
  (awhen (probe-file path)
    (with-infile str it
     (read-rest str))))

とりあえずできた。上のread-restをファイル用途に限定したもののようです。何故かこれだけ、with-infileが使われていなかったりしますが何か深い理由があるのか、それともこっちの定義の方がwith-infileより古かったりするのか理由は謎です。

お題

suck-dry

暗記で再現

(defun suck-dry (str)
  (do ((c (read-char str nil :eof) (read-char str nil :eof)))
      ((eql c :eof) nil)))

;; 他とeofの判定方法を合わせた版
(defun suck-dry (str)
  (do ((c (read-char str nil eof) (read-char str nil eof)))
      ((eql c eof) nil)))

とりあえずできた。ファイルを読んで結果としてnilを返すというもの。

「吸い尽くす」ということですが、何に使うんでしょう。検証用とかでしょうか。

何故かこれだけ、EOFの検査にdefconstantで定義したeofを使っていなかったりします。

感想のようなもの

毎回(awhen (probe-file "foo") ~ it)するので、そこまで一つのマクロにしたらどうかしらとか思ったりしますが、うーん、どうなんでしょう。

(defmacro with-infile-if-probed (str path &body body)
  `(awhen (probe-file ,path)
     (with-infile ,str it ,@body)))

2007-10-18

Lisppasteからの漂着物(unzipcan)

| 02:46 | Lisppasteからの漂着物(unzipcan) - わだばLisperになる を含むブックマーク はてなブックマーク - Lisppasteからの漂着物(unzipcan) - わだばLisperになる

とりあえずコードを読むことは日課にしたいところなので、量は少なくとも毎日更新して行くことを目標としました。

今日は、気力が出ないので、LisppasteのRSSをチェックしていて気になったものに挑戦。

Paste number 49158: unzipcan Pasted by: kpreid

コードの作者は、kpreid氏です。

お題

(defun unzipcan (operation list)
  "Call OPERATION for each element of LIST, destructively concatenating its two return values into two result lists."
  (loop with x and y
        for item in list
        do (setf (values x y) (funcall operation item))
        nconc x into xs
        nconc y into ys
        finally (return (values xs ys))))

暗記で再現:失敗

(defun unzipcan (operation list)
  (loop :with x :and y
        :for item :in list
        :do (setf (values x y) (funcall operation item))
        :nconc x :into xs
        :nconc y :into ys
        :finally (values xs ys)))

finally節で、returnを忘れてしまった…。もっとloopに親しまないといけないなという感じ。

ちなみに、doだと、

(defun unzipcan (operation list)
  (do ((item list (cdr item))
       x y 
       (xs (list ()))
       (ys (list ())))
      ((endp item) (values (cdr xs) (cdr ys)))
    (setf (values x y) (funcall operation (car item)))
    (nconc xs x)
    (nconc ys y)))

みたいな感じでしょうか…。

ループのキーワードがキーワードなのは、こういう風に書いている人がいて、こっちの方がキーワードっぽくて自分には読みやすかったのて真似してみました。

どうしてこれをお題をしたかというと、(setf (values x y) (funcall operation item))っていうところを読んて、setfにvaluesとか使えることを初めて知ったので記念に取り上げてみました。

まあ、multiple-value-setqとかありますが…。戻り値が多値と単一だったり微妙に動作が違ってはいたりはします。

このunzipcanの動作については良く分からず、

(unzipcan (lambda (x) (list (apply #'floor x))) '((2 1) (4 3) (6 5) (8 7)))

とか

(unzipcan (lambda (x) (values `(,(car x)) `(,(cadr x)))) '((2 1) (4 3) (6 5) (8 7)))

とかするんでしょうか。

mapcan的なunzipってのは分かるんですが…。

2007-10-16

Paul Graham氏のユーティリティ その5

| 03:25 | Paul Graham氏のユーティリティ その5 - わだばLisperになる を含むブックマーク はてなブックマーク - Paul Graham氏のユーティリティ その5 - わだばLisperになる

PG氏のユーティリティを読んでみることの5回目。

ファイルの読み書きユーティリティ編です。

Lisp utilities that were not included in On Lisp or ANSI Common Lisp

下準備

(defconstant eof (gensym))

PG氏は、eofっていう定数を定義するらしい。どういう御利益があるのかまだ自分には推し量れないのだった。

お題

clear-file

暗記で再現

(defun clear-file (file)
  (aif (probe-file file) (delete-file it)))

とりあえずできた。その名の通りファイルを消去するユーティリティ。

;; 動作
(clear-file "/tmp/foo.txt")
=> ファイルが消えました。

お題

do-chars

暗記で再現

(defmacro do-chars (var str &body body)
  (with-gensyms (g)
    `(let ((,g ,str))
       (do ((,var (read-char ,g nil eof) (read-char ,g nil eof)))
	   ((eql ,var eof))
	 ,@body))))

とりあえずきた。暗記するときにstrはストリングと覚えたので再現するとき混乱してしまった、streamの略だった。

;; 動作
(with-input-from-string (stream "foo bar baz")
  (do-chars i stream
    (print i)))
#\f 
#\o 
#\o 
#\  
#\b 
#\a 
#\r 
#\  
#\b 
#\a 
#\z 

お題

do-stream

暗記で再現

(defmacro do-stream (var str &body body)
  (with-gensyms (g)
    `(let ((,g ,str))
       (do ((,var (read ,g nil eof) (read ,g nil eof)))
	   ((eql ,var eof))
	 ,@body))))

とりあえずできた。do-charsとは、read-charを使うかread-を使うかの違いだけ。

;; 動作
(with-input-from-string (stream "foo bar baz")
  (do-stream i stream
    (print i)))

FOO 
BAR 
BAZ 

お題

in-case-error

暗記で再現

(defmacro in-case-error (expr err)
  (with-gensyms (var cond)
    `(bind (,var ,cond) (ignore-errors ,expr)
       (if (typep ,cond 'error)
	   (progn
	     ,err
	     (error ,cond))
	   ,var))))

とりあえずできた。自分がファイル関係の操作に馴れてないってのもあって、どういう意図があってこういう構成になっているのか分かっていないのだった。

順番がファイルと前後してしまうけれど、後ででてくるfile-readが依存しているので、先に読むことに。

;; 動作
(in-case-error 
 (load "/tmp/f") ;存在していないファイル
 (format *error-output* "hello!"))
=> hello!

お題

with-infile

暗記で再現

(defmacro with-infile (var fname &body body)
  (with-gensyms (f)
    `(let ((,f ,fname))
       (in-case-error
	(with-open-file (,var ,f :direction :input)
	  ,@body)
	(format *error-output* "Error reading from ~S.~%" ,f)))))

とりあえずできた。with-open-fileをちまちま書くのが面倒だったので作られたようなマクロ。元ファイルには何故か使われていないgensymの宣言があってちょっと迷った。

お題

file-read

暗記で再現

(defun file-read (path)
  (awhen (probe-file path)
    (with-infile str it
      (read str nil nil))))

とりあえずできた。上記2つはfile-readが依存していたので芋蔓式に書くことになった。しかし、これはファイルの先頭しか読まないんだけれど、どういう風に使うんだろう…。

お題

file-read-line

暗記で再現

(defun file-read-line (path)
  (awhen (probe-file path)
    (with-infile str path
      (read-line str nil nil))))

とりあえずできた。その名の通り上記file-readのread-line版。これも使い方が良く分からない。

これまで気付いたちょっとしたこと

PG氏に一貫しているところとして、

  1. eqを使わない(eql以上を使う)
  2. マクロでは&bodyを使わず、&restで統一
  3. ファイルユーティリティ系では、アナフォリック系条件式で、probe-fileをして、itで読み込ませるのを定石としているらしい。
  4. gensymで使われるシンボルはとりあえず、g次に順番で、hとかが多い。

他に自分が感じるところとしては、日常で使うシェルスクリプト的感覚で、思い付いたらとりあえずマクロ作って使ってみてるんじゃないかと思ったりします。