lcs.el

;;; lcs.el --- find out the longest common sequence

;;   Copyright (c) 2002-2003 by Alex Shinn, All rights reserved.
;;   Copyright (c) 2002-2003 by Shiro Kawai, All rights reserved.
;;   Copyright (c) 2006, 2012 by Jorgen Schaefer, All rights reserved.

;; Authors: Alex Shinn, Shiro Kawai
;; Maintainer: Jorgen Schaefer <forcer@forcix.cx>
;; URL: https://github.com/emacs-circe/circe/wiki/lcs

;;   Redistribution and use in source and binary forms, with or without
;;   modification, are permitted provided that the following conditions
;;   are met:

;;   1. Redistributions of source code must retain the above copyright
;;      notice, this list of conditions and the following disclaimer.

;;   2. Redistributions in binary form must reproduce the above copyright
;;      notice, this list of conditions and the following disclaimer in the
;;      documentation and/or other materials provided with the distribution.

;;   3. Neither the name of the authors nor the names of its contributors
;;      may be used to endorse or promote products derived from this
;;      software without specific prior written permission.

;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;;; Commentary:

;; lcs.el is a library for other Emacs Lisp programs not useful by
;; itself.

;; This library provides functions to find the Longest Common Sequence
;; (LCS) of two sequences. This is used to create a unified diff of to
;; two lists. See `lcs-unified-diff' for a useful function to be
;; called.

;; The code is more or less a literal translation of (part of)
;; Gauche's util/lcs.scm module to Emacs Lisp.

;;; Code:

(put 'lcs-for 'lisp-indent-function 4)
(defmacro lcs-for (var from to step &rest body)
  "A simple FOR loop macro.
Count VAR from FROM to TO by stepsize STEP. Evaluate BODY in each
iteration."
  (let ((sto (make-symbol "to"))
        (sstep (make-symbol "step")))
    `(let ((,var ,from)
           (,sto ,to)
           (,sstep ,step))
       (while (<= ,var ,sto)
         (progn
           ,@body)
         (setq ,var (+ ,var ,sstep))))))

(defun lcs-split-at (lis pos)
  "Return a cons cell of the first POS elements of LIS and the rest."
  (let ((head nil))
    (while (> pos 0)
      (setq head (cons (car lis)
                       head)
            pos (- pos 1)
            lis (cdr lis)))
    (cons (reverse head)
          lis)))

(defun lcs-finish (M+N V_l vl V_r vr)
  "Finalize the LCS algorithm.
Should be used only by `lcs-with-positions'."
  (let ((maxl 0)
        (r '()))
    (lcs-for i (- M+N) M+N 1
      (when (> (funcall vl i)
               maxl)
        (setq maxl (funcall vl i)
              r (funcall vr i))))
    (list maxl (reverse r))))

(defun lcs-with-positions (a-ls b-ls &optional equalp)
  "Return the longest common subsequence (LCS) of A-LS and B-LS.
EQUALP can be any procedure which returns non-nil when two
elements should be considered equal."
  (let* ((A (vconcat a-ls))
         (B (vconcat b-ls))
         (N (length A))
         (M (length B))
         (M+N (+ M N))
         (V_d (make-vector (+ 1 (* 2 M+N))
                           0))
         (V_r (make-vector (+ 1 (* 2 M+N))
                           nil))
         (V_l (make-vector (+ 1 (* 2 M+N))
                           0))
         (vd (lambda (i &optional x)
               (if x
                   (aset V_d (+ i M+N) x)
                 (aref V_d (+ i M+N)))))
         (vr (lambda (i &optional x)
               (if x
                   (aset V_r (+ i M+N) x)
                 (aref V_r (+ i M+N)))))
         (vl (lambda (i &optional x)
               (if x
                   (aset V_l (+ i M+N) x)
                 (aref V_l (+ i M+N))))))
    (when (not equalp)
      (setq equalp 'equal))
    (catch 'return
      (if (= M+N 0)
          (throw 'return '(0 ()))
        (lcs-for d 0 M+N 1
          (lcs-for k (- d) d 2
            (let ((x nil)
                  (y nil)
                  (l nil)
                  (r nil))
              (if (or (= k (- d))
                      (and (not (= k d))
                           (< (funcall vd (- k 1))
                              (funcall vd (+ k 1)))))
                  (setq x (funcall vd (+ k 1))
                        l (funcall vl (+ k 1))
                        r (funcall vr (+ k 1)))
                (setq x (+ 1 (funcall vd (- k 1)))
                      l (funcall vl (- k 1))
                      r (funcall vr (- k 1))))
              (setq y (- x k))
              (while (and (< x N)
                          (< y M)
                          (funcall equalp (aref A x) (aref B y)))
                (setq r (cons (list (aref A x) x y)
                              r)
                      x (+ x 1)
                      y (+ y 1)
                      l (+ l 1)))
              (funcall vd k x)
              (funcall vr k r)
              (funcall vl k l)
              (when (and (>= x N)
                         (>= y M))
                (throw 'return(lcs-finish M+N V_l vl V_r vr)))))))
      (error "Can't happen"))))

(defun lcs-unified-diff (a b &optional equalp)
  "Return a unified diff of the lists A and B.
EQUALP should can be a procedure that returns non-nil when two
elements of A and B should be considered equal. It's `equal' by
default."
  (let ((common (cadr (lcs-with-positions a b equalp)))
        (a a)
        (a-pos 0)
        (b b)
        (b-pos 0)
        (diff '()))
    (while common
      (let* ((elt (car common))
             (a-off (nth 1 elt))
             (a-skip (- a-off a-pos))
             (b-off (nth 2 elt))
             (b-skip (- b-off b-pos))
             (a-split (lcs-split-at a a-skip))
             (a-head (car a-split))
             (a-tail (cdr a-split))
             (b-split (lcs-split-at b b-skip))
             (b-head (car b-split))
             (b-tail (cdr b-split)))
        (setq diff (append diff
                           (mapcar (lambda (a)
                                     `(- ,a))
                                   a-head)
                           (mapcar (lambda (b)
                                     `(+ ,b))
                                   b-head)
                           `((! ,(car elt))))

              common (cdr common)
              a (cdr a-tail)
              a-pos (+ a-off 1)
              b (cdr b-tail)
              b-pos (+ b-off 1))))
    (append diff
            (mapcar (lambda (a)
                      `(- ,a))
                    a)
            (mapcar (lambda (b)
                      `(+ ,b))
                    b))))

(provide 'lcs)
;;; lcs.el ends here