[graphic-forms-cvs] r50 - in trunk: . src src/intrinsics/system src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Sun Mar 19 17:42:21 UTC 2006
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+))
+ , at 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*))
More information about the Graphic-forms-cvs
mailing list