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


SRFI-61 CONDの拡張

| 18:25 | SRFI-61 CONDの拡張 - わだばLisperになる を含むブックマーク はてなブックマーク - SRFI-61 CONDの拡張 - わだばLisperになる

またもや、「Gaucheクックブック」を読んでいて、cond拡張が便利だなと思ったので、前に自分で作りかけていてやめたcond拡張を再作成してみることにしました。

HTTPヘッダフィールド名をきれいに整形する:

http://d.hatena.ne.jp/rui314/20070924/p1

作ってみている過程でどうでも良いような良くないような、次のような素朴な疑問が何点か浮んできました。

  1. condのT節(else節)がない場合の返り値はどうなるんだろう。
  2. 条件節の結果が多値を返した場合、どうなるんだろう。

まず、1ですが、事の発端は、Gaucheで動作を確認してる最中に

(define (superreverse lst)
  (if (null? lst)
      '()
      (append (superreverse (cdr lst)) 
	      (list (cond ((car lst) pair? => superreverse))))))

(superreverse '(foo bar (foo f)))
 ((#<undef> #<undef>) #<undef> #<undef>)

という風になったので、「あれ、なんでなのかしら?」と思ったわけです。

(define (superreverse lst)
  (if (null? lst)
      '()
      (append (superreverse (cdr lst)) 
	      (list (cond ((car lst) pair? => superreverse)
			  (else (car lst)))))))

なら意図した通りに動きます。

それで定義ですが、R5RSで確認してみたら、else節がない場合で抜けた場合は、未定義ということでした。たまたまですが、Schemeが世に現われた最初の論文*1でも、それらしきことが書いてあるのを今日見付けました。なんらかの美学というか確固とした理由があるんだと思いますが、なんでなんでしょう。CLTL2にもcondのスタイル問題について書いてありますが、GLSの愛なんでしょうか。

それで2ですが、R5RSの定義では、「1引数を取る式でなければならない」とあるので、引数は一つのようです。ということは、多値は取らないのかー、と思って、SRFI-61を読んでみたら、多値の処理もできるようにするのも目的だった様子。そうなのか、ガードが取れるようにした拡張だけじゃなかったのかー、と思って試してみたら、

(cond ((values 1 2) => values)  
→1      

(cond ((values 1 2) values => values)
→1,2

(cond ((values 1 2) (lambda val (even? (length val))) => values))
 1 2

(cond ((values 1 2 3) (lambda val (even? (length val))) => values)
      (else 'foo))
 foo

でした。なるほど。

ということで、自分なりにグチャグチャと作ってみました。

(defmacro cond-61 (&body forms)
  (if (every #'null (mapcar (lambda (form) (member '=> form :test #'eq)) forms))
      `(cl:cond ,@forms)		;Basic
      (let (retforms gss)
	(dolist (f forms `(let ,gss (cond ,@(nreverse retforms))))
	  (if (member '=> f :test #'eq)
	      (cl:cond ((and (eq '=> (third f)) (= 4 (list-length f))) ;SRFI-61
			(destructuring-bind (generator guard => receiver) f
			  (declare (ignore =>))
			  (let ((gs (gensym)))
			    (push `((multiple-value-call 
					,guard (values-list 
						(setq ,gs (multiple-value-list 
							   ,generator))))
				    (multiple-value-call ,receiver (values-list ,gs)))
				  retforms)
			    (push `((values-list ,gs)) retforms) ;fall thru
			    (push gs gss))))
		       ((and (eq '=> (second f)) (= 3 (list-length f)))	; R5RS
			(destructuring-bind (generator => receiver) f
			  (declare (ignore =>))
			  (let ((gs (gensym)))
			    (push `((setq ,gs ,generator) (funcall ,receiver ,gs)) retforms))))
		       ('T (error "srfi:COND: bad clause in cond?: ~S" f)))
	      (push f retforms))))))

...
(cond-61 ((values 1 2) => #'values))1      

(cond-61 ((values 1 2) #'values => #'values))1,2

(cond-61 ((values 1 2) (lambda (&rest val) (evenp (length val))) => #'values))1 2

(cond-61 ((values 1 2 3) (lambda (&rest val) (evenp (length val))) => #'values)
	 ('T 'foo))
→ foo

Common Lispなのでelse節がない場合は上から値が落ちてくる値が返ることにしました。ということで、

(defun superreverse (lst)
  (and lst
       (append (superreverse (cdr lst)) 
	       (list (cond-61 ((car lst) #'consp => #'superreverse))))))

(superreverse '(foo bar baz (1 2 3)))((3 2 1) BAZ BAR FOO)

はありにしました。

*1:SCHEME: an interpreter for extended lambda calculus, AI Memo No. 349

2007-09-26

.6

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

今回は、またMaclispのファイルで、UMLMAC.LSPというファイルのdolistを観察/再現してみました。

1981年より前のファイルのようです。

お題:

(defmacro DOLIST ((var form index) &rest body &aux dummy decls)
   (setq decls (cond ((and body 
			   (not (atom (car body)))
			   (eq (caar body) 'DECLARE))
		      (prog2 () (cdar body) (pop body)))))
   (cond (index (push `(FIXNUM ,INDEX) decls)
		(setq index (ncons `(,INDEX 0 (1+ ,INDEX)) ))))
   (and decls (setq decls  (ncons `(DECLARE ,.decls))))
   (si:gen-local-var dummy)
   `(DO ((,DUMMY ,FORM (CDR ,DUMMY)) (,VAR) ,.index )
	((NULL ,DUMMY))
      ,@decls
      (SETQ ,VAR (CAR ,DUMMY))  ,.BODY))

再現:

(defmacro my-old-dolist ((var list &optional index) &body body &aux decls dummy) ;indexの扱いが良く分からない。
  (setq decls (cond ((and (consp (car body)) ;ちょっと違うけど同じことだと思う。
			  (eq (caar body) 'declare)
			  (prog2 () (cdar body) (pop body))))))
  (cond (index (push `(fixnum ,index) decls)
	       (setq index `((,index 0 (1+ ,index)))))) ;`(())と二重にするんじゃなくてncons使ってました。
  (push 'declare decls)			;indexがnilの場合の対策漏れ。(declare)というものが出来てしまう。-> (and decls (push 'declare decls))
  (setq dummy (gensym))
  `(do ((,dummy ,list (cdr ,dummy))
	(,var)				;抜けてました。
	,@index)			;,.使ってました。
       ((null ,dummy))
     ,decls
     (setq ,var (car ,dummy))
     ,@body))				;,.使ってました。

間違ったところ:

  1. varをdo内部で宣言するのを抜かしてしまった。
  2. declareされなかった場合の処理を抜かしてしまった。

考察:

  • 現行のCommon Lispのdolistでは、変数束縛のところの3つ目は、結果を返すところになってますが、これは、インデックスの変数を指定する場所になってます。
(my-dolist (i '(foo bar baz) idx)
  (format t "~A: ~A~%" idx i))
=> 
0: FOO
1: BAR
2: BAZ

これはこれで使えそうな気がします。

  • 返り値は、nil
  • (prog2 () 返したい処理 ~)
    • これはこの当時のイディオムの様で、今ならprog1を使うところだと思います。prog1より先にprog2が存在していた理由は謎です。
  • si:gen-local-var
    • これは、gentemp+適用した変数をローカル扱い?にするもののようですが詳細は謎です。gensymに置き換えて再現で良いんだとは思います。
  • ncons
(defun ncons (x)
  (cons x () ))

のような関数のようです。`( (foo))とは書かずに、(ncons `(foo))と書いています。

  • &optionalでなくても引数を省略できている様子

Tops-20のMaclispで動作を確認しましたが、index引数は省略できてました。詳細は謎です。

  • ,.(コンマドット)
    • Maclispでも、Common Lispのように,.と,@の違いは、nconcを使うか、appendを使うかの違いなのか不明ですが、使い分けしてるようなので、多分、Common Lispと同じのようです。

その他

  • マクロの展開される本体の部分は、大文字で書く」派
  • 「関数/マクロ名は大文字にする」派

Lisp Tutorial

| 15:27 | Lisp Tutorial - わだばLisperになる を含むブックマーク はてなブックマーク - Lisp Tutorial - わだばLisperになる

Practical Common Lisp著者である、Peter Seibel氏が自身のブログで呼びかけるところによれば、Googleの検索キーワード「lisp tutorial」で、Practical Common Lispのページが上位に表示されるようになりたいんだそうで、リンクしてくれよのお願いをしているようです。

自分は、Practical Common Lispはまだ読んでないのでアレですが、何となく参加してみます。

(一週間前は、結構下だったんですが、確認してみたら、もう既に大分上位になってきたようです。)

Lisp tutorial

Bomb me--please!:

http://www.gigamonkeys.com/blog/2007/09/19/bomb-me.html

L-99 (63)

| 02:58 | L-99 (63) - わだばLisperになる を含むブックマーク はてなブックマーク - L-99 (63) - わだばLisperになる

L-99 P63に挑戦 - L-99:Ninety-Nine Lisp Problems

今回は、木の各ノードに番号を振ってゆくというお題。

左のノードを優先して埋めて行き、かつノードの番号付

けは、

         1
   2           3
 4    5     6     7
8 9 10 11 12 13 14 15

のようになるようなので、そういう風に作ったつもりで

ございます。

残りの問題:'(66 80-94 96-99) 解答状況 65/84

P63

回答
;;; ---------------------------------------------------------------------------
;;; common lisp
;;; ---------------------------------------------------------------------------
(load "max-nodes")

(defun complete-binary-tree (n &optional (base 1))
  (if (zerop n)
      ()
      (let ((cn-max-size (max-nodes (1- (cbt-height n))))
	    (gcn-max-size (max-nodes (- (cbt-height n) 2)))
	    (cn (1- n)))
	(cond ((= cn (* 2 cn-max-size))
	       `(,base ,(complete-binary-tree cn-max-size (* 2 base))
		       ,(complete-binary-tree cn-max-size (1+ (* 2 base)))))
	      ((> cn cn-max-size)
	       `(,base ,(complete-binary-tree cn-max-size (* 2 base))
		       ,(complete-binary-tree (- cn cn-max-size) (1+ (* 2 base)))))
	      ((<= cn cn-max-size)
	       `(,base ,(complete-binary-tree (- cn gcn-max-size) (* 2 base))
		       ,(complete-binary-tree gcn-max-size (1+ (* 2 base)))))))))

(defun cbt-height (n)
  (if (zerop n) n (1+ (truncate (log n 2)))))

2007-09-22


.9

| 15:00 | .9 - わだばLisperになる を含むブックマーク はてなブックマーク - .9 - わだばLisperになる

Maclispのファイルを読んでいて、面白くて理解しやすいファイルがあったので、内容を再現して遊んでみました。

ファイルは、Maclispの「CARCDR.LSP」です。

ファイル名が示すようにこれは、carやcdrのマクロを作成の為のユーティリティのようです。今回は、お題とエラーメッセージだけ頂戴して内容は自分で適当に作りました。

;; def-carcdr

(defmacro def-carcdr (&body exprs)
  `(progn
     ,@(mapcar (lambda (ex)
		 (multiple-value-bind (body name)
		     (compose-CarCdr-expr ex 'lst)
		   `(defun ,name (lst) ,body)))
	       exprs)))

(defun decompose-carcdr-expr (expr)
  (let ((char-lst (map 'list (lambda (x) 
			       (intern (string x)))
		       (string-upcase (string expr)))))
    (or (and (< 7 (length char-lst))
	     (eq 'c (car char-lst)) 
	     (pop char-lst)
	     (eq 'r (car (setq char-lst (nreverse char-lst))))
	     (pop char-lst)
	     (null (remove-if (lambda (x) (or (eq 'a x) (eq 'd x)))
			      char-lst)))
	(error "Invalid name for decompose-CarCdr-expr."))
    (nreverse char-lst)))

(defun compose-carcdr-expr (expr body)
  (values 
   (reduce (lambda (x res)
	     `(,(if (eq 'a x) 'car 'cdr)
		,res))
	   (decompose-CarCdr-expr expr)
	   :initial-value body
	   :from-end 'T)
   expr))
  • 使い方

def-carcdrに定義したいパターンを指定するだけです。複数を一度に定義できます。シンボルのクウォートも必要ありません。

 (def-carcdr
     cadddddaaadadadadaaadaddddaaadddaaddaaadaaddaaddaaddadaadr
     caaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaar)

(caaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaar 
 '(((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((hello!))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
=> hello!

見ての通り、あまり使いどころはなさそうです。

  • おまけ

Maclispのファイルを読んでいると、関数名に|foo-bar-baz/||や、foo-bar/|という最後に「|」を付けた名前をちらほら見かけます。(/は、Maclispのエスケープ文字なので、Common Lispだと、foo-bar-bar\|に相当)最初これは一体何なんだろうと思っていましたが、この名前を持つ関数は大概、内部的な補助関数のことが多いので、外部から呼ばれることを意図していない関数にこういう名前を付けているようです。%foo-bar-bazというように先頭に%を付けるというのは今の主流かと思いますが、探せば亜流は他にも色々あるのかもしれません。

2007-09-19


.8

| 04:53 | .8 - わだばLisperになる を含むブックマーク はてなブックマーク - .8 - わだばLisperになる

今日もSAILの昔のLispのアーカイブを探索してみていたところ怪しげなMaclispのコード群が結構ありました。

変ったletのフォーム、パターンマッチでマクロを定義するらしいmatch-macroというマクロ、その他色々…。

公開されているMITのMaclispのファイルでこんなに変ったものは目にしたことはなかったので、ちょっとびっくりしました。

今回は、その中の変ったletのフォームをマクロで再現して遊んでみました。

MATCH.118 (1981-05-27 00:41) (Maclisp)

http://www.saildart.org/prog/LSP/AID_LSP/.html/000130?129,5760

作者の詳細は不明ですが、このファイルが置かれているディレクトリにはrpgという署名が沢山あり、スタイルも統一されたものがあるのでrpg氏か、その一派だと思います。

それでrpg氏とは恐らく「デザインの「悪い方がよい」原則」で有名な、Richard Gabriel氏ではないかと思います。

  • 変った形式のlet

これのファイルを見て最初に思ったのは、LispUser.netさんのところで紹介されていた矢印付きletでした。

http://lispuser.net/memo/lisp/2007-01-28-01-54.html

殆どそのままなのですが、違いといえば、矢印が「<-」ではなく、そのまま矢印の文字を使っているところ(SAILではASCII以外の拡張文字が結構普通に使われていました)と、バインド部とボディ部を分けるキーワードが「do」だということと、「then」というキーワードが使えてthen以降は、先に定義した変数が使えます。このletを定義したソースが見付からないので何ともいえないのですが、thenが複数回使えるとすれば、letとlet*の組み合わせも一つの記述で実現できる方法だと思います。

  • 再現

基本的にリスト操作でごちゃごちゃ作りました。パッケージ名は適当です。

パッケージ名SRFIは、自分がSRFIを見て作った自分用のユーティリティ群です。srfi-breakだけ名前の衝突が面倒なのでを変えてます。

SRFI-1がそのままあれば良いのになーとかいつも思っているのですが、リスト操作系のCLのユーティリティ群で決定版ってのはあるんでしょうか。

(defpackage rpg
  (:use :cl)
  (:export let.))

(in-package :rpg)

(defmacro let. (&body form)
  (destructuring-bind (binds body)
      (separate 'do form :test #'eq)
    (let ((blist (separate 'then binds :test #'eq)))
      (reduce 
       (lambda (xx res)
	 `(let ,(do ((b xx (cdddr b))
		     res)
		    ((endp b) (nreverse res))
		    (let ((spec (srfi:take b 3)))
		      (or (eq (cadr spec) ')
			  (error "LET.: Bad bind."))
		      (push `(,(car spec) ,(caddr spec)) res)))
	    ,res))
       blist
       :initial-value `(progn ,@body)
       :from-end 'T) )))

;; 補助関数 (1 2 3 x 4 5 x 6 7 8) -> ((1 2 3)(4 5) (6 7 8))
(defun separate (item list &optional &key (test #'eql))
  (labels ((frob (item list acc)
	     (if (endp list)
		 (nreverse acc)
		 (multiple-value-bind (top rest)
		     (srfi:srfi-break (lambda (x) (funcall test item x)) list)
		   (frob item (cdr rest) (cons top acc))))))
    (frob item list () )))
(let. a ← 1 then
      b ← (+ a 2) then
      c ← 3 
      d ← 4 then
      e ← () do
      (list a b c d) 
      (reverse (list a b c d)))

が、

(LET ((A 1))
  (LET ((B (+ A 2)))
    (LET ((C 3) (D 4))
      (LET ((E NIL))
        (PROGN (LIST A B C D) (REVERSE (LIST A B C D)))))))

のように展開されます。

2007-09-18


.5

| 00:42 | .5 - わだばLisperになる を含むブックマーク はてなブックマーク - .5 - わだばLisperになる

今回は、SAILのアーカイブサイトにあるコードを読んでみました。

タイムスタンプは、1978-09-20 14:41のファイルなので、約30年前の恐らくMaclispのコードです。

関数名は、pruneです。

CSGREC.LSP [206,LSP]:

http://www.saildart.org/prog/LSP/206_LSP/.html/000088?87,5120

お題:

(defun prune (u)
 (prog (v v1)
    (setq v (cons NIL u))
    (setq v1 v)
   ploop
    (cond ((null (cdr v)) (return (cdr v1))) )
    (cond ((member (cadr v) seen) (rplacd v (cddr v))(go ploop)) )
    (setq v (cdr v))
    (setq seen (cons (car v) seen))
    (go ploop) ))

初見時の感想:

  • なんで、(cons nil u)してるんだろうか?
  • リストの破壊的操作らしい。
  • 重複したアイテムを取り除く関数だと思う。
  • 「condや、関数の終わりの括弧はスペースを一つ入れて分かりやすくする」派
  • NILだけ大文字で書いている意味が分からない
  • なんでリストなのに変数名はuなのか
  • progでseenが宣言されていない

再現:(失敗)

(defun prune (u)
  (prog (v v1 seen)
        (setq v (cons NIL u))
	(setq v1 v)
	ploop
	(cond ((null (cdr v)) (return (cdr v1))) )
	(cond ((member (cadr v) seen) (rplacd v (cddr v)) (go ploop)) )
	(setq seen (cons (cadr v) seen))
	(setq v (cons NIL (cddr v)))	;?????
	(go ploop) ))

途中で、リストの更新をどうやってるのか分からなくなってしまいました。

考察:

自分なりにお題を考察してみました。

  • (con NIL u)している理由
    • rplacdが使いたいからだと思う
  • 構造
    1. seenに既出のアイテムを溜め込んで、
    2. memberで既出かどうかを比較し、
    3. 既出の場合は、rplacdでアイテムをとばして結合してしまう。

以上を踏まえてdoで書き直してみました。

ついでにcopy-listも使ってdelete系からremove系にしてみました。

(defun prune (u &optional (test #'equal))
  (do* ((v (cons () (copy-list u)))
	(v1 v)                  ;ポインタを代入(的な操作)
	(seen () (cons (car v) seen)))
       ((endp (cdr v)) (cdr v1)) ;v1のcdrが指すオブジェクトを返す
    (if (member (cadr v) seen :test test)
	(setf (cdr v) (cddr v))
	(setq v (cdr v)))))

2007-09-17

.7

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

今日は、Gaucheクックブックの「#?=を使ったデバグ」というのがなんとなく便利そうでだったので、自分なりに真似して作ってみました。

Gaucheクックブック/「#?=を使ったデバグ」

http://d.hatena.ne.jp/rui314/20070628/p1

(defmacro debug-print (obj &optional name (stream t))
  `(let ((hr "** ----------------------------------------")
	 (name (if ,name ,name 0)))
     (format ,stream "~A~%** Debug: #~A | ~A => ~A | ~S~%~0@*~A~%" 
	     hr name ',obj ,obj (type-of ,obj))
     ,obj))

(defun gauche-debug-print ()
  (when (get-dispatch-macro-character #\# #\?)
    (or (yes-or-no-p "#?は既に使用されています。上書きしますか?") 
	(return-from gauche-debug-print)))
  (set-dispatch-macro-character #\# #\?
   (lambda (stream char arg)
     (declare (ignore char))
     (if (char= #\= (peek-char t stream))
	 (read-char stream))
     (list 'debug-print (read stream t nil t) arg t))))
(gauche-debug-print)

を評価すると、#?=が使えるようになります。

(let ((foo '(1 2 3 4 5))
      (bar "qwerasdfzxcv"))
  (nreconc foo (map 'list (lambda (x) #1068?=x)
		    #?=bar)))

のように使用し、


** ----------------------------------------
** Debug: #0 | BAR => qwerasdfzxcv | (SIMPLE-ARRAY CHARACTER (12))
** ----------------------------------------
** ----------------------------------------
** Debug: #1068 | X => q | STANDARD-CHAR
** ----------------------------------------
** ----------------------------------------
** Debug: #1068 | X => w | STANDARD-CHAR
** ----------------------------------------
   ~~~~~~ ~~~

のような結果を出力します。

ディスパッチングマクロ文字は10進数の引数が取れるようなのですが、捨てるのも勿体ないので使ってみました。

引数が無ければ、番号は0になります。

そして番号付けが面倒臭いので、emacsで現在のポイントの位置を挿入してみることにしました。

;; emacs lisp
(defun insert-gauche-debug-print-dispatch-char (insert-point-p)
  (interactive "P")
  (insert 
   (format "#%s?=" (if insert-point-p (int-to-string (point)) ""))))

C-U M-X insert-gauche-debug-print-dispatch-charで、数字を付けて#?=を挿入します。

.4

| 00:17 | .4 - わだばLisperになる を含むブックマーク はてなブックマーク - .4 - わだばLisperになる

今日は、普通な題材にしようということで、lw-compatの中から適当に探してみました。

お題は、with-unique-namesと、rebindingにしました。

作者は、色んな所で目にするので恐らく著名な、Pascal Costanza氏です。

lw-compat:

http://www.google.com/codesearch?hl=en&q=show:yZBDJzpf0IM:HkZCZvv6THQ:7NeZEGaEv28&sa=N&ct=rd&cs_p=http://ftp.debian.org/debian/pool/main/c/cl-lw-compat/cl-lw-compat_0.22.orig.tar.gz&cs_f=cl-lw-compat-0.22.orig/lw-compat.lisp&start=1

お題 1.

(defmacro with-unique-names (names &body body)
  "Returns a body of code with each specified name bound to a similar name."
  `(let ,(mapcar (lambda (name) `(,name (gensym ,(symbol-name name))))
                 names)
     ,@body))
  • 初見時の感想

これは、Paul Graham氏でお馴染のwith-gensymじゃないだろうか。

  • 再現(失敗)
(defmacro with-uniq-names (names &body body)
  `(let ,(mapcar (lambda(n) `(,n ,(gensym (symbol-name n))))
		 names)
     ,@body))
  • 失敗したところ

コンマの場所を間違えて、展開時にgensymが働いてしまっているのに気付かず、結構悩みました。

  • 感想 (思ったことをつらつらと)
    • 丁寧に、gensymに名前を付けるのが、Costanza流なのか、Lispworks流なのか。一応Lispworksで確認してみたら、Lispworksでは、このスタイルのようです。
    • 単数->name、複数->names系の変数名命名法
    • 「&bodyは使う」派

お題 2.

(defmacro rebinding (vars &body body)
  (loop for var in vars
        for name = (gensym (symbol-name var))
        collect `(,name ,var) into renames
        collect ``(,,var ,,name) into temps
        finally (return `(let ,renames
			   (with-unique-names ,vars
			     `(let (,,@temps)
				,,@body))))))
  • 初見時の感想

これは、多重評価防止で使うonce-onlyという名前でお馴染のマクロじゃないだろうか。

  • 再現:
(defmacro rebinding (vars &body body)
  (loop for var in vars
        for name = (gensym (symbol-name var))
        collect `(,name ,var) into renames
        collect ``(,,var ,,name) into temps
        finally (return `(let ,renames
			   (with-unique-names ,vars
			     `(let (,,@temps)
				,,@body))))))

感想:

  • あまり内容は理解していないけれど、字面通り再現できた。ややこしい。
  • 内部にwith-unique-namesが使用されていることもあって把握はしやすくなっている。
  • 色々あるonce-only的マクロのうちでも簡潔で分かりやすい記述だと思った。

脱線:

once-onlyについて調べてみたら、これはかなり昔からあるようでLispマシンのマニュアルにも乗っていました。

http://common-lisp.net/project/bknr/static/lmman/macros.xml#once-only

2007-09-16

L-99 (60)

| 16:38 | L-99 (60) - わだばLisperになる を含むブックマーク はてなブックマーク - L-99 (60) - わだばLisperになる

L-99 P60に挑戦 - L-99:Ninety-Nine Lisp Problems

P59変形で、高さの代わりにノード数を与え、バランス

の取れた木を生成するというお題。

残りの問題:'(63 66 80-94 96-99) 解答状況 64/84

P60

解答
N = 15のとき生成される木の組み合わせは、1553通り。
(length (hbal-tree-nodes 15))
=> 1553
;;; ---------------------------------------------------------------------------
;;; common lisp
;;; ---------------------------------------------------------------------------
(defun max-nodes (h)
  (1- (expt 2 h)))

(defun min-nodes (h)
  (do ((h h (1- h))
       (res 2 (+ 1 res acc))
       (acc 1 res))
      ((< h 3) res)))

#|(defun min-nodest (h a1 a2)
  (if (< h 3)
      a1
      (min-nodest (1- h) (+ 1 a1 a2) a1)))|#

(defun max-height (n)
  (do ((i 0 (1+ i)))
      ((> (min-nodes i) n) (1- i))))

(defun min-height (n)
  (1+ (truncate (log n 2))))

(defun hbal-tree-nodes (n)
  (let ((min-height (min-height n))
	(max-height (max-height n)))
    (do ((h min-height (1+ h))
	 res)
	((> h max-height) res)
      (setq res `(,@(remove-if-not (lambda (x) (= n (count-leaf x)))
				   (hbal-tree h))
		    ,@res)))))

.3

| 00:31 | .3 - わだばLisperになる を含むブックマーク はてなブックマーク - .3 - わだばLisperになる

今回は、以前から分析してみたかったコードに挑戦してみました。

お題は、30年以上前のコードと思われるMaclispのrdsylの定義です。

Maclisp/maklap.lsp

http://www.google.com/codesearch?hl=ja&q=+DEFUN%5C+RDSYL+show:vVmLEzSQCwQ:uCPQVGUIK4w:K_YYdzk_7EY&sa=N&cd=1&ct=rc&cs_p=ftp://ftp.ultimate.com/pdp10/maclisp/maclsp804.tar.gz&cs_f=maclsp804/maklap.lsp#a0

(DEFUN RDSYL (L DF) 
  (PROG (LL BRAKP ANS CH)
	(SETQ DF (MERGEF DF '((* *) * *)))
     AA	(SETQ LL (SETQ BRAKP () ))
     A	(SETQ CH (OR (CAR L) #/_))
        (COND ((OR (= CH #/^Q) (= CH #//))	 			;"/", "^Q" ;^Qはコントロール文字
	       (POP L)
	       (SETQ CH (CAR L)))
	      ((AND (= CH #/[) (NOT #%(ITSP)))				;"["
	       (SETQ BRAKP 'T))
	      ((AND (= CH #/]) (NOT #%(ITSP))) (SETQ BRAKP () ))	;"]"
	      ((OR (= CH #/( ) (= CH #/) )) (RETURN () ))		;Cant have parens here
	      ((= CH #/,)					;Comma
	       (COND ((NOT BRAKP)
		      (POP L)
		      (GO RET))))
	      ((= CH #/_) (GO RET)))
	(PUSH CH LL)
	(POP L)
	(GO A)
   RET  (SETQ DF (MERGEF (NAMELIST (MAKNAM (NREVERSE LL))) DF))
	(SETQ ANS (NCONC ANS (LIST DF)))
	(AND (= CH #/,) (GO AA))
	(RETURN ANS) ))

だいぶ前に、自分もスティーブン・レビーの「ハッカーズ」を図書館から借りて読みました。それで、Greenblatt氏に興味を持って適当に検索していたら、lispmeister.comのブログでcomp.lang.lispで、奇怪なコードが典型的なGreenblatt氏のスタイルとして紹介されている、というエントリを目にして以来いつか分析してみたいなと思っていました。

http://lispmeister.com/blog/lisp-news/richard-greenblatt.html

日本のLispUser.netさんのところでも紹介されてます。

http://lispuser.net/memo/lisp/2006-06-25-10-20.html

ということで、写経してみたいのですが、ちょっとこれは動作自体が想像できず、記憶もできないので、今回は、分解して一体何をするものなのかということを解明してみることにします。

前準備:

  • 全体的な動作

コードから動作が想像できないので、実際にMaclispを実際に動かしてみて確認してみたところ、どうやらファイル名を受け取ってシステムで使用できる名前に整える関数のようです。

  • エスケープ文字

Common Lispだと、キャラクタは、#\Aの様に表現されますが、Maclispは、/がエスケープ文字なので、#/Aの様に表現されます。

  • 関数名:RDSYL

Read Symbol Listとかその辺の短縮じゃないかと思うのですが実際のところ何なんでしょう。

  • MERGEF

Common Lispのmerge-pathnamesみたいな関数です。

  • NAMELIST

デバイスとディレクトリ、ファイル名、拡張子をシステムが扱える形式にして出力する関数のようです。

  • MAKNAM

何とも説明しにくいのですが、

(defun maknam (syms)
  (intern
   (map 'string (lambda (x) (char (string x) 0))
	syms)))

のような動作をする関数です。

  • #%

#.とか#,とかその辺の動作と同じなんでしょうか、詳細は分かりませんでした。あってもなくても大体の動作は同じでした。

  • ITSP

ITS上のMaclispでもTOPS-20でも試してみましたが、ITSPはありませんでした。恐らく名前からして、#+ITSみたいなもんだろうとは思います。

大体見通しが付いたので、細かいOS依存のところは無視して、UNIX上で動くCommon Lisp版といった感じに訳してみました。

(defun rdsyl-ux (filename directory) 
  (prog (ll brakp ans ch fn dir)
        (setq fn (coerce filename 'list))
        (setq dir (coerce directory 'list))
     aa	(setq ll (setq brakp () ))
     a	(setq ch (or (car fn) #\_))	;一文字読みこむ。デフォルトは#\_。#\_は番兵としてループから抜ける判断にも使用される。
        (cond ((or (char= ch #\Nul) (char= ch #\/)) ;読み飛ばす。
	       (pop fn)
	       (setq ch (car fn)))
	      ((char= ch #\[) (setq brakp 't)) ;","文字のエスケープ開始
	      ((char= ch #\]) (setq brakp () )) ;","文字のエスケープ解除
	      ((or (char= ch #\( ) (char= ch #\) )) (return () )) ;括弧は名前に使わないので、nilを返して終了
	      ((char= ch #\,)	        ;エスケープされていない","の場合RETへ飛ぶ。
	       (cond ((not brakp)
		      (pop fn)
		      (go ret))))
	      ((char= ch #\_) (go ret))) ;#\_なら、RETへ飛ぶ。
	(push ch ll)
	(pop fn)
	(go a)
   ret  (setq dir (append dir (nreverse ll)))
	(setq ans (nconc ans (list dir)))
	(and (char= ch #\,) (go aa))
	(return (coerce (car ans) 'string)) ))

動作の解析:

  • ファイル名中の#\Nulと"/"は無視し読み飛ばされる。(UNIX風に変更してみました)
  • ","と"_"はファイル名に使えず、終端文字として機能する。
  • "["が","より先に出現していれば、","は終端文字にならない。
  • ファイル名に"()"は使えない。
(rdsyl-ux "f/o/o.txt" "/tmp/")
=> "/tmp/foo.txt"

のように動作します。

"["と"]"が特別扱いされていますが、これは恐らく、TOPS-10か、SAILのWAITS上でディレクトリが、[30,20]や、[MAC, LSP]の様に表現される為の処理じゃないかと想像しています。ITSは、DSK:DIR;FOO 1のようなファイル名の形式になるので、ITSか、それ以外のOSかを振り分けているのでしょう。

感想:

どうやってループから抜けているのか分からずしばらく悩みました。

多分こういうスタイルにも常套句が色々あって、それに則ったスタイルなんじゃないかなとは思います。

雑感:

それで、結局このコードはGreenblatt氏のコードなのかというと、署名もなにもないのでソースを眺めただけでは分かりません。

Maclispは、JonL White氏がメインで活躍していたみたいなので、JonL氏の可能性も高いと思います。

そして、ループは、progを使用するというスタイルですが、comp.lang.lispでこのコードを紹介したMarshall氏が公開しているLMIの各種Lispマシンのソースコード中のGreenblatt氏のホームディレクトリのLispのファイルを眺めてみてもdoとか普通に使ってるみたいです。ただ70年代の初期のLispマシンの開発においては、progのループでゴリゴリ書いていた可能性は高いとは思います。これは、個人のスタイルというより、70年代全般のスタイルみたいで全体的にdoのループより多いんじゃないかという位です。

それと、Kent Pitman氏のgoタグ使い過ぎの警告についてですが、メッセージを探してみた人がいるみたいですが、見付けられなかったみたいです。自分も暇なので、結構探してみましたが、見付けられませんでした。あるとしたら警告の内容も揶揄するような内容にも思われるので、多分、LMIのライバルのSymbolics社のLispマシンじゃないかなと思います。

ということで、極東の地で壮大に一人でネタに釣られてみました。

2007-09-15

.2

| 03:12 | .2 - わだばLisperになる を含むブックマーク はてなブックマーク - .2 - わだばLisperになる

日課でコードを読むことの2回目

今日は、CMUCL 19のコードを写経してみることにしました。

お題は、list.lispの中のmap1です。

http://www.google.com/codesearch?hl=ja&q=show:vmxbnnEW51Q:knqQqWNc9uc:d4orNuqkr1I&sa=N&ct=rd&cs_p=http://gentoo.osuosl.org/distfiles/cmucl_19c-release-20051115.orig.tar.gz&cs_f=cmucl-19c-release-20051115.orig/src/code/list.lisp&start=1

map1は内部の関数で、mapcarや、mapconを作るための汎用的なものみたいです。

このコードはSpice lispの由来のものらしく、自分が調べた限りでは、少なくとも20年以上前のコードみたいです。

お題:

(defun map1 (function original-arglists accumulate take-car)
  "This function is called by mapc, mapcar, mapcan, mapl, maplist, and mapcon.
  It Maps function over the arglists in the appropriate way. It is done when any
  of the arglists runs out.  Until then, it CDRs down the arglists calling the
  function and accumulating results as desired."

  (let* ((arglists (copy-list original-arglists))
	 (ret-list (list nil))
	 (temp ret-list))
    (do ((res nil)
	 (args '() '()))
	((dolist (x arglists nil) (if (null x) (return t)))
	 (if accumulate
	     (cdr ret-list)
	     (car original-arglists)))
      (do ((l arglists (cdr l)))
	  ((null l))
	(push (if take-car (caar l) (car l)) args)
	(setf (car l) (cdar l)))
      (setq res (apply function (nreverse args)))
      (case accumulate
	(:nconc (setq temp (last (nconc temp res))))
	(:list (rplacd temp (list res))
	       (setq temp (cdr temp)))))))

初見時の感想:

  • dolistのところは、someの代りっぽい。
  • とりあえず、リストの破壊的操作が満載っぽい。

再現1:

  • とりあえず、一度、字面は再現したものの挙動が全然分からなくなってしまったので、自分の理解の為、動くものを作成。
(defun my-map1 (function lists accumulate take-car)
  (do ((l lists (mapcar #'cdr l))
       res
       (tem () () ))
      ((some #'endp l)
       (if accumulate
	   (case accumulate
	     (:nconc res)
	     (:append (nreverse res)))
	   (car lists)))
    (setq tem
	  (apply function (if take-car (mapcar #'car l) l)))
    (case accumulate
      (:nconc 
       (setq res (nconc res (apply function tem))))
      (:append
       (push (apply function tem) res)))))

部品を再現

  • 部品1.
(some #'endp lst)
=> (dolist (x lst nil) (if (null x) (return t)))
  • 部品2.
(do ((ls '((foo bar baz) (1 2 3 4)) (mapcar #'cdr ls)))
    ((some #'endp ls))
  (print ls))
=>
(let ((lists '((foo bar baz) (1 2 3 4))))
  (do ()
      ((dolist (x lists nil) (if (null x) (return t))))
    (do ((x lists (cdr x)))
	((null x))
      (setf (car x) (cdar x))
      (print lists))))
  • 部品3.
(push (apply function tem) res) ~ (nreverse res)
=>
(do* ((l '(foo bar baz) (cdr l))
      (res (list () ))			;'(())だと駄目なのはなんでだろう。
      (splice res))
     ((endp l) (cdr res))
  (setq splice (cdr (rplacd splice (list (car l))))))
  • 部品4.
(setq res (nconc res (apply function tem)))
=>
(setq temp (last (nconc temp res)))

再構成で再現2

(defun map1 (function original-arglists accumulate take-car)
  (let* ((arglists (copy-list original-arglists))
	 (ret-list (list () ))
	 (temp ret-list))
    (do ((xx arglists)                  ;不要だった。
	 (res nil)
	 (args '() '() ))
	((dolist (x xx nil) (if (null x) (return t)))
	 (if accumulate
	     (cdr ret-list)
	     (car original-arglists)))
      (do ((l arglists (cdr l)))
	  ((null l))
	(push (if take-car (caar l) (car l)) args)
	(setf (car l) (cdar l))) ;これがarglistsを更新している。
      (setq res (apply function (nreverse args)))
      (case accumulate
	(:nconc (setq temp (last (nconc temp res))))
	(:append (rplacd temp (list res))
		 (setq temp (cdr temp)))))))

(map1 #'list '((foo bar baz) (1 2)) :nconc nil)
=> (mapcon #'list '(foo bar baz) '(1 2))

(map1 #'list '((foo bar baz) (1 2)) :append t)
=> (mapcar #'list '(foo bar baz) '(1 2))

答え合わせ:

  • 外側のdoの(xx arglists)は不要だった。

感想:

イデオム的なものが、3つ程出てきたけれど、全部リストの破壊的操作関係だった。

  • 部品1. someに置き換えられるので、把握できたが、なんでループから抜けられるのかちょっと分からなかった。
  • 部品2. 入れ子になったdoがあり、外側のものが、ループを抜ける条件節だけを使ってるようなもので、実は内側のdoがsetfでリストの内容を更新していてその結果を判定していると分かるまでかなり悩んだ。
  • 部品3、4. 以前偶々del.icio.usのlispタグのとこに流れて来たリストのspliceというやつなのかなと思ったけれど、これもなんだか馴れないとトリッキーに感じる。

参考:

spliceについて

http://www.apl.jhu.edu/~hall/Lisp-Notes/Destructive-Ops.html

2007-09-14

.1.5

| 13:50 | .1.5 - わだばLisperになる を含むブックマーク はてなブックマーク - .1.5 - わだばLisperになる

前回のmy-setqの定義ですが、Common Lispだと、setを使うとスペシャル変数に代入してしまうことを寝る前に思い出しました。

(defmacro my-setq (&rest symbols-and-values)
  (do ((l symbols-and-values (cddr l))
       (val () (set (car l) `,(cadr l))))      
      ((endp l) val)))

これだとローカル変数には代入せず、スペシャル変数にだけ代入するという謎なものができます。

(let (x y)
  (my-setq x 10 y 30)
  (values x y
  (symbol-value 'x)
  (symbol-value 'y)))
=> nil, nil, 10, 30

結局Common Lispだと、

(defmacro my-setq (&rest symbols-and-values)
  (do ((l symbols-and-values (cddr l))
       (form () (cons `(setq ,(car l) ,(cadr l)) form)))      
      ((endp l) `(progn ,@(nreverse form)))))

のようになるのかもしれません。

CADRのLisp Machine Lispでは、setはsetqのqが取れただけの動きのようなので、以上Common LispとLisp MachineLispの違いというところなのかなーという、全く役に立たない考察でした。

.1

| 13:50 | .1 - わだばLisperになる を含むブックマーク はてなブックマーク - .1 - わだばLisperになる

何となくネタ切れという感じで、更新が途絶えがちになってしまうのですが、あまり考えないで、日々Lispを触ってみているプログラム経験初心者の感想を書き散らかすということに方針を変えてみようかと思います。

適当にごちゃごちゃとLispのコードを書き散らかしてはいるのですが、あまり自分以外のコードを読んだりすることはなかったりするので、先達のコードを読んで研究してみようと思い立ちました。

ぼーっと眺めるだけだとあまり効果がなさそうなので、

1) お題を一定時間じっくり観察する。

2) その後、一切見ないで、再現する。

3) 確認と感想をまとめる。

のサイクルを繰り返してみることを試すことにしました。

写経ってやつでしょうか。

ということで、今回のお題は、LispマシンCADRのsetqの定義です。

1977~80年位のコードで、ファイル名は、qfctns.lispです。

先達すぎると思いますが、レトロコンピューティングが自分の趣味なので…。

Lispの方言はLisp machine lispです。

お題:

(DEFUN SETQ (&QUOTE &REST SYMBOLS-AND-VALUES)
  (PROG (VAL)
   L	(COND ((NULL SYMBOLS-AND-VALUES) (RETURN VAL)))
	(SET (CAR SYMBOLS-AND-VALUES) (SETQ VAL (EVAL (CADR SYMBOLS-AND-VALUES))))
	(SETQ SYMBOLS-AND-VALUES (CDDR SYMBOLS-AND-VALUES))
	(GO L)))

初見時の感想:

  • "Eってなんだ?
  • setが使われているのを初めて見た。
  • なんでevalが使われているんだ。

再現:

(defun my-setq (&rest symbols-and-vars)
  (prog (l var)
        (setq l symbols-and-vars)
    l   (cond ((null l) (return var)))
	(set (car l) (setq var (eval (cadr l))))
	(setq l (cddr l))
	(go l)))

とりあえず、"eは無視して記憶を辿って再現し、実行。

(my-setq foo 10 bar 20)

=> The variable FOO is unbound.

あ、そうか、そうだよね。"eは、引数をクオートするってことか。

ということで、"eを実現する方法を色々考えてみたけれど分からないので、defmacroを使うことにした。

しかし、defunがdefmacroに変っただけ。

(defmacro my-setq (&rest symbols-and-vars)
  (prog (l var)
        (setq l symbols-and-vars)
    l   (cond ((null l) (return var)))
	(set (car l) (setq var (eval (cadr l))))
	(setq l (cddr l))
	(go l)))

これで動作した。

確認と感想:

  • &restを直接いじっているけど良いのだろうか。
  • ラムダリストキーワードの"eと内部でのevalの組み合わせはdefmacroに統合されたのかもしれない。
  • 関数とマクロの中間みたいな微妙なマクロもあるのかもしれない。

もう少し今風に書き直してみた。

(defmacro my-setq (&rest symbols-and-values)
  (do ((l symbols-and-values (cddr l))
       (val () (set (car l) `,(cadr l))))      
      ((endp l) val)))

2007-09-13

L-99 (59)

| 16:17 | L-99 (59) - わだばLisperになる を含むブックマーク はてなブックマーク - L-99 (59) - わだばLisperになる

L-99 P59に挑戦 - L-99:Ninety-Nine Lisp Problems

今度は、木の高さのバランスを取りつつ与えられた高さ

の木を生成するというお題。

残りの問題:'(60 63 66 80-94 96-99) 解答状況 63/84

P59

;;; ---------------------------------------------------------------------------
;;; common lisp
;;; ---------------------------------------------------------------------------
(load "comb2")

(defun hbal-tree (h)
  (remove-if-not #'hbal-tree-p (gen-tree-h h)))

(defun gen-tree-h (h)
  (cond ((zerop h) '(()))
	((= h 1)   '((x () ())))
	((= h 2)   '((x (x () ()) () )
		     (x () (x () ()))
		     (x (x () ()) (x () ()) )))
	((> h 2)
	 (let ((h-1 (gen-tree-h (1- h)))
	       (h-2 (gen-tree-h (- h 2))))
	   (map 'list (lambda (item) `(x ,@item))
		`(,@(comb2 h-1 h-1)
		  ,@(comb2 h-1 h-2)
		  ,@(comb2 h-2 h-1))))
	('T (error "Bad arg to gen-tree-h"))))

(defun hbal-tree-p (tree)
  (>= 1 (abs (- (tree-height (cadr tree))
		(tree-height (caddr tree))))))

(defun tree-height (tree)
  (if tree
      (1+ (max (tree-height (cadr tree)) 
	       (tree-height (caddr tree))))
      0))

2007-09-12

L-99 (58)

| 12:30 | L-99 (58) - わだばLisperになる を含むブックマーク はてなブックマーク - L-99 (58) - わだばLisperになる

L-99 P58に挑戦 - L-99:Ninety-Nine Lisp Problems

解けなかったP55が解けたので、関連するP58も解答を作

成。

57ノードの場合、16個のうちから13個取る組み合わせなの

で、nPr = n!/r!(n-r)!

で、560通りかと思いきや、自作プログラムの結果は、256。

560通りの組み合わせのうち自身のパターンが、

1010と0101の関係のように逆行系が同じになるパターン

を纏めれば、256になるのかもしれない。

考えても分からないので、元のPrologで作成されたプロ

グラムを実行してみたら、これも256。

理屈は全然分からないが、自作プログラムとPrologの解

答の結果を色々テストで突合せてみても同じなのでこれ

で良いんだとは思う。

残りの問題:'(59 60 63 66 80-94 96-99) 解答状況 62/84

P58

解答
N=57の時に線対称の形状になる組み合わせの数
(length (sym-cbal-trees 57))
=> 256

Nが偶数だとどうなるか。
=> 線対称の木は生成されない。

;; Common Lisp
;; -----------------------------------------------------------------------------
(defpackage l99 (:use #:cl))

(load "p55") ;cbal-tree
(load "p57") ;symmetric

(in-package :l99)

(defun sym-cbal-tree (n)
  (reduce (lambda (res tr) (if (symmetric tr) `(,tr ,@res) res))
	  (cbal-tree n)
	  :initial-value () ))

2007-09-10

L-99 (55)

| 22:42 | L-99 (55) - わだばLisperになる を含むブックマーク はてなブックマーク - L-99 (55) - わだばLisperになる

L-99 P55に挑戦 - L-99:Ninety-Nine Lisp Problems

実に4ヶ月ぶり。以前、12時間考えてどうにも分からな

かった問題を思い出して再挑戦。

しかし、久しぶりに考えてみたら案外あっさりできた。

難しく考え過ぎてたらしい。

残りの問題:'(58-60 63 66 80-94 96-99) 解答状況 61/84

P55

解答
;; Common Lisp
;; -----------------------------------------------------------------------------
(defpackage l99 (:use #:cl))

(in-package :l99)

(defun cbal-tree (n)
  (if (zerop n)
      '(())
      (if (>= 1 n)
	  '((x () () ))
	  (reduce (lambda (res x) 
		    (let ((tree `(x ,@x)))
		      (if (cbal-tree-p tree)
			  `(,tree ,@res)
			  res)))
		  (let ((half (/ (1- n) 2))) ;balanced
		    (if (zerop (mod half 1))
			(comb2 (cbal-tree half)
			       (cbal-tree half))
			(let ((g (ceiling (/ (1- n) 2))) ;greater
			      (l (truncate (/ (1- n) 2)))) ;less
			`(,@(comb2 (cbal-tree l)
				   (cbal-tree g))
			    ,@(comb2 (cbal-tree g)
				     (cbal-tree l))))))
		  :initial-value () ))))

(defun cbal-tree-p (tree)
  (>= 1 (abs (- (count-leaf (cadr tree))
		(count-leaf (caddr tree))))))

(defun count-leaf (tree)
  (if tree
      (+ 1 (count-leaf (cadr tree)) (count-leaf (caddr tree)))
      0))

(defun comb2 (xs ys)
  (mapcan (lambda (y)
	    (mapcar (lambda (x) `(,x ,y)) xs))
	  ys))
テスト
(defun ppt (tree) (mapc #'print tree))

(ppt (cbal-tree 4))
=>
 (X (X NIL (X NIL NIL)) (X NIL NIL)) 
 (X (X (X NIL NIL) NIL) (X NIL NIL)) 
 (X (X NIL NIL) (X NIL (X NIL NIL))) 
 (X (X NIL NIL) (X (X NIL NIL) NIL))