char-aux.lsp 11.7 KB
Newer Older
1 2 3 4 5 6 7 8
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat Oct  5 20:15:55 2002
;;;; Contains: Auxiliary functions for character tests

(in-package :cl-test)

(defun is-ordered-by (seq fn)
9
  (declare (type function fn))
10 11
  (let ((n (length seq)))
    (loop for i from 0 below (1- n)
sds's avatar
sds committed
12 13 14 15
          for e = (elt seq i)
          always
          (loop for j from (1+ i) below n
                always (funcall fn e (elt seq j))))))
16 17

(defun is-antisymmetrically-ordered-by (seq fn)
18
  (declare (type function fn))
19 20 21 22
  (and (is-ordered-by seq fn)
       (is-ordered-by (reverse seq) (complement fn))))

(defun is-case-insensitive (fn)
23 24 25 26 27 28 29
  (when (symbolp fn)
    (assert (fboundp fn))
    (setf fn (symbol-function fn)))
  (assert (typep fn 'function))
  (locally
   (declare (type function fn))
   (loop for c across +code-chars+
sds's avatar
sds committed
30 31 32 33 34 35 36 37 38 39
         for c1 = (char-upcase c)
         for c2 = (if (eql c c1) (char-downcase c) c1)
         always
         (loop for d across +code-chars+
               for d1 = (char-upcase d)
               for d2 = (if (eql d d1) (char-downcase d) d1)
               always (equiv (funcall fn c d)
                             (funcall fn c2 d)
                             (funcall fn c d2)
                             (funcall fn c2 d2))))))
40 41 42 43 44 45

(defun equiv (&rest args)
  (declare (dynamic-extent args))
  (cond
   ((null args) t)
   ((car args)
46 47
    (loop for e in (cdr args) always e))
   (t (loop for e in (cdr args) never e))))
48

49 50
;;; From character.lsp
(defun char-type-error-check (fn)
51 52 53 54 55 56 57
  (when (symbolp fn)
    (assert (fboundp fn))
    (setf fn (symbol-function fn)))
  (assert (typep fn 'function))
  (locally
   (declare (type function fn))
   (loop for x in *universe*
sds's avatar
sds committed
58 59 60 61
         always (or (characterp x)
                    ;; FIXME -- catch the type error and check that datum
                    ;; is eql to x (and that datum is not in the expected type)
                    (eqt (catch-type-error (funcall fn x)) 'type-error)))))
62

63
(defun standard-char.5.body ()
64 65 66
  (loop for i from 0 below (min 65536 char-code-limit) for c = (code-char i)
        unless (not (and (typep c 'standard-char)
                         (not (standard-char-p c))))
67
        collect (char-name c)))
68

69
(defun extended-char.3.body ()
70 71 72
  (loop for i from 0 below (min 65536 char-code-limit) for c = (code-char i)
        unless (not (and (typep c 'base-char)
                         (typep c 'extended-char)))
73
        collect (char-name c)))
74 75

(defun character.1.body ()
76 77 78 79 80 81 82
  (loop for i from 0 below (min 65536 char-code-limit) for c = (code-char i)
        unless (or (null c)
                   (let ((s (string c)))
                     (and
                      (eqlt (character c) c)
                      (eqlt (character s) c)
                      (eqlt (character (make-symbol s)) c))))
83
        collect (char-name c)))
84 85 86

(defun character.2.body ()
  (loop for x in *universe*
sds's avatar
sds committed
87 88 89 90 91 92 93 94
        when (not (or (characterp x)
                      (and (stringp x) (eqlt (length x) 1))
                      (and (symbolp x) (eqlt (length (symbol-name x)) 1))
                      (let ((c (catch-type-error (character x))))
                        (or (eqlt c 'type-error)
                            (let ((s (catch-type-error (string x))))
                              (and (stringp s) (eqlt (my-aref s 0) c)))))))
        do (return x)))
95 96

(defun characterp.2.body ()
97 98
  (loop for i from 0 below (min 65536 char-code-limit) for c = (code-char i)
        unless (or (null c) (characterp c))
99
        collect (char-name c)))
100 101 102

(defun characterp.3.body ()
  (loop for x in *universe*
103
        unless (let ((p (characterp x))
sds's avatar
sds committed
104
                     (q (typep x 'character)))
105 106
                 (if p (notnot q) (not q)))
        collect x))
107 108 109

(defun alphanumericp.4.body ()
  (loop for x in *universe*
110
        unless (or (not (characterp x))
sds's avatar
sds committed
111 112 113 114 115 116 117
                   (if (or (digit-char-p x) (alpha-char-p x))
                       (alphanumericp x)
                     ;; The hyperspec has an example that claims alphanumeric ==
                     ;;  digit-char-p or alpha-char-p, but the text seems to suggest
                     ;;  that there can be numeric characters for which digit-char-p
                     ;;  returns NIL.  Therefore, I've weakened the next line
                     ;; (not (alphanumericp x))
118 119
                     t))
        collect x))
120 121 122

(defun alphanumericp.5.body ()
  (loop for i from 0 below (min 65536 char-code-limit)
sds's avatar
sds committed
123
        for x = (code-char i)
124
        unless (or (not (characterp x))
sds's avatar
sds committed
125 126 127 128 129 130 131
                   (if (or (digit-char-p x) (alpha-char-p x))
                       (alphanumericp x)
                     ;; The hyperspec has an example that claims alphanumeric ==
                     ;;  digit-char-p or alpha-char-p, but the text seems to suggest
                     ;;  that there can be numeric characters for which digit-char-p
                     ;;  returns NIL.  Therefore, I've weakened the next line
                     ;; (not (alphanumericp x))
132
                     t))
133
        collect (char-name x)))
134

135 136 137
(defun digit-char.1.body.old ()
  (loop for r from 2 to 36 always
       (loop for i from 0 to 36
sds's avatar
sds committed
138 139 140 141 142 143 144
          always (let* ((c (digit-char i r))
                        (result
                         (if (>= i r) (null c)
                             (eqlt c (char +extended-digit-chars+ i)))))
                   (unless result
                     (format t "~A ~A ~A~%" r i c))
                   result))))
145

146
(defun digit-char.1.body ()
147 148
  (loop for r from 2 to 36 nconc
       (loop for i from 0 to 36
sds's avatar
sds committed
149 150 151 152
          for c = (digit-char i r)
          unless (if (>= i r) (null c)
                     (eqlt c (char +extended-digit-chars+ i)))
          collect (list r i c))))
153 154 155

(defun digit-char-p.1.body ()
  (loop for x in *universe*
156
        unless (not (and (characterp x)
sds's avatar
sds committed
157
                         (not (alphanumericp x))
158 159
                         (digit-char-p x)))
        collect x))
160 161 162

(defun digit-char-p.2.body ()
  (loop for i from 0 below (min 65536 char-code-limit)
sds's avatar
sds committed
163
        for x = (code-char i)
164
        unless (or (not x)
sds's avatar
sds committed
165
                   (not (and (not (alphanumericp x))
166
                             (digit-char-p x))))
167
        collect (char-name x)))
168 169 170

(defun digit-char-p.3.body ()
  (loop for r from 2 to 35
171
    for bad =
sds's avatar
sds committed
172 173
        (loop for i from r to 35
              for c = (char +extended-digit-chars+ i)
174 175 176 177
              when (or (digit-char-p c r)
                        (digit-char-p (char-downcase c) r))
              collect i)
    when bad collect (cons r bad)))
178 179 180

(defun digit-char-p.4.body ()
  (loop for r from 2 to 35
181
    for bad =
sds's avatar
sds committed
182 183
        (loop for i from 0 below r
              for c = (char +extended-digit-chars+ i)
184 185 186 187
              unless (and (eqlt (digit-char-p c r) i)
                          (eqlt (digit-char-p (char-downcase c) r) i))
              collect i)
    when bad collect (cons r bad)))
188 189 190

(defun standard-char-p.2.body ()
  (loop for x in *universe*
191
        unless (or (not (characterp x))
sds's avatar
sds committed
192
                   (find x +standard-chars+)
193 194
                   (not (standard-char-p x)))
        collect x))
195 196 197

(defun standard-char-p.2a.body ()
  (loop for i from 0 below (min 65536 char-code-limit)
sds's avatar
sds committed
198
        for x = (code-char i)
199
        unless (or (not (characterp x))
sds's avatar
sds committed
200
                   (find x +standard-chars+)
201
                   (not (standard-char-p x)))
202
        collect (char-name x)))
203 204 205

(defun char-upcase.1.body ()
  (loop for x in *universe*
206 207 208 209 210
        unless (or (not (characterp x))
                   (let ((u (char-upcase x)))
                     (and
                      (or (lower-case-p x) (eqlt u x))
                      (eqlt u (char-upcase u)))))
211
        collect (char-name x)))
212 213 214

(defun char-upcase.2.body ()
  (loop for i from 0 below (min 65536 char-code-limit)
sds's avatar
sds committed
215
        for x = (code-char i)
216 217 218 219 220
        unless (or (not x)
                   (let ((u (char-upcase x)))
                     (and
                      (or (lower-case-p x) (eqlt u x))
                      (eqlt u (char-upcase u)))))
221
        collect (char-name x)))
222 223 224

(defun char-downcase.1.body ()
  (loop for x in *universe*
225 226 227 228 229
        unless (or (not (characterp x))
                   (let ((u (char-downcase x)))
                     (and
                      (or (upper-case-p x) (eqlt u x))
                      (eqlt u (char-downcase u)))))
230
        collect (char-name x)))
231 232 233

(defun char-downcase.2.body ()
  (loop for i from 0 below (min 65536 char-code-limit)
sds's avatar
sds committed
234
        for x = (code-char i)
235 236 237 238 239
        unless (or (not x)
                   (let ((u (char-downcase x)))
                     (and
                      (or (upper-case-p x) (eqlt u x))
                      (eqlt u (char-downcase u)))))
240
        collect (char-name x)))
241 242 243

(defun both-case-p.1.body ()
  (loop for x in *universe*
244
        unless (or (not (characterp x))
sds's avatar
sds committed
245 246 247 248 249
                   (if (both-case-p x)
                       (and (graphic-char-p x)
                            (or (upper-case-p x)
                                (lower-case-p x)))
                     (not (or (upper-case-p x)
250
                              (lower-case-p x)))))
251
        collect (char-name x)))
252 253 254

(defun both-case-p.2.body ()
  (loop for i from 0 below (min 65536 char-code-limit)
sds's avatar
sds committed
255
        for x = (code-char i)
256
        unless (or (not (characterp x))
sds's avatar
sds committed
257 258 259 260 261
                   (if (both-case-p x)
                       (and (graphic-char-p x)
                            (or (upper-case-p x)
                                (lower-case-p x)))
                     (not (or (upper-case-p x)
262
                              (lower-case-p x)))))
263
        collect (char-name x)))
264 265 266

(defun char-code.2.body ()
  (loop for i from 0 below (min 65536 char-code-limit)
sds's avatar
sds committed
267
        for c = (code-char i)
268 269
        unless (or (not c)
                   (eqlt (char-code c) i))
270
        collect (char-name c)))
271 272 273 274

(defun char-int.2.fn ()
  (declare (optimize (safety 3) (speed 1) (space 1)))
  (let ((c->i (make-hash-table :test #'equal))
sds's avatar
sds committed
275
        (i->c (make-hash-table :test #'eql)))
276
    (flet ((%insert
sds's avatar
sds committed
277 278 279 280 281 282 283 284 285 286 287 288
            (c)
            (or (not (characterp c))
                (let* ((i (char-int c))
                       (j (gethash c c->i))
                       (d (gethash i i->c)))
                  (and
                   (or (null j) (eqlt j i))
                   (or (null d) (char= c d))
                   (progn
                     (setf (gethash c c->i) i)
                     (setf (gethash i i->c) c)
                     t))))))
289 290
      (or
       (loop for i from 0 below (min (ash 1 16) char-code-limit)
sds's avatar
sds committed
291 292
             unless (%insert (code-char i))
             collect i)
293
       (loop for i = (random char-code-limit)
sds's avatar
sds committed
294 295 296
             repeat 1000
             unless (%insert (code-char i))
             collect i)
297 298
       (find-if-not #'%insert +standard-chars+)
       (find-if-not #'%insert *universe*)))))
299 300 301 302

(defun char-name.1.fn ()
  (declare (optimize (safety 3) (speed 1) (space 1)))
  (flet ((%check
sds's avatar
sds committed
303 304 305 306 307 308
          (c)
          (or (not (characterp c))
              (let ((name (char-name c)))
                (or (null name)
                    (and (stringp name)
                         (eqlt c (name-char name))))))))
309
    (and
310
     (loop for i from 0 below (min (ash 1 16) char-code-limit)
sds's avatar
sds committed
311
           always (%check (code-char i)))
312 313 314 315 316
     (every #'%check +standard-chars+)
     (every #'%check *universe*)
     t)))

(defun name-char.1.body ()
317
  (declare (optimize (safety 3)))
318
  (loop for x in *universe*
sds's avatar
sds committed
319
        for s = (catch-type-error (string x))
320
        unless
sds's avatar
sds committed
321 322 323 324 325 326 327 328 329 330 331
        (or (eqlt s 'type-error)
            (let ((c (name-char x)))
              (or (not c)
                  (characterp c)
                  ;; FIXME The rest of this wasn't reachable
                  #|
                  (let ((name (char-name c)))
                    (declare (type (or null string) name))
                    (and name
                         (string-equal name s)))
                  |#
332 333
                  )))
        collect x))