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

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

　第１５章 関数を返すマクロ 。今回は、部分ツリーでの再帰 です。
　ツリーに対する再帰のためのマクロ を newLISP で実装する前に、前回予告した関数rreplace です。

(define rreplace set-ref-all)

　関数rrpelace は、階層化されたリスト中の要素も置き換えまるのですが、newLISP では組込関数set-ref-all だったのですね（汗）。

> (set-ref-all 'x '(a (b x) d) 'c)
(a (b c) d)
> 

　前の時は、それに気付かず、関数rrpelace を実装した私（汗）。なんと回り道をしたことか（嘆）。
　気を取り直して、ツリーに対する再帰のためのマクロ を実装します
（gensym は newlisp-utility.lsp に、trec は onnewlisp.lsp に定義してあります）。

(define-macro (atrec rec (base 'it)) 
; (atrec  rec &optional (base 'it))
  (let (lfn (gensym)
        rfn (gensym))
    (letex (_lfn lfn
            _rfn rfn
            _recbody (set-ref-all
                       'right 
                       (set-ref-all 'left rec (list lfn)) 
                       (list rfn))
            _base base)
      (trec (fn (it _lfn _rfn) _recbody )
        (fn (it) _base)))))

(define-macro (on-trees)
; (on-cdrs rec base &rest tress)
  (letex (_rec (args 0)
          _base (args 1)
          _trees (third (args)))
    ((atrec _rec _base) _trees)))

　マクロatrec は、もちろん、”cltl2 version”バージョンです。
　動作は、（oddp は、newlisp-utility.lsp に定義してあります）

> (atrec (or left right) (and (oddp it) it))
(lambda (tree) 
 (if (atom tree) 
  (if (functionp '(lambda (it) (and (oddp it) it))) 
   ((lambda (it) (and (oddp it) it)) tree) 
   (MACRO? '(lambda (it) (and (oddp it) it))) 
   (eval ((lambda (it) (and (oddp it) it)) tree)) '(lambda (it) (and (oddp it) it))) 
  ((lambda (it gensym1 gensym2) (or (gensym1) (gensym2))) tree (lambda () (self-r 
     (first tree))) 
   (lambda () 
    (if (rest tree) 
     (self-r (rest tree))))))) 
> 

　そして、on-trees を使って定義した関数 です。

(defun our-copy-tree (tree)
  (on-trees (cons left right) it tree))

(defun count-leaves (tree)
  (on-trees (+ left (or right 0)) 1 tree)) ;if Common Lisp (or right 1)

(defun flatten (tree)
  (on-trees (append left right) (mklist it) tree))

(defun rfind-if (f tree)
  (on-trees (or left right)
            (and (f it) it)
            tree))

いくつか動作させて見ましょう。

> (our-copy-tree '(1 2))
(1 2)
> (count-leaves '((a b (c d)) (e) f))
6
> (flatten '((a b (c d)) (e) f ))
(a b c d e f)
> (rfind-if oddp '(2 (3 4) 5))
3
> 

　count-leaves が 10 ではなく 6 を返すのは、バグではありません。仕様です（笑）。

　切りがいいので、遅延評価 は次回に。

　以上、如何でしょうか？

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 のテストですから（笑）。

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

　以上、如何でしょうか？