/[meta-cvs]/meta-cvs/F-26D2A2DCE1CF180F943606C59DC63A51.lisp
ViewVC logotype

Diff of /meta-cvs/F-26D2A2DCE1CF180F943606C59DC63A51.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by kaz, Tue Jun 25 23:39:19 2002 UTC revision 1.2 by kaz, Wed Jun 26 22:21:44 2002 UTC
# Line 1  Line 1 
1  (require "dirwalk")  (require "dirwalk")
2  (require "system")  (require "system")
3    (require "split")
4    (require "seqfuncs")
5  (require "mapping")  (require "mapping")
6  (require "types")  (require "types")
7  (require "chatter")  (require "chatter")
# Line 14  Line 16 
16          token          token
17          (state :junk))          (state :junk))
18      (labels ((new-token ()      (labels ((new-token ()
19                 (make-array '(64)                 (if token
20                             :element-type 'character                   (setf (fill-pointer token) 0)
21                             :adjustable t                   (setf token (make-array '(8)
22                             :fill-pointer 0))                                           :element-type 'character
23               (save-token (tok)                                           :adjustable t
24                 (setf (gethash tok word-hash) tok)))                                           :fill-pointer 0))))
25                 (save-token ()
26                   (unless (gethash token word-hash)
27                     (setf (gethash token word-hash) token)
28                     (setf token nil))))
29        (do ((byte (read-byte byte-stream nil)        (do ((byte (read-byte byte-stream nil)
30                   (read-byte byte-stream nil)))                   (read-byte byte-stream nil)))
31            ((null byte) (if (eq state :word) (save-token token)) word-hash)            ((null byte) (if (eq state :word) (save-token)) word-hash)
32          (let ((ch (int-char byte)))          (let ((ch (int-char byte)))
33            (ecase state            (ecase state
34              ((:junk)              ((:junk)
35                (when (or (alpha-char-p ch) (digit-char-p ch)                (when (or (alpha-char-p ch) (digit-char-p ch)
36                          (char= ch #\_))                          (char= ch #\_))
37                  (setf token (new-token))                  (new-token)
38                  (vector-push-extend ch token)                  (vector-push-extend ch token)
39                  (setf state :word)))                  (setf state :word)))
40              ((:word)              ((:word)
# Line 37  Line 43 
43                          (char= ch #\_) (char= ch #\-))                          (char= ch #\_) (char= ch #\-))
44                       (vector-push-extend ch token))                       (vector-push-extend ch token))
45                    (t (setf state :junk)                    (t (setf state :junk)
46                       (save-token token))))))))))                       (save-token))))))))))
47    
48  (defun word-hash-file (name)  (defun word-hash-file (name)
49    (with-open-file (s (parse-posix-namestring name)    (with-open-file (s (parse-posix-namestring name)
# Line 45  Line 51 
51                       :element-type 'unsigned-byte)                       :element-type 'unsigned-byte)
52      (read-word-hash s)))      (read-word-hash s)))
53    
54  (defun correlate (hash-1 hash-2)  (defun correlate-word-hashes (hash-1 hash-2)
55    (let ((hc-1 (hash-table-count hash-1))    (let ((hc-1 (hash-table-count hash-1))
56          (hc-2 (hash-table-count hash-2)))          (hc-2 (hash-table-count hash-2)))
57      (when (> hc-1 hc-2)      (when (> hc-1 hc-2)
# Line 62  Line 68 
68            0            0
69            (/ common-count total-count))))))            (/ common-count total-count))))))
70    
71    
72    (defun correlate-paths (path-1 path-2)
73      (let* ((split-1 (split-fields path-1 *path-sep*))
74             (split-2 (split-fields path-2 *path-sep*))
75             (longer (max (length split-1) (length split-2)))
76             (lcs-len (length (longest-common-subsequence split-1 split-2
77                                                           :test #'string=))))
78        (case (- longer lcs-len)
79          ((0 1) 1)
80          ((2) 95/100)
81          ((3) 90/100)
82          ((4) 85/100)
83          (otherwise 80/100))))
84    
85  (defun added-removed (old-paths new-paths  (defun added-removed (old-paths new-paths
86                        &key (key-old #'values) (key-new #'values))                        &key (key-old #'values) (key-new #'values))
87    (let (added-files removed-files stable-files)    (let (added-files removed-files stable-files)
# Line 96  Line 116 
116    (let (pairs candidates taken-added taken-removed)    (let (pairs candidates taken-added taken-removed)
117      (dolist (added added-files)      (dolist (added added-files)
118        (dolist (removed removed-files)        (dolist (removed removed-files)
119          (push (list added removed (correlate (second added) (second removed)))          (let ((correlation (correlate-word-hashes (second added)
120                pairs)))                                                    (second removed))))
121              (when (>= correlation 7/10)
122                (push (list added removed
123                            (* correlation (correlate-paths (first added)
124                                                            (first removed))))
125                      pairs)))))
126      (setf pairs (sort pairs #'> :key #'third))      (setf pairs (sort pairs #'> :key #'third))
127      (dolist (pair pairs)      (dolist (pair pairs)
       (when (< (third pair) 7/10)  
         (return))  
128        (unless (or (member (first pair) taken-added :test #'eq)        (unless (or (member (first pair) taken-added :test #'eq)
129                    (member (second pair) taken-removed :test #'eq))                    (member (second pair) taken-removed :test #'eq))
130          (push (first pair) taken-added)          (push (first pair) taken-added)

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

  ViewVC Help
Powered by ViewVC 1.1.5