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 | |
---|