[mcclim-cvs] CVS mcclim/Extensions/Images
thenriksen
thenriksen at common-lisp.net
Sun Jan 6 08:36:57 UTC 2008
Update of /project/mcclim/cvsroot/mcclim/Extensions/Images
In directory clnet:/tmp/cvs-serv18285/Extensions/Images
Added Files:
gif.lisp images.lisp package.lisp xpm.lisp
Log Message:
Added extension MCCLIM-IMAGES in Extensions/Images.
This extension is a simple collection of functions that make it easy
to load images and convert them into CLIM designs. Currently, only the
GIF and XPM formats are supported. If it turns out that the facilities
provided by MCCLIM-IMAGES are useful for non-CLIM applications, it
could be generalised into an external library, but due to its
simplicity, I doubt the major benefit of this.
An example of use:
;; Is there a non-CLIM-INTERNALS way of getting these things drawn?
(define-presentation-method present ((pattern climi::pattern) (type climi::pattern) stream
(view drei-view)
&key acceptably for-context-type)
(declare (ignore acceptably for-context-type))
(multiple-value-bind (x y) (stream-cursor-position stream)
(draw-pattern* stream pattern x y)
(stream-increment-cursor-position stream (+ (pattern-width pattern)) 0)))
(asdf:operate 'asdf:load-op :mcclim-images)
(asdf:operate 'asdf:load-op :mcclim-images-gif)
(asdf:operate 'asdf:load-op :mcclim-images-xpm)
(define-command (com-insert-image :name t :command-table climacs-gui::development-table)
((image-pathname 'pathname :default (merge-pathnames (user-homedir-pathname))
:insert-default t))
(if (probe-file image-pathname)
(handler-case
(insert-object (point) (mcclim-images:load-image image-pathname))
(mcclim-images:unsupported-image-format (c)
(display-message "Image format ~A not recognized" (mcclim-images:image-format c))))
(display-message "No such file: ~A" image-pathname)))
--- /project/mcclim/cvsroot/mcclim/Extensions/Images/gif.lisp 2008/01/06 08:36:57 NONE
+++ /project/mcclim/cvsroot/mcclim/Extensions/Images/gif.lisp 2008/01/06 08:36:57 1.1
;;; -*- Mode: Lisp; Package: MCCLIM-IMAGES -*-
;;; (c) copyright 2008 by
;;; Troels Henriksen (athas at 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.
(in-package :mcclim-images)
(define-image-reader "gif" (image-pathname &key)
(let* ((data-stream (skippy:load-data-stream image-pathname))
(first-image (aref (skippy:images data-stream) 0))
(pattern-array (make-array (list (skippy:height first-image)
(skippy:width first-image))))
(designs (coerce (loop with color-table = (skippy:color-table data-stream)
for i below 255
collecting (multiple-value-bind (r g b)
(skippy:color-rgb (skippy:color-table-entry color-table i))
(make-rgb-color (/ r 255) (/ g 255) (/ b 255))))
'vector)))
(dotimes (y (array-dimension pattern-array 0))
(dotimes (x (array-dimension pattern-array 1))
(setf (aref pattern-array y x) (skippy:pixel-ref first-image x y))))
(make-pattern pattern-array designs)))
--- /project/mcclim/cvsroot/mcclim/Extensions/Images/images.lisp 2008/01/06 08:36:57 NONE
+++ /project/mcclim/cvsroot/mcclim/Extensions/Images/images.lisp 2008/01/06 08:36:57 1.1
;;; -*- Mode: Lisp; Package: MCCLIM-IMAGES -*-
;;; (c) copyright 2008 by
;;; Troels Henriksen (athas at 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.
(in-package :mcclim-images)
(defvar *image-readers* (make-hash-table :test 'equalp)
"A hash table mapping lowercase image format names to a
function that can read an image of that format. The functions
will be called with at least one argument, the pathname of the
file to be read, and any keyword arguments provided by the
user.")
(defun image-format-supported (format)
"Return true if `format' is supported by `load-image'."
(not (null (gethash format *image-readers*))))
(define-condition unsupported-image-format (error)
((%format :reader image-format
:initarg :image-format
:initform (error "The image format must be supplied")
:documentation "The image format that cannot be loaded"))
(:report (lambda (condition stream)
(format
stream "Cannot read image of unknown format \"~A\""
(image-format condition))))
(:documentation "This exception is signalled when
`load-image-of-type' is called on an image of a type that no
reader has been defined for."))
(defun unsupported-image-format (format)
"Signal an error of type `unsupprted-image-format' for the
image format `format'."
(error 'unsupported-image-format :image-format format))
(defun load-image (image-pathname &rest args &key)
"Load an image from `image-pathname', with the format of the
image being the pathname-type of `image-pathname'. `Args' can be
any keyword-arguments, they will be passed on to the image reader
function for the relevant image format. If the image format is
not recognised, an error of type `unsupprted-image-format' will
be signalled."
(apply #'load-image-of-format (pathname-type image-pathname)
image-pathname args))
(defun load-image-of-format (format image-pathname &rest args &key)
"Load an image of format `format' from `image-pathname'. `Args'
can be any keyword-arguments, they will be passed on to the image
reader function for `format'. If the image format is not
recognised, an error of type `unsupprted-image-format' will be
signalled."
(apply (or (gethash format *image-readers*)
(unsupported-image-format format))
image-pathname args))
(defmacro define-image-reader (image-format (&rest args) &body body)
`(setf (gethash ,image-format *image-readers*)
#'(lambda (, at args)
, at body)))
--- /project/mcclim/cvsroot/mcclim/Extensions/Images/package.lisp 2008/01/06 08:36:57 NONE
+++ /project/mcclim/cvsroot/mcclim/Extensions/Images/package.lisp 2008/01/06 08:36:57 1.1
;;; -*- Mode: Lisp; Package: CL-USER -*-
;;; (c) copyright 2008 by
;;; Troels Henriksen (athas at 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.
(in-package :cl-user)
(defpackage :mcclim-images
(:use :clim-lisp :clim)
(:export :export #:image-format-supported
#:load-image #:load-image-of-format
#:unsupported-image-format #:image-format))
--- /project/mcclim/cvsroot/mcclim/Extensions/Images/xpm.lisp 2008/01/06 08:36:57 NONE
+++ /project/mcclim/cvsroot/mcclim/Extensions/Images/xpm.lisp 2008/01/06 08:36:57 1.1
;;; -*- Mode: Lisp; Package: MCCLIM-IMAGES -*-
;;; (c) copyright 2003 by
;;; Gilbert Baumann (unk6 at rz.uni-karlsruhe.de)
;;; (c) copyright 2006 by
;;; Andy Hefner (ahefner at gmail.com)
;;; (c) copyright 2008 by
;;; Troels Henriksen (athas at 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.
(in-package :mcclim-images)
;;;; 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 , at 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)))
[951 lines skipped]
More information about the Mcclim-cvs
mailing list