1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
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 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
12 ;;;; KMRCL users are granted the rights to distribute and use this software
13 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
14 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
15 ;;;; *************************************************************************
20 (defun score-multiword-match (s1 s2)
21 "Score a match between two strings with s1 being reference string.
22 S1 can be a string or a list or strings/conses"
23 (let* ((word-list-1 (if (stringp s1)
24 (split-alphanumeric-string s1)
26 (word-list-2 (split-alphanumeric-string s2))
27 (n1 (length word-list-1))
28 (n2 (length word-list-2))
31 (declare (fixnum n1 n2 score unmatched))
32 (decf score (* 4 (abs (- n1 n2))))
34 (declare (fixnum iword))
35 (let ((w1 (nth iword word-list-1))
40 (dotimes (i-alt (length w1))
42 (position (nth i-alt w1) word-list-2
43 :test #'string-equal))
52 (kmrcl:awhen (position w1 word-list-2
54 (incf score (- 30 (abs (- kmrcl::it iword))))
56 (decf score (* 4 unmatched))
60 (defun multiword-match (s1 s2)
61 "Matches two multiword strings, ignores case, word position, punctuation"
62 (let* ((word-list-1 (split-alphanumeric-string s1))
63 (word-list-2 (split-alphanumeric-string s2))
64 (n1 (length word-list-1))
65 (n2 (length word-list-2)))
67 ;; remove each word from word-list-2 as walk word-list-1
68 (dolist (w word-list-1)
69 (let ((p (position w word-list-2 :test #'string-equal)))
71 (return-from multiword-match nil))
72 (setf (nth p word-list-2) "")))