strmatch.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; package: kmrcl -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          strings.lisp
   6 ;;;; Purpose:       Strings utility functions for KMRCL package
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  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 ;;;; *************************************************************************
  18
  19 (in-package #:kmrcl)
  20
  21
  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)
  27                         s1))
  28          (word-list-2 (split-alphanumeric-string s2))
  29          (n1 (length word-list-1))
  30          (n2 (length word-list-2))
  31          (unmatched n1)
  32          (score 0))
  33     (declare (fixnum n1 n2 score unmatched))
  34     (decf score (* 4 (abs (- n1 n2))))
  35     (dotimes (iword n1)
  36       (declare (fixnum iword))
  37       (let ((w1 (nth iword word-list-1))
  38             pos)
  39         (cond
  40          ((consp w1)
  41           (let ((first t))
  42             (dotimes (i-alt (length w1))
  43               (setq pos
  44                 (position (nth i-alt w1) word-list-2
  45                           :test #'string-equal))
  46               (when pos
  47                 (incf score (- 30
  48                                (if first 0 5)
  49                                (abs (- iword pos))))
  50                 (decf unmatched)
  51                 (return))
  52               (setq first nil))))
  53          ((stringp w1)
  54           (kmrcl:awhen (position w1 word-list-2
  55                                :test #'string-equal)
  56                        (incf score (- 30 (abs (- kmrcl::it iword))))
  57                        (decf unmatched))))))
  58     (decf score (* 4 unmatched))
  59     score))
  60
  61
  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)))
  68     (when (= n1 n2)
  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)))
  72           (unless p
  73             (return-from multiword-match nil))
  74           (setf (nth p word-list-2) "")))
  75       t)))
  76
  77
  78
  79
  80