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

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

さて、第４章 の 検索 です。
リストを検索する関数 は、こうなります。

(defun before (x y lst (test =))
  (and lst
       (let ((first-a (car lst)))
         (cond ((test y first-a) nil)
               ((test x first-a) lst)
               (t (before x y (cdr lst) test))))))

(defun member+ (key lst (test =))
  (let (i (find key lst test))
    (and i (i lst))))

(defun after (x y lst (test =))
  (let (rest-a (before y x lst test))
    (and rest-a (member+ x rest-a test))))

(defun duplicate (obj lst (test =))
  (member+ obj (cdr (member+ obj lst test)) test))

(defun split-if (f lst)
  (let (acc)
    (do ((src lst (cdr src)))
      ((or (null src) (f (car src)))
       (values acc src))
      (push (car src) acc -1))))

関数find2 は、第４章（その１）に掲載していますので、割愛します。本文のスクリプトからfuncall を外しただけですし。もちろん、それだけで済んでいるのは、newlisp-utility.lsp の定義を使っているからです。また、values の定義は、こちらにあります。
関数before も、funcall を外してあります。また、first と rest は、newLISP の組込関数なので、それぞれ、first-a と rest-a に変えてあります。
そして、&key オプション。CommonLisp の &key オプションは、便利ですよね。引数の位置によらず、特定の引数を指定できますから。残念ながら、newLISP に、この引数オプションはありません。だからといって、引数の位置によらない特定引数の束縛ができないかというと、これができます。もちろん、内部変数としてですよ。以前、解説した内容がこちらにあります。
ここでは &key オプションが一つだけなので、newLISP お得意の暗黙の引数という形（つまり、引数をつけなくても、文句を言われない)で対応します。デフォルトの 判定条件は、= です。newLISP では、eq、eql、equal の区別がありません。全て、= で対応します。
では、動作を。

> (before 'a 'b '(a b c d))
(a b c d)
> (before 'a 'b '(a))
(a)
> (before 'b 'a '(a b c d))
nil
> (before 'A 'B '(a b A B))
(A B)

また、本文にある素の Lisp による表現の関数position はありませんが、組込関数find で代用できます。

> (< (find 'a '(a b c d)) (find 'b '(a b c d)))
true

といった感じです。
次の、関数before で使われている関数member は、newLISPにもありますが、判定条件の指定ができません。そこで、CommonLisp互換っぽい関数member+ を用意して、使っています。
後の変更点は、関数before と一緒です。では、動作を。

> (after 'a 'b '(b a d))
(a d)
> (after 'a 'b '(a))
nil
> (after 'a 'b '(b))
nil

この程度の動作なら、関数member+ は要らないですけどね。
次の関数duplicate でも、関数member+ を使っています。&key オプションの扱いは、前述の関数と同じです。
では、動作を、

> (duplicate 'a '(a b c a d a c))
(a b a c)
> (duplicate 'a '(a b c e d))
nil

さて、リスト検索 の最後は、関数split-if 。毎度おなじみ、内部変数の初期値nil と funcall を外します。もちろん、fn の変名も必要です。
do と values は、以前に定義したものを使います。
あとは、newlisp-utility.lsp での定義が補ってくれます。
もちろん、組込push の末尾挿入を使って、reverse を省いています。
では、動作を、

> (split-if (fn (x) (> x 4)) '(1 2 3 4 5 6 7 8 9 10))
(1 2 3 4)
> (multiple-value-list (split-if (fn (x) (> x 4)) '(1 2 3 4 5 6 7 8 9 10)))
((1 2 3 4) (5 6 7 8 9 10))
> (multiple-value-list (split-if (fn (x) (> x 4)) (sequence 1 10)))
((1 2 3 4) (5 6 7 8 9 10))
> (multiple-value-list (split-if (fn (x) (> x 4)) (sequence 10 1)))
(nil (10 9 8 7 6 5 4 3 2 1))

戻り値に values を使っていますので、全ての戻り値を見るのに multiple-value-list を使っています。組込sequence は、等差数列のリストを返します。こういう場合に便利です。
ちなみに、values 以外を newLISP だけ書くと

(define (split-if f lst)
  (or (dolist (i lst (and (f i)
                     (values (0 $idx lst) ($idx lst)))))
      (values lst '())))

こんな感じです（笑）。
さて、引き続き、要素を比較する検索関数 は、こうなります。

(define let* letn)
(defun most (f lst)
  (if (null lst)
      (values nil nil)
    (let* ((wins (car lst))
           (max-i (f wins)))
      (dolist (obj (cdr lst))
        (let ((score (f obj)))
          (when (> score max-i)
            (setq wins obj
                  max-i score))))
      (values wins max-i))))

(defun best (f lst)
  (if (null lst)
      nil
    (let ((wins (car lst)))
      (dolist (obj (cdr lst))
        (if (f obj wins)
            (setq wins obj)))
      wins)))

(defun mostn (f lst)
  (if (null lst)
      (values nil nil)
    (let ((result (list (car lst)))
          (max-i (f (car lst))))
      (dolist (obj (cdr lst))
        (let ((score (f obj)))
          (cond ((> score max-i)
                 (setq max-i score
                       result (list obj)))
                ((= score max-i)
                 (push obj result -1)))))
      (values result max-i))))

では、関数most から。
その前に、let* を定義しています。newLISP組込の letn に置き換えるだけですが（笑）。
後は、いつものように、funcall を外し、fn を変名します。また、newLISPには、組込関数max （もちろん、min も）がありますから、内部変数max も max-i に直します。
動作はというと、

> (most length '((a b) (a b c) (a) (e f g)))
(a b c)
> (multiple-value-list (most length '((a b) (a b c) (a) (e f g))))
((a b c) 3)
> (most length '((a b) (a b c) (a) (d e f g)))
(d e f g)
> (multiple-value-list (most length '((a b) (a b c) (a) (d e f g))))
((d e f g) 4)

さて、関数best は、funcall を外し、fn を変名するだけ。
動作は、

> (best > '(3 4 1 5 2))
5
> (best < '(3 4 1 5 2))
1

次に、関数mostn 。これまでの変更と同様です。reverse も省いています。
動作は、こうなります。

> (mostn length '((a b) (a b c) (a) (e f g)))
((a b c) (e f g))
> (multiple-value-list (mostn length '((a b) (a b c) (a) (e f g))))
(((a b c) (e f g)) 3)
> (mostn length '((a b) (a b c) (a) (d e f g)))
((d e f g))
> (multiple-value-list (mostn length '((a b) (a b c) (a) (d e f g))))
(((d e f g)) 4)
> (mostn length '())
nil
> (multiple-value-list (mostn length '()))
(nil nil)

切りがいいので、マッピング からは、次回に。

以上、如何でしょうか？