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


Setagayaプロジェクト (1)

| 19:58 | Setagayaプロジェクト (1) - わだばLisperになる を含むブックマーク はてなブックマーク - Setagayaプロジェクト (1) - わだばLisperになる

UNIXで生活している上で初期化ファイルは非常に大事でまた愛着が湧くものでもあり、また人様の初期化ファイルは非常に勉強になったり興味深かったりします。

The very unofficial dotemacs homehttp://www.dotfiles.com/:tilte=www.dotfiles.comのようなサイトもある位ですが、Common Lispのユーティリティにも自分は同じようなものを感じます。

そういうユーティリティを集めて便利に使えたら良いなと思い、Google Codeでプロジェクトを作ってみました。

いちいち考えがまとまらず、ちぐはぐな感じで、結局ただのファイル置場な気が気がしますが、Common Lispのユーティリティを作るのが趣味でネット上にファイルを置いてみたいという方、是非一緒に遊んで下さい。

Google Code Archive - Long-term storage for Google Code Project Hosting.

今のところ自作のSRFI-1等を置いてみています。

srfi-1.setagaya

gotoを多用したふざけた作りになっていますがとりあえずで置いてみました。

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


DrakmaでTwitterに投稿

| 20:00 | DrakmaでTwitterに投稿 - わだばLisperになる を含むブックマーク はてなブックマーク - DrakmaでTwitterに投稿 - わだばLisperになる

Drakma(Common Lispで書かれたウェブクライアント)を使ったことがなかったので、これを使って何かしてみたいと思いTwitterに与えられた文字列を投稿する関数を書いてみました。

本当は、自分が利用している図書館の本の予約状況を取得するようなものを作りたかったんですが、日本語を扱っているページでは、UTF-8以外のページのクッキーの取得が上手く行かず*1、自力では解決できなかったので、UTF-8でできているTwitterで何かすることに方向転換しました。

UTF-8のページだと、殆どDrakmaのチュートリアルの通りですんなりとできました。

本当は、パスワード等は、別ファイルに書き出して読み込ませる方が良いと思いますが直に書いてます。

Drakmaは思った以上に便利なんですが、どうやったら文字コードの問題がクリアできるのかー。

(defun update-twitter-status (mesg)
  "twitterに投稿する"
  (let ((mesg-list (split-by-length mesg 50))
	(cj (make-instance 'drakma:cookie-jar)))
    ;; login
    (drakma:http-request "http://twitter.com/sessions" 
			 :external-format-in :utf-8 
			 :external-format-out :utf-8
			 :method :post
			 :cookie-jar cj
			 :parameters `(("username_or_email" . "おなまえ") 
				       ("password" . "パスワード")))
    ;; update
    (do ((m mesg-list (cdr m)))
	((endp m) (length mesg))
      (drakma:http-request "http://twitter.com/status/update" 
			   :external-format-in :utf-8
			   :external-format-out :utf-8
			   :method :post
			   :cookie-jar cj
			   :parameters `(("status" . ,(car m))))
      (unless (endp (cdr m)) (sleep 5)))))

(defun split-by-length (str len)
  "指定した長さ`len'で文字列`str'を区切り、結果を文字列のリストにして返す。"
  (let ((slen (length str)))
    (if (> slen len)
	(do ((pos len (+ pos len))
	     res)
	    ((> pos slen) 
	     (nreverse (push (subseq str (- pos len) slen) res)))
	  (push (subseq str (- pos len) pos) res))
	`(,str))))

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

雑感

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

*1::external-format-inで、:euc-jpの扱いが良く分からず、:force-binary tで読み込んで、octets-to-stringで戻すことはできるけれど、それだとcookieは拾ってくれない、などとぐるぐる悩む

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


Maclispの入出力ユーティリティを再現してみる

| 18:54 | Maclispの入出力ユーティリティを再現してみる - わだばLisperになる を含むブックマーク はてなブックマーク - Maclispの入出力ユーティリティを再現してみる - わだばLisperになる

MaclispのLispで書かれたシステムソースを漁っていて面白そうな機構があったので再現して遊んでみました。

ファイル名は、IOTA.LSPで、恐らく1980年付近のコードで、オリジナルはKent Pitman氏の作のようです。

このIOTA.LSPの中で、IOTAとPHIという、いわば入出力系のletの様な構文が定義されています。

;IOTA 
(IOTA ((<var1> <filename1> <filemodes1>)
       (<var2> <filename2> <filemodes2>) ...)
      <body>)

; 使用例
(DEFUN FILECOPY (FROM TO)
   (IOTA ((FOO FROM 'IN)
          (BAR TO 'OUT))
         (DO ((C (TYI FOO -1) (TYI FOO -1)))
             ((MINUSP C))
            (TYO C BAR))))
; PHI 
(PHI ((<var1> <form1>)
      (<var2> <form2>) ...)
     <body>)

; 使用例
(DEFUN DUMP-DATA (FROM TO)
   (PHI ((FOO (MY-SFA-MAKER FROM 'INPUT))
         (BAR (MY-SFA-MAKER TO 'OUTPUT)))
        (DO ((C (TYI FOO -1) (TYI FOO -1)))
            ((MINUSP C))
          (TYO C BAR))))

まず名前ですが、IOなので、IOTA、file => PHIleということで、PHI、他にPIってのもあります。

IOTAはAPL由来のSRFIのiotaとは全く動作が違っていて、letとopenが足されたようなものに、closeで後始末をするもの、phiは、IOTAと殆ど同じですがストリームを変数に束縛する方法までは備え付けでないもの、といった感じです。

ということで、sbclのwith-open-file等のmacroexpandの出力を参考に適当にがちゃがちゃ作ってみました。

(defmacro iota ((&rest stream-binds) &body body)
  (with-gensyms (abortp)
    `(let (,@(mapcar (lambda (x)
		       `(,(car x) (open ,(cadr x) ,@(cddr x))))
		     stream-binds)
	   (,abortp t))
       (unwind-protect
	    (multiple-value-prog1
		(progn ,@body)
	      (setq ,abortp nil))
	 (progn
	   ,@(mapcar (lambda (x) `(when ,(car x) (close ,(car x) :abort ,abortp)))
		     stream-binds))))))

(defmacro phi ((&rest stream-binds) &body body)
  (with-gensyms (abortp)
    `(let (,@stream-binds (,abortp t))
       (unwind-protect
	    (multiple-value-prog1
		(progn ,@body)
	      (setq ,abortp nil))
	 (progn
	   ,@(mapcar (lambda (x) `(when ,(car x) (close ,(car x) :abort ,abortp)))
		     stream-binds))))))

(defmacro make-input-stream (path &rest keys)
  `(open ,path :direction :input ,@keys))

(defmacro make-output-stream (path &rest keys)
  `(open ,path :direction :output ,@keys))

make-input-streamとmake-output-streamは別になくても良いと思いますが何となく…。

;使用例
(DEFUN FILECOPY (FROM TO)
  (IOTA ((FOO FROM :direction :input 
	           :element-type 'unsigned-byte)
	 (BAR TO :direction :output 
	         :if-exists :supersede
		 :element-type 'unsigned-byte))
    (DO ((C (read-byte FOO nil -1) (read-byte FOO nil -1)))
	((MINUSP C))
      (write-byte c BAR))))

(filecopy "/tmp/foo.jpg" "/tmp/quux.jpg")
;=> ファイルがコピーされる。

(DEFUN DUMP-DATA (FROM TO)
  (PHI ((FOO (make-input-stream from :element-type 'unsigned-byte))
	(BAR (make-output-stream to :element-type 'unsigned-byte
				    :if-exists :supersede
				    :if-does-not-exist :create)))
    (DO ((C (read-byte foo nil -1) (read-byte foo nil -1)))
	((MINUSP C))
      (write-byte c BAR))))

(dump-data "/tmp/abc.jpg" "/tmp/123.jpg")
;=> ファイルがコピーされる。

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


Lisp関係の文献の翻訳

| 07:31 | Lisp関係の文献の翻訳 - わだばLisperになる を含むブックマーク はてなブックマーク - Lisp関係の文献の翻訳 - わだばLisperになる

このブログのテーマであるLispやレトロコンピューティング系の情報/文献というとやはり英語圏のものがほとんどで、英語が苦手な自分は文献が存在することは分かっていても内容がちっとも把握できないというもどかしさを日々感じているわけなのですが、そんなLispとレトロコンピューティング系の面白い文献を翻訳し公開されている素敵過ぎるブログ(okshiraiさんのブログ)をみつけたので何点か紹介させてもらいたいと思います!!

okshiraiさんのブログ

エラー:SSブログ

沢山翻訳されているのですが、何点か取り上げるとすると、まずは、

Guy L. Steele Jr氏と、Richard P. Gabriel氏の

The evolution of Lispの翻訳

これは、Lispの歴史を俯瞰したもので読み応えがあります。

Peter Norvig氏とKent Pitman氏の

Tutorial on Good Lisp Programming Styleの翻訳

こっちは、以前にこのブログでも触れたLispのプログラミングにおけるスタイルについてまとめられたもの。ためになりました!

その他、Paul Graham氏のArc関連のものや、Interlisp関連のもの、Richard Greenblatt氏の2002年のObjective Lispの提案等々盛沢山。さらに、現在Computer History MuseumのGreenblattやAlan Kotok氏のインタビューも翻訳されている最中です。

自分にとってはまさにお宝の山であり、小一時間ディスプレイの前で「うぉー、すげー」と叫んでおりました。

これからもどんどん続けて行って頂きたいです。

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


リーダーマクロでPerlのインデックスのまね事

| 13:01 | リーダーマクロでPerlのインデックスのまね事 - わだばLisperになる を含むブックマーク はてなブックマーク - リーダーマクロでPerlのインデックスのまね事 - わだばLisperになる

今回は、Perlの$foo[1]や、$bar[i]などという、インデックス指定の構文を真似してみることにしました。

作ってみたい構文

(let ((list '(0 1 2 3)))
  [1]list)
;=> 1

最初は、ディスパッチマクロ文字が引数を取れることを利用して組んでみましたが、これだと、10進の数しか引数に取れず変数が使えないのでは面白くないのでリーダーマクロで作ることに方針変更。

試行錯誤しているうちにできたものの、なんだか良く分からないものができました。

(set-macro-character #\[
		     (lambda (stream char)
		       (declare (ignore char))
		       (cache-arg (read stream t nil t))
		       (values)))

(set-macro-character #\]
		     (lambda (stream char)
		       (declare (ignore char))
		       (list 'elt-with-cached-index (read stream t nil t))))

(let (arg)
  (defun cache-arg (n)
    (setq arg n))
  (defmacro elt-with-cached-index (lst)
    `(elt ,lst ,arg)))
[1]list

というのを単純に

(elt list 1)

に変換したかっただけなのですが、いまいちうまい展開方法が分からず、

  1. #\[は、cache-argという次の文字をキャッシュする関数を実行するが、副作用が欲しいだけで、何かが展開されると逆に不都合なので、(values)を実行し、何も痕跡を残さない。
  2. #\]は、chache-argがキャッシュした引数でnthを実行するという、elt-with-cached-indexに展開させる。
  3. cache-argからelt-with-cached-indexに引数を受け渡す手段がないので、両者をクロージャで包み変数を共有させた。
  4. nth-with-cached-indexは展開された引数が、展開される文脈中で実行される必要があるので?(うまく説明できない(;´Д`)…)マクロにした。

という流れです。特にリーダーマクロが(values)を最後に評価して消えたりするところが非常にアレな気がします。

;; 動作
(progn
  [1]'(1 2 3))
; => 2

(my i 3
  (print [(+ i 3)](srfi:iota 10)))
; => 5

(my str "123456789"
  [3]str)
; => 4

(progn 
  [(+ 3 3)]'(0 1 2 3 4 5 6 7 8 9 10))
; => 6

(map 'string (lambda (x) [x]"abcdefghij")
     '(2 3 8 0 1 2 3))
; => "cdiabcd"  

(loop :for i :below 10 
      :do (print [i]'(a b c d e f g i h j k)))
; =>
;A 
;B 
;C 
;D 
;E 
;F 
;G 
;I 
;H 
;J 
;NIL 

ちなみに

(my lst '(foo bar baz)
 [1

 (print "hello")

 ]lst)
; -> "hello"
; => BAR

のようなものの対策は施していません。

雑感

自分の期待とは裏腹に使えなさそうなものに仕上がりました。

こういう場合の定番の解決手法ってどういうものがあるんでしょう…。

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とかが多い。

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

2007-10-15

StumpWM

| 23:54 | StumpWM - わだばLisperになる を含むブックマーク はてなブックマーク - StumpWM - わだばLisperになる

del.icio.usのLispタグからStumpWMの紹介のムービーが流れてきたのでチェック。

The StumpWM Experience : male : Free Download, Borrow, and Streaming : Internet Archive

StumpWMはCommon Lispで書かれたウィンドウマネージャーということで、前から興味はあったのですが、この動画を観ると思いのほか使えそうなので、インストールしてみることにしました。

最初、asdf-install可能だったので、cmuclで試してみましたが、どうやら、登録されているのは古めで、試すなら、最新の方が良さそうだったので、READMEを参照しつつ再度sbclで試してみることにしました。

以下、Ubuntu 7.04 + SBCL 1.0.10 + Git版StumpWMで試しています。

StumpWMのソースの取得

$ git clone git://git.savannah.nongnu.org/stumpwm.git

で取得します。

ASDFで導入できるようにする。

ダウンロードしたものの中にstumpwm.asdがあるので、asdf::*central-registry*に登録されているパスにリンクを張ります。

専用イメージの作成

別にイメージを作成しなくても良いとは思うのですが、起動が少し速いのでイメージを作成してみることにします。cl-ppcreとclxに依存しているので、それも読み込みます。

;; make-stumpwm-core.lisp
;;
;; cd $coredir 
;; sbcl --load make-stumpwm-core.lisp

(require :asdf)
(asdf:oos 'asdf:load-op :clx)
(asdf:oos 'asdf:load-op :cl-ppcre)
(asdf:oos 'asdf:load-op :stumpwm)
(save-lisp-and-die "stumpwm-sbcl.core" :purify t)

のようなファイルを作成し、

$ sbcl --load make-stumpwm-core.lisp

を実行して、イメージを作成しました。

ウィンドウマネージャーの起動

色々方法はあると思うのですが、自分は、最初に古いstumpwmを試してしまったということもありスクリプトを色々作って対応しました。

最新だと色々準備されている様子なので、そっちを使った方が良いとは思います。

#!/bin/sh

sbcl --core ~/cl/stumpwm-sbcl.core --load ~/cl/stumpwm-sbcl.lisp
;; STUMPWM - stumpwm-sbcl.lisp
;; ================================================================
(stumpwm:stumpwm)
(cl-user::quit)

のような、stumpwmというシェルスクリプトと起動で読み込ませるファイルを作成し、

~/.xsessionに

#!/bin/sh

#~色々環境設定記述~

$HOME/bin/stumpwm

のように記述し起動させることにしました。

カスタマイズ

環境設定は、.stumpwmrcで設定します。サンプルが付いているので、それを参照しつつ設定という感じです。

使ってみる

使ってみた感じとしては、GNU Screenのウィンドウマネージャー版みたいな感じです。

初期設定では、Control-tがプレフィックスキーになっていて、そのあとにコマンドを入力します。

C-t :で式を評価できたりします。

詳細なドキュメントはないので、サンプルの初期化ファイルと、ソースを読んで、使い方を探るという感じです。

ウィンドウマネージャーの終了方法

とりあえず、どうやって終了するのか分からないので、式評価のプロンプトに(cl-user::quit)として終了させています。

まとめ

とりあえず、Common Lispで色々できるというところと、ムービーでは結構便利そうに使っていたので、しばらく常用してみたいと思います。

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

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

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

引き続き繰り返し系(do系)のユーティリティ編です。

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

お題

do-cyclic

暗記で再現

(defmacro do-cyclic (parms source &body body)
  (with-gensyms (g)
    `(let ((,g ,source))
       (case (length ,g)
	 (0 nil)
	 (1 (let ((,(first parms) (first ,g))
		  (,(second parms) (first ,g))
		  (,(third parms) (first ,g)))
	      ,@body))
	 (2 (let ((,(first parms) (second ,g))
		  (,(second parms) (first ,g))
		  (,(third parms) (second ,g)))
	      ,@body)
	    (let ((,(first parms) (first ,g))
		  (,(second parms) (second ,g))
		  (,(third parms) (first ,g)))
	      ,@body))
	 (otherwise 
	  (do-tuples/c ,parms (rotlist ,g)
	    ,@body))))))

とりあえずできた。ややこしい。そして、使い道が良く分からない。

rotlistは、このutx.lisp内で、do-tuples/cはonlispで定義されている。

動作
(do-cyclic (x y z) '(a b c d e f g h i j k)
  (print `(,x ,y ,z)))
=>
(K A B) 
(A B C) 
(B C D) 
(C D E) 
(D E F) 
(E F G) 
(F G H) 
(G H I) 
(H I J) 
(I J K) 
(J K A) 

お題

(defmacro do-plist (v1 v2 plist &rest body)
  (with-gensyms (rec rest pl)
    `(labels ((,rec (,v1 ,v2 ,rest)
                 ,@body
                 (when ,rest
                   (,rec (car ,rest) (cadr ,rest) (cddr ,rest)))))
       (let ((,pl ,plist))
         (when (consp ,pl)
           (,rec (car ,pl) (cadr ,pl) (cddr ,pl)))))))

暗記で再現:失敗

(defmacro do-plist (v1 v2 plist &body body)
  (with-gensyms (rec rest pl)
    `(labels ((,rec (,v1 ,v2 ,rest)
		(when ,rest
		  ,@body ;ここではない
		  (,rec ,(car rest) ,(cadr rest) ,(cddr rest)))))
       (let ((,pl ,plist)) 
	 (,rec ,(car pl) ,(cadr pl) ,(caddr pl)))))) ;consかどうかの判定を抜かした。
;; 動作
(do-plist i j '(a 1 b 2 c 3 d 4)
  (setf (get 'foo i) j))

(do-plist i j '(a 1 b 2 c 3 d 4)
  (print (get 'foo i)))
=>
1 
2 
3 
4 

動かしてみれば、そんなに難しいものでもなかったけれど、plistの構造が良く分かってないせいで上手く把握できてなくて、途中で何だか良く分からなくなって間違えてしまった。

2007-10-14


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

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

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

繰り返し系(do系)のユーティリティ編です。

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

http://lib.store.yahoo.net/lib/paulgraham/utx.lisp

お題

do-all

暗記で再現

(defmacro do-all (var x &body body)
  (with-gensyms (g)
    `(let ((,g ,x))
       (if (consp ,g)
	   (dolist (,var ,g) ,@body)
	   (let ((,var ,g)) ,@body)))))
;; 動作
(do-all i '(a b c d e)
  (print i))
=>
a
b
c
d
e

(do-all i 'a
  (print i))
a

とりあえずできた。

ポイントとしては当たり前のことなのかもしれないけれど、前回のエントリでも考えていた展開時の動作について

この例では、consかどうかの判定は展開時ではなくて、実行時にされる。

自分は、極端に書けば、

(defmacro do-all (var x &body body)
  (with-gensyms (g)
    (if (consp (cadr x))
	`(let ((,g ,x))
	   (dolist (,var ,g) ,@body))
	`(let ((,g ,x))
	  (let ((,var ,g)) ,@body)))))

のようなもの(展開時にconsかを判定したりする)を書いてしまいがちなので気を付けたい。

お題

dolists

暗記で再現

(defmacro dolists (pairs &body body)
  (with-gensyms (f)
    (let ((parms (mapcar (lambda (x) (declare (ignore x))
				 (gensym)) 
			 pairs)))
      `(labels ((,f ,parms
		  (when (or ,@parms)
		    (let ,(mapcar (lambda (p g)
				    (list (car p) `(car ,g)))
				  pairs
				  parms)
		      ,@body
		      (,f ,@(mapcar (lambda (p) `(cdr ,p)) parms))))))
	 (,f ,@(mapcar #'cadr pairs))))))

とりあえずできた。

(mapcar (lambda (x)
	  (declare (ignore x))
	  (gensym)) 
	pairs)

は引数の個数だけgensymを作るという常套句らしい。(declare (ignore x))しないと警告がでるので宣言を追加した。

;; 動作
(dolists ((i '(1 2 3))
	   (j '(a b c d)))
  (print (list i j)))

(1 A) 
(2 B) 
(3 C) 
(NIL D) 

map系のように一番短いものに合わせるのではなく一番長いものに合わせたくなったときには便利な気がする。

お題

do3

暗記で再現

(defmacro do3 (v1 v2 v3 list &body body)
  (with-gensyms (g h)
    `(let ((,g ,list))
       (do ((,h ,g (cdr ,h)))
	   ((endp ,h) nil)
	 (let ((,v1 (car ,h))
	       (,v2 (if (cdr ,h)
		       (cadr ,h)
		       (car ,g)))
	       (,v3 (if (cddr ,h)
			(third ,h)
			(if (cdr ,h)
			    (car ,g)
			    (cadr ,g)))))
	   ,@body)))))
;;動作
(do3 hee foo mee '(1 2 3 4 5 6 7 8 9 10 11 12)
  (print (list hee foo mee)))
=>
(1 2 3) 
(2 3 4) 
(3 4 5) 
(4 5 6) 
(5 6 7) 
(6 7 8) 
(7 8 9) 
(8 9 10) 
(9 10 11) 
(10 11 12) 
(11 12 1) 
(12 1 2) 

とりあえずできた。

どういうときに使うのか、ぱっとは思い付かないけど、便利そうではある。

2007-10-12


マクロでPerlのmyのまね

| 00:06 | マクロでPerlのmyのまね - わだばLisperになる を含むブックマーク はてなブックマーク - マクロでPerlのmyのまね - わだばLisperになる

Perlに挑戦して何度も挫折しているんですが、それならLispでPerlの機構を真似ることで学ぶというのはどうだろうかと思い立ち、Perlの入門書を見ながらPerlの機構を再現してみることにしました。

今回は、変数束縛機構?のmyを作ってみました。

Gaucheのlet1+Common Lispのdestructuring-bind+αみたいな感じになってます。

(defmacro my (vars vals &body body)
  (cond ((member vals '('nil nil) :test #'equal)
	 `(let ,(if (consp vars) vars `(,vars))
	    ,@body))
	('T 
	 (if (consp vars)
	     (if (member '&rest vars)
		 `(destructuring-bind ,vars ,vals
		    (declare 
		     (ignorable ,@(remove-if-lambda-list-keyword vars)))
		    ,@body)
		 (let ((g (gensym)))
		   `(destructuring-bind 
			  (,@(remove-if-lambda-list-keyword vars) &rest ,g) ,vals
		      (declare (ignorable ,@vars ,g))
		      ,@body)))
	     `(let ((,vars ,vals))
		,@body)))))

(defun remove-if-lambda-list-keyword (lst)
  (remove-if (lambda (x) (member x lambda-list-keywords)) lst))

;;; (my foo ()
;;;     (print foo))
;;; => NIL
;;; 
;;; (my foo 1
;;;     (print foo))
;;; => 1
;;; 
;;; (my (foo) '(1)
;;;     (print foo))
;;; => 1
;;; (my foo '(1 2 3 4 5 6 7 8 9)
;;;     (format t "~@{~A~^, ~}" foo))
;;; -> (1 2 3 4 5 6 7 8 9)
;;; 
;;; (my (foo bar baz) '(1 2 3 4 5 6 7 8 9)
;;;     (format t "~@{~A~^, ~}" foo bar baz))
;;; -> 1, 2, 3
;;; 
;;; (my (foo bar baz) '()
;;;     (format t "~@{~A~^, ~}" foo bar baz))
;;; -> NIL, NIL, NIL
;;; 
;;; (my (foo bar baz) '(1 2 3 4 5 6 7 8 9)
;;;     (format t "~@{~A~^, ~}" foo bar baz))
;;; -> 1, 2, 3
;;; 
;;; (my (foo bar baz) ()
;;;     (format t "~@{~A~^, ~}" foo bar baz))
;;; -> NIL, NIL, NIL
;;; 
;;; (my (foo bar &rest baz) '(1 2 3 4 5 6 7 8 9)
;;;     (format t "~@{~A~^, ~}" foo bar baz))
;;; -> 1, 2, (3 4 5 6 7 8 9)
;;; 
;;; (my (&rest foo) '(1 2 3 4 5 6 7 8 9)
;;;     (format t "~@{~A~^, ~}" foo))
;;; -> (1 2 3 4 5 6 7 8 9)

マクロ書法についての疑問

最近マクロを自分流でごちゃごちゃ作っていて思うのですが、展開時に色々処理をするというのは非常に悪いスタイルなのかもしれないと気になります。

Tutorial on Good Lisp Programming Style

http://norvig.com/luv-slides.ps

での、

Bad: Works at the expansion time.

(defmacro defclass (name &rest def)
  (setf (get name 'class) def)   
  ...
  (list 'quote name))

のようなものが念頭にあるのですが、今回のものも1通りに展開されるのではなくて、状況によって3通りに展開されます。

いまいち勘所が掴めないという…。

上記の例では、

  1. 展開時の動作で代入をしてしまっている。

ってのが要点でしょうか。展開の副作用を処理のメインに使うのは良くないという主張だとしたら何となく分かりますが、なかなか難しい…。

2007-10-10


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

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

今日も続きでPaul Graham氏のユーティリティを読んでみることにしました。

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

http://lib.store.yahoo.net/lib/paulgraham/utx.lisp

お題

bind

暗記で再現

(defmacro bind (args &body body)
  `(multiple-value-bind ,args ,@body))

いま一歩だった。

バインド部とボディを分ける必要がなかった。

名前が長いのでエイリアスのためのマクロらしい。

お題

ifnot

暗記で再現

(defun ifnot (bad var)
  (unless (eql bad var) var))

とりあえずできた。

ちょっとした便利小物といった感じ。でも、自分の思考パターンにない感じなので用途がぱっとは思い付かない。

お題

nullor

暗記で再現

(defmacro nullor (x y)
  (with-gensyms (g)
    `(let ((,g ,x))
       (if (null ,g) ,y ,g))))

間違った。

nullで判定するのではなくて、(zerop (length ,g))で判定していた。これならlist以外にも使えるということなんだろう。

(let ((hello-str (nullor str "Hello")))
     ...)

などのようにデフォルト値の設定などに使うのだろうか。

お題

until

暗記で再現

(defmacro until (test &body body)
  `(do ()
       (,test)
     ,@body))

これは定番といった感じ。

お題

caseequal

暗記で再現

(defmacro caseequal (var &body clauses)
  (let ((g (gensym)))
    `(let ((,g ,var))
       (cond ,@(mapcar (lambda (cl) 
			 `(,(if (eql (car cl) t)
				t
				`(equal ,g (car cl)))
			    ,@(cdr cl)))
		       clauses)))))

とりあえずできた。

equalで判定するcaseだから、caseequalという、memq、delq系の、動作+判定するeq系の命名法のマクロの様子。

このような命名法では、TAOのmember系の命名がなかなか素敵で、memq、memql、memquと分かりやすい。

http://www.nue.org/nue/tao-manual/tao-m.txt

SRFIだと、memq、memvといった感じ。

Common Lispでは消えてしまったけれど、Maclispでは普通に使われていた様子。Common Lispでは消えたけれど、EmacsやSchemeには受け継がれている名前というのは結構ある気がする。

2007-10-09


Paul Graham氏のユーティリティ

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

たまには普通に勉強になりそうなコードに挑戦しようと思い、del.icio.usのlispタグから流れて来たPaul Graham氏のユーティリティを読んでみることにしました。

これは、On LispやANSI Common Lispには載ってないものを纏めたもののようです。

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

http://lib.store.yahoo.net/lib/paulgraham/utx.lisp

大きいものはないので数点纏めてます。いきなり途中から始まってますが、これより前はもう読んでいたので、途中からになってます。

お題

delete-nth

暗記で再現

(defun delete-nth (n lst)
  (cond ((< n 0) (error "Bad arg to delete-nth"))
        ((= n 0) (cdr lst))
        (t (let ((rest (nthcdr (1- n) lst)))
             (pop (cdr rest))
             lst))))

とりあえず同じにできた。

副作用あったりなかったり。

だからdelete系なんだろうけども。

お題

pull-nth

暗記で再現

(defmacro pull-nth (n place)
  (multiple-value-bind (vars forms var set access) (get-setf-expansion place)
    (let ((g (gensym)))
      `(let* ((,g ,n)
	      ,@(mapcar #'list vars forms)
	      (,(car var) (delete-nth ,g ,access)))
	 ,set))))

;; 実行例
(let ((l '(a (1 2 3 4 5) b c)))
  (pull-nth 3 (cadr l))
  l)
;=>(A (1 2 3 5) B C) 

とりあえずできた。

上記のdelete-nthを使ったもの。

get-setf-methodってのが分からなくて、HyperSpecにも該当なしだしなんだろうと思って調べたら、ANSI Common Lispでは、get-setf-expansionとなっているらしい。

紫藤さんのページが参考になりました。

http://www.shido.info/lisp/macro4.html

お題

ninsert-nth

暗記で再現

(defun ninsert-nth (n obj lst)
  (if (< n 0)
      (error "Bad arg to ninsert-nth.")
      (let ((rest (nthcdr n lst)))
	(push obj (cdr rest))
	lst)))

とりあえずできた。

挿入される場所がなんとなくしっくりこない…。

お題

push-nth

暗記で再現

(defmacro push-nth (n obj place)
  (multiple-value-bind (vars forms var set access) (get-setf-expansion place)
    (with-gensyms (g h)
      `(let* ((,g ,n)
	      (,h ,obj)
	      ,@(mapcar #'list vars forms)
	      (,(car var) (ninsert-nth ,g ,h ,access)))
	 ,set))))

;; 実行例
(let ((l '((a b c d) 2 3 4 5 6 7)))
  (push-nth 1 '('-'*) (car l))
  l)
;=>((A B ('- '*) C D) 2 3 4 5 6 7) 

お題

insert-elt-after

暗記で再現

(defun insert-elt-after (elt ins lst)
  (if (null lst)
      nil
      (if (eql (car lst) elt)
	  (cons (car lst) (cons ins (cdr lst)))
	  (cons (car lst) (insert-elt-after elt ins (cdr lst))))))

;; 実行例
(insert-elt-after 'x 'foo '(x y z))
=>(X FOO Y Z) 

とりあえずできた。

感想

レトロなコードを読むより勉強になってるというか、ためになってる感は強く感じる…。

当たり前か…。

2007-10-08

LTD

| 19:18 | LTD - わだばLisperになる を含むブックマーク はてなブックマーク - LTD - わだばLisperになる

なんとなく前から試してみたかったPeter Norvig氏のLTD(Common lispからDylanにコンバートするツール)がどんなものなのか試してみました。

Converting Common Lisp to Dylan

多分、暫くすると導入方法等は完全に忘れてしまうのでメモ。

インストール

概要は、サイトにドキュメントがあるので、そのまま進んで行けば導入はできるようです。

最初SBCLで試してみましたが、あまり上手く動かず、試用版のAllegroはそこそこ上手く使えるようです。Clispでも打ち死しました。

関数の定義の順番で上手くloadできなかったり、パッケージのロックとぶつかってしまったりしますが、ぶつかる個所を適当にコメントアウトしたり、定義の順番を入れ換えたりしてちょっといじってやりすごしました。

;; make-ltd-core.lisp
(load "load")
(load-ltd :compile t)
(load-ltd)
(dumplisp :name "ltd-allegro.core")
(exit)

のようなファイルを作って、codeのディレクトリに移動し、

% alisp -L ../make-ltd-image.lisp

のように実行すると、イメージができるので、

alisp -I ltd-allegro.core

のように実行するとLTD込みのAllegroが起動。

変換してみる

;; foo.lisp
(defun fib (n)
  (if (< n 2)
      n
      (+ (fib (1- n))
	 (fib (- n 2)))))

(defun tarai (x y z)
  (cond ((> x y)
	 (tarai
	  (tarai (1- x) y z)
	  (tarai (1- y) z x)
	  (tarai (1- z) x y) ))
	(t y) ))

のようなファイルを作って、

(ltd-files "foo.lisp")

とすると、

// foo.lisp
define method fib (n)
  if (n < 2) n; else fib(n - 1) + fib((n - 2)); end if;
end method fib;

define method tarai (x, y, z)
  if (x > y)
    tarai(tarai(x - 1, y, z), tarai(y - 1, z, x), tarai(z - 1, x, y));
  else
    y;
  end if;
end method tarai;

のようにdylanに変換されたfoo.dylanが生成されます。

testディレクトリには、このツールで変換された約4万行の変換されたファイルがあり、なかなか壮観です。

…しかし、自分は上手く変換できませんでした。

色々探ってみる必要がありそうです。しかし、難しそう。

Gaucheのファイルを読み込んで、Common Lispに書き出してくれるようなツールがあると便利そうだなとしばし妄想。

MAP(TI Explorer)

| 01:22 | MAP(TI Explorer) - わだばLisperになる を含むブックマーク はてなブックマーク - MAP(TI Explorer) - わだばLisperになる

今回は、テキサス・インスツルメンツ(TI)社が製造していてLispマシンのExplorerのMAPに挑戦してみます。

Explorerのソースコードはウェブで公開されています。

Error 404 (Not Found)!!1

1986~1989年位のソースコードのようなので、CLTL1の時期でしょうか。

お題:

(DEFUN MAP (result-type fcn &REST sequences)
  "Maps over successive elements of each SEQUENCE, returns a sequence of the results.
FCN is called first on the 0'th elements of all the sequences,
then on the 1st elements of all, and so on until some argument sequence is exhausted.
The values returned by FCN are put into a result sequence which is returned by MAP.
RESULT-TYPE is a sequence type; the result is of that type.
Or RESULT-TYPE can be NIL, meaning call FCN for effect only,
throw away the values, and return NIL."

  (UNLESS sequences (RETURN-FROM MAP nil))      ;;; if no sequences, then exit
  (LET ((number-of-args (LENGTH sequences))
	(result-length (COMPUTE-MIN-SEQUENCE-LENGTH sequences)))
    ;; <return-length> is the length of the shortest sequence in <sequences>
    
    (WHEN (ZEROP result-length)                 ;;; If some sequence has length 0, return fast.
      (RETURN-FROM MAP (IF result-type (MAKE-SEQUENCE result-type 0) nil)))
    (%ASSURE-PDL-ROOM (+ number-of-args 4))	;;; make sure %PUSH's don't lose
    (IF result-type
	(LET* ((result (MAKE-SEQUENCE result-type result-length)))
	  (IF (LISTP result)
	      ;; if <result> is a list, then CDR-down <result> replacing the i-th element with the
	      ;;   result of applying <fcn> to the i-th element of each sequence
	      (DO ((res result (CDR res))
		   (index 0 (1+ index)))     ;; use <index> to traverse any seuqnces which are arrays
		  ((NULL res) result)        
		(SETF (CAR res)
		      (DO ((seqlist sequences (CDR seqlist)))   ;; push the i-th element of each sequence onto the stack
			  ((NULL seqlist) (%CALL fcn number-of-args))   ;; when done, call the function.
			(%PUSH (IF (ARRAYP (CAR seqlist)) (AREF (CAR seqlist) index)
				   (POP (CAR seqlist)))))))
	      ;; else <result> is an array of some sort.
	      (DOTIMES (index result-length result)   
		(SETF (AREF result index)
		      (DO ((seqlist sequences (CDR seqlist)))
			  ((NULL seqlist) (%CALL fcn number-of-args))
			(%PUSH (IF (ARRAYP (CAR seqlist)) (AREF (CAR seqlist) index)
				   (POP (CAR seqlist)))))))))
	;;  <result-type> unspecified -- just call <fcn> for effect
	(DO ((index 0 (1+ index)))
	    ((= index result-length) nil) 
	  (DO ((seqlist sequences (CDR seqlist)))
	      ((NULL seqlist) (%CALL fcn number-of-args))
	    (%PUSH (IF (ARRAYP (CAR seqlist)) (AREF (CAR seqlist) index)
		       (POP (CAR seqlist)))))))))

初見時の感想:

  • 関数名を大文字にする主義らしい。
  • %assure-pdl-room等Lispマシン依存なコードにみえる。
  • なんとなく複雑な気がする。

暗記で再現:いま一歩

(DEFUN MY-MAP (result-type fcn &rest sequences)
  (UNLESS sequences (RETURN-FROM MY-MAP nil))
  (LET ((result-length (COMPUTE-MIN-LENGTH sequences))
	(seq-len (length sequences)))
    (%ASSURE-PDL-ROOM (+ 4 seq-len))
    (IF (ZEROP result-length)
	(RETURN-FROM MY-MAP (MAKE-SEQUENCE (OR result-type 'list) 0)) ;間違い
	(LET ((result (MAKE-SEQUENCE (or result-type 'list) result-length))) ;間違い
	  (IF result-type
	      (IF (LISTP result)
		  (DO ((index 0 (1+ index))
		       (res result (cdr res)))
		      ((ENDP res) result)
		    (SETF (CAR res)
			  (DO ((seqlist sequences (CDR seqlist)))
			      ((ENDP seqlist) (%CALL fcn seq-len))
			    (%PUSH (IF (ARRAYP (CAR seqlist))
				       (AREF (CAR seqlist) index)
				       (POP (CAR seqlist)))))))
		  (DOTIMES (index result-length result)
		    (SETF (AREF result index)
			  (DO ((seqlist sequences (cdr seqlist)))
			      ((ENDP seqlist) (%CALL fcn seq-len))
			    (%PUSH (IF (ARRAYP (CAR seqlist))
				       (AREF (CAR seqlist) index)
				       (POP (CAR seqlist))))))))
	      (DO ((index 0 (1+ index)))
		  ((= index result-length) nil)
		(DO ((seqlist sequences (CDR seqlist)))
		    ((ENDP seqlist) (%CALL fcn seq-len))
		  (%PUSH (IF (ARRAYP (CAR seqlist))
			     (AREF (CAR seqlist) index)
			     (POP (CAR seqlist)))))))))))

;;; lispm固有のところを想像して適当に補完するための補助関数群
(defvar *pdl* nil)

(defun %assure-pdl-room (size)
  (setq *pdl* (make-list size)))

(defun %push (item)
  (push item *pdl*))

(defun %call (fcn times)
  (let (result)
    (apply fcn (dotimes (i times result)
		 (push (pop *pdl*) result)))))

(defun compute-min-length (seq)
  (apply #'min (mapcar (lambda (x) (length x)) seq)))

反省と観察:

  • make-sequenceの辺がちゃんと再現できなかった。返り値の型がnilになった場合に、とりあえずlistを返してしまうことにしてしまった。正しくは、nilの場合の処理に分岐する。
  • seq-lenよりは、元のnumber-of-argsの方が良い名前。
  • %push、%assure-pdl-room、%call等はLispマシンの関数用?のスタック(PDL)のようで、多分これを使うとLispマシンでは普通より速いんだとは思う。

以上を踏まえて自分なりにまとめてみた:

(DEFUN MY-MAP (result-type fcn &rest sequences)
  (UNLESS sequences (RETURN-FROM my-map nil))
  (LET ((result-length (COMPUTE-MIN-LENGTH sequences))
	(number-of-args (LENGTH sequences)))
    (%ASSURE-PDL-ROOM (+ 4 number-of-args))
    (IF (ZEROP result-length)
	(RETURN-FROM MY-MAP (IF result-type (MAKE-SEQUENCE result-type 0) nil))
	(FLET ((FUNCALL-SEQ (fcn sequences index)
		 (DO ((seqlist sequences (CDR seqlist)))
		     ((ENDP seqlist) (%CALL fcn number-of-args))
		   (%PUSH (IF (ARRAYP (CAR seqlist))
			      (AREF (CAR seqlist) index)
			      (POP (CAR seqlist)))))))
	  (IF result-type
	      (LET ((result (MAKE-SEQUENCE result-type result-length)))
		(IF (LISTP result)
		    (DO ((index 0 (1+ index))
			 (res result (cdr res)))
			((ENDP res) result)
		      (SETF (CAR res) (FUNCALL-SEQ fcn sequences index)))
		    (DOTIMES (index result-length result)
		      (SETF (AREF result index) (FUNCALL-SEQ fcn sequences index)))))
	      (DOTIMES (index result-length nil)
		(FUNCALL-SEQ fcn sequences index)))))))

…けれど、あまりぱっとしない…。

2007-10-03


rev (Lisp 1.5マニュアルより)

| 16:49 | rev (Lisp 1.5マニュアルより) - わだばLisperになる を含むブックマーク はてなブックマーク - rev (Lisp 1.5マニュアルより) - わだばLisperになる

今回は、Lisp 1.5のマニュアル*1の中のrevに挑戦してみます。

1962年出版のようなので、恐らく45年前のコードです。

お題:

; function rev, which reverses a list and all its sublists is an example of this.
rev[x] = prog[[y;z];
A    [null[x] → return[y]];
     z:= car[x];
     [atom[z] → go[B]];
     z:= rev[z];
B    y: = cons[z;y];
     x:= cdr[x];
     go [A]];

The function rev will reverse a list on all levels so that
rev[(A ((B C) D))] = ((D (C B)) A)

初見時の感想:

  • 動作としては、入れ子になったリストも全部反対にするreverseの様子.
  • S式じゃなくてM式だ。
  • gotoと再帰の共存を初めて目にした。

暗記で再現:

(defun rev (lst)
  (prog (x y res)
        (setq x lst)
     a  (cond ((endp x) (return res)))
        (setq y (car x))
        (cond ((atom y) (go b)))
	(setq y (rev y))
     b  (setq res (append (list y) res))
        (setq x (cdr x))
	(go a)))

まあ、大体同じに再現できたと思う。返り値のリストの作成は、consで可能だった。

お題をS式に書き直したもの:

(defun rev (x)
  (prog (y z)
     a  (cond ((null x) (return y)))
        (setq z (car x))
	(cond ((atom z) (go b)))
	(setq z (rev z))
     b	(setq y (cons z y))
	(setq x (cdr x))
	(go a)))

考察:

doで書き直してみる(goあり)

;; 
(defun rev (lst)
  (do ((x lst (cdr x))
       y
       res)
      ((endp x) res)
    (setq y (car x))
    (cond ((atom y) (go B)))
    (setq y (rev y))         ;非共通処理
  B (setq res (cons y res))))

要約するとBに飛ぶのは、共通でない処理をスキップするためなので、

(defun rev (lst)
  (do ((x lst (cdr x))
       y
       res)
      ((endp x) res)
    (setq y (car x))
    (setq y (if (atom y) y (rev y)))
    (setq res (cons y res))))
→圧縮
(defun rev (lst)
  (do ((x lst (cdr x))
       y
       res)
      ((endp x) res)
    (setq y (if (atom (setq y (car x))) y (rev y)))
          res (cons y res)))

とか

(defun rev (lst)
  (let (res)
    (dolist (l lst res)
      (setq l (if (atom l) l (rev l)))
      (push l res))))

と今なら書けるところかもしれない。

しかし、45年前のLisp 1.5で同じことができるのかは謎。

どうでも良いこと:

  • 古代LISPのPROGの作法は、このマニュアルに従うところが多い気がする。

DOMAP-AND,DOMAP-OR (Maclisp/LET.LSP)

| 15:02 | DOMAP-AND,DOMAP-OR (Maclisp/LET.LSP) - わだばLisperになる を含むブックマーク はてなブックマーク - DOMAP-AND,DOMAP-OR (Maclisp/LET.LSP) - わだばLisperになる

今回も前回と同じMaclispのLET.LSPからDOMAP-AND、DOMAP-ORに挑戦してみることにしました。

お題:

;;; DOMAP-AND evaluates a form, on successive tails of a list, returning ()
;;;  if any of the evaluations if (), and returning the last one if not.
;;; DOMAP-OR returns the first non-() one, or () if all are ().
;;; Syntax is (DOMAP-and/or (VAR1 <first-form>) ... (VARn <last-form>) <pred>)
;;;   Items in angle-brackets are evaluated, and the names "VARi" are used
;;;   as the stepping variables to use;  <pred> is a "predicate" form.
;;;   Typical use -  (DOMAP-AND (TEMP DATA-LIST) (NOT (LOSEP (CAR TEMP))))
(macro DOMAP-AND (x) 
  (bind-let ((forms (cdr x)) pred (g (gensym)))
	    (setq pred (car (setq forms (reverse forms)))
		  forms (nreverse (cdr forms)))
	    `(DO ((,g)
		  ,.(mapcar #'(lambda (x) `(,(car x) ,(cadr x) (CDR ,(car x))))
			    forms))
		 ((NOT (AND ,.(mapcar #'CAR forms))) ,g)
	       (OR (setq ,g ,pred) (RETURN () )))))

(macro DOMAP-OR (x) 
  (bind-let ((forms (cdr x)) pred (g (gensym)))
	    (setq pred (car (setq forms (reverse forms)))
		  forms (nreverse (cdr forms)))
	    `(DO ((,g)
		  ,.(mapcar #'(lambda (x) `(,(car x) ,(cadr x) (CDR ,(car x))))
			    forms))
		 ((NOT (AND ,.(mapcar #'CAR forms))) () )
	       (AND (setq ,g ,pred) (RETURN ,g)))))

初見時の感想:

  • どういう時に便利なマクロなのかいまいち想像がつかない…。
  • コードの内容はdomap-and/orの違いはちょっとの違いしかない。

暗記で再現:

(defmacro DOMAP-AND (&body forms)
  (let (pred (g (gensym)))
    (setq pred (car (setq forms (reverse forms)))
	  forms (nreverse (cdr forms)))
    `(DO (,g
	  ,.(mapcar (lambda (x) `(,(car x) ,(cadr x) (CDR ,(car x)))) forms))
	 ((NOT (and ,.(mapcar #'car forms))) ,g)
       (OR (setq ,g ,pred) (RETURN () )))))

(defmacro DOMAP-OR (&body forms)
  (let (pred (g (gensym)))
    (setq pred (car (setq forms (reverse forms)))
	  forms (nreverse (cdr forms)))
    `(DO (,g
	  ,.(mapcar (lambda (x) `(,(car x) ,(cadr x) (CDR ,(car x)))) forms))
	 ((and ,.(mapcar #'car forms)) () )
       (AND (setq ,g ,pred) (RETURN ,g )))))

また、これもdefmacroに翻訳してみました。細かいところはちょっと違うけど、なんとかできました。

使い方:

(domap-and (tem '(1 2 3 4 5))
	   (tem2 '(10 20 30 40 50))
	   (print (* (car tem) (car tem2))))
=>
10 
40 
90 
160 
250 

みたいになるのだろうか。やっぱり「これは便利だ!」という使用法が思い付かない…。

技法的なこと:

(setq pred (car (setq forms (reverse forms)))
      forms (nreverse (cdr forms)))

妙に巧妙で妙に感心してしまう。自分なら、

(setq pred (car (last forms))
      forms (butlast forms))

と書いてしまいそう。

BIND-LET (Maclisp/LET.LSP)

| 14:33 | BIND-LET (Maclisp/LET.LSP) - わだばLisperになる を含むブックマーク はてなブックマーク - BIND-LET (Maclisp/LET.LSP) - わだばLisperになる

今回は、MaclispのLET.LSPのBIND-LETをお題にしてみました。

これも大体30年位前のコードです。

お題:

(macro BIND-LET (x)
   ((lambda (ll w vars vals)
	    (do ((l ll (cdr l)))
		((null l))
		(push (cond ((atom (car l)) (push () vals) (car l))
			    ('T (push (cadar l) vals) (caar l)))
		      vars))
	    `((LAMBDA (,.(nreverse vars)) ,.w) ,.(nreverse vals)))
       (cadr x) (cddr x) () () ))

初見時の感想:

  • macroの動作は多分、
(defmacro macro (name (arg) &body body)
  `(defmacro ,name (&whole ,arg &rest bvl-decls-and-body)
     (declare (ignore bvl-decls-and-body))
     ,@body))

のようなものだと思う。

再現:

(defmacro BIND-LET (binds &body body)
  ((lambda (ll w vars vals)
     (do ((l ll (cdr l)))
	 ((endp l))
       (push (cond ((atom (car l)) (push () vals) (car l))
		   ('T (push (cadar l) vals) (caar l)))
	     vars))
     `((lambda (,.(nreverse vars)) ,.w) ,.(nreverse vals)))
   binds body () () ))

感想:

macroの個所をdefmacroに読み替えて再現してみました。

bind-letは要するに普通のletでした。

マクロの中で、letの代わりにlambdaを使って変数を束縛するというのも、場合によってはありなのかもしれないと思ったり。まあ、今回の場合は、letが無い環境なので、lambdaを使っているわけではありますが…。

技法的なこと:

(push (cond ((atom (car l)) (push () vals) (car l))
            ('T (push (cadar l) vals) (caar l)))
      vars)

pushを入れ子にすることで、atomかどうかの判定を一回にまとめている。

どうでも良いこと:

  • 「condのelse節のtは、大文字にしてクオートを付ける」派
  • 「nilも'()も、とにかく()と書く」派