Author: junrue Date: Sun Mar 19 12:42:18 2006 New Revision: 50

Added: trunk/src/intrinsics/system/clib.lisp trunk/src/tests/uitoolkit/blackwhite20x16.bmp (contents, props changed) trunk/src/tests/uitoolkit/happy.bmp (contents, props changed) trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/tests/uitoolkit/image-unit-tests.lisp trunk/src/tests/uitoolkit/truecolor16x16.bmp (contents, props changed) trunk/src/uitoolkit/graphics/magick-core-api.lisp trunk/src/uitoolkit/graphics/magick-core-types.lisp Removed: trunk/src/uitoolkit/graphics/file-formats.lisp Modified: trunk/build.lisp trunk/graphic-forms-tests.asd trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/image.lisp trunk/src/uitoolkit/graphics/palette.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/tests.lisp Log: integrated ImageMagick and got rid of home-grown bmp parsing; fixed bugs in data->image and draw-image in order for image-tester to partially work -- bitmap transparency is next

Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Sun Mar 19 12:42:18 2006 @@ -39,20 +39,22 @@

(defvar *external-build-dirs* nil)

-(defvar *library-root* "c:/projects/third_party/") -(defvar *project-root* "c:/projects/public/") +(defvar *library-root* "c:/projects/third_party/") +(defvar *project-root* "c:/projects/public/")

-(defvar *asdf-root* (concatenate 'string *library-root* "asdf-repo/")) +(defvar *asdf-root* (concatenate 'string *library-root* "asdf-repo/"))

-(defvar *cffi-dir* (concatenate 'string *asdf-root* "cffi-0.9.0/")) -(defvar *closer-mop-dir* (concatenate 'string *asdf-root* "closer-mop/")) -(defvar *lw-compat-dir* (concatenate 'string *asdf-root* "lw-compat/")) -(defvar *pcl-ch08-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter08/")) -(defvar *pcl-ch24-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter24/")) - -(defvar *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) -(defvar *gf-build-dir* "c:/projects/public/build/graphic-forms/") -(defvar *gf-doc-dir* (concatenate 'string *gf-build-dir* "docs/")) +(defvar *cffi-dir* (concatenate 'string *asdf-root* "cffi-0.9.0/")) +(defvar *closer-mop-dir* (concatenate 'string *asdf-root* "closer-mop/")) +(defvar *imagemagick-dir* "c:/Program Files/ImageMagick-6.2.6-Q16/") +(defvar *lw-compat-dir* (concatenate 'string *asdf-root* "lw-compat/")) +(defvar *pcl-ch08-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter08/")) +(defvar *pcl-ch24-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter24/")) + +(defvar *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) +(defvar *gf-build-dir* "c:/projects/public/build/graphic-forms/") +(defvar *gf-doc-dir* (concatenate 'string *gf-build-dir* "docs/")) +(defvar *gf-tests-dir* (concatenate 'string *gf-dir* "src/tests/uitoolkit/"))

(defvar *asdf-dirs* (list *cffi-dir* *closer-mop-dir* @@ -99,10 +101,6 @@ (asdf:operate 'asdf:load-op :closer-mop)

(if *external-build-dirs* - (chdir *cffi-build-dir*)) - (asdf:operate 'asdf:load-op :cffi) - - (if *external-build-dirs* (chdir *pcl-ch08-build-dir*)) (asdf:operate 'asdf:load-op :macro-utilities)

Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Mar 19 12:42:18 2006 @@ -50,8 +50,10 @@ ((:module "uitoolkit" :components ((:file "mock-objects") + (:file "image-unit-tests") (:file "layout-unit-tests") (:file "hello-world") (:file "event-tester") (:file "layout-tester") + (:file "image-tester") (:file "windlg")))))))))

Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sun Mar 19 12:42:18 2006 @@ -58,6 +58,7 @@ ((:file "native-classes") (:file "native-conditions") (:file "native-object-generics") + (:file "clib") (:file "native-object"))))) (:module "uitoolkit" :depends-on ("intrinsics") @@ -74,11 +75,12 @@ (:module "graphics" :depends-on ("system") :components - ((:file "graphics-classes") + ((:file "magick-core-types") + (:file "magick-core-api") + (:file "graphics-classes") (:file "graphics-generics") (:file "color") (:file "palette") - (:file "file-formats") (:file "image-data") (:file "image") (:file "font")

Added: trunk/src/intrinsics/system/clib.lisp ============================================================================== --- (empty file) +++ trunk/src/intrinsics/system/clib.lisp Sun Mar 19 12:42:18 2006 @@ -0,0 +1,44 @@ +;;;; +;;;; clib.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.intrinsics) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (use-package :cffi)) + +(defcfun + ("strncpy" strncpy) + :pointer + (dest :pointer) + (src :pointer) + (count :unsigned-int))

Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Mar 19 12:42:18 2006 @@ -136,7 +136,6 @@ #:average-char-width #:background-color #:background-pattern - #:bits-per-pixel #:blue-mask #:blue-shift #:clipped-p @@ -148,9 +147,8 @@ #:color-table #:copy-area #:data-obj + #:depth #:descent - #:direct - #:direct-p #:draw-arc #:draw-filled-arc #:draw-filled-oval @@ -174,8 +172,6 @@ #:green-mask #:green-shift #:height - #:image-data-type - #:image-palette #:invert #:leading #:line-cap-style @@ -183,18 +179,14 @@ #:line-join-style #:line-style #:line-width + #:load #:make-color - #:make-image-data - #:make-palette #:matrix #:maximum-char-width #:metrics #:multiply - #:pixel-color - #:pixels #:red-mask #:red-shift - #:register-image-loader #:rotate #:scale #:size

Added: trunk/src/tests/uitoolkit/blackwhite20x16.bmp ============================================================================== Binary file. No diff available.

Added: trunk/src/tests/uitoolkit/happy.bmp ============================================================================== Binary file. No diff available.

Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Sun Mar 19 12:42:18 2006 @@ -38,7 +38,7 @@ (defclass hellowin-events (gfw:event-dispatcher) ())

(defmethod gfw:event-close ((d hellowin-events) window time) - (declare (ignore widget time)) + (declare (ignore time)) (gfi:dispose window) (gfw:shutdown 0))

Added: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/image-tester.lisp Sun Mar 19 12:42:18 2006 @@ -0,0 +1,86 @@ +;;;; +;;;; image-tester.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.tests) + +(defvar *image-win* nil) +(defvar *happy-image* nil) +(defvar *bw-image* nil) +(defvar *true-image* nil) + +(defclass image-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((d image-events) window time) + (declare (ignore window time)) + (gfi:dispose *happy-image*) + (setf *happy-image* nil) + (gfi:dispose *bw-image*) + (setf *bw-image* nil) + (gfi:dispose *true-image*) + (setf *true-image* nil) + (gfi:dispose *image-win*) + (setf *image-win* nil) + (gfw:shutdown 0)) + +(defmethod gfw:event-paint ((d image-events) window time gc rect) + (declare (ignore window time rect)) + (let ((pnt (gfi:make-point))) + (gfg:draw-image gc *happy-image* pnt) + (incf (gfi:point-x pnt) 36) + (gfg:draw-image gc *bw-image* pnt) + (incf (gfi:point-x pnt) 24) + (gfg:draw-image gc *true-image* pnt))) + +(defun exit-image-fn (disp item time rect) + (declare (ignorable disp item time rect)) + (gfi:dispose *image-win*) + (setf *image-win* nil) + (gfw:shutdown 0)) + +(defun run-image-tester-internal () + (let ((menubar nil)) + (setf *happy-image* (make-instance 'gfg:image)) + (setf *bw-image* (make-instance 'gfg:image)) + (setf *true-image* (make-instance 'gfg:image)) + (gfg::load *happy-image* "happy.bmp") + (gfg::load *bw-image* "blackwhite20x16.bmp") + (gfg::load *true-image* "truecolor16x16.bmp") + (setf *image-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'image-events) + :style '(:style-workspace))) + (setf menubar (gfw:defmenusystem ((:item "&File" + :submenu ((:item "E&xit" :callback #'exit-image-fn)))))) + (setf (gfw:menu-bar *image-win*) menubar) + (gfw:show *image-win* t))) + +(defun run-image-tester () + (gfw:startup "Image Tester" #'run-image-tester-internal))

Added: trunk/src/tests/uitoolkit/image-unit-tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/image-unit-tests.lisp Sun Mar 19 12:42:18 2006 @@ -0,0 +1,73 @@ +;;;; +;;;; image-unit-tests.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.tests) + +(defun image-data-tester (path) + (let ((d1 (make-instance 'gfg:image-data)) + (d2 nil) + (d3 nil) + (im (make-instance 'gfg:image)) + (hbmp (cffi:null-pointer))) + (unwind-protect + (progn + (gfg:load d1 path) + (cffi:with-foreign-string (ptr path) + (setf hbmp (gfs::load-image nil + ptr + gfs::+image-bitmap+ + 0 0 + (logior gfs::+lr-loadfromfile+ + gfs::+lr-createdibsection+)))) + (if (gfi:null-handle-p hbmp) + (error 'gfs:win32-error :detail "load-image failed")) + (setf d2 (gfg::image->data hbmp)) + (assert-equal (gfg:depth d1) (gfg:depth d2) path) + (let ((size1 (gfg:size d1)) + (size2 (gfg:size d2))) + (assert-equal (gfi:size-width size1) (gfi:size-width size2) path) + (assert-equal (gfi:size-height size1) (gfi:size-height size2) path)) + (gfg:load im path) + (setf d3 (gfg:data-obj im)) + (assert-equal (gfg:depth d1) (gfg:depth d3) path) + (let ((size1 (gfg:size d1)) + (size2 (gfg:size d3))) + (assert-equal (gfi:size-width size1) (gfi:size-width size2) path) + (assert-equal (gfi:size-height size1) (gfi:size-height size2) path)) + (unless (gfi:disposed-p im) + (gfi:dispose im)) + (unless (gfi:null-handle-p hbmp) + (gfs::delete-object hbmp)))))) + +(define-test image-data-loading-test + (mapc #'image-data-tester '("blackwhite20x16.bmp" "happy.bmp" "truecolor16x16.bmp")))

Added: trunk/src/tests/uitoolkit/truecolor16x16.bmp ============================================================================== Binary file. No diff available.

Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Sun Mar 19 12:42:18 2006 @@ -37,61 +37,47 @@ (defstruct color (red 0) (green 0) - (blue 0))) + (blue 0))

-(eval-when (:compile-toplevel :load-toplevel :execute) (defstruct font-metrics (ascent 0) (descent 0) (leading 0) (avg-char-width 0) - (max-char-width 0))) + (max-char-width 0))

-(eval-when (:compile-toplevel :load-toplevel :execute) (defmacro ascent (metrics) - `(gfg::font-metrics-ascent ,metrics))) + `(gfg::font-metrics-ascent ,metrics))

-(eval-when (:compile-toplevel :load-toplevel :execute) (defmacro descent (metrics) - `(gfg::font-metrics-descent ,metrics))) + `(gfg::font-metrics-descent ,metrics))

-(eval-when (:compile-toplevel :load-toplevel :execute) (defmacro leading (metrics) - `(gfg::font-metrics-leading ,metrics))) + `(gfg::font-metrics-leading ,metrics))

-(eval-when (:compile-toplevel :load-toplevel :execute) (defmacro height (metrics) `(+ (gfg::font-metrics-ascent ,metrics) (gfg::font-metrics-descent ,metrics) - (gfg::font-metrics-leading ,metrics)))) + (gfg::font-metrics-leading ,metrics)))

-(eval-when (:compile-toplevel :load-toplevel :execute) (defmacro average-char-width (metrics) - `(gfg::font-metrics-avg-char-width ,metrics))) + `(gfg::font-metrics-avg-char-width ,metrics))

-(eval-when (:compile-toplevel :load-toplevel :execute) (defmacro maximum-char-width (metrics) - `(gfg::font-metrics-max-char-width ,metrics))) + `(gfg::font-metrics-max-char-width ,metrics))

-(eval-when (:compile-toplevel :load-toplevel :execute) - (defstruct image-data - (pixels nil) ; vector of bytes - (bits-per-pixel 0) ; number of bits per pixel - (palette nil) ; palette - (size (gfi:make-size)) ; width and height of image in pixels - (type 'bmp))) ; symbol corresponding to file extension (e.g., 'bmp) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro bits-per-pixel (data) - `(gfg::image-data-bits-per-pixel ,data))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro image-palette (data) - `(gfg::image-data-palette ,data))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro pixels (data) - `(gfg::image-data-pixels ,data))) + (defstruct palette + (red-mask 0) + (green-mask 0) + (blue-mask 0) + (red-shift 0) + (green-shift 0) + (blue-shift 0) + (direct nil) + (table nil))) ; vector of COLOR structs + +(defclass image-data (gfi:native-object) () + (:documentation "This class maintains image attributes, color, and pixel data."))

(defclass font (gfi:native-object) () (:documentation "This class encapsulates a realized native font.")) @@ -106,17 +92,6 @@ :initform (make-color))) (:documentation "This class represents an image of a particular type (BMP, PNG, etc.)."))

-(eval-when (:compile-toplevel :load-toplevel :execute) - (defstruct palette - (red-mask 0) - (green-mask 0) - (blue-mask 0) - (red-shift 0) - (green-shift 0) - (blue-shift 0) - (direct nil) - (table nil))) ; vector of COLOR structs - (defmacro blue-mask (data) `(gfg::palette-blue-mask ,data))

@@ -126,10 +101,6 @@ (defmacro direct (data flag) `(setf (gfg::palette-direct ,data) ,flag))

-(eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro direct-p (data) - `(null (gfg::palette-direct ,data)))) - (defmacro green-mask (data) `(gfg::palette-green-mask ,data))

Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Sun Mar 19 12:42:18 2006 @@ -90,20 +90,20 @@ ;; TODO: support addressing elements within bitmap as if it were an array ;; (let ((memdc (gfs::create-compatible-dc (gfi:handle gc))) - oldhbm) + (oldhbm (cffi:null-pointer))) (if (gfi:null-handle-p memdc) (error 'gfs:win32-error :detail "create-compatible-dc failed")) (setf oldhbm (gfs::select-object memdc (gfi:handle im))) (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) (gfs::get-object (gfi:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) (gfs::bit-blt (gfi:handle gc) - (gfi:point-x pnt) - (gfi:point-y pnt) - (cffi:foreign-slot-value bmp-ptr 'gfs::bitmap 'gfs::width) - (cffi:foreign-slot-value bmp-ptr 'gfs::bitmap 'gfs::height) - memdc - 0 0 - gfs::+blt-srccopy+)) + (gfi:point-x pnt) + (gfi:point-y pnt) + (cffi:foreign-slot-value bmp-ptr 'gfs::bitmap 'gfs::width) + (cffi:foreign-slot-value bmp-ptr 'gfs::bitmap 'gfs::height) + memdc + 0 0 + gfs::+blt-srccopy+)) (gfs::select-object memdc oldhbm) (gfs::delete-dc memdc)))

Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Sun Mar 19 12:42:18 2006 @@ -57,6 +57,9 @@ (defgeneric data-obj (object) (:documentation "Returns the data structure representing the raw form of the object."))

+(defgeneric depth (object) + (:documentation "Returns the bits-per-pixel depth of the object.")) + (defgeneric draw-arc (object rect start-angle arc-angle) (:documentation "Draws the outline of a circular or elliptical arc within the specified rectangular area."))

Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Sun Mar 19 12:42:18 2006 @@ -33,110 +33,12 @@

(in-package :graphic-forms.uitoolkit.graphics)

-(defvar *loaders-by-type* (make-hash-table :test #'equal)) - -;;; -;;; image loader functions -;;; - -(defmacro bmp-pixel-row-length (im-width im-bit-count) - `(ash (logand (+ (* ,im-width ,im-bit-count) 31) (lognot 31)) -3)) - -(defun bmp-loader (path victim) - (with-open-file (in path :element-type '(unsigned-byte 8)) - (let ((header (read-value 'BITMAPFILEHEADER in)) - (info (read-value 'BASE-BITMAPINFOHEADER in)) - (pix-bits nil)) - (declare (ignore header)) - (unless (= (biCompression info) gfs::+bi-rgb+) - (error 'gfs:toolkit-error :detail "FIXME: not yet implemented")) - - ;; load color table - ;; - (let ((used (biClrUsed info)) - (rgbs nil)) - (ecase (biBitCount info) - (1 - (setf rgbs (make-array 2))) - (4 - (if (or (= used 0) (= used 16)) - (setf rgbs (make-array 16)) - (setf rgbs (make-array used)))) - (8 - (if (or (= used 0) (= used 256)) - (setf rgbs (make-array 256)) - (setf rgbs (make-array used)))) - (16 - (unless (/= used 0) - (setf rgbs (make-array used)))) - (24 - (unless (/= used 0) - (setf rgbs (make-array used)))) - (32 - (unless (/= used 0) - (setf rgbs (make-array used))))) - (dotimes (i (length rgbs)) - (let ((quad (read-value 'RGBQUAD in))) - (setf (aref rgbs i) (make-color :red (rgbRed quad) - :green (rgbGreen quad) - :blue (rgbBlue quad))))) - (setf (image-data-palette victim) (make-palette :direct nil :table rgbs))) - - ;; load pixel bits - ;; - (let ((row-len (bmp-pixel-row-length (biWidth info) (biBitCount info)))) - (setf pix-bits (make-array (* row-len (biHeight info)) :element-type '(unsigned-byte 8))) - (read-sequence pix-bits in)) - - ;; populate and return image-data object - ;; - (setf (image-data-pixels victim) pix-bits) - (setf (image-data-bits-per-pixel victim) (biBitCount info)) - (setf (size victim) (gfi:make-size :width (biWidth info) :height (biHeight info))) - (setf (image-data-type victim) 'bmp) - victim))) - -#| -(define-binary-type raw-data (size width) - (:reader (in) - (let ((buf (make-array size :element-type '(unsigned-byte width)))) - (read-sequence buf in) - buf)) - (:writer (out) - (write-sequence buf out))) -|# - -#| -(defun bmp-loader (path) - (let (hwnd) - (cffi:with-foreign-string (ptr (namestring path)) - (setf hwnd (gfs::load-image nil - ptr - gfs::+image-bitmap+ - 0 0 - gfs::+lr-loadfromfile+))) - (if (gfi:null-handle-p hwnd) - (error 'gfs:win32-error :detail "load-image failed")) - hwnd)) -|# - -(setf (gethash "bmp" *loaders-by-type*) #'bmp-loader) - ;;; ;;; helper functions ;;;

-(defun register-image-loader (file-type loader-fn) - "Associate a new (or replacement) loader function with the specified file type. \ -Returns the previous loader function, if any." - (unless (typep file-type 'string) - (error 'gfs:toolkit-error :detail "file-type must be a string")) - (unless (typep loader-fn 'function) - (error 'gfs:toolkit-error :detail "loader-fn must be a function")) - (let ((old-fn (gethash file-type *loaders-by-type*))) - (setf (gethash file-type *loaders-by-type*) loader-fn) - old-fn)) - +(defun image->data (hbmp) (declare (ignore hbmp))) +#| (defun image->data (hbmp) "Convert the native bitmap handle to an image-data." (let ((mem-dc (gfs::create-compatible-dc (cffi:null-pointer))) @@ -222,6 +124,7 @@ (cffi:foreign-free raw-bits)) (gfs::delete-dc mem-dc)) data)) +|#

(defun data->image (data) "Convert the image-data object to a bitmap and return the native handle." @@ -239,20 +142,20 @@ gfs::biclrimp gfs::bmicolors) bi-ptr gfs::bitmapinfo) - (let* ((sz (size data)) - (colors (palette-table (image-palette data))) - (bit-count (bits-per-pixel data)) - (row-len (bmp-pixel-row-length (gfi:size-width sz) bit-count)) - (byte-count (* row-len (gfi:size-height sz))) - (data-bits (pixels data)) - (pix-bits (cffi:null-pointer)) + (let* ((handle (gfi:handle data)) + (sz (size data)) + (pix-count (* (gfi:size-width sz) (gfi:size-height sz))) + (bit-count (depth data)) (hbmp (cffi:null-pointer)) - (mem-dc (gfs::create-compatible-dc (cffi:null-pointer)))) + (screen-dc (gfs::get-dc (cffi:null-pointer)))) +(format t "bi-size: ~a~%" (cffi:foreign-type-size 'gfs::bitmapinfoheader)) +(format t "bit-count: ~a~%" bit-count) +(format t "size: ~a ~a~%" (gfi:size-width sz) (gfi:size-height sz)) (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader)) (setf gfs::biwidth (gfi:size-width sz)) - (setf gfs::biheight (gfi:size-height sz)) + (setf gfs::biheight (- 0 (gfi:size-height sz))) (setf gfs::biplanes 1) - (setf gfs::bibitcount bit-count) + (setf gfs::bibitcount 32) ;; 32bpp even if original image file is not (setf gfs::bicompression gfs::+bi-rgb+) (setf gfs::bisizeimage 0) (setf gfs::bixpels 0) @@ -260,73 +163,111 @@ (setf gfs::biclrused 0) (setf gfs::biclrimp 0)

- (unwind-protect - (progn - - ;; populate the RGBQUADs - ;; - (dotimes (i (length colors)) - (let ((clr (aref colors i))) - (cffi:with-foreign-slots ((gfs::rgbblue gfs::rgbgreen - gfs::rgbred gfs::rgbreserved) - (cffi:mem-aref gfs::bmicolors 'gfs::rgbquad i) - gfs::rgbquad) - (setf gfs::rgbblue (color-blue clr)) - (setf gfs::rgbgreen (color-green clr)) - (setf gfs::rgbred (color-red clr)) - (setf gfs::rgbreserved 0)))) - - ;; populate the pixel data - ;; - (setf pix-bits (cffi:foreign-alloc :unsigned-char :count byte-count)) - (dotimes (i byte-count) - (setf (cffi:mem-aref pix-bits :unsigned-char i) (aref data-bits i))) + ;; 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 (gfi:null-handle-p hbmp) + (error 'gfs:win32-error :detail "create-dib-section failed"))

- ;; create the bitmap - ;; - (setf hbmp (gfs::create-di-bitmap mem-dc - bi-ptr - 0 ; gfs::+cbm-init+ - pix-bits - bi-ptr - gfs::+dib-rgb-colors+)) - (if (gfi:null-handle-p hbmp) - (error 'gfs:win32-error :detail "create-di-bitmap failed"))) - (unless (cffi:null-pointer-p pix-bits) - (cffi:foreign-free pix-bits)) - (gfs::delete-dc mem-dc)) - hbmp)))) + ;; update the RGBQUADs + ;; + (let ((tmp (get-image-pixels handle 0 0 (gfi:size-width sz) (gfi: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)))))) + hbmp)))))

;;; ;;; methods ;;;

-(defmethod load ((d image-data) path) +(defmethod depth ((data image-data)) + (let ((handle (gfi:handle data))) + (if (null handle) + (error 'gfi:disposed-error)) + (cffi:foreign-slot-value handle 'magick-image 'depth))) + +(defmethod gfi:dispose ((data image-data)) + (let ((victim (gfi:handle data))) + (if (null victim) + (error 'gfi:disposed-error)) + (destroy-image victim)) + (setf (slot-value data 'gfi:handle) nil)) + +(defmethod load ((data image-data) path) (setf path (cond - ((typep path 'pathname) path) - ((typep path 'string) - (parse-namestring path)) + ((typep path 'pathname) (namestring path)) + ((typep path 'string) path) (t (error 'gfs:toolkit-error :detail "pathname or string required")))) - (let* ((ptype (pathname-type path)) - (fn (gethash ptype *loaders-by-type*))) - (if (null fn) - (error 'gfs:toolkit-error - :detail (format nil "no loader registered for type: ~a" ptype))) - (funcall fn path d) - d)) - -(defmethod size ((obj image-data)) - (image-data-size obj)) - -(defmethod (setf size) (sz (obj image-data)) - (setf (image-data-size obj) sz)) - -(defmethod print-object ((obj image-data) stream) - (print-unreadable-object (obj stream :type t) - (format stream "type: ~a " (image-data-type obj)) - (format stream "width: ~a " (gfi:size-width (image-data-size obj))) - (format stream "height: ~a " (gfi:size-height (image-data-size obj))) - (format stream "bits per pixel: ~a " (bits-per-pixel obj)) - (format stream "pixel count: ~a " (length (pixels obj))) - (format stream "palette: ~a" (image-palette obj)))) + (let ((handle (gfi:handle data))) + (when (and (not (null handle)) (not (cffi:null-pointer-p handle))) + (destroy-image handle) + (setf (slot-value data 'gfi: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-string-to-lisp (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 'gfi:handle) handle)))) + +(defmethod size ((data image-data)) + (let ((handle (gfi:handle data)) + (size (gfi:make-size))) + (if (or (null handle) (cffi:null-pointer-p handle)) + (error 'gfi:disposed-error)) + (cffi:with-foreign-slots ((rows columns) handle magick-image) + (setf (gfi:size-height size) rows) + (setf (gfi:size-width size) columns)) + size)) + +(defmethod (setf size) (size (data image-data)) + (let ((handle (gfi:handle data)) + (new-handle (cffi:null-pointer)) + (ex (acquire-exception-info))) + (if (or (null handle) (cffi:null-pointer-p handle)) + (error 'gfi:disposed-error)) + (unwind-protect + (progn + (setf new-handle (resize-image handle + (gfi:size-width size) + (gfi:size-height size) + (cffi:foreign-enum-value 'filter-types :lanczos) + 1.0 ex)) + (if (gfi: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 'gfi:handle) new-handle) + (destroy-image handle)) + (destroy-exception-info ex)))) + +(defmethod print-object ((data image-data) stream) + (if (or (null (gfi:handle data)) (cffi:null-pointer-p (gfi:handle data))) + (error 'gfi:disposed-error)) + (let ((size (size data))) + (print-unreadable-object (data stream :type t) + ;; FIXME: dump palette info, too + ;; + (format stream "width: ~a " (gfi:size-width size)) + (format stream "height: ~a " (gfi:size-height size)) + (format stream "bits per pixel: ~a " (depth data)))))

Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Sun Mar 19 12:42:18 2006 @@ -59,13 +59,7 @@ (setf (slot-value im 'gfi:handle) (data->image id)))

(defmethod load ((im image) path) - (let ((data (make-image-data))) + (let ((data (make-instance 'image-data))) (load data path) (setf (data-obj im) data) data)) - -(defmethod size ((im image)) - (error 'gfs:toolkit-error :detail "FIXME: not yet implemented")) - -(defmethod transparency-mask ((im image)) - (error 'gfs:toolkit-error :detail "FIXME: not yet implemented"))

Added: trunk/src/uitoolkit/graphics/magick-core-api.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/graphics/magick-core-api.lisp Sun Mar 19 12:42:18 2006 @@ -0,0 +1,198 @@ +;;;; +;;;; magick-core-api.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) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (use-package :cffi) + (pushnew gfsys::*imagemagick-dir* *foreign-library-directories*)) + +(define-foreign-library wsock32 (t (:default "wsock32"))) +(define-foreign-library msvcr71 (t (:default "msvcr71"))) +(define-foreign-library x11 (t (:default "x11"))) +(define-foreign-library core_rl_bzlib (t (:default "CORE_RL_bzlib_"))) +(define-foreign-library core_rl_jbig (t (:default "CORE_RL_jbig_"))) +(define-foreign-library core_rl_jpeg (t (:default "CORE_RL_jpeg_"))) +(define-foreign-library core_rl_lcms (t (:default "CORE_RL_lcms_"))) +(define-foreign-library core_rl_zlib (t (:default "CORE_RL_zlib_"))) +(define-foreign-library core_rl_png (t (:default "CORE_RL_png_"))) +(define-foreign-library core_rl_tiff (t (:default "CORE_RL_tiff_"))) +(define-foreign-library core_rl_ttf (t (:default "CORE_RL_ttf_"))) +(define-foreign-library core_rl_xlib (t (:default "CORE_RL_xlib_"))) +(define-foreign-library core_rl_magick (t (:default "CORE_RL_magick_"))) + +(use-foreign-library wsock32) +(use-foreign-library msvcr71) +(use-foreign-library x11) +(use-foreign-library core_rl_bzlib) +(use-foreign-library core_rl_jbig) +(use-foreign-library core_rl_jpeg) +(use-foreign-library core_rl_lcms) +(use-foreign-library core_rl_zlib) +(use-foreign-library core_rl_png) +(use-foreign-library core_rl_tiff) +(use-foreign-library core_rl_ttf) +(use-foreign-library core_rl_xlib) +(use-foreign-library core_rl_magick) + +;;; +;;; translated from constitute.h +;;; + +(defcfun + ("ConstituteImage" constitute-image) + :pointer ;; Image* + (columns :unsigned-long) + (rows :unsigned-long) + (map :pointer) ;; const char* + (storage storage-type) + (pixels :pointer) ;; void* + (exception :pointer)) ;; ExceptionInfo* + +(defcfun + ("PingImage" ping-image) + :pointer ;; Image* + (image-info :pointer) ;; ImageInfo* + (exception :pointer)) ;; ExceptionInfo* + +(defcfun + ("ReadImage" read-image) + :pointer ;; Image* + (image-info :pointer) ;; ImageInfo* + (exception :pointer)) ;; ExceptionInfo* + +(defcfun + ("WriteImage" write-image) + boolean-type + (image-info :pointer) ;; ImageInfo* + (image :pointer)) ;; Image* + +;;; +;;; translated from exception.h +;;; + +(defcfun + ("AcquireExceptionInfo" acquire-exception-info) + :pointer) + +(defcfun + ("CatchException" catch-exception) + :void + (exception :pointer)) ;; ExceptionInfo* + +(defcfun + ("ClearMagickException" clear-magick-exception) + :void + (exception :pointer)) ;; ExceptionInfo* + +(defcfun + ("DestroyExceptionInfo" destroy-exception-info) + :pointer ;; ExceptionInfo* + (exception :pointer)) ;; ExceptionInfo* + +;;; +;;; translated from image.h +;;; + +(defcfun + ("CloneImageInfo" clone-image-info) + :pointer ;; ImageInfo* + (orig :pointer)) ;; ImageInfo* + +(defcfun + ("DestroyImage" destroy-image) + :pointer ;; Image* + (victim :pointer)) ;; Image* + +(defcfun + ("DestroyImageInfo" destroy-image-info) + :pointer ;; ImageInfo* + (victim :pointer)) ;; ImageInfo* + +(defcfun + ("GetImagePixels" get-image-pixels) + :pointer ;; PixelPacket* + (image :pointer) ;; Image* + (x :long) + (y :long) + (width :unsigned-long) + (height :unsigned-long)) + +(defun scale-quantum-to-byte (quant) + (floor (/ quant 257))) + +;;; +;;; translated from magick.h +;;; + +(defcfun + ("DestroyMagick" destroy-magick) + :void) + +(defcfun + ("InitializeMagick" initialize-magick) + :void + (args :pointer)) ;; char* + +;;; +;;; translated from resize.h +;;; + +(defcfun + ("ResizeImage" resize-image) + :pointer ;; Image* + (orig :pointer) ;; Image* + (width :unsigned-long) + (height :unsigned-long) + (filter :int) ;; filter-type + (blur :double) + (exception :pointer)) ;; ExceptionInfo* + +;;; +;;; helper macros +;;; + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro with-image-path ((path info ex) &body body) + `(let ((,info (clone-image-info (cffi:null-pointer))) + (,ex (acquire-exception-info))) + (if (cffi:null-pointer-p ,info) + (error 'gfs:toolkit-error :detail "could not allocate Magick ImageInfo object")) + (unwind-protect + (cffi:with-foreign-string (str ,path) + (gfi::strncpy (cffi:foreign-slot-pointer ,info 'magick-image-info 'filename) + str + (1- +magick-max-text-extent+)) + ,@body)) + (destroy-image-info ,info) + (destroy-exception-info ,ex))))

Added: trunk/src/uitoolkit/graphics/magick-core-types.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/graphics/magick-core-types.lisp Sun Mar 19 12:42:18 2006 @@ -0,0 +1,549 @@ +;;;; +;;;; magick-core-types.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) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (use-package :cffi)) + +;;; +;;; see magick-type.h for the original C-language definitions +;;; of these types from ImageMagick Core. +;;; + +(defconstant +magick-max-text-extent+ 4096) +(defconstant +magick-signature+ #xABACADAB) + +(defconstant +undefined-channel+ #x00000000) +(defconstant +red-channel+ #x00000001) +(defconstant +gray-channel+ #x00000001) +(defconstant +cyan-channel+ #x00000001) +(defconstant +green-channel+ #x00000002) +(defconstant +magenta-channel+ #x00000002) +(defconstant +blue-channel+ #x00000004) +(defconstant +yellow-channel+ #x00000004) +(defconstant +alpha-channel+ #x00000008) +(defconstant +opacity-channel+ #x00000008) +(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) + +(defctype quantum :unsigned-short) + +(defcenum boolean-type + (:false 0) + (:true 1)) + +(defcenum class-type + :undefined + :direct + :pseudo) + +(defcenum colorspace-type + :undefined + :rgb + :gray + :transparent + :ohta + :lab + :xyz + :ycbcr + :ycc + :yiq + :ypbpr + :yuv + :cmyk + :srgb + :hsb + :hsl + :hwb + :rec601luma + :rec601ycbcr + :rec709luma + :rec709ycbcr + :log) + +(defcenum composite-operator + :undefined + :no + :add + :atop + :blend + :bump-map + :clear + :color-burn + :color-dodge + :colorize + :copy-black + :copy-blue + :copy + :copy-cyan + :copy-green + :copy-magenta + :copy-opacity + :copy-red + :copy-yellow + :darken + :dst-atop + :dst + :dst-in + :dst-out + :dst-over + :difference + :displace + :dissolve + :exclusion + :hard-light + :hue + :in + :lighten + :luminize + :minus + :modulate + :multiply + :out + :over + :overlay + :plus + :replace + :saturate + :screen + :soft-light + :src-atop + :src + :src-in + :src-out + :src-over + :subtract + :threshold + :xor-composite-op) + +(defcenum compression-type + :undefined + :no + :bzip + :fax + :group4 + :jpeg + :jpeg2000 + :lossless-jpeg + :lzw + :rle + :zip) + +(defcenum dispose-type + :unrecognized + (:undefined 0) + (:none 1) + (:background 2) + (:previous 3)) + +(defcenum endian-type + :undefined + :lsb + :msb) + +(defcenum exception-type + :undefined + (:warning 300) + (:resource-limit-warning 300) + (:type-warning 305) + (:option-warning 310) + (:delegate--warning 315) + (:missing-delegate-warning 320) + (:corrupt-image-warning 325) + (:file-open-warning 330) + (:blob-warning 335) + (:stream-warning 340) + (:cache-warning 345) + (:coder-warning 350) + (:module-warning 355) + (:draw-warning 360) + (:image-warning 365) + (:wand-warning 370) + (:xserver-warning 380) + (:monitor-warning 385) + (:registry-warning 390) + (:configure-warning 395) + (:error 400) + (:resource-limit-error 400) + (:type-error 405) + (:option-error 410) + (:delegate-error 415) + (:missing-delegate-error 420) + (:corrupt-image-error 425) + (:file-open-error 430) + (:blob-error 435) + (:stream-error 440) + (:cache-error 445) + (:coder-error 450) + (:module-error 455) + (:draw-error 460) + (:image-error 465) + (:wand-error 470) + (:xserver-error 480) + (:monitor-error 485) + (:registry-error 490) + (:configure-error 495) + (:fatal-error 700) + (:resource-limit-fatal-error 700) + (:type-fatal-error 705) + (:option-fatal-error 710) + (:delegate-fatal-error 715) + (:missing-delegate-fatal-error 720) + (:corrupt-image-fatal-error 725) + (:file-open-fatal-error 730) + (:blob-fatal-error 735) + (:stream-fatal-error 740) + (:cache-fatal-error 745) + (:coder-fatal-error 750) + (:module-fatal-error 755) + (:draw-fatal-error 760) + (:image-fatal-error 765) + (:wand-fatal-error 770) + (:xserver-fatal-error 780) + (:monitor-fatal-error 785) + (:registry-fatal-error 790) + (:configure-fatal-error 795)) + +(defcenum filter-types + :undefined + :point + :box + :triangle + :hermite + :hanning + :hamming + :blackman + :gaussian + :quadratic + :cubic + :catrom + :mitchell + :lanczos + :bessel + :sinc) + +(defcenum gravity-type + :undefined + (:forget 0) + (:north-west 1) + (:north 2) + (:north-east 3) + (:west 4) + (:center 5) + (:east 6) + (:south-west 7) + (:south 8) + (:south-east 9) + (:static 10)) + +(defcenum image-type + :undefined + :bi-level + :gray-scale + :gray-scale-matte + :palette + :palette-matte + :true-color + :true-color-matte + :color-separation + :color-separation-matte + :optimize) + +(defcenum interlace-type + :undefined + :no + :line + :plane + :partition) + +(defcenum orientation-type + :undefined + :top-left + :top-right + :bottom-right + :bottom-left + :left-top + :right-top + :right-bottom + :left-bottom) + +(defcenum preview-type + :undefined + :rotate + :shear + :roll + :hue + :saturation + :brightness + :gamma + :spiff + :dull + :gray-scale + :quantize + :despeckle + :reduce-noise + :add-noise + :sharpen + :blur + :threshold + :edge-detect + :spread + :solarize + :shade + :raise + :segment + :swirl + :implode + :wave + :oil-paint + :charcoal-drawing + :jpeg) + +(defcenum rendering-intent + :undefined + :saturation + :perceptual + :absolute + :relative) + +(defcenum resolution-type + :undefined + :pixels-per-inch + :pixels-per-centimeter) + + ;; from constitute.h + ;; +(defcenum storage-type + :undefined + :char + :double + :float + :integer + :long + :quantum + :short) + +(defcenum timer-state + :undefined + :stopped + :running) + +(defcstruct error-info + (mean-error-per-pixel :double) + (normalized-mean-error :double) + (normalized-maximum-error :double)) + +(defcstruct exception-info + (severity exception-type) + (error-number :int) + (reason :string) + (description :string) + (exceptions :pointer) ;; void* + (relinquish boolean-type) + (semaphore :pointer) ;; Semaphore* + (signature :unsigned-long)) + +(defcstruct primary-info + (x :double) + (y :double) + (z :double)) + +(defcstruct chromaticity-info + (red-primary primary-info) + (green-primary primary-info) + (blue-primary primary-info) + (white-point primary-info)) + +(defcstruct pixel-packet + (blue quantum) + (green quantum) + (red quantum) + (opacity quantum)) + +(defcstruct profile-info + (name :string) + (length :unsigned-long) + (info :pointer) ;; char* + (signature :unsigned-long)) + +(defcstruct rectangle-info + (width :unsigned-long) + (height :unsigned-long) + (x :long) + (y :long)) + +(defcstruct timer + (start :double) + (stop :double) + (total :double)) + +(defcstruct timer-info + (user timer) + (elapsed timer) + (state timer-state) + (signature :unsigned-long)) + +(defcstruct magick-image + (storage-class class-type) + (color-space colorspace-type) + (compression compression-type) + (quality :long) + (orientation orientation-type) + (taint boolean-type) + (matte boolean-type) + (columns :unsigned-long) + (rows :unsigned-long) + (depth :unsigned-long) + (colors :unsigned-long) + (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* + (units resolution-type) + (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 + (bias :double) + (blur :double) + (fuzz :double) + (filter filter-types) + (interlace interlace-type) + (endian endian-type) + (gravity gravity-type) + (compose composite-operator) + (dispose dispose-type) + (clip-mask :pointer) ;; Image* + (scene :unsigned-long) + (delay :unsigned-long) + (ticks-per-second :unsigned-long) + (iterations :unsigned-long) + (total-colors :unsigned-long) + (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_* + (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* + (color-profile profile-info) + (iptc-profile profile-info) + (generic-profile :pointer) ;; ProfileInfo* + (generic-profiles :unsigned-long) ;; deprecated (and ProfileInfo too?) + (signature :unsigned-long) + (previous :pointer) ;; Image* + (list :pointer) ;; Image* + (next :pointer)) ;; Image* + +(defcstruct magick-image-info + (compression compression-type) + (orientation orientation-type) + (temporary boolean-type) + (adjoin boolean-type) + (affirm boolean-type) + (antialias boolean-type) + (size :pointer) ;; char* + (extract :pointer) ;; char* + (page :pointer) ;; char* + (scenes :pointer) ;; char* + (scene :unsigned-long) + (number-scenes :unsigned-long) + (depth :unsigned-long) + (interlace interlace-type) + (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* + (point-size :double) + (fuzz :double) + (background-color pixel-packet) + (border-color pixel-packet) + (matte-color pixel-packet) + (dither boolean-type) + (monochrome boolean-type) + (colors :unsigned-long) + (colorspace colorspace-type) + (type image-type) + (prevu-type preview-type) + (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* + (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 + (subimage :unsigned-long) + (subrange :unsigned-long) + (pen pixel-packet) + (signature :unsigned-long)) + \ No newline at end of file

Modified: trunk/src/uitoolkit/graphics/palette.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/palette.lisp (original) +++ trunk/src/uitoolkit/graphics/palette.lisp Sun Mar 19 12:42:18 2006 @@ -33,11 +33,13 @@

(in-package :graphic-forms.uitoolkit.graphics)

+#| (defun pixel-color (pal pixel-val) "Returns the color struct corresponding to the given pixel value; the inverse of the pixel function." (if (direct-p pal) (error 'toolkit-error :detail "not yet implemented") (aref (palette-table pal) pixel-val))) +|#

(defun dump-colors (pal) (let* ((tmp (palette-table pal))

Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Sun Mar 19 12:42:18 2006 @@ -73,6 +73,16 @@ (usage UINT))

(defcfun + ("CreateDIBSection" create-dib-section) + HANDLE + (hdc HANDLE) + (bmi LPTR) + (usage UINT) + (values LPTR) ;; VOID ** + (section HANDLE) + (offset DWORD)) + +(defcfun ("DeleteDC" delete-dc) BOOL (hdc HANDLE))

Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sun Mar 19 12:42:18 2006 @@ -35,11 +35,13 @@

#+clisp (defun startup (thread-name start-fn) (declare (ignore thread-name)) + (gfg::initialize-magick (cffi:null-pointer)) (setf *the-thread-context* (make-instance 'thread-context)) (funcall start-fn) (run-default-message-loop))

#+lispworks (defun startup (thread-name start-fn) + (gfg::initialize-magick (cffi:null-pointer)) (when (null (mp:list-all-processes)) (mp:initialize-multiprocessing)) (mp:process-run-function thread-name @@ -49,6 +51,7 @@ (run-default-message-loop)))))

(defun shutdown (exit-code) + (gfg::destroy-magick) (gfs::post-quit-message exit-code))

(defun clear-all (w)

Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Sun Mar 19 12:42:18 2006 @@ -44,4 +44,5 @@ (defun load-tests () (if *external-build-dirs* (chdir *gf-build-dir*)) - (asdf:operate 'asdf:load-op :graphic-forms-tests)) + (asdf:operate 'asdf:load-op :graphic-forms-tests) + (chdir *gf-tests-dir*))