r5354: *** empty log message ***

[kmrcl.git] / strmatch.lisp

diff --git a/strmatch.lisp b/strmatch.lisp
new file mode 100644 (file)
index 0000000..a56f3bf
--- /dev/null
+++ b/strmatch.lisp
@@ -0,0 +1,74 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; package: kmrcl -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          strings.lisp
+;;;; Purpose:       Strings utility functions for KMRCL package
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id: strmatch.lisp,v 1.1 2003/07/21 00:52:56 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
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:kmrcl)
+
+
+(defun score-multiword-match (s1 s2)
+  "Score a match between two strings with s1 being reference string"
+  (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))
+        (unmatched n1)
+        (score 0)
+        (nlong 0)
+        (nshort 0)
+        short-list long-list)
+    (declare (fixnum n1 n2 nshort nlong score unmatched))
+    (if (> n1 n2)
+       (progn
+         (setq nlong n1)
+         (setq nshort n2)
+         (setq long-list word-list-1)
+         (setq short-list word-list-2))
+      (progn
+       (setq nlong n2)
+       (setq nshort n1)
+       (setq long-list word-list-2)
+       (setq short-list word-list-1)))
+    (decf score (* 3 (- nlong nshort))) ;; reduce score for extra words
+    (dotimes (iword nshort)
+      (declare (fixnum iword))
+      (kmrcl:aif (position (nth iword short-list) long-list :test #'string-equal)
+                (progn
+                  (incf score (- 20 (abs (- kmrcl::it iword))))
+                  (decf unmatched))))
+    (decf score (* 5 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)))
+    (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) "")))
+      t)))
+
+
+              
+  
+