/usr/share/common-lisp/source/kmrcl/strmatch.lisp is in cl-kmrcl 1.106-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: strings.lisp
;;;; Purpose: Strings utility functions for KMRCL package
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
;;;; 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.
S1 can be a string or a list or strings/conses"
(let* ((word-list-1 (if (stringp s1)
(split-alphanumeric-string s1)
s1))
(word-list-2 (split-alphanumeric-string s2))
(n1 (length word-list-1))
(n2 (length word-list-2))
(unmatched n1)
(score 0))
(declare (fixnum n1 n2 score unmatched))
(decf score (* 4 (abs (- n1 n2))))
(dotimes (iword n1)
(declare (fixnum iword))
(let ((w1 (nth iword word-list-1))
pos)
(cond
((consp w1)
(let ((first t))
(dotimes (i-alt (length w1))
(setq pos
(position (nth i-alt w1) word-list-2
:test #'string-equal))
(when pos
(incf score (- 30
(if first 0 5)
(abs (- iword pos))))
(decf unmatched)
(return))
(setq first nil))))
((stringp w1)
(kmrcl:awhen (position w1 word-list-2
:test #'string-equal)
(incf score (- 30 (abs (- kmrcl::it iword))))
(decf unmatched))))))
(decf score (* 4 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)))
|