Update of /project/mcclim/cvsroot/mcclim/Experimental In directory clnet:/tmp/cvs-serv4400
Modified Files: xpm.lisp Log Message: Rewrote XPM parser to parse directly from one large byte array, rather than using read-line and strings.
--- /project/mcclim/cvsroot/mcclim/Experimental/xpm.lisp 2003/07/12 19:36:56 1.2 +++ /project/mcclim/cvsroot/mcclim/Experimental/xpm.lisp 2006/12/17 20:00:13 1.3 @@ -2,10 +2,12 @@ ;;; --------------------------------------------------------------------------- ;;; Title: XPM Parser ;;; Created: 2003-05-25 -;;; Author: Gilbert Baumann unk6@rz.uni-karlsruhe.de +;;; Authors: Gilbert Baumann unk6@rz.uni-karlsruhe.de +;;; Andy Hefner ahefner@gmail.com ;;; License: LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2003 by Gilbert Baumann +;;; (c) copyright 2006 by Andy Hefner
;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -26,6 +28,26 @@
;;;; Notes
+;;; This is essentially a rewrite/transliteration of Gilbert's original code, +;;; modified to improve performance. This is achieved primarily by using +;;; read-sequence into an (unsigned-byte 8) array and parsing directly +;;; from this array (the original code read a list of strings using read-line +;;; and further divided these into substrings in various places. It is +;;; substantially faster than the original code, but there are opportunities +;;; to further improve performance by perhaps several times, including: +;;; - Use an array rather than hash table to resolve color tokens +;;; (I avoided doing this for now due to a pathological case of a file +;;; with a small palette but high CPP and sparse color tokens) +;;; - Stricter type declarations (some but not all of the code assumes cpp<3) +;;; - In the worst case (photographs), we spent most of our time parsing +;;; the palette (it may have thousands or millions of entries). +;;; - For the above case, we should be generating an RGB or RGBA image +;;; rather than an indexed-pattern (and consing a ton of color objects). +;;; - People who save photographs in XPM format are morons, so it isn't +;;; worth optimizing. + +;;; Gilbert's Notes: + ;; - We lose when the XPM image only specifies colors for say the mono ;; visual. ;; @@ -47,14 +69,9 @@ ;; - This needs to be incorporated into READ-BITMAP-FILE or what ever ;; that is called. ;; -;; - Also: Don't read from text streams but also be able to read from -;; binary streams, as a general image reader will want a binary -;; stream and first parse off a magic to figure out the format and -;; then pass the stream further down here. -;; ;; - We might be interested in the hot spot also. ;; -;; --GB 2003-05-25 +;; --GB 2003-05-25
;;;; Summary of the File Format
@@ -140,174 +157,293 @@ ;; | prefixed by the name of the company. This would ensure uniqueness. ;; |
-(defun xpm-white-space-p (char) - (member char '(#\space #\tab #\newline))) - -(defun xpm-pop-token (string start end) - ;; -> token-start, token-end - (let* ((p1 (position-if-not #'xpm-white-space-p string :start start :end end)) - (p2 (and p1 (or (position-if #'xpm-white-space-p string :start p1 :end end) end)))) - (values p1 p2))) - -(defun xpm-parse-color (string cpp &key (start 0) (end (length string))) - (let ((code (subseq string start (+ start cpp))) - (color (xpm-parse-color-spec string :start (+ start cpp) :end end))) +(deftype xpm-data-array () `(simple-array (unsigned-byte 8) 1)) +(deftype array-index () + #-sbcl '#.(integer 0 #.array-dimension-limit) + #+sbcl 'sb-int:index) +(deftype xpm-pixcode () `(unsigned-byte 24)) ; Bogus upper limit for speed.. =/ + +(defmacro xpm-over-array ((arrayform elt0 idx0 elt1 idx1 start) &body body) + (let ((arraysym (gensym)) + (lengthsym (gensym))) + `(let* ((,arraysym ,arrayform) + (,lengthsym (length ,arraysym))) + (declare (type xpm-data-array ,arraysym) + (optimize (speed 3))) + (loop for ,idx0 of-type array-index from ,start below (1- ,lengthsym) + as ,idx1 of-type array-index = (1+ ,idx0) + as ,elt0 = (aref ,arraysym ,idx0) + as ,elt1 = (aref ,arraysym ,idx1) + do (progn ,@body))))) + +(declaim (inline xpm-whitespace-p) + (ftype (function ((unsigned-byte 8)) t) xpm-whitespace-p)) +(defun xpm-white-space-p (code) + (declare (type (unsigned-byte 8) code) + (optimize (speed 3))) + (or (= code 32) ; #\Space + (= code 9) ; #\Tab + (= code 10))) ; #\Newline + +(defun xpm-token-terminator-p (code) + (declare (type (unsigned-byte 8) code)) + (or (xpm-white-space-p code) + (= code 34))) ; #" + +(defun xpm-token-bounds (data start) + (xpm-over-array (data b0 start b1 i1 start) + (when (not (xpm-white-space-p b0)) + (xpm-over-array (data b0 end b1 i1 start) + (when (xpm-token-terminator-p b0) (return-from xpm-token-bounds (values start end)))) + (error "Unbounded token"))) + (error "Missing token")) + +(defun xpm-extract-color-token (data start end) + (declare (type xpm-data-array data) + (type array-index start end) + (optimize (speed 3))) + (let ((x 0)) + (declare (type xpm-pixcode x)) ; Bah, this didn't help. + (loop for i from start below end do (setf x (+ (ash x 8) (elt data i)))) + x)) + +(defun xpm-parse-color (data cpp index) + (declare (type xpm-data-array data) + (type (integer 1 4) cpp) ; ??? =p + (type array-index index) + (optimize (speed 3) (safety 0))) + (let* ((color-token-end (the array-index (+ index cpp))) + (code (xpm-extract-color-token data index color-token-end)) + (string-end (1- (xpm-exit-string data color-token-end))) + (color (xpm-parse-color-spec data color-token-end string-end))) + (declare (type array-index color-token-end string-end) + (type xpm-pixcode code)) (unless color - (error "Color ~S does not parse." (subseq string (+ start cpp) end))) - (values code color))) - -(defparameter *xpm-color-keys* - '("m" "s" "g4" "g" "c")) + (error "Color ~S does not parse." (map 'string #'code-char (subseq data color-token-end string-end)))) + (values code color (1+ string-end))))
-(defun xpm-parse-color-spec (string &key (start 0) (end (length string))) - ;; Lossage! - ;; There exist files which say e.g. "c light yellow". - ;; How am I supposed to parse that? - ;; - ;; It seems that the C code just parse everything until one of keys. - ;; That is we do the same although it is quite stupid. - ;; - (let ((start0 start) - (key nil) - (color nil) - (last-was-key nil)) - (labels ((quux (k c) - (let ((ink (xpm-parse-single-color k c))) +(declaim (inline xpm-key-p)) +(defun xpm-key-p (x) + (or (= x 109) + (= x 115) + (= x 103) + (= x 99))) + +(defun xpm-parse-color-spec (data start end) + ;; Gilbert says: + ;; > Lossage! + ;; > There exist files which say e.g. "c light yellow". + ;; > How am I supposed to parse that? + ;; > + ;; > It seems that the C code just parse everything until one of keys. + ;; > That is we do the same although it is quite stupid. + ;(declare (optimize (debug 3) (safety 3))) + (declare (optimize (speed 3) (space 0) (safety 0)) + (type xpm-data-array data) + (type array-index start end)) + (let ((original-start start) + key last-was-key + color-token-start + color-token-end) + (declare (type (or null array-index) color-token-start color-token-end) + (type (or null (unsigned-byte 8)) key)) + (flet ((find-token (start end) + (let* ((p1 (position-if-not #'xpm-white-space-p data :start start :end end)) + (p2 (and p1 (or (position-if #'xpm-white-space-p data :start p1 :end end) end)))) + (values p1 p2))) + (quux (key color-token-start color-token-end) + (let ((ink (xpm-parse-single-color key data color-token-start color-token-end))) (when ink - (return-from xpm-parse-color-spec ink))))) - (loop - (multiple-value-bind (p1 p2) (xpm-pop-token string start end) - (unless p1 - (cond (last-was-key - (error "Premature end of color line (no color present after key): ~S." - (subseq string start0 end)))) - (if color - (quux key color)) - (error "We failed to parse a color out of ~S." - (subseq string start0 end))) - (let ((thing (subseq string p1 p2))) - (cond (last-was-key - (setf last-was-key nil) - (setf color thing)) - ((find thing *xpm-color-keys* :test #'string=) - (when color - (quux key color)) - (setf last-was-key t - color nil - key thing)) - (t - (when (null color) - (error "Color not prefixed by a key: ~S." - (subseq string start0 end))) - (setf last-was-key nil) - (setf color (concatenate 'string color " " thing))))) - (setf start p2) ))))) - -(defun xpm-parse-single-color (key color) - (cond ((and (string= key "s") (string-equal color "None")) + (return-from xpm-parse-color-spec ink)))) + (stringize () (map 'string #'code-char (subseq data original-start end)))) + (loop + (multiple-value-bind (p1 p2) (find-token start end) + (unless p1 + (when last-was-key + (error "Premature end of color line (no color present after key): ~S." (stringize))) + (when color-token-start (quux key color-token-start color-token-end)) + (error "We failed to parse a color out of ~S." (stringize))) + (cond (last-was-key + (setf last-was-key nil + color-token-start p1 + color-token-end p2)) + ((xpm-key-p (elt data p1)) + (when color-token-start (quux key color-token-start color-token-end)) + (setf last-was-key t + color-token-start nil + color-token-end nil + key (elt data p1))) + (t (when (null color-token-start) + (error "Color not prefixed by a key: ~S." (stringize))) + (setf last-was-key nil) + (setf color-token-end p2))) + (setf start p2)))))) + +(defun xpm-subvector-eql-p (data start end vector) ; FIXME: Guarantee type of input 'vector' and strengthen declaration + (declare (type xpm-data-array data) + (type array-index start end) + (type simple-array vector) + (optimize (speed 3))) + (and (= (length vector) (- end start)) + (loop for i from start below end + do (unless (= (elt data i) (elt vector (- i start))) (return nil)) + return t))) + +(defun xpm-parse-single-color (key data start end) + (declare (type xpm-data-array data) + (type array-index start end) + (type (unsigned-byte 8) key) + (optimize (speed 3))) + (cond ((and (= key 115) + (or + (xpm-subvector-eql-p data start end #|"None"|# #(78 111 110 101)) + (xpm-subvector-eql-p data start end #|"background"|# #(98 97 99 107 103 114 111 117 110 100)))) clim:+transparent-ink+) - ((and (string= key "c") - (xpm-parse-single-color-2 color))))) - -(defun xpm-parse-single-color-2 (color &aux ink) - (cond ((and (char= (char color 0) ##) - (= 0 (mod (- (length color) 1) 3)) - (every #'(lambda (x) (digit-char-p x 16)) (subseq color 1))) - (let* ((n (1- (length color))) - (w (* 4 (/ n 3))) - (m (1- (expt 2 w))) - (x (parse-integer color :start 1 :radix 16))) - (clim:make-rgb-color (/ (ldb (byte w (* 2 w)) x) m) - (/ (ldb (byte w (* 1 w)) x) m) - (/ (ldb (byte w (* 0 w)) x) m)))) - ((setq ink (xpm-find-named-color color)) - ink))) + ((= key 99) (xpm-parse-single-color-2 data start end)) + (t (error "Unimplemented key type ~A" key))))
-(defun xpm-parse-header (string &key (start 0) (end (length string))) +(declaim (ftype (function ((unsigned-byte 8)) t) xpm-hex-digit-p)) +(defun xpm-hex-digit-p (byte) + (declare (type (unsigned-byte 8) byte) + (optimize (speed 3))) + (or (<= 48 byte 57) + (<= 65 byte 70) + (<= 97 byte 102))) + +(defun xpm-parse-integer-hex (data start end) + (declare (type xpm-data-array data) + (type array-index start end) + (optimize (speed 3))) + (let ((accumulator 0)) ; stupid optimizer.. + (loop for index from start below end + as byte = (elt data index) + do (setf accumulator (+ (ash accumulator 4) + (cond ((<= 48 byte 57) (- byte 48)) + ((<= 65 byte 70) (- byte 65 -10)) + ((<= 97 byte 102) (- byte 97 -10)) + (t (error "Unknown hex digit ~A, this should be impossible." byte))))) + finally (return accumulator)))) + +(defun xpm-parse-single-color-2 (data start end) + (declare (type xpm-data-array data) + (type array-index start end) + (optimize (speed 3))) + (or (and (= (elt data start) 35) ; 35 = ## + (= 0 (mod (- end start 1) 3)) + (loop for i from (1+ start) below end do (unless (xpm-hex-digit-p (elt data i)) (return nil)) finally (return t)) + (let* ((n (- end start 1)) + (w (* 4 (/ n 3))) + (m (1- (expt 2 w))) + (x (xpm-parse-integer-hex data (1+ start) end))) + (clim:make-rgb-color (/ (ldb (byte w (* 2 w)) x) m) + (/ (ldb (byte w (* 1 w)) x) m) + (/ (ldb (byte w (* 0 w)) x) m)))) + (xpm-find-named-color (map 'string #'code-char (subseq data start end))))) + +(defun xpm-parse-header (data &optional (index 0)) + (setf index (xpm-find-next-c-string data index)) + (flet ((token (name) + (multiple-value-bind (p1 p2) (xpm-token-bounds data index) + (unless p1 (error "~A field missing in header." name)) + (setf index p2) + (parse-integer (map 'string #'code-char (subseq data p1 p2)) :radix 10 :junk-allowed nil)))) (values - (multiple-value-bind (p1 p2) (xpm-pop-token string start end) - (unless p1 (error "width field missing in header.")) - (setf start p2) - (parse-integer string :start p1 :end p2 :radix 10 :junk-allowed nil)) - (multiple-value-bind (p1 p2) (xpm-pop-token string start end) - (unless p1 (error "height field missing in header.")) - (setf start p2) - (parse-integer string :start p1 :end p2 :radix 10 :junk-allowed nil)) - (multiple-value-bind (p1 p2) (xpm-pop-token string start end) - (unless p1 (error "ncolors field missing in header.")) - (setf start p2) - (parse-integer string :start p1 :end p2 :radix 10 :junk-allowed nil)) - (multiple-value-bind (p1 p2) (xpm-pop-token string start end) - (unless p1 (error "cpp field missing in header.")) - (setf start p2) - (parse-integer string :start p1 :end p2 :radix 10 :junk-allowed nil)))) - -(defun xpm-parse* (strings) - (multiple-value-bind (width height ncolors cpp) (xpm-parse-header (pop strings)) - (let ((color-hash (make-hash-table :test #'equal)) + (token "width") + (token "height") + (token "ncolors") + (token "cpp") + (xpm-exit-string data index)))) + +(defun xpm-parse* (data) + (declare (type xpm-data-array data)) + (multiple-value-bind (width height ncolors cpp index) (xpm-parse-header data) + (let ((color-hash (make-hash-table :test #'eql)) (designs (make-array ncolors)) (j 0)) + (dotimes (i ncolors) - (multiple-value-bind (code ink) (xpm-parse-color (pop strings) cpp) - (setf (aref designs j) ink) - (setf (gethash code color-hash) j) + (multiple-value-bind (code ink post-index) (xpm-parse-color data cpp (xpm-find-next-c-string data index)) + (setf (aref designs j) ink + (gethash code color-hash) j + index post-index) (incf j))) - (let ((res (make-array (list height width)))) + + ;; It is considerably faster still to make the array below of element type '(unsigned-byte 8), + ;; but this would be wrong by failing to load many legal XPM files. To support both, most + ;; of this file would have to be compiled twice for the different types, which is more + ;; trouble than its worth. =( + (let ((res (make-array (list height width) #|:element-type '(unsigned-byte 8)|#))) + ;(line-start (xpm-find-next-c-string data index)) + (setf index (xpm-find-next-c-string data index)) (dotimes (y height) (dotimes (x width) + (when (= 34 (elt data index)) ; Reached closing quote for this line of pixels? + (setf index (xpm-find-next-c-string data (1+ index)))) (setf (aref res y x) - (or (gethash (subseq (first strings) (* x cpp) (+ cpp (* x cpp))) color-hash) + (or (gethash (xpm-extract-color-token data index (+ index cpp)) color-hash) (error "Color code ~S not defined." - (subseq (first strings) (* x cpp) (+ cpp (* x cpp))))))) - (pop strings)) + (subseq data index (+ index cpp))))) + (incf index cpp))) (clim:make-pattern res designs))))) - -(defun xpm-parse-next-c-string (input) - (do ((c (read-char input nil nil) (read-char input nil nil)))
[101 lines skipped]