1 | ;-*- Mode: Lisp -*- |
---|
2 | ;;;; Author: Paul Dietz |
---|
3 | ;;;; Created: Fri Oct 4 06:51:32 2002 |
---|
4 | ;;;; Contains: Auxiliary functions for string testing |
---|
5 | |
---|
6 | (in-package :cl-test) |
---|
7 | |
---|
8 | (eval-when (:compile-toplevel :load-toplevel :execute) |
---|
9 | (compile-and-load "random-aux.lsp")) |
---|
10 | |
---|
11 | (defun my-string-compare (string1 string2 comparison |
---|
12 | &key (start1 0) end1 (start2 0) end2 case |
---|
13 | &aux |
---|
14 | (len1 (progn (assert (stringp string1)) |
---|
15 | (length string1))) |
---|
16 | (len2 (progn (assert (stringp string2)) |
---|
17 | (length string2))) |
---|
18 | (compare-fn |
---|
19 | (case comparison |
---|
20 | (< (if case #'char-lessp #'char<)) |
---|
21 | (<= (if case #'char-not-greaterp |
---|
22 | #'char<=)) |
---|
23 | (= (if case #'char-equal #'char=)) |
---|
24 | (/= (if case #'char-not-equal #'char/=)) |
---|
25 | (> (if case #'char-greaterp #'char>)) |
---|
26 | (>= (if case #'char-not-lessp #'char>=)) |
---|
27 | (t (error "Bad comparison arg: ~A~%" |
---|
28 | comparison)))) |
---|
29 | (equal-fn (if case #'char-equal #'char=))) |
---|
30 | |
---|
31 | (assert (integerp start1)) |
---|
32 | (assert (integerp start2)) |
---|
33 | (unless end1 (setq end1 len1)) |
---|
34 | (unless end2 (setq end2 len2)) |
---|
35 | (assert (<= 0 start1 end1)) |
---|
36 | (assert (<= 0 start2 end2)) |
---|
37 | (loop |
---|
38 | for i1 from start1 |
---|
39 | for i2 from start2 |
---|
40 | do |
---|
41 | (cond |
---|
42 | ((= i1 end1) |
---|
43 | (return |
---|
44 | (cond |
---|
45 | ((= i2 end2) |
---|
46 | ;; Both ended -- equality case |
---|
47 | (if (member comparison '(= <= >=)) |
---|
48 | end1 |
---|
49 | nil)) |
---|
50 | (t ;; string2 still extending |
---|
51 | (if (member comparison '(/= < <=)) |
---|
52 | end1 |
---|
53 | nil))))) |
---|
54 | ((= i2 end2) |
---|
55 | ;; string1 still extending |
---|
56 | (return |
---|
57 | (if (member comparison '(/= > >=)) |
---|
58 | i1 |
---|
59 | nil))) |
---|
60 | (t |
---|
61 | (let ((c1 (my-aref string1 i1)) |
---|
62 | (c2 (my-aref string2 i2))) |
---|
63 | (cond |
---|
64 | ((funcall equal-fn c1 c2)) |
---|
65 | (t ;; mismatch found -- what kind? |
---|
66 | (return |
---|
67 | (if (funcall compare-fn c1 c2) |
---|
68 | i1 |
---|
69 | nil))))))))) |
---|
70 | |
---|
71 | (defun make-random-string-compare-test (n) |
---|
72 | (let* ((len (random n)) |
---|
73 | ;; Maximum lengths of the two strings |
---|
74 | (len1 (if (or (coin) (= len 0)) len (+ len (random len)))) |
---|
75 | (len2 (if (or (coin) (= len 0)) len (+ len (random len)))) |
---|
76 | (s1 (make-random-string len1)) |
---|
77 | (s2 (make-random-string len2)) |
---|
78 | ;; Actual lengths of the strings |
---|
79 | (len1 (length s1)) |
---|
80 | (len2 (length s2)) |
---|
81 | ;; Lengths of the parts of the strings to be matched |
---|
82 | (sublen1 (if (or (coin) (= len1 0)) (min len1 len2) (random len1))) |
---|
83 | (sublen2 (if (or (coin) (= len2 0)) (min len2 sublen1) (random len2))) |
---|
84 | ;; Start and end of the substring of the first string |
---|
85 | (start1 (if (coin 3) 0 |
---|
86 | (max 0 (min (1- len1) (random (- len1 sublen1 -1)))))) |
---|
87 | (end1 (+ start1 sublen1)) |
---|
88 | ;; Start and end of the substring of the second string |
---|
89 | (start2 (if (coin 3) 0 |
---|
90 | (max 0 (min (1- len2) (random (- len2 sublen2 -1)))))) |
---|
91 | (end2 (+ start2 sublen2)) |
---|
92 | ) |
---|
93 | #| |
---|
94 | (format t "len = ~A, len1 = ~A, len2 = ~A, sublen1 = ~A, sublen2 = ~A~%" |
---|
95 | len len1 len2 sublen1 sublen2) |
---|
96 | (format t "start1 = ~A, end1 = ~A, start2 = ~A, end2 = ~A~%" |
---|
97 | start1 end1 start2 end2) |
---|
98 | (format t "s1 = ~S, s2 = ~S~%" s1 s2) |
---|
99 | |# |
---|
100 | ;; Sometimes we want them to have a common prefix |
---|
101 | (when (and (coin) |
---|
102 | (equal (array-element-type s1) |
---|
103 | (array-element-type s2))) |
---|
104 | (if (<= sublen1 sublen2) |
---|
105 | (setf (subseq s2 start2 (+ start2 sublen1)) |
---|
106 | (subseq s1 start1 (+ start1 sublen1))) |
---|
107 | (setf (subseq s1 start1 (+ start1 sublen2)) |
---|
108 | (subseq s2 start2 (+ start2 sublen2))))) |
---|
109 | (values |
---|
110 | s1 |
---|
111 | s2 |
---|
112 | (reduce #'nconc |
---|
113 | (random-permute |
---|
114 | (list |
---|
115 | (if (and (= start1 0) (coin)) |
---|
116 | nil |
---|
117 | (list :start1 start1)) |
---|
118 | (if (and (= end1 len1) (coin)) |
---|
119 | nil |
---|
120 | (list :end1 end1)) |
---|
121 | (if (and (= start2 0) (coin)) |
---|
122 | nil |
---|
123 | (list :start2 start2)) |
---|
124 | (if (and (= end2 len2) (coin)) |
---|
125 | nil |
---|
126 | (list :end2 end2)))))))) |
---|
127 | |
---|
128 | (defun random-string-compare-test (n comparison case &optional (iterations 1)) |
---|
129 | (loop for i from 1 to iterations |
---|
130 | count |
---|
131 | (multiple-value-bind (s1 s2 args) |
---|
132 | (make-random-string-compare-test n) |
---|
133 | ;; (format t "Strings: ~s ~s - Args = ~S~%" s1 s2 args) |
---|
134 | (let ((x (apply (case comparison |
---|
135 | (< (if case #'string-lessp #'string<)) |
---|
136 | (<= (if case #'string-not-greaterp |
---|
137 | #'string<=)) |
---|
138 | (= (if case #'string-equal #'string=)) |
---|
139 | (/= (if case #'string-not-equal #'string/=)) |
---|
140 | (> (if case #'string-greaterp #'string>)) |
---|
141 | (>= (if case #'string-not-lessp #'string>=)) |
---|
142 | (t (error "Bad comparison arg: ~A~%" comparison))) |
---|
143 | s1 s2 args)) |
---|
144 | (y (apply #'my-string-compare s1 s2 comparison :case case args))) |
---|
145 | (not |
---|
146 | (or (eql x y) |
---|
147 | (and x y (eqt comparison '=)))))))) |
---|
148 | |
---|
149 | (defun string-all-the-same (s) |
---|
150 | (let ((len (length s))) |
---|
151 | (or (= len 0) |
---|
152 | (let ((c (my-aref s 0))) |
---|
153 | (loop for i below len |
---|
154 | for d = (my-aref s i) |
---|
155 | always (eql c d)))))) |
---|