;;;; -*- 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)))