Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv15385
Modified Files: NEWS clim-examples.asd clim-listener.asd decls.lisp design.lisp graphics.lisp mcclim.asd package.lisp Added Files: mcclim-gif-bitmaps.asd mcclim-jpeg-bitmaps.asd xpm.lisp Log Message: Converted MCCLIM-IMAGES to CLIM 2.2 bitmap functions (with extensions).
Includes new demo application.
--- /project/mcclim/cvsroot/mcclim/NEWS 2008/01/31 10:47:07 1.34 +++ /project/mcclim/cvsroot/mcclim/NEWS 2008/04/14 16:46:37 1.35 @@ -4,8 +4,9 @@ ** Bug fix: Some missing methods and functions have been implemented for the Null backend, allowing headless operation for many applications. -** New extension: MCCLIM-IMAGES. This extension makes it easy to use - McCLIM for loading and displaying images of various formats. +** Specification compliance: READ-BITMAP-FILE and + MAKE-PATTERN-FROM-BITMAP-FILE from CLIM 2.2. Includes new example + program, IMAGE-VIEWER. ** Drei improvements *** New redisplay engine that is faster and has more features. *** Support for "views" concept. --- /project/mcclim/cvsroot/mcclim/clim-examples.asd 2007/02/05 03:47:40 1.3 +++ /project/mcclim/cvsroot/mcclim/clim-examples.asd 2008/04/14 16:46:37 1.4 @@ -37,7 +37,8 @@ (:file "font-selector") (:file "tabdemo") (:file "bordered-output-examples") - (:file "misc-tests"))) + (:file "misc-tests") + (:file "image-viewer"))) (:module "Goatee" :components ((:file "goatee-test"))))) --- /project/mcclim/cvsroot/mcclim/clim-listener.asd 2008/01/06 15:32:12 1.3 +++ /project/mcclim/cvsroot/mcclim/clim-listener.asd 2008/04/14 16:46:37 1.4 @@ -6,13 +6,10 @@ (in-package :clim-listener.system)
(defsystem :clim-listener - :depends-on (:mcclim #+sbcl :sb-posix :mcclim-images :mcclim-images-xpm) + :depends-on (:mcclim #+sbcl :sb-posix) :components - ((:file "Experimental/xpm" - :pathname #.(make-pathname :directory '(:relative "Experimental") :name "xpm" :type "lisp")) - (:module "Apps/Listener" + ((:module "Apps/Listener" :pathname #.(make-pathname :directory '(:relative "Apps" "Listener")) - :depends-on ("Experimental/xpm") :components ((:file "package") (:file "util" :depends-on ("package")) @@ -22,4 +19,4 @@ (:file "wholine" :depends-on ("package" "dev-commands" "util")) (:file "listener" :depends-on ("package" "wholine" "file-types" "icons" "dev-commands" "util"))
- #+CMU (:file "cmu-hacks" :depends-on ("package")))))) \ No newline at end of file + #+CMU (:file "cmu-hacks" :depends-on ("package")))))) --- /project/mcclim/cvsroot/mcclim/decls.lisp 2008/01/19 20:35:47 1.49 +++ /project/mcclim/cvsroot/mcclim/decls.lisp 2008/04/14 16:46:37 1.50 @@ -400,6 +400,21 @@ (defgeneric medium-clear-area (medium left top right bottom)) (defgeneric medium-beep (medium))
+;;;; 14.2 + +(defgeneric pattern-width (pattern) + (:documentation "Return the width of `pattern'.")) + +(defgeneric pattern-height (pattern) + (:documentation "Return the height of `pattern'.")) + +(defgeneric pattern-array (pattern) + (:documentation "Returns the array associated with `pattern'.")) + +(defgeneric pattern-designs (pattern) + (:documentation "Returns the array of designs associated with +`pattern'.")) + ;;;; 14.5 (defgeneric draw-design (medium design --- /project/mcclim/cvsroot/mcclim/design.lisp 2008/01/21 20:54:48 1.28 +++ /project/mcclim/cvsroot/mcclim/design.lisp 2008/04/14 16:46:37 1.29 @@ -2,7 +2,7 @@
;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com) ;;; (c) copyright 2000 by Robert Strandh (strandh@labri.u-bordeaux.fr) -;;; (c) copyright 2002 by Gilbert Baumann unk6@rz.uni-karlsruhe.de +;;; (c) copyright 1998,2002 by Gilbert Baumann unk6@rz.uni-karlsruhe.de
;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -402,6 +402,73 @@ (defgeneric compose-in (ink mask)) (defgeneric compose-out (ink mask))
+;;; RGB image designs, efficient support for truecolor images. ARGB +;;; image data represented as an (unsigned-byte 32) array + +(defclass rgb-image () + ((width :initarg :width :accessor image-width) + (height :initarg :height :accessor image-height) + (data :initarg :data + :accessor image-data + :type (or null (simple-array (unsigned-byte 32) (* *)))) + (alphap :initarg :alphap + :initform nil + :accessor image-alpha-p))) + +;; Applications (closure in particular) might want to cache any +;; backend-specific data required to draw an RGB-IMAGE. +;; +;; To implement this caching, designs must be created separately for each +;; medium, so that mediums can put their own data into them. + +(defclass rgb-image-design (design) + ((medium :initform nil :initarg :medium) + (image :reader image + :initarg :image) + (medium-data :initform nil))) + +(defun make-rgb-image-design (image) + (make-instance 'rgb-image-design :image image)) + + +;; Protocol to free cached data + +(defgeneric medium-free-image-design (medium design)) + +(defun free-image-design (design) + (medium-free-image-design (slot-value design 'medium) design)) + + +;; Drawing protocol + +(defgeneric medium-draw-image-design* (medium design x y)) + +;; Fetching protocol + +(defun sheet-rgb-image (sheet &key x y width height) + (multiple-value-bind (data alphap) + (sheet-rgb-data (port sheet) + sheet + :x x + :y y + :width width + :height height) + (destructuring-bind (height width) + (array-dimensions data) + (make-instance 'rgb-image + :width width + :height height + :data data + :alphap alphap)))) + +(defgeneric sheet-rgb-data (port sheet &key x y width height)) + +(defmethod draw-design + (medium (design rgb-image-design) &rest options + &key (x 0) (y 0) &allow-other-keys) + (with-medium-options (medium options) + (medium-draw-image-design* medium design x y))) + ;; PATTERN is just the an abstract class of all pattern-like design.
;; For performance might consider to sort out pattern, which consists @@ -410,23 +477,17 @@ (define-protocol-class pattern (design))
(defclass indexed-pattern (pattern) - ((array :initarg :array) - (designs :initarg :designs))) + ((array :initarg :array :reader pattern-array) + (designs :initarg :designs :reader pattern-designs)))
(defun make-pattern (array designs) (make-instance 'indexed-pattern :array array :designs designs))
-(defgeneric pattern-width (pattern)) - (defmethod pattern-width ((pattern indexed-pattern)) - (with-slots (array) pattern - (array-dimension array 1))) - -(defgeneric pattern-height (pattern)) + (array-dimension (pattern-array pattern) 1))
(defmethod pattern-height ((pattern indexed-pattern)) - (with-slots (array) pattern - (array-dimension array 0))) + (array-dimension (pattern-array pattern) 0))
(defclass stencil (pattern) ((array :initarg :array))) @@ -442,6 +503,37 @@ (with-slots (array) pattern (array-dimension array 0)))
+;; These methods are included mostly for completeness and are likely +;; of little use in practice. +(defmethod pattern-array ((pattern stencil)) + (let ((array (make-array (list (pattern-height pattern) + (pattern-width pattern))))) + (dotimes (i (pattern-height pattern)) + (dotimes (j (pattern-width pattern)) + (setf (aref array i j) (+ (* i (array-dimension array 1)) j)))) + array)) + +(defmethod pattern-designs ((pattern stencil)) + (with-slots (array) pattern + (let ((designs (make-array (* (pattern-height pattern) + (pattern-width pattern))))) + (dotimes (i (length designs)) + (setf (aref designs i) (make-opacity (row-major-aref array i)))) + array))) + +(defclass rgb-pattern (pattern rgb-image-design) + ()) + +(defmethod pattern-width ((pattern rgb-pattern)) + (image-width (image pattern))) + +(defmethod pattern-height ((pattern rgb-pattern)) + (image-height (image pattern))) + +;; RGB-PATTERNs must be treated specially... +(defmethod medium-draw-pattern* (medium (pattern rgb-pattern) x y) + (medium-draw-image-design* medium pattern x y)) + ;;;
(defclass transformed-design (design) --- /project/mcclim/cvsroot/mcclim/graphics.lisp 2008/01/21 01:26:42 1.60 +++ /project/mcclim/cvsroot/mcclim/graphics.lisp 2008/04/14 16:46:37 1.61 @@ -902,6 +902,23 @@ align-x align-y toward-x toward-y transform-glyphs))
+;;; Some image junk... + +(defmethod medium-free-image-design ((sheet sheet-with-medium-mixin) design) + (medium-free-image-design (sheet-medium sheet) design)) + +(defmethod medium-draw-image-design* :before (current-medium design x y) + (with-slots (medium medium-data) design + (unless (eq medium current-medium) + (when medium + (medium-free-image-design medium design)) + (setf medium current-medium) + (setf medium-data nil)))) + +(defmethod medium-draw-image-design* + ((medium sheet-with-medium-mixin) design x y) + (medium-draw-image-design* (sheet-medium medium) design x y)) + ;;;; ;;;; DRAW-DESIGN ;;;; @@ -995,6 +1012,14 @@
;;;;
+(defmethod draw-design + (medium (design rgb-image-design) &rest options + &key (x 0) (y 0) &allow-other-keys) + (with-medium-options (medium options) + (medium-draw-image-design* medium design x y))) + +;;;; + (defmethod draw-design (medium (pattern pattern) &key clipping-region transformation &allow-other-keys) (draw-pattern* medium pattern 0 0 @@ -1101,3 +1126,92 @@ :radius-left :radius-right :radius-top :radius-bottom)) args))) + +;;; Bitmap images +;;; +;;; Based on CLIM 2.2, with an extension permitting the definition of +;;; new image formats by the user. + +(defvar *bitmap-file-readers* (make-hash-table :test 'equalp) + "A hash table mapping keyword symbols naming bitmap image +formats to a function that can read an image of that format. The +functions will be called with one argument, the pathname of the +file to be read. The functions should return two values as per +`read-bitmap-file'.") + +(defmacro define-bitmap-file-reader (bitmap-format (&rest args) &body body) + "Define a method for reading bitmap images of format +BITMAP-FORMAT that will be used by `read-bitmap-file' and +MAKE-PATTERN-FROM-BITMAP-FILE. BODY should return two values as +per `read-bitmap-file'." + `(setf (gethash ,bitmap-format *bitmap-file-readers*) + #'(lambda (,@args) + ,@body))) + +(defun bitmap-format-supported-p (format) + "Return true if FORMAT is supported by `read-bitmap-file'." + (not (null (gethash format *bitmap-file-readers*)))) + +(define-condition unsupported-bitmap-format (error) + ((%format :reader bitmap-format + :initarg :bitmap-format + :initform (error "The bitmap format must be supplied") + :documentation "The bitmap format that cannot be loaded")) + (:report (lambda (condition stream) + (format + stream "Cannot read bitmap of unknown format "~A"" + (bitmap-format condition)))) + (:documentation "This exception is signalled when +`read-bitmap-file' is called on an bitmap of a type that no reader +has been defined for.")) + +(defun unsupported-bitmap-format (format) + "Signal an error of type `unsupported-bitmap-format' for the +bitmap format `format'." + (error 'unsupported-bitmap-format :bitmap-format format)) + +(defun read-bitmap-file (pathname &key (format :bitmap) (port (find-port))) + "Read a bitmap file named by `pathname'. `Port' specifies the +port that the bitmap is to be used on. `Format' is a keyword +symbol naming any defined bitmap file format defined by +`clim-extensions:define-bitmap-file-reader'. Two values are +returned: a two-dimensional array of pixel values and an array of +either colors or color names. If the second value is non-NIL, the +pixel values are assumed to be indexes into this +array. Otherwise, the pixel values are taken to be RGB values +encoded in 32 bit unsigned integers, with the three most +significant octets being the values R, G and B, in order." + (declare (ignore port)) ; XXX? + (funcall (or (gethash format *bitmap-file-readers*) + (unsupported-bitmap-format format)) + pathname)) + +(defun make-pattern-from-bitmap-file (pathname &key designs + (format :bitmap) (port (find-port))) + "Read a bitmap file named by `pathname'. `Port' specifies the +port that the bitmap is to be used on. `Format' is a keyword +symbol naming any defined bitmap file format defined by +`clim-extensions:define-bitmap-file-reader'. Two values are +returned: a two-dimensional array of pixel values and an array of +either colors or color names. If the second value is non-NIL, the +pixel values are assumed to be indexes into this +array. Otherwise, the pixel values are taken to be RGB values +encoded in 32 bit unsigned integers, with the three most +significant octets being the values R, G and B, in order." + (multiple-value-bind (res read-designs) + (read-bitmap-file pathname :format format :port port) + (if read-designs + (make-pattern res (or designs read-designs)) + (make-instance 'rgb-pattern :image (make-instance 'rgb-image + :width (array-dimension res 0) + :height (array-dimension res 1) + :data res))))) + +(define-bitmap-file-reader :xpm (pathname) + (xpm-parse-file pathname)) + +(define-bitmap-file-reader :pixmap (pathname) + (read-bitmap-file pathname :format :xpm)) + +(define-bitmap-file-reader :pixmap-3 (pathname) + (read-bitmap-file pathname :format :xpm)) --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/03/28 19:53:19 1.77 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/04/14 16:46:37 1.78 @@ -219,6 +219,7 @@ :components ((:file "text-formatting") (:file "defresource") (:file "presentations") + (:file "xpm") (:file "bordered-output" :depends-on ("presentations")) (:file "table-formatting" :depends-on ("presentations")) (:file "input-editing" :depends-on ("presentations" "bordered-output" "table-formatting")) @@ -362,8 +363,6 @@ (:file "input-editing-goatee") (:file "input-editing-drei") (:file "text-editor-gadget") - (:file "Extensions/rgb-image" :pathname #.(make-pathname :directory '(:relative "Extensions") - :name "rgb-image")) (:file "Extensions/tab-layout" :pathname #.(make-pathname :directory '(:relative "Extensions") :name "tab-layout")))) @@ -547,35 +546,6 @@ (:file "Looks/pixie" :pathname #.(make-pathname :directory '(:relative "Looks") :name "pixie" :type "lisp"))))
-(defsystem :mcclim-images - :depends-on (:clim) - :components ((:module "Extensions/Images" - :pathname #.(make-pathname :directory '(:relative "Extensions" "Images")) - :components ((:file "package") - (:file "images" :depends-on ("package")) - (:file "image-viewer" :depends-on ("images")))))) - -(defmacro support-format (format &rest depends-on) - "Generate the ASDF `defsystem' form for a single-file system -consisting of a file with the name `format' in -Extensions/Images. It will depend on the ASDF systems listed in -`depends-on' as well as MCCLIM-IMAGES." - `(defsystem ,(intern (format nil "MCCLIM-IMAGES-~A" (string-upcase format)) - (find-package :keyword)) - :depends-on (:mcclim-images ,@depends-on) - :components - ((:file ,format - :pathname ,(make-pathname :directory '(:relative "Extensions" "Images") - :name format))))) - -(defmacro support-formats (&rest formats) - "Generate the ASDF `defsystem' forms for supporting -`formats'." - `(progn ,@(loop for (format . depends-on) in formats - collecting `(support-format ,format ,@depends-on)))) - -(support-formats ("gif" :skippy) ("xpm") ("jpeg" :cl-jpeg)) - ;;; The actual McCLIM system that people should to use in their ASDF ;;; package dependency lists. (defsystem :mcclim --- /project/mcclim/cvsroot/mcclim/package.lisp 2008/02/03 18:49:57 1.67 +++ /project/mcclim/cvsroot/mcclim/package.lisp 2008/04/14 16:46:38 1.68 @@ -1648,6 +1648,8 @@ #:+list-pane-view+ ;constant #:option-pane-view ;class #:+option-pane-view+ ;constant + #:pattern-array ;generic function (in franz user guide) + #:pattern-designs ;generic function (in franz user guide) #:pointer-input-rectangle ;function (in franz user guide) #:pointer-input-rectangle* ;function (in franz user guide) #:pointer-place-rubber-band-line* ;function (in franz user guide) @@ -1657,6 +1659,7 @@ #:+push-button-view+ ;constant #:radio-box-view ;class #:+radio-box-view+ ;class + #:read-bitmap-file ;function #:slider-view ;slider-view #:+slider-view+ ;constant #:text-editor-view ;class @@ -1963,7 +1966,11 @@ #:font-face-family #:font-face-all-sizes #:font-face-scalable-p - #:font-face-text-style)) + #:font-face-text-style + + #:define-bitmap-file-reader + #:unsupported-bitmap-format + #:bitmap-format))
;;; Symbols that must be defined by a backend. ;;;
--- /project/mcclim/cvsroot/mcclim/mcclim-gif-bitmaps.asd 2008/04/14 16:46:39 NONE +++ /project/mcclim/cvsroot/mcclim/mcclim-gif-bitmaps.asd 2008/04/14 16:46:39 1.1 ;;; -*- Mode: Lisp -*-
;;; (c) copyright 2008 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA.
(cl:defpackage :mcclim-gif-bitmaps.system (:use :asdf :cl))
(cl:in-package :mcclim-gif-bitmaps.system)
(defsystem :mcclim-gif-bitmaps :description "Support for GIF images in McCLIM bitmap reading functions." :depends-on (:mcclim :skippy) :components ((:file "gif" :pathname #P"Extensions/Bitmap-formats/gif"))) --- /project/mcclim/cvsroot/mcclim/mcclim-jpeg-bitmaps.asd 2008/04/14 16:46:39 NONE +++ /project/mcclim/cvsroot/mcclim/mcclim-jpeg-bitmaps.asd 2008/04/14 16:46:39 1.1 ;;; -*- Mode: Lisp -*-
;;; (c) copyright 2008 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA.
(cl:defpackage :mcclim-gif-bitmaps.system (:use :asdf :cl))
(cl:in-package :mcclim-gif-bitmaps.system)
(defsystem :mcclim-jpeg-bitmaps :description "Support for JPEG images in McCLIM bitmap reading functions." :depends-on (:mcclim :cl-jpeg) :components ((:file "gif" :pathname #P"Extensions/Bitmap-formats/jpeg"))) --- /project/mcclim/cvsroot/mcclim/xpm.lisp 2008/04/14 16:46:39 NONE +++ /project/mcclim/cvsroot/mcclim/xpm.lisp 2008/04/14 16:46:39 1.1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-INTERNALS; -*- ;;; --------------------------------------------------------------------------- ;;; Title: XPM Parser ;;; Created: 2003-05-25 ;;; 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 ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA.
(in-package :clim-internals)
;;;; 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. ;; ;; - We need a little refactoring: ;; ;; . The list of colors below is now actually the second place we have ;; that. ;; ;; . Parsing of #rgb style colors is now the upteens place we have ;; that in general. ;; ;; => Put that in utils.lisp and document its interface. ;; ;; - The ASCII-centric approach of XPM makes it suitable for embedding ;; it into sources files. I want a macro which takes a list of ;; strings according the XPM format and turns it into a make-pattern ;; call. ;; ;; - This needs to be incorporated into READ-BITMAP-FILE or what ever ;; that is called. ;; ;; - We might be interested in the hot spot also. ;; ;; --GB 2003-05-25
;;;; Summary of the File Format
;; [as of the XPM-3.4i documentation by Arnaud Le Hors].
;; | The XPM Format ;; | ;; | The XPM format presents a C syntax, in order to provide the ability to ;; | include XPM files in C and C++ programs. It is in fact an array of ;; | strings composed of six different sections as follows: ;; | ;; | /* XPM */ ;; | static char* <variable_name>[] = { ;; | <Values> ;; | <Colors> ;; | <Pixels> ;; | <Extensions> ;; | }; ;; | ;; | The words are separated by a white space which can be composed of ;; | space and tabulation characters. The <Values> section is a string ;; | containing four or six integers in base 10 that correspond to: the ;; | pixmap width and height, the number of colors, the number of ;; | characters per pixel (so there is no limit on the number of colors), ;; | and, optionally the hotspot coordinates and the XPMEXT tag if there is ;; | any extension following the <Pixels> section. ;; | ;; | <width> <height> <ncolors> <cpp> [<x_hotspot> <y_hotspot>] [XPMEXT] ;; | ;; | The Colors section contains as many strings as there are colors, and ;; | each string is as follows: ;; | ;; | <chars> {<key> <color>}+ ;; | ;; | Where <chars> is the <chars_per_pixel> length string (not surrounded ;; | by anything) representing the pixels, <color> is the specified color, ;; | and <key> is a keyword describing in which context this color should ;; | be used. Currently the keys may have the following values: ;; | ;; | m for mono visual ;; | s for symbolic name ;; | g4 for 4-level grayscale ;; | g for grayscale with more than 4 levels ;; | c for color visual ;; | ;; | Colors can be specified by giving the colorname, a # followed by the ;; | RGB code in hexadecimal, or a % followed by the HSV code (not ;; | implemented). The symbolic name provides the ability of specifying the ;; | colors at load time and not to hardcode them in the file. ;; | ;; | Also the string None can be given as a colorname to mean ;; | ``transparent''. Transparency is supported by the XPM library by ;; | providing a masking bitmap in addition to the pixmap. This mask can ;; | then be used either as a clip-mask of an Xlib GC, or a shape-mask of a ;; | window using the X11 Nonrectangular Window Shape Extension [XShape]. ;; | The <Pixels> section is composed by <height> strings of <width> * ;; | <chars_per_pixel> characters, where every <chars_per_pixel> length ;; | string must be one of the previously defined groups in the <Colors> ;; | section. ;; | ;; | Then follows the <Extensions> section which must be labeled, if not ;; | empty, in the <Values> section as previously described. This section ;; | may be composed by several <Extension> subsections which may be of two ;; | types: ;; | ;; | . one stand alone string composed as follows: ;; | ;; | XPMEXT <extension-name> <extension-data> ;; | ;; | . or a block composed by several strings: ;; | ;; | XPMEXT <extension-name> ;; | <related extension-data composed of several strings> ;; | ;; | Finally, if not empty, this section must end by the following string: ;; | ;; | XPMENDEXT ;; | ;; | Extensions can be used to store any type of data one might want to ;; | store along with a pixmap, as long as they are properly encoded so ;; | they do not conflict with the general syntax. To avoid possible ;; | conflicts with extension names in shared files, they should be ;; | prefixed by the name of the company. This would ensure uniqueness. ;; |
(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." (map 'string #'code-char (subseq data color-token-end string-end)))) (values code color (1+ string-end))))
(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)))) (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+) ((= key 99) (xpm-parse-single-color-2 data start end)) (t (error "Unimplemented key type ~A" key))))
(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)
[893 lines skipped]