1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; package: kmrcl -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: strings.lisp
6 ;;;; Purpose: Strings utility functions for KMRCL package
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Apr 2000
10 ;;;; $Id: strmatch.lisp,v 1.2 2003/07/23 22:07:48 kevin Exp $
12 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
14 ;;;; KMRCL users are granted the rights to distribute and use this software
15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
17 ;;;; *************************************************************************
22 (defun score-multiword-match (s1 s2)
23 "Score a match between two strings with s1 being reference string.
24 S1 can be a string or a list or strings/conses"
25 (let* ((word-list-1 (if (stringp s1)
26 (split-alphanumeric-string s1)
28 (word-list-2 (split-alphanumeric-string s2))
29 (n1 (length word-list-1))
30 (n2 (length word-list-2))
33 (declare (fixnum n1 n2 score unmatched))
34 (decf score (* 4 (abs (- n1 n2))))
36 (declare (fixnum iword))
37 (let ((w1 (nth iword word-list-1))
42 (dotimes (i-alt (length w1))
44 (position (nth i-alt w1) word-list-2
45 :test #'string-equal))
54 (kmrcl:awhen (position w1 word-list-2
56 (incf score (- 30 (abs (- kmrcl::it iword))))
58 (decf score (* 4 unmatched))
62 (defun multiword-match (s1 s2)
63 "Matches two multiword strings, ignores case, word position, punctuation"
64 (let* ((word-list-1 (split-alphanumeric-string s1))
65 (word-list-2 (split-alphanumeric-string s2))
66 (n1 (length word-list-1))
67 (n2 (length word-list-2)))
69 ;; remove each word from word-list-2 as walk word-list-1
70 (dolist (w word-list-1)
71 (let ((p (position w word-list-2 :test #'string-equal)))
73 (return-from multiword-match nil))
74 (setf (nth p word-list-2) "")))