From: Kevin M. Rosenberg <kevin@rosenberg.net>
Date: Mon, 21 Jul 2003 00:53:27 +0000 (+0000)
Subject: r5354: *** empty log message ***
X-Git-Tag: v1.96~153
X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=commitdiff_plain;h=5738e60dc3724dc7d022d0fd2d5f2dbe337be470

r5354: *** empty log message ***
---

diff --git a/kmrcl.asd b/kmrcl.asd
index 6216a71..73c004c 100644
--- a/kmrcl.asd
+++ b/kmrcl.asd
@@ -7,7 +7,7 @@
 ;;;; 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
 ;;;;
@@ -40,6 +40,7 @@
      (: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"))
diff --git a/package.lisp b/package.lisp
index 68cd413..16b5ed0 100644
--- a/package.lisp
+++ b/package.lisp
@@ -7,7 +7,7 @@
 ;;;; 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
 ;;;;
@@ -144,6 +144,12 @@
    #:escape-backslashes
    #:concat-separated-strings
    #:print-separated-strings
+   #:lex-string
+   #:split-alphanumeric-string
+   
+   ;; strmatch.lisp
+   #:score-multiword-match
+   #:multiword-match
    
    ;; symbols.lisp
    #:ensure-keyword
diff --git a/sockets.lisp b/sockets.lisp
index 259b7b0..f7c8408 100644
--- a/sockets.lisp
+++ b/sockets.lisp
@@ -7,7 +7,7 @@
 ;;;; 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)
@@ -35,7 +35,7 @@ setsockopt SO_REUSEADDR if :reuse is not nil"
 (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
diff --git a/strings.lisp b/strings.lisp
index 6ec3f5c..6b6d9df 100644
--- a/strings.lisp
+++ b/strings.lisp
@@ -7,7 +7,7 @@
 ;;;; 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
 ;;;;
@@ -551,13 +551,48 @@ for characters in a string"
 (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)))))
+
+
diff --git a/strmatch.lisp b/strmatch.lisp
new file mode 100644
index 0000000..a56f3bf
--- /dev/null
+++ b/strmatch.lisp
@@ -0,0 +1,74 @@
+;;;; -*- 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)))
+
+
+	       
+  
+