- graphic-forms-cvs@common-lisp.net - mailman3.common-lisp.net

[graphic-forms-cvs] r56 - in trunk: . src src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 20 Mar '06

20 Mar '06

Author: junrue Date: Mon Mar 20 01:03:14 2006 New Revision: 56 Added: trunk/src/uitoolkit/widgets/label.lisp - copied, changed from r46, trunk/src/uitoolkit/widgets/text-label.lisp Removed: trunk/src/uitoolkit/widgets/text-label.lisp Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp Log: reverted back to single label class which will distinguish text vs image via style flags Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Mar 20 01:03:14 2006 @@ -101,7 +101,7 @@ (:file "item") (:file "widget") (:file "control") - (:file "text-label") + (:file "label") (:file "button") (:file "widget-with-items") (:file "menu") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Mar 20 01:03:14 2006 @@ -394,6 +394,7 @@ #:items #:key-down-p #:key-toggled-p + #:label #:layout #:layout-of #:layout-p Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Mar 20 01:03:14 2006 @@ -342,7 +342,7 @@ (add-btn-disp (make-instance 'add-child-dispatcher)) (add-panel-disp (make-instance 'add-child-dispatcher :widget-class 'test-panel :subtype :panel)) - (add-text-label-disp (make-instance 'add-child-dispatcher :widget-class 'gfw::text-label + (add-text-label-disp (make-instance 'add-child-dispatcher :widget-class 'gfw:label :subtype :text-label)) (rem-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'remove-child-dispatcher)) (vis-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'visibility-child-dispatcher Copied: trunk/src/uitoolkit/widgets/label.lisp (from r46, trunk/src/uitoolkit/widgets/text-label.lisp) ============================================================================== --- trunk/src/uitoolkit/widgets/text-label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Mon Mar 20 01:03:14 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; text-label.lisp +;;;; label.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. @@ -37,7 +37,7 @@ ;;; methods ;;; -(defmethod compute-style-flags ((label text-label) &rest style) +(defmethod compute-style-flags ((label label) &rest style) (declare (ignore label)) (let ((std-flags 0) (ex-flags 0)) @@ -72,7 +72,7 @@ (setf std-flags (logior std-flags gfs::+ss-left+))))) (values std-flags ex-flags))) -(defmethod initialize-instance :after ((label text-label) &key parent style &allow-other-keys) +(defmethod initialize-instance :after ((label label) &key parent style &allow-other-keys) (if (not (listp style)) (setf style (list style))) (multiple-value-bind (std-style ex-style) @@ -88,7 +88,7 @@ (init-control label)) -(defmethod preferred-size ((label text-label) width-hint height-hint) +(defmethod preferred-size ((label label) width-hint height-hint) (let* ((hwnd (gfi:handle label)) (bits (gfs::get-window-long hwnd gfs::+gwl-style+)) (b-width (border-width label)) @@ -106,8 +106,8 @@ (incf (gfi:size-height sz) (* b-width 2)) sz)) -(defmethod text ((label text-label)) +(defmethod text ((label label)) (get-widget-text label)) -(defmethod (setf text) (str (label text-label)) +(defmethod (setf text) (str (label label)) (set-widget-text label str)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Mar 20 01:03:14 2006 @@ -65,11 +65,8 @@ (defclass button (control) () (:documentation "This class represents selectable controls that issue notifications when clicked.")) -(defclass image-label (control) () - (:documentation "This class represents non-selectable controls that display an image.")) - -(defclass text-label (control) () - (:documentation "This class represents non-selectable controls that display a string.")) +(defclass label (control) () + (:documentation "This class represents non-selectable controls that display a string or image.")) (defclass widget-with-items (widget) ((items

1 0

[graphic-forms-cvs] r55 - in trunk/src: . tests/uitoolkit uitoolkit/graphics
by junrue＠common-lisp.net 20 Mar '06

20 Mar '06

Author: junrue Date: Mon Mar 20 00:51:28 2006 New Revision: 55 Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/graphics/color.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp Log: changed color constants to be defvars not defconstants Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Mar 20 00:51:28 2006 @@ -124,11 +124,11 @@ #:transform ;; constants - #:+color-black+ - #:+color-blue+ - #:+color-green+ - #:+color-red+ - #:+color-white+ + #:*color-black* + #:*color-blue* + #:*color-green* + #:*color-red* + #:*color-white* ;; methods, functions, macros #:alpha Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Mon Mar 20 00:51:28 2006 @@ -48,8 +48,8 @@ (defmethod gfw:event-paint ((d event-tester-window-events) window time gc rect) (declare (ignorable time rect)) - (setf (gfg:background-color gc) gfg:+color-white+) - (setf (gfg:foreground-color gc) gfg:+color-blue+) + (setf (gfg:background-color gc) gfg:*color-white*) + (setf (gfg:foreground-color gc) gfg:*color-blue*) (let* ((sz (gfw:client-size window)) (pnt (gfi:make-point :x 0 :y (floor (/ (gfi:size-height sz) 2))))) (gfg:draw-text gc *event-tester-text* pnt))) Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Mon Mar 20 00:51:28 2006 @@ -46,10 +46,10 @@ (declare (ignore time)) (setf rect (make-instance 'gfi:rectangle :location (gfi:make-point) :size (gfw:client-size window))) - (setf (gfg:background-color gc) gfg:+color-white+) + (setf (gfg:background-color gc) gfg:*color-white*) (gfg:draw-filled-rectangle gc rect) - (setf (gfg:background-color gc) gfg:+color-red+) - (setf (gfg:foreground-color gc) gfg:+color-green+) + (setf (gfg:background-color gc) gfg:*color-red*) + (setf (gfg:foreground-color gc) gfg:*color-green*) (gfg:draw-text gc "Hello World!" (gfi:make-point))) (defun exit-fn (disp item time rect) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Mon Mar 20 00:51:28 2006 @@ -49,7 +49,7 @@ (declare (ignore time)) (setf rect (make-instance 'gfi:rectangle :location (gfi:make-point) :size (gfw:client-size window))) - (setf (gfg:background-color gc) gfg:+color-white+) + (setf (gfg:background-color gc) gfg:*color-white*) (gfg:draw-filled-rectangle gc rect)) (defclass test-mini-events (test-win-events) ()) Modified: trunk/src/uitoolkit/graphics/color.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/color.lisp (original) +++ trunk/src/uitoolkit/graphics/color.lisp Mon Mar 20 00:51:28 2006 @@ -34,12 +34,6 @@ (in-package :graphic-forms.uitoolkit.graphics) (eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +color-black+ (make-color :red 0 :green 0 :blue 0)) - (defconstant +color-blue+ (make-color :red 0 :green 0 :blue #xFF)) - (defconstant +color-green+ (make-color :red 0 :green #xFF :blue 0)) - (defconstant +color-red+ (make-color :red #xFF :green 0 :blue 0)) - (defconstant +color-white+ (make-color :red #xFF :green #xFF :blue #xFF)) - (defmacro color-as-rgb (color) (let ((result (gensym))) `(let ((,result 0)) @@ -48,6 +42,12 @@ (setf (ldb (byte 8 16) ,result) (color-blue ,color)) ,result)))) +(defvar *color-black* (make-color :red 0 :green 0 :blue 0)) +(defvar *color-blue* (make-color :red 0 :green 0 :blue #xFF)) +(defvar *color-green* (make-color :red 0 :green #xFF :blue 0)) +(defvar *color-red* (make-color :red #xFF :green 0 :blue 0)) +(defvar *color-white* (make-color :red #xFF :green #xFF :blue #xFF)) + (defmethod print-object ((obj color) stream) (print-unreadable-object (obj stream :type t) (format stream "~a,~a,~a" (color-red obj) (color-green obj) (color-blue obj)))) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Mon Mar 20 00:51:28 2006 @@ -99,11 +99,13 @@ (if (not (null (transparency-pixel-of im))) (let ((hmask (gfi:handle (transparency-mask im))) (hcopy (clone-bitmap himage)) - (memdc2 (gfs::create-compatible-dc (cffi:null-pointer)))) + (memdc2 (gfs::create-compatible-dc (cffi:null-pointer))) + (black (make-color :red 0 :green 0 :blue 0)) + (white (make-color :red #xFF :green #xFF :blue #xFF))) (gfs::select-object memdc hmask) (gfs::select-object memdc2 hcopy) - (gfs::set-bk-color memdc2 (color-as-rgb +color-black+)) - (gfs::set-text-color memdc2 (color-as-rgb +color-white+)) + (gfs::set-bk-color memdc2 (color-as-rgb black)) + (gfs::set-text-color memdc2 (color-as-rgb white)) (gfs::bit-blt memdc2 0 0 gfs::width

1 0

[graphic-forms-cvs] r54 - trunk
by junrue＠common-lisp.net 20 Mar '06

20 Mar '06

Author: junrue Date: Mon Mar 20 00:38:50 2006 New Revision: 54 Modified: trunk/build.lisp Log: got rid of dependencies on practicals code from PCL Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Mon Mar 20 00:38:50 2006 @@ -48,8 +48,6 @@ (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/") @@ -59,22 +57,16 @@ (defvar *asdf-dirs* (list *cffi-dir* *closer-mop-dir* *lw-compat-dir* - *pcl-ch08-dir* - *pcl-ch24-dir* *gf-dir*)) (defvar *library-build-root* (concatenate 'string *library-root* "build/")) (defvar *cffi-build-dir* (concatenate 'string *library-build-root* "cffi/")) (defvar *closer-mop-build-dir* (concatenate 'string *library-build-root* "closer-mop/")) (defvar *lw-compat-build-dir* (concatenate 'string *library-build-root* "lw-compat/")) -(defvar *pcl-ch08-build-dir* (concatenate 'string *library-build-root* "pcl-macro-utilities/")) -(defvar *pcl-ch24-build-dir* (concatenate 'string *library-build-root* "pcl-binary-data/")) (defvar *build-dirs* (list *cffi-build-dir* *closer-mop-build-dir* *lw-compat-build-dir* - *pcl-ch08-build-dir* - *pcl-ch24-build-dir* *gf-build-dir*)) #+lispworks (defmacro chdir (path) @@ -101,13 +93,5 @@ (asdf:operate 'asdf:load-op :closer-mop) (if *external-build-dirs* - (chdir *pcl-ch08-build-dir*)) - (asdf:operate 'asdf:load-op :macro-utilities) - - (if *external-build-dirs* - (chdir *pcl-ch24-build-dir*)) - (asdf:operate 'asdf:load-op :binary-data) - - (if *external-build-dirs* (chdir *gf-build-dir*)) (asdf:operate 'asdf:load-op :graphic-forms-uitoolkit))

1 0

[graphic-forms-cvs] r53 - in trunk/src: . tests/uitoolkit uitoolkit/graphics
by junrue＠common-lisp.net 20 Mar '06

20 Mar '06

Author: junrue Date: Mon Mar 20 00:34:03 2006 New Revision: 53 Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/image.lisp Log: image transparency is now specified as a point in the image rather than a color Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Mar 20 00:34:03 2006 @@ -197,7 +197,7 @@ #:transform-coordinates #:translate #:transparency - #:transparency-of + #:transparency-pixel-of #:transparency-mask #:with-transparency #:xor-mode-p Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Mon Mar 20 00:34:03 2006 @@ -58,11 +58,12 @@ (defmethod gfw:event-paint ((d image-events) window time gc rect) (declare (ignore window time rect)) (let ((pnt (gfi:make-point)) - (color (gfg:make-color :red 0 :green 255 :blue 255))) + (pixel-pnt1 (gfi:make-point)) + (pixel-pnt2 (gfi:make-point :x 0 :y 15))) (gfg:draw-image gc *happy-image* pnt) (incf (gfi:point-x pnt) 36) - (gfg:with-transparency (*happy-image* color) + (gfg:with-transparency (*happy-image* pixel-pnt1) (gfg:draw-image gc (gfg:transparency-mask *happy-image*) pnt) (incf (gfi:point-x pnt) 36) (gfg:draw-image gc *happy-image* pnt)) @@ -71,7 +72,7 @@ (incf (gfi:point-y pnt) 36) (gfg:draw-image gc *bw-image* pnt) (incf (gfi:point-x pnt) 24) - (gfg:with-transparency (*bw-image* gfg:+color-black+) + (gfg:with-transparency (*bw-image* pixel-pnt1) (gfg:draw-image gc (gfg:transparency-mask *bw-image*) pnt) (incf (gfi:point-x pnt) 24) (gfg:draw-image gc *bw-image* pnt)) @@ -80,7 +81,7 @@ (incf (gfi:point-y pnt) 20) (gfg:draw-image gc *true-image* pnt) (incf (gfi:point-x pnt) 20) - (gfg:with-transparency (*true-image* color) + (gfg:with-transparency (*true-image* pixel-pnt2) (gfg:draw-image gc (gfg:transparency-mask *true-image*) pnt) (incf (gfi:point-x pnt) 20) (gfg:draw-image gc *true-image* pnt)))) @@ -103,6 +104,7 @@ (setf *image-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'image-events) :style '(:style-workspace))) (setf (gfw:size *image-win*) (gfi:make-size :width 250 :height 200)) + (setf (gfw:text *image-win*) "Image Tester") (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-image-fn)))))) (setf (gfw:menu-bar *image-win*) menubar) Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Mon Mar 20 00:34:03 2006 @@ -86,9 +86,9 @@ (:documentation "This class represents the context associated with drawing primitives.")) (defclass image (gfi:native-object) - ((transparency - :accessor transparency-of - :initarg :transparency + ((transparency-pixel + :accessor transparency-pixel-of + :initarg :transparency-pixel :initform nil)) (:documentation "This class wraps a native image object.")) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Mon Mar 20 00:34:03 2006 @@ -90,14 +90,13 @@ (error 'gfi:disposed-error)) (if (gfi:disposed-p im) (error 'gfi:disposed-error)) - (let* ((color (transparency-of im)) - (gc-dc (gfi:handle gc)) - (himage (gfi:handle im)) - (memdc (gfs::create-compatible-dc (cffi:null-pointer)))) + (let ((gc-dc (gfi:handle gc)) + (himage (gfi:handle im)) + (memdc (gfs::create-compatible-dc (cffi:null-pointer)))) (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) (gfs::get-object himage (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) - (if (not (null color)) + (if (not (null (transparency-pixel-of im))) (let ((hmask (gfi:handle (transparency-mask im))) (hcopy (clone-bitmap himage)) (memdc2 (gfs::create-compatible-dc (cffi:null-pointer)))) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Mon Mar 20 00:34:03 2006 @@ -37,14 +37,14 @@ ;;; helper macros and functions ;;; -(defmacro with-transparency ((image color) &body body) - (let ((orig-color (gensym))) - `(let ((,orig-color (transparency-of ,image))) +(defmacro with-transparency ((image pnt) &body body) + (let ((orig-pnt (gensym))) + `(let ((,orig-pnt (transparency-pixel-of ,image))) (unwind-protect (progn - (setf (transparency-of ,image) ,color) + (setf (transparency-pixel-of ,image) ,pnt) ,@body) - (setf (transparency-of ,image) ,orig-color))))) + (setf (transparency-pixel-of ,image) ,orig-pnt))))) (defun clone-bitmap (horig) (let ((hclone (cffi:null-pointer)) @@ -90,20 +90,23 @@ (defmethod transparency-mask ((im image)) (if (gfi:disposed-p im) (error 'gfi:disposed-error)) - (let ((hbmp (gfi:handle im)) + (let ((pixel-pnt (transparency-pixel-of im)) + (hbmp (gfi:handle im)) (hmask (cffi:null-pointer)) (nptr (cffi:null-pointer)) (old-bg 0)) - (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) - (gfs::get-object (gfi:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) - (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) - (setf hmask (gfs::create-bitmap gfs::width gfs::height 1 1 (cffi:null-pointer))) - (if (gfi:null-handle-p hmask) - (error 'gfs:win32-error :detail "create-bitmap failed")) - (gfs::with-compatible-dcs (nptr memdc1 memdc2) - (gfs::select-object memdc1 hbmp) - (setf old-bg (gfs::set-bk-color memdc1 (gfs::get-pixel memdc1 0 0))) - (gfs::select-object memdc2 hmask) - (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+) - (gfs::set-bk-color memdc1 old-bg)))) - (make-instance 'image :handle hmask))) + (unless (null pixel-pnt) + (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) + (gfs::get-object (gfi:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) + (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) + (setf hmask (gfs::create-bitmap gfs::width gfs::height 1 1 (cffi:null-pointer))) + (if (gfi:null-handle-p hmask) + (error 'gfs:win32-error :detail "create-bitmap failed")) + (gfs::with-compatible-dcs (nptr memdc1 memdc2) + (gfs::select-object memdc1 hbmp) + (setf old-bg (gfs::set-bk-color memdc1 + (gfs::get-pixel memdc1 (gfi:point-x pixel-pnt) (gfi:point-y pixel-pnt)))) + (gfs::select-object memdc2 hmask) + (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+) + (gfs::set-bk-color memdc1 old-bg)))) + (make-instance 'image :handle hmask))))

1 0

[graphic-forms-cvs] r52 - in trunk/src: . tests/uitoolkit uitoolkit/graphics uitoolkit/system uitoolkit/widgets
by junrue＠common-lisp.net 20 Mar '06

20 Mar '06

Author: junrue Date: Mon Mar 20 00:18:25 2006 New Revision: 52 Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/happy.bmp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/tests/uitoolkit/truecolor16x16.bmp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/image.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: basic transparency working, need to allow caller to select the pixel that defines transparent color Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Mar 20 00:18:25 2006 @@ -94,8 +94,9 @@ ;; methods, functions, macros #:detail + #:with-compatible-dcs #:with-hfont-selected - #:with-retrieved-hdc + #:with-retrieved-dc ;; conditions #:toolkit-error Modified: trunk/src/tests/uitoolkit/happy.bmp ============================================================================== Binary files. No diff available. Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Mon Mar 20 00:18:25 2006 @@ -58,11 +58,11 @@ (defmethod gfw:event-paint ((d image-events) window time gc rect) (declare (ignore window time rect)) (let ((pnt (gfi:make-point)) - (tr-color (gfg:make-color :red 192 :green 192 :blue 192))) + (color (gfg:make-color :red 0 :green 255 :blue 255))) (gfg:draw-image gc *happy-image* pnt) (incf (gfi:point-x pnt) 36) - (gfg:with-transparency (*happy-image* tr-color) + (gfg:with-transparency (*happy-image* color) (gfg:draw-image gc (gfg:transparency-mask *happy-image*) pnt) (incf (gfi:point-x pnt) 36) (gfg:draw-image gc *happy-image* pnt)) @@ -80,7 +80,7 @@ (incf (gfi:point-y pnt) 20) (gfg:draw-image gc *true-image* pnt) (incf (gfi:point-x pnt) 20) - (gfg:with-transparency (*true-image* tr-color) + (gfg:with-transparency (*true-image* color) (gfg:draw-image gc (gfg:transparency-mask *true-image*) pnt) (incf (gfi:point-x pnt) 20) (gfg:draw-image gc *true-image* pnt)))) Modified: trunk/src/tests/uitoolkit/truecolor16x16.bmp ============================================================================== Binary files. No diff available. Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Mon Mar 20 00:18:25 2006 @@ -90,25 +90,42 @@ (error 'gfi:disposed-error)) (if (gfi:disposed-p im) (error 'gfi:disposed-error)) - (let* ((gc-dc (gfi:handle gc)) + (let* ((color (transparency-of im)) + (gc-dc (gfi:handle gc)) (himage (gfi:handle im)) - (memdc (gfs::create-compatible-dc gc-dc)) - (tr-color (transparency-of im)) - (op gfs::+blt-srccopy+)) - (unwind-protect - (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) - (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) - (gfs::get-object himage (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) - (when (not (null tr-color)) - (setf op gfs::+blt-srcpaint+) - (gfs::select-object memdc (gfi:handle (transparency-mask im))) - (gfs::bit-blt gc-dc - (gfi:point-x pnt) - (gfi:point-y pnt) - gfs::width - gfs::height - memdc - 0 0 gfs::+blt-srcand+)) + (memdc (gfs::create-compatible-dc (cffi:null-pointer)))) + (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) + (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) + (gfs::get-object himage (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) + (if (not (null color)) + (let ((hmask (gfi:handle (transparency-mask im))) + (hcopy (clone-bitmap himage)) + (memdc2 (gfs::create-compatible-dc (cffi:null-pointer)))) + (gfs::select-object memdc hmask) + (gfs::select-object memdc2 hcopy) + (gfs::set-bk-color memdc2 (color-as-rgb +color-black+)) + (gfs::set-text-color memdc2 (color-as-rgb +color-white+)) + (gfs::bit-blt memdc2 + 0 0 + gfs::width + gfs::height + memdc + 0 0 gfs::+blt-srcand+) + (gfs::bit-blt gc-dc + (gfi:point-x pnt) + (gfi:point-y pnt) + gfs::width + gfs::height + memdc + 0 0 gfs::+blt-srcand+) + (gfs::bit-blt gc-dc + (gfi:point-x pnt) + (gfi:point-y pnt) + gfs::width + gfs::height + memdc2 + 0 0 gfs::+blt-srcpaint+)) + (progn (gfs::select-object memdc himage) (gfs::bit-blt gc-dc (gfi:point-x pnt) @@ -116,8 +133,8 @@ gfs::width gfs::height memdc - 0 0 op))) - (gfs::delete-dc memdc)))) + 0 0 gfs::+blt-srccopy+))))) + (gfs::delete-dc memdc))) (defmethod draw-text ((gc graphics-context) text (pnt gfi:point)) (if (gfi:disposed-p gc) Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Mon Mar 20 00:18:25 2006 @@ -46,8 +46,6 @@ (data nil) (sz nil) (byte-count 0)) - (when (gfi:null-handle-p mem-dc) - (error 'gfs:win32-error :detail "create-compatible-dc failed")) (unwind-protect (progn (cffi:with-foreign-object (bc-ptr 'gfs::bitmapcoreheader) @@ -218,8 +216,9 @@ (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))))) + (error 'gfs:toolkit-error :detail (format nil + "exception reason: ~s" + (cffi:foreign-slot-value ex 'exception-info 'reason)))) (if (cffi:null-pointer-p handle) (error 'gfs:toolkit-error :detail (format nil "could not load image: ~a" path))) (setf (slot-value data 'gfi:handle) handle)))) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Mon Mar 20 00:18:25 2006 @@ -34,7 +34,7 @@ (in-package :graphic-forms.uitoolkit.graphics) ;;; -;;; helper macros +;;; helper macros and functions ;;; (defmacro with-transparency ((image color) &body body) @@ -46,6 +46,21 @@ ,@body) (setf (transparency-of ,image) ,orig-color))))) +(defun clone-bitmap (horig) + (let ((hclone (cffi:null-pointer)) + (nptr (cffi:null-pointer))) + (gfs:with-compatible-dcs (nptr memdc-src memdc-dest) + (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) + (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) + (gfs::get-object horig (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) + (setf hclone (gfs::create-compatible-bitmap (gfs::get-dc (cffi:null-pointer)) + gfs::width + gfs::height)) + (gfs::select-object memdc-dest hclone) + (gfs::select-object memdc-src horig) + (gfs::bit-blt memdc-dest 0 0 gfs::width gfs::height memdc-src 0 0 gfs::+blt-srccopy+)))) + hclone)) + ;;; ;;; methods ;;; @@ -76,25 +91,19 @@ (if (gfi:disposed-p im) (error 'gfi:disposed-error)) (let ((hbmp (gfi:handle im)) - (tr-color (transparency-of im)) - (hmask (cffi:null-pointer))) - (if (null tr-color) - (setf tr-color +color-black+)) ;; FIXME: upper-left pixel might be better choice + (hmask (cffi:null-pointer)) + (nptr (cffi:null-pointer)) + (old-bg 0)) (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) (gfs::get-object (gfi:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) (setf hmask (gfs::create-bitmap gfs::width gfs::height 1 1 (cffi:null-pointer))) (if (gfi:null-handle-p hmask) (error 'gfs:win32-error :detail "create-bitmap failed")) - (let ((memdc1 (gfs::create-compatible-dc (cffi:null-pointer))) - (memdc2 (gfs::create-compatible-dc (cffi:null-pointer)))) - (unwind-protect - (progn - (gfs::select-object memdc1 hbmp) - (gfs::select-object memdc2 hmask) - (gfs::set-bk-color memdc1 (color-as-rgb tr-color)) - (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+) - (gfs::bit-blt memdc1 0 0 gfs::width gfs::height memdc2 0 0 gfs::+blt-srcinvert+)) - (gfs::delete-dc memdc1) - (gfs::delete-dc memdc2))))) + (gfs::with-compatible-dcs (nptr memdc1 memdc2) + (gfs::select-object memdc1 hbmp) + (setf old-bg (gfs::set-bk-color memdc1 (gfs::get-pixel memdc1 0 0))) + (gfs::select-object memdc2 hmask) + (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+) + (gfs::set-bk-color memdc1 old-bg)))) (make-instance 'image :handle hmask))) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Mon Mar 20 00:18:25 2006 @@ -164,6 +164,13 @@ (buffer LPTR)) (defcfun + ("GetPixel" get-pixel) + COLORREF + (hdc HANDLE) + (x INT) + (y INT)) + +(defcfun ("GetStockObject" get-stock-object) HANDLE (type INT)) @@ -180,6 +187,22 @@ (lpm LPTR)) (defcfun + ("MaskBlt" mask-blt) + BOOL + (hdest HANDLE) + (xdest INT) + (ydest INT) + (width INT) + (height INT) + (hsrc HANDLE) + (xsrc INT) + (ysrc INT) + (hmask HANDLE) + (xmask INT) + (ymask INT) + (rop DWORD)) + +(defcfun ("SelectObject" select-object) HANDLE (hdc HANDLE) @@ -219,3 +242,6 @@ COLORREF (hdc HANDLE) (color COLORREF)) + +(defun makerop4 (fore back) + (logior (logand (ash back 8) #xFF000000) fore)) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Mon Mar 20 00:18:25 2006 @@ -47,7 +47,7 @@ (unless (gfi:null-handle-p ,hfont-old) (gfs::select-object ,hdc ,hfont-old)))))) -(defmacro with-retrieved-hdc ((hwnd hdc-var) &body body) +(defmacro with-retrieved-dc ((hwnd hdc-var) &body body) `(let ((,hdc-var nil)) (unwind-protect (progn @@ -56,3 +56,12 @@ (error 'gfs:win32-error :detail "get-dc failed")) ,@body) (gfs::release-dc ,hwnd ,hdc-var)))) + +(defmacro with-compatible-dcs ((orig-dc &rest hdc-vars) &body body) + `(let ,(loop for var in hdc-vars + collect `(,var (gfs::create-compatible-dc ,orig-dc))) + (unwind-protect + (progn + ,@body) + ,@(loop for var2 in hdc-vars + collect `(gfs::delete-dc ,var2))))) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Mon Mar 20 00:18:25 2006 @@ -136,7 +136,7 @@ (sz (gfi:make-size)) (hfont nil)) (setf dt-flags (logior dt-flags gfs::+dt-calcrect+)) - (gfs:with-retrieved-hdc (hwnd hdc) + (gfs:with-retrieved-dc (hwnd hdc) (setf hfont (cffi:make-pointer (gfs::send-message hwnd gfs::+wm-getfont+ 0 0))) (gfs:with-hfont-selected (hdc hfont) (when (> len 0)

1 0

[graphic-forms-cvs] r51 - in trunk/src: . tests/uitoolkit uitoolkit/graphics uitoolkit/system
by junrue＠common-lisp.net 19 Mar '06

19 Mar '06

Author: junrue Date: Sun Mar 19 16:35:26 2006 New Revision: 51 Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/uitoolkit/graphics/color.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/magick-core-types.lisp trunk/src/uitoolkit/system/gdi32.lisp Log: initial transparency work Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Mar 19 16:35:26 2006 @@ -195,8 +195,10 @@ #:transform #:transform-coordinates #:translate - #:transparency-color + #:transparency + #:transparency-of #:transparency-mask + #:with-transparency #:xor-mode-p ;; conditions Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Sun Mar 19 16:35:26 2006 @@ -40,29 +40,54 @@ (defclass image-events (gfw:event-dispatcher) ()) -(defmethod gfw:event-close ((d image-events) window time) - (declare (ignore window time)) +(defun dispose-images () (gfi:dispose *happy-image*) (setf *happy-image* nil) (gfi:dispose *bw-image*) (setf *bw-image* nil) (gfi:dispose *true-image*) - (setf *true-image* nil) + (setf *true-image* nil)) + +(defmethod gfw:event-close ((d image-events) window time) + (declare (ignore window time)) + (dispose-images) (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))) + (let ((pnt (gfi:make-point)) + (tr-color (gfg:make-color :red 192 :green 192 :blue 192))) + (gfg:draw-image gc *happy-image* pnt) (incf (gfi:point-x pnt) 36) + (gfg:with-transparency (*happy-image* tr-color) + (gfg:draw-image gc (gfg:transparency-mask *happy-image*) pnt) + (incf (gfi:point-x pnt) 36) + (gfg:draw-image gc *happy-image* pnt)) + + (setf (gfi:point-x pnt) 0) + (incf (gfi:point-y pnt) 36) (gfg:draw-image gc *bw-image* pnt) (incf (gfi:point-x pnt) 24) - (gfg:draw-image gc *true-image* pnt))) + (gfg:with-transparency (*bw-image* gfg:+color-black+) + (gfg:draw-image gc (gfg:transparency-mask *bw-image*) pnt) + (incf (gfi:point-x pnt) 24) + (gfg:draw-image gc *bw-image* pnt)) + + (setf (gfi:point-x pnt) 0) + (incf (gfi:point-y pnt) 20) + (gfg:draw-image gc *true-image* pnt) + (incf (gfi:point-x pnt) 20) + (gfg:with-transparency (*true-image* tr-color) + (gfg:draw-image gc (gfg:transparency-mask *true-image*) pnt) + (incf (gfi:point-x pnt) 20) + (gfg:draw-image gc *true-image* pnt)))) (defun exit-image-fn (disp item time rect) (declare (ignorable disp item time rect)) + (dispose-images) (gfi:dispose *image-win*) (setf *image-win* nil) (gfw:shutdown 0)) @@ -77,6 +102,7 @@ (gfg::load *true-image* "truecolor16x16.bmp") (setf *image-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'image-events) :style '(:style-workspace))) + (setf (gfw:size *image-win*) (gfi:make-size :width 250 :height 200)) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-image-fn)))))) (setf (gfw:menu-bar *image-win*) menubar) Modified: trunk/src/uitoolkit/graphics/color.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/color.lisp (original) +++ trunk/src/uitoolkit/graphics/color.lisp Sun Mar 19 16:35:26 2006 @@ -33,13 +33,13 @@ (in-package :graphic-forms.uitoolkit.graphics) -(defconstant +color-black+ (make-color :red 0 :green 0 :blue 0)) -(defconstant +color-blue+ (make-color :red 0 :green 0 :blue #xFF)) -(defconstant +color-green+ (make-color :red 0 :green #xFF :blue 0)) -(defconstant +color-red+ (make-color :red #xFF :green 0 :blue 0)) -(defconstant +color-white+ (make-color :red #xFF :green #xFF :blue #xFF)) - (eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +color-black+ (make-color :red 0 :green 0 :blue 0)) + (defconstant +color-blue+ (make-color :red 0 :green 0 :blue #xFF)) + (defconstant +color-green+ (make-color :red 0 :green #xFF :blue 0)) + (defconstant +color-red+ (make-color :red #xFF :green 0 :blue 0)) + (defconstant +color-white+ (make-color :red #xFF :green #xFF :blue #xFF)) + (defmacro color-as-rgb (color) (let ((result (gensym))) `(let ((,result 0)) 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 16:35:26 2006 @@ -87,10 +87,10 @@ (defclass image (gfi:native-object) ((transparency - :accessor transparency-color - :initarg :transparency-color - :initform (make-color))) - (:documentation "This class represents an image of a particular type (BMP, PNG, etc.).")) + :accessor transparency-of + :initarg :transparency + :initform nil)) + (:documentation "This class wraps a native image object.")) (defmacro blue-mask (data) `(gfg::palette-blue-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 16:35:26 2006 @@ -82,30 +82,42 @@ 0 (cffi:null-pointer)))))) +;;; +;;; TODO: support addressing elements within bitmap as if it were an array +;;; (defmethod draw-image ((gc graphics-context) (im image) (pnt gfi:point)) (if (gfi:disposed-p gc) (error 'gfi:disposed-error)) (if (gfi:disposed-p im) (error 'gfi:disposed-error)) - ;; TODO: support addressing elements within bitmap as if it were an array - ;; - (let ((memdc (gfs::create-compatible-dc (gfi:handle gc))) - (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+)) - (gfs::select-object memdc oldhbm) - (gfs::delete-dc memdc))) + (let* ((gc-dc (gfi:handle gc)) + (himage (gfi:handle im)) + (memdc (gfs::create-compatible-dc gc-dc)) + (tr-color (transparency-of im)) + (op gfs::+blt-srccopy+)) + (unwind-protect + (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) + (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) + (gfs::get-object himage (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) + (when (not (null tr-color)) + (setf op gfs::+blt-srcpaint+) + (gfs::select-object memdc (gfi:handle (transparency-mask im))) + (gfs::bit-blt gc-dc + (gfi:point-x pnt) + (gfi:point-y pnt) + gfs::width + gfs::height + memdc + 0 0 gfs::+blt-srcand+)) + (gfs::select-object memdc himage) + (gfs::bit-blt gc-dc + (gfi:point-x pnt) + (gfi:point-y pnt) + gfs::width + gfs::height + memdc + 0 0 op))) + (gfs::delete-dc memdc)))) (defmethod draw-text ((gc graphics-context) text (pnt gfi:point)) (if (gfi:disposed-p gc) 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 16:35:26 2006 @@ -175,7 +175,7 @@ (:documentation "Returns a modified version of the object which is the result of translating the original by the specified mathematical vector.")) (defgeneric transparency-mask (object) - (:documentation "Returns an image-data object specifying the transparency mask for the image.")) + (:documentation "Returns an image object that will serve as the transparency mask for the original image, based on the original image's assigned transparency.")) (defgeneric xor-mode-p (object) (:documentation "Returns T if colors are combined in XOR mode; nil otherwise.")) 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 16:35:26 2006 @@ -145,12 +145,8 @@ (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)) (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 (- 0 (gfi:size-height sz))) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Sun Mar 19 16:35:26 2006 @@ -34,9 +34,18 @@ (in-package :graphic-forms.uitoolkit.graphics) ;;; -;;; helper functions +;;; helper macros ;;; +(defmacro with-transparency ((image color) &body body) + (let ((orig-color (gensym))) + `(let ((,orig-color (transparency-of ,image))) + (unwind-protect + (progn + (setf (transparency-of ,image) ,color) + ,@body) + (setf (transparency-of ,image) ,orig-color))))) + ;;; ;;; methods ;;; @@ -45,7 +54,6 @@ (let ((hgdi (gfi:handle im))) (unless (gfi:null-handle-p hgdi) (gfs::delete-object hgdi))) - (setf (transparency-color im) nil) (setf (slot-value im 'gfi:handle) nil)) (defmethod data-obj ((im image)) @@ -63,3 +71,30 @@ (load data path) (setf (data-obj im) data) data)) + +(defmethod transparency-mask ((im image)) + (if (gfi:disposed-p im) + (error 'gfi:disposed-error)) + (let ((hbmp (gfi:handle im)) + (tr-color (transparency-of im)) + (hmask (cffi:null-pointer))) + (if (null tr-color) + (setf tr-color +color-black+)) ;; FIXME: upper-left pixel might be better choice + (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) + (gfs::get-object (gfi:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) + (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) + (setf hmask (gfs::create-bitmap gfs::width gfs::height 1 1 (cffi:null-pointer))) + (if (gfi:null-handle-p hmask) + (error 'gfs:win32-error :detail "create-bitmap failed")) + (let ((memdc1 (gfs::create-compatible-dc (cffi:null-pointer))) + (memdc2 (gfs::create-compatible-dc (cffi:null-pointer)))) + (unwind-protect + (progn + (gfs::select-object memdc1 hbmp) + (gfs::select-object memdc2 hmask) + (gfs::set-bk-color memdc1 (color-as-rgb tr-color)) + (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+) + (gfs::bit-blt memdc1 0 0 gfs::width gfs::height memdc2 0 0 gfs::+blt-srcinvert+)) + (gfs::delete-dc memdc1) + (gfs::delete-dc memdc2))))) + (make-instance 'image :handle hmask))) Modified: trunk/src/uitoolkit/graphics/magick-core-types.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/magick-core-types.lisp (original) +++ trunk/src/uitoolkit/graphics/magick-core-types.lisp Sun Mar 19 16:35:26 2006 @@ -41,8 +41,9 @@ ;;; of these types from ImageMagick Core. ;;; -(defconstant +magick-max-text-extent+ 4096) -(defconstant +magick-signature+ #xABACADAB) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +magick-max-text-extent+ 4096) + (defconstant +magick-signature+ #xABACADAB)) (defconstant +undefined-channel+ #x00000000) (defconstant +red-channel+ #x00000001) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Sun Mar 19 16:35:26 2006 @@ -53,11 +53,27 @@ (rop DWORD)) (defcfun + ("CreateBitmap" create-bitmap) + HANDLE + (width INT) + (height INT) + (planes UINT) + (bpp UINT) + (pixels LPTR)) + +(defcfun ("CreateBitmapIndirect" create-bitmap-indirect) HANDLE (lpbm LPTR)) (defcfun + ("CreateCompatibleBitmap" create-compatible-bitmap) + HANDLE + (hdc HANDLE) + (width INT) + (height INT)) + +(defcfun ("CreateCompatibleDC" create-compatible-dc) HANDLE (hdc HANDLE))

1 0

[graphic-forms-cvs] r50 - in trunk: . src src/intrinsics/system src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 19 Mar '06

19 Mar '06

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*))

1 0

[graphic-forms-cvs] r49 - trunk/docs/website
by junrue＠common-lisp.net 18 Mar '06

18 Mar '06

Author: junrue Date: Sat Mar 18 17:32:58 2006 New Revision: 49 Modified: trunk/docs/website/index.html Log: corrected link to bug database Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Sat Mar 18 17:32:58 2006 @@ -18,7 +18,7 @@ <a class="barcenter" href="screenshots.html">Screenshots</a> <a class="barcenter" href="download.html">Download</a> <a class="barcenter" href="docs.html">Documentation</a> - <a class="barlast" href="https://sourceforge.net/tracker/?group_id=163034&atid=826145">Bug Database</a> + <a class="barlast" href="http://sourceforge.net/tracker/?group_id=163034&atid=826145">Bug Database</a> </div>

1 0

[graphic-forms-cvs] r48 - trunk/docs/website
by junrue＠common-lisp.net 18 Mar '06

18 Mar '06

Author: junrue Date: Sat Mar 18 14:28:47 2006 New Revision: 48 Modified: trunk/docs/website/sourceforge.html Log: tweaked redirect parameters Modified: trunk/docs/website/sourceforge.html ============================================================================== --- trunk/docs/website/sourceforge.html (original) +++ trunk/docs/website/sourceforge.html Sat Mar 18 14:28:47 2006 @@ -6,11 +6,11 @@ <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" /> <meta http-equiv="pragma" content="no-cache" /> <meta http-equiv="expires" content="0" /> - <meta http-equiv="refresh" content="$1$; http://common-lisp.net/project/graphic-forms" /> + <meta http-equiv="refresh" content="3; http://common-lisp.net/project/graphic-forms" /> </head> <body> - <p>Redirecting to common-lisp.net hosted website...</p> + <h4>Redirecting to common-lisp.net hosted website for Graphic-Forms...</h4> </body> </html>

1 0

[graphic-forms-cvs] r47 - trunk/docs/website
by junrue＠common-lisp.net 18 Mar '06

18 Mar '06

Author: junrue Date: Sat Mar 18 14:17:32 2006 New Revision: 47 Added: trunk/docs/website/sourceforge.html Modified: trunk/docs/website/docs.html trunk/docs/website/download.html trunk/docs/website/index.html trunk/docs/website/screenshots.html Log: updated for newly-created SourceForge project Modified: trunk/docs/website/docs.html ============================================================================== --- trunk/docs/website/docs.html (original) +++ trunk/docs/website/docs.html Sat Mar 18 14:17:32 2006 @@ -3,12 +3,16 @@ <head> <title>Graphic-Forms Documentation</title> - <link rel="stylesheet" type="text/css" href="style.css"> - <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"> + <link rel="stylesheet" type="text/css" href="style.css"/> + <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" /> </head> <body> + <div class="header"> + <h3>Graphic-Forms documentation</h3> + </div> + <h3><a href="reference/index.html">Programming Reference</a></h3> <h3>FAQ</h3> Modified: trunk/docs/website/download.html ============================================================================== --- trunk/docs/website/download.html (original) +++ trunk/docs/website/download.html Sat Mar 18 14:17:32 2006 @@ -3,28 +3,33 @@ <head> <title>Graphic-Forms Source Control</title> - <link rel="stylesheet" type="text/css" href="style.css"> - <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"> + <link rel="stylesheet" type="text/css" href="style.css" /> + <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" /> </head> <body> + <div class="header"> + <h3>Graphic-Forms downloads</h3> + </div> + <p>Graphic-Forms is distributed in source code form. Please choose from one of the following options: <ul> <li> - <a href="http://sourceforge.net/project/showfiles.php?group_id=1355">Download</a> - a release tarball. + <a href="http://sourceforge.net/project/showfiles.php?group_id=163034">Download</a> + a release tarball. File hosting courtesy of + <a href="http://sourceforge.net"><IMG src="http://sourceforge.net/sflogo.php?group_id=20959" width="88" height="31" border="0" alt="SourceForge Logo"></a><p/> </li> <li> <a href="http://common-lisp.net/faq.shtml">Download</a> the current development tree via anonymous Subversion. - Note: <i><project-name></i> is <i>graphic-forms</i>. + Note: <i><project-name></i> is <i>graphic-forms</i>.<p/> </li> <li> <a href="http://common-lisp.net/websvn/listing.php?repname=graphic-forms&path=%2F&sc…">Browse</a> - the Subversion repository. + the Subversion repository.<p/> </li> </ul> </p> Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Sat Mar 18 14:17:32 2006 @@ -3,32 +3,32 @@ <head> <title>Graphic-Forms project</title> - <link rel="stylesheet" type="text/css" href="style.css"> - <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"> + <link rel="stylesheet" type="text/css" href="style.css" /> + <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" /> </head> <body> - <div class="header"> - <h1>Graphic-Forms</h1> - <h2>A user interface toolkit for the Windows® platform.</h2> - </div> - - <div class="NavBar"> - <a class="barfirst" href="http://awayrepl.blogspot.com/">News</a> - <a class="barcenter" href="screenshots.html">Screenshots</a> - <a class="barcenter" href="download.html">Download</a> - <a class="barcenter" href="docs.html">Documentation</a> - <a class="barlast" href="http://sourceforge.net/tracker/?group_id=1355&atid=101355">Bug Database</a> -</div> - - - <h3>Introduction</h3> - - <p>Graphic-Forms is a user interface library implemented in - <a href="http://www.lisp.org">Common Lisp</a> focusing on the - Windows® platform. Graphic-Forms is licensed under the - terms of the - <a href="http://home.earthlink.net/~jdunrue/license.html">BSD License</a>.</p> + <div class="header"> + <h1>Graphic-Forms</h1> + <h2>A user interface toolkit for the Windows® platform.</h2> + </div> + + <div class="NavBar"> + <a class="barfirst" href="http://awayrepl.blogspot.com/">News</a> + <a class="barcenter" href="screenshots.html">Screenshots</a> + <a class="barcenter" href="download.html">Download</a> + <a class="barcenter" href="docs.html">Documentation</a> + <a class="barlast" href="https://sourceforge.net/tracker/?group_id=163034&atid=826145">Bug Database</a> + </div> + + + <h3>Introduction</h3> + + <p>Graphic-Forms is a user interface library implemented in + <a href="http://www.lisp.org">Common Lisp</a> focusing on the + Windows® platform. Graphic-Forms is licensed under the + terms of the + <a href="http://home.earthlink.net/~jdunrue/license.html">BSD License</a>.</p> <p>In the near term, the goal is to provide a toolkit encapsulating the underlying Modified: trunk/docs/website/screenshots.html ============================================================================== --- trunk/docs/website/screenshots.html (original) +++ trunk/docs/website/screenshots.html Sat Mar 18 14:17:32 2006 @@ -3,12 +3,16 @@ <head> <title>Graphic-Forms Screenshots</title> - <link rel="stylesheet" type="text/css" href="style.css"> - <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"> + <link rel="stylesheet" type="text/css" href="style.css" /> + <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" /> </head> <body> + <div class="header"> + <h3>Graphic-Forms screenshots</h3> + </div> + <p>Screenshots coming soon...stay tuned!</p> <div class="footer"> Added: trunk/docs/website/sourceforge.html ============================================================================== --- (empty file) +++ trunk/docs/website/sourceforge.html Sat Mar 18 14:17:32 2006 @@ -0,0 +1,16 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"> + +<head> + <title>Graphic-Forms project</title> + <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" /> + <meta http-equiv="pragma" content="no-cache" /> + <meta http-equiv="expires" content="0" /> + <meta http-equiv="refresh" content="$1$; http://common-lisp.net/project/graphic-forms" /> +</head> + +<body> + <p>Redirecting to common-lisp.net hosted website...</p> +</body> + +</html>

1 0