X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=strmatch.lisp;h=e48e2309728be96d07adbdbc2416e09cafbb94a6;hp=6d7b89eb62a6a4d868220c28f2299cbd49d76de6;hb=6bdd43a1b1daa21561706ba5213e1442e4971351;hpb=d11d6cc43fd9227a8aeed28dc2cfecdbc587ec4a diff --git a/strmatch.lisp b/strmatch.lisp index 6d7b89e..e48e230 100644 --- a/strmatch.lisp +++ b/strmatch.lisp @@ -23,38 +23,38 @@ "Score a match between two strings with s1 being reference string. S1 can be a string or a list or strings/conses" (let* ((word-list-1 (if (stringp s1) - (split-alphanumeric-string s1) - s1)) - (word-list-2 (split-alphanumeric-string s2)) - (n1 (length word-list-1)) - (n2 (length word-list-2)) - (unmatched n1) - (score 0)) + (split-alphanumeric-string s1) + s1)) + (word-list-2 (split-alphanumeric-string s2)) + (n1 (length word-list-1)) + (n2 (length word-list-2)) + (unmatched n1) + (score 0)) (declare (fixnum n1 n2 score unmatched)) (decf score (* 4 (abs (- n1 n2)))) (dotimes (iword n1) (declare (fixnum iword)) (let ((w1 (nth iword word-list-1)) - pos) - (cond - ((consp w1) - (let ((first t)) - (dotimes (i-alt (length w1)) - (setq pos - (position (nth i-alt w1) word-list-2 - :test #'string-equal)) - (when pos - (incf score (- 30 - (if first 0 5) - (abs (- iword pos)))) - (decf unmatched) - (return)) - (setq first nil)))) - ((stringp w1) - (kmrcl:awhen (position w1 word-list-2 - :test #'string-equal) - (incf score (- 30 (abs (- kmrcl::it iword)))) - (decf unmatched)))))) + pos) + (cond + ((consp w1) + (let ((first t)) + (dotimes (i-alt (length w1)) + (setq pos + (position (nth i-alt w1) word-list-2 + :test #'string-equal)) + (when pos + (incf score (- 30 + (if first 0 5) + (abs (- iword pos)))) + (decf unmatched) + (return)) + (setq first nil)))) + ((stringp w1) + (kmrcl:awhen (position w1 word-list-2 + :test #'string-equal) + (incf score (- 30 (abs (- kmrcl::it iword)))) + (decf unmatched)))))) (decf score (* 4 unmatched)) score)) @@ -62,19 +62,19 @@ S1 can be a string or a list or strings/conses" (defun multiword-match (s1 s2) "Matches two multiword strings, ignores case, word position, punctuation" (let* ((word-list-1 (split-alphanumeric-string s1)) - (word-list-2 (split-alphanumeric-string s2)) - (n1 (length word-list-1)) - (n2 (length word-list-2))) + (word-list-2 (split-alphanumeric-string s2)) + (n1 (length word-list-1)) + (n2 (length word-list-2))) (when (= n1 n2) ;; remove each word from word-list-2 as walk word-list-1 (dolist (w word-list-1) - (let ((p (position w word-list-2 :test #'string-equal))) - (unless p - (return-from multiword-match nil)) - (setf (nth p word-list-2) ""))) + (let ((p (position w word-list-2 :test #'string-equal))) + (unless p + (return-from multiword-match nil)) + (setf (nth p word-list-2) ""))) t))) - - - + + +