newLISP で On Lisp する．．．第１５章（その２）

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

　第１５章 関数を返すマクロ 。今回は、Cdr 部での再帰 です。
　まず、リストでの再帰のためのマクロ を実装します（gensym と second は newlisp-utility.lsp に、functionp と lrec は、onnewlisp.lsp に定義してあります）。

(define-macro (alrec)
; (alrec rec base)
(let (gfn (gensym))
  (letex (_gfn gfn
          _recbody (replace 'rec (args 0) (list gfn))
          _base (second (args)))
    (lrec (fn (it _gfn) _recbody)
           _base))))

(define-macro (on-cdrs)
; (on-cdrs rec base &rest lsts)
  (letex (_rec (args 0)
          _base (args 1)
          _lsts (third (args)))
  ((alrec _rec (fn () _base)) _lsts)))

　lrec は、onnewlisp.lsp に定義してあるといっても、動作には、newlisp-utility.lsp が必要です。
　拙作関数include を使って、読み込んでおくと、便利です。（定義は、こちらから）
　マクロalrec は、”cltl2 version” バージョンです。newLISP 組込replace を次回紹介する rreplace にした方が良いかもしれませんが、“On Lisp”本書の例を動かすには、これで十分です。
　alrec の動作は（car、cdr、oddp、t は newlisp-utility.lsp に定義してあります）、

> (alrec (and (oddp it) rec) t)
(lambda (lst) 
 (if (null lst) 
  (if (functionp 'true) 
   (true) 'true) 
  ((lambda (it gensym1) (and (oddp it) (gensym1))) (car lst) (lambda () (self-r (
      cdr lst))))))
> ((alrec (and (oddp it) rec) t) '(1 3 5))
true
> ((alrec (and (oddp it) rec) t) '(1 2 5))
nil
> 

　”cltl2 version” バージョンですから、rec を括弧で括る必要はありません。
　on-cdrs の例では、Common Lisp の関数 から（defun は newlisp-utility.lsp に定義してあります）、

(defun our-length (lst)
  (on-cdrs (++ rec) 0 lst))

(defun our-every (f lst)
  (on-cdrs (and (f it) rec) t lst))

(defun our-copy-list (lst)
  (on-cdrs (cons it rec) '() lst))

(define adjoin (fn (obj lst) (if (member obj lst) lst (cons obj lst))))
(defun our-remove-duplicates (lst)
  (on-cdrs (adjoin it rec) '() lst))

(defun our-find-if (f lst)
  (on-cdrs (if (f it) it rec) nil lst))

(defun our-some (f lst)
  (on-cdrs (or (f it) rec) nil lst))

　length 以外は、newLISP に無いので our- は要らないですけどね（笑）。例によって、fn は f に代えてあります。また、newLISPには、関数adjoin が無いので一緒に定義しています。しかし、remove-duplicates の実装に remove を使わず adjoin を使うという発想はすごいですね。ちなみに、Common Lisp の every、some、remove-duplicates は、newLISP では、for-all、exists、unique に相当します。
　せっかくですから、いくつか動作させて見ましょう。

> (our-length '(1 2 3))
3
> (our-every oddp '(1 3 5))
true
> (our-every oddp '(1 2 5))
nil
> (our-some oddp '(1 2 4))
true
> (our-some oddp '(0 2 4))
nil
> (our-find-if oddp '(0 2 4))
nil
> (our-find-if oddp '(0 2 1))
1
> (our-remove-duplicates '(a b c d))
(a b c d)
> (our-remove-duplicates '(a b c a))
(b c a)
> 

　そして、新しいユーティリティ の方です。

(define union (fn (lst0 lst1) (unique (append lst0 lst1))))
(defun unions ()
  (let (sets (args))
    (on-cdrs (union rec it) (first sets) (rest sets))))

(defun intersections ()
  (let (sets (args))
    (unless (our-some null sets)
      (on-cdrs (intersect it rec) (first sets) (rest sets)))))

(defun differences ()
  (let (sets (args))
    (on-cdrs (difference rec it) (first sets) (rest sets))))

(defun maxmin (_args)
  (when _args
    (on-cdrs ((fn (i l) (list (max i (l 0)) (min i (l 1)))) it rec)
             (list (first _args) (first _args))
             (rest _args))))

　newLISP には、union がありませんので、newLISP 組込 unique を使って実装しています。Common Lisp の intersection は、newLISP では intersect に相当します。関数difference は、なぜか両者同じ名前です（笑）。
　また、newLISP には、多値がありませんので、multiple-value-bind と values の動作を別な形で実装しています。こちらの方が、on-cdrs の動作を把握しやすいと思うのですが、どうでしょう？
　では、動作を見てみましょう。

> (union '(a b) '(b c))
(a b c)
> (unions '(a b) '(b c) '(c d))
(a b c d)
> (intersections '(a b c) '(a b d) '(c a b))
(a b)
> (differences '(a b c d e) '(a f) '(d))
(b c e)
> (maxmin '(3 4 2 8 5 1 6 7))
(8 1)
> 

　ちなみに、unions を実装するには、わざわざ on-cdrs を使わなくても、

> (defun unions () (unique (apply append (args))))
(lambda () (unique (apply append (args))))
> (unions '(a b) '(b c) '(c d))
(a b c d)
> 

　で済みます。
　Common Lisp なら、

(defun unions (&rest args)
   (remove-duplicates (apply #'append args)))

　こんな感じ。ま、on-cdrs のテストですから（笑）。

　さて、部分ツリーでの再帰 からは次回に。

　以上、如何でしょうか？