/[meta-cvs]/meta-cvs/F-C8A05CD5CF4264BADFA19C8E232CF00C
ViewVC logotype

Contents of /meta-cvs/F-C8A05CD5CF4264BADFA19C8E232CF00C

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14 - (show annotations)
Fri Nov 24 04:53:50 2006 UTC (7 years, 4 months ago) by kaz
Branch: MAIN
CVS Tags: asdf-import-branch~merged-to-HEAD-0, mcvs-1-1-98, asdf-import-branch~branch-point, HEAD
Branch point for: asdf-import-branch
Changes since 1.13: +1 -1 lines
Stylistic change.

* code/add.lisp: Change in-package calls not to use the all-caps
"META-CVS" string string, but rather the :meta-cvs keyword.
* code/branch.lisp: Likewise.
* code/chatter.lisp: Likewise.
* code/checkout.lisp: Likewise.
* code/clisp-unix.lisp: Likewise.
* code/cmucl-unix.lisp: Likewise.
* code/convert.lisp: Likewise.
* code/create.lisp: Likewise.
* code/dirwalk.lisp: Likewise.
* code/error.lisp: Likewise.
* code/execute.lisp: Likewise.
* code/filt.lisp: Likewise.
* code/find-bind.lisp: Likewise.
* code/generic.lisp: Likewise.
* code/grab.lisp: Likewise.
* code/link.lisp: Likewise.
* code/main.lisp: Likewise.
* code/mapping.lisp: Likewise.
* code/memoize.lisp: Likewise.
* code/move.lisp: Likewise.
* code/multi-hash.lisp: Likewise.
* code/options.lisp: Likewise.
* code/paths.lisp: Likewise.
* code/print.lisp: Likewise.
* code/prop.lisp: Likewise.
* code/purge.lisp: Likewise.
* code/rcs-utils.lisp: Likewise.
* code/remap.lisp: Likewise.
* code/remove.lisp: Likewise.
* code/restart.lisp: Likewise.
* code/restore.lisp: Likewise.
* code/seqfuncs.lisp: Likewise.
* code/slot-refs.lisp: Likewise.
* code/split.lisp: Likewise.
* code/sync.lisp: Likewise.
* code/types.lisp: Likewise.
* code/unix.lisp: Likewise.
* code/update.lisp: Likewise.
* code/watch.lisp: Likewise.
1 ;;; This source file is part of the Meta-CVS program,
2 ;;; which is distributed under the GNU license.
3 ;;; Copyright 2002 Kaz Kylheku
4
5 (in-package :meta-cvs)
6
7 (defun separate-if (test sequence &rest keys)
8 (let ((wheat (apply #'remove-if-not test sequence keys))
9 (chaff (apply #'remove-if test sequence keys)))
10 (values wheat chaff)))
11
12 (defun separate (item sequence &key (test #'eql) key)
13 (let ((wheat (funcall #'remove-if-not #'(lambda (x) (funcall test item x))
14 sequence :key key))
15 (chaff (funcall #'remove item sequence :key key :test test)))
16 (values wheat chaff)))
17
18 (define-memoized-function lcs-list ((list-1 :test #'eq)
19 (list-2 :test #'eq)
20 &key (test #'eql))
21 (cond
22 ((null list-1) nil)
23 ((null list-2) nil)
24 ((funcall test (first list-1) (first list-2))
25 (cons (first list-1) (lcs-list (rest list-1) (rest list-2))))
26 (t (let ((lcs-1 (lcs-list list-1 (rest list-2)))
27 (lcs-2 (lcs-list (rest list-1) list-2)))
28 (if (> (length lcs-1) (length lcs-2))
29 lcs-1
30 lcs-2)))))
31
32 (defun lcs-vector (vec-1 vec-2 &key (test #'eql))
33 (let ((list-1 (coerce vec-1 'list))
34 (list-2 (coerce vec-2 'list)))
35 (coerce (lcs-list list-1 list-2 :test test) 'vector)))
36
37 (defun longest-common-subsequence (seq-1 seq-2 &key (test #'eql))
38 (etypecase seq-1
39 (list (lcs-list seq-1 seq-2 :test test))
40 (vector (lcs-vector seq-1 seq-2 :test test))))
41
42 (defun intersection-difference (seq1 seq2
43 &key (key #'values) key1 key2 (test #'eql)
44 (combine #'values) squash-nil)
45 "Finds the intersection, and mutual differences between two sets.
46 Returns three values: a sequence of elements that are members of seq1 and seq2;
47 a sequence of elements that are in seq1 only; and a sequence of elements
48 that are in seq2 only.
49
50 Arguments and values:
51
52 seq1 seq2 The input sequences.
53 :key Monadic function that specifies what part of
54 the element of either sequence to extract. By default,
55 takes the element itself as the value.
56 :key1 Override :key value for elements of seq1.
57 :key2 Override :key value for elements of seq2.
58 :combine Dyadic function which specifies how matching elements from seq1 and
59 seq2 are combined to form the intersection. The parameters
60 to the function are an element from seq1 and a matching
61 counterpart from seq2. The default function takes
62 the seq1 element.
63 :squash-nil If the combine function returns NIL, do not include the
64 value in the intersection set. Default is NIL, do not squash."
65 (setf key1 (or key1 key))
66 (setf key2 (or key2 key))
67
68 (let ((hash1 (make-hash-table :test test))
69 (hash2 (make-hash-table :test test))
70 (intersection ())
71 (difference1 ())
72 (difference2 ()))
73 (dolist (i1 seq1)
74 (setf (gethash (funcall key1 i1) hash1) i1))
75 (dolist (i2 seq2)
76 (setf (gethash (funcall key2 i2) hash2) i2)
77 (multiple-value-bind (i1 found)
78 (gethash (funcall key2 i2) hash1)
79 (if found
80 (let ((combined (funcall combine i1 i2)))
81 (unless (and squash-nil (null combined))
82 (push (funcall combine i1 i2) intersection)))
83 (push i2 difference2))))
84 (dolist (i1 seq1)
85 (multiple-value-bind (i2 found)
86 (gethash (funcall key1 i1) hash2)
87 (declare (ignore i2))
88 (unless found
89 (push i1 difference1))))
90 (values intersection difference1 difference2)))

  ViewVC Help
Powered by ViewVC 1.1.5