March 2006 - graphic-forms-cvs@common-lisp.net

[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

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

17 Mar '06

Author: junrue Date: Fri Mar 17 00:42:11 2006 New Revision: 46 Added: trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/top-level.lisp Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/text-label.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: refactored window class to differentiate between top-level and panel windows; replaced realize generic function by moving native object creation into initialize-instance Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Fri Mar 17 00:42:11 2006 @@ -107,5 +107,7 @@ (:file "menu-language") (:file "event") (:file "window") + (:file "top-level") + (:file "panel") (:file "layout") (:file "flow-layout"))))))))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Fri Mar 17 00:42:11 2006 @@ -91,7 +91,6 @@ ;; classes and structs ;; constants - #:+button-classname+ ;; methods, functions, macros #:detail @@ -230,6 +229,8 @@ #:layout-manager #:menu #:menu-item + #:panel + #:top-level #:widget #:widget-with-items #:window @@ -423,7 +424,6 @@ #:paste #:peer #:preferred-size - #:realize #:redraw #:redrawing-p #:remove-all Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Fri Mar 17 00:42:11 2006 @@ -190,8 +190,8 @@ (let ((echo-md (make-instance 'event-tester-echo-dispatcher)) (exit-md (make-instance 'event-tester-exit-dispatcher)) (menubar nil)) - (setf *event-tester-window* (make-instance 'gfw:window :dispatcher (make-instance 'event-tester-window-events))) - (gfw:realize *event-tester-window* nil :style-workspace) + (setf *event-tester-window* (make-instance 'gfw:top-level :dispatcher (make-instance 'event-tester-window-events) + :style '(:style-workspace))) (setf menubar (gfw:defmenusystem ((:item "&File" :dispatcher echo-md :submenu ((:item "&Open..." :dispatcher echo-md) (:item "&Save..." :disabled :dispatcher echo-md) Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Fri Mar 17 00:42:11 2006 @@ -60,8 +60,8 @@ (defun run-hello-world-internal () (let ((menubar nil)) - (setf *hello-win* (make-instance 'gfw:window :dispatcher (make-instance 'hellowin-events))) - (gfw:realize *hello-win* nil :style-workspace) + (setf *hello-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'hellowin-events) + :style '(:style-workspace))) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-fn)))))) (setf (gfw:menu-bar *hello-win*) menubar) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Fri Mar 17 00:42:11 2006 @@ -70,9 +70,19 @@ :initarg :id :initform 0))) +(defclass test-panel (gfw:panel) ()) + +(defmethod gfw:preferred-size ((win test-panel) width-hint height-hint) + (declare (ignore width-hint height-hint)) + (gfi:make-size :width 45 :height 45)) + +(defmethod gfw:text ((win test-panel)) + (declare (ignore win)) + "Test Panel") + (defun add-layout-tester-widget (widget-class subtype) (let* ((be (make-instance 'layout-tester-widget-events :id *widget-counter*)) - (w (make-instance widget-class :dispatcher be))) + (w (make-instance widget-class :parent *layout-tester-win* :dispatcher be))) (cond ((eql subtype :push-button) (setf (toggle-fn be) (let ((flag nil)) @@ -83,11 +93,10 @@ (format nil "~d ~a" (id be) +btn-text-before+)) (progn (setf flag nil) - (format nil "~d ~a" (id be) +btn-text-after+))))))) + (format nil "~d ~a" (id be) +btn-text-after+)))))) + (setf (gfw:text w) (funcall (toggle-fn be)))) ((eql subtype :text-label) - (setf (toggle-fn be) #'(lambda () (format nil "~d ~a" (id be) +label-text+))))) - (gfw:realize w *layout-tester-win* subtype) - (setf (gfw:text w) (funcall (toggle-fn be))) + (setf (gfw:text w) (format nil "~d ~a" (id be) +label-text+)))) (incf *widget-counter*))) (defmethod gfw:event-select ((d layout-tester-widget-events) btn time rect) @@ -331,23 +340,26 @@ (let ((menubar nil) (pack-disp (make-instance 'pack-layout-dispatcher)) (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 :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 :check-test-fn #'gfw:visible-p))) - (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events) - :layout (make-instance 'gfw:flow-layout - :spacing +spacing-delta+ - :margins +margin-delta+))) - (gfw:realize *layout-tester-win* nil :style-workspace) + (setf *layout-tester-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'layout-tester-events) + :style '(:style-workspace) + :layout (make-instance 'gfw:flow-layout + :spacing +spacing-delta+ + :margins +margin-delta+))) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-layout-callback))) (:item "&Children" :submenu ((:item "Add" :submenu ((:item "Button" :dispatcher add-btn-disp) - (:item "Label" :dispatcher add-text-label-disp))) + (:item "Label" :dispatcher add-text-label-disp) + (:item "Panel" :dispatcher add-panel-disp))) (:item "Remove" :dispatcher rem-menu-disp :submenu ((:item ""))) (:item "Visible" :dispatcher vis-menu-disp Modified: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- trunk/src/tests/uitoolkit/mock-objects.lisp (original) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Fri Mar 17 00:42:11 2006 @@ -57,7 +57,7 @@ :initarg :min-size :initform (gfi:make-size)))) -(defmethod initialize-instance :after ((widget mock-widget) &key &allow-other-keys) +(defmethod initialize-instance :after ((widget mock-widget) &key) (setf (slot-value widget 'gfi:handle) (cffi:make-pointer #xFFFFFFFF))) (defmethod gfw:minimum-size ((widget mock-widget)) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Fri Mar 17 00:42:11 2006 @@ -66,16 +66,18 @@ (defun create-borderless-win (disp item time rect) (declare (ignore disp item time rect)) - (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-borderless-events)))) - (gfw:realize window *main-win* :style-borderless) + (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-borderless-events) + :owner *main-win* + :style '(:style-borderless)))) (setf (gfw:location window) (gfi:make-point :x 400 :y 250)) (setf (gfw:size window) (gfi:make-size :width 300 :height 250)) (gfw:show window t))) (defun create-miniframe-win (disp item time rect) (declare (ignore disp item time rect)) - (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-mini-events)))) - (gfw:realize window *main-win* :style-miniframe) + (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events) + :owner *main-win* + :style '(:style-miniframe)))) (setf (gfw:location window) (gfi:make-point :x 250 :y 150)) (setf (gfw:size window) (gfi:make-size :width 150 :height 225)) (setf (gfw:text window) "Mini Frame") @@ -83,8 +85,9 @@ (defun create-palette-win (disp item time rect) (declare (ignore disp item time rect)) - (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-mini-events)))) - (gfw:realize window *main-win* :style-palette) + (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events) + :owner *main-win* + :style '(:style-palette)))) (setf (gfw:location window) (gfi:make-point :x 250 :y 150)) (setf (gfw:size window) (gfi:make-size :width 150 :height 225)) (setf (gfw:text window) "Palette") @@ -98,8 +101,8 @@ (defun run-windlg-internal () (let ((menubar nil)) - (setf *main-win* (make-instance 'gfw:window :dispatcher (make-instance 'main-win-events))) - (gfw:realize *main-win* nil :style-workspace) + (setf *main-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'main-win-events) + :style '(:style-workspace))) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-callback))) (:item "&Windows" Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Fri Mar 17 00:42:11 2006 @@ -232,11 +232,6 @@ (defconstant +mfs-disabled+ #x00000003) (defconstant +mfs-checked+ #x00000008) (defconstant +mfs-hilite+ #x00000080) -(defconstant +mfs-syncactive+ #x00000100) ; mini-frame style from afxwin.h -(defconstant +mfs-4thickframe+ #x00000200) ; mini-frame style from afxwin.h -(defconstant +mfs-thickframe+ #x00000400) ; mini-frame style from afxwin.h -(defconstant +mfs-moveframe+ #x00000800) ; mini-frame style from afxwin.h -(defconstant +mfs-blocksysmenu+ #x00001000) ; mini-frame style from afxwin.h (defconstant +mfs-enabled+ #x00000000) (defconstant +mfs-unchecked+ #x00000000) (defconstant +mfs-unhilite+ #x00000000) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Fri Mar 17 00:42:11 2006 @@ -61,6 +61,21 @@ (setf std-flags gfs::+bs-pushbox+)))) (values std-flags ex-flags))) +(defmethod initialize-instance :after ((btn button) &key parent style &allow-other-keys) + (if (not (listp style)) + (setf style (list style))) + (multiple-value-bind (std-style ex-style) + (compute-style-flags btn style) + (let ((hwnd (create-window gfs::+button-classname+ + " " + (gfi:handle parent) + (logior std-style gfs::+ws-child+ gfs::+ws-visible+) + ex-style))) + (if (not hwnd) + (error 'gfs:win32-error :detail "create-window failed")) + (setf (slot-value btn 'gfi:handle) hwnd))) + (init-control btn)) + (defmethod preferred-size ((btn button) width-hint height-hint) (let ((sz (widget-text-size btn gfs::+dt-singleline+ 0))) (if (>= width-hint 0) @@ -71,18 +86,6 @@ (setf (gfi:size-height sz) (+ (gfi:size-height sz) 10))) sz)) -(defmethod realize ((btn button) parent &rest style) - (multiple-value-bind (std-style ex-style) - (compute-style-flags btn style) - (let ((hwnd (create-window gfs:+button-classname+ - " " - (gfi:handle parent) - (logior std-style gfs::+ws-child+ gfs::+ws-visible+) - ex-style))) - (if (not hwnd) - (error 'gfs:win32-error :detail "create-window failed")) - (setf (slot-value btn 'gfi:handle) hwnd)))) - (defmethod text ((btn button)) (get-widget-text btn)) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Fri Mar 17 00:42:11 2006 @@ -34,30 +34,30 @@ (in-package :graphic-forms.uitoolkit.widgets) ;;; -;;; methods +;;; helper functions ;;; -(defmethod preferred-size :before ((ctl control) width-hint height-hint) - (declare (ignorable width-hint height-hint)) - (if (gfi:disposed-p ctl) - (error 'gfi:disposed-error))) - -(defmethod realize :before ((ctl control) parent &rest style) - (declare (ignore style)) - (if (gfi:disposed-p parent) - (error 'gfi:disposed-error)) - (if (not (gfi:disposed-p ctl)) - (error 'gfs:toolkit-error :detail "object already realized"))) - -(defmethod realize :after ((ctl control) parent &rest style) - (declare (ignorable parent style)) - (let ((hwnd (gfi:handle ctl))) +(defun init-control (ctrl) + (let ((hwnd (gfi:handle ctrl))) (subclass-wndproc hwnd) - (put-widget (thread-context) ctl) + (put-widget (thread-context) ctrl) (let ((hfont (gfs::get-stock-object gfs::+default-gui-font+))) (unless (gfi:null-handle-p hfont) (unless (zerop (gfs::send-message hwnd - gfs::+wm-setfont+ - (cffi:pointer-address hfont) - 0)) + gfs::+wm-setfont+ + (cffi:pointer-address hfont) + 0)) (error 'gfs:win32-error :detail "send-message failed")))))) + +;;; +;;; methods +;;; + +(defmethod initialize-instance :after ((ctrl control) &key parent &allow-other-keys) + (if (gfi:disposed-p parent) + (error 'gfi:disposed-error))) + +(defmethod preferred-size :before ((ctrl control) width-hint height-hint) + (declare (ignorable width-hint height-hint)) + (if (gfi:disposed-p ctrl) + (error 'gfi:disposed-error))) Added: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/panel.lisp Fri Mar 17 00:42:11 2006 @@ -0,0 +1,71 @@ +;;;; +;;;; panel.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.widgets) + +(defconstant +panel-window-classname+ "GraphicFormsPanel") + +;;; +;;; helper functions +;;; + +(defun register-panel-window-class () + (register-window-class +panel-window-classname+ + (cffi:get-callback 'uit_widgets_wndproc) + gfs::+cs-dblclks+ + gfs::+color-btnface+)) + +;;; +;;; methods +;;; + +(defmethod compute-style-flags ((win panel) &rest style) + (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+)) + (ex-flags 0)) + (mapc #'(lambda (sym) + (cond + ;; styles that can be combined + ;; + ((eq sym :style-border) + (setf std-flags (logior std-flags gfs::+ws-border+))))) + (flatten style)) + (values std-flags ex-flags))) + +(defmethod initialize-instance :after ((win panel) &key parent style &allow-other-keys) + (if (null parent) + (error 'gfs:toolkit-error :detail "parent is required for panel")) + (if (gfi:disposed-p parent) + (error 'gfi:disposed-error)) + (if (not (listp style)) + (setf style (list style))) + (init-window win +panel-window-classname+ #'register-panel-window-class style parent "")) Modified: trunk/src/uitoolkit/widgets/text-label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/text-label.lisp (original) +++ trunk/src/uitoolkit/widgets/text-label.lisp Fri Mar 17 00:42:11 2006 @@ -72,6 +72,22 @@ (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) + (if (not (listp style)) + (setf style (list style))) + (multiple-value-bind (std-style ex-style) + (compute-style-flags label style) + (let ((hwnd (create-window gfs::+static-classname+ + " " + (gfi:handle parent) + (logior std-style gfs::+ws-child+ gfs::+ws-visible+) + ex-style))) + (if (not hwnd) + (error 'gfs:win32-error :detail "create-window failed")) + (setf (slot-value label 'gfi:handle) hwnd))) + (init-control label)) + + (defmethod preferred-size ((label text-label) width-hint height-hint) (let* ((hwnd (gfi:handle label)) (bits (gfs::get-window-long hwnd gfs::+gwl-style+)) @@ -90,18 +106,6 @@ (incf (gfi:size-height sz) (* b-width 2)) sz)) -(defmethod realize ((label text-label) parent &rest style) - (multiple-value-bind (std-style ex-style) - (compute-style-flags label style) - (let ((hwnd (create-window gfs::+static-classname+ - " " - (gfi:handle parent) - (logior std-style gfs::+ws-child+ gfs::+ws-visible+) - ex-style))) - (if (not hwnd) - (error 'gfs:win32-error :detail "create-window failed")) - (setf (slot-value label 'gfi:handle) hwnd)))) - (defmethod text ((label text-label)) (get-widget-text label)) Added: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/top-level.lisp Fri Mar 17 00:42:11 2006 @@ -0,0 +1,172 @@ +;;;; +;;;; top-level.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.widgets) + +(defconstant +toplevel-window-classname+ "GraphicFormsTopLevel") + +(defconstant +default-window-title+ "New Window") + +;;; +;;; helper functions +;;; + +(defun register-toplevel-window-class () + (register-window-class +toplevel-window-classname+ + (cffi:get-callback 'uit_widgets_wndproc) + gfs::+cs-dblclks+ + gfs::+color-appworkspace+)) + +;;; +;;; methods +;;; + +(defmethod compute-style-flags ((win top-level) &rest style) + (declare (ignore win)) + (let ((std-flags 0) + (ex-flags 0)) + (mapc #'(lambda (sym) + (cond + ;; styles that can be combined + ;; +#| + ((eq sym :style-hscroll) + (setf std-flags (logior std-flags gfs::+ws-hscroll+))) + ((eq sym :style-max) + (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) + ((eq sym :style-min) + (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) + ((eq sym :style-resize) + (setf std-flags (logior std-flags gfs::+ws-thickframe+))) + ((eq sym :style-sysmenu) + (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) + ((eq sym :style-title) + (setf std-flags (logior std-flags gfs::+ws-caption+))) + ((eq sym :style-top) + (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+))) + ((eq sym :style-vscroll) + (setf std-flags (logior std-flags gfs::+ws-vscroll+))) +|# + + ;; pre-packaged combinations of window styles + ;; + ((eq sym :style-borderless) + (setf std-flags (logior gfs::+ws-clipchildren+ + gfs::+ws-clipsiblings+ + gfs::+ws-border+ + gfs::+ws-popup+)) + (setf ex-flags gfs::+ws-ex-topmost+)) + ((eq sym :style-palette) + (setf std-flags (logior gfs::+ws-clipchildren+ + gfs::+ws-clipsiblings+ + gfs::+ws-popupwindow+ + gfs::+ws-caption+)) + (setf ex-flags (logior gfs::+ws-ex-toolwindow+ + gfs::+ws-ex-windowedge+))) + ((eq sym :style-miniframe) + (setf std-flags (logior gfs::+ws-clipchildren+ + gfs::+ws-clipsiblings+ + gfs::+ws-popup+ + gfs::+ws-thickframe+ + gfs::+ws-sysmenu+ + gfs::+ws-caption+)) + (setf ex-flags (logior gfs::+ws-ex-appwindow+ + gfs::+ws-ex-toolwindow+))) + ((eq sym :style-workspace) + (setf std-flags (logior gfs::+ws-overlappedwindow+ + gfs::+ws-clipsiblings+ + gfs::+ws-clipchildren+)) + (setf ex-flags 0)))) + (flatten style)) + (values std-flags ex-flags))) + +(defmethod gfi:dispose ((win top-level)) + (let ((m (menu-bar win))) + (unless (null m) + (visit-menu-tree m #'menu-cleanup-callback) + (remove-widget (thread-context) (gfi:handle m)))) + (call-next-method)) + +(defmethod initialize-instance :after ((win top-level) &key owner style title &allow-other-keys) + (unless (null owner) + (if (gfi:disposed-p owner) + (error 'gfi:disposed-error))) + (if (null title) + (setf title +default-window-title+)) + (if (not (listp style)) + (setf style (list style))) + (init-window win +toplevel-window-classname+ #'register-toplevel-window-class style owner title)) + +(defmethod menu-bar :before ((win top-level)) + (if (gfi:disposed-p win) + (error 'gfi:disposed-error))) + +(defmethod menu-bar ((win top-level)) + (let ((hmenu (gfs::get-menu (gfi:handle win)))) + (if (gfi:null-handle-p hmenu) + (return-from menu-bar nil)) + (let ((m (get-widget (thread-context) hmenu))) + (if (null m) + (error 'gfs:toolkit-error :detail "no object for menu handle")) + m))) + +(defmethod (setf menu-bar) :before ((m menu) (win top-level)) + (declare (ignore m)) + (if (gfi:disposed-p win) + (error 'gfi:disposed-error))) + +(defmethod (setf menu-bar) ((m menu) (win top-level)) + (let* ((hwnd (gfi:handle win)) + (hmenu (gfs::get-menu hwnd)) + (old-menu (get-widget (thread-context) hmenu))) + (unless (gfi:null-handle-p hmenu) + (gfs::destroy-menu hmenu)) + (unless (null old-menu) + (gfi:dispose old-menu)) + (gfs::set-menu hwnd (gfi:handle m)) + (gfs::draw-menu-bar hwnd))) + +(defmethod text :before ((win top-level)) + (if (gfi:disposed-p win) + (error 'gfi:disposed-error))) + +(defmethod text ((win top-level)) + (get-widget-text win)) + +(defmethod (setf text) :before (str (win top-level)) + (declare (ignore str)) + (if (gfi:disposed-p win) + (error 'gfi:disposed-error))) + +(defmethod (setf text) (str (win top-level)) + (set-widget-text win str)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Mar 17 00:42:11 2006 @@ -60,7 +60,7 @@ (:documentation "The caret class provides an i-beam typically representing an insertion point.")) (defclass control (widget) () - (:documentation "The base class for widgets that process user input and/or display items.")) + (:documentation "The base class for widgets having pre-defined native behavior.")) (defclass button (control) () (:documentation "This class represents selectable controls that issue notifications when clicked.")) @@ -76,7 +76,7 @@ :accessor items ;; FIXME: allow subclasses to set initial size? :initform (make-array 7 :fill-pointer 0 :adjustable t))) - (:documentation "The widget-with-items class is the base class for objects composed of fine-grained items.")) + (:documentation "The widget-with-items class is the base class for objects composed of sub-items.")) (defclass menu (widget-with-items) () (:documentation "The menu class represents a container for menu items (and submenus).")) @@ -89,4 +89,10 @@ :accessor layout-of :initarg :layout :initform nil)) - (:documentation "The window class is the base class for widgets that serve as containers (including top-level windows).")) + (:documentation "Base class for user-defined widgets that serve as containers.")) + +(defclass panel (window) () + (:documentation "Base class for windows that are children of top-level windows (or other panels).")) + +(defclass top-level (window) () + (:documentation "Base class for windows that can be moved and resized by the user, and which normally have title bars.")) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Fri Mar 17 00:42:11 2006 @@ -255,9 +255,6 @@ (defgeneric preferred-size (object width-hint height-hint) (:documentation "Returns a size object representing the object's 'preferred' size.")) -(defgeneric realize (object parent &rest style) - (:documentation "Realizes the object on the screen.")) - (defgeneric redraw (object) (:documentation "Causes the entire bounds of the object to be marked as needing to be redrawn")) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Fri Mar 17 00:42:11 2006 @@ -179,6 +179,10 @@ (declare (ignore w)) nil) +(defmethod size :before ((w widget)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + (defmethod size ((w widget)) (client-size w)) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Fri Mar 17 00:42:11 2006 @@ -33,14 +33,27 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +workspace-window-classname+ "GraphicForms_WorkspaceWindow") - -(defconstant +default-window-title+ "New Window") - ;;; ;;; helper functions ;;; +(defun init-window (win classname register-class-fn style parent text) + (let ((tc (thread-context))) + (setf (widget-in-progress tc) win) + (funcall register-class-fn) + (multiple-value-bind (std-style ex-style) + (compute-style-flags win style) + (create-window classname + text + (if (null parent) (cffi:null-pointer) (gfi:handle parent)) + std-style + ex-style)) + (clear-widget-in-progress tc) + (let ((hwnd (gfi:handle win))) + (if (not hwnd) ; handle slot should have been set during create-window + (error 'gfs:win32-error :detail "create-window failed")) + (put-widget tc win)))) + #+lispworks (fli:define-foreign-callable ("child_window_visitor" :result-type :integer :calling-convention :stdcall) @@ -85,7 +98,7 @@ (pop-child-visitor-func tc))) nil) -(defun register-window-class (class-name proc-ptr st) +(defun register-window-class (class-name proc-ptr style bkgcolor) (let ((retval 0)) (cffi:with-foreign-string (str-ptr class-name) (cffi:with-foreign-object (wc-ptr 'gfs::wndclassex) @@ -100,7 +113,7 @@ str-ptr wc-ptr)) (progn (setf gfs::cbsize (cffi:foreign-type-size 'gfs::wndclassex)) - (setf gfs::style st) + (setf gfs::style style) (setf gfs::wndproc proc-ptr) (setf gfs::clsextra 0) (setf gfs::wndextra 0) @@ -111,7 +124,7 @@ gfs::+image-cursor+ 0 0 (logior gfs::+lr-defaultcolor+ gfs::+lr-shared+))) - (setf gfs::hbrush (cffi:make-pointer (1+ gfs::+color-appworkspace+))) + (setf gfs::hbrush (cffi:make-pointer (1+ bkgcolor))) (setf gfs::menuname (cffi:null-pointer)) (setf gfs::classname str-ptr) (setf gfs::smallicon (cffi:null-pointer)) @@ -130,16 +143,13 @@ (setf ,var (reverse ,var)) ,@body))) -(defun register-workspace-window-class () - (register-window-class +workspace-window-classname+ - (cffi:get-callback 'uit_widgets_wndproc) - (logior gfs::+cs-hredraw+ gfs::+cs-vredraw+))) - ;;; ;;; methods ;;; (defmethod compute-outer-size ((win window) desired-client-size) + ;; TODO: consider reimplementing this with AdjustWindowRect + ;; (let ((client-sz (client-size win)) (outer-sz (size win)) (trim-sz (gfi:make-size :width (gfi:size-width desired-client-size) @@ -150,72 +160,6 @@ (gfi:size-height client-sz))) trim-sz)) -(defmethod compute-style-flags ((win window) &rest style) - (declare (ignore win)) - (let ((std-flags 0) - (ex-flags 0)) - (mapc #'(lambda (sym) - (cond - ;; styles that can be combined - ;; - ((eq sym :style-hscroll) - (setf std-flags (logior std-flags gfs::+ws-hscroll+))) -#| - ((eq sym :style-max) - (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) - ((eq sym :style-min) - (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) - ((eq sym :style-resize) - (setf std-flags (logior std-flags gfs::+ws-thickframe+))) - ((eq sym :style-sysmenu) - (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) - ((eq sym :style-title) - (setf std-flags (logior std-flags gfs::+ws-caption+))) - ((eq sym :style-top) - (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+))) -|# - ((eq sym :style-vscroll) - (setf std-flags (logior std-flags gfs::+ws-vscroll+))) - - ;; pre-packaged combinations of window styles - ;; - ((eq sym :style-borderless) - (setf std-flags (logior gfs::+ws-clipchildren+ - gfs::+ws-clipsiblings+ - gfs::+ws-border+ - gfs::+ws-popup+)) - (setf ex-flags gfs::+ws-ex-topmost+)) - ((eq sym :style-palette) - (setf std-flags (logior gfs::+ws-clipchildren+ - gfs::+ws-clipsiblings+ - gfs::+ws-popupwindow+ - gfs::+ws-caption+)) - (setf ex-flags (logior gfs::+ws-ex-toolwindow+ - gfs::+ws-ex-windowedge+))) - ((eq sym :style-miniframe) - (setf std-flags (logior gfs::+ws-clipchildren+ - gfs::+ws-clipsiblings+ - gfs::+ws-popup+ - gfs::+ws-thickframe+ - gfs::+ws-sysmenu+ - gfs::+ws-caption+)) - (setf ex-flags (logior gfs::+ws-ex-appwindow+ - gfs::+ws-ex-toolwindow+))) - ((eq sym :style-workspace) - (setf std-flags (logior gfs::+ws-overlappedwindow+ - gfs::+ws-clipsiblings+ - gfs::+ws-clipchildren+)) - (setf ex-flags 0)))) - (flatten style)) - (values std-flags ex-flags))) - -(defmethod gfi:dispose ((win window)) - (let ((m (menu-bar win))) - (unless (null m) - (visit-menu-tree m #'menu-cleanup-callback) - (remove-widget (thread-context) (gfi:handle m)))) - (call-next-method)) - (defmethod enable-layout :before ((win window) flag) (declare (ignore flag)) (if (gfi:disposed-p win) @@ -232,37 +176,17 @@ (let ((sz (client-size win))) (perform-layout win (gfi:size-width sz) (gfi:size-height sz)))) -(defmethod location ((w window)) - (if (gfi:disposed-p w) +(defmethod location ((win window)) + (if (gfi:disposed-p win) (error 'gfi:disposed-error)) (let ((pnt (gfi:make-point))) - (outer-location w pnt) + (outer-location win pnt) pnt)) (defmethod layout ((win window)) (let ((sz (client-size win))) (perform-layout win (gfi:size-width sz) (gfi:size-height sz)))) -(defmethod menu-bar ((win window)) - (let ((hmenu (gfs::get-menu (gfi:handle win)))) - (if (gfi:null-handle-p hmenu) - (return-from menu-bar nil)) - (let ((m (get-widget (thread-context) hmenu))) - (if (null m) - (error 'gfs:toolkit-error :detail "no object for menu handle")) - m))) - -(defmethod (setf menu-bar) ((m menu) (win window)) - (let* ((hwnd (gfi:handle win)) - (hmenu (gfs::get-menu hwnd)) - (old-menu (get-widget (thread-context) hmenu))) - (unless (gfi:null-handle-p hmenu) - (gfs::destroy-menu hmenu)) - (unless (null old-menu) - (gfi:dispose old-menu)) - (gfs::set-menu hwnd (gfi:handle m)) - (gfs::draw-menu-bar hwnd))) - (defmethod pack ((win window)) (perform-layout win -1 -1) (call-next-method)) @@ -274,42 +198,12 @@ (compute-outer-size win new-client-sz)) (size win)))) -(defmethod realize ((win window) parent &rest style) - (if (not (gfi:disposed-p win)) - (error 'gfs:toolkit-error :detail "object already realized")) - (unless (null parent) - (if (gfi:disposed-p parent) - (error 'gfi:disposed-error))) - (let ((tc (thread-context))) - (setf (widget-in-progress tc) win) - (register-workspace-window-class) - (multiple-value-bind (std-style ex-style) - (compute-style-flags win style) - (create-window +workspace-window-classname+ - +default-window-title+ - (if (null parent) (cffi:null-pointer) (gfi:handle parent)) - std-style - ex-style)) - (clear-widget-in-progress tc) - (let ((hwnd (gfi:handle win))) - (if (not hwnd) ; handle slot should have been set during create-window - (error 'gfs:win32-error :detail "create-window failed")) - (put-widget tc win)))) - (defmethod show ((win window) flag) (declare (ignore flag)) (call-next-method) (gfs::update-window (gfi:handle win))) (defmethod size ((win window)) - (if (gfi:disposed-p win) - (error 'gfi:disposed-error)) (let ((sz (gfi:make-size))) (outer-size win sz) sz)) - -(defmethod text ((win window)) - (get-widget-text win)) - -(defmethod (setf text) (str (win window)) - (set-widget-text win str))

1 0

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

16 Mar '06

Author: junrue Date: Thu Mar 16 00:17:31 2006 New Revision: 45 Modified: trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/window.lisp Log: replaced +style-popup+ with +style-palette+ and associated implementation; implemented +style-miniframe+ and +style-borderless+; relocated thread context cleanup function call to a more robust location Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Thu Mar 16 00:17:31 2006 @@ -33,14 +33,17 @@ (in-package #:graphic-forms.uitoolkit.tests) +(defvar *hello-win* nil) + (defclass hellowin-events (gfw:event-dispatcher) ()) -(defmethod gfw:event-close ((d hellowin-events) widget time) +(defmethod gfw:event-close ((d hellowin-events) window time) (declare (ignore widget time)) + (gfi:dispose window) (gfw:shutdown 0)) (defmethod gfw:event-paint ((d hellowin-events) window time gc rect) - (declare (ignore window time rect)) + (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+) @@ -51,17 +54,18 @@ (defun exit-fn (disp item time rect) (declare (ignorable disp item time rect)) + (gfi:dispose *hello-win*) + (setf *hello-win* nil) (gfw:shutdown 0)) (defun run-hello-world-internal () - (let ((menubar nil) - (window nil)) - (setf window (make-instance 'gfw:window :dispatcher (make-instance 'hellowin-events))) - (gfw:realize window nil :style-workspace) + (let ((menubar nil)) + (setf *hello-win* (make-instance 'gfw:window :dispatcher (make-instance 'hellowin-events))) + (gfw:realize *hello-win* nil :style-workspace) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-fn)))))) - (setf (gfw:menu-bar window) menubar) - (gfw:show window t))) + (setf (gfw:menu-bar *hello-win*) menubar) + (gfw:show *hello-win* t))) (defun run-hello-world () (gfw:startup "Hello World" #'run-hello-world-internal)) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Thu Mar 16 00:17:31 2006 @@ -33,19 +33,18 @@ (in-package #:graphic-forms.uitoolkit.tests) +(defvar *main-win* nil) + (defclass main-win-events (gfw:event-dispatcher) ()) (defmethod gfw:event-close ((d main-win-events) window time) (declare (ignore time)) + (setf *main-win* nil) (gfi:dispose window) (gfw:shutdown 0)) (defclass test-win-events (gfw:event-dispatcher) ()) -(defmethod gfw:event-close ((d test-win-events) window time) - (declare (ignore time)) - (gfi:dispose window)) - (defmethod gfw:event-paint ((d test-win-events) window time gc rect) (declare (ignore time)) (setf rect (make-instance 'gfi:rectangle :location (gfi:make-point) @@ -53,36 +52,62 @@ (setf (gfg:background-color gc) gfg:+color-white+) (gfg:draw-filled-rectangle gc rect)) -(defun create-borderless-win ()) +(defclass test-mini-events (test-win-events) ()) -(defun create-miniframe-win ()) +(defmethod gfw:event-close ((d test-mini-events) window time) + (declare (ignore time)) + (gfi:dispose window)) + +(defclass test-borderless-events (test-win-events) ()) + +(defmethod gfw:event-mouse-down ((d test-borderless-events) window time point button) + (declare (ignore time point button)) + (gfi:dispose window)) -(defun create-popup-win (disp item time rect) +(defun create-borderless-win (disp item time rect) (declare (ignore disp item time rect)) - (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-win-events)))) - (gfw:realize window nil :style-popup) + (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-borderless-events)))) + (gfw:realize window *main-win* :style-borderless) + (setf (gfw:location window) (gfi:make-point :x 400 :y 250)) + (setf (gfw:size window) (gfi:make-size :width 300 :height 250)) + (gfw:show window t))) + +(defun create-miniframe-win (disp item time rect) + (declare (ignore disp item time rect)) + (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-mini-events)))) + (gfw:realize window *main-win* :style-miniframe) + (setf (gfw:location window) (gfi:make-point :x 250 :y 150)) + (setf (gfw:size window) (gfi:make-size :width 150 :height 225)) + (setf (gfw:text window) "Mini Frame") + (gfw:show window t))) + +(defun create-palette-win (disp item time rect) + (declare (ignore disp item time rect)) + (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-mini-events)))) + (gfw:realize window *main-win* :style-palette) (setf (gfw:location window) (gfi:make-point :x 250 :y 150)) - (setf (gfw:size window) (gfi:make-size :width 75 :height 125)) - (setf (gfw:text window) "Popup") + (setf (gfw:size window) (gfi:make-size :width 150 :height 225)) + (setf (gfw:text window) "Palette") (gfw:show window t))) (defun exit-callback (disp item time rect) (declare (ignore disp item time rect)) + (gfi:dispose *main-win*) + (setf *main-win* nil) (gfw:shutdown 0)) (defun run-windlg-internal () - (let ((menubar nil) - (window nil)) - (setf window (make-instance 'gfw:window :dispatcher (make-instance 'main-win-events))) - (gfw:realize window nil :style-workspace) + (let ((menubar nil)) + (setf *main-win* (make-instance 'gfw:window :dispatcher (make-instance 'main-win-events))) + (gfw:realize *main-win* nil :style-workspace) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-callback))) (:item "&Windows" :submenu ((:item "&Borderless" :callback #'create-borderless-win) (:item "&Mini Frame" :callback #'create-miniframe-win) - (:item "&Popup" :callback #'create-popup-win)))))) - (setf (gfw:menu-bar window) menubar) - (gfw:show window t))) + (:item "&Palette" :callback #'create-palette-win)))))) + (setf (gfw:menu-bar *main-win*) menubar) + (gfw:show *main-win* t))) (defun run-windlg () (gfw:startup "Window/Dialog Tester" #'run-windlg-internal)) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Thu Mar 16 00:17:31 2006 @@ -232,6 +232,11 @@ (defconstant +mfs-disabled+ #x00000003) (defconstant +mfs-checked+ #x00000008) (defconstant +mfs-hilite+ #x00000080) +(defconstant +mfs-syncactive+ #x00000100) ; mini-frame style from afxwin.h +(defconstant +mfs-4thickframe+ #x00000200) ; mini-frame style from afxwin.h +(defconstant +mfs-thickframe+ #x00000400) ; mini-frame style from afxwin.h +(defconstant +mfs-moveframe+ #x00000800) ; mini-frame style from afxwin.h +(defconstant +mfs-blocksysmenu+ #x00001000) ; mini-frame style from afxwin.h (defconstant +mfs-enabled+ #x00000000) (defconstant +mfs-unchecked+ #x00000000) (defconstant +mfs-unhilite+ #x00000000) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Thu Mar 16 00:17:31 2006 @@ -75,6 +75,7 @@ msg-ptr gfs::msg) (setf (event-time (thread-context)) gfs::time) (when (zerop gm) + (dispose-thread-context) (return-from run-default-message-loop gfs::wparam)) (when (= gm -1) (warn 'gfs:win32-warning :detail "get-message failed") Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Thu Mar 16 00:17:31 2006 @@ -49,8 +49,7 @@ (run-default-message-loop))))) (defun shutdown (exit-code) - (gfs::post-quit-message exit-code) - (dispose-thread-context)) + (gfs::post-quit-message exit-code)) (defun clear-all (w) (let ((count (gfw:item-count w))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu Mar 16 00:17:31 2006 @@ -179,19 +179,28 @@ ;; pre-packaged combinations of window styles ;; - ((eq sym :style-popup) - (setf std-flags (logior gfs::+ws-popupwindow+ gfs::+ws-caption+)) - (setf ex-flags gfs::+ws-ex-toolwindow+)) - ((eq sym :style-splash) - (setf std-flags (logior gfs::+ws-overlapped+ - gfs::+ws-popup+ + ((eq sym :style-borderless) + (setf std-flags (logior gfs::+ws-clipchildren+ gfs::+ws-clipsiblings+ gfs::+ws-border+ - gfs::+ws-visible+)) - (setf ex-flags 0)) - ((eq sym :style-tool) - (setf std-flags 0) - (setf ex-flags gfs::+ws-ex-palettewindow+)) + gfs::+ws-popup+)) + (setf ex-flags gfs::+ws-ex-topmost+)) + ((eq sym :style-palette) + (setf std-flags (logior gfs::+ws-clipchildren+ + gfs::+ws-clipsiblings+ + gfs::+ws-popupwindow+ + gfs::+ws-caption+)) + (setf ex-flags (logior gfs::+ws-ex-toolwindow+ + gfs::+ws-ex-windowedge+))) + ((eq sym :style-miniframe) + (setf std-flags (logior gfs::+ws-clipchildren+ + gfs::+ws-clipsiblings+ + gfs::+ws-popup+ + gfs::+ws-thickframe+ + gfs::+ws-sysmenu+ + gfs::+ws-caption+)) + (setf ex-flags (logior gfs::+ws-ex-appwindow+ + gfs::+ws-ex-toolwindow+))) ((eq sym :style-workspace) (setf std-flags (logior gfs::+ws-overlappedwindow+ gfs::+ws-clipsiblings+ @@ -266,10 +275,11 @@ (size win)))) (defmethod realize ((win window) parent &rest style) - (if (not (null parent)) - (error 'gfs:toolkit-error :detail "FIXME: not implemented")) ; may allow MDI in the future (if (not (gfi:disposed-p win)) (error 'gfs:toolkit-error :detail "object already realized")) + (unless (null parent) + (if (gfi:disposed-p parent) + (error 'gfi:disposed-error))) (let ((tc (thread-context))) (setf (widget-in-progress tc) win) (register-workspace-window-class) @@ -277,7 +287,7 @@ (compute-style-flags win style) (create-window +workspace-window-classname+ +default-window-title+ - (cffi:null-pointer) + (if (null parent) (cffi:null-pointer) (gfi:handle parent)) std-style ex-style)) (clear-widget-in-progress tc)

1 0