diff options
Diffstat (limited to 'configs/shared/emacs/.emacs.d/elpa/circe-20180525.531/lcs.el')
| -rw-r--r-- | configs/shared/emacs/.emacs.d/elpa/circe-20180525.531/lcs.el | 202 |
1 files changed, 202 insertions, 0 deletions
diff --git a/configs/shared/emacs/.emacs.d/elpa/circe-20180525.531/lcs.el b/configs/shared/emacs/.emacs.d/elpa/circe-20180525.531/lcs.el new file mode 100644 index 000000000000..b5beb12ef145 --- /dev/null +++ b/configs/shared/emacs/.emacs.d/elpa/circe-20180525.531/lcs.el @@ -0,0 +1,202 @@ +;;; 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/jorgenschaefer/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 |