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 |

2008-04-13

CLで学ぶ「プログラミングGauche」 (6)

| 18:13 | CLで学ぶ「プログラミングGauche」 (6) - わだばLisperになる を含むブックマーク はてなブックマーク - CLで学ぶ「プログラミングGauche」 (6) - わだばLisperになる

今回は6章「リスト」です。

6.1 リストの二つの顔

ここはCL/Scheme共通だと思います。

6.2 リストの基本操作

()のcar、cdr適用は動作が違っているのは、CL/Schemeでの違いでも割と有名な事項だと思います。

CLでは、伝統に則って空リストにcarとcdrを適用すると、()が返ります。

色々深遠な理由があるとも言われているようですが、LISP 1.5では、このような動作ではなく、PDP-1 LISPからかと思っていましたが、(cdr () )は、()のプロパティが返るのでnilが返って来ている訳ではありませんでした。そうなると、PDP-6 LISP以降だと思うのですが、いまいちはっきりしません。まあ、誰も拘ってないと思いますが(笑)

()にcarや、cdrを適用してもエラーにならないというのは、便利なところもありますが、

(defun foo (lst)
  (when (atom (car lst))
    (car lst)))

のように書くと、

(foo ())
;=> nil
(foo '(()))
;=> nil

では、区別がつかないし、エラーにもならないしで気付かないバグを入れていることが自分は多いです。ということで

(defun *car (lst)
  (when (null lst)
    (warn "()にcarを適用しました。"))
  (car lst))

のようなものを作って使ってみたりもしますが、いまいちです。

ちなみに、TAOでは、デフォルトの挙動を大域変数で変更できてエラーにすることも、nilを返すこともできたようです。

  • null?、pair?

CLでは、null、pair?はそれぞれnullと、conspになります。

最後に、-pが付くか、-?が付くかはSchemeと伝統的LISPの習慣の違いかと思いますが、atomと、nullには、-pが付かないので一貫性がなかったりします。これは、LISP 1.5からそうなので、50年来の伝統というほかないんでしょう。処理系によっては、atompや、nullpもあったりするようです。

空リストかを判定する関数としては、nullの他に、endpがあります。endpは、リスト以外を与えるとエラーになります。

6.3 リストの操作

  • fold => reduce

ここでは、foldがでてきます。CLには、foldという名前の関数はありませんが、同じような機能としてreduceがあります。

;; fold
(fold <手続き> <初期値> <リスト> ... <リストN>)

;; reduce / CL
(reduce <手続き> <リスト> :initial-value <初期値>)

reduceでは、初期値をキーワードで与えることと、複数のリストを与えることができないというところが違っています。

また、このセクションででてくる+inf.0、-inf.0のようなものはCLにはありません。

most-negative-〜定数があるので、それが近いといえば近いのかもしれませんが、どうなのでしょう。

  • 内部define => flet、labels

恐らく、Schemeでは、名前空間が一つで変数/関数の名前の衝突を避ける必要があるのでローカル関数は多用される傾向があるんじゃないかと思います。

CLでは空間が別々で変数と関数の名前は衝突せず、割と大らかに大域で定義してしまうことが多いように思います。

個人的には、関数内関数は個別にデバッグするのが面倒に感じるので、大域で定義することが多いです。まあ、デバッグが済んでから合体すれば良いのですが…。

また、CLでは、さらにパッケージを分割することもできるので、名前空間の汚染に関してはそれほど気にする必要はないのかもしれません。

「いちいちfuncallを付けなくてはいけない面倒臭ささ」と「名前の衝突回避のノウハウを頭の片隅に常駐させて置く負担」はトレードオフな気もします。

そして、CLでは、defunの中でdefunを使うような書き方は普通されず、

(defun max-number (lst)
  (defun pick-greater (a b)
    (if (> a b) a b))
  (reduce #'pick-greater lst
          :initial-value most-negative-long-float))

(defun max-number (lst)
  (flet ((pick-greater (a b)
           (if (> a b) a b)))
    (reduce #'pick-greater lst
            :initial-value most-negative-long-float)))

下の例のように、fletや、再帰する場合、labelsを使ってローカル関数を定義します。

内部defunは以前のSBCLでは警告が出たと思ったのですが、今回改めて試してみると警告はでなくなっているようです。

他の処理系でも警告は出ないのですが、これは書法としてOKなのでしょうか…。

6.4 foldの定義

リストの操作を学習する上で、foldの定義をしてみるというのは教材として良いアイディアではないかと思いました。

ここで#?=を使用したデバッグプリントがでてきますが、CLにはないので、適当に以前作ったものを、また載せてみます。

(defmacro debug-print (obj &optional name (output t))
  `(let ((name (if ,name ,name 0)))
     (format ,output "~&#?=[~A]:~A~%#-~4T~A~%" name ',obj ,obj)
     ,obj))

(defun gauche-debug-print (stream char arg)
  (declare (ignore char))
  (if (char= #\= (peek-char t stream))
      (read-char stream))
  `(debug-print ,(read stream t nil t) ,arg t))

(set-dispatch-macro-character #\# #\? #'Gauche-debug-print)

;; #?=を仕込む
(defun fold (proc init lst)
  (if (null lst)
      init
      (fold proc
            #111?=(funcall proc (car lst) init)
            #555?=(cdr lst))))

;; 使ってみる
(fold #'+ 0 '(1 2 3 4 5))
;>>>
;#?=[111]:(FUNCALL PROC (CAR LST) INIT)
;#-  1
;#?=[555]:(CDR LST)
;#-  (2 3 4 5)
;#?=[111]:(FUNCALL PROC (CAR LST) INIT)
;#-  3
;#?=[555]:(CDR LST)
;#-  (3 4 5)
;#?=[111]:(FUNCALL PROC (CAR LST) INIT)
;#-  6
;#?=[555]:(CDR LST)
;#-  (4 5)
;#?=[111]:(FUNCALL PROC (CAR LST) INIT)
;#-  10
;#?=[555]:(CDR LST)
;#-  (5)
;#?=[111]:(FUNCALL PROC (CAR LST) INIT)
;#-  15
;#?=[555]:(CDR LST)
;#-  NIL

Gaucheのようにソースファイルの行を表示することは、難しかったのですが、ディスパッチマクロ文字は、10進数の引数が取れるので番号付けで代用してみています。

しかし、CLには、普通にtraceがあるので、

(trace fold)

で、

  0: (FOLD #<FUNCTION (SB-C::&OPTIONAL-DISPATCH +) {10007DEFC9}> 0 (1 2 3 4 5))
    1: (FOLD #<FUNCTION (SB-C::&OPTIONAL-DISPATCH +) {10007DEFC9}> 1 (2 3 4 5))
      2: (FOLD #<FUNCTION (SB-C::&OPTIONAL-DISPATCH +) {10007DEFC9}> 3 (3 4 5))
        3: (FOLD #<FUNCTION (SB-C::&OPTIONAL-DISPATCH +) {10007DEFC9}> 6 (4 5))
          4: (FOLD #<FUNCTION (SB-C::&OPTIONAL-DISPATCH +) {10007DEFC9}> 10 (5))
            5: (FOLD #<FUNCTION (SB-C::&OPTIONAL-DISPATCH +) {10007DEFC9}> 15
                     NIL)
            5: FOLD returned 15
          4: FOLD returned 15
        3: FOLD returned 15
      2: FOLD returned 15
    1: FOLD returned 15
  0: FOLD returned 15

のように表示することもできるので、普通はこっちを使えば良いかなと思います。

6.5 簡単なリスト処理

ここでは、CLの関数で言えば、last、copy-list、copy-tree/練習問題、append、reverse、find-ifを自作することによってリスト処理を学びます。

deep-copy-listは、CLの標準関数でいうと、copy-treeになるかと思います。

一応、課題を書いてみました。

(defun deep-copy-list (lst)
  (if (consp lst)
      (cons (deep-copy-list (car lst))
            (deep-copy-list (cdr lst)))
      lst))
  • char-alphabetic? => alpha-char-p

char-alphabetic?は、CL標準では、alpha-char-pとして存在しています。

  • find => find-if

ここでのfindは、CLでは、find-ifです。

また、condの説明がでてきますが、Schemeのようにelseがキーワードになってはいません。

慣例的にtを書きますが、CLでは、nil以外は全部真なので、'Tでも'elseでも:elseでもOKです。

また、RSR6風の括弧の使い方ですが、CLにはこのようなものはないので欲しい場合は、自作することになると思います。

(defun open-bracket-macro-char (stream macro-char)
  (declare (ignore macro-char))
  (read-delimited-list #\] stream t))
(set-macro-character #\[ #'open-bracket-macro-char)
(set-macro-character #\] (get-macro-character #\)))

;; 使用例
(defun my-find-if (pred lst)
  (cond [(null lst) nil]
        [(funcall pred (car lst)) (car lst)]
        [:else (my-find-if pred (cdr lst))]))

6.6 2種類の再帰

末尾再帰とそれ以外の再帰についてのセクションです。

Schemeでは末尾再帰が最適化されるというところは、Schemeのプログラミング書法にはかなり大きく影響していると思います。

CLでは、最適化することを義務付けてはいないので、処理系によってするものもあればしないものもあるといった感じです。

ということで、末尾再帰が必ず最適化されることを期待して書くということは推奨されていないようで普通にループで書くことが多いようです。

イレギュラーなところでは、

(defun len (lst)
  (prog ((lst lst) (n 0))
    =>  (return (if (null lst)
                    n
                    (progn (setq lst (cdr lst) n (1+ n))
                           (go =>))))

のように書けば、関数呼び出し気分なgotoを書けるので、もの好きな方にはお勧めしたいです(笑)

このブログでも、末尾再帰の最適化機構付きのtail-recursive-defunというマクロを古いMacLISPのコードからみつけて動作を考えてみたことがありましたが、マクロのレベルで構文を解析して、末尾再帰的記述をループに書き換えるというのはどの程度有効なのでしょう。

どうしても、変数の代入と束縛というところが違ってきてしまう気はしますが…。

2008-01-31

末尾再帰的DEFUN (2)

| 04:53 | 末尾再帰的DEFUN (2) - わだばLisperになる を含むブックマーク はてなブックマーク - 末尾再帰的DEFUN (2) - わだばLisperになる

何となく釈然としないまま、一旦放置した末尾再帰的DEFUNですが、何となく眺めていると末尾再帰をgo-toに変換するんじゃないのかなあ、という気がしてきました。

つまり明示的に末尾再帰で書かれたものを、完全なループに変換するという目的のものだったのではないかと思えてきました。

そう考えると、関数呼び出しの個所をgo-toに変換すれば良いのですが、

(defun fib (n &optional (a1 1) (a2 0))
  (if (< n 2)
      a1
      (fib (1- n) (+ a1 a2) a1))))

のような末尾再帰の定義は

(defun fib (n &optional (a1 1) (a2 0))
  (prog ()
    L   (if (< n 2)
	    (return a1)
	    ((lambda (t1 t2 t3) (setq n t1 a1 t2 a2 t3) (go L)) (1- n) (+ a1 a2) a1)))))

のようにすれば、マクロで置き換えるのも、そんなに大変でもないかなと。

本当は、

(defun fib (n &optional (a1 1) (a2 0))
  (prog ()
    L   (if (< n 2)
	    (return a1)
	    (progn (setq n (1- n) a1 (+ a1 a2) a2 a1) (go L))))))

という風にするべきな気もします。スタックの使われ方とか、その辺に違いがありそうですが、disassemしても良く分からなかったので、とりあえず、lambdaの方で行くことにしました。

それで、この場合、PROGの中に展開されるので、最終的に値を返すところには、returnを付けないといけない訳なのですが、それがどこなのか判別するのは至難の技なので、逆にRETURNの中に展開してしまうことにしました。オリジナルもこういう感じなのですが、こういうことなのかも知れません。

(defun fib (n &optional (a1 1) (a2 0))
  (prog ()
    L   (return (if (< n 2)
		    a1
		    ((lambda (t1 t2 t3) (setq n t1 a1 t2 a2 t3) (go L)) (1- n) (+ a1 a2) a1))))))

そんなこんなでいつものごとくガチャガチャと自分なりに作ってみました。

RETURN式の中から外にgotoとかして良いのかしら、とか思ったりしますが、これって手法としてはありななんですかねえ。

;; 動作
(tail-recursive-defun fib (n &optional (a1 1) (a2 0)) 
  (if (< n 2)
      a1
      (fib (1- n) (+ a1 a2) a1)))

;; マクロ展開=>
(DEFUN FIB (N &OPTIONAL (A1 1) (A2 0))
  (PROG ()
     #:G3105
     (RETURN
       (IF (< N 2) 
	   A1
	   ((LAMBDA (#:G3106 #:G3107 #:G3108)
	      (SETQ N #:G3106 A1 #:G3107 A2 #:G3108)
	      (GO #:G3105))
	    (1- N) (+ A1 A2) A1)))))

;; 定義 --------
;; 関数呼び出し部分をgo-to付きのlambda式で置き換え
(defun fn-to-lambda (new old expr)
  (flet ((self (x) (fn-to-lambda new old x)))
    (cond ((atom expr) expr)
	  ((and (consp expr) (eq (car expr) old))
	   (cons new (mapcar #'self (cdr expr))))
	  ('T (cons (funcall #'self (car expr)) (mapcar #'self (cdr expr)))))))

;; 関数をgo-to付きのlambda式に変換
(defun funcall-to-goto (args gotag)
  (let ((syms (mapcar (lambda (x) `(,x ,(gensym))) args)))
    `(lambda ,(mapcar #'cadr syms) (setq ,@(mapcan #'identity syms)) (go ,gotag))))

;; 余計なパラメータを削除
(defun remove-&param (expr)
  (mapcar (lambda (x) (if (consp x) (car x) x))
	  (remove-if (lambda (x) (member x '(&optional &rest &key))) expr)))

;; 本体
(defmacro tail-recursive-defun (name args &body body)
  (let ((go-tag (gensym))
	(decl (if (eq 'declare (and (consp (car body)) (caar body)))
		  `(,(pop body))
		  ())))
    `(defun ,name ,args
       ,@decl
       (prog ()
	  ,go-tag
	  (return
	    ,@(fn-to-lambda (funcall-to-goto (remove-&param args) go-tag) name 
			    body))))))
 ;

末尾再帰的DEFUN

| 02:12 | 末尾再帰的DEFUN - わだばLisperになる を含むブックマーク はてなブックマーク - 末尾再帰的DEFUN - わだばLisperになる

今日は、Arcもいじっていたのですが、なんとなくSAILのMACLISPのコードも漁っていました。

SAILのものは非常に野心的というか、変態的というか、妙なコードが多いのですが、ふと以前から気になっていたTAIL-RECURSIVE-DEFUNのコードを追っ掛けてみることにしました。

実際のコードはこちらです。

SAILの変態っぷりは、恐らくRichard P.Gabriel氏によるところが非常に大きいと思うのですが、何となくこのTAIL-RECURSIVE-DEFUNもそんな香りがします。

とりあえず、探ってみたいのは、このコードです。

(DEFUN (TAIL-RECURSIVE-DEFUN MACRO)(X)
  ((LAMBDA(?F-NAME *TYPE)
    ((LAMBDA(*ARGS *DEFINITION)
      ((LAMBDA(?GO-LABEL)
	(α-GRAB-TAILS *ARGS *DEFINITION ?GO-LABEL)
	(CCODE (DEFUN ?F-NAME *TYPE (*ARGS) (PROG NIL
						  ?GO-LABEL
						  (RETURN (PROGN *DEFINITION))))))
       (GENSYM)))
     (COND (*TYPE (CADDDR X))(T (CADDR X)))
     (COND (*TYPE (CDDDDR X))(T (CDDDR X)))))
   (CADR X)
   (COND ((MEMQ (CADDR X) '(EXPR FEXPR))
	  (LIST (CADDR X)))
	 (T NIL))))
 ;

これは一体何をするものなのか。自動で末尾再帰に変換してくれるのか。それとも他に末尾再帰的な何かの特長があるのか、謎です…。

とりあえず、もの凄くLAMBDAがネストしているのですが、これはLETの役割です。それで、DEFUNになっているのですが、MACLISPでは、DEFUNでマクロも定義でき、この場合、マクロを定義しています。

最終的には、(defun foo (n) ...body)のように展開されたものができるんじゃないかと思います。

それでこのTAIL-RECURSIVE-DEFUNが依存している関数で独自に定義されたものを追っ掛けてみます。

とりあえず、MACLISPからCLへ移植してみました。CLにないMACLISP標準は自作しています。

(DEFUN ANY-MEMQ(X Y)
  (COND ((NULL Y)NIL)
	((ATOM Y)(EQ X Y))
	(T(OR (ANY-MEMQ X (CAR Y))
	      (ANY-MEMQ X (CDR Y))))))

;(any-memq 'x '(y (((((x(((())))))))) z))
;=> t

(defmacro ccode (X) `(DO-CODE ,x))

(DEFUN DO-CODE(X)
  (COND ((NULL X)NIL)
	((ATOM X)
	 ((LAMBDA(CHAR1)
	   (COND ((MEMQ CHAR1 '(? *))X)
		 (T (LIST 'QUOTE X))))
	  (GETCHAR X 1)))
	((AND (ATOM (CAR X))(EQ '* (GETCHAR (CAR X) 1)))
	 (LIST 'APPEND (DO-CODE (CAR X)) (DO-CODE (CDR X))))
	(T(LIST 'CONS (DO-CODE (CAR X)) (DO-CODE (CDR X))))))

(DEFUN α-GRAB-TAILS (ARGS DEF ?GO-LABEL)
 (COND ((ATOM DEF)NIL)
       ((AND (ATOM(CAR DEF)) (EQ 'TAIL-RECUR (CAR DEF)))
	(COND ((EQUAL ARGS (CDR DEF))		;calling with same args!
	       (RPLACA DEF 'GO)
	       (RPLACD DEF (LIST ?GO-LABEL)))
	      (T(DO ((ARGS ARGS (CDR ARGS))
		     (NEWARGS (CDR DEF) (CDR NEWARGS))
		     (SETS NIL (NCONC SETS
				      (COND ((EQ (CAR ARGS) (CAR NEWARGS))
					     NIL)
					    (T (NCONS
						((LAMBDA(SYM)
						  (CONS (CONS (CAR ARGS)SYM)
							(LIST 'SETQ
							      (CAR ARGS)
							      (SUBLIS (MAPCAR 'CAR
									      SETS)
								      (CAR NEWARGS)))))
						 (GENSYM))))))))
		    ((NULL ARGS)
		     ((LAMBDA(L-EXP)
		       (RPLACA DEF (CAR L-EXP))
		       (RPLACD DEF (CDR L-EXP)))
		      (α-OPTIMIZE-λ (MAPCAR 'CDAR SETS)
				    (NCONC (MAPCAR 'CDR SETS)
					   (NCONS(LIST 'GO ?GO-LABEL)))
				    (MAPCAR 'CAAR SETS))))))))
       (T(MAPC (FUNCTION(LAMBDA(DEF)
			 (α-GRAB-TAILS ARGS DEF ?GO-LABEL)))
	       DEF))))

(DEFUN α-OPTIMIZE-λ (VARS BODY BINDINGS)
  (DO ((VARS VARS (CDR VARS))
       (BINDINGS BINDINGS (CDR BINDINGS))
       (NVARS NIL (NCONC NVARS
			 (COND ((ANY-MEMQ (CAR VARS) BODY)(NCONS (CAR VARS)))
			       (T NIL))))
       (NBINS NIL (NCONC NBINS
			 (COND ((ANY-MEMQ (CAR VARS) BODY)(NCONS (CAR BINDINGS)))
			       (T NIL)))))
      ((NULL VARS)(CONS (CONS 'LAMBDA (CONS NVARS BODY))
			NBINS))))

;; オリジナルに割と忠実版
(defmacro TAIL-RECURSIVE-DEFUN (&whole X &body body)
  (declare (ignore body))
  ((LAMBDA(?F-NAME *TYPE)
     ((LAMBDA(*ARGS *DEFINITION)
	((LAMBDA(?GO-LABEL)
	   `(progn
	      ,@(α-GRAB-TAILS *ARGS *DEFINITION ?GO-LABEL)
	      (DEFUN ,?F-NAME ,*TYPE (,@*ARGS) (PROG NIL
						  ,?GO-LABEL
						  (RETURN (PROGN ,@*DEFINITION))))))
	 (GENSYM)))
      (COND (*TYPE (CADDDR X))(T (CADDR X)))
      (COND (*TYPE (CDDDDR X))(T (CDDDR X)))))
   (CADR X)
   (COND ((MEMQ (CADDR X) '(EXPR FEXPR))
	  (LIST (CADDR X)))
	 (T NIL))))

;; バッサリとMACLISP特有の部分を切り捨てた版
(defmacro TAIL-RECURSIVE-DEFUN (?f-name *args &body *definition)
  (let ((?GO-LABEL (gensym)))
    `(progn
       ,(α-GRAB-TAILS *ARGS *DEFINITION ?GO-LABEL)
       (DEFUN ,?F-NAME (,@*ARGS) 
	 (PROG NIL
	    ,?GO-LABEL
	       (RETURN (PROGN ,@*DEFINITION)))))))


;; ML標準の関数達
(defun ncons (n) (list n))

(defun memq (x y)
  (member x y :test #'eq))

(defun getchar (x index)
  (values (intern (string (char (string x) (1- index))))))
 ; 

中身の動作なのですが、とりあえず、

(α-GRAB-TAILS '(x y z) '(tail-recur) 'go)
;-> ((LAMBDA () (SETQ X NIL) (SETQ Y NIL) (SETQ Z NIL) (GO GO))) 

(α-GRAB-TAILS '(x y z) '(tail-recur x) 'go)
;-> ((LAMBDA () (SETQ Y NIL) (SETQ Z NIL) (GO GO))) 

(α-GRAB-TAILS '(x y z) '(tail-recur y z x) 'go)
;-> ((LAMBDA (#:G2999) (SETQ X Y) (SETQ Y Z) (SETQ Z #:G2999) (GO GO)) X) 

(α-GRAB-TAILS '(x y z) '( y z x) 'go)
;-> (Y Z X) 

(do-code '(?foobarbaz hello one))
;(CONS ?FOOBARBAZ (CONS 'HELLO (CONS 'ONE NIL))) 

(do-code '(*foobarbaz hello one))
;(APPEND *FOOBARBAZ (CONS 'HELLO (CONS 'ONE NIL))) 

(tail-recursive-defun xyz (x y z)
  tail-recur
  (list x y z))
; マクロ展開結果
;->
(PROGN
 ((LAMBDA () (SETQ X (LIST X Y Z)) (SETQ Y NIL) (SETQ Z NIL) (GO #:G2995)))
 (DEFUN XYZ (X Y Z)
   (PROG ()
    #:G2995
     (RETURN
      (PROGN
       ((LAMBDA ()
          (SETQ X (LIST X Y Z))
          (SETQ Y NIL)
          (SETQ Z NIL)
          (GO #:G2995))))))))

という感じです。

α-OPTIMIZE-λは、どうやら不要な変数束縛を取り除いて簡略化するもののようで、これは理解できました。

これを呼び出しているα-GRAB-TAILSが良く分からないのですが、名前からすると、末尾部分を抽出するもののようなのですが、動きが良く分からない…。

何がどう末尾再帰なのか…、纏められないままエントリを終わります(笑)