;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: kmrcl.asd,v 1.40 2003/07/11 06:58:32 kevin Exp $
+;;;; $Id: kmrcl.asd,v 1.41 2003/07/21 00:52:56 kevin Exp $
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
(:file "io" :depends-on ("macros"))
(:file "console" :depends-on ("macros"))
(:file "strings" :depends-on ("macros" "seqs"))
+ (:file "strmatch" :depends-on ("strings"))
(:file "buff-input" :depends-on ("macros"))
(:file "random" :depends-on ("macros"))
(:file "symbols" :depends-on ("macros"))
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: package.lisp,v 1.52 2003/07/19 20:32:48 kevin Exp $
+;;;; $Id: package.lisp,v 1.53 2003/07/21 00:52:56 kevin Exp $
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
#:escape-backslashes
#:concat-separated-strings
#:print-separated-strings
+ #:lex-string
+ #:split-alphanumeric-string
+
+ ;; strmatch.lisp
+ #:score-multiword-match
+ #:multiword-match
;; symbols.lisp
#:ensure-keyword
;;;; Programmer: Kevin M. Rosenberg with excerpts from portableaserve
;;;; Date Started: Jun 2003
;;;;
-;;;; $Id: sockets.lisp,v 1.4 2003/07/11 06:58:32 kevin Exp $
+;;;; $Id: sockets.lisp,v 1.5 2003/07/21 00:52:56 kevin Exp $
;;;; *************************************************************************
(in-package #:kmrcl)
(defun create-inet-listener (port &key (format :text) (reuse-address t))
#+cmu (ext:create-inet-listener port)
#+allegro
- (socket:make-socket :connect :passive :local-port port :format :binary
+ (socket:make-socket :connect :passive :local-port port :format format
:address-family
(if (stringp port)
:file
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: strings.lisp,v 1.49 2003/07/19 20:32:48 kevin Exp $
+;;;; $Id: strings.lisp,v 1.50 2003/07/21 00:52:56 kevin Exp $
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
(defun shrink-vector (str size)
#+allegro
(excl::.primcall 'sys::shrink-svector str size)
- #+sbcl
- (sb-kernel:shrink-vector str size)
#+cmu
(lisp::shrink-vector str size)
#+lispworks
(system::shrink-vector$vector str size)
- #+(or allegro cmu sbcl lispworks)
- str
- #-(or allegro cmu sbcl lispworks)
- (subseq str 0 size))
+ #+sbcl
+ (sb-kernel:shrink-vector str size)
+ #+scl
+ (common-lisp::shrink-vector str size)
+ #-(or allegro cmu lispworks sbcl scl)
+ (setq str (subseq str 0 size))
+ str)
+
+(defun lex-string (string &key (whitespace '(#\space #\newline)))
+ "Separates a string at whitespace and returns a list of strings"
+ (flet ((whitespace? (char) (member char whitespace :test #'char=)))
+ (let ((tokens nil))
+ (do* ((token-start
+ (position-if-not #'whitespace? string)
+ (when token-end
+ (position-if-not #'whitespace? string :start (1+ token-end))))
+ (token-end
+ (when token-start
+ (position-if #'whitespace? string :start token-start))
+ (when token-start
+ (position-if #'whitespace? string :start token-start))))
+ ((null token-start) (nreverse tokens))
+ (push (subseq string token-start token-end) tokens)))))
+
+(defun split-alphanumeric-string (string)
+ "Separates a string at any non-alphanumeric chararacter"
+ (flet ((whitespace? (char) (non-alphanumericp char)))
+ (let ((tokens nil))
+ (do* ((token-start
+ (position-if-not #'whitespace? string)
+ (when token-end
+ (position-if-not #'whitespace? string :start (1+ token-end))))
+ (token-end
+ (when token-start
+ (position-if #'whitespace? string :start token-start))
+ (when token-start
+ (position-if #'whitespace? string :start token-start))))
+ ((null token-start) (nreverse tokens))
+ (push (subseq string token-start token-end) tokens)))))
+
+
--- /dev/null
+;;;; -*- 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)))
+
+
+
+
+