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(a)mikemac.com)
;;; (c) copyright 2000 by Robert Strandh (strandh(a)labri.u-bordeaux.fr)
-;;; (c) copyright 2002 by Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de>
+;;; (c) copyright 1998,2002 by Gilbert Baumann <unk6(a)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(a)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(a)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(a)rz.uni-karlsruhe.de>
;;; Andy Hefner <ahefner(a)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]
