1;;; search.lisp 2;;; 3;;; Copyright (C) 2003-2004 Peter Graves 4;;; $Id$ 5;;; 6;;; This program is free software; you can redistribute it and/or 7;;; modify it under the terms of the GNU General Public License 8;;; as published by the Free Software Foundation; either version 2 9;;; of the License, or (at your option) any later version. 10;;; 11;;; This program is distributed in the hope that it will be useful, 12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14;;; GNU General Public License for more details. 15;;; 16;;; You should have received a copy of the GNU General Public License 17;;; along with this program; if not, write to the Free Software 18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 19;;; 20;;; As a special exception, the copyright holders of this library give you 21;;; permission to link this library with independent modules to produce an 22;;; executable, regardless of the license terms of these independent 23;;; modules, and to copy and distribute the resulting executable under 24;;; terms of your choice, provided that you also meet, for each linked 25;;; independent module, the terms and conditions of the license of that 26;;; module. An independent module is a module which is not derived from 27;;; or based on this library. If you modify this library, you may extend 28;;; this exception to your version of the library, but you are not 29;;; obligated to do so. If you do not wish to do so, delete this 30;;; exception statement from your version. 31 32(in-package "SYSTEM") 33 34(require "EXTENSIBLE-SEQUENCES-BASE") 35 36(export '(simple-search)) 37 38 39;; From CMUCL. 40 41(eval-when (:compile-toplevel :execute) 42 43 (defmacro compare-elements (elt1 elt2) 44 `(if test-not 45 (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2)) 46 (return nil) 47 t) 48 (if (not (funcall test (apply-key key ,elt1) (apply-key key ,elt2))) 49 (return nil) 50 t))) 51 52 53 (defmacro search-compare-list-list (main sub) 54 `(do ((main ,main (cdr main)) 55 (jndex start1 (1+ jndex)) 56 (sub (nthcdr start1 ,sub) (cdr sub))) 57 ((or (null main) (null sub) (= end1 jndex)) 58 t) 59 (compare-elements (car sub) (car main)))) 60 61 62 (defmacro search-compare-list-vector (main sub) 63 `(do ((main ,main (cdr main)) 64 (index start1 (1+ index))) 65 ((or (null main) (= index end1)) t) 66 (compare-elements (aref ,sub index) (car main)))) 67 68 69 (defmacro search-compare-vector-list (main sub index) 70 `(do ((sub (nthcdr start1 ,sub) (cdr sub)) 71 (jndex start1 (1+ jndex)) 72 (index ,index (1+ index))) 73 ((or (= end1 jndex) (null sub)) t) 74 (compare-elements (car sub) (aref ,main index)))) 75 76 77 (defmacro search-compare-vector-vector (main sub index) 78 `(do ((index ,index (1+ index)) 79 (sub-index start1 (1+ sub-index))) 80 ((= sub-index end1) t) 81 (compare-elements (aref ,sub sub-index) (aref ,main index)))) 82 83 84 (defmacro search-compare (main-type main sub index) 85 (if (eq main-type 'list) 86 `(if (listp ,sub) 87 (search-compare-list-list ,main ,sub) 88 (search-compare-list-vector ,main ,sub)) 89 `(if (listp ,sub) 90 (search-compare-vector-list ,main ,sub ,index) 91 (search-compare-vector-vector ,main ,sub ,index)))) 92 93 94 (defmacro list-search (main sub) 95 `(do ((main (nthcdr start2 ,main) (cdr main)) 96 (index2 start2 (1+ index2)) 97 (terminus (- end2 (- end1 start1))) 98 (last-match ())) 99 ((> index2 terminus) last-match) 100 (if (search-compare list main ,sub index2) 101 (if from-end 102 (setq last-match index2) 103 (return index2))))) 104 105 106 (defmacro vector-search (main sub) 107 `(do ((index2 start2 (1+ index2)) 108 (terminus (- end2 (- end1 start1))) 109 (last-match ())) 110 ((> index2 terminus) last-match) 111 (if (search-compare vector ,main ,sub index2) 112 (if from-end 113 (setq last-match index2) 114 (return index2))))) 115 116 ) ; eval-when 117 118(defun search (sequence1 sequence2 &rest args &key from-end (test #'eql) 119 test-not (start1 0) end1 (start2 0) end2 key) 120 (let ((end1 (or end1 (length sequence1))) 121 (end2 (or end2 (length sequence2)))) 122 (when key 123 (setq key (coerce-to-function key))) 124 (sequence::seq-dispatch sequence2 125 (list-search sequence2 sequence1) 126 (vector-search sequence2 sequence1) 127 (apply #'sequence:search sequence1 sequence2 args)))) 128 129(defun simple-search (sequence1 sequence2) 130 (cond ((and (stringp sequence1) (stringp sequence2)) 131 (simple-string-search sequence1 sequence2)) 132 ((vectorp sequence2) 133 (simple-vector-search sequence1 sequence2)) 134 (t 135 (search sequence1 sequence2 :from-end nil)))) 136