source: trunk/ccl/lib/chars.lisp @ 5328

Last change on this file since 5328 was 5328, checked in by gb, 15 years ago

Use a hashtable to map characters to their names. (Maybe a sparse vector ?).

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 20.6 KB
Line 
1; -*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16;; chars.lisp
17
18(in-package "CCL")
19
20; If object is a character, it is returned.  If it is an integer, its INT-CHAR
21; is returned. If it is a string of length 1, then the sole element of the
22; string is returned.  If it is a symbol whose pname is of length 1, then
23; the sole element of the pname is returned. Else error.
24
25(defun character (arg)
26  "Coerce OBJECT into a CHARACTER if possible. Legal inputs are
27  characters, strings and symbols of length 1."
28  (if (typep arg 'character)
29    arg
30    (if (typep arg 'fixnum)
31      (code-char arg)
32      (if (and (typep arg 'string)
33               (= (the fixnum (length arg)) 1))
34        (char arg 0)
35        (let* ((pname (if (typep arg 'symbol) (symbol-name arg))))
36          (if (and pname (= (the fixnum (length pname)) 1))
37            (char pname 0)
38            (%err-disp $xcoerce arg 'character)))))))
39
40
41
42(defun digit-char (weight &optional radix)
43  "All arguments must be integers. Returns a character object that
44  represents a digit of the given weight in the specified radix. Returns
45  NIL if no such character exists."
46  (let* ((r (if radix (require-type radix 'integer) 10)))
47    (if (and (typep (require-type weight 'integer) 'fixnum)
48             (>= r 2)
49             (<= r 36)
50             (>= weight 0)
51             (< weight r))
52      (locally (declare (fixnum weight))
53        (if (< weight 10)
54          (code-char (the fixnum (+ weight (char-code #\0))))
55          (code-char (the fixnum (+ weight (- (char-code #\A) 10)))))))))
56
57
58
59;True for ascii codes 32-126 inclusive.
60; and for guys >= 128. Its really a function of the font of the moment.
61(defun graphic-char-p (c)
62  "The argument must be a character object. GRAPHIC-CHAR-P returns T if the
63  argument is a printing character (space through ~ in ASCII), otherwise
64  returns NIL."
65  (let* ((code (char-code c)))
66    (unless (eq c #\rubout)
67      (>= code (char-code #\space)))))
68
69
70;True for ascii codes 10 and 32-126 inclusive.
71(defun standard-char-p (c)
72  "The argument must be a character object. STANDARD-CHAR-P returns T if the
73   argument is a standard character -- one of the 95 ASCII printing characters
74   or <return>."
75  (let* ((code (char-code c)))
76    (or (eq c #\newline)
77        (and 
78         (>= code (char-code #\space))
79         (< code (char-code #\rubout))))))
80
81
82
83
84(defun upper-case-p (c)
85  "The argument must be a character object; UPPER-CASE-P returns T if the
86   argument is an upper-case character, NIL otherwise."
87  (let* ((code (char-code c)))
88    (declare (type (mod #x110000) code))
89    (and (>= code (char-code #\A))
90         (<= code (char-code #\Z)))))
91
92
93
94
95(defun both-case-p (c)
96  "The argument must be a character object. BOTH-CASE-P returns T if the
97  argument is an alphabetic character and if the character exists in
98  both upper and lower case. For ASCII, this is the same as ALPHA-CHAR-P."
99  (let* ((code (char-code c)))
100    (declare (type (mod #x110000) code))
101    (or (and (>= code (char-code #\A))
102             (<= code (char-code #\Z)))
103        (and (>= code (char-code #\a))
104             (<= code (char-code #\z))))))
105 
106(defun alphanumericp (c)
107  "Given a character-object argument, ALPHANUMERICP returns T if the
108   argument is either numeric or alphabetic."
109  (let ((code (char-code c)))
110    (declare (type (mod #x110000) code))
111    (or
112     (and (>= code (char-code #\0))
113          (<= code (char-code #\9)))
114     (and (>= code (char-code #\a))
115          (<= code (char-code #\z)))
116     (and (>= code (char-code #\A))
117          (<= code (char-code #\Z))))))
118
119(defun char= (ch &rest others)
120  "Return T if all of the arguments are the same character."
121  (declare (dynamic-extent others))
122  (unless (typep ch 'character)
123    (setq ch (require-type ch 'character)))
124  (dolist (other others t)
125    (unless (eq other ch)
126      (unless (typep other 'character)
127        (setq other (require-type other 'character)))
128      (return))))
129
130(defun char/= (ch &rest others)
131  "Return T if no two of the arguments are the same character."
132  (declare (dynamic-extent others))
133  (unless (typep ch 'character)
134    (setq ch (require-type ch 'character)))
135  (do* ((rest others (cdr rest)))
136       ((null rest) t)
137    (let ((other (car rest)))
138      (if (eq other ch) (return))
139      (unless (typep other 'character)
140        (setq other (require-type other 'character)))
141      (dolist (o2 (cdr rest))
142        (if (eq o2 other)(return-from char/= nil))))))
143
144
145(defun char-equal (char &rest others)
146  "Return T if all of the arguments are the same character.
147  Font, bits, and case are ignored."
148  (declare (dynamic-extent others))
149  (locally (declare (optimize (speed 3)(safety 0)))
150    (dolist (c others t)
151      (when (not (eq c char))
152        (unless (eq (char-upcase char) (char-upcase c))
153          (return))))))
154
155;;; Compares each char against all following chars, not just next one. Tries
156;;; to be fast for one or two args.
157(defun char-not-equal (char &rest others)
158  "Return T if no two of the arguments are the same character.
159   Font, bits, and case are ignored."
160  (declare (dynamic-extent others))
161  (locally (declare (optimize (speed 3) (safety 0)))
162    (let* ((rest (cdr others)))
163      (cond 
164       (rest                   
165        (setq char (char-code (char-upcase char)))
166        (do ((list others (cdr list)))
167            ((null list))
168          (rplaca list (char-code (char-upcase (car list)))))
169        (while others
170          (when (memq char others)
171            (return-from char-not-equal nil))
172          (setq char (car others)
173                others rest
174                rest (cdr others)))
175        t)
176       (others                     ;  2 args, no table
177        (not (eq (char-upcase char) (char-upcase (car others)))))
178       (t t)))))
179
180
181(defun char-lessp (char &rest others)
182  "Return T if the arguments are in strictly increasing alphabetic order.
183   Font, bits, and case are ignored."
184  (declare (dynamic-extent others))
185  (locally (declare (optimize (speed 3)(safety 0)))
186    (let* ((code (char-code (char-upcase char))))
187      (dolist (c others t)
188        (unless (< code (setq code (char-code (char-upcase c))))
189          (return))))))
190
191(defun char-not-lessp (char &rest others)
192  "Return T if the arguments are in strictly non-increasing alphabetic order.
193   Font, bits, and case are ignored."
194  (declare (dynamic-extent others))
195  (locally (declare (optimize (speed 3)(safety 0)))
196    (let* ((code (char-code (char-upcase char))))
197      (dolist (c others t)
198        (when (< code (setq code (char-code (char-upcase c))))
199          (return))))))
200
201(defun char-greaterp (char &rest others)
202  "Return T if the arguments are in strictly decreasing alphabetic order.
203   Font, bits, and case are ignored."
204  (declare (dynamic-extent others))
205  (locally (declare (optimize (speed 3)(safety 0)))
206    (let* ((code (char-code (char-upcase char))))
207      (dolist (c others t)
208        (unless (> code (setq code (char-code (char-upcase c))))
209          (return))))))
210
211(defun char-not-greaterp (char &rest others)
212  "Return T if the arguments are in strictly non-decreasing alphabetic order.
213   Font, bits, and case are ignored."
214  (declare (dynamic-extent others))
215  (locally (declare (optimize (speed 3)(safety 0)))
216    (let* ((code (char-code (char-upcase char))))
217      (dolist (c others t)
218        (when (> code (setq code (char-code (char-upcase c))))
219          (return))))))
220
221
222(defun char> (char &rest others)
223  "Return T if the arguments are in strictly decreasing alphabetic order."
224  (declare (dynamic-extent others))
225  (locally (declare (optimize (speed 3)(safety 0)))
226    (let* ()     
227      (setq char (char-code char))
228      (dolist (c others t)
229        (let ((code (char-code c)))
230          (when (not (%i> char (setq char code)))
231            (return)))))))
232
233(defun char>= (char &rest others)
234  "Return T if the arguments are in strictly non-increasing alphabetic order."
235  (declare (dynamic-extent others))
236  (locally (declare (optimize (speed 3)(safety 0)))
237    (let* ()     
238      (setq char (char-code char))
239      (dolist (c others t)
240        (let ((code (char-code c)))
241          (when (not (%i>= char (setq char code)))
242            (return)))))))
243
244
245(defun char< (char &rest others)
246  "Return T if the arguments are in strictly increasing alphabetic order."
247  (declare (dynamic-extent others))
248  (locally (declare (optimize (speed 3)(safety 0)))
249    (let* ()     
250      (setq char (char-code char))
251      (dolist (c others t)
252        (let ((code (char-code c)))
253          (when (not (%i< char (setq char code)))
254            (return)))))))
255
256(defun char<= (char &rest others)
257  "Return T if the arguments are in strictly non-decreasing alphabetic order."
258  (declare (dynamic-extent others))
259  (locally (declare (optimize (speed 3)(safety 0)))
260    (let* ()     
261      (setq char (char-code char))
262      (dolist (c others t)
263        (let ((code (char-code c)))
264          (when (not (%i<= char (setq char code)))
265            (return)))))))
266
267; This is Common Lisp
268(defun char-int (c)
269  "Return the integer code of CHAR."
270  (char-code c))
271
272
273;If char has an entry in the *NAME-CHAR-ALIST*, return first such entry.
274;Otherwise, if char is a graphics character, return NIL
275;Otherwise, if char code is < 128, return "^C", otherwise "1nn"
276
277(defun char-name (c)
278  "Return the name (a STRING) for a CHARACTER object."
279  (let* ((code (char-code c)))
280    (declare (type (mod #x110000) code))
281    (or (gethash c *char->name*)
282        (cond ((< code #x7f)
283               (when (< code (char-code #\space))
284                 (let ((str (make-string 2 :element-type 'base-char)))
285                   (declare (simple-base-string str))
286                   (setf (schar str 0) #\^)
287                   (setf (schar str 1)(code-char (logxor code #x40)))
288                   str)))
289              ((and (< code #x100)(graphic-char-p c)) nil)
290              (t (format nil "U+~4,'0x" code))))))
291
292
293(defun string-downcase (string &key start end)
294  (setq string (copy-string-arg string))
295  (if (not start) (setq start 0)(require-type start 'fixnum))
296  (if (not end)(setq end (length string))(require-type end 'fixnum))
297  (%strdown string start end))
298
299(defun %strdown (string start end)
300  (declare (fixnum start end))
301  (loop 
302    (when (>= start end)(return string))
303    (let ((code (%scharcode string start)))
304      (when (and (%i>= code (char-code #\A))(%i<= code (char-code #\Z)))
305        (setq code (%i+ code #.(- (char-code #\a)(char-code #\A))))
306        (setf (%scharcode string start) code))
307      (setq start (%i+ 1 start)))))
308
309
310(defun copy-string-arg (string &aux (org 0) len)
311  (etypecase string
312    (string
313     (setq len (length string))
314     (multiple-value-setq (string org)(array-data-and-offset string)))
315    (symbol
316     (setq string (symbol-name string))
317     (setq len (length string)))
318    (character
319     (return-from copy-string-arg
320                    (make-string 1 :initial-element string :element-type (type-of string)))))
321  (%substr string org (+ len org)))     
322
323(defun string-upcase (string &key start end)
324  (setq string (copy-string-arg string))
325  (if (not start) (setq start 0)(require-type start 'fixnum))
326  (if (not end)(setq end (length string))(require-type end 'fixnum))
327  (%strup string start end))
328
329(defun %strup (string start end)
330  (declare (fixnum start end))
331  (loop 
332    (when (>= start end)(return string))
333    (let ((code (%scharcode string start)))
334      (when (and (%i>= code (char-code #\a))(%i<= code (char-code #\z)))
335        (setq code (%i- code #.(- (char-code #\a)(char-code #\A))))
336        (setf (%scharcode string start) code))
337      (setq start (%i+ 1 start)))))
338
339
340
341(defun string-capitalize (string &key start end)
342  (setq string (copy-string-arg string))
343  (if (not start) (setq start 0)(require-type start 'fixnum))
344  (if (not end)(setq end (length string))(require-type end 'fixnum))
345  (%strcap string start end))
346
347(defun %strcap (string start end)
348  (declare (fixnum start end))
349  (let ((state :up)
350        (i start))
351    (declare (fixnum i))
352    (while (< i end)
353      (let* ((c (%schar string i))
354             (alphap (alphanumericp c))) ; makes no sense
355        (if alphap
356          (progn
357            (setf (%schar string i)
358                  (case state
359                    (:up (char-upcase c))
360                    (t (char-downcase c))))
361            (setq state :down))
362          (setq state :up)))
363      (setq i (1+ i)))
364    string))
365
366
367
368
369(defun nstring-downcase (string &key start end)
370  (etypecase string
371    (string
372     (if (not start) (setq start 0)(require-type start 'fixnum))
373     (if (not end)(setq end (length string))(require-type end 'fixnum))
374     (multiple-value-bind (sstring org) (array-data-and-offset string)
375       (%strdown sstring (+ start org)(+ end org)))
376     string)))
377
378(defun nstring-upcase (string &key start end)
379  (etypecase string
380    (string
381     (if (not start) (setq start 0)(require-type start 'fixnum))
382     (if (not end)(setq end (length string))(require-type end 'fixnum))
383     (multiple-value-bind (sstring org) (array-data-and-offset string)
384       (%strup sstring (+ start org)(+ end org)))
385     string)))
386
387
388(defun nstring-capitalize (string &key start end)
389  (etypecase string
390    (string
391     (if (not start) (setq start 0)(require-type start 'fixnum))
392     (if (not end)(setq end (length string))(require-type end 'fixnum))
393     (multiple-value-bind (sstring org) (array-data-and-offset string)
394       (%strcap sstring (+ start org)(+ end org)))
395     string)))
396
397
398
399(defun nstring-studlify (string &key start end)
400  (declare (ignore start end))
401  string)
402
403 
404(defun string-compare (string1 start1 end1 string2 start2 end2)
405  (let ((istart1 (or start1 0)))
406    (if (and (typep string1 'simple-string)(null start1)(null end1))
407      (setq start1 0 end1 (length string1))
408      (multiple-value-setq (string1 start1 end1)(string-start-end string1 start1 end1)))
409    (if (and (typep string2 'simple-string)(null start2)(null end2))
410      (setq start2 0 end2 (length string2))
411      (multiple-value-setq (string2 start2 end2)(string-start-end string2 start2 end2)))
412    (setq istart1 (%i- start1 istart1))       
413    (let* ((val t))
414      (declare (optimize (speed 3)(safety 0)))
415      (do* ((i start1 (%i+ 1 i))
416            (j start2 (%i+ 1 j)))
417           ()
418        (when (eq i end1)
419          (when (neq j end2)(setq val -1))
420          (return))
421        (when (eq j end2)
422          (setq end1 i)
423          (setq val 1)(return))
424        (let ((code1 (%scharcode string1 i))
425              (code2 (%scharcode string2 j)))
426          (declare (fixnum code1 code2))
427          (if (and (>= code1 (char-code #\a))
428                   (<= code1 (char-code #\z)))
429            (setq code1 (- code1 (- (char-code #\a) (char-code #\A)))))
430          (if (and (>= code2 (char-code #\a))
431                   (<= code2 (char-code #\z)))
432            (setq code2 (- code2 (- (char-code #\a) (char-code #\A)))))
433          (unless (= code1 code2)           
434            (setq val (if (%i< code1 code2) -1 1))
435            (setq end1 i)
436            (return))))
437      (values val (%i- end1 istart1)))))
438
439
440(defun string-greaterp (string1 string2 &key start1 end1 start2 end2)
441  "Given two strings, if the first string is lexicographically greater than
442  the second string, returns the longest common prefix (using char-equal)
443  of the two strings. Otherwise, returns ()."
444  (multiple-value-bind (result pos) (string-compare string1 start1 end1 string2 start2 end2)
445    (if (eq result 1) pos nil)))
446
447(defun string-not-greaterp (string1 string2 &key start1 end1 start2 end2)
448  "Given two strings, if the first string is lexicographically less than
449  or equal to the second string, returns the longest common prefix
450  (using char-equal) of the two strings. Otherwise, returns ()."
451  (multiple-value-bind (result pos) (string-compare string1 start1 end1 string2 start2 end2)
452    (if (eq result 1) nil pos)))
453
454(defun string-not-equal (string1 string2 &key start1 end1 start2 end2)
455  "Given two strings, if the first string is not lexicographically equal
456  to the second string, returns the longest common prefix (using char-equal)
457  of the two strings. Otherwise, returns ()."
458  (multiple-value-bind (result pos) (string-compare string1 start1 end1 string2 start2 end2)
459    (if (eq result t) nil pos)))
460
461(defun string-not-lessp (string1 string2 &key start1 end1 start2 end2)
462  "Given two strings, if the first string is lexicographically greater
463  than or equal to the second string, returns the longest common prefix
464  (using char-equal) of the two strings. Otherwise, returns ()."
465  (multiple-value-bind (result pos) (string-compare string1 start1 end1 string2 start2 end2)
466    (if (eq result -1) nil pos)))
467
468(defun string-equal (string1 string2 &key start1 end1 start2 end2)
469  "Given two strings (string1 and string2), and optional integers start1,
470  start2, end1 and end2, compares characters in string1 to characters in
471  string2 (using char-equal)."
472  (eq t (string-compare string1 start1 end1 string2 start2 end2)))
473
474
475(defun string-lessp (string1 string2 &key start1 end1 start2 end2)
476  "Given two strings, if the first string is lexicographically less than
477  the second string, returns the longest common prefix (using char-equal)
478  of the two strings. Otherwise, returns ()."
479  (multiple-value-bind (result pos)(string-compare string1 start1 end1 string2 start2 end2)
480    (if (eq result -1) pos nil)))
481
482; forget script-manager - just do codes
483(defun string-cmp (string1 start1 end1 string2 start2 end2)
484  (let ((istart1 (or start1 0)))
485    (if (and (typep string1 'simple-string)(null start1)(null end1))
486      (setq start1 0 end1 (length string1))
487      (multiple-value-setq (string1 start1 end1)(string-start-end string1 start1 end1)))
488    (if (and (typep string2 'simple-string)(null start2)(null end2))
489      (setq start2 0 end2 (length string2))
490      (multiple-value-setq (string2 start2 end2)(string-start-end string2 start2 end2)))
491    (setq istart1 (%i- start1 istart1))       
492    (let* ((val t))
493      (declare (optimize (speed 3)(safety 0)))
494      (do* ((i start1 (%i+ 1 i))
495            (j start2 (%i+ 1 j)))
496           ()
497        (when (eq i end1)
498          (when (neq j end2)(setq val -1))
499          (return))
500        (when (eq j end2)
501          (setq end1 i)
502          (setq val 1)(return))
503        (let ((code1 (%scharcode string1 i))
504              (code2 (%scharcode string2 j)))
505          (declare (fixnum code1 code2))
506          (unless (= code1 code2)           
507            (setq val (if (%i< code1 code2) -1 1))
508            (setq end1 i)
509            (return))))
510      (values val (%i- end1 istart1)))))
511
512(defun string> (string1 string2 &key start1 end1 start2 end2)
513  "Given two strings, if the first string is lexicographically greater than
514  the second string, returns the longest common prefix (using char=)
515  of the two strings. Otherwise, returns ()."
516  (multiple-value-bind (result pos) (string-cmp string1 start1 end1 string2 start2 end2)
517    (if (eq result 1) pos nil)))
518
519(defun string>= (string1 string2 &key start1 end1 start2 end2)
520  "Given two strings, if the first string is lexicographically greater
521  than or equal to the second string, returns the longest common prefix
522  (using char=) of the two strings. Otherwise, returns ()."
523  (multiple-value-bind (result pos) (string-cmp string1 start1 end1 string2 start2 end2)
524    (if (eq result -1) nil pos)))
525
526(defun string< (string1 string2 &key start1 end1 start2 end2)
527  "Given two strings, if the first string is lexicographically less than
528  the second string, returns the longest common prefix (using char=)
529  of the two strings. Otherwise, returns ()."
530  (multiple-value-bind (result pos) (string-cmp string1 start1 end1 string2 start2 end2)
531    (if (eq result -1) pos nil)))
532
533(defun string<= (string1 string2 &key start1 end1 start2 end2)
534  "Given two strings, if the first string is lexicographically less than
535  or equal to the second string, returns the longest common prefix
536  (using char=) of the two strings. Otherwise, returns ()."
537  (multiple-value-bind (result pos) (string-cmp string1 start1 end1 string2 start2 end2)
538    (if (eq result 1) nil pos)))
539
540; this need not be so fancy?
541(defun string/= (string1 string2 &key start1 end1 start2 end2)
542  "Given two strings, if the first string is not lexicographically equal
543  to the second string, returns the longest common prefix (using char=)
544  of the two strings. Otherwise, returns ()."
545  (multiple-value-bind (result pos) (string-cmp string1 start1 end1 string2 start2 end2)
546    (if (eq result t) nil pos)))
547
548
549
550(provide 'chars)
Note: See TracBrowser for help on using the repository browser.