わだばLisperになる

YouTubeのFLVダウンローダー

つくりましょう | 18:02 |

最近PCを新しくして、Ubuntuで64bit環境にしてみたのですが、64bit版Flash PlayerがないためYouTube等は工夫しないと見れなくなってしまいました。元々YouTubeはあんまり見てないんないですが、観れないとなると観たくなってきました。

YouTubeの動画は、FLVという形式らしく、ダウンロード可能とのことで、動画ページに含まれるswfArgsという行のvideo_idとtをyoutube.com/get_video.phpというページにGETで送れば、FLVが取得できる仕組みとのこと(11/30日現在の仕様)ということなので、idの取得は、cl-ppcreで適当に抽出し、FLVのダウンロードは、以前letterさんのletter: Common Lisp でニコニコ動画ダウンローダーという記事を目にしていたので、記事を参考にさせて頂きました。

そんなこんなで、拙いですがFLVダウンローダーをでっち上げてみました。一応動きますが、flvファイル名の付けなおし等はいまいちな出来です。

一応ソース(youtube.lisp)も置いてみます。

;;; 動画ページのJavaScriptにある、swfArgsからvideo_idとtを取得し、両方をhttp://youtube.com/get_video.phpにGETで送りFLVを取得
;;; 
;;; 使用例
;;; (mapc (lambda (u)
;;; 	(format t "~A Started...~%" u)
;;; 	(get-flv-to-file-interactive u (merge-pathnames "Desktop/" (user-homedir-pathname)))
;;; 	(format t "Done...~%"))
;;;       '("http://jp.youtube.com/watch?v=E4PYJhh8ooo" ...))

(defpackage #:setagaya.youtube.mc
  (:nicknames #:youtube)
  (:use #:cl #:series #:drakma)			;and cl-ppcre
  (:export #:get-flv-to-file 
	   #:get-flv-to-file-interactive ;インタラクティブというよりちょっと状況を表示してくれるだけ
	   #:extruct-links))

(in-package #:youtube)

(defun get-video_id-&-title (uri)
  (with-input-from-string (line (http-request uri))
    (let ((id-scanner (ppcre:create-scanner "video_id:'\([0-9A-z\-_]{11}\)'.*,t:'\([0-9A-z\-_]{32}\)'"))
	  (title-scanner (ppcre:create-scanner "vidTitle\">\(.*\)</div>")))
      (flet ((rl () (read-line line nil :eof))
	     (latch (data scanner line)
	       (or data (nth-value 1 (ppcre:scan-to-strings scanner line)))))
	(do ((l (rl) (rl))
	     (id+tee nil (latch id+tee id-scanner l))
	     (title nil (latch title title-scanner l)))
	    ((eq :eof l))
	  (when (and id+tee title)
	    (let ((video_id (aref id+tee 0))
		  (tee (aref id+tee 1))
		  (title (ppcre:regex-replace-all "/" (aref title 0) "-"))) ;ファイル名の"/"をエスケープ
	      (return (values video_id tee title)))))))))

(defun decode-flv-uri (uri)
  (multiple-value-bind (id tee title ) (get-video_id-&-title uri)
    (values (concatenate 'string "http://youtube.com/get_video.php" "?video_id=" id "&t=" tee) title)))

(defun get-flv-to-file (uri path)
  (with-open-stream (in (http-request (decode-flv-uri uri) :want-stream t))
    (with-open-file (out path :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
      (collect-stream out (scan-stream in #'read-byte) #'write-byte))))

(defun get-flv-to-file-interactive (uri dir)
  (multiple-value-bind (flv-uri title) (decode-flv-uri uri)
    (with-open-stream (in (http-request flv-uri :want-stream t))
      (print "connect...")
      (with-open-file (out (merge-pathnames (concatenate 'string title ".flv") dir)
			   :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
	(collect-stream out (scan-stream in #'read-byte) #'write-byte))
      (print "Done..."))))

;; 検索結果等のページからflvへのリンクを抽出
(defun extruct-links (uri)
  (with-input-from-string (line (http-request uri))
    (let ((scanner (ppcre:create-scanner "watch\\?v=")))
      (flet ((rl () (read-line line nil :eof)))
	(do ((l (rl) (rl))
	     res)
	    ((eq :eof l) (nreverse res))
	  (let ((v (nth-value 1 (ppcre:scan-to-strings scanner l))))
	    (when v
	      (pushnew (concatenate 'string "http://jp.youtube.com"
				    (aref (nth-value 1 (ppcre:scan-to-strings ".*\(/watch\\?v=.{11}\)\".*" l)) 0))
		       res :test #'equal))))))))

;; 使用例
;; (get-flv-to-file-interactive URL 保存場所
;;
;; (mapc (lambda (u)
;; 	(format t "~A Started...~%" u)
;; 	(get-flv-to-file-interactive u (merge-pathnames "Desktop/" (user-homedir-pathname)))
;; 	(format t "Done...~%"))
;;       (extruct-links "http://jp.youtube.com/results?search_query=jerry+bergonzi&search=%E6%A4%9C%E7%B4%A2"))

ツイートする

はてなグループへ引越し

17:40 |

はてなグループにLisp関係のグループを作ってみたわけなのですが、グループにも日記が書くことができるようです。

Lisp関係以外のことを書くつもりもなくインポートも簡単にできるようなので、グループ内日記に全部引っ越してしまうことにしました。

本当は引越ししなくてもそのまま連携できれば良いんですけど…。

引越前は、

• (gensym)

でした。

ツイートする

はてなグループでLisp関係のグループを作ってみました。

つくりましょう | 22:51 |

はてなグループという機能があることを知ったので早速Lisp関係のグループを探してみました。

既に一つlispグループというグループがあるのですが、ポール・グレアム氏のANSI Common Lispをxyzzyを使って読むグループということで、Lisp関係とはいえあまり勝手なことを書き散らかす訳にもいかない気がしたので、自分で作ってみることにしました。2番目なので、名前は、cadrグループです。

• cadr group

このグループはLisp的なことであれば特に限定するものではありません。

個人的にはキーワード機能を利用して関数のクロスリファレンス的なものが作れないかを試してみたいと思っています。

また、処理系のインストール記事や、最近のCommon Lisp開発環境ではなくてはならないSLIME、ASDF周辺の情報も集められたら良いなと思っています。

自分自身いまいち、はてなグループの利用方法が分かっていないのですが、どなたでも参加できるように設定したつもりですので、ご興味ありましたらお気軽に参加して頂ければと思います。

ツイートする

String#to_procの真似ごと

つくりましょう | 00:36 |

Matzにっきさん経由で、String#to_procというアイディアを知りました。

Rubyは全く書けませんが、何だか面白そうなので真似して遊んでみました。

元記事だともっと多彩なことができるようですが、複雑になると大変そうなので端折りに端折って気分だけ。

;; to-proc
(defmacro to-proc ((&rest args) string)
  (let ((fn (gensym "FN-")))
    `(let ,args
       (macrolet ((,fn () (read-from-string ,string)))
	 (,fn)))))

;; 動作
(to-proc ((x 3)) "(print x)")
;-> 3

(defun square (x)
  (to-proc ((x x)) "(* x x)"))

(square 3)
;=> 9

(to-proc ((x 2) (y 3)) "(+ x (* 2 y))")
;=> 8

(to-proc ((x 3) (y 2)) "(+ x (* 2 y))")
;=> 7

(mapcar (lambda (x y) (to-proc ((x x) (y y)) "(+ x (* 2 y))")) 
	'(1 2 3) '(10 20 30))

;=> (21 42 63)

to_procをletみたいな形式で実現するのは、ちょっと違うのかなと思いつつ、どっちにしろ引数の指定はすることになるようなので安直にletみたいな感じで…。

使いたい場面がありそうな、なさそうな…。

ツイートする

CLOSチュートリアル (3)

学びましょう | 00:57 |

Common Lisp クックブックさんのところののCLOSのチュートリアルにて新しい練習問題(CLOSチュートリアル -3.6. サブクラスと継承)が出たので挑戦!。

問題.1

今までの記述で、CLOSの機能のうち defstruct に相当するものすべてに言及してきましたか？

解答

defclass(CLOS)でフォローできるdefstructの機能というところでは、漏れなく言及されたと思うのですが…。見た感じでは、defstructはもう少し多機能なようです。

問題.2

構造体を使っているアプリケーションを取ってきて、defclass を使って書き直しなさい。

解答

ぱっと思い付いたのが、ポール・グレアム氏のANSI Common Lispの二重リンクリスト(日本語版P183辺り)だったので、それをお題に書き直してみることにしました。

• Source Files Of _Ansi Common Lisp_

(defclass thread ()
  ((prev :initarg :prev :accessor THREAD-uncdr :initform nil)
   (data :initarg :data :accessor THREAD-car :initform nil)
   (next :initarg :next :accessor THREAD-cdr :initarg nil)))

;; なんとなくthreadpを追加
(declaim (inline threadp))
(defun threadp (obj)
  (typep obj 'thread))

(defun thread->list (lst)
  (if (threadp lst)
      (cons (thread-car lst) (thread->list (thread-cdr lst)))
      lst))

(defun thread-insert (x lst)
  (let ((elt (make-instance 'thread :data x :next lst)))
    (when (threadp lst)
      (if (thread-uncdr lst)
          (setf (thread-cdr (thread-uncdr lst)) elt
                (thread-uncdr elt) (thread-uncdr lst)))
      (setf (thread-uncdr lst) elt))
    elt))

(defun thread-cons (&rest args)
  (reduce #'thread-insert args
          :from-end t :initial-value nil))

(defun thread-remove (lst)
  (if (thread-uncdr lst)
      (setf (thread-cdr (thread-uncdr lst)) (thread-cdr lst)))
  (if (thread-cdr lst)
      (setf (thread-uncdr (thread-cdr lst)) (thread-uncdr lst)))
  (thread-cdr lst))

たまたま眺めていたMaclispのソースに二重リンクリストのコードがあって、二重リンクリストのことをスレッドと呼んで、car、cdr、uncdr(その名の通り逆のcdr)としていたので、そういう名前にしてみました。…名前はそのままにしておいた方が良かったような…。結果としては殆ど元のコードそのままで、defstructからの変更は殆どなし。

;; 動作
(setq th (thread-cons 'x 'y 'z))

(thread-car th)
;=> x
(thread->list (thread-cdr th))

;=>(Y Z)

;(thread->list th)

;=> (X Y Z)

(thread->list (thread-remove th))
;=> (Y Z)

defstructと違ってprint-functionの指定ができないようなので、結果を一々thread->listしないと見辛いですが、同じように動作しています。

問題.3

今使っている処理系で、nil のクラス継承階層（ class-precedence-list）を調べなさい。

解答

とりあえず、手元の処理系で、

(let ((cpl #+sbcl 'sb-mop:class-precedence-list
	   #+allegro 'mop:class-precedence-list
	   #+lispworks 'class-precedence-list
	   #+clisp 'clos:class-precedence-list))
  (funcall cpl (find-class nil)))

(mapc #'print (sb-mop:class-precedence-list (find-class nil)))

を試してみましたが、全部エラーで、NILってクラスはないよ、ということでした。

;; SBCL
;; => error There is no class named NIL.

;lisp works 
;; => There is no class named NIL.

;; Allegro
;; => Error: No class named: NIL.

;; CLISP
;; => *** - FIND-CLASS: NIL does not name a class

ツイートする

CLOSチュートリアル (2)

学びましょう | 20:45 |

Common Lisp クックブックさんのところのCLOSのチュートリアルで新しい練習問題を見付けたので挑戦!。

問題

CLOSチュートリアル 3.5. スロットより

• defstruct マクロの実装を探し、CLOSのスロットオプションを一つ以上追加しなさい。

解答

SBCLのマクロを追い掛けてみましたが、どうも既存のマクロに追加するというのはちょっと難しそうなので、defstructをラッピングするdefstruct-plusというマクロを定義してみることにしました。

追加したスロットは、一番簡単そうなところで、:accessorと、:readerの2つです。

(defmacro defstruct-plus (name-and-options &rest slot-descriptions)
  (let ((name (carat name-and-options)))
    `(prog1
	 (defstruct ,name-and-options
	   ,@(mapcar (lambda (x) 
		       (cond ((member :accessor x) (remove-accessor-def x))
			     ((member :reader x) (repl-reader-def x))
			     ('T x)))
		     slot-descriptions))
       ,@(mapcar (lambda (x) 
		   (multiple-value-bind (accessor slot-name reader-p) 
		       (get-accessor-or-reader-name x)
		     (let ((acc-name (symbol-name-conc name "-" slot-name)))
		       (when accessor
			 (if reader-p
			     `(defun ,accessor (obj)
				(,acc-name obj))
			     `(progn
				(defun ,accessor (obj)
				  (,acc-name obj))
				(define-setf-expander ,accessor (obj)
				  (get-setf-expansion 
				 `(,',acc-name ,obj)))))))))
		   slot-descriptions))))

;; defstructには不要な、:accessor引数を除いた引数を返す
(defun remove-accessor-def (args)
  (do ((a args (cdr a)) 
       res)
      ((endp a) (nreverse res))
    (if (eq :accessor (car a))
	(return (nreconc res (cddr a)))
	(push (car a) res))))

;; defstructの形式に合わせて:reader引数を:read-only tに変換する
(defun repl-reader-def (args)
  (do ((a args (cdr a)) 
       res)
      ((endp a) (nreverse res))
    (if (eq :reader (car a))
	(return (nreconc res `(:read-only 'T ,@(cddr a))))
	(push (car a) res))))

;; 関数の名前を付けるための補助関数
(defun symbol-name-conc (&rest names)
  (values
   (intern 
    (string-upcase 
     (apply #'concatenate 'string (mapcar #'string names))))))

(defun carat (obj)
  (if (consp obj) (car obj) obj))

;; :readerか:accessorの場合に与えられた値を返す。
;;  2値目は、スロットの名前
;;  :readerの場合、3値目でtを返す。
(defun get-accessor-or-reader-name (args)
  (let (reader-p)
    (values (or (cadr (member :accessor args))
		(let ((tem (cadr (member :reader args))))
		  (when tem
		    (setq reader-p t)
		    tem)))
	    (car args)
	    reader-p)))

適当に建増しを繰り返していたらどうにも収集がついてない長ったらしいものになってしまいました。

(defstruct-plus foo
  (x 10 :accessor access-foo-x)
  (y 20 :reader reader-foo-y-ro))

が

(PROG1 (DEFSTRUCT FOO (X 10) (Y 20 :READ-ONLY 'T))
  (PROGN
   (DEFUN ACCESS-FOO-X (OBJ) (FOO-X OBJ))
   (DEFINE-SETF-EXPANDER ACCESS-FOO-X (OBJ)
     (GET-SETF-EXPANSION `(FOO-X ,OBJ))))
  (DEFUN READER-FOO-Y-RO (OBJ) (FOO-Y OBJ)))

のように展開され、普通のdefstructの定義に加えてaccessorかreaderで指定した名前の関数をエイリアスとして作っているような感じです。

ツイートする

Luaのgeneric forの真似

つくりましょう | 12:57 |

[Think IT] 第2回：言語開発者が目標にするパフォーマンス「Lua」 (1/3)の記事で、Luaのgeneric forという機構では、ループに関数を返す関数を取ることができて(これをLuaではイテレータというとのこと)非常に柔軟であるらしい、というところを見て、何か凄く便利っぽい!と思ったので真似して作ってみることにしました。

とりあえず、ここで例として取り上げられている、uptoは、

(defun upto (max)
  (let ((count 0))
    (lambda ()
      (if (< count max)
	  (incf count)
	  (values nil t)))))

のように書けるかと思います。

空になったらnilを返して終了というのでも良いと思うんですが、それだと単体のnilを返した時も終了となってしまうので、空になったら多値を返し、2値目でnil以外の値を返してみることにしました。

それで、これを呼び出すループの機構を考えるわけですが、doが好みなので、

(dog ((l (cdrdown '(foo bar baz zot)))
      (i (upto 10)))
  (print (list (car l) i)))

;=>
;  (FOO 1) 
;  (BAR 2) 
;  (BAZ 3) 
;  (ZOT 4) 

のように決めて、適当にマクロででっち上げました。

(defmacro dog ((&rest binds) &body body)
  (let ((vars (mapcar #'car binds))
	(vals (mapcar #'cadr binds))
	(iters (mapcar (lambda (x) (declare (ignore x)) (gensym "ITER-")) binds))
	(endp (gensym "ENDP-"))
	(end (gensym))
	(val (gensym)))
    `(let ,(mapcar #'list iters vals)
       (let (,endp)
	 (do ,(mapcar (lambda (v i)
			`(,v
			  (multiple-value-bind (,val ,end) (funcall ,i)
			    (unless ,endp (setq ,endp ,end))
			    ,val)
			  (multiple-value-bind (,val ,end) (funcall ,i)
			    (unless ,endp (setq ,endp ,end))
			    ,val)))
		      vars iters)
	     (,endp)
	   ,@body)))))

終了判定の多値の受けとりで上手い書き方が思い付かず、存外ぐちゃぐちゃになりました。

それで、どっちかというと肝は関数を返す関数を工夫して書けば応用が広がるところだと思うんですが、

; (1 2 3)

; (2 3)

; (3)

のような事をする関数を返す関数は、

(defun cdrdown (list)
  (let ((l list))
    (lambda () 
      (if l
	  (prog1 l (pop l))
	  (values nil t)))))

; (1 2 3 4)

; 1

; 2

; 3

; 4

; nil,t

と順番に値を返す関数を返す関数は

(defun next-item (list)
  (let ((l list))
    (lambda () 
      (if l
	  (prog1 (car l) (pop l))
	  (values nil t)))))

という風に簡潔にどんどん拡張できそうです。

と、色々考えてみて思ったのですが、関数を返す関数を取るループではないものの、これはSERIESの使い勝手と非常に近いということで、SERIESだと

(iterate ((l (scan-sublists '(foo bar baz zot)))
	  (i (scan-range :from 1)))
  (print (list (car l) i)))

という風に書けると思います。

SERIESのscan系の関数を自分でどんどん拡張して書けば、同じく柔軟に使えそうです。

ツイートする

CLOSチュートリアル (1)

学びましょう | 15:37 |

自分は、多少Lispでのリスト操作はできるようになった気はしますが、CLOSとなると全く訳が分かりません。

そもそもオブジェクト指向言語自体まともに触ったことが無いし、全く未知の領域で、Lispとオブジェクト指向がどう融合するのか見当もつきません。

しかし、CLOSは折角Common Lispに標準で付いてくるし、ちょっとは分かるようになれたら良いなと思っていた折、Common Lisp クックブックを訳されているid:cl-internさんのCommon Lisp クックブックで、CLOSの記事(

no title)の翻訳の開始を目にし、おおこれは素晴らしいと思っていたところ、丁度、練習問題が付いてくるようなので、良い機会なので練習問題に挑戦してみることにしました。

ということで早速挑戦。

CLOSチュートリアル 3.2. defclass マクロの練習問題より

1. with-slots を使って set-point-values を書き直しなさい。

;; 解答
(defun set-point-values (point x-pos y-pos z-pos)
  (with-slots (x y z) point
    (setf x x-pos
	  y y-pos
	  z z-pos)))

with-slotsを使うと名前の衝突を起してしまうので、x-pos等として衝突を回避してみましたが、他に回避方法はあるのでしょうか。

with-slotsはマクロなので、マクロを展開して眺めてみても回避はできないっぽいんですが…。

1. symbol-macrolet を使って with-slots を実装しなさい。symbol-macrolet の最初の引数は、次のペア (変数名 スロット名) のリストになります。

;; 解答
(defmacro my-with-slots ((&rest vars) instance &body body)
  (let ((inst (gensym "INST-")))
    `(let ((,inst ,instance))
       (declare (ignorable ,inst))
       (symbol-macrolet ,(mapcar (lambda (v) 
				   `(,v (slot-value ,inst ',v)))
				 vars)
	 ,@body))))

sbclのmacroexpandの結果から類推してマクロ作成。ちょっとズルかもしれない。

(my-with-slots (x y z) bar
  (list x y z))

が

(LET ((#:INST-2958 BAR))
  (DECLARE (IGNORABLE #:INST-2958))
  (SYMBOL-MACROLET ((X (SLOT-VALUE #:INST-2958 'X))
                    (Y (SLOT-VALUE #:INST-2958 'Y))
                    (Z (SLOT-VALUE #:INST-2958 'Z)))
    (LIST X Y Z)))

のように展開されます。

1. defclass に defstruct の機能を追加したマクロ defclass-plus を実装しなさい。新しいクラスを定義したときに、そのクラスのコンストラクタ関数、述語関数、アクセサ関数、コピー関数も自動的に定義するようにします。退屈かもしれませんが、納得できるまでやってみてください。

;; 解答

;; 本体
(defmacro defclass-plus (name direct-super-classes direct-slots &rest options)
  `(prog1
     (defclass ,name ,direct-super-classes 
        ,(mapcar (lambda (s) `(,s :initarg ,(intern (string s) :keyword))) 
	         direct-slots)
          ,@options)
     (constructer-maker ,name)
     (pred-maker ,name)
     (accessor-maker ,name ,@direct-slots)
     (copier-maker ,name ,@direct-slots)
     (setter-maker ,name ,@direct-slots)))

;; 関数の名前を付けるための補助関数
(defun symbol-name-conc (&rest names)
  (values
   (intern 
    (string-upcase 
     (apply #'concatenate 'string (mapcar #'string names))))))

;; コンストラクタ関数 make-～を作るマクロ
(defmacro constructer-maker (name)
  `(defun ,(symbol-name-conc "MAKE-" name) (&rest initargs)
     (apply #'make-instance ',name initargs)))

;; 述語関数 ～-pを作るマクロ
(defmacro pred-maker (name)
  `(defun ,(symbol-name-conc name "-P") (object)
     (eq ',name (type-of object))))

;; アクセサ関数を作るマクロ
(defmacro accessor-maker (name &rest slots)
  `(progn
     ,@(mapcar (lambda (s) 
		 `(defun ,(symbol-name-conc name "-" s) (object)
		    (slot-value object ',s)))
	       slots)))

;; コピー関数を作るマクロ
(defmacro copier-maker (name &rest slots)
  (let ((new (gensym)))
    `(defun ,(symbol-name-conc "COPY-" name) (object)
       (setf ,new (make-instance ',name))
       (mapc (lambda (s) (setf (slot-value ,new s) (slot-value object s)))
	     ',slots)
       ,new)))

;; (setf (accessor-x object) 30)のようなことができるようにするマクロ
(defmacro setter-maker (name &rest slots)
  `(progn
     ,@(mapcar (lambda (s) 
		 (let ((name (symbol-name-conc name "-" s)))
		   `(define-setf-expander ,name (obj)
		    (let ((tem (gensym)))
		      (values nil nil `(,tem)
			      `(setf (slot-value ,obj ',',s) ,tem)
			      `(,',name ,obj))))))
	       slots)))

defstructの説明がこの前の章にあって、その機能の説明を全部盛り込むと結構複雑になりました。

(make-foo :x 40)のように初期値を取るようにするには、defclassで、:initargを使う必要があるようなので、まだチュートリアルに説明は出てきませんが、:initargを使ってみました。

色々使ったことが無い関数やマクロを触ることになったのでかなり試行錯誤という感じです。

また、謎なところでは、マクロの中で、:xや、:yを作る方法が分からず、(intern (string s) :keyword)とかしています。

安直に、`(:,keyword)のような感じで展開できると思っていたんですが、できなかったためですが、こういう時、普通はどうするんでしょう。

ツイートする

祝Multics Emacsのソース公開

読みましょう | 04:56 |

• no title

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

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

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

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

• Multics Internet Server

ここのソースの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氏もエントリの中で言及しています。

• WordPress.com

このエントリは、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

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

ツイートする

LispMの関数こまごま

読みましょう | 16:33 |

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

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

• LMI Lambda (sys2ディレクトリ)
  • clmac.lisp
  • qfcntns.lisp
  • qrand.lisp

お題

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)

ツイートする

Lispm Font

試してみましょう | 05:17 |

ああ、毎日更新することが目標だったのに間があいてしまった!

とりあえず、小ネタでXで使えるLispマシン(以下、LispM)のフォントを紹介してみます。

とはいえ、こちらの配布サイトの解説の通りにすればすぐ使えます。

• M.I.T. "CADR LispMachine" main console font

LispMのフォントはもちろんこれだけではなくて他にも色々ありますが、これが標準で、CPTFONTという名前です。

個人的には、このフォントだと全部大文字で書かれたLispのコードでも読み易かったりするところが気に入っています。

また、Fontforgeで、無理矢理TrueTypeフォントに変換したりして使ってみてますが、それも乙です。

ツイートする

StumpWM (2)

試してみましょう, StumpWM | 23:46 |

StumpWMをインストールしてから一ヶ月位常用してみていますが、もとからWMに高機能を求めていないせいか別段不自由することもなく使えています。

この間に使ってみて分かった細々としたことを書いてみたいと思います。

WMの終了方法

前回WMの終了の方法さえ分からず、Lisp式を評価する方法で、(cl-user::quit)などとしていましたが、プレフィクスキー(EmacsのCtrl-xのようなもので、デフォルトでは、Ctrl-t)+;でコマンド入力のところで、quitを実行するらしいことが分かりました。

StumpWM内部のコマンドを定義する

下準備

定義するコマンドは、~/.stumpwmrcに記述するのが一般的かと思います。下記の例は、全部、~/.stumpwmrcに記述しています。

定義する

define-stumpwm-commandによって定義できます。emacsを実行するコマンドは下記のように定義できます。

(define-stumpwm-command "emacs" ()
  (run-or-raise "emacs-22.0.50" '(:class "Emacs")))

run-or-raiseは、ウィンドウを最前面に持ってくるか、実行されていない場合プロセスを実行します。

他にも色々方法はあるようです。

コマンドにショートカットキーを定義する

define-keyで定義します。下記の例では、通常のプレフィクスキー+C-eでStumpWM内で定義したコマンドemacsを実行するようにしています。

(define-key *root-map* (kbd "C-e") "emacs")

フォント

set-fontで指定可能です。UTF-8環境でフォントのエンコードをiso10646-1にすれば、日本語も化けないで表示されます。

(set-font "-kochi-gothic-medium-r-normal-*-*-110-*-*-p-*-iso10646-1")

便利なところ

最新のStumpWMには、内部のコマンドをシェルから実行できる、stumpishというシェルスクリプトが附属してきます。

これを使用するとウィンドウの切り替えを自動で実行できたりするので、例えば、emacsclient等と組み合わせると便利です。

#!/bin/sh

stumpish emacs #StumpWM内のコマンド
emacsclient $*
stumpish other #直前にフォーカスがあったウィンドウにフォーカス

exit 0

上記は、

1. stumpish emacsで、Emacsのウィンドウにフォーカスし、
2. emacsclientを実行し、
3. 終了したら、元のウィンドウにフォーカスを戻す

という内容です。

同じようにslimeからHyperSpecを呼び出すついでにfirefoxにフォーカスするようなものも便利です。

その他、小物

(define-stumpwm-command "init" ()
  (stumpwm::load-rc-file))

設定を変更して、初期化ファイルを読み込ませるのが面倒なので定義してみています。

困っていること

一番良く使うアプリケーションはfirefoxなのですが、どうやらEmacsや、他のアプリケーションのようにウィンドウに一定の名前が付かないせいか、run-or-raiseだと実行する度に新しいfirefoxのプロセスが実行されてしまいます。

その場しのぎの対策

firefoxのウィンドウには、ffという名前を付けて、プロセスが実行されているならウィンドウの切り替えだけ、プロセスが起動されていないならば、firefoxを起動という風にしてみています。firefoxのウィンドウへの名前づけは、WMが起動するたびに手動で行っているので、若干面倒なものがあります。

run-or-raiseは、WM内のWindowの名前を見て判断しているので、プロセスを見て判断するものを定義して使ってみています。

;; psを実行して、firefox-binの文字列をgrep
(defun get-firefox-ps (&optional (owner "g000001"))
  (let ((ps (with-output-to-string (out)
	      (sb-ext:run-program "/bin/ps" '("-ef")
				  :environment '("LANG=C")
				  :output out)))
	(scn (cl-ppcre:create-scanner (format nil "~A.*firefox-bin" owner))))
    (with-input-from-string (str ps)
      (series:iterate ((line (series:scan-stream str #'read-line)))
		      (when (cl-ppcre:scan scn line)
			(return-from get-firefox-ps line))))))

;; get-firefox-psを実行し、ffというウィンドウに切り換えるか、
;; run-or-raiseでfirefoxを起動。
(defun run-or-raise-firefox ()
  (if (get-firefox-ps)
      (select-window (current-group) "ff")
      (run-or-raise "firefox" '(:class "Firefox" :title "Firefox"))))

;; ffでfirefoxを実行するStumpWMのコマンド定義
(define-stumpwm-command "ff" ()
  (run-or-raise-firefox))

まとめ

まだまだ使い方も分っていないStumpWMですが、Common Lispで拡張できるというのはやはり面白くこれからも掘り下げてみたいと思っています。

ツイートする

asdf-addonsで楽をする

試してみましょう | 20:00 |

asdfやasdf-installはとても便利で、単一の実装を単一のOSで使う分には最高なんですが、素のasdfでは、faslファイルをasdfのソースのディレクトリに出力するので、そのディレクトリを異なるプラットホームで共有させようと思うとちょっと厄介だったりします。

Lispのソースファイルはアーキテクチャに依存しないので各種OS/lisp間で共有のNFSディレクトリ等に設置し、アーキテクチャに依存したfaslファイル等は、は別ディレクトリに格納したらもっと楽に共有できるのになあとずっと考えていましたが、common-lisp.netのプロジェクトをつらつらと眺めていたら、asdf-addons projectがまさにこの問題を解決するもののようだったので早速試してみることにしました。

設定

今のところ、asdf-addonsが提供しているものは、asdf-cacheというものだけのようです。これが、faslファイルの出力先を変更するという機能を実現します。

各ファイルの配置方針は、

• /share/sys/cl/src
  • asdfインストール可能なファイルも可能でないファイルもソースファイルはこの場所に置く
• /share/sys/cl/asdf
  • asdfのasdファイルを置く
• /share/sys/cl/fasls
  • 各アーキテクチャに依存したfaslファイルが格納される

という風に決めて、adsfや、adsf-installのパス設定等を変更してみます。

ちなみに、これが正しい方法かどうかは不明です…。

• asdf

asdf::*central-registry*にasdファイルが置かれたパスを設定するので、

(setq asdf::*central-registry* '(#p"/share/sys/cl/asdf/" その他～))

として上記のパスを一番最初に検索するようにします。

• asdf-install

asdf-install:*locations*がadsf-installでインストールする先を設定しているようなので、上記のパスをシステムグローバルなパスとして設定します。

(setq asdf-install:*locations* 
      '((#P"/share/sys/cl/src/" #P"/share/sys/cl/asdf/" "System-wide install")
	(#Pホームディレクトリ等～ "Personal installation"))

asdf-installの際にシステム全体か、ホームディレクトリかを訊かれますが、この変数を参照しているようです。

リスト内部の各項目がインストール先の場所で、

'((ソースの場所 asdファイルの場所 名前) ～繰り返し～)

の様になっていて、任意の数の場所を設定します。

• asdf-cache

(setq asdf-cache:*asdf-cache* #p"/share/sys/cl/")

これが、今回導入したasdf-addonsのasdff-cacheがfaslファイルを出力する場所になります。asdf-cache内部で、このディレクトリをベースディレクトリとして、.faslsというディレクトリを作成し、そこにさらにOSや処理系のバージョンごとに異なるディレクトリを作成しファイルを配置してくれます。デフォルトでは、.faslsですが、自分の環境では隠す必要もないので、ソースを変更してfaslsという名前で作るようにしました。

asdf-cacheのインストール

asdf-cacheのインストールは、直接ファイルを読み込ませて行ないます。

(load "/share/sys/cl/src/asdf-cache.lisp")

動作の確認

まず、自分のメインの処理系である、SBCL/Linuxで試してみました。

sbclは、asdfもasdf-installも完備しているので楽です。

(asdf-install:install :foo)

とすると、上記で設定したインストール先を訊かれ、設定した場所にソースファイルが展開され、asdディレクトリにリンクが張られます。

この後は、asdf-installは、asdfを呼び出してコンパイル等が始まりますがasdf-cacheの働きで、

/share/sys/cl/fasls/sbcl-linux-x86-1.0.10/share/sys/cl/src/foo

というようなディレクトリが作成され、その下にfaslファイルが出力されます。

そして、faslファイルの読み出しもasdf-cacheの働きで、指定したディレクトリより読み出すようになります。

adsf-cacheが便利なところ

共有している場合、どこか一つのマシンで、asdf-installすると、共有しているasdのディレクトリにもasdファイルがリンクされるため、他のマシンでも、

(asdf:oos 'asdf:load-op :foo)

とすれば、コンパイルとロードが完了するため、asdf-installは一回で済みます。これが案外便利です。

また、asdfに対応したソースならば、asdf::*central-registry*にリンクを張るだけでasdfで導入できますが、この場合ソースディレクトリにfaslファイルがばら蒔かれることもないので快適です。

今のところ、処理系は、SBCL、CLISP、CMUCL、Allegro 8.1試用版、Lispworks 5.0.1試用版、ECL、OSはLinux、MacOSXで試してみましたが、全部の環境を簡単に揃えることができるので結構お勧めです。

ツイートする

Series (3) / generatorとgatherer

試してみましょう, SERIES | 01:34 |

今回は、Seriesと同じく配布されていて、また同じくCLtL2の巻末にも関連して収録されている、ジェネレータとギャザラを試してみることにしました。

generator

ジェネレータは、シリーズの列を順番に取り出す機構のようです。

(generator シリーズ)

とすると、ジェネレータが生成されます。

生成された、ジェネレータは

(next-in ジェネレータ 空になったときのアクション)

で順番に取り出すことができ、空になると、指定したアクションを実行します。

(defun doとgeneratorをつかったfizzbuzz ()
  (do ((gen (generator (scan-range :from 1 :upto 100))))
      (())
    (let* ((i (next-in gen (return)))
	   (fizz (zerop (mod i 3)))
	   (buzz (zerop (mod i 5))))
      (print (cond ((and fizz buzz) "FizzBuzz")
		   (fizz "Fizz")
		   (buzz "Buzz")
		   ('T i))))))

無理矢理な感じですが、FizzBuzzを作ってみました。doは無限ループと変数束縛のために使っています。

gatherer

ギャザラはジェネレータの逆で、

(gatherer コレクタ) ;コレクタは、collect系の関数

結果を溜め込む機構であるギャザラを生成し、

(next-out ギャザラ)

で指定したギャザラに溜め込み、溜め込んだものは、

(result-of ギャザラ)

を呼ぶことで、結果として返せます。

(defun remq (item list &key (count -1))
  (let ((res (gatherer #'collect)))
    (iterate ((l (scan list)))
      (cond ((zerop count) (next-out res l))
	    ((eq item l) (decf count))
	    ('T (next-out res l))))
    (result-of res)))

(remq 'x '(x x x x x foo x) :count 2)
;=> (X X X FOO X) 

gathererを使ってeqで要素を比較するremoveを作ってみました。

gathering

gathererは出力が一つですが、gatheringは複数を切り換え出力できるところが違い、また、本体から抜けると自動で結果が返されます。

(gathering ((変数 コレクター) (変数 コレクター) ～) ～本体～)

(defvar hiyoko '(♂ ♀ ♂ ♀ ♂ ♀ ♂ ♀ ♂ ♀ ♂ ♂ ♀ ♂  ♂ ♀ ♂ ♀ ♀ ♂ ♀ ♀))

(gathering ((m collect) (f (lambda (x) (collect 'vector x))))
  (iterate ((i (scan hiyoko)))
    (case i
      (♂ (next-out m i))
      (♀ (next-out f i)))))
=>
(♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂ ♂), #(♀ ♀ ♀ ♀ ♀ ♀ ♀ ♀ ♀ ♀ ♀)

ひよこの選別をすると考えて、♂はリストで、♀はベクタの2値を返しています。

ツイートする

Series (2)

試してみましょう, SERIES | 22:48 |

今回もSeriesがどんなものなのか色々試してみています。

実際の利用事例をGoogle Codeを使って検索してみるのですが、利用例は見当らずで、見付かるものといえばSERIES自体のソースコード位です。

CLTL2では、map-fnを#M、seriesを#Zとリードマクロ文字で定義して表記してあります。

これは、表記としても使う上でも便利だなと思うのですが、自分で定義しないといけないんだと思ってコードを検索してみたら、SERIESのソース自体に定義がありました(*'-')

(series::install)

を実行することで使えるようになるらしいです。が、#Mが自分の手元だと上手く機能しません…。何が間違っているのだろうか…。

色々試してみる

自分の予想では、SERIESはSRFI-42に非常に近い使い勝手ではないだろうか思い、SRFI-42の使用例をSERIESに翻訳してみることにしました。ちなみに自分は、SRFI-42の使い方も良く分かっているわけではありません…。

とりあえずウェブで見付けてきた題材と翻訳を列記してみます。

doukaku.org:九九の表示よりdo-ecの例

;; doukaku 
(define (display99 n)
  (do-ec (: x 1 (+ n 1)) (: y 1 (+ n 1))
         (format #t "~d * ~d = ~2d~%" x y (* x y))))

;; SERIESで
(defun display99 (n)
  (iterate ((x (scan-range :from 1 :upto n)))
    (iterate ((y (scan-range :from 1 :upto n)))
      (format t "~D * ~D = ~2D~%" x y (* x y)))))

適当なマクロですが、

(defmacro iterate* (binds &body body)
  `,(reduce (lambda (b res)
	      `(iterate (,b) ,res))
	    binds
	    :initial-value `(progn ,@body)
	    :from-end 'T))

のようにすれば、

(defun display99 (n)
  (iterate* ((x (scan-range :from 1 :upto n)) 
             (y (scan-range :from 1 :upto n)))
    (format t "~D * ~D = ~2D~%" x y (* x y))))

と書けてより近いような気もしましたが、気休めな気もします。

上記を任意の数に拡張した版

(define (displayNN n)
  (let ((w0 (string-length (number->string n)))
        (w1 (string-length (number->string (* n n)))))
    (do-ec (: x 1 (+ n 1)) (: y 1 (+ n 1))
           (format #t "~vd * ~vd = ~vd~%" w0 x w0 y w1 (* x y)))))

;; SERIESで
(defun displayNN (n)
  (let ((w0 (length (princ-to-string n)))
	(w1 (length (princ-to-string (* n n)))))
    (iterate ((x (scan-range :from 1 :upto n)))
      (iterate ((y (scan-range :from 1 :upto n)))
	(format t "~VD * ~VD = ~VD~%" w0 x w0 y w1 (* x y))))))

doukaku.org:隣り合う二項の差よりlist-ecの例

(define (diff xs) (list-ec (:parallel (: x xs) (: y (cdr xs))) (- y x)))

;; SERIESで
(defun diff (xs) 
  (collect (mapping ((x (scan xs)) (y (scan (cdr xs)))) (- y x))))
;;
(diff '(2 1 4 3 6 5 7))
;-> (-1 3 -1 3 -1 2)

SRFI-42ではデフォルトで入れ子になり:parallelを指定することにより並列になるそうですが、SERIESはデフォルトが並列で、入れ子は手作りになります。

doukaku.org:ダブル完全数よりsum-ecの例

(define (double-complete-number? n)
  (= (* n 3)
     (sum-ec (: i 1 (+ 1 n))
             (if (zero? (remainder n i)))
             i)))

(do-ec (: i 1 10001)
       (if (double-complete-number? i) (print i)))

;; SERIESで
(defun double-complete-number-p (n)
  (= (* n 3)
     (collect-sum 
      (choose
       (mapping ((i (scan-range :from 1 :upto n)))
	 (when (zerop (rem n i)) i))))))

(iterate ((i (scan-range :from 1 :upto 10000)))
  (when (double-complete-number-p i)
    (print i)))

まとめ

というようにSRFI-42をSERIESに変換してみましたが、結構何の捻りもなしに素直に変換できるようです。関数/マクロの名前の付け方にも非常に共通点が多いというのも理由の一つかもしれません。

ツイートする

Series (1)

試してみましょう, SERIES | 20:39 |

CLTL2の巻末の付録にも載っていて非常に魅力的にも見えるseriesですが、全然使い方が分からないので、loopの解説と対照させつつ機能を散策してみることにしました。

下記のloopマクロを解説したサイトさんを参考にさせて頂きました。

• Common Lisp’s Loop Macro Examples for Beginners
• Common Lisp: loopマクロ用法抄: 微酔半壊

こちらの方々のloopの事例を拾ってSERIESに変換してみています。

元々使い方が分ってないので、妙なところもあるんじゃないかと思います。

下準備

SERIESはasdf-install可能です。

(asdf-install:install :series)

いろいろなケースをSERIESで処理してみる

(use-package "SERIES")

リスト

(loop for i from 10 to 50 by 5 collect i)
;==> (10 15 20 25 30 35 40 45 50)

;; SERIESで
(collect (scan-range :from 10 :upto 50 :by 5))

まず、SERIESの作法としては、scan～でシリーズと呼ばれる列を生成し、collect～や、mapping、iterateでシリーズを加工するという流れのようです。

上では、scan-rangeでシリーズを作成し、collectでシリーズのアイテムを集めてリストに変換しています。

(loop for x in '(1 2 3 4) by #'cddr collect x) 

;; SERIESで
(collect
    (choose (series t nil)
	    (scan '(1 2 3 4))))
;==> (1 3) ; 一つ飛ばし

一つ飛しというのが良く分からず、chooseで選択しています。

(series t nil)で、tとnilが無限に続いたシリーズを作成し、それと、(scan '(1 2 3 4))を重ね合せることによってtの部分だけ拾っています。

(loop for x on '(1 2 3) collect x) 
;==> ((1 2 3) (2 3) (3))

;; SERIESで
(collect (scan-sublists '(1 2 3)))

(loop for x on '(1 2 3 4 5) by #'cddr collect x)
;==> ((1 2 3 4 5) (3 4 5) (5))

;; SERIESで
(collect
  (choose (series t nil)
	  (scan-sublists '(1 2 3 4 5))))

ハッシュ

;; 下準備
(defvar ht (make-hash-table))
(setf (gethash 'foo ht) 1)
(setf (gethash 'bar ht) 2)

(loop for x being the hash-keys in ht collect x)
; ==> (BAR FOO)

;; SERIESで
(collect (scan-hash ht))

(loop for x being the hash-keys in ht using (hash-value y) collect (cons x y))
;==> ((BAR . 2) (FOO . 1))

;; SERIESで
(collect
  (mapping (((k v) (scan-hash ht)))
    (cons k v)))

scan-hashはキーと値の多値を返すので、それをmappingで拾っています。

分割代入

(loop :for (a b) in '((1 2) (3 4) (5 6) (8))
      :collecting (list a b 'foo))
;==> ((1 2 FOO) (3 4 FOO) (5 6 FOO) (8 NIL FOO)) 

;; SERIESで
(collect 
  (mapping ((x (scan '((1 2) (3 4) (5 6) (8)))))
    (destructuring-bind (a &optional b) x
      (list a b 'foo))))

分割代入の機構は存在するのかどうかが分からなかったので、mappingの内部でdestructuring-bindを使用しています。

要素ごとに処理

(loop for i in '(1 2 3) do (print i))
;1
;2
;3

;; SERIESで
(iterate ((x (scan '(1 2 3))))
  (print x))

mapppingとiterateは、mapcarとmapcのような関係です。ということで、副作用が目的なので、iterateを使っています。

(loop for i on '(1 2 3) do (print i))
;(1 2 3)
;(2 3)
;(3)

;; SERIESで
(iterate ((x (scan-sublists '(1 2 3))))
  (print x))

(loop for i across #(1 2 3) do (print i))
;1
;2
;3

;; SERIESで
(iterate ((i (scan #(1 2 3))))
  (print i))

リスト、ベクタ、ストリング等は普通にscanで処理できます。

数値の範囲を処理

(loop for i from 1.0 to 3.0 by 0.5 do (print i))
;==>1.0
;   1.5 
;   2.0 
;   2.5 
;   3.0 

;; SERIESで
(iterate ((i (scan-range :from 1 :upto 3 :by 0.5)))
  (print i))

(loop for i from 3 downto 1 do (print i))
;==>3
;   2
;   1

;; SERIESで
(iterate ((i (scan-range :from 3 :by -1 :above 0)))
  (print i))

;downtoもあるようなのですが、手元の環境では上手く動かなかったため、:byにマイナスの数値を指定しています。

(loop for i from 3.0 downto 1.0 by 0.5 do (print i))
;==>3.0 
;   2.5 
;   2.0 
;   1.5 
;   1.0 

;; SERIESで
(iterate ((i (scan-range :from 3 :by -0.5 :above 0.5)))
  (print i))

> (loop for i from 1 to 3 for x = (* i i) do (print x))
;==>1
;   4
;   9

;; SERIESで
(iterate ((i (scan-range :from 1 :upto 3)))
  (let ((x (* i i)))
    (print x)))

iterateのボディで普通に計算してみています。seriesを加工するという手もあるのかもしれません。

フィルタリング

(loop for i from 1 to 3 when (oddp i) collect i)
;==> (1 3)

;; SERIESで
(collect
  (choose 
   (mapping ((i (scan-range :from 1 :upto 3)))
     (when (oddp i)
       i))))

• scan-rangeで1～3のシリーズを作成
• mappingは節の最後に評価された値を集める(#Z(1 nil 3)のようになる。)
• chooseでシリーズからnilのアイテムを捨てる
• collectでリストに変換

もっと短く書く方法があるに違いないですが、とりあえず…。

まとめ

以上、まだまだシリーズの一部なのですが、独自の作法はあるもののseriesは、なかなか便利な気がします。

Common Lispの標準に取り込まれることも検討されていたらしいですが、もし取り込まれていたらまた面白い展開があったような気がします。さらに巨大化しちゃいますが…。

今後もまたシリーズで処理できる例題を探して変換してみたいと思います。

ツイートする

Common Idioms (3)

読みましょう | 15:09 |

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

ツイートする