source: trunk/source/tests/ansi-tests/search-aux.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 12 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 3.0 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat Aug 24 07:22:10 2002
4;;;; Contains: Aux. functions for testing SEARCH
5
6(in-package :cl-test)
7
8(defparameter *searched-list*
9  '(b b a b b b b b b b a b a b b b a b a b b b a a a a b a a b a a a a a
10      a b a b b a b a a b a a a b b a a b a a a a b b a b a b a a a b a b
11      b a b a a b b b b b a a a a a b a b b b b b a b a b b a b a b))
12
13(defparameter *pattern-sublists*
14  (remove-duplicates
15   (let* ((s *searched-list*) (len (length s)))
16     (loop for x from 0 to 8 nconc
17           (loop for y from 0 to (- len x)
18                 collect (subseq s y (+ y x)))))
19   :test #'equal))
20
21(defparameter *searched-vector*
22  (make-array (length *searched-list*)
23              :initial-contents *searched-list*))
24
25(defparameter *pattern-subvectors*
26  (mapcar #'(lambda (x) (apply #'vector x)) *pattern-sublists*))
27
28(defparameter *searched-bitvector*
29  #*1101111111010111010111000010010000001011010010001100100001101010001011010011111000001011111010110101)
30
31(defparameter *pattern-subbitvectors*
32  (remove-duplicates
33   (let* ((s *searched-bitvector*) (len (length s)))
34     (loop for x from 0 to 8 nconc
35           (loop for y from 0 to (- len x)
36                 collect (subseq s y (+ y x)))))
37   :test #'equalp))
38
39(defparameter *searched-string*
40  "1101111111010111010111000010010000001011010010001100100001101010001011010011111000001011111010110101")
41
42(defparameter *pattern-substrings*
43  (remove-duplicates
44   (let* ((s *searched-string*) (len (length s)))
45     (loop for x from 0 to 8 nconc
46           (loop for y from 0 to (- len x)
47                 collect (subseq s y (+ y x)))))
48   :test #'equalp))
49
50(defun subseq-equalp (seq1 seq2 start1 start2 len &key (test #'equalp))
51  (assert
52   (and
53    (>= start1 0)
54    (>= start2 0)
55    (<= (+ start1 len) (length seq1))
56    (<= (+ start2 len) (length seq2))))
57  (setq test (coerce test 'function))
58  (if (and (listp seq1) (listp seq2))
59      (loop for i from 0 to (1- len)
60            for e1 in (nthcdr start1 seq1)
61            for e2 in (nthcdr start2 seq2)
62            always (funcall test e1 e2))
63    (loop for i from 0 to (1- len)
64          always
65          (funcall (the function test)
66                   (elt seq1 (+ start1 i))
67                   (elt seq2 (+ start2 i))))))
68
69(defun search-check (pattern searched pos
70                             &key (start1 0) (end1 nil) (start2 0) (end2 nil)
71                             key from-end (test #'equalp))
72  (unless end1 (setq end1 (length pattern)))
73  (unless end2 (setq end2 (length searched)))
74  (assert (<= start1 end1))
75  (assert (<= start2 end2))
76  (let* ((plen (- end1 start1)))
77    (when key
78      (setq pattern (map 'list key pattern))
79      (setq searched (map 'list key searched)))
80    (if pos
81        (and
82         (subseq-equalp searched pattern pos start1 plen :test test)
83         (if from-end
84             (loop for i from (1+ pos) to (- end2 plen)
85                   never
86                   (subseq-equalp searched pattern i start1 plen :test test))
87           (loop for i from start2 to (1- pos)
88                 never
89                 (subseq-equalp searched pattern i start1 plen :test test))))
90      (loop for i from start2 to (- end2 plen)
91            never (subseq-equalp searched pattern i start1 plen :test test)))))
92
93
Note: See TracBrowser for help on using the repository browser.