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: strmatch.lisp,v 1.1 2003/07/21 00:52:56 kevin Exp $
  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   (let* ((word-list-1 (split-alphanumeric-string s1))
  25          (word-list-2 (split-alphanumeric-string s2))
  26          (n1 (length word-list-1))
  27          (n2 (length word-list-2))
  28          (unmatched n1)
  29          (score 0)
  30          (nlong 0)
  31          (nshort 0)
  32          short-list long-list)
  33     (declare (fixnum n1 n2 nshort nlong score unmatched))
  34     (if (> n1 n2)
  35         (progn
  36           (setq nlong n1)
  37           (setq nshort n2)
  38           (setq long-list word-list-1)
  39           (setq short-list word-list-2))
  40       (progn
  41         (setq nlong n2)
  42         (setq nshort n1)
  43         (setq long-list word-list-2)
  44         (setq short-list word-list-1)))
  45     (decf score (* 3 (- nlong nshort))) ;; reduce score for extra words
  46     (dotimes (iword nshort)
  47       (declare (fixnum iword))
  48       (kmrcl:aif (position (nth iword short-list) long-list :test #'string-equal)
  49                  (progn
  50                    (incf score (- 20 (abs (- kmrcl::it iword))))
  51                    (decf unmatched))))
  52     (decf score (* 5 unmatched))
  53     score))
  54
  55
  56 (defun multiword-match (s1 s2)
  57   "Matches two multiword strings, ignores case, word position, punctuation"
  58   (let* ((word-list-1 (split-alphanumeric-string s1))
  59          (word-list-2 (split-alphanumeric-string s2))
  60          (n1 (length word-list-1))
  61          (n2 (length word-list-2)))
  62     (when (= n1 n2)
  63       ;; remove each word from word-list-2 as walk word-list-1
  64       (dolist (w word-list-1)
  65         (let ((p (position w word-list-2 :test #'string-equal)))
  66           (unless p
  67             (return-from multiword-match nil))
  68           (setf (nth p word-list-2) "")))
  69       t)))
  70
  71
  72
  73
  74