strmatch.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   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 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
  11 ;;;;
  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 ;;;; *************************************************************************
  16
  17 (in-package #:kmrcl)
  18
  19
  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)
  25                         s1))
  26          (word-list-2 (split-alphanumeric-string s2))
  27          (n1 (length word-list-1))
  28          (n2 (length word-list-2))
  29          (unmatched n1)
  30          (score 0))
  31     (declare (fixnum n1 n2 score unmatched))
  32     (decf score (* 4 (abs (- n1 n2))))
  33     (dotimes (iword n1)
  34       (declare (fixnum iword))
  35       (let ((w1 (nth iword word-list-1))
  36             pos)
  37         (cond
  38          ((consp w1)
  39           (let ((first t))
  40             (dotimes (i-alt (length w1))
  41               (setq pos
  42                 (position (nth i-alt w1) word-list-2
  43                           :test #'string-equal))
  44               (when pos
  45                 (incf score (- 30
  46                                (if first 0 5)
  47                                (abs (- iword pos))))
  48                 (decf unmatched)
  49                 (return))
  50               (setq first nil))))
  51          ((stringp w1)
  52           (kmrcl:awhen (position w1 word-list-2
  53                                :test #'string-equal)
  54                        (incf score (- 30 (abs (- kmrcl::it iword))))
  55                        (decf unmatched))))))
  56     (decf score (* 4 unmatched))
  57     score))
  58
  59
  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)))
  66     (when (= n1 n2)
  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)))
  70           (unless p
  71             (return-from multiword-match nil))
  72           (setf (nth p word-list-2) "")))
  73       t)))
  74
  75
  76
  77
  78