;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: kmrcl.asd,v 1.42 2003/07/21 08:41:19 kevin Exp $
+;;;; $Id: kmrcl.asd,v 1.43 2003/07/23 22:07:48 kevin Exp $
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
(:file "processes" :depends-on ("macros"))
(:file "listener" :depends-on ("sockets" "processes" "console"))
(:file "repl" :depends-on ("listener" "strings"))
+ (:file "os" :depends-on ("macros"))
))
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: os.lisp
+;;;; Purpose: Operating System utilities
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Jul 2003
+;;;;
+;;;; $Id: os.lisp,v 1.1 2003/07/23 22:08:21 kevin Exp $
+;;;;
+;;;; *************************************************************************
+
+(in-package #:kmrcl)
+
+(defun run-shell-command (control-string &rest args)
+ "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
+synchronously execute the result using a Bourne-compatible shell,
+returns (VALUES string-output exit-code)"
+ (let ((command (apply #'format nil control-string args)))
+ #+sbcl
+ (sb-impl::process-exit-code
+ (sb-ext:run-program
+ "/bin/sh"
+ (list "-c" command)
+ :input nil :output nil))
+
+ #+(or cmu scl)
+ (ext:process-exit-code
+ (ext:run-program
+ "/bin/sh"
+ (list "-c" command)
+ :input nil :output nil))
+
+ #+allegro
+ (multiple-value-bind (output dummy exit)
+ (excl:run-shell-command command :input nil :output :stream
+ :wait nil)
+ (declare (ignore dummy))
+ (values output exit))
+
+ #+lispworks
+ (system:call-system-showing-output
+ command
+ :shell-type "/bin/sh"
+ :output-stream output)
+
+ #+clisp ;XXX not exactly *verbose-out*, I know
+ (ext:run-shell-command command :output :terminal :wait t)
+
+ #+openmcl
+ (nth-value 1
+ (ccl:external-process-status
+ (ccl:run-program "/bin/sh" (list "-c" command)
+ :input nil :output nil
+ :wait t)))
+
+ #-(or openmcl clisp lispworks allegro scl cmu sbcl)
+ (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
+
+ ))
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: package.lisp,v 1.53 2003/07/21 00:52:56 kevin Exp $
+;;;; $Id: package.lisp,v 1.54 2003/07/23 22:07:48 kevin Exp $
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;; fformat.lisp
#:fformat
+
+ ;; os.lisp
+ #:run-shell-command
))
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: strmatch.lisp,v 1.1 2003/07/21 00:52:56 kevin Exp $
+;;;; $Id: strmatch.lisp,v 1.2 2003/07/23 22:07:48 kevin Exp $
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
(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))
+ "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)
- (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)
+ (score 0))
+ (declare (fixnum n1 n2 score unmatched))
+ (decf score (* 4 (abs (- n1 n2))))
+ (dotimes (iword n1)
(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))
+ (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))