-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; package: kmrcl -*-
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: strmatch.lisp,v 1.2 2003/07/23 22:07:48 kevin Exp $
-;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;;;; KMRCL users are granted the rights to distribute and use this software
"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))
(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)))
-
-
-
+
+
+