組（tuple）を扱うためのユーティリティ

『On Lisp』の原著を半分くらいまで読んだ。とても面白い。プログラム自体もそうだけど、文章にも味があって。
さて、その本に載っていた do-tuple とその亜種のマクロがけっこう複雑で、コードを理解する前に自分で同じ動作のものを作ったりした、というのが今回のネタ。
with-gensyms は有名なマクロ。第１引数に渡されたリスト中のシンボルそれぞれに gensym して、本体部分で使えるようにする。extend は第１引数のリストを、第２引数のぶんだけ延長する。伸びた部分はもとのリストの繰り返しとなる。以上２つは実装のためのユーティリティ。
メインの map-tupple と do-tupple は、どちらも引数に与えられたリストから連続する組を作って、それに対して関数を呼んだり手続きをしたりする。前者は組の長さを指定する必要がある。
派生品の名前の最後に"/c"がついているのは循環的（circular）ということで、与えられたリストの末端が最初につながっているかのように動作する。具体的なことは使用例を見ていただければ一目瞭然だろう。

コード：

(defmacro with-gensyms (syms &body body)
  `(let ,(mapcar #'(lambda (s)
		     `(,s (gensym)))
		 syms)
     ,@body))

(defun extend (lst len)
  (let ((res (subseq lst 0 (mod len (length lst)))))
    (dotimes (i (1+ (floor (/ len (length lst)))))
      (setq res (append lst res)))
    res))


(defun map-tuple (fn num lst)
  (do ((rest lst (cdr rest))
       (len (length lst) (1- len))
       (acc nil))
      ((< len num) (nreverse acc))
    (push (apply fn (subseq rest 0 num))
          acc)))

(defmacro do-tuple (params lst &body body)
  (with-gensyms (rest len num)
    `(do ((,rest ,lst (cdr ,rest))
          (,len (length ,lst) (1- ,len))
          (,num (length ',params)))
         ((< ,len ,num))
       (destructuring-bind ,params (subseq ,rest 0 ,num)
         ,@body))))


(defun map-tuple/c (fn num lst)
  (let (acc)
    (do* ((rest (extend lst (1- num)) (cdr rest))
          (len (length rest) (1- len)))
         ((< len num))
      (push (apply fn (subseq rest 0 num))
            acc))
    (nreverse acc)))

(defmacro do-tuple/c (params lst &body body)
  (with-gensyms (num rest len)
    `(do* ((,num (length ',params))
           (,rest (extend ,lst (1- ,num))
                  (cdr ,rest))
           (,len (length ,rest) (1- ,len)))
          ((< ,len ,num))
       (destructuring-bind ,params (subseq ,rest 0 ,num)
         ,@body))))

使用例：

CL-USER> (map-tuple #'list 3 '(a b c d e))
((A B C) (B C D) (C D E))
CL-USER> (map-tuple/c #'list 3 '(a b c d e))
((A B C) (B C D) (C D E) (D E A) (E A B))
CL-USER> (do-tuple (x y z) '(a b c d e)
           (print (list x y z)))

(A B C) 
(B C D) 
(C D E) 
NIL
CL-USER> (do-tuple/c (x y z) '(a b c d e)
           (print (list x y z)))

(A B C) 
(B C D) 
(C D E) 
(D E A) 
(E A B) 
NIL