読者です 読者をやめる 読者になる 読者になる

Common Lispで重複するコードを一つにまとめる

common lisp メモ

こういう重複したコードを一つにまとめたい

(defun hoge (line fn)
  (do ((line line (line-next line)))
      ((null line))
    (funcall fn line)))

(defun piyo (line fn)
  (do ((line line (line-prev line)))
      ((null line))
    (funcall fn line)))

二つのS式を渡して共通部分を変数に置き換えたS式と変数のバインディングを返す

* (defun diff-tree (x y)
    (let ((vars)
          (*gensym-counter* 1))
      (labels ((mkvar (x y)
                      (let ((var (gensym "$")))
                        (push (list var x y) vars)
                        var))
               (recur (x y)
                      (cond ((and (atom x) (atom y))
                             (if (eql x y)
                                 x
                                 (mkvar x y)))
                            ((atom x)
                             (mkvar x y))
                            ((atom y)
                             (mkvar x y))
                            (t
                             (cons (recur (car x) (car y))
                                   (recur (cdr x) (cdr y)))))))
        (let ((tree (recur x y)))
          (values tree vars)))))

* (diff-tree '(defun hoge (line fn)
                (do ((line line (line-next line)))
                    ((null line))
                  (funcall fn line)))
             '(defun piyo (line fn)
                (do ((line line (line-prev line)))
                    ((null line))
                  (funcall fn line))))

(defun #:$1 (line fn)
  (do ((line line (#:$2 line)))
      ((null line))
    (funcall fn line)))

((#:$2 line-next line-prev)
 (#:$1 hoge piyo))

変数のバインディングと共通部分を変数に置き換えた式を渡してコードを生成するマクロを書く

(defmacro with-copy-code (vars &body body)
  `(progn
     ,@(loop :for alist :in
         (loop :for i :from 1 :to (1- (apply #'min (mapcar #'length vars)))
           :collect (mapcar #'(lambda (v)
                                (cons (car v)
                                      (nth i v)))
                            vars))
         :collect (sublis alist `(progn ,@body)))))

* (macroexpand-1 '(with-copy-code ((#1=#:$1 f g)
                                   (#2=#:$2 line-next line-prev))
                    (defun #1# (line fn)
                      (do ((line line (#2# line)))
                          ((null line))
                        (funcall fn line)))))

(PROGN
 (PROGN
  (DEFUN F (LINE FN)
    (DO ((LINE LINE (LINE-NEXT LINE)))
        ((NULL LINE))
      (FUNCALL FN LINE))))
 (PROGN
  (DEFUN G (LINE FN)
    (DO ((LINE LINE (LINE-PREV LINE)))
        ((NULL LINE))
      (FUNCALL FN LINE)))))

一連の操作をする関数を書く

* (defun gen-code (x y)
    (multiple-value-bind (code vars) (diff-tree x y)
      `(with-copy-code ,vars ,code)))

* (gen-code '(defun hoge (line fn)
               (do ((line line (line-next line)))
                   ((null line))
                 (funcall fn line)))

            '(defun piyo (line fn)
               (do ((line line (line-prev line)))
                   ((null line))
                 (funcall fn line))))

(WITH-COPY-CODE ((#:$2 LINE-NEXT LINE-PREV) (#:$1 HOGE PIYO))
  (DEFUN #:$1 (LINE FN)
    (DO ((LINE LINE (#:$2 LINE))) ((NULL LINE)) (FUNCALL FN LINE))))

完成

もっとよく出来たものが既にありそう