Archive for 2010年7月19日|Daily archive page

newLISP で On Lisp する...第11章(その3)

(この blog は、“short short story または 晴耕雨読な日々”からの引越してきたもの。スクリプトは、newLISP V10.2.1 以降で動作するように書き直しています。
defun 等の newLISP組込関数に無い関数は、特に断らない限り、newlisp-utility.lsp に定義してあります。)

 第11章 古典的なマクロ も三回目。
 今回は、反復 から。
 最初のマクロforever です(do の定義は、こちらにあります)。

(define-macro (forever)
; (forever &body body)
  (letex (_body (cons 'begin (args)))
   (do ()  (nil) _body)))

 しかし、newLISP では、わざわざマクロを組む必要あありません。

(until nil  expr ・・・ )

 あるいは、

(while true  expr ・・・ )

で済みます。使うかどうかは別にして。
 newLISP 組込の反復制御構造文には、 whileuntil(マクロtillに相当)、 for の他に do-whiledo-until(それぞれ終了条件が、body部の実行後に判定される、つまり必ず一回は、body部が実行される。)があります。よほどのことが無い限り、これだけあれば十分でしょう。ということで、残りの、単純な反復用マクロ は、実装しません。すでに、do を実装し、それを使って、our-while を実装していますから、後は自明でしょう(笑)。
 ということで、部分リストに渡る再帰のためのマクロ に移ります。

(define-macro (do-tuples/o parms)
; (do-tuples/o parms source &body body)
  (if parms
    (letex (_parms parms
            _n (gensym)
            _parmslen (-- (length parms))
            _source (args 0)
            _body (cons 'begin (1 (args))))
      (map (curry apply (fn _parms _body)) 
           (0 (- (length _source) _parmslen) 
             (transpose (map (fn (_n) (_n _source))
                             (sequence 0 (length _parmslen))))))
      nil)))

 “On Lisp” 本書のマクロは、ソースとソースの cd…dr部 を用意し、mapc で部分リストを作っています。

(mapc #'(fn (x y z) (list x y z))
      '(a b c d e)
      '(b c d)
      '(c d))

 これを実現するために、mapc も用意したのですが、この形を見て思い出したんです。組込 transpose が使える、と。それで書いたのが上記マクロです。前に書いたように、map0-n は、 mapsequence の組合せで実現できます。展開式部の最後に nil があるのは、本書マクロの戻り値に合わせたものです。本書にあるように戻り値ではなく、副作用が目的ですから。
 動作はというと、

> (do-tuples/o (x y z w) '(a b c d e f) (print (list x y z w)))
(a b c d)(b c d e)(c d e f)nil
> (let (res) (do-tuples/o (x y z w) '(a b c d e f) (push (list x y z w) res -1)) res)
((a b c d) (b c d e) (c d e f))
> (let (res) (catch (do-tuples/o (x y z w) '(a b c d e f) (if (= x 'b) (throw (list x y z w)))) 'res) res)
(b c d e)

 return の代わりに catchthrow が使えます。
 マクロdo-tuples/c は、transpose を使うことで、補助関数すら要りません。

(define-macro (do-tuples/c parms)
; (do-tuples/o parms source &body body)
  (if parms
    (letex (_parms parms
            _n (gensym)
            _parmslen (-- (length parms))
            _source (args 0)
            _srclen (length (eval (args 0)))
            _body (cons 'begin (1 (args))))
      (when (< _parmslen _srclen)
        (map (curry apply (fn _parms _body)) 
             (0 _srclen (transpose (map (fn (_n) (_n (append _source (0 _parmslen _source))))
                                   (sequence 0 (length _parmslen))))))
      nil))))

 動作は、

> (do-tuples/c (x y z w) '(a b c d e f) (print (list x y z w)))
(a b c d)(b c d e)(c d e f)(d e f a)(e f a b)(f a b c)nil

 どちらも、引数が1個なら、 dolist と同じです。

> (do-tuples/o (x) '(a b c) (print x))
abcnil
> (do-tuples/c (x) '(a b c) (print x))
abcnil

 同じ引数に対しては、

> (do-tuples/o (x y z w) '(a b c d) (print (list x y z w)))
(a b c d)nil
> (do-tuples/c (x y z w) '(a b c d) (print (list x y z w)))
(a b c d)(b c d a)(c d a b)(d a b c)nil

 となります。mapc の実装については、後述します。

 さて、今回のメイン・イベント、複数の値に渡る反復 です。
 newLISP には、多値の戻り値を返す機能はありません。values と multiple-value-bind も既に定義しましたが、ここでは、values の代わりに list と使います。
 そして、すでに do と do* は、定義できていますから、あとは、mvsetq と mvpsetq が用意するだけです。
 前置きが長くなりましたが、mvpseq から。もちろん、破壊的ですから、マクロです
(labels と psetq は、newlisp-utility.lsp で定義してあります)。

(define (add-c lst)
  (labels ((add/c (x) (if (symbol? x) (letex (_x x) ''_x) x)))
    (if (atom? lst) (add/c lst)
      (let (res)
        (map (fn (x) (push (add/c x) res -1)) lst)
      res)))) 

(define (mvbind-c)
  (letex 
    (_vars (let (res)
      (dolist (v (explode (args 0) 2))
        (setf (v 1) (add-c (eval $it)))
        (if (list? (v 0))
            (push (transpose v) res -1)
          (push v res -1)))
      (flat res)))
    '_vars))

(define-macro (mvpsetq)
  (letex (_args (cons 'psetq (mvbind-c (args))))
    _args))

 補助関数mvbind-c を使って、見通しを良くしているつもりです(笑)。本当は、別の目論見もあったのですが(汗)。マクロの説明の前に動作を見てもらいましょう。
 例によって、展開式を表示させます。

> (mvpsetq x 1 (z w) (list 3 4) y 2)
(psetq x 1 z 3 w 4 y 2)
> (let ((w 0) (x 1) (y 2) (z 3)) (mvpsetq (w x) (list 'a 'b) (y z) (list w x)))
(psetq w 'a x 'b y 0 z 1)

 どうです、所望の展開になっているでしょう。もちろん、展開式用のカンマを外して、実行すれば、

> (let ((w 0) (x 1) (y 2) (z 3)) (mvpsetq (w x) (list 'a 'b) (y z) (list w x)) (list w x y z))
(a b 0 1)

 となります。values の代わりに list を使っているので、

> (let ((w 0) (x 1) (y 2) (z 3)) (mvpsetq (w x) '(a b) (y z) (list w x)) (list w x y z))
(a b 0 1)

 という形式でも使えます(笑)。
 これで、マクロmvdo を実装できます(hayashi と mappend は、newlisp-utility.lsp で定義してあります)。

(define-macro (mvdo)
  (letex (_init (flat (map first (args 0)))
          _initset (cons 'mvpsetq (mappend (hayashi select '(0 1)) (args 0)))
          _steps   (cons 'mvpsetq (mappend (hayashi select '(0 2)) (args 0)))
          _results (cons 'begin (rest (args 1)))
          _end-test (first (args 1))
          _body (cons 'begin (2 (args))))
     (local _init
       _initset
       (until _end-test
         _body
         _steps)
       _results)))

 あっけなく終わります。本書の動作例、

(mvdo ((x 1 (++ x))
      ((y z) (values 0 0) (list z x)))
      ((> x 5) (list x y z))
      (print (list x y z)))

 の結果は、

(1 0 0)(2 0 1)(3 1 2)(4 2 3)(5 3 4)(6 4 5)

 となります。
 そして、本書にはない(笑)、マクロmvsetq は

(define-macro (mvsetq)
  (dolist (v (explode (args) 2))
    (setf (v 1) (add-c (eval $it)))
    (if (list? (v 0))
        (eval (cons 'begin (map (curry append '(setq)) (transpose v))))
      (eval (cons 'setq v)))))

 となります。こちらは、マクロmvpsetq とうってかわって引数を順に評価していきます。引数を評価せずに受け取るためだけにマクロ機能を利用しています。Common Lispなら、マクロにする必要はないのですが(泣)。
 そして、マクロmvdo* は、

(define-macro (mvdo*)
  (letex (_init (flat (map first (args 0)))
          _initset (cons 'mvsetq (mappend (hayashi select '(0 1)) (args 0)))
          _steps   (cons 'mvsetq (mappend (hayashi select '(0 2)) (args 0)))
          _results (cons 'begin (rest (args 1)))
          _end-test (first (args 1))
          _body (cons 'begin (2 (args))))
   (let _init
     _initset
     (until _end-test
       _body
       _steps)
     _results)))

 となります。マクロmvdo の mvpsetq が、mvsetq に変わっただけですけどね。mvsetq と mvpsetq の実装で苦労した分、mvdo と mvdo* は楽に実装できたってことです(笑)。
 さて、動作例

(mvdo* ((x 1 (++ x))
       ((y z) (list 0 0) (list z x)))
       ((> x 5) (list x y z))
       (print (list x y z)))

 の結果は、

(1 0 0)(2 0 2)(3 2 3)(4 3 4)(5 4 5)(6 5 6)

 となり、所望のリストを得ます。
 また、関数shuffle は使っていませんが、面白そうなので実装してみました(defun、null と t は、newlisp-utility.lsp で定義してあります)。

(defun shuffle (x y)
  (cond ((null x) y)
        ((null y) x)
        (t (append (list (first x) (first y))
                   (shuffle (rest x) (rest y))))))

 動作は、

> (shuffle '(a b c) '(1 2 3 4))
(a 1 b 2 c 3 4)

 となります。

 さて、第11章 古典的なマクロ もいよいよ、最後、マクロの必要性 です。
 関数版if は、こうなります。

(defun fnif (test then else)
  (if test
      (then)
    (if else (else))))

 そうすれば、

(if (rich) (employ-lisper) (write-script))

 は、

(fnif (rich)
      (fn () (employ-lisper))
   (fn () (write-script)))

 と書けます(笑)。こんな例よりも、本書にある 引数の式の中身を切り分けたり,引数として渡された変数を束縛するためにはマクロが必要になる ということは、newLISPでも同じで、重要です。そして、反復構造についても、同様ですが、反復制御構造の豊富なnewLISP の方がマクロが軽くなるという点で有利かもしれませんね。
 さて、おまけに、newLISP には無い mapc を実装しましょう。

(defun mapc (f)
  (let (lsts (args))
    (dotimes (i (apply min (map length lsts)))
      (apply f (map (curry nth i) lsts)))))

 という風に関数で実装できます。
 動作は、

(mapc (fn (x y z) (print (list x y z)) nil)
      '(a b c d e)
      '(b c d)
      '(c d))

 が、

(a b c)(b c d)nil

 となります。

 第11章 古典的なマクロ まとめです。

  • newLISPには、反復構造制御文が豊富にあるので、do が必要になることは、めったに、ありません。
  • with-系マクロのエラー回避には、catch & throw が使えます。
  • newLISP の組込 or、and には、apply を適用できます。
  • Common Lispでは、マクロが必要なものでも、newLISP では、関数で済む場合があります。もちろん、その逆もあります。

 以上、如何でしょうか?

広告