/[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.3 by kaz, Thu Jun 27 20:05:27 2002 UTC revision 1.4 by kaz, Fri Jun 28 21:39:50 2002 UTC
# Line 16  Line 16 
16  (provide "grab")  (provide "grab")
17    
18  (defun read-word-hash (&optional (byte-stream t))  (defun read-word-hash (&optional (byte-stream t))
19    (let ((word-hash (make-hash-table :test #'equal))    (let ((word-hash (make-hash-table :test #'equalp))
20          token          token
21          (state :junk))          (state :junk))
22      (labels ((new-token ()      (labels ((new-token ()
# Line 107  Line 107 
107                   (inc-new))                   (inc-new))
108                ((null new-iter)                ((null new-iter)
109                   (inc-old))                   (inc-old))
110                ((string-lessp old-key new-key)                ((string< old-key new-key)
111                   (inc-old))                   (inc-old))
112                ((string= new-key old-key)                ((string= new-key old-key)
113                   (push (first old-iter) stable-files)                   (push (first old-iter) stable-files)
# Line 116  Line 116 
116                (t (inc-new)))))))                (t (inc-new)))))))
117      (values added-files removed-files stable-files)))      (values added-files removed-files stable-files)))
118    
119    (defun determine-common-words (common-hash added-or-removed-files)
120      (dolist (file added-or-removed-files common-hash)
121        (maphash #'(lambda (key value)
122                     (declare (ignore value))
123                     (let ((existing (gethash key common-hash)))
124                       (if existing
125                         (setf (gethash key common-hash)
126                               (1+ existing))
127                         (setf (gethash key common-hash)
128                               1))))
129                 (second file))))
130    
131    (defun eliminate-common-words (common-hash files threshold)
132      (dolist (file files)
133        (maphash #'(lambda (key value)
134                     (declare (ignore value))
135                     (let ((count (gethash key common-hash)))
136                       (if (and count (>= count threshold))
137                         (remhash key (second file)))))
138                 (second file))))
139    
140  (defun move-candidates (added-files removed-files)  (defun move-candidates (added-files removed-files)
141    (let (pairs candidates taken-added taken-removed)    (let (pairs candidates taken-added taken-removed)
142      (dolist (added added-files)      (dolist (added added-files)
143        (dolist (removed removed-files)        (dolist (removed removed-files)
144          (let ((correlation (correlate-word-hashes (second added)          (let ((correlation (correlate-word-hashes (second added)
145                                                    (second removed))))                                                    (second removed))))
146            (when (>= correlation 7/10)            (when (>= correlation 50/100)
147              (push (list added removed              (push (list added removed
148                          (* correlation (correlate-paths (first added)                          (* correlation (correlate-paths (first added)
149                                                          (first removed))))                                                          (first removed))))
# Line 145  Line 166 
166                   :no-generate t)                   :no-generate t)
167    (in-sandbox-root-dir    (in-sandbox-root-dir
168      (let ((old-paths (sort (mapping-read *mcvs-map*)      (let ((old-paths (sort (mapping-read *mcvs-map*)
169                             #'string-lessp :key #'second))                             #'string< :key #'second))
170            new-paths added-files removed-files stable-files)            new-paths added-files removed-files stable-files)
171        (chatter-info "Scanning directory structure.~%")        (chatter-info "Scanning directory structure.~%")
172    
# Line 158  Line 179 
179                (when (path-equal path *mcvs-dir*)                (when (path-equal path *mcvs-dir*)
180                  (skip))))))                  (skip))))))
181    
182        (setf new-paths (sort new-paths #'string-lessp))        (setf new-paths (sort new-paths #'string<))
183    
184        (multiple-value-setq (added-files removed-files stable-files)        (multiple-value-setq (added-files removed-files stable-files)
185                             (added-removed old-paths new-paths                             (added-removed old-paths new-paths
# Line 177  Line 198 
198                                                (word-hash-file f-file)                                                (word-hash-file f-file)
199                                                f-file)))                                                f-file)))
200                                    removed-files))                                    removed-files))
201          (let ((common-word-hash (make-hash-table :test #'equalp)))
202            (determine-common-words common-word-hash added-files)
203            (determine-common-words common-word-hash removed-files)
204            (let ((threshold (min 5 (* 1/5 (+ (length added-files)
205                                              (length removed-files))))))
206              (eliminate-common-words common-word-hash added-files threshold)
207              (eliminate-common-words common-word-hash removed-files threshold)))
208        (chatter-terse "Determining move candidates.~%")        (chatter-terse "Determining move candidates.~%")
209        (multiple-value-bind (moved-files added-files removed-files)        (multiple-value-bind (moved-files added-files removed-files)
210                             (move-candidates added-files removed-files)                             (move-candidates added-files removed-files)

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.4

  ViewVC Help
Powered by ViewVC 1.1.5