[graphic-forms-cvs] r198 - in trunk: . src src/uitoolkit/graphics src/uitoolkit/graphics/plugins src/uitoolkit/graphics/plugins/imagemagick src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Mon Jul 17 04:48:15 UTC 2006
Author: junrue
Date: Mon Jul 17 00:48:13 2006
New Revision: 198
Added:
trunk/src/uitoolkit/graphics/plugins/
trunk/src/uitoolkit/graphics/plugins/graphics-plugin-packages.lisp
trunk/src/uitoolkit/graphics/plugins/imagemagick/
trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp
- copied, changed from r153, trunk/src/uitoolkit/graphics/magick-core-api.lisp
trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-types.lisp
- copied, changed from r58, trunk/src/uitoolkit/graphics/magick-core-types.lisp
trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp
Removed:
trunk/src/uitoolkit/graphics/magick-core-api.lisp
trunk/src/uitoolkit/graphics/magick-core-types.lisp
Modified:
trunk/graphic-forms-uitoolkit.asd
trunk/src/packages.lisp
trunk/src/uitoolkit/graphics/graphics-classes.lisp
trunk/src/uitoolkit/graphics/graphics-generics.lisp
trunk/src/uitoolkit/graphics/image-data.lisp
trunk/src/uitoolkit/widgets/thread-context.lisp
trunk/src/uitoolkit/widgets/widget-utils.lisp
Log:
created a plugin system for choosing what library code to load for image data processing, moved existing ImageMagick support into such a plugin
Modified: trunk/graphic-forms-uitoolkit.asd
==============================================================================
--- trunk/graphic-forms-uitoolkit.asd (original)
+++ trunk/graphic-forms-uitoolkit.asd Mon Jul 17 00:48:13 2006
@@ -69,9 +69,7 @@
(:module "graphics"
:depends-on ("system")
:components
- ((:file "magick-core-types")
- (:file "magick-core-api")
- (:file "graphics-constants")
+ ((:file "graphics-constants")
(:file "graphics-classes")
(:file "graphics-generics")
(:file "color")
@@ -80,7 +78,18 @@
(:file "image")
(:file "font-data")
(:file "font")
- (:file "graphics-context")))
+ (:file "graphics-context")
+ (:module "plugins"
+ :components
+ ((:file "graphics-plugin-packages")
+#+load-imagemagick-plugin
+ (:module "imagemagick"
+ ; :depends-on ("graphics")
+ :components
+ ((:file "magick-core-types")
+ (:file "magick-core-api")
+ (:file "magick-data-plugin"
+ :depends-on ("magick-core-types" "magick-core-api"))))))))
(:module "widgets"
:depends-on ("graphics")
:components
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Mon Jul 17 00:48:13 2006
@@ -111,6 +111,7 @@
#:graphics-context
#:image
#:image-data
+ #:image-data-plugin
#:palette
#:pattern
#:transform
@@ -121,8 +122,10 @@
#:*color-green*
#:*color-red*
#:*color-white*
+ #:*image-file-types*
;; methods, functions, macros
+ #:accepts-file-p
#:alpha
#:anti-alias
#:ascent
@@ -142,6 +145,7 @@
#:copy-color
#:copy-font-data
#:copy-font-metrics
+ #:data->image
#:data-object
#:depth
#:descent
Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original)
+++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Mon Jul 17 00:48:13 2006
@@ -81,7 +81,13 @@
(direct nil)
(table nil))) ; vector of COLOR structs
-(defclass image-data (gfs:native-object) ()
+(defclass image-data-plugin (gfs:native-object) ()
+ (:documentation "Graphics library plugin implementation objects."))
+
+(defclass image-data ()
+ ((data-plugin
+ :reader data-plugin-of
+ :initform nil))
(:documentation "This class maintains image attributes, color, and pixel data."))
(defclass font (gfs:native-object) ()
Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original)
+++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Mon Jul 17 00:48:13 2006
@@ -36,6 +36,9 @@
(defgeneric background-color (self)
(:documentation "Returns a color object corresponding to the current background color."))
+(defgeneric data->image (self)
+ (:documentation "Plugins implement this to translate from a data structure to an HGDIOBJ."))
+
(defgeneric data-object (self &optional gc)
(:documentation "Returns the data structure representing the raw form of the object."))
Modified: trunk/src/uitoolkit/graphics/image-data.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/image-data.lisp (original)
+++ trunk/src/uitoolkit/graphics/image-data.lisp Mon Jul 17 00:48:13 2006
@@ -33,10 +33,54 @@
(in-package :graphic-forms.uitoolkit.graphics)
+(defvar *image-plugins* nil)
+
+;;
+;; list the superset of file extensions for formats that any
+;; plugin might support (clearly there are more formats than
+;; this extant in the world, so add more as needed)
+;;
+(defvar *image-file-types* (let ((table (make-hash-table :test #'equal)))
+ (loop for (key value) in '(("bmp" "Microsoft Windows bitmap")
+ ("cur" "Microsoft Windows cursor")
+ ("dib" "Microsoft Windows device-independent bitmap")
+ ("emf" "Microsoft Windows Enhanced Metafile")
+ ("eps" "Adobe Encapsulated PostScript")
+ ("fax" "Group 3 TIFF")
+ ("fig" "FIG graphics format")
+ ("gif" "CompuServe Graphics Interchange Format")
+ ("ico" "Microsoft Windows icon")
+ ("jpeg" "Joint Photographic Experts Group")
+ ("jpg" "Joint Photographic Experts Group")
+ ("pbm" "Portable bitmap format (b/w)")
+ ("pcd" "Photo CD")
+ ("pcl" "HP Page Control Language")
+ ("pcx" "ZSoft IBM PC Paintbrush")
+ ("pdf" "Portable Document Format")
+ ("pgm" "Portable graymap")
+ ("pix" "Alias/Wavefront RLE")
+ ("png" "Portable Network Graphics")
+ ("ppm" "Portable pixmap (color)")
+ ("ps" "Adobe PostScript")
+ ("svg" "Scalable Vector Graphics")
+ ("tga" "Truevision Targa")
+ ("tiff" "Tagged Image File")
+ ("wmf" "Microsoft Windows Metafile")
+ ("xbm" "X Window System bitmap (b/w)")
+ ("xpm" "X Window System pixmap (color)"))
+ do (setf (gethash key table) value))
+ table))
+
;;;
;;; helper functions
;;;
+(defun find-image-plugin (path)
+ (loop for acceptor in *image-plugins*
+ for plugin = (funcall acceptor path)
+ until plugin
+ finally (return plugin)))
+
(defun image->data (hbmp) (declare (ignore hbmp)))
#|
(defun image->data (hbmp)
@@ -124,147 +168,52 @@
data))
|#
-(defun data->image (data)
- "Convert the image-data object to a bitmap and return the native handle."
- (cffi:with-foreign-object (bi-ptr 'gfs::bitmapinfo)
- (cffi:with-foreign-slots ((gfs::bisize
- gfs::biwidth
- gfs::biheight
- gfs::biplanes
- gfs::bibitcount
- gfs::bicompression
- gfs::bisizeimage
- gfs::bixpels
- gfs::biypels
- gfs::biclrused
- gfs::biclrimp
- gfs::bmicolors)
- bi-ptr gfs::bitmapinfo)
- (let* ((handle (gfs:handle data))
- (sz (size data))
- (pix-count (* (gfs:size-width sz) (gfs:size-height sz)))
- (hbmp (cffi:null-pointer))
- (screen-dc (gfs::get-dc (cffi:null-pointer))))
- (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader)
- gfs::biwidth (gfs:size-width sz)
- gfs::biheight (- 0 (gfs:size-height sz))
- gfs::biplanes 1
- gfs::bibitcount 32 ;; 32bpp even if original image file is not
- gfs::bicompression gfs::+bi-rgb+
- gfs::bisizeimage 0
- gfs::bixpels 0
- gfs::biypels 0
- gfs::biclrused 0
- gfs::biclrimp 0)
-
- ;; create the bitmap
- ;;
- (cffi:with-foreign-object (pix-bits-ptr :pointer)
- (setf hbmp (gfs::create-dib-section screen-dc
- bi-ptr
- gfs::+dib-rgb-colors+
- pix-bits-ptr
- (cffi:null-pointer)
- 0))
- (if (gfs:null-handle-p hbmp)
- (error 'gfs:win32-error :detail "create-dib-section failed"))
-
- ;; update the RGBQUADs
- ;;
- (let ((tmp (get-image-pixels handle 0 0 (gfs:size-width sz) (gfs:size-height sz)))
- (ptr (cffi:mem-ref pix-bits-ptr :pointer)))
- (dotimes (i pix-count)
- (cffi:with-foreign-slots ((gfg::blue gfg::green gfg::red gfg::reserved)
- (cffi:mem-aref tmp 'gfg::pixel-packet i)
- gfg::pixel-packet)
- (cffi:with-foreign-slots ((gfs::rgbred gfs::rgbgreen gfs::rgbblue gfs::rgbreserved)
- (cffi:mem-aref ptr 'gfs::rgbquad i) gfs::rgbquad)
- (setf gfs::rgbreserved 0)
- (setf gfs::rgbred (scale-quantum-to-byte red))
- (setf gfs::rgbgreen (scale-quantum-to-byte green))
- (setf gfs::rgbblue (scale-quantum-to-byte blue)))))))
- (unless (gfs:null-handle-p screen-dc)
- (gfs::release-dc (cffi:null-pointer) screen-dc))
- hbmp))))
-
;;;
;;; methods
;;;
-(defmethod depth ((data image-data))
- (let ((handle (gfs:handle data)))
- (if (null handle)
- (error 'gfs:disposed-error))
- (cffi:foreign-slot-value handle 'magick-image 'depth)))
-
-(defmethod gfs:dispose ((data image-data))
- (let ((victim (gfs:handle data)))
- (if (null victim)
- (error 'gfs:disposed-error))
- (destroy-image victim))
- (setf (slot-value data 'gfs:handle) nil))
+(defmethod data->image ((self image-data))
+ (data->image (data-plugin-of self)))
+
+(defmethod depth ((self image-data))
+ (depth (data-plugin-of self)))
-(defmethod load ((data image-data) path)
+(defmethod gfs:dispose ((self image-data))
+ (let ((victim (data-plugin-of self)))
+ (unless (null victim)
+ (gfs:dispose victim)))
+ (setf (slot-value self 'data-plugin) nil))
+
+(defmethod load ((self image-data) path)
(setf path (cond
((typep path 'pathname) (namestring (merge-pathnames path)))
((typep path 'string) (namestring (merge-pathnames path)))
(t
(error 'gfs:toolkit-error :detail "pathname or string required"))))
- (let ((handle (gfs:handle data)))
- (when (and handle (not (cffi:null-pointer-p handle)))
- (destroy-image handle)
- (setf (slot-value data 'gfs:handle) nil)
- (setf handle nil))
- (with-image-path (path info ex)
- (setf handle (read-image info ex))
- (if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined))
- (error 'gfs:toolkit-error :detail (format nil
- "exception reason: ~s"
- (cffi:foreign-slot-value ex 'exception-info 'reason))))
- (if (cffi:null-pointer-p handle)
- (error 'gfs:toolkit-error :detail (format nil "could not load image: ~a" path)))
- (setf (slot-value data 'gfs:handle) handle))))
-
-(defmethod size ((data image-data))
- (let ((handle (gfs:handle data))
- (size (gfs:make-size)))
- (if (or (null handle) (cffi:null-pointer-p handle))
- (error 'gfs:disposed-error))
- (cffi:with-foreign-slots ((rows columns) handle magick-image)
- (setf (gfs:size-height size) rows)
- (setf (gfs:size-width size) columns))
- size))
-
-(defmethod (setf size) (size (data image-data))
- (let ((handle (gfs:handle data))
- (new-handle (cffi:null-pointer))
- (ex (acquire-exception-info)))
- (if (or (null handle) (cffi:null-pointer-p handle))
- (error 'gfs:disposed-error))
- (unwind-protect
- (progn
- (setf new-handle (resize-image handle
- (gfs:size-width size)
- (gfs:size-height size)
- (cffi:foreign-enum-value 'filter-types :lanczos)
- 1.0 ex))
- (if (gfs:null-handle-p new-handle)
- (error 'gfs:toolkit-error :detail (format nil
- "could not resize: ~a"
- (cffi:foreign-slot-value ex
- 'exception-info
- 'reason))))
- (setf (slot-value data 'gfs:handle) new-handle)
- (destroy-image handle))
- (destroy-exception-info ex))))
-(defmethod print-object ((data image-data) stream)
- (if (or (null (gfs:handle data)) (cffi:null-pointer-p (gfs:handle data)))
+ (let ((plugin (data-plugin-of self)))
+ (when plugin
+ (gfs:dispose plugin)
+ (setf (slot-value self 'data-plugin) nil))
+ (setf plugin (find-image-plugin path))
+ (unless plugin
+ (error 'gfs:toolkit-error :detail (format nil "no image data plugin supports: ~a" path)))
+ (load plugin path)
+ (setf (slot-value self 'data-plugin) plugin)))
+
+(defmethod size ((self image-data))
+ (size (data-plugin-of self)))
+
+(defmethod (setf size) (size (self image-data))
+ (setf (gfg:size (data-plugin-of self)) size))
+
+(defmethod print-object ((self image-data) stream)
+ (if (or (null (gfs:handle self)) (cffi:null-pointer-p (gfs:handle self)))
(error 'gfs:disposed-error))
- (let ((size (size data)))
- (print-unreadable-object (data stream :type t)
+ (let ((size (size self)))
+ (print-unreadable-object (self stream :type t)
;; FIXME: dump palette info, too
;;
(format stream "width: ~a " (gfs:size-width size))
(format stream "height: ~a " (gfs:size-height size))
- (format stream "bits per pixel: ~a " (depth data)))))
+ (format stream "bits per pixel: ~a " (depth self)))))
Added: trunk/src/uitoolkit/graphics/plugins/graphics-plugin-packages.lisp
==============================================================================
--- (empty file)
+++ trunk/src/uitoolkit/graphics/plugins/graphics-plugin-packages.lisp Mon Jul 17 00:48:13 2006
@@ -0,0 +1,70 @@
+;;;;
+;;;; packages.lisp
+;;;;
+;;;; Copyright (C) 2006, Jack D. Unrue
+;;;; All rights reserved.
+;;;;
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions
+;;;; are met:
+;;;;
+;;;; 1. Redistributions of source code must retain the above copyright
+;;;; notice, this list of conditions and the following disclaimer.
+;;;;
+;;;; 2. Redistributions in binary form must reproduce the above copyright
+;;;; notice, this list of conditions and the following disclaimer in the
+;;;; documentation and/or other materials provided with the distribution.
+;;;;
+;;;; 3. Neither the names of the authors nor the names of its contributors
+;;;; may be used to endorse or promote products derived from this software
+;;;; without specific prior written permission.
+;;;;
+;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY
+;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS-
+;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY
+;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;;
+
+(in-package #:cl-user)
+
+;;;
+;;; package for base Win32 graphics plugin
+;;;
+(defpackage #:graphic-forms.uitoolkit.graphics.win32
+ (:nicknames #:gfgw32)
+ (:shadow #:load #:type)
+ (:use #:common-lisp)
+ (:export
+
+;; classes and structs
+
+;; constants
+
+;; methods, functions, macros
+
+;; conditions
+ ))
+
+;;;
+;;; package for ImageMagick graphics plugin
+;;;
+(defpackage #:graphic-forms.uitoolkit.graphics.imagemagick
+ (:nicknames #:gfgim)
+ (:shadow #:load #:type)
+ (:use #:common-lisp)
+ (:export
+
+;; classes and structs
+
+;; constants
+
+;; methods, functions, macros
+
+;; conditions
+ ))
Copied: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp (from r153, trunk/src/uitoolkit/graphics/magick-core-api.lisp)
==============================================================================
--- trunk/src/uitoolkit/graphics/magick-core-api.lisp (original)
+++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp Mon Jul 17 00:48:13 2006
@@ -31,12 +31,14 @@
;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;;
-(in-package :graphic-forms.uitoolkit.graphics)
+(in-package :graphic-forms.uitoolkit.graphics.imagemagick)
(eval-when (:compile-toplevel :load-toplevel :execute)
(use-package :cffi)
(pushnew cl-user::*magick-library-directory* cffi:*foreign-library-directories* :test #'equal))
+(defvar *magick-initialized* nil)
+
(load-foreign-library "wsock32.dll")
(load-foreign-library "msvcr71.dll")
(load-foreign-library "x11.dll")
Copied: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-types.lisp (from r58, trunk/src/uitoolkit/graphics/magick-core-types.lisp)
==============================================================================
--- trunk/src/uitoolkit/graphics/magick-core-types.lisp (original)
+++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-types.lisp Mon Jul 17 00:48:13 2006
@@ -31,7 +31,7 @@
;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;;
-(in-package :graphic-forms.uitoolkit.graphics)
+(in-package :graphic-forms.uitoolkit.graphics.imagemagick)
(eval-when (:compile-toplevel :load-toplevel :execute)
(use-package :cffi))
@@ -55,11 +55,11 @@
(defconstant +yellow-channel+ #x00000004)
(defconstant +alpha-channel+ #x00000008)
(defconstant +opacity-channel+ #x00000008)
-(defconstant +matte-channel+ #x00000008) ;; deprecated
+(defconstant +matte-channel+ #x00000008) ; deprecated
(defconstant +black-channel+ #x00000020)
(defconstant +index-channel+ #x00000020)
(defconstant +all-channels+ #x000000FF)
-(defconstant +default-channels+ (logand +all-channels+ (lognot +opacity-channel+))) ;; (AllChannels &~ OpacityChannel)
+(defconstant +default-channels+ (logand +all-channels+ (lognot +opacity-channel+))) ; (AllChannels &~ OpacityChannel)
(defctype quantum :unsigned-short)
@@ -373,9 +373,9 @@
(error-number :int)
(reason :string)
(description :string)
- (exceptions :pointer) ;; void*
+ (exceptions :pointer) ; void*
(relinquish boolean-type)
- (semaphore :pointer) ;; Semaphore*
+ (semaphore :pointer) ; Semaphore*
(signature :unsigned-long))
(defcstruct primary-info
@@ -398,7 +398,7 @@
(defcstruct profile-info
(name :string)
(length :unsigned-long)
- (info :pointer) ;; char*
+ (info :pointer) ; char*
(signature :unsigned-long))
(defcstruct rectangle-info
@@ -430,24 +430,24 @@
(rows :unsigned-long)
(depth :unsigned-long)
(colors :unsigned-long)
- (colormap :pointer) ;; PixelPacket*
+ (colormap :pointer) ; PixelPacket*
(background-color pixel-packet)
(border-color pixel-packet)
(matte-color pixel-packet)
(gamma :double)
(chromaticity chromaticity-info)
(render-intent rendering-intent)
- (profiles :pointer) ;; void*
+ (profiles :pointer) ; void*
(units resolution-type)
- (montage :pointer) ;; char*
- (directory :pointer) ;; char*
- (geometry :pointer) ;; char*
+ (montage :pointer) ; char*
+ (directory :pointer) ; char*
+ (geometry :pointer) ; char*
(offset :long)
(x-resolution :double)
(y-resolution :double)
(page rectangle-info)
(extract-info rectangle-info)
- (tile-info rectangle-info) ;; deprecated
+ (tile-info rectangle-info) ; deprecated
(bias :double)
(blur :double)
(fuzz :double)
@@ -457,7 +457,7 @@
(gravity gravity-type)
(compose composite-operator)
(dispose dispose-type)
- (clip-mask :pointer) ;; Image*
+ (clip-mask :pointer) ; Image*
(scene :unsigned-long)
(delay :unsigned-long)
(ticks-per-second :unsigned-long)
@@ -466,27 +466,27 @@
(start-loop :long)
(error error-info)
(timer timer-info)
- (progress-monitor :pointer) ;; MagickBooleanType (*MagickProgressMonitor)(args)
- (client-data :pointer) ;; void*
- (cache :pointer) ;; void*
- (attributes :pointer) ;; void*
- (ascii85 :pointer) ;; _Ascii85Info_*
- (blob :pointer) ;; _BlobInfo_*
+ (progress-monitor :pointer) ; MagickBooleanType (*MagickProgressMonitor)(args)
+ (client-data :pointer) ; void*
+ (cache :pointer) ; void*
+ (attributes :pointer) ; void*
+ (ascii85 :pointer) ; _Ascii85Info_*
+ (blob :pointer) ; _BlobInfo_*
(filename :char :count 4096)
(magick-filename :char :count 4096)
(magick :char :count 4096)
(exception exception-info)
(debug boolean-type)
(reference-count :long)
- (semaphore :pointer) ;; SemaphoreInfo*
+ (semaphore :pointer) ; SemaphoreInfo*
(color-profile profile-info)
(iptc-profile profile-info)
- (generic-profile :pointer) ;; ProfileInfo*
- (generic-profiles :unsigned-long) ;; deprecated (and ProfileInfo too?)
+ (generic-profile :pointer) ; ProfileInfo*
+ (generic-profiles :unsigned-long) ; deprecated (and ProfileInfo too?)
(signature :unsigned-long)
- (previous :pointer) ;; Image*
- (list :pointer) ;; Image*
- (next :pointer)) ;; Image*
+ (previous :pointer) ; Image*
+ (list :pointer) ; Image*
+ (next :pointer)) ; Image*
(defcstruct magick-image-info
(compression compression-type)
@@ -495,10 +495,10 @@
(adjoin boolean-type)
(affirm boolean-type)
(antialias boolean-type)
- (size :pointer) ;; char*
- (extract :pointer) ;; char*
- (page :pointer) ;; char*
- (scenes :pointer) ;; char*
+ (size :pointer) ; char*
+ (extract :pointer) ; char*
+ (page :pointer) ; char*
+ (scenes :pointer) ; char*
(scene :unsigned-long)
(number-scenes :unsigned-long)
(depth :unsigned-long)
@@ -506,11 +506,11 @@
(endian endian-type)
(units resolution-type)
(quality :unsigned-long)
- (sampling-factor :pointer) ;; char*
- (server-name :pointer) ;; char*
- (font :pointer) ;; char*
- (texture :pointer) ;; char*
- (density :pointer) ;; char*
+ (sampling-factor :pointer) ; char*
+ (server-name :pointer) ; char*
+ (font :pointer) ; char*
+ (texture :pointer) ; char*
+ (density :pointer) ; char*
(point-size :double)
(fuzz :double)
(background-color pixel-packet)
@@ -525,24 +525,24 @@
(group :long)
(ping boolean-type)
(verbose boolean-type)
- (view :pointer) ;; char*
- (authenticate :pointer) ;; char*
- (channel :unsigned-int) ;; ChannelType
- (attributes :pointer) ;; Image*
- (options :pointer) ;; void*
- (progress-monitor :pointer) ;; MagickBooleanType (*MagickProgressMonitor)(args)
- (client-data :pointer) ;; void*
- (cache :pointer) ;; void*
- (stream :pointer) ;; size_t (*StreamHandler)(args)
- (file :pointer) ;; FILE*
- (blob :pointer) ;; void*
+ (view :pointer) ; char*
+ (authenticate :pointer) ; char*
+ (channel :unsigned-int) ; ChannelType
+ (attributes :pointer) ; Image*
+ (options :pointer) ; void*
+ (progress-monitor :pointer) ; MagickBooleanType (*MagickProgressMonitor)(args)
+ (client-data :pointer) ; void*
+ (cache :pointer) ; void*
+ (stream :pointer) ; size_t (*StreamHandler)(args)
+ (file :pointer) ; FILE*
+ (blob :pointer) ; void*
(length :unsigned-int)
(magick :char :count 4096)
(unique :char :count 4096)
(zero :char :count 4096)
(filename :char :count 4906)
(debug boolean-type)
- (tile :pointer) ;; deprecated
+ (tile :pointer) ; deprecated
(subimage :unsigned-long)
(subrange :unsigned-long)
(pen pixel-packet)
Added: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp
==============================================================================
--- (empty file)
+++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Mon Jul 17 00:48:13 2006
@@ -0,0 +1,179 @@
+;;;;
+;;;; magick-data-plugin.lisp
+;;;;
+;;;; Copyright (C) 2006, Jack D. Unrue
+;;;; All rights reserved.
+;;;;
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions
+;;;; are met:
+;;;;
+;;;; 1. Redistributions of source code must retain the above copyright
+;;;; notice, this list of conditions and the following disclaimer.
+;;;;
+;;;; 2. Redistributions in binary form must reproduce the above copyright
+;;;; notice, this list of conditions and the following disclaimer in the
+;;;; documentation and/or other materials provided with the distribution.
+;;;;
+;;;; 3. Neither the names of the authors nor the names of its contributors
+;;;; may be used to endorse or promote products derived from this software
+;;;; without specific prior written permission.
+;;;;
+;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY
+;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS-
+;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY
+;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;;
+
+(in-package :graphic-forms.uitoolkit.graphics.imagemagick)
+
+(defclass magick-data-plugin (gfg:image-data-plugin) ()
+ (:documentation "ImageMagick library plugin for the graphics package."))
+
+(defun accepts-file-p (path)
+ (unless *magick-initialized*
+ (initialize-magick (cffi:null-pointer))
+ (setf *magick-initialized* t))
+ (cond
+ ((parse-namestring path)) ; syntax check
+ ((typep path 'pathname)
+ (setf path (namestring path)))
+ (t
+ (error 'gfs:toolkit-error :detail (format nil "~s must be a string or pathname" path))))
+ (if (gethash (pathname-type path) gfg:*image-file-types*)
+ (let ((plugin (make-instance 'magick-data-plugin)))
+ (gfg:load plugin path)
+ plugin)
+ nil))
+
+(push #'accepts-file-p gfg::*image-plugins*)
+
+(defmethod gfg:data->image ((self magick-data-plugin))
+ "Convert the image-data object to a bitmap and return the native handle."
+ (cffi:with-foreign-object (bi-ptr 'gfs::bitmapinfo)
+ (cffi:with-foreign-slots ((gfs::bisize
+ gfs::biwidth
+ gfs::biheight
+ gfs::biplanes
+ gfs::bibitcount
+ gfs::bicompression
+ gfs::bisizeimage
+ gfs::bixpels
+ gfs::biypels
+ gfs::biclrused
+ gfs::biclrimp
+ gfs::bmicolors)
+ bi-ptr gfs::bitmapinfo)
+ (let* ((handle (gfs:handle self))
+ (sz (gfg:size self))
+ (pix-count (* (gfs:size-width sz) (gfs:size-height sz)))
+ (hbmp (cffi:null-pointer))
+ (screen-dc (gfs::get-dc (cffi:null-pointer))))
+ (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader)
+ gfs::biwidth (gfs:size-width sz)
+ gfs::biheight (- 0 (gfs:size-height sz))
+ gfs::biplanes 1
+ gfs::bibitcount 32 ;; 32bpp even if original image file is not
+ gfs::bicompression gfs::+bi-rgb+
+ gfs::bisizeimage 0
+ gfs::bixpels 0
+ gfs::biypels 0
+ gfs::biclrused 0
+ gfs::biclrimp 0)
+
+ ;; create the bitmap
+ ;;
+ (cffi:with-foreign-object (pix-bits-ptr :pointer)
+ (setf hbmp (gfs::create-dib-section screen-dc
+ bi-ptr
+ gfs::+dib-rgb-colors+
+ pix-bits-ptr
+ (cffi:null-pointer)
+ 0))
+ (if (gfs:null-handle-p hbmp)
+ (error 'gfs:win32-error :detail "create-dib-section failed"))
+
+ ;; update the RGBQUADs
+ ;;
+ (let ((tmp (get-image-pixels handle 0 0 (gfs:size-width sz) (gfs:size-height sz)))
+ (ptr (cffi:mem-ref pix-bits-ptr :pointer)))
+ (dotimes (i pix-count)
+ (cffi:with-foreign-slots ((blue green red reserved)
+ (cffi:mem-aref tmp 'pixel-packet i)
+ pixel-packet)
+ (cffi:with-foreign-slots ((gfs::rgbred gfs::rgbgreen gfs::rgbblue gfs::rgbreserved)
+ (cffi:mem-aref ptr 'gfs::rgbquad i) gfs::rgbquad)
+ (setf gfs::rgbreserved 0)
+ (setf gfs::rgbred (scale-quantum-to-byte red))
+ (setf gfs::rgbgreen (scale-quantum-to-byte green))
+ (setf gfs::rgbblue (scale-quantum-to-byte blue)))))))
+ (unless (gfs:null-handle-p screen-dc)
+ (gfs::release-dc (cffi:null-pointer) screen-dc))
+ hbmp))))
+
+(defmethod gfg:depth ((self magick-data-plugin))
+ (let ((handle (gfs:handle self)))
+ (if (null handle)
+ (error 'gfs:disposed-error))
+ (cffi:foreign-slot-value handle 'magick-image 'depth)))
+
+(defmethod gfs:dispose ((self magick-data-plugin))
+ (let ((victim (gfs:handle self)))
+ (unless (or (null victim) (cffi:null-pointer-p victim))
+ (destroy-image victim)))
+ (setf (slot-value self 'gfs:handle) (cffi:null-pointer)))
+
+(defmethod gfg:load ((self magick-data-plugin) path)
+ (let ((handle (gfs:handle self)))
+ (when (and handle (not (cffi:null-pointer-p handle)))
+ (destroy-image handle)
+ (setf (slot-value self 'gfs:handle) nil)
+ (setf handle nil))
+ (with-image-path (path info ex)
+ (setf handle (read-image info ex))
+ (if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined))
+ (error 'gfs:toolkit-error :detail (format nil
+ "exception reason: ~s"
+ (cffi:foreign-slot-value ex 'exception-info 'reason))))
+ (if (cffi:null-pointer-p handle)
+ (error 'gfs:toolkit-error :detail (format nil "could not load image: ~a" path)))
+ (setf (slot-value self 'gfs:handle) handle))))
+
+(defmethod gfg:size ((self magick-data-plugin))
+ (let ((handle (gfs:handle self))
+ (size (gfs:make-size)))
+ (if (or (null handle) (cffi:null-pointer-p handle))
+ (error 'gfs:disposed-error))
+ (cffi:with-foreign-slots ((rows columns) handle magick-image)
+ (setf (gfs:size-height size) rows)
+ (setf (gfs:size-width size) columns))
+ size))
+
+(defmethod (setf gfg:size) (size (self magick-data-plugin))
+ (let ((handle (gfs:handle self))
+ (new-handle (cffi:null-pointer))
+ (ex (acquire-exception-info)))
+ (if (or (null handle) (cffi:null-pointer-p handle))
+ (error 'gfs:disposed-error))
+ (unwind-protect
+ (progn
+ (setf new-handle (resize-image handle
+ (gfs:size-width size)
+ (gfs:size-height size)
+ (cffi:foreign-enum-value 'filter-types :lanczos)
+ 1.0 ex))
+ (if (gfs:null-handle-p new-handle)
+ (error 'gfs:toolkit-error :detail (format nil
+ "could not resize: ~a"
+ (cffi:foreign-slot-value ex
+ 'exception-info
+ 'reason))))
+ (setf (slot-value self 'gfs:handle) new-handle)
+ (destroy-image handle))
+ (destroy-exception-info ex))))
Modified: trunk/src/uitoolkit/widgets/thread-context.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/thread-context.lisp (original)
+++ trunk/src/uitoolkit/widgets/thread-context.lisp Mon Jul 17 00:48:13 2006
@@ -38,7 +38,6 @@
(child-visitor-results :initform nil :accessor child-visitor-results)
(display-visitor-func :initform nil :accessor display-visitor-func)
(display-visitor-results :initform nil :accessor display-visitor-results)
- (image-loaders-by-type :initform (make-hash-table :test #'equal))
(job-table :initform (make-hash-table :test #'equal))
(job-table-lock :initform nil)
(event-time :initform 0 :accessor event-time)
Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp Mon Jul 17 00:48:13 2006
@@ -81,13 +81,11 @@
#+clisp (defun startup (thread-name start-fn)
(declare (ignore thread-name))
- (gfg::initialize-magick (cffi:null-pointer))
(funcall start-fn)
(message-loop #'default-message-filter))
#+lispworks (defun startup (thread-name start-fn)
(hcl:add-special-free-action 'gfs::native-object-special-action)
- (gfg::initialize-magick (cffi:null-pointer))
(when (null (mp:list-all-processes))
(mp:initialize-multiprocessing))
(mp:process-run-function thread-name
@@ -97,7 +95,6 @@
(message-loop #'default-message-filter))))
(defun shutdown (exit-code)
- (gfg::destroy-magick)
(gfs::post-quit-message exit-code))
(defun initialize-comctl-classes (icc-flags)
More information about the Graphic-forms-cvs
mailing list