-
Notifications
You must be signed in to change notification settings - Fork 2
/
xpm-parser.lisp
389 lines (359 loc) · 13.7 KB
/
xpm-parser.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
;;;; Copyright © 2006 Jeremy English <jhe@jeremyenglish.org>
;;;;
;;;; Permission to use, copy, modify, distribute, and sell this software and its
;;;; documentation for any purpose is hereby granted without fee, provided that
;;;; the above copyright notice appear in all copies and that both that
;;;; copyright notice and this permission notice appear in supporting
;;;; documentation. No representations are made about the suitability of this
;;;; software for any purpose. It is provided "as is" without express or
;;;; implied warranty.
;;;;
;;;; Created: 18-December-2006
;;;;
;;;; Reference: http://koala.ilog.fr/ftp/pub/xpm/xpm-3-paper.ps.gz
(in-package :xpm-to-gif)
(defclass xpm-parser ()
((variable-name :accessor variable-name
:initarg :variable-name)
(color-table :accessor color-table
:initarg :color-table)
(mono-table :accessor mono-table
:initarg :mono-table)
(symbolic-table :accessor symbolic-table
:initarg :symbolic-table)
(level-four-grayscale-table :accessor level-four-grayscale-table
:initarg :level-four-grayscale-table)
(grayscale-table :accessor grayscale-table
:initarg :grayscale-table)
(data :accessor data
:initarg :data)
(width :accessor width
:initarg :width)
(height :accessor height
:initarg :height)
(number-colors :accessor number-colors
:initarg :number-colors)
(characters-per-pixel :accessor characters-per-pixel
:initarg :characters-per-pixel)
(x-hotspot :accessor x-hotspot
:initarg :x-hotspot)
(y-hotspot :accessor y-hotspot
:initarg :y-hotspot)
(string-state :accessor string-state
:initarg :string-state)
(color-count :accessor color-count
:initarg :color-count)
(data-index :accessor data-index
:initarg :data-index))
(:default-initargs
:variable-name ""
:color-table (make-hash-table :test #'equal)
:mono-table (make-hash-table :test #'equal)
:symbolic-table (make-hash-table :test #'equal)
:level-four-grayscale-table (make-hash-table :test #'equal)
:grayscale-table (make-hash-table :test #'equal)
:data nil
:width 0
:height 0
:number-colors 0
:characters-per-pixel 0
:color-count 0
:string-state 'values
:x-hotspot nil
:y-hotspot nil)
(:documentation
"Parse an xpm file. The color tables are hashes that lets you look
up the value set for a character. Data is a character stream of the
raw xpm data"))
(defun expected (s)
"Throws an error stating that s was expected"
(error (format nil "~a expected" s)))
(defun match (reader x)
"If the current symbol of the reader does not match x throw an
error"
(if (char= x (sym reader))
(next reader)
(expected (format nil "~a" x))))
(defun is-white (char)
"Check to see if the character passed is considered white space.
This only works for ASCII values."
(if (characterp char)
(char<= char #\space)
nil))
(defun skip-white (reader)
"Skip over white spaces in the reader."
(loop while (is-white (sym reader))
do (next reader)))
(defun xpm-number (reader)
"Parse a number from the reader and return a integer."
(if (digit-char-p (sym reader))
(let ((w (collect-until
reader
#'(lambda (char)
(not
(digit-char-p char))))))
(skip-white reader)
(parse-integer w))
(error (format nil "Invalid number. Symbol = ~s" (sym reader)))))
;; Color names can be seperated by a space. This means we can not use
;; a simple single lookahead parser.
(defun xpm-color-name (reader)
"Parses the color name from the xpm color table."
(if (or (alpha-char-p (sym reader))
(char= (sym reader) #\_)
(char= (sym reader) #\#)
(char= (sym reader) #\%))
(let ((name "")
(prev-char #\0))
(loop do
(when (char= (sym reader) #\") (return))
(when (is-white prev-char)
(let ((c (sym reader)))
(when (or (char= c #\c)
(char= c #\s)
(char= c #\g)
(char= c #\m))
(next reader)
(if (or (char= (sym reader) #\space)
(and (char= c #\g) (char= (sym reader) #\4)))
(progn
(undo-next reader)
(return))
(undo-next reader)))))
(setf prev-char (sym reader))
(setf name (format nil "~a~a" name (sym reader)))
(next reader))
(string-trim '(#\space) name))
(error (format nil "Invalid color name. Symbol = ~s" (sym reader)))))
(defun xpm-word (reader)
"Get the next word from the reader."
(if (or (alpha-char-p (sym reader)) (char= (sym reader) #\_))
(let ((w (collect-until
reader
#'(lambda (char)
(not
(or (alphanumericp char)
(char= char #\_)))))))
(skip-white reader)
w)
(error (format nil "Invalid word. Symbol = ~s" (sym reader)))))
(defmethod xpm-comment ((xpm xpm-parser) reader)
"Advance over a c style comment in the reader."
(match reader #\/)
(match reader #\*)
(let ((old (sym reader)))
(loop until (and (char= old #\*) (char= (sym reader) #\/)) do
(setf old (sym reader))
(next reader)))
(match reader #\/))
(defmethod xpm-declaration ((xpm xpm-parser) reader)
"Parses the declaration section of the xpm data and sets the
variable name."
(let ((char (xpm-word reader)))
(if (string-equal char "char")
(progn
(match reader #\*)
(skip-white reader)
(let ((var (xpm-word reader)))
(setf (variable-name xpm) var))
(collect-until
reader
#'(lambda (char) (char= char #\{)))
(match reader #\{))
(error "Invalid xpm file. The declaration is wrong"))))
(defmethod xpm-values ((xpm xpm-parser) reader)
"The values section of the xpm data contains the width, height,
number of colors, characters per pixel and optionally the x and y
hotspots."
(match reader #\")
(skip-white reader)
(setf (width xpm) (xpm-number reader))
(setf (height xpm) (xpm-number reader))
(setf (number-colors xpm) (xpm-number reader))
(setf (characters-per-pixel xpm) (xpm-number reader))
(unless (char= #\" (sym reader))
(setf (x-hotspot xpm) (xpm-number reader)))
(unless (char= #\" (sym reader))
(setf (y-hotspot xpm) (xpm-number reader)))
(match reader #\"))
(defmethod pixel-reader ((xpm xpm-parser) reader)
"Read in the number of characters that make up a pixel. Characters
per pixels is defined in the values section."
(let* ((idx 0)
(chars
(collect-until
reader
#'(lambda (char)
(let ((b (= idx (characters-per-pixel xpm))))
(incf idx)
b)))))
chars))
(defmethod parse-color-pair ((xpm xpm-parser) hash-key reader)
"Get the key and color from the colors section of the xpm data and
store them to the correct hash."
(let* ((key (xpm-word reader))
(color (xpm-color-name reader))
(hash
(cond
((string= key "c") (color-table xpm))
((string= key "s") (symbolic-table xpm))
((string= key "g4") (level-four-grayscale-table xpm))
((string= key "g") (grayscale-table xpm))
((string= key "m") (mono-table xpm))
(t (error "Invalid color key.")))))
(setf (gethash hash-key hash) color))
(skip-white reader))
(defmethod xpm-colors ((xpm xpm-parser) reader)
"Parse all key color pairs found in a sting of the colors section"
(match reader #\")
(let* ((chars (pixel-reader xpm reader)))
(skip-white reader)
(loop until (char= #\" (sym reader)) do
(parse-color-pair xpm chars reader))
(match reader #\")))
(defmethod xpm-pixels ((xpm xpm-parser) reader)
"Read in all of the pixels from the pixels section of the xpm file
and store then in the data slot."
(match reader #\")
(loop until (char= (sym reader) #\") do
(let ((pixel (pixel-reader xpm reader)))
(setf (elt (data xpm) (data-index xpm)) pixel)
(incf (data-index xpm))))
(match reader #\"))
(defmethod xpm-string ((xpm xpm-parser) reader)
"Based on the string-state determine what to do with a string found
in the xpm data."
(cond
((equal (string-state xpm) 'values)
(xpm-values xpm reader)
(setf (data xpm) (make-array (* (width xpm) (height xpm))))
(setf (string-state xpm) 'colors)
(setf (color-count xpm) (number-colors xpm)))
((equal (string-state xpm) 'colors)
(xpm-colors xpm reader)
(decf (color-count xpm))
(when (zerop (color-count xpm))
(setf (string-state xpm) 'pixel)
(setf (data-index xpm) 0)))
((equal (string-state xpm) 'pixel)
(xpm-pixels xpm reader))))
(defmethod xpm-main ((xpm xpm-parser) reader)
"The main parsing method. Calls the correction function based on the
readers symbol."
(loop until (or (null (sym reader)) (char= (sym reader) #\})) do
(skip-white reader)
(cond
((char= (sym reader) #\/) (xpm-comment xpm reader))
((char= (sym reader) #\") (xpm-string xpm reader))
((char= (sym reader) #\,) (match reader #\,))
(t
(let ((s (xpm-word reader)))
(if (string-equal s "static")
(xpm-declaration xpm reader)
(error "Invalid xpm file.")))))
(skip-white reader)))
(defmethod parse-xpm-file ((xpm xpm-parser) file-name)
"Parse the file given feeling up the slots of xpm-parser."
(setf (string-state xpm) 'values)
(with-open-file (stream file-name)
(let ((reader (define-stream-reader stream)))
(xpm-main xpm reader))))
(defmethod parse-xpm-string ((xpm xpm-parser) str)
"Define a reader passed on the string passed and parse it."
(let ((reader (define-string-reader str)))
(xpm-main xpm reader)))
#|
;;;Testing code.
(defmacro test-xpm-parser (str xpm-name reader-name &body body)
`(let ((,xpm-name (make-instance 'xpm-parser))
(,reader-name (define-string-reader ,str)))
,@body))
(defun test-xpm-declaration ()
(test-xpm-parser (format nil "/* XPM */~%static char *foo[] = {") xpm reader
(xpm-main xpm reader)
(assert (string= (variable-name xpm) "foo"))))
(defun test-xpm-values ()
(test-xpm-parser "\"50 100 5 2\"" xpm reader
(xpm-string xpm reader)
(assert (= (width xpm) 50))
(assert (= (height xpm) 100))
(assert (= (number-colors xpm) 5))
(assert (= (characters-per-pixel xpm) 2))
(assert (null (x-hotspot xpm)))
(assert (null (y-hotspot xpm))))
(test-xpm-parser "\"50 100 5 2 3 4\"" xpm reader
(xpm-string xpm reader)
(assert (= (width xpm) 50))
(assert (= (height xpm) 100))
(assert (= (number-colors xpm) 5))
(assert (= (characters-per-pixel xpm) 2))
(assert (= (x-hotspot xpm) 3))
(assert (= (y-hotspot xpm) 4))))
(defun test-xpm-colors ()
(test-xpm-parser
(format nil "\"# c #456677 s yow \",~%/*funky stuff*/\"^ c #ffeeff m #eeeeee\"/* is here*/,~%/* MOre stuff here */\"+ c %213466\"~%\": c sandy brown\"~%\" s None c None\"") xpm reader
(setf (string-state xpm) 'colors)
(setf (number-colors xpm) 5)
(setf (color-count xpm) (number-colors xpm))
(setf (characters-per-pixel xpm) 1)
(xpm-main xpm reader)
(assert (string= (gethash "#" (color-table xpm)) "#456677"))
(assert (string= (gethash "#" (symbolic-table xpm)) "yow"))
(assert (string= (gethash "^" (color-table xpm)) "#ffeeff"))
(assert (string= (gethash "^" (mono-table xpm)) "#eeeeee"))
(assert (string= (gethash "+" (color-table xpm)) "%213466"))
(assert (string= (gethash ":" (color-table xpm)) "sandy brown"))
(assert (string= (gethash " " (color-table xpm)) "None"))
(assert (equal (string-state xpm) 'pixel))
(assert (zerop (color-count xpm)))))
(defun test-xpm-file ()
(test-xpm-parser
(format nil
"/* XPM */
static char *noname[] = {
/* width height ncolors chars_per_pixel */
\"9 13 2 1\",
/* colors */
\"` c None s ledbg\",
\"a c #CA1E1C s ledfg\",
/* pixels */
\"`````````\",
\"````aaaaa\",
\"```a````a\",
\"```a````a\",
\"``a````a`\",
\"``a````a`\",
\"`````````\",
\"`a````a``\",
\"`a````a``\",
\"a````a```\",
\"a````a```\",
\"aaaaa````\",
\"`````````\"
};") xpm reader
(let ((data "`````````````aaaaa```a````a```a````a``a````a```a````a```````````a````a```a````a``a````a```a````a```aaaaa`````````````"))
(xpm-main xpm reader)
(print (variable-name xpm))
(assert (string= (variable-name xpm) "noname"))
(assert (= (width xpm) 9))
(assert (= (height xpm) 13))
(assert (= (number-colors xpm) 2))
(assert (= (characters-per-pixel xpm) 1))
(assert (string= (gethash "`" (color-table xpm)) "None"))
(assert (string= (gethash "a" (color-table xpm)) "#CA1E1C"))
(assert (string= (gethash "`" (symbolic-table xpm)) "ledbg"))
(assert (string= (gethash "a" (symbolic-table xpm)) "ledfg"))
(print (length (data xpm)))
(print (* (width xpm) (height xpm)))
(assert (= (length (data xpm)) (* (width xpm) (height xpm))))
(loop for pixel across (data xpm)
for i from 0 do
(assert (string=
pixel
(format nil "~a" (elt data i))))))))
(defun test-xpm-comments ()
(test-xpm-parser "/**/" xpm reader
(xpm-main xpm reader))
(test-xpm-parser "/********/" xpm reader
(xpm-main xpm reader)))
|#