From junrue at common-lisp.net Mon Apr 3 03:24:48 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 2 Apr 2006 23:24:48 -0400 (EDT) Subject: [graphic-forms-cvs] r85 - in trunk: . docs/manual src/demos src/demos/unblocked src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/widgets Message-ID: <20060403032448.2C97B19002@common-lisp.net> Author: junrue Date: Sun Apr 2 23:24:46 2006 New Revision: 85 Added: trunk/src/demos/ trunk/src/demos/unblocked/ trunk/src/demos/unblocked/scoreboard-panel.lisp trunk/src/demos/unblocked/tiles.lisp trunk/src/demos/unblocked/unblocked-model.lisp trunk/src/demos/unblocked/unblocked-panel.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/tests/uitoolkit/blue-tile.bmp (contents, props changed) trunk/src/tests/uitoolkit/brown-tile.bmp (contents, props changed) trunk/src/tests/uitoolkit/gold-tile.bmp (contents, props changed) trunk/src/tests/uitoolkit/green-tile.bmp (contents, props changed) trunk/src/tests/uitoolkit/pink-tile.bmp (contents, props changed) trunk/src/tests/uitoolkit/red-tile.bmp (contents, props changed) Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-tests.asd trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/image.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: initial code for blocks game Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Apr 2 23:24:46 2006 @@ -299,8 +299,30 @@ @anchor{top-level} @deftp Class top-level -Base class for @ref{window}s that can be moved and resized by the -user, and which normally have title bars. +Base class for @ref{window}s that are self-contained and parented to +the @ref{root-window}. Except for the @code{:palette} style, they are +normally resizable have title bars (also called 'captions'). + at deffn Initarg :style +The :style initarg is a list of keywords that define the overall +look-and-feel of the window being created. Applications may choose +from one of the following primary style keywords: + at table @code + at item :borderless +a window with a one-pixel border (so not really @emph{borderless} in the +strictest sense); no frame icon, system menu, minimize/maximize buttons, +or close buttons + at item :miniframe +a resizable window with a shorter than normal caption; has a close box +but no system menu or minimize/maximize buttons + at item :palette +similar to the @code{:miniframe} style, but in this case the window +does not have resize frame + at item :workspace +the standard top-level frame style with system menu, close box, and +minimize/maximize buttons; this window is resizable and normally hosts +the primary user interface for an application + at end table + at end deffn @end deftp @anchor{widget} Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Apr 2 23:24:46 2006 @@ -35,7 +35,15 @@ (defpackage #:graphic-forms.uitoolkit.tests (:nicknames #:gft) - (:use :common-lisp :lisp-unit)) + (:use :common-lisp :lisp-unit) + (:export + #:run-drawing-tester + #:run-event-tester + #:run-hello-world + #:run-image-tester + #:run-layout-tester + #:run-windlg + #:unblocked)) (print "Graphic-Forms UI Toolkit Tests") (print "Copyright (c) 2006 by Jack D. Unrue") @@ -49,7 +57,16 @@ :components ((:module "src" :components - ((:module "tests" + ((:module "demos" + :components + ((:module "unblocked" + :components + ((:file "tiles") + (:file "unblocked-model") + (:file "scoreboard-panel") + (:file "unblocked-panel") + (:file "unblocked-window"))))) + (:module "tests" :components ((:module "uitoolkit" :components Added: trunk/src/demos/unblocked/scoreboard-panel.lisp ============================================================================== --- (empty file) +++ trunk/src/demos/unblocked/scoreboard-panel.lisp Sun Apr 2 23:24:46 2006 @@ -0,0 +1,87 @@ +;;;; +;;;; scoreboard-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.tests) + +(defclass scoreboard-panel-events (gfw:event-dispatcher) + ((label-font + :accessor label-font-of + :initform nil) + (value-font + :accessor value-font-of + :initform nil) + (size + :accessor size-of + :initform (gfs:make-size)))) + +(defmethod dispose ((self scoreboard-panel-events)) + (let ((tmp-font (label-font-of self))) + (unless (null tmp-font) + (gfs:dispose tmp-font) + (setf (label-font-of self) nil)) + (setf tmp-font (value-font-of self)) + (unless (null tmp-font) + (gfs:dispose tmp-font) + (setf (label-font-of self) nil)))) + +(defmethod initialize-instance :after ((self scoreboard-panel-events) &key) + (let ((gc (make-instance 'gfg:graphics-context)) + (label-font-data (gfg:make-font-data :face-name "Tahoma" + :point-size 14 + :style '(:bold))) + (value-font-data (gfg:make-font-data :face-name "Tahoma" + :point-size 14)) + (extent-size nil) + (pref-size (gfs:make-size)) + (font nil)) + (unwind-protect + (progn + (setf font (make-instance 'gfg:font :gc gc :data label-font-data) + (label-font-of self) font + (gfg:font gc) font + extent-size (gfg:text-extent gc "Next Level Score:") + (gfs:size-width pref-size) (gfs:size-width extent-size) + (gfs:size-height pref-size) (* (gfs:size-height extent-size) 4)) + (setf font (make-instance 'gfg:font :gc gc :data value-font-data) + (value-font-of self) font + (gfg:font gc) font + extent-size (gfg:text-extent gc (format nil "~c9,999,999" #\Tab))) + (incf (gfs:size-width pref-size) (gfs:size-width extent-size)) + (setf (size-of self) pref-size)) + (gfs:dispose gc)))) + +(defclass scoreboard-panel (gfw:panel) ()) + +(defmethod gfw:preferred-size ((self scoreboard-panel) width-hint height-hint) + (declare (ignore width-hint height-hint)) + (size-of (gfw:dispatcher self))) Added: trunk/src/demos/unblocked/tiles.lisp ============================================================================== --- (empty file) +++ trunk/src/demos/unblocked/tiles.lisp Sun Apr 2 23:24:46 2006 @@ -0,0 +1,115 @@ +;;;; +;;;; tiles.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) + +(defstruct tile (kind 0) (location (gfs:make-point))) + +(defun init-tiles (width height kinds) + (let* ((tiles (make-array width :initial-element nil))) + (dotimes (i width) + (let ((column (make-array height :initial-element 0))) + (setf (aref tiles i) column) + (dotimes (j height) + (setf (aref column j) (random (1+ kinds)))))) + tiles)) + +(defun size-tiles (tiles) + (gfs:make-size :width (length tiles) :height (length (aref tiles 0)))) + +(defun map-tiles (func tiles) + (let ((size (size-tiles tiles))) + (dotimes (j (gfs:size-height size)) + (dotimes (i (gfs:size-width size)) + (let ((kind (aref (aref tiles i) (- (1- (gfs:size-height size)) j)))) + (funcall func (gfs:make-point :x i :y j) kind)))))) + +(defun print-tiles (tiles) + (let ((size (size-tiles tiles))) + (dotimes (j (gfs:size-height size)) + (dotimes (i (gfs:size-width size)) + (let ((kind (aref (aref tiles i) (- (1- (gfs:size-height size)) j)))) + (if (< kind 0) + (print " ") + (format t "~d " kind)))) + (format t "~%")))) + +(defun eql-point (pnt1 pnt2) + (and (= (gfs:point-x pnt1) (gfs:point-x pnt2)) + (= (gfs:point-y pnt1) (gfs:point-y pnt2)))) + +(defun obtain-tile (tiles pnt) + (let ((column (aref tiles (gfs:point-x pnt)))) + (aref column (gfs:point-y pnt)))) + +(defun neighbor-point (tiles orig-pnt delta-x delta-y) + (let ((size (size-tiles tiles)) + (new-x (+ (gfs:point-x orig-pnt) delta-x)) + (new-y (+ (gfs:point-y orig-pnt) delta-y))) + (unless (or (< new-x 0) + (< new-y 0) + (>= new-x (gfs:size-width size)) + (>= new-y (gfs:size-height size))) + (return-from neighbor-point (gfs:make-point :x new-x :y new-y))) + nil)) + +(defun neighbor-points (tiles orig-pnt) + (loop for pnt in (list (neighbor-point tiles orig-pnt 0 -1) + (neighbor-point tiles orig-pnt 0 1) + (neighbor-point tiles orig-pnt -1 0) + (neighbor-point tiles orig-pnt 1 0)) + when (not (null pnt)) + collect pnt)) + +(defun shape-tiles (tiles tile-pnt results) + (when (null (gethash tile-pnt results)) + (let ((kind (obtain-tile tiles tile-pnt))) + (setf (gethash tile-pnt results) kind) + (loop for pnt2 in (neighbor-points tiles tile-pnt) + when (= kind (obtain-tile tiles pnt2)) + do (shape-tiles tiles pnt2 results))))) + +(defun collapse-column (column-tiles) + (let ((new-column (make-array (length column-tiles) :initial-element 0)) + (new-index 0)) + (dotimes (i (length column-tiles)) + (let ((kind (aref column-tiles i))) + (unless (zerop kind) + (setf (aref new-column new-index) kind) + (incf new-index)))) + new-column)) + +(defun collapse-tiles (tiles) + (let ((size (size-tiles tiles))) + (dotimes (i (gfs:size-width size)) + (setf (aref tiles i) (collapse-column (aref tiles i)))))) Added: trunk/src/demos/unblocked/unblocked-model.lisp ============================================================================== --- (empty file) +++ trunk/src/demos/unblocked/unblocked-model.lisp Sun Apr 2 23:24:46 2006 @@ -0,0 +1,40 @@ +;;;; +;;;; unblocked-model.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) + +(defconstant +max-tile-kinds+ 6) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +horz-tile-count+ 14) + (defconstant +vert-tile-count+ 9)) Added: trunk/src/demos/unblocked/unblocked-panel.lisp ============================================================================== --- (empty file) +++ trunk/src/demos/unblocked/unblocked-panel.lisp Sun Apr 2 23:24:46 2006 @@ -0,0 +1,103 @@ +;;;; +;;;; unblocked-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.tests) + +(defconstant +tile-bmp-width+ 24) +(defconstant +tile-bmp-height+ 24) + +(defun tiles->window (pnt) + (gfs:make-point :x (* (gfs:point-x pnt) +tile-bmp-width+) + :y (* (gfs:point-y pnt) +tile-bmp-height+))) + +(defun window->tiles (pnt) + (gfs:make-point :x (floor (/ (gfs:point-x pnt) +tile-bmp-width+)) + :y (floor (/ (gfs:point-y pnt) +tile-bmp-height+)))) + +(defclass unblocked-panel-events (gfw:event-dispatcher) + ((image-buffer + :accessor image-buffer-of + :initform (make-instance 'gfg:image :size (gfs:make-size :width (* +horz-tile-count+ + +tile-bmp-width+) + :height (* +vert-tile-count+ + +tile-bmp-height+)))) + (tile-image-table + :accessor tile-image-table-of + :initform (make-hash-table :test #'equal)))) + +(defmethod dispose ((self unblocked-panel-events)) + (let ((image (image-buffer-of self)) + (table (tile-image-table-of self))) + (gfs:dispose image) + (maphash #'(lambda (kind image) + (declare (ignore kind)) + (gfs:dispose image)) + table)) + (setf (image-buffer-of self) nil) + (setf (tile-image-table-of self) nil)) + +(defmethod gfw:event-paint ((self unblocked-panel-events) window time gc rect) + (declare (ignore window time rect)) + (gfg:draw-image gc (image-buffer-of self) (gfs:make-point))) + +(defmethod initialize-instance :after ((self unblocked-panel-events) &key) + (let ((table (tile-image-table-of self)) + (kind 1)) + (loop for filename in '("blue-tile.bmp" "brown-tile.bmp" "gold-tile.bmp" + "green-tile.bmp" "pink-tile.bmp" "red-tile.bmp") + do (let ((image (make-instance 'gfg:image))) + (gfg:load image filename) + (setf (gethash kind table) image) + (incf kind))))) + +(defmethod update-buffer ((self unblocked-panel-events) tiles) + (let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self))) + (image-table (tile-image-table-of self))) + (setf (gfg:background-color gc) gfg:*color-black*) + (setf (gfg:foreground-color gc) gfg:*color-black*) + (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location (gfs:make-point) + :size (gfg:size (image-buffer-of self)))) + (map-tiles #'(lambda (pnt kind) + (let ((image (gethash kind image-table))) + (gfg:draw-image gc image (tiles->window pnt)))) + tiles))) + +(defclass unblocked-panel (gfw:panel) ()) + +(defmethod gfs:dispose ((self unblocked-panel)) + (dispose (gfw:dispatcher self)) + (call-next-method)) + +(defmethod gfw:preferred-size ((self unblocked-panel) width-hint height-hint) + (declare (ignore width-hint height-hint)) + (gfg:size (image-buffer-of (gfw:dispatcher self)))) Added: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- (empty file) +++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Apr 2 23:24:46 2006 @@ -0,0 +1,84 @@ +;;;; +;;;; unblocked-window.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) + +(defconstant +spacing+ 4) +(defconstant +margin+ 4) + +(defvar *unblocked-win* nil) + +(defun new-unblocked (disp item time rect) + (declare (ignore disp item time rect))) + +(defun restart-unblocked (disp item time rect) + (declare (ignore disp item time rect))) + +(defun reveal-unblocked (disp item time rect) + (declare (ignore disp item time rect))) + +(defun quit-unblocked (disp item time rect) + (declare (ignore disp item time rect)) + (gfs:dispose *unblocked-win*) + (setf *unblocked-win* nil) + (gfw:shutdown 0)) + +(defclass unblocked-win-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((disp unblocked-win-events) window time) + (declare (ignore window time)) + (quit-unblocked disp nil nil nil)) + +(defun unblocked-startup () + (let ((menubar (gfw:defmenu ((:item "&File" + :submenu ((:item "&New" :callback #'new-unblocked) + (:item "&Restart" :callback #'restart-unblocked) + (:item "Reveal &Move" :callback #'reveal-unblocked) + (:item "" :separator) + (:item "E&xit" :callback #'quit-unblocked))))))) + (setf *unblocked-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'unblocked-win-events) + :layout (make-instance 'gfw:flow-layout + :spacing +spacing+ + :margin +margin+) + :style '(:workspace))) + (setf (gfw:menu-bar *unblocked-win*) menubar) + (make-instance 'scoreboard-panel :parent *unblocked-win* + :dispatcher (make-instance 'scoreboard-panel-events)) + (make-instance 'unblocked-panel :parent *unblocked-win* + :dispatcher (make-instance 'unblocked-panel-events)) + (setf (gfw:text *unblocked-win*) "Graphic-Forms UnBlocked") + (gfw:pack *unblocked-win*) + (gfw:show *unblocked-win* t))) + +(defun unblocked () + (gfw:startup "UnBlocked" #'unblocked-startup)) Added: trunk/src/tests/uitoolkit/blue-tile.bmp ============================================================================== Binary file. No diff available. Added: trunk/src/tests/uitoolkit/brown-tile.bmp ============================================================================== Binary file. No diff available. Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Sun Apr 2 23:24:46 2006 @@ -362,7 +362,7 @@ (setf *drawing-dispatcher* (make-instance 'drawing-win-events)) (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs) (setf *drawing-win* (make-instance 'gfw:top-level :dispatcher *drawing-dispatcher* - :style '(:style-workspace))) + :style '(:workspace))) (setf (gfw:menu-bar *drawing-win*) menubar) (setf (gfw:size *drawing-win*) (gfs:make-size :width 390 :height 310)) (setf (gfw:text *drawing-win*) "Drawing Tester") Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Sun Apr 2 23:24:46 2006 @@ -227,7 +227,7 @@ (exit-md (make-instance 'event-tester-exit-dispatcher)) (menubar nil)) (setf *event-tester-window* (make-instance 'gfw:top-level :dispatcher (make-instance 'event-tester-window-events) - :style '(:style-workspace))) + :style '(:workspace))) (setf menubar (gfw:defmenu ((:item "&File" :callback #'manage-file-menu :submenu ((:item "Timer" :callback #'manage-timer) (:item "" :separator) Added: trunk/src/tests/uitoolkit/gold-tile.bmp ============================================================================== Binary file. No diff available. Added: trunk/src/tests/uitoolkit/green-tile.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 Apr 2 23:24:46 2006 @@ -61,7 +61,7 @@ (defun run-hello-world-internal () (let ((menubar nil)) (setf *hello-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'hellowin-events) - :style '(:style-workspace))) + :style '(:workspace))) (setf menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-fn)))))) (setf (gfw:menu-bar *hello-win*) menubar) Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Sun Apr 2 23:24:46 2006 @@ -102,7 +102,7 @@ (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))) + :style '(:workspace))) (setf (gfw:size *image-win*) (gfs:make-size :width 250 :height 200)) (setf (gfw:text *image-win*) "Image Tester") (setf menubar (gfw:defmenu ((:item "&File" Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Apr 2 23:24:46 2006 @@ -348,7 +348,7 @@ (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:top-level :dispatcher (make-instance 'layout-tester-events) - :style '(:style-workspace) + :style '(:workspace) :layout (make-instance 'gfw:flow-layout :spacing +spacing-delta+ :margins +margin-delta+))) Added: trunk/src/tests/uitoolkit/pink-tile.bmp ============================================================================== Binary file. No diff available. Added: trunk/src/tests/uitoolkit/red-tile.bmp ============================================================================== Binary file. No diff available. Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sun Apr 2 23:24:46 2006 @@ -73,7 +73,7 @@ (declare (ignore disp item time rect)) (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-borderless-events) :owner *main-win* - :style '(:style-borderless)))) + :style '(:borderless)))) (setf (gfw:size window) (gfs:make-size :width 300 :height 250)) (gfw:center-on-owner window) (gfw:show window t))) @@ -82,7 +82,7 @@ (declare (ignore disp item time rect)) (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events) :owner *main-win* - :style '(:style-miniframe)))) + :style '(:miniframe)))) (setf (gfw:location window) (gfs:make-point :x 250 :y 150)) (setf (gfw:size window) (gfs:make-size :width 150 :height 225)) (setf (gfw:text window) "Mini Frame") @@ -92,7 +92,7 @@ (declare (ignore disp item time rect)) (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events) :owner *main-win* - :style '(:style-palette)))) + :style '(:palette)))) (setf (gfw:location window) (gfs:make-point :x 250 :y 150)) (setf (gfw:size window) (gfs:make-size :width 150 :height 225)) (setf (gfw:text window) "Palette") @@ -101,7 +101,7 @@ (defun run-windlg-internal () (let ((menubar nil)) (setf *main-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'main-win-events) - :style '(:style-workspace))) + :style '(:workspace))) (setf menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'windlg-exit-fn))) (:item "&Windows" Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Sun Apr 2 23:24:46 2006 @@ -88,8 +88,11 @@ (:documentation "This class encapsulates a realized native font.")) (defclass graphics-context (gfs:native-object) - ((owns-dc - :accessor owns-dc + ((dc-destructor + :accessor dc-destructor-of + :initform nil) + (widget-handle + :accessor widget-handle-of :initform nil) (logbrush-style :accessor logbrush-style-of Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Sun Apr 2 23:24:46 2006 @@ -179,6 +179,10 @@ (setf gfs::rightmargin 0) (cffi:with-foreign-object (rect-ptr 'gfs::rect) (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom) rect-ptr gfs::rect) + (setf gfs::left 0 + gfs::right 0 + gfs::top 0 + gfs::bottom 0) (gfs::draw-text-ex hdc str -1 rect-ptr (logior dt-flags gfs::+dt-calcrect+) dt-ptr) (setf (gfs:size-width sz) (- gfs::right gfs::left)) (setf (gfs:size-height sz) (- gfs::bottom gfs::top))))))) @@ -228,9 +232,13 @@ (setf (orig-pen-handle-of self) nil) (gfs::delete-object (pen-handle-of self)) (setf (pen-handle-of self) nil) - (if (owns-dc self) - (gfs::delete-dc (gfs:handle self))) - (setf (slot-value self 'gfs:handle) nil)) + (let ((fn (dc-destructor-of self))) + (unless (null fn) + (if (null (widget-handle-of self)) + (funcall fn (gfs:handle self)) + (funcall fn (widget-handle-of self) (gfs:handle self))))) + (setf (widget-handle-of self) nil) + (setf (slot-value self 'gfs:handle) (cffi:null-pointer))) (defmethod draw-arc ((self graphics-context) rect start-pnt end-pnt) (if (gfs:disposed-p self) @@ -471,10 +479,20 @@ (setf (logbrush-color-of self) rgb) (update-pen-for-gc self))) -(defmethod initialize-instance :after ((self graphics-context) &key) +(defmethod initialize-instance :after ((self graphics-context) &key image widget &allow-other-keys) (when (null (gfs:handle self)) - (setf (owns-dc self) t) - (setf (slot-value self 'gfs:handle) (gfs::create-compatible-dc (cffi:null-pointer)))) + (let ((hdc (cffi:null-pointer))) + (if (null widget) + (progn + (setf hdc (gfs::create-compatible-dc (cffi:null-pointer))) + (setf (dc-destructor-of self) #'gfs::delete-dc)) + (progn + (setf hdc (gfs::get-dc (gfs:handle widget))) + (setf (dc-destructor-of self) #'gfs::release-dc) + (setf (widget-handle-of self) (gfs:handle widget)))) + (setf (slot-value self 'gfs:handle) hdc) + (unless (null image) + (gfs::select-object hdc (gfs:handle image))))) ;; ensure world-to-device transformation conformance (gfs::set-graphics-mode (gfs:handle self) gfs::+gm-advanced+) (update-pen-for-gc self)) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Sun Apr 2 23:24:46 2006 @@ -81,12 +81,44 @@ (gfs:dispose im)) (setf (slot-value im 'gfs:handle) (data->image id))) +(defmethod initialize-instance :after ((image image) &key size &allow-other-keys) + (unless (null size) + (cffi:with-foreign-object (bih-ptr 'gfs::bitmapinfoheader) + (gfs::zero-mem bih-ptr gfs::bitmapinfoheader) + (cffi:with-foreign-slots ((gfs::bisize gfs::biwidth gfs::biheight gfs::biplanes + gfs::bibitcount gfs::bicompression) + bih-ptr gfs::bitmapinfoheader) + (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader) + gfs::biwidth (gfs:size-width size) + gfs::biheight (- (gfs:size-height size)) + gfs::biplanes 1 + gfs::bibitcount 32 + gfs::bicompression gfs::+bi-rgb+) + (let ((nptr (cffi:null-pointer)) + (hbmp (cffi:null-pointer))) + (cffi:with-foreign-object (buffer :pointer) + (gfs::with-compatible-dcs (nptr memdc) + (setf hbmp (gfs::create-dib-section memdc bih-ptr gfs::+dib-rgb-colors+ buffer nptr 0)))) + (setf (slot-value image 'gfs:handle) hbmp)))))) + (defmethod load ((im image) path) (let ((data (make-instance 'image-data))) (load data path) (setf (data-obj im) data) data)) +(defmethod size ((image image)) + (if (gfs:disposed-p image) + (error 'gfs:disposed-error)) + (let ((size (gfs:make-size)) + (himage (gfs:handle image))) + (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) + (setf (gfs:size-width size) gfs::width + (gfs:size-height size) gfs::height))) + size)) + (defmethod transparency-mask ((im image)) (if (gfs:disposed-p im) (error 'gfs:disposed-error)) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Sun Apr 2 23:24:46 2006 @@ -37,7 +37,7 @@ ;;; methods ;;; -(defmethod compute-style-flags ((btn button) &rest style) +(defmethod compute-style-flags ((btn button) style) (declare (ignore btn)) (let ((std-flags 0) (ex-flags 0)) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Sun Apr 2 23:24:46 2006 @@ -37,7 +37,7 @@ ;;; methods ;;; -(defmethod compute-style-flags ((label label) &rest style) +(defmethod compute-style-flags ((label label) style) (declare (ignore label)) (let ((std-flags 0) (ex-flags 0)) Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Sun Apr 2 23:24:46 2006 @@ -49,14 +49,14 @@ ;;; methods ;;; -(defmethod compute-style-flags ((self panel) &rest style) +(defmethod compute-style-flags ((self panel) 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) + ((eq sym :border) (setf std-flags (logior std-flags gfs::+ws-border+))))) (gfs:flatten style)) (values std-flags ex-flags))) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Sun Apr 2 23:24:46 2006 @@ -51,7 +51,7 @@ ;;; methods ;;; -(defmethod compute-style-flags ((win top-level) &rest style) +(defmethod compute-style-flags ((win top-level) style) (declare (ignore win)) (let ((std-flags 0) (ex-flags 0)) @@ -60,40 +60,40 @@ ;; styles that can be combined ;; #| - ((eq sym :style-hscroll) + ((eq sym :hscroll) (setf std-flags (logior std-flags gfs::+ws-hscroll+))) - ((eq sym :style-max) + ((eq sym :max) (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) - ((eq sym :style-min) + ((eq sym :min) (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) - ((eq sym :style-resize) + ((eq sym :resize) (setf std-flags (logior std-flags gfs::+ws-thickframe+))) - ((eq sym :style-sysmenu) + ((eq sym :sysmenu) (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) - ((eq sym :style-title) + ((eq sym :title) (setf std-flags (logior std-flags gfs::+ws-caption+))) - ((eq sym :style-top) + ((eq sym :top) (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+))) - ((eq sym :style-vscroll) + ((eq sym :vscroll) (setf std-flags (logior std-flags gfs::+ws-vscroll+))) |# ;; pre-packaged combinations of window styles ;; - ((eq sym :style-borderless) + ((eq sym :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) + ((eq sym :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) + ((eq sym :miniframe) (setf std-flags (logior gfs::+ws-clipchildren+ gfs::+ws-clipsiblings+ gfs::+ws-popup+ @@ -102,7 +102,7 @@ gfs::+ws-caption+)) (setf ex-flags (logior gfs::+ws-ex-appwindow+ gfs::+ws-ex-toolwindow+))) - ((eq sym :style-workspace) + ((eq sym :workspace) (setf std-flags (logior gfs::+ws-overlappedwindow+ gfs::+ws-clipsiblings+ gfs::+ws-clipchildren+)) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sun Apr 2 23:24:46 2006 @@ -105,7 +105,7 @@ (defgeneric columns (self) (:documentation "Returns the column objects displayed by the object.")) -(defgeneric compute-style-flags (self &rest style) +(defgeneric compute-style-flags (self style) (:documentation "Convert a list of keyword symbols to a pair of native bitmasks; the first conveys normal/standard flags, whereas the second any extended flags that the system supports.")) (defgeneric compute-outer-size (self desired-client-size) From junrue at common-lisp.net Mon Apr 3 05:13:51 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 3 Apr 2006 01:13:51 -0400 (EDT) Subject: [graphic-forms-cvs] r86 - in trunk: . src/demos/unblocked src/uitoolkit/graphics Message-ID: <20060403051351.9FE1D550CF@common-lisp.net> Author: junrue Date: Mon Apr 3 01:13:51 2006 New Revision: 86 Added: trunk/src/demos/unblocked/tiles-panel.lisp - copied, changed from r85, trunk/src/demos/unblocked/unblocked-panel.lisp Removed: trunk/src/demos/unblocked/unblocked-panel.lisp Modified: trunk/graphic-forms-tests.asd trunk/src/demos/unblocked/scoreboard-panel.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp Log: initial tile painting implemented; fixed a bitmap leak in draw-image Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Mon Apr 3 01:13:51 2006 @@ -64,7 +64,7 @@ ((:file "tiles") (:file "unblocked-model") (:file "scoreboard-panel") - (:file "unblocked-panel") + (:file "tiles-panel") (:file "unblocked-window"))))) (:module "tests" :components Modified: trunk/src/demos/unblocked/scoreboard-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/scoreboard-panel.lisp (original) +++ trunk/src/demos/unblocked/scoreboard-panel.lisp Mon Apr 3 01:13:51 2006 @@ -33,6 +33,10 @@ (in-package :graphic-forms.uitoolkit.tests) +(defconstant +level-label+ "Level:") +(defconstant +points-needed-label+ "Points Needed:") +(defconstant +score-label+ "Score:") + (defclass scoreboard-panel-events (gfw:event-dispatcher) ((label-font :accessor label-font-of @@ -54,6 +58,13 @@ (gfs:dispose tmp-font) (setf (label-font-of self) nil)))) +(defmethod gfw:event-paint ((self scoreboard-panel-events) window time gc rect) + (declare (ignore time rect)) + (setf (gfg:background-color gc) gfg:*color-black*) + (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location (gfs:make-point) + :size (gfw:client-size window)))) + + (defmethod initialize-instance :after ((self scoreboard-panel-events) &key) (let ((gc (make-instance 'gfg:graphics-context)) (label-font-data (gfg:make-font-data :face-name "Tahoma" @@ -69,7 +80,7 @@ (setf font (make-instance 'gfg:font :gc gc :data label-font-data) (label-font-of self) font (gfg:font gc) font - extent-size (gfg:text-extent gc "Next Level Score:") + extent-size (gfg:text-extent gc +points-needed-label+) (gfs:size-width pref-size) (gfs:size-width extent-size) (gfs:size-height pref-size) (* (gfs:size-height extent-size) 4)) (setf font (make-instance 'gfg:font :gc gc :data value-font-data) Copied: trunk/src/demos/unblocked/tiles-panel.lisp (from r85, trunk/src/demos/unblocked/unblocked-panel.lisp) ============================================================================== --- trunk/src/demos/unblocked/unblocked-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Mon Apr 3 01:13:51 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; unblocked-panel.lisp +;;;; tiles-panel.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. @@ -44,7 +44,7 @@ (gfs:make-point :x (floor (/ (gfs:point-x pnt) +tile-bmp-width+)) :y (floor (/ (gfs:point-y pnt) +tile-bmp-height+)))) -(defclass unblocked-panel-events (gfw:event-dispatcher) +(defclass tiles-panel-events (gfw:event-dispatcher) ((image-buffer :accessor image-buffer-of :initform (make-instance 'gfg:image :size (gfs:make-size :width (* +horz-tile-count+ @@ -55,7 +55,7 @@ :accessor tile-image-table-of :initform (make-hash-table :test #'equal)))) -(defmethod dispose ((self unblocked-panel-events)) +(defmethod dispose ((self tiles-panel-events)) (let ((image (image-buffer-of self)) (table (tile-image-table-of self))) (gfs:dispose image) @@ -66,11 +66,11 @@ (setf (image-buffer-of self) nil) (setf (tile-image-table-of self) nil)) -(defmethod gfw:event-paint ((self unblocked-panel-events) window time gc rect) +(defmethod gfw:event-paint ((self tiles-panel-events) window time gc rect) (declare (ignore window time rect)) (gfg:draw-image gc (image-buffer-of self) (gfs:make-point))) -(defmethod initialize-instance :after ((self unblocked-panel-events) &key) +(defmethod initialize-instance :after ((self tiles-panel-events) &key) (let ((table (tile-image-table-of self)) (kind 1)) (loop for filename in '("blue-tile.bmp" "brown-tile.bmp" "gold-tile.bmp" @@ -80,24 +80,28 @@ (setf (gethash kind table) image) (incf kind))))) -(defmethod update-buffer ((self unblocked-panel-events) tiles) +(defmethod update-buffer ((self tiles-panel-events) tiles) (let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self))) - (image-table (tile-image-table-of self))) + (image-table (tile-image-table-of self)) + (pixel-pnt (gfs:make-point))) (setf (gfg:background-color gc) gfg:*color-black*) (setf (gfg:foreground-color gc) gfg:*color-black*) (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location (gfs:make-point) :size (gfg:size (image-buffer-of self)))) (map-tiles #'(lambda (pnt kind) - (let ((image (gethash kind image-table))) - (gfg:draw-image gc image (tiles->window pnt)))) - tiles))) + (unless (= kind 0) + (let ((image (gethash kind image-table))) + (gfg:with-transparency (image pixel-pnt) + (gfg:draw-image gc image (tiles->window pnt)))))) + tiles) + (gfs:dispose gc))) -(defclass unblocked-panel (gfw:panel) ()) +(defclass tiles-panel (gfw:panel) ()) -(defmethod gfs:dispose ((self unblocked-panel)) +(defmethod gfs:dispose ((self tiles-panel)) (dispose (gfw:dispatcher self)) (call-next-method)) -(defmethod gfw:preferred-size ((self unblocked-panel) width-hint height-hint) +(defmethod gfw:preferred-size ((self tiles-panel) width-hint height-hint) (declare (ignore width-hint height-hint)) (gfg:size (image-buffer-of (gfw:dispatcher self)))) Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Mon Apr 3 01:13:51 2006 @@ -36,10 +36,17 @@ (defconstant +spacing+ 4) (defconstant +margin+ 4) +(defvar *scoreboard-panel* nil) +(defvar *tiles-panel* nil) (defvar *unblocked-win* nil) (defun new-unblocked (disp item time rect) - (declare (ignore disp item time rect))) + (declare (ignore disp item time rect)) + (let ((tiles-disp (gfw:dispatcher *tiles-panel*)) + (tiles (init-tiles +horz-tile-count+ +vert-tile-count+ 5))) + (collapse-tiles tiles) + (update-buffer tiles-disp tiles) + (gfw:redraw *tiles-panel*))) (defun restart-unblocked (disp item time rect) (declare (ignore disp item time rect))) @@ -49,6 +56,8 @@ (defun quit-unblocked (disp item time rect) (declare (ignore disp item time rect)) + (setf *scoreboard-panel* nil) + (setf *tiles-panel* nil) (gfs:dispose *unblocked-win*) (setf *unblocked-win* nil) (gfw:shutdown 0)) @@ -68,14 +77,17 @@ (:item "E&xit" :callback #'quit-unblocked))))))) (setf *unblocked-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'unblocked-win-events) :layout (make-instance 'gfw:flow-layout + :style :vertical :spacing +spacing+ - :margin +margin+) + :margins +margin+) :style '(:workspace))) (setf (gfw:menu-bar *unblocked-win*) menubar) - (make-instance 'scoreboard-panel :parent *unblocked-win* - :dispatcher (make-instance 'scoreboard-panel-events)) - (make-instance 'unblocked-panel :parent *unblocked-win* - :dispatcher (make-instance 'unblocked-panel-events)) + (setf *scoreboard-panel* (make-instance 'scoreboard-panel + :parent *unblocked-win* + :dispatcher (make-instance 'scoreboard-panel-events))) + (setf *tiles-panel* (make-instance 'tiles-panel + :parent *unblocked-win* + :dispatcher (make-instance 'tiles-panel-events))) (setf (gfw:text *unblocked-win*) "Graphic-Forms UnBlocked") (gfw:pack *unblocked-win*) (gfw:show *unblocked-win* t))) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Mon Apr 3 01:13:51 2006 @@ -333,40 +333,44 @@ (error 'gfs:disposed-error)) (let ((gc-dc (gfs:handle self)) (himage (gfs:handle im)) + (tr-mask nil) (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 (transparency-pixel-of im))) - (let ((hmask (gfs:handle (transparency-mask im))) - (hcopy (clone-bitmap himage)) - (memdc2 (gfs::create-compatible-dc (cffi:null-pointer))) - (black (make-color :red 0 :green 0 :blue 0)) - (white (make-color :red #xFF :green #xFF :blue #xFF))) - (gfs::select-object memdc hmask) - (gfs::select-object memdc2 hcopy) - (gfs::set-bk-color memdc2 (color->rgb black)) - (gfs::set-text-color memdc2 (color->rgb white)) - (gfs::bit-blt memdc2 - 0 0 - gfs::width - gfs::height - memdc - 0 0 gfs::+blt-srcand+) - (gfs::bit-blt gc-dc - (gfs:point-x pnt) - (gfs:point-y pnt) - gfs::width - gfs::height - memdc - 0 0 gfs::+blt-srcand+) - (gfs::bit-blt gc-dc - (gfs:point-x pnt) - (gfs:point-y pnt) - gfs::width - gfs::height - memdc2 - 0 0 gfs::+blt-srcpaint+)) + (progn + (setf tr-mask (transparency-mask im)) + (let ((hmask (gfs:handle tr-mask)) + (hcopy (clone-bitmap himage)) + (memdc2 (gfs::create-compatible-dc (cffi:null-pointer))) + (black (make-color :red 0 :green 0 :blue 0)) + (white (make-color :red #xFF :green #xFF :blue #xFF))) + (gfs::select-object memdc hmask) + (gfs::select-object memdc2 hcopy) + (gfs::set-bk-color memdc2 (color->rgb black)) + (gfs::set-text-color memdc2 (color->rgb white)) + (gfs::bit-blt memdc2 + 0 0 + gfs::width + gfs::height + memdc + 0 0 gfs::+blt-srcand+) + (gfs::bit-blt gc-dc + (gfs:point-x pnt) + (gfs:point-y pnt) + gfs::width + gfs::height + memdc + 0 0 gfs::+blt-srcand+) + (gfs::bit-blt gc-dc + (gfs:point-x pnt) + (gfs:point-y pnt) + gfs::width + gfs::height + memdc2 + 0 0 gfs::+blt-srcpaint+)) + (gfs:dispose tr-mask)) (progn (gfs::select-object memdc himage) (gfs::bit-blt gc-dc From junrue at common-lisp.net Mon Apr 3 06:42:39 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 3 Apr 2006 02:42:39 -0400 (EDT) Subject: [graphic-forms-cvs] r87 - trunk/src/uitoolkit/graphics Message-ID: <20060403064239.9470DA0E5@common-lisp.net> Author: junrue Date: Mon Apr 3 02:42:38 2006 New Revision: 87 Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/image.lisp Log: fixed more GDI handle leaks Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Mon Apr 3 02:42:38 2006 @@ -114,9 +114,6 @@ :initform 1) (pen-handle :accessor pen-handle-of - :initform (cffi:null-pointer)) - (orig-pen-handle - :accessor orig-pen-handle-of :initform (cffi:null-pointer))) (:documentation "This class represents the context associated with drawing primitives.")) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Mon Apr 3 02:42:38 2006 @@ -91,10 +91,8 @@ (setf (pen-handle-of gc) new-hpen) (setf old-hpen (gfs::select-object (gfs:handle gc) new-hpen)) (gfs::set-miter-limit (gfs:handle gc) (miter-limit gc) (cffi:null-pointer)) - (if (gfs:null-handle-p (orig-pen-handle-of gc)) - (setf (orig-pen-handle-of gc) old-hpen) - (unless (gfs:null-handle-p old-hpen) - (gfs::delete-object old-hpen))))))) + (unless (gfs:null-handle-p old-hpen) + (gfs::delete-object old-hpen)))))) (defun call-rect-function (fn name hdc rect) (let ((pnt (gfs:location rect)) @@ -227,9 +225,7 @@ (gfs::set-bk-color hdc rgb))) (defmethod gfs:dispose ((self graphics-context)) - (unless (gfs:null-handle-p (orig-pen-handle-of self)) - (gfs::select-object (gfs:handle self) (orig-pen-handle-of self))) - (setf (orig-pen-handle-of self) nil) + (gfs::select-object (gfs:handle self) (gfs::get-stock-object gfs::+null-pen+)) (gfs::delete-object (pen-handle-of self)) (setf (pen-handle-of self) nil) (let ((fn (dc-destructor-of self))) @@ -369,7 +365,9 @@ gfs::width gfs::height memdc2 - 0 0 gfs::+blt-srcpaint+)) + 0 0 gfs::+blt-srcpaint+) + (gfs::delete-dc memdc2) + (gfs::delete-object hcopy)) (gfs:dispose tr-mask)) (progn (gfs::select-object memdc himage) Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Mon Apr 3 02:42:38 2006 @@ -182,8 +182,10 @@ (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))))) + (setf gfs::rgbblue (scale-quantum-to-byte blue))))))) + (unless (gfs:null-handle-p screen-dc) + (gfs::release-dc (cffi:null-pointer) screen-dc)) + hbmp)))) ;;; ;;; methods Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Mon Apr 3 02:42:38 2006 @@ -48,17 +48,18 @@ (defun clone-bitmap (horig) (let ((hclone (cffi:null-pointer)) + (screen-dc (gfs::get-dc (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)) + (setf hclone (gfs::create-compatible-bitmap screen-dc 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+)))) + (unless (gfs:null-handle-p screen-dc) + (gfs::release-dc (cffi:null-pointer) screen-dc)) hclone)) ;;; @@ -88,12 +89,12 @@ (cffi:with-foreign-slots ((gfs::bisize gfs::biwidth gfs::biheight gfs::biplanes gfs::bibitcount gfs::bicompression) bih-ptr gfs::bitmapinfoheader) - (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader) - gfs::biwidth (gfs:size-width size) - gfs::biheight (- (gfs:size-height size)) - gfs::biplanes 1 - gfs::bibitcount 32 - gfs::bicompression gfs::+bi-rgb+) + (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader) + gfs::biwidth (gfs:size-width size) + gfs::biheight (- (gfs:size-height size)) + gfs::biplanes 1 + gfs::bibitcount 32 + gfs::bicompression gfs::+bi-rgb+) (let ((nptr (cffi:null-pointer)) (hbmp (cffi:null-pointer))) (cffi:with-foreign-object (buffer :pointer) @@ -125,8 +126,7 @@ (let ((pixel-pnt (transparency-pixel-of im)) (hbmp (gfs:handle im)) (hmask (cffi:null-pointer)) - (nptr (cffi:null-pointer)) - (old-bg 0)) + (nptr (cffi:null-pointer))) (unless (null pixel-pnt) (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) (gfs::get-object (gfs:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) @@ -136,9 +136,9 @@ (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 (gfs:point-x pixel-pnt) (gfs:point-y pixel-pnt)))) + (gfs::set-bk-color memdc1 (gfs::get-pixel memdc1 + (gfs:point-x pixel-pnt) + (gfs: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)))) + (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+))) + (make-instance 'image :handle hmask))))) From junrue at common-lisp.net Tue Apr 4 01:56:19 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 3 Apr 2006 21:56:19 -0400 (EDT) Subject: [graphic-forms-cvs] r88 - in trunk/src: . demos/unblocked tests/uitoolkit uitoolkit/widgets Message-ID: <20060404015619.16E012A014@common-lisp.net> Author: junrue Date: Mon Apr 3 21:56:18 2006 New Revision: 88 Modified: trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/demos/unblocked/tiles.lisp trunk/src/demos/unblocked/unblocked-model.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/packages.lisp trunk/src/tests/uitoolkit/brown-tile.bmp trunk/src/uitoolkit/widgets/event.lisp Log: additional image/graphics-context testing by virtue of implementing selected tile highlighting Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Mon Apr 3 21:56:18 2006 @@ -37,12 +37,19 @@ (defconstant +tile-bmp-height+ 24) (defun tiles->window (pnt) - (gfs:make-point :x (* (gfs:point-x pnt) +tile-bmp-width+) - :y (* (gfs:point-y pnt) +tile-bmp-height+))) + (let ((xpos (* (gfs:point-x pnt) +tile-bmp-width+)) + (ypos (* (gfs:point-y pnt) +tile-bmp-height+)) + (size (gfw:client-size (get-tiles-panel)))) + (if (or (>= xpos (gfs:size-width size)) (>= ypos (gfs:size-height size))) + nil + (gfs:make-point :x xpos :y ypos)))) (defun window->tiles (pnt) - (gfs:make-point :x (floor (/ (gfs:point-x pnt) +tile-bmp-width+)) - :y (floor (/ (gfs:point-y pnt) +tile-bmp-height+)))) + (let ((xpos (floor (/ (gfs:point-x pnt) +tile-bmp-width+))) + (ypos (- +vert-tile-count+ (1+ (floor (/ (gfs:point-y pnt) +tile-bmp-height+)))))) + (if (or (>= xpos +horz-tile-count+) (>= ypos +vert-tile-count+)) + nil + (gfs:make-point :x xpos :y ypos)))) (defclass tiles-panel-events (gfw:event-dispatcher) ((image-buffer @@ -53,7 +60,10 @@ +tile-bmp-height+)))) (tile-image-table :accessor tile-image-table-of - :initform (make-hash-table :test #'equal)))) + :initform (make-hash-table :test #'equal)) + (mouse-tile + :accessor mouse-tile-of + :initform nil))) (defmethod dispose ((self tiles-panel-events)) (let ((image (image-buffer-of self)) @@ -73,13 +83,37 @@ (defmethod initialize-instance :after ((self tiles-panel-events) &key) (let ((table (tile-image-table-of self)) (kind 1)) - (loop for filename in '("blue-tile.bmp" "brown-tile.bmp" "gold-tile.bmp" - "green-tile.bmp" "pink-tile.bmp" "red-tile.bmp") + (loop for filename in '("blue-tile.bmp" "brown-tile.bmp" "red-tile.bmp" + "green-tile.bmp" "pink-tile.bmp" "gold-tile.bmp") do (let ((image (make-instance 'gfg:image))) (gfg:load image filename) (setf (gethash kind table) image) (incf kind))))) +(defmethod gfw:event-mouse-down ((self tiles-panel-events) panel time point button) + (declare (ignore panel time)) + (let ((tile-pnt (window->tiles point))) + (if (and (eql button :left-button) (not (null tile-pnt))) + (setf (mouse-tile-of self) tile-pnt) + (setf (mouse-tile-of self) nil)))) + +(defmethod gfw:event-mouse-up ((self tiles-panel-events) panel time point button) + (declare (ignore time)) + (let ((tile-pnt (window->tiles point)) + (tiles (model-tiles))) + (if (and (eql button :left-button) (not (null tile-pnt)) (eql-point tile-pnt (mouse-tile-of self))) + (let ((results (make-hash-table :test #'equalp))) + (unless (= (obtain-tile tiles tile-pnt) 0) + (shape-tiles tiles tile-pnt results) + (when (> (hash-table-count results) 1) + (maphash #'(lambda (pnt kind) + (declare (ignore kind)) + (set-tile tiles pnt +max-tile-kinds+)) + results) + (update-buffer self tiles) + (gfw:redraw panel))))) + (setf (mouse-tile-of self) nil))) + (defmethod update-buffer ((self tiles-panel-events) tiles) (let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self))) (image-table (tile-image-table-of self)) Modified: trunk/src/demos/unblocked/tiles.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles.lisp (original) +++ trunk/src/demos/unblocked/tiles.lisp Mon Apr 3 21:56:18 2006 @@ -72,6 +72,10 @@ (let ((column (aref tiles (gfs:point-x pnt)))) (aref column (gfs:point-y pnt)))) +(defun set-tile (tiles pnt kind) + (let ((column (aref tiles (gfs:point-x pnt)))) + (setf (aref column (gfs:point-y pnt)) kind))) + (defun neighbor-point (tiles orig-pnt delta-x delta-y) (let ((size (size-tiles tiles)) (new-x (+ (gfs:point-x orig-pnt) delta-x)) Modified: trunk/src/demos/unblocked/unblocked-model.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-model.lisp (original) +++ trunk/src/demos/unblocked/unblocked-model.lisp Mon Apr 3 21:56:18 2006 @@ -35,6 +35,15 @@ (defconstant +max-tile-kinds+ 6) +(defvar *tiles* nil) + (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +horz-tile-count+ 14) (defconstant +vert-tile-count+ 9)) + +(defun init-model-tiles () + (setf *tiles* (init-tiles +horz-tile-count+ +vert-tile-count+ (1- +max-tile-kinds+))) + *tiles*) + +(defun model-tiles () + *tiles*) Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Mon Apr 3 21:56:18 2006 @@ -40,10 +40,16 @@ (defvar *tiles-panel* nil) (defvar *unblocked-win* nil) +(defun get-tiles-panel () + *tiles-panel*) + +(defun get-scoreboard-panel () + *scoreboard-panel*) + (defun new-unblocked (disp item time rect) (declare (ignore disp item time rect)) (let ((tiles-disp (gfw:dispatcher *tiles-panel*)) - (tiles (init-tiles +horz-tile-count+ +vert-tile-count+ 5))) + (tiles (init-model-tiles))) (collapse-tiles tiles) (update-buffer tiles-disp tiles) (gfw:redraw *tiles-panel*))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Apr 3 21:56:18 2006 @@ -232,12 +232,9 @@ #:window ;; constants - #:left-button ;; FIXME: should be a keyword #:maximized ;; FIXME: should be a keyword - #:middle-button ;; FIXME: should be a keyword #:minimized ;; FIXME: should be a keyword #:restored ;; FIXME: should be a keyword - #:right-button ;; FIXME: should be a keyword #:+vk-break+ #:+vk-backspace+ #:+vk-tab+ Modified: trunk/src/tests/uitoolkit/brown-tile.bmp ============================================================================== Binary files. No diff available. Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Mon Apr 3 21:56:18 2006 @@ -232,37 +232,37 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-lbuttondblclk+)) wparam lparam) (declare (ignore wparam)) - (process-mouse-message #'event-mouse-double hwnd lparam 'left-button)) + (process-mouse-message #'event-mouse-double hwnd lparam :left-button)) (defmethod process-message (hwnd (msg (eql gfs::+wm-lbuttondown+)) wparam lparam) (declare (ignore wparam)) - (process-mouse-message #'event-mouse-down hwnd lparam 'left-button)) + (process-mouse-message #'event-mouse-down hwnd lparam :left-button)) (defmethod process-message (hwnd (msg (eql gfs::+wm-lbuttonup+)) wparam lparam) (declare (ignore wparam)) - (process-mouse-message #'event-mouse-up hwnd lparam 'left-button)) + (process-mouse-message #'event-mouse-up hwnd lparam :left-button)) (defmethod process-message (hwnd (msg (eql gfs::+wm-mbuttondblclk+)) wparam lparam) (declare (ignore wparam)) - (process-mouse-message #'event-mouse-double hwnd lparam 'middle-button)) + (process-mouse-message #'event-mouse-double hwnd lparam :middle-button)) (defmethod process-message (hwnd (msg (eql gfs::+wm-mbuttondown+)) wparam lparam) (declare (ignore wparam)) - (process-mouse-message #'event-mouse-down hwnd lparam 'middle-button)) + (process-mouse-message #'event-mouse-down hwnd lparam :middle-button)) (defmethod process-message (hwnd (msg (eql gfs::+wm-mbuttonup+)) wparam lparam) (declare (ignore wparam)) - (process-mouse-message #'event-mouse-up hwnd lparam 'middle-button)) + (process-mouse-message #'event-mouse-up hwnd lparam :middle-button)) (defmethod process-message (hwnd (msg (eql gfs::+wm-mousemove+)) wparam lparam) - (let ((btn-sym 'left-button)) + (let ((btn-sym :left-button)) (cond ((= (logand wparam gfs::+mk-mbutton+) gfs::+mk-mbutton+) - (setf btn-sym 'middle-button)) + (setf btn-sym :middle-button)) ((= (logand wparam gfs::+mk-rbutton+) gfs::+mk-rbutton+) - (setf btn-sym 'right-button)) + (setf btn-sym :right-button)) (t - (setf btn-sym 'left-button))) + (setf btn-sym :left-button))) (process-mouse-message #'event-mouse-move hwnd lparam btn-sym))) (defmethod process-message (hwnd (msg (eql gfs::+wm-move+)) wparam lparam) @@ -308,15 +308,15 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-rbuttondblclk+)) wparam lparam) (declare (ignore wparam)) - (process-mouse-message #'event-mouse-double hwnd lparam 'right-button)) + (process-mouse-message #'event-mouse-double hwnd lparam :right-button)) (defmethod process-message (hwnd (msg (eql gfs::+wm-rbuttondown+)) wparam lparam) (declare (ignore wparam)) - (process-mouse-message #'event-mouse-down hwnd lparam 'right-button)) + (process-mouse-message #'event-mouse-down hwnd lparam :right-button)) (defmethod process-message (hwnd (msg (eql gfs::+wm-rbuttonup+)) wparam lparam) (declare (ignore wparam)) - (process-mouse-message #'event-mouse-up hwnd lparam 'right-button)) + (process-mouse-message #'event-mouse-up hwnd lparam :right-button)) (defmethod process-message (hwnd (msg (eql gfs::+wm-size+)) wparam lparam) (declare (ignore lparam)) From junrue at common-lisp.net Tue Apr 4 02:50:21 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 3 Apr 2006 22:50:21 -0400 (EDT) Subject: [graphic-forms-cvs] r89 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/widgets Message-ID: <20060404025021.D83F57D001@common-lisp.net> Author: junrue Date: Mon Apr 3 22:50:20 2006 New Revision: 89 Modified: trunk/docs/manual/api.texinfo trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/window.lisp Log: modified class registration to differentiate between window styles for which the system automatically paints the background vs. those that the app must paint Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Apr 3 22:50:20 2006 @@ -310,17 +310,24 @@ @item :borderless a window with a one-pixel border (so not really @emph{borderless} in the strictest sense); no frame icon, system menu, minimize/maximize buttons, -or close buttons +or close buttons; the system does not paint the background + at item :frame +the standard top-level frame style with system menu, close box, and +minimize/maximize buttons; this window type is resizable; it differs +from the @code{:workspace} style in that the application is completely +responsible for painting the contents @item :miniframe a resizable window with a shorter than normal caption; has a close box -but no system menu or minimize/maximize buttons +but no system menu or minimize/maximize buttons; the system does not +paint the background @item :palette similar to the @code{:miniframe} style, but in this case the window -does not have resize frame +does not have a resize frame; the system does not paint the background @item :workspace the standard top-level frame style with system menu, close box, and -minimize/maximize buttons; this window is resizable and normally hosts -the primary user interface for an application +minimize/maximize buttons; this window type is resizable; it differs +from the @code{:frame} style in that the system paints the background +using the @sc{color_appworkspace} color scheme @end table @end deffn @end deftp Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Mon Apr 3 22:50:20 2006 @@ -362,7 +362,7 @@ (setf *drawing-dispatcher* (make-instance 'drawing-win-events)) (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs) (setf *drawing-win* (make-instance 'gfw:top-level :dispatcher *drawing-dispatcher* - :style '(:workspace))) + :style '(:frame))) (setf (gfw:menu-bar *drawing-win*) menubar) (setf (gfw:size *drawing-win*) (gfs:make-size :width 390 :height 310)) (setf (gfw:text *drawing-win*) "Drawing Tester") Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Mon Apr 3 22:50:20 2006 @@ -61,7 +61,7 @@ (defun run-hello-world-internal () (let ((menubar nil)) (setf *hello-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'hellowin-events) - :style '(:workspace))) + :style '(:frame))) (setf menubar (gfw:defmenu ((: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 Mon Apr 3 22:50:20 2006 @@ -70,6 +70,14 @@ :initarg :id :initform 0))) +(defmethod gfw:event-paint ((self layout-tester-widget-events) window time gc rect) + (declare (ignore time rect)) + (setf (gfg:background-color gc) gfg:*color-white*) + (setf (gfg:foreground-color gc) gfg:*color-white*) + (gfg:draw-filled-rectangle gc + (make-instance 'gfs:rectangle :location (gfs:make-point) + :size (gfw:client-size window)))) + (defclass test-panel (gfw:panel) ()) (defmethod gfw:preferred-size ((win test-panel) width-hint height-hint) Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Mon Apr 3 22:50:20 2006 @@ -43,7 +43,7 @@ (register-window-class +panel-window-classname+ (cffi:get-callback 'uit_widgets_wndproc) gfs::+cs-dblclks+ - gfs::+color-btnface+)) + -1)) ;;; ;;; methods Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Mon Apr 3 22:50:20 2006 @@ -33,7 +33,8 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +toplevel-window-classname+ "GraphicFormsTopLevel") +(defconstant +toplevel-erasebkgnd-window-classname+ "GraphicFormsTopLevelEraseBkgnd") +(defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd") (defconstant +default-window-title+ "New Window") @@ -41,12 +42,18 @@ ;;; helper functions ;;; -(defun register-toplevel-window-class () - (register-window-class +toplevel-window-classname+ +(defun register-toplevel-erasebkgnd-window-class () + (register-window-class +toplevel-erasebkgnd-window-classname+ (cffi:get-callback 'uit_widgets_wndproc) gfs::+cs-dblclks+ gfs::+color-appworkspace+)) +(defun register-toplevel-noerasebkgnd-window-class () + (register-window-class +toplevel-noerasebkgnd-window-classname+ + (cffi:get-callback 'uit_widgets_wndproc) + gfs::+cs-dblclks+ + -1)) + ;;; ;;; methods ;;; @@ -102,7 +109,7 @@ gfs::+ws-caption+)) (setf ex-flags (logior gfs::+ws-ex-appwindow+ gfs::+ws-ex-toolwindow+))) - ((eq sym :workspace) + ((or (eq sym :workspace) (eq sym :frame)) (setf std-flags (logior gfs::+ws-overlappedwindow+ gfs::+ws-clipsiblings+ gfs::+ws-clipchildren+)) @@ -125,7 +132,12 @@ (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)) + (let ((classname +toplevel-noerasebkgnd-window-classname+) + (register-func #'register-toplevel-noerasebkgnd-window-class)) + (when (not (null (find :workspace style))) + (setf classname +toplevel-erasebkgnd-window-classname+) + (setf register-func #'register-toplevel-erasebkgnd-window-class)) + (init-window win classname register-func style owner title))) (defmethod menu-bar :before ((win top-level)) (if (gfs:disposed-p win) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Mon Apr 3 22:50:20 2006 @@ -124,7 +124,9 @@ gfs::+image-cursor+ 0 0 (logior gfs::+lr-defaultcolor+ gfs::+lr-shared+))) - (setf gfs::hbrush (cffi:make-pointer (1+ bkgcolor))) + (setf gfs::hbrush (if (< bkgcolor 0) + (cffi:null-pointer) + (cffi:make-pointer (1+ bkgcolor)))) (setf gfs::menuname (cffi:null-pointer)) (setf gfs::classname str-ptr) (setf gfs::smallicon (cffi:null-pointer)) From junrue at common-lisp.net Tue Apr 4 05:04:46 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 4 Apr 2006 01:04:46 -0400 (EDT) Subject: [graphic-forms-cvs] r90 - in trunk/src: . demos/unblocked tests/uitoolkit uitoolkit/graphics uitoolkit/widgets Message-ID: <20060404050446.1D2F45C122@common-lisp.net> Author: junrue Date: Tue Apr 4 01:04:44 2006 New Revision: 90 Modified: trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/packages.lisp trunk/src/tests/uitoolkit/blue-tile.bmp trunk/src/tests/uitoolkit/brown-tile.bmp trunk/src/tests/uitoolkit/gold-tile.bmp trunk/src/tests/uitoolkit/green-tile.bmp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/tests/uitoolkit/pink-tile.bmp trunk/src/tests/uitoolkit/red-tile.bmp trunk/src/uitoolkit/graphics/image.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/timer.lisp Log: fixed timer bugs; implemented collapse redraw when tile shape is selected Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Tue Apr 4 01:04:44 2006 @@ -36,17 +36,32 @@ (defconstant +tile-bmp-width+ 24) (defconstant +tile-bmp-height+ 24) +(defvar *background-color* (gfg:make-color :red 0 :green #x80 :blue #x80)) + +(defclass tiles-timer-events (gfw:event-dispatcher) + ((panel-dispatcher + :accessor panel-dispatcher + :initarg :panel-dispatcher + :initform nil))) + +(defmethod gfw:event-timer ((self tiles-timer-events) timer time) + (declare (ignore timer time)) + (let ((tiles (model-tiles))) + (collapse-tiles tiles) + (update-buffer (panel-dispatcher self) tiles) + (gfw:redraw (get-tiles-panel)))) + (defun tiles->window (pnt) - (let ((xpos (* (gfs:point-x pnt) +tile-bmp-width+)) - (ypos (* (gfs:point-y pnt) +tile-bmp-height+)) + (let ((xpos (1+ (* (gfs:point-x pnt) +tile-bmp-width+))) + (ypos (1+ (* (gfs:point-y pnt) +tile-bmp-height+))) (size (gfw:client-size (get-tiles-panel)))) (if (or (>= xpos (gfs:size-width size)) (>= ypos (gfs:size-height size))) nil (gfs:make-point :x xpos :y ypos)))) (defun window->tiles (pnt) - (let ((xpos (floor (/ (gfs:point-x pnt) +tile-bmp-width+))) - (ypos (- +vert-tile-count+ (1+ (floor (/ (gfs:point-y pnt) +tile-bmp-height+)))))) + (let ((xpos (floor (/ (1- (gfs:point-x pnt)) +tile-bmp-width+))) + (ypos (- +vert-tile-count+ (1+ (floor (/ (1- (gfs:point-y pnt)) +tile-bmp-height+)))))) (if (or (>= xpos +horz-tile-count+) (>= ypos +vert-tile-count+)) nil (gfs:make-point :x xpos :y ypos)))) @@ -54,10 +69,12 @@ (defclass tiles-panel-events (gfw:event-dispatcher) ((image-buffer :accessor image-buffer-of - :initform (make-instance 'gfg:image :size (gfs:make-size :width (* +horz-tile-count+ - +tile-bmp-width+) - :height (* +vert-tile-count+ - +tile-bmp-height+)))) + :initform (make-instance 'gfg:image :size (gfs:make-size :width (+ (* +horz-tile-count+ + +tile-bmp-width+) + 2) + :height (+ (* +vert-tile-count+ + +tile-bmp-height+) + 2)))) (tile-image-table :accessor tile-image-table-of :initform (make-hash-table :test #'equal)) @@ -111,22 +128,30 @@ (set-tile tiles pnt +max-tile-kinds+)) results) (update-buffer self tiles) - (gfw:redraw panel))))) + (gfw:redraw panel) + (maphash #'(lambda (pnt kind) + (declare (ignore kind)) + (set-tile tiles pnt 0)) + results) + (gfw:start (make-instance 'gfw:timer + :initial-delay 333 + :delay 0 + :dispatcher (make-instance 'tiles-timer-events + :panel-dispatcher self))))))) (setf (mouse-tile-of self) nil))) (defmethod update-buffer ((self tiles-panel-events) tiles) - (let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self))) - (image-table (tile-image-table-of self)) - (pixel-pnt (gfs:make-point))) - (setf (gfg:background-color gc) gfg:*color-black*) - (setf (gfg:foreground-color gc) gfg:*color-black*) + (let* ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self))) + (image-table (tile-image-table-of self)) + (image (image-buffer-of self)) + (size (gfg:size image))) + (setf (gfg:background-color gc) *background-color*) + (setf (gfg:foreground-color gc) *background-color*) (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location (gfs:make-point) - :size (gfg:size (image-buffer-of self)))) + :size size)) (map-tiles #'(lambda (pnt kind) (unless (= kind 0) - (let ((image (gethash kind image-table))) - (gfg:with-transparency (image pixel-pnt) - (gfg:draw-image gc image (tiles->window pnt)))))) + (gfg:draw-image gc (gethash kind image-table) (tiles->window pnt)))) tiles) (gfs:dispose gc))) @@ -138,4 +163,5 @@ (defmethod gfw:preferred-size ((self tiles-panel) width-hint height-hint) (declare (ignore width-hint height-hint)) - (gfg:size (image-buffer-of (gfw:dispatcher self)))) + (let ((size (gfg:size (image-buffer-of (gfw:dispatcher self))))) + (gfs:make-size :width (+ (gfs:size-width size) 2) :height (+ (gfs:size-height size) 2)))) Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Tue Apr 4 01:04:44 2006 @@ -93,6 +93,7 @@ :dispatcher (make-instance 'scoreboard-panel-events))) (setf *tiles-panel* (make-instance 'tiles-panel :parent *unblocked-win* + :style '(:border) :dispatcher (make-instance 'tiles-panel-events))) (setf (gfw:text *unblocked-win*) "Graphic-Forms UnBlocked") (gfw:pack *unblocked-win*) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Apr 4 01:04:44 2006 @@ -197,7 +197,7 @@ #:transparency #:transparency-pixel-of #:transparency-mask - #:with-transparency + #:with-image-transparency #:xor-mode-p ;; conditions Modified: trunk/src/tests/uitoolkit/blue-tile.bmp ============================================================================== Binary files. No diff available. Modified: trunk/src/tests/uitoolkit/brown-tile.bmp ============================================================================== Binary files. No diff available. Modified: trunk/src/tests/uitoolkit/gold-tile.bmp ============================================================================== Binary files. No diff available. Modified: trunk/src/tests/uitoolkit/green-tile.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 Tue Apr 4 01:04:44 2006 @@ -63,7 +63,7 @@ (gfg:draw-image gc *happy-image* pnt) (incf (gfs:point-x pnt) 36) - (gfg:with-transparency (*happy-image* pixel-pnt1) + (gfg:with-image-transparency (*happy-image* pixel-pnt1) (gfg:draw-image gc (gfg:transparency-mask *happy-image*) pnt) (incf (gfs:point-x pnt) 36) (gfg:draw-image gc *happy-image* pnt)) @@ -72,7 +72,7 @@ (incf (gfs:point-y pnt) 36) (gfg:draw-image gc *bw-image* pnt) (incf (gfs:point-x pnt) 24) - (gfg:with-transparency (*bw-image* pixel-pnt1) + (gfg:with-image-transparency (*bw-image* pixel-pnt1) (gfg:draw-image gc (gfg:transparency-mask *bw-image*) pnt) (incf (gfs:point-x pnt) 24) (gfg:draw-image gc *bw-image* pnt)) @@ -81,7 +81,7 @@ (incf (gfs:point-y pnt) 20) (gfg:draw-image gc *true-image* pnt) (incf (gfs:point-x pnt) 20) - (gfg:with-transparency (*true-image* pixel-pnt2) + (gfg:with-image-transparency (*true-image* pixel-pnt2) (gfg:draw-image gc (gfg:transparency-mask *true-image*) pnt) (incf (gfs:point-x pnt) 20) (gfg:draw-image gc *true-image* pnt)))) Modified: trunk/src/tests/uitoolkit/pink-tile.bmp ============================================================================== Binary files. No diff available. Modified: trunk/src/tests/uitoolkit/red-tile.bmp ============================================================================== Binary files. No diff available. Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Tue Apr 4 01:04:44 2006 @@ -37,7 +37,7 @@ ;;; helper macros and functions ;;; -(defmacro with-transparency ((image pnt) &body body) +(defmacro with-image-transparency ((image pnt) &body body) (let ((orig-pnt (gensym))) `(let ((,orig-pnt (transparency-pixel-of ,image))) (unwind-protect Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Apr 4 01:04:44 2006 @@ -347,9 +347,10 @@ (if (null timer) (gfs::kill-timer (cffi:null-pointer) wparam) (progn - (event-timer (dispatcher timer) timer (event-time tc)) - (when (<= (delay-of timer) 0) - (stop timer))))) + (if (<= (delay-of timer) 0) + (stop timer) + (reset-timer-to-delay timer (delay-of timer))) + (event-timer (dispatcher timer) timer (event-time tc))))) 0) ;;; Modified: trunk/src/uitoolkit/widgets/timer.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/timer.lisp (original) +++ trunk/src/uitoolkit/widgets/timer.lisp Tue Apr 4 01:04:44 2006 @@ -58,6 +58,14 @@ (defun gf-set-timer (delay) (gfs::set-timer nil 0 delay #'timer_proc)) +(defun reset-timer-to-delay (timer delay) + (remove-timer (thread-context) timer) + (let ((id (gf-set-timer delay))) + (if (zerop id) + (error 'gfs:win32-error :detail "set-timer failed")) + (setf (slot-value timer 'id) id) + (put-timer (thread-context) timer))) + (defun clamp-delay-values (init-delay delay) "Adjust delay settings based on system-defined limits." ;; @@ -105,15 +113,10 @@ ;; tick; the interval will be adjusted (or the timer killed) ;; as part of processing the first event ;; - (let ((init-delay (initial-delay-of self)) - (delay (delay-of self))) + (let ((init-delay (initial-delay-of self))) (if (> init-delay 0) - (setf delay init-delay)) - (let ((id (gf-set-timer delay))) - (if (zerop id) - (error 'gfs:win32-error :detail "set-timer failed")) - (setf (slot-value self 'id) id) - (put-timer (thread-context) self)))) + (reset-timer-to-delay self init-delay) + (reset-timer-to-delay self (delay-of self))))) (defmethod stop ((self timer)) (remove-timer (thread-context) self)) ;; kill-timer will be called on the next tick From junrue at common-lisp.net Fri Apr 7 05:00:42 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Fri, 7 Apr 2006 01:00:42 -0400 (EDT) Subject: [graphic-forms-cvs] r91 - in trunk: . src/demos/unblocked src/uitoolkit/system Message-ID: <20060407050042.A2C722F008@common-lisp.net> Author: junrue Date: Fri Apr 7 01:00:41 2006 New Revision: 91 Added: trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp Modified: trunk/graphic-forms-tests.asd trunk/src/demos/unblocked/scoreboard-panel.lisp trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/demos/unblocked/unblocked-model.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-types.lisp Log: implemented scoreboard panel display; implemented double-buffering base event dispatcher and refactored tiles-panel-events accordingly Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Fri Apr 7 01:00:41 2006 @@ -63,6 +63,7 @@ :components ((:file "tiles") (:file "unblocked-model") + (:file "double-buffered-event-dispatcher") (:file "scoreboard-panel") (:file "tiles-panel") (:file "unblocked-window"))))) Added: trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp ============================================================================== --- (empty file) +++ trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp Fri Apr 7 01:00:41 2006 @@ -0,0 +1,66 @@ +;;;; +;;;; double-buffered-event-dispatcher.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 *background-color* (gfg:make-color :red 0 :green #x80 :blue #x80)) + +(defgeneric update-buffer (disp tiles) + (:documentation "Revises the image buffer so that the associated window can be repainted.") + (:method (disp tiles) + (declare (ignorable disp tiles)))) + +(defclass double-buffered-event-dispatcher (gfw:event-dispatcher) + ((image-buffer + :accessor image-buffer-of + :initform nil))) + +(defmethod clear-buffer ((self double-buffered-event-dispatcher) gc) + (let ((image (image-buffer-of self))) + (setf (gfg:background-color gc) *background-color*) + (setf (gfg:foreground-color gc) *background-color*) + (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location (gfs:make-point) + :size (gfg:size image))))) + +(defmethod dispose ((self double-buffered-event-dispatcher)) + (let ((image (image-buffer-of self))) + (unless (or (null image) (gfs:disposed-p image)) + (gfs:dispose image)) + (setf (image-buffer-of self) nil))) + +(defmethod initialize-instance :after ((self double-buffered-event-dispatcher) &key buffer-size) + (setf (image-buffer-of self) (make-instance 'gfg:image :size buffer-size))) + +(defmethod gfw:event-paint ((self double-buffered-event-dispatcher) window time gc rect) + (declare (ignore window time rect)) + (gfg:draw-image gc (image-buffer-of self) (gfs:make-point))) Modified: trunk/src/demos/unblocked/scoreboard-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/scoreboard-panel.lisp (original) +++ trunk/src/demos/unblocked/scoreboard-panel.lisp Fri Apr 7 01:00:41 2006 @@ -33,20 +33,27 @@ (in-package :graphic-forms.uitoolkit.tests) -(defconstant +level-label+ "Level:") -(defconstant +points-needed-label+ "Points Needed:") -(defconstant +score-label+ "Score:") +(defconstant +level-label+ "Level:") +(defconstant +points-needed-label+ "Points Needed:") +(defconstant +score-label+ "Score:") -(defclass scoreboard-panel-events (gfw:event-dispatcher) +(defconstant +scoreboard-text-margin+ 2) + +(defvar *text-color* (gfg:make-color :red 237 :green 232 :blue 14)) + +(defvar *scoreboard-label-font-data* (gfg:make-font-data :face-name "Tahoma" + :point-size 14 + :style '(:bold))) +(defvar *scoreboard-value-font-data* (gfg:make-font-data :face-name "Tahoma" + :point-size 14)) + +(defclass scoreboard-panel-events (double-buffered-event-dispatcher) ((label-font :accessor label-font-of :initform nil) (value-font :accessor value-font-of - :initform nil) - (size - :accessor size-of - :initform (gfs:make-size)))) + :initform nil))) (defmethod dispose ((self scoreboard-panel-events)) (let ((tmp-font (label-font-of self))) @@ -56,43 +63,62 @@ (setf tmp-font (value-font-of self)) (unless (null tmp-font) (gfs:dispose tmp-font) - (setf (label-font-of self) nil)))) + (setf (label-font-of self) nil))) + (call-next-method)) + +(defun compute-scoreboard-size () + (let* ((gc (make-instance 'gfg:graphics-context)) + (font (make-instance 'gfg:font :gc gc :data *scoreboard-label-font-data*)) + (metrics (gfg:metrics gc font)) + (buffer-size (gfs:make-size))) + (unwind-protect + (progn + (setf (gfs:size-width buffer-size) (* (+ (length +points-needed-label+) + 2 ; space between label and value + 9) ; number of value characters + (gfg:average-char-width metrics))) + (setf (gfs:size-height buffer-size) (* (gfg:height metrics) 4))) + + (gfs:dispose font) + (gfs:dispose gc)) + buffer-size)) + +(defmethod initialize-instance :after ((self scoreboard-panel-events) &key buffer-size) + (declare (ignorable buffer-size)) + (let ((gc (make-instance 'gfg:graphics-context))) + (unwind-protect + (progn + (setf (label-font-of self) (make-instance 'gfg:font :gc gc :data *scoreboard-label-font-data*)) + (setf (value-font-of self) (make-instance 'gfg:font :gc gc :data *scoreboard-value-font-data*))) + (gfs:dispose gc)))) -(defmethod gfw:event-paint ((self scoreboard-panel-events) window time gc rect) - (declare (ignore time rect)) - (setf (gfg:background-color gc) gfg:*color-black*) - (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location (gfs:make-point) - :size (gfw:client-size window)))) - - -(defmethod initialize-instance :after ((self scoreboard-panel-events) &key) - (let ((gc (make-instance 'gfg:graphics-context)) - (label-font-data (gfg:make-font-data :face-name "Tahoma" - :point-size 14 - :style '(:bold))) - (value-font-data (gfg:make-font-data :face-name "Tahoma" - :point-size 14)) - (extent-size nil) - (pref-size (gfs:make-size)) - (font nil)) +(defmethod draw-scoreboard-row (gc row image-size label-font label-text value-font value-text) + (let* ((metrics (gfg:metrics gc label-font)) + (text-pnt (gfs:make-point :x +scoreboard-text-margin+ :y (* row (gfg:height metrics))))) + (setf (gfg:font gc) label-font) + (setf (gfg:foreground-color gc) *text-color*) + (gfg:draw-text gc label-text text-pnt) + (setf (gfg:font gc) value-font) + (setf (gfs:point-x text-pnt) (- (- (gfs:size-width image-size) +scoreboard-text-margin+) + (gfs:size-width (gfg:text-extent gc value-text)))) + (gfg:draw-text gc value-text text-pnt))) + +(defmethod update-buffer ((self scoreboard-panel-events) tiles) + (let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self))) + (label-font (label-font-of self)) + (value-font (value-font-of self)) + (image-size (gfg:size (image-buffer-of self)))) (unwind-protect (progn - (setf font (make-instance 'gfg:font :gc gc :data label-font-data) - (label-font-of self) font - (gfg:font gc) font - extent-size (gfg:text-extent gc +points-needed-label+) - (gfs:size-width pref-size) (gfs:size-width extent-size) - (gfs:size-height pref-size) (* (gfs:size-height extent-size) 4)) - (setf font (make-instance 'gfg:font :gc gc :data value-font-data) - (value-font-of self) font - (gfg:font gc) font - extent-size (gfg:text-extent gc (format nil "~c9,999,999" #\Tab))) - (incf (gfs:size-width pref-size) (gfs:size-width extent-size)) - (setf (size-of self) pref-size)) + (clear-buffer self gc) + (draw-scoreboard-row gc 0 image-size label-font +level-label+ value-font (model-level)) + (draw-scoreboard-row gc 1 image-size label-font +score-label+ value-font (model-score)) + (draw-scoreboard-row gc 2 image-size label-font +points-needed-label+ value-font (model-points-needed))) (gfs:dispose gc)))) (defclass scoreboard-panel (gfw:panel) ()) (defmethod gfw:preferred-size ((self scoreboard-panel) width-hint height-hint) (declare (ignore width-hint height-hint)) - (size-of (gfw:dispatcher self))) + (let ((size (gfg:size (image-buffer-of (gfw:dispatcher self))))) + (gfs:make-size :width (+ (gfs:size-width size) 2) :height (+ (gfs:size-height size) 2)))) Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Fri Apr 7 01:00:41 2006 @@ -33,23 +33,9 @@ (in-package :graphic-forms.uitoolkit.tests) -(defconstant +tile-bmp-width+ 24) -(defconstant +tile-bmp-height+ 24) - -(defvar *background-color* (gfg:make-color :red 0 :green #x80 :blue #x80)) - -(defclass tiles-timer-events (gfw:event-dispatcher) - ((panel-dispatcher - :accessor panel-dispatcher - :initarg :panel-dispatcher - :initform nil))) - -(defmethod gfw:event-timer ((self tiles-timer-events) timer time) - (declare (ignore timer time)) - (let ((tiles (model-tiles))) - (collapse-tiles tiles) - (update-buffer (panel-dispatcher self) tiles) - (gfw:redraw (get-tiles-panel)))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +tile-bmp-width+ 24) + (defconstant +tile-bmp-height+ 24)) (defun tiles->window (pnt) (let ((xpos (1+ (* (gfs:point-x pnt) +tile-bmp-width+))) @@ -66,16 +52,21 @@ nil (gfs:make-point :x xpos :y ypos)))) -(defclass tiles-panel-events (gfw:event-dispatcher) - ((image-buffer - :accessor image-buffer-of - :initform (make-instance 'gfg:image :size (gfs:make-size :width (+ (* +horz-tile-count+ - +tile-bmp-width+) - 2) - :height (+ (* +vert-tile-count+ - +tile-bmp-height+) - 2)))) - (tile-image-table +(defclass tiles-timer-events (gfw:event-dispatcher) + ((panel-dispatcher + :accessor panel-dispatcher + :initarg :panel-dispatcher + :initform nil))) + +(defmethod gfw:event-timer ((self tiles-timer-events) timer time) + (declare (ignore timer time)) + (let ((tiles (model-tiles))) + (collapse-tiles tiles) + (update-buffer (panel-dispatcher self) tiles) + (gfw:redraw (get-tiles-panel)))) + +(defclass tiles-panel-events (double-buffered-event-dispatcher) + ((tile-image-table :accessor tile-image-table-of :initform (make-hash-table :test #'equal)) (mouse-tile @@ -83,21 +74,16 @@ :initform nil))) (defmethod dispose ((self tiles-panel-events)) - (let ((image (image-buffer-of self)) - (table (tile-image-table-of self))) - (gfs:dispose image) + (let ((table (tile-image-table-of self))) (maphash #'(lambda (kind image) (declare (ignore kind)) (gfs:dispose image)) table)) - (setf (image-buffer-of self) nil) - (setf (tile-image-table-of self) nil)) - -(defmethod gfw:event-paint ((self tiles-panel-events) window time gc rect) - (declare (ignore window time rect)) - (gfg:draw-image gc (image-buffer-of self) (gfs:make-point))) + (setf (tile-image-table-of self) nil) + (call-next-method)) -(defmethod initialize-instance :after ((self tiles-panel-events) &key) +(defmethod initialize-instance :after ((self tiles-panel-events) &key buffer-size) + (declare (ignorable buffer-size)) (let ((table (tile-image-table-of self)) (kind 1)) (loop for filename in '("blue-tile.bmp" "brown-tile.bmp" "red-tile.bmp" @@ -141,19 +127,15 @@ (setf (mouse-tile-of self) nil))) (defmethod update-buffer ((self tiles-panel-events) tiles) - (let* ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self))) - (image-table (tile-image-table-of self)) - (image (image-buffer-of self)) - (size (gfg:size image))) - (setf (gfg:background-color gc) *background-color*) - (setf (gfg:foreground-color gc) *background-color*) - (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location (gfs:make-point) - :size size)) - (map-tiles #'(lambda (pnt kind) - (unless (= kind 0) - (gfg:draw-image gc (gethash kind image-table) (tiles->window pnt)))) - tiles) - (gfs:dispose gc))) + (let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self))) + (image-table (tile-image-table-of self))) + (clear-buffer self gc) + (unwind-protect + (map-tiles #'(lambda (pnt kind) + (unless (= kind 0) + (gfg:draw-image gc (gethash kind image-table) (tiles->window pnt)))) + tiles) + (gfs:dispose gc)))) (defclass tiles-panel (gfw:panel) ()) Modified: trunk/src/demos/unblocked/unblocked-model.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-model.lisp (original) +++ trunk/src/demos/unblocked/unblocked-model.lisp Fri Apr 7 01:00:41 2006 @@ -33,13 +33,13 @@ (in-package :graphic-forms.uitoolkit.tests) -(defconstant +max-tile-kinds+ 6) (defvar *tiles* nil) (eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +horz-tile-count+ 14) - (defconstant +vert-tile-count+ 9)) + (defconstant +max-tile-kinds+ 6) + (defconstant +horz-tile-count+ 16) + (defconstant +vert-tile-count+ 12)) (defun init-model-tiles () (setf *tiles* (init-tiles +horz-tile-count+ +vert-tile-count+ (1- +max-tile-kinds+))) @@ -47,3 +47,12 @@ (defun model-tiles () *tiles*) + +(defun model-level () + (format nil "~:d" 134)) + +(defun model-points-needed () + (format nil "~:d" 30964)) + +(defun model-score () + (format nil "~:d" 1548238)) Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Fri Apr 7 01:00:41 2006 @@ -49,9 +49,12 @@ (defun new-unblocked (disp item time rect) (declare (ignore disp item time rect)) (let ((tiles-disp (gfw:dispatcher *tiles-panel*)) + (scoreboard-disp (gfw:dispatcher *scoreboard-panel*)) (tiles (init-model-tiles))) + (update-buffer scoreboard-disp tiles) (collapse-tiles tiles) (update-buffer tiles-disp tiles) + (gfw:redraw *scoreboard-panel*) (gfw:redraw *tiles-panel*))) (defun restart-unblocked (disp item time rect) @@ -80,7 +83,12 @@ (:item "&Restart" :callback #'restart-unblocked) (:item "Reveal &Move" :callback #'reveal-unblocked) (:item "" :separator) - (:item "E&xit" :callback #'quit-unblocked))))))) + (:item "E&xit" :callback #'quit-unblocked)))))) + (scoreboard-buffer-size (compute-scoreboard-size)) + (tile-buffer-size (gfs:make-size :width (+ (* +horz-tile-count+ +tile-bmp-width+) + 2) + :height (+ (* +vert-tile-count+ +tile-bmp-height+) + 2)))) (setf *unblocked-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'unblocked-win-events) :layout (make-instance 'gfw:flow-layout :style :vertical @@ -90,11 +98,14 @@ (setf (gfw:menu-bar *unblocked-win*) menubar) (setf *scoreboard-panel* (make-instance 'scoreboard-panel :parent *unblocked-win* - :dispatcher (make-instance 'scoreboard-panel-events))) + :style '(:border) + :dispatcher (make-instance 'scoreboard-panel-events + :buffer-size scoreboard-buffer-size))) (setf *tiles-panel* (make-instance 'tiles-panel :parent *unblocked-win* :style '(:border) - :dispatcher (make-instance 'tiles-panel-events))) + :dispatcher (make-instance 'tiles-panel-events + :buffer-size tile-buffer-size))) (setf (gfw:text *unblocked-win*) "Graphic-Forms UnBlocked") (gfw:pack *unblocked-win*) (gfw:show *unblocked-win* t))) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Fri Apr 7 01:00:41 2006 @@ -243,6 +243,14 @@ (hdc HANDLE)) (defcfun + ("GetTextExtentPoint32A" get-text-extent-point) + BOOL + (hdc HANDLE) + (str :string) + (count INT) + (size LPTR)) + +(defcfun ("GetTextMetricsA" get-text-metrics) BOOL (hdc HANDLE) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Fri Apr 7 01:00:41 2006 @@ -207,6 +207,10 @@ (rgbred BYTE) (rgbreserved BYTE)) +(defcstruct size + (cx LONG) + (cy LONG)) + (defcstruct textmetrics (tmheight LONG) (tmascent LONG) From junrue at common-lisp.net Fri Apr 7 06:12:07 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Fri, 7 Apr 2006 02:12:07 -0400 (EDT) Subject: [graphic-forms-cvs] r92 - trunk/src/demos/unblocked Message-ID: <20060407061207.AA27E7D001@common-lisp.net> Author: junrue Date: Fri Apr 7 02:12:06 2006 New Revision: 92 Modified: trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/demos/unblocked/tiles.lisp Log: slightly faster drawing of selected shapes Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Fri Apr 7 02:12:06 2006 @@ -39,7 +39,7 @@ (defun tiles->window (pnt) (let ((xpos (1+ (* (gfs:point-x pnt) +tile-bmp-width+))) - (ypos (1+ (* (gfs:point-y pnt) +tile-bmp-height+))) + (ypos (1+ (* (- (1- +vert-tile-count+) (gfs:point-y pnt)) +tile-bmp-height+))) (size (gfw:client-size (get-tiles-panel)))) (if (or (>= xpos (gfs:size-width size)) (>= ypos (gfs:size-height size))) nil @@ -109,18 +109,19 @@ (unless (= (obtain-tile tiles tile-pnt) 0) (shape-tiles tiles tile-pnt results) (when (> (hash-table-count results) 1) - (maphash #'(lambda (pnt kind) - (declare (ignore kind)) - (set-tile tiles pnt +max-tile-kinds+)) - results) - (update-buffer self tiles) - (gfw:redraw panel) - (maphash #'(lambda (pnt kind) - (declare (ignore kind)) - (set-tile tiles pnt 0)) - results) + (let ((gc (make-instance 'gfg:graphics-context :widget panel)) + (image-table (tile-image-table-of self))) + (unwind-protect + (maphash #'(lambda (pnt kind) + (declare (ignore kind)) + (set-tile tiles pnt 0) + (gfg:draw-image gc + (gethash +max-tile-kinds+ image-table) + (tiles->window pnt))) + results) + (gfs:dispose gc))) (gfw:start (make-instance 'gfw:timer - :initial-delay 333 + :initial-delay 100 :delay 0 :dispatcher (make-instance 'tiles-timer-events :panel-dispatcher self))))))) Modified: trunk/src/demos/unblocked/tiles.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles.lisp (original) +++ trunk/src/demos/unblocked/tiles.lisp Fri Apr 7 02:12:06 2006 @@ -51,14 +51,14 @@ (let ((size (size-tiles tiles))) (dotimes (j (gfs:size-height size)) (dotimes (i (gfs:size-width size)) - (let ((kind (aref (aref tiles i) (- (1- (gfs:size-height size)) j)))) + (let ((kind (aref (aref tiles i) j))) (funcall func (gfs:make-point :x i :y j) kind)))))) (defun print-tiles (tiles) (let ((size (size-tiles tiles))) (dotimes (j (gfs:size-height size)) (dotimes (i (gfs:size-width size)) - (let ((kind (aref (aref tiles i) (- (1- (gfs:size-height size)) j)))) + (let ((kind (aref (aref tiles i) j))) (if (< kind 0) (print " ") (format t "~d " kind)))) @@ -105,8 +105,9 @@ (defun collapse-column (column-tiles) (let ((new-column (make-array (length column-tiles) :initial-element 0)) - (new-index 0)) - (dotimes (i (length column-tiles)) + (new-index 0) + (count (length column-tiles))) + (dotimes (i count) (let ((kind (aref column-tiles i))) (unless (zerop kind) (setf (aref new-column new-index) kind) From junrue at common-lisp.net Sat Apr 8 05:34:23 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sat, 8 Apr 2006 01:34:23 -0400 (EDT) Subject: [graphic-forms-cvs] r93 - in trunk/src: demos/unblocked uitoolkit/graphics uitoolkit/widgets Message-ID: <20060408053423.7F46115001@common-lisp.net> Author: junrue Date: Sat Apr 8 01:34:22 2006 New Revision: 93 Modified: trunk/src/demos/unblocked/scoreboard-panel.lisp trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/demos/unblocked/tiles.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/widgets/menu-language.lisp trunk/src/uitoolkit/widgets/top-level.lisp Log: even better selection behavior in the unblocked demo Modified: trunk/src/demos/unblocked/scoreboard-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/scoreboard-panel.lisp (original) +++ trunk/src/demos/unblocked/scoreboard-panel.lisp Sat Apr 8 01:34:22 2006 @@ -104,6 +104,7 @@ (gfg:draw-text gc value-text text-pnt))) (defmethod update-buffer ((self scoreboard-panel-events) tiles) + (declare (ignore tiles)) (let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self))) (label-font (label-font-of self)) (value-font (value-font-of self)) Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Sat Apr 8 01:34:22 2006 @@ -52,27 +52,26 @@ nil (gfs:make-point :x xpos :y ypos)))) -(defclass tiles-timer-events (gfw:event-dispatcher) - ((panel-dispatcher - :accessor panel-dispatcher - :initarg :panel-dispatcher - :initform nil))) - -(defmethod gfw:event-timer ((self tiles-timer-events) timer time) - (declare (ignore timer time)) - (let ((tiles (model-tiles))) - (collapse-tiles tiles) - (update-buffer (panel-dispatcher self) tiles) - (gfw:redraw (get-tiles-panel)))) - (defclass tiles-panel-events (double-buffered-event-dispatcher) ((tile-image-table :accessor tile-image-table-of :initform (make-hash-table :test #'equal)) - (mouse-tile - :accessor mouse-tile-of + (shape-kind + :accessor shape-kind-of + :initform 0) + (shape-pnts + :accessor shape-pnts-of :initform nil))) +(defun draw-tiles-directly (panel shape-pnts kind) + (let ((gc (make-instance 'gfg:graphics-context :widget panel)) + (image-table (tile-image-table-of (gfw:dispatcher panel)))) + (unwind-protect + (loop for pnt in shape-pnts + do (let ((image (gethash kind image-table))) + (gfg:draw-image gc image (tiles->window pnt)))) + (gfs:dispose gc)))) + (defmethod dispose ((self tiles-panel-events)) (let ((table (tile-image-table-of self))) (maphash #'(lambda (kind image) @@ -80,6 +79,7 @@ (gfs:dispose image)) table)) (setf (tile-image-table-of self) nil) + (setf (shape-pnts-of self) nil) (call-next-method)) (defmethod initialize-instance :after ((self tiles-panel-events) &key buffer-size) @@ -94,38 +94,45 @@ (incf kind))))) (defmethod gfw:event-mouse-down ((self tiles-panel-events) panel time point button) - (declare (ignore panel time)) - (let ((tile-pnt (window->tiles point))) - (if (and (eql button :left-button) (not (null tile-pnt))) - (setf (mouse-tile-of self) tile-pnt) - (setf (mouse-tile-of self) nil)))) + (declare (ignore time)) + (let* ((tiles (model-tiles)) + (tile-pnt (window->tiles point)) + (tile-kind (obtain-tile tiles tile-pnt)) + (shape-pnts (shape-pnts-of self)) + (tmp-table (make-hash-table :test #'equalp))) + (unless (or (null shape-pnts) (find tile-pnt shape-pnts :test #'eql-point)) + (draw-tiles-directly panel shape-pnts (shape-kind-of self)) + (setf (shape-pnts-of self) nil) + (setf (shape-kind-of self) 0)) + (setf shape-pnts nil) + (if (and (eql button :left-button) (> tile-kind 0)) + (shape-tiles tiles tile-pnt tmp-table)) + (when (> (hash-table-count tmp-table) 1) + (maphash #'(lambda (pnt kind) + (declare (ignore kind)) + (push pnt shape-pnts)) + tmp-table) + (setf (shape-kind-of self) tile-kind) + (setf (shape-pnts-of self) shape-pnts) + (draw-tiles-directly panel shape-pnts +max-tile-kinds+)))) (defmethod gfw:event-mouse-up ((self tiles-panel-events) panel time point button) (declare (ignore time)) - (let ((tile-pnt (window->tiles point)) - (tiles (model-tiles))) - (if (and (eql button :left-button) (not (null tile-pnt)) (eql-point tile-pnt (mouse-tile-of self))) - (let ((results (make-hash-table :test #'equalp))) - (unless (= (obtain-tile tiles tile-pnt) 0) - (shape-tiles tiles tile-pnt results) - (when (> (hash-table-count results) 1) - (let ((gc (make-instance 'gfg:graphics-context :widget panel)) - (image-table (tile-image-table-of self))) - (unwind-protect - (maphash #'(lambda (pnt kind) - (declare (ignore kind)) - (set-tile tiles pnt 0) - (gfg:draw-image gc - (gethash +max-tile-kinds+ image-table) - (tiles->window pnt))) - results) - (gfs:dispose gc))) - (gfw:start (make-instance 'gfw:timer - :initial-delay 100 - :delay 0 - :dispatcher (make-instance 'tiles-timer-events - :panel-dispatcher self))))))) - (setf (mouse-tile-of self) nil))) + (let* ((tiles (model-tiles)) + (tile-pnt (window->tiles point)) + (shape-pnts (shape-pnts-of self))) + (if (and (eql button :left-button) + shape-pnts + (find tile-pnt shape-pnts :test #'eql-point)) + (progn + (loop for pnt in shape-pnts do (set-tile tiles pnt 0)) + (collapse-tiles tiles) + (update-buffer (gfw:dispatcher panel) tiles) + (gfw:redraw panel)) + (if shape-pnts + (draw-tiles-directly panel shape-pnts (shape-kind-of self))))) + (setf (shape-kind-of self) 0) + (setf (shape-pnts-of self) nil)) (defmethod update-buffer ((self tiles-panel-events) tiles) (let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self))) Modified: trunk/src/demos/unblocked/tiles.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles.lisp (original) +++ trunk/src/demos/unblocked/tiles.lisp Sat Apr 8 01:34:22 2006 @@ -69,6 +69,8 @@ (= (gfs:point-y pnt1) (gfs:point-y pnt2)))) (defun obtain-tile (tiles pnt) + (if (null pnt) + (return-from obtain-tile 0)) (let ((column (aref tiles (gfs:point-x pnt)))) (aref column (gfs:point-y pnt)))) @@ -92,7 +94,7 @@ (neighbor-point tiles orig-pnt 0 1) (neighbor-point tiles orig-pnt -1 0) (neighbor-point tiles orig-pnt 1 0)) - when (not (null pnt)) + when pnt collect pnt)) (defun shape-tiles (tiles tile-pnt results) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Sat Apr 8 01:34:22 2006 @@ -334,7 +334,7 @@ (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 (transparency-pixel-of im))) + (if (transparency-pixel-of im) (progn (setf tr-mask (transparency-mask im)) (let ((hmask (gfs:handle tr-mask)) Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Sat Apr 8 01:34:22 2006 @@ -211,7 +211,7 @@ (t (error 'gfs:toolkit-error :detail "pathname or string required")))) (let ((handle (gfs:handle data))) - (when (and (not (null handle)) (not (cffi:null-pointer-p handle))) + (when (and handle (not (cffi:null-pointer-p handle))) (destroy-image handle) (setf (slot-value data 'gfs:handle) nil) (setf handle nil)) Modified: trunk/src/uitoolkit/widgets/menu-language.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-language.lisp Sat Apr 8 01:34:22 2006 @@ -102,18 +102,18 @@ (sub-tmp nil)) (loop for opt in form do (cond - ((not (null cb-tmp)) + (cb-tmp (setf callback opt) (setf cb-tmp nil) (setf disp nil)) - ((not (null disp-tmp)) + (disp-tmp (setf disp opt) (setf disp-tmp nil) (setf callback nil)) - ((not (null image-tmp)) + (image-tmp (setf image opt) (setf image-tmp nil)) - ((not (null sub-tmp)) + (sub-tmp (setf sub opt) (setf sub-tmp nil)) ((and (not (eq opt :item)) (null label)) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Sat Apr 8 01:34:22 2006 @@ -134,7 +134,7 @@ (setf style (list style))) (let ((classname +toplevel-noerasebkgnd-window-classname+) (register-func #'register-toplevel-noerasebkgnd-window-class)) - (when (not (null (find :workspace style))) + (when (find :workspace style) (setf classname +toplevel-erasebkgnd-window-classname+) (setf register-func #'register-toplevel-erasebkgnd-window-class)) (init-window win classname register-func style owner title))) From junrue at common-lisp.net Sun Apr 9 18:02:37 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 9 Apr 2006 14:02:37 -0400 (EDT) Subject: [graphic-forms-cvs] r94 - in trunk: . src/demos/unblocked Message-ID: <20060409180237.E47C916001@common-lisp.net> Author: junrue Date: Sun Apr 9 14:02:36 2006 New Revision: 94 Modified: trunk/build.lisp trunk/config.lisp trunk/graphic-forms-tests.asd trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp trunk/src/demos/unblocked/scoreboard-panel.lisp trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/demos/unblocked/tiles.lisp trunk/src/demos/unblocked/unblocked-model.lisp trunk/src/demos/unblocked/unblocked-window.lisp Log: now using Cells experimentally as the data model for the unblocked demo Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Sun Apr 9 14:02:36 2006 @@ -44,6 +44,7 @@ (defvar *asdf-repo-root* (concatenate 'string *library-root* "asdf-repo/")) (defvar *project-root* "c:/projects/public/") +(setf *cells-dir* (concatenate 'string *asdf-repo-root* "cells/")) (setf *cffi-dir* (concatenate 'string *asdf-repo-root* "cffi-0.9.0/")) (setf *closer-mop-dir* (concatenate 'string *asdf-repo-root* "closer-mop/")) (setf *imagemagick-dir* "c:/Program Files/ImageMagick-6.2.6-Q16/") Modified: trunk/config.lisp ============================================================================== --- trunk/config.lisp (original) +++ trunk/config.lisp Sun Apr 9 14:02:36 2006 @@ -37,6 +37,7 @@ (in-package #:graphic-forms-system) +(defvar *cells-dir* "cells/") (defvar *cffi-dir* "cffi-0.9.0/") (defvar *closer-mop-dir* "closer-mop/") (defvar *imagemagick-dir* "c:/Program Files/ImageMagick-6.2.6-Q16/") @@ -51,6 +52,7 @@ `(ext:cd ,path)) (defun configure-asdf () + (pushnew *cells-dir* asdf:*central-registry* :test #'equal) (pushnew *cffi-dir* asdf:*central-registry* :test #'equal) (pushnew *closer-mop-dir* asdf:*central-registry* :test #'equal) (pushnew *lw-compat-dir* asdf:*central-registry* :test #'equal)) Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Apr 9 14:02:36 2006 @@ -54,6 +54,7 @@ :version "0.2.0" :author "Jack D. Unrue" :licence "BSD" + :depends-on ("cells") :components ((:module "src" :components Modified: trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp ============================================================================== --- trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp (original) +++ trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp Sun Apr 9 14:02:36 2006 @@ -35,10 +35,10 @@ (defvar *background-color* (gfg:make-color :red 0 :green #x80 :blue #x80)) -(defgeneric update-buffer (disp tiles) +(defgeneric update-buffer (disp) (:documentation "Revises the image buffer so that the associated window can be repainted.") - (:method (disp tiles) - (declare (ignorable disp tiles)))) + (:method (disp) + (declare (ignorable disp)))) (defclass double-buffered-event-dispatcher (gfw:event-dispatcher) ((image-buffer Modified: trunk/src/demos/unblocked/scoreboard-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/scoreboard-panel.lisp (original) +++ trunk/src/demos/unblocked/scoreboard-panel.lisp Sun Apr 9 14:02:36 2006 @@ -92,9 +92,10 @@ (setf (value-font-of self) (make-instance 'gfg:font :gc gc :data *scoreboard-value-font-data*))) (gfs:dispose gc)))) -(defmethod draw-scoreboard-row (gc row image-size label-font label-text value-font value-text) +(defmethod draw-scoreboard-row (gc row image-size label-font label-text value-font value) (let* ((metrics (gfg:metrics gc label-font)) - (text-pnt (gfs:make-point :x +scoreboard-text-margin+ :y (* row (gfg:height metrics))))) + (text-pnt (gfs:make-point :x +scoreboard-text-margin+ :y (* row (gfg:height metrics)))) + (value-text (format nil "~:d" value))) (setf (gfg:font gc) label-font) (setf (gfg:foreground-color gc) *text-color*) (gfg:draw-text gc label-text text-pnt) @@ -103,8 +104,7 @@ (gfs:size-width (gfg:text-extent gc value-text)))) (gfg:draw-text gc value-text text-pnt))) -(defmethod update-buffer ((self scoreboard-panel-events) tiles) - (declare (ignore tiles)) +(defmethod update-buffer ((self scoreboard-panel-events)) (let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self))) (label-font (label-font-of self)) (value-font (value-font-of self)) @@ -112,9 +112,9 @@ (unwind-protect (progn (clear-buffer self gc) - (draw-scoreboard-row gc 0 image-size label-font +level-label+ value-font (model-level)) - (draw-scoreboard-row gc 1 image-size label-font +score-label+ value-font (model-score)) - (draw-scoreboard-row gc 2 image-size label-font +points-needed-label+ value-font (model-points-needed))) + (draw-scoreboard-row gc 1 image-size label-font +score-label+ value-font (game-score)) + (draw-scoreboard-row gc 0 image-size label-font +level-label+ value-font (game-level)) + (draw-scoreboard-row gc 2 image-size label-font +points-needed-label+ value-font (game-points-needed))) (gfs:dispose gc)))) (defclass scoreboard-panel (gfw:panel) ()) Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Sun Apr 9 14:02:36 2006 @@ -95,7 +95,7 @@ (defmethod gfw:event-mouse-down ((self tiles-panel-events) panel time point button) (declare (ignore time)) - (let* ((tiles (model-tiles)) + (let* ((tiles (game-tiles)) (tile-pnt (window->tiles point)) (tile-kind (obtain-tile tiles tile-pnt)) (shape-pnts (shape-pnts-of self)) @@ -118,23 +118,18 @@ (defmethod gfw:event-mouse-up ((self tiles-panel-events) panel time point button) (declare (ignore time)) - (let* ((tiles (model-tiles)) - (tile-pnt (window->tiles point)) - (shape-pnts (shape-pnts-of self))) + (let ((tile-pnt (window->tiles point)) + (shape-pnts (shape-pnts-of self))) (if (and (eql button :left-button) shape-pnts (find tile-pnt shape-pnts :test #'eql-point)) - (progn - (loop for pnt in shape-pnts do (set-tile tiles pnt 0)) - (collapse-tiles tiles) - (update-buffer (gfw:dispatcher panel) tiles) - (gfw:redraw panel)) + (game-shape-data shape-pnts) (if shape-pnts (draw-tiles-directly panel shape-pnts (shape-kind-of self))))) (setf (shape-kind-of self) 0) (setf (shape-pnts-of self) nil)) -(defmethod update-buffer ((self tiles-panel-events) tiles) +(defmethod update-buffer ((self tiles-panel-events)) (let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self))) (image-table (tile-image-table-of self))) (clear-buffer self gc) @@ -142,7 +137,7 @@ (map-tiles #'(lambda (pnt kind) (unless (= kind 0) (gfg:draw-image gc (gethash kind image-table) (tiles->window pnt)))) - tiles) + (game-tiles)) (gfs:dispose gc)))) (defclass tiles-panel (gfw:panel) ()) Modified: trunk/src/demos/unblocked/tiles.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles.lisp (original) +++ trunk/src/demos/unblocked/tiles.lisp Sun Apr 9 14:02:36 2006 @@ -120,3 +120,10 @@ (let ((size (size-tiles tiles))) (dotimes (i (gfs:size-width size)) (setf (aref tiles i) (collapse-column (aref tiles i)))))) + +(defun clone-tiles (orig-tiles) + (let* ((width (gfs:size-width (size-tiles orig-tiles))) + (new-tiles (make-array width :initial-element nil))) + (dotimes (i width) + (setf (aref new-tiles i) (copy-seq (aref orig-tiles i)))) + new-tiles)) Modified: trunk/src/demos/unblocked/unblocked-model.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-model.lisp (original) +++ trunk/src/demos/unblocked/unblocked-model.lisp Sun Apr 9 14:02:36 2006 @@ -33,26 +33,79 @@ (in-package :graphic-forms.uitoolkit.tests) - -(defvar *tiles* nil) - (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +max-tile-kinds+ 6) - (defconstant +horz-tile-count+ 16) + (defconstant +horz-tile-count+ 17) (defconstant +vert-tile-count+ 12)) -(defun init-model-tiles () - (setf *tiles* (init-tiles +horz-tile-count+ +vert-tile-count+ (1- +max-tile-kinds+))) - *tiles*) - -(defun model-tiles () - *tiles*) - -(defun model-level () - (format nil "~:d" 134)) +(defun factorial (n) + (if (zerop n) + 1 + (* n (factorial (1- n))))) + +(cells:defmodel unblocked-game-model () + ((level + :accessor level + :initform (cells:c? (let* ((lvl (if cells:.cache cells:.cache 1)) + (pnts-needed (* 20 (factorial lvl)))) + (if (>= (^score) pnts-needed) + (1+ lvl) + lvl)))) + (score + :accessor score + :initform (cells:c? (+ (if cells:.cache cells:.cache 0) + (* 5 (length (^shape-data)))))) + (points-needed + :accessor points-needed + :initform (cells:c? (* 20 (factorial (^level))))) + (shape-data + :accessor shape-data + :initform (cells:c-in nil)) + (tiles + :accessor tiles + :initform (cells:c? (let ((tmp nil) + (data (^shape-data))) + (if (null cells:.cache) + (progn + (setf tmp (init-tiles +horz-tile-count+ + +vert-tile-count+ + (1- +max-tile-kinds+))) + (collapse-tiles tmp)) + (if data + (progn + (setf tmp (clone-tiles cells:.cache)) + (loop for pnt in data do (set-tile tmp pnt 0)) + (collapse-tiles tmp)) + (setf tmp cells:.cache))) + tmp))))) + +(defvar *game* (make-instance 'unblocked-game-model)) + +(defun reset-game () + (cells:cells-reset) + (setf *game* (make-instance 'unblocked-game-model))) + +(defun game-tiles () + (tiles *game*)) + +(defun game-shape-data (pnts) + (setf (shape-data *game*) pnts)) + +(defun game-level () + (level *game*)) + +(defun game-points-needed () + (- (points-needed *game*) (score *game*))) + +(defun game-score () + (score *game*)) + +(defun update-panel (panel) + (update-buffer (gfw:dispatcher panel)) + (gfw:redraw panel)) -(defun model-points-needed () - (format nil "~:d" 30964)) +(cells:defobserver score ((self unblocked-game-model)) + (update-panel (get-scoreboard-panel))) -(defun model-score () - (format nil "~:d" 1548238)) +(cells:defobserver tiles ((self unblocked-game-model)) + (update-panel (get-tiles-panel))) Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Apr 9 14:02:36 2006 @@ -48,12 +48,11 @@ (defun new-unblocked (disp item time rect) (declare (ignore disp item time rect)) + (reset-game) (let ((tiles-disp (gfw:dispatcher *tiles-panel*)) - (scoreboard-disp (gfw:dispatcher *scoreboard-panel*)) - (tiles (init-model-tiles))) - (update-buffer scoreboard-disp tiles) - (collapse-tiles tiles) - (update-buffer tiles-disp tiles) + (scoreboard-disp (gfw:dispatcher *scoreboard-panel*))) + (update-buffer scoreboard-disp) + (update-buffer tiles-disp) (gfw:redraw *scoreboard-panel*) (gfw:redraw *tiles-panel*))) @@ -83,7 +82,9 @@ (:item "&Restart" :callback #'restart-unblocked) (:item "Reveal &Move" :callback #'reveal-unblocked) (:item "" :separator) - (:item "E&xit" :callback #'quit-unblocked)))))) + (:item "E&xit" :callback #'quit-unblocked))) + (:item "&Help" + :submenu ((:item "&About")))))) (scoreboard-buffer-size (compute-scoreboard-size)) (tile-buffer-size (gfs:make-size :width (+ (* +horz-tile-count+ +tile-bmp-width+) 2) From junrue at common-lisp.net Thu Apr 13 19:14:14 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 13 Apr 2006 15:14:14 -0400 (EDT) Subject: [graphic-forms-cvs] r95 - in trunk: docs/manual src src/demos/unblocked src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060413191414.9012578001@common-lisp.net> Author: junrue Date: Thu Apr 13 15:14:13 2006 New Revision: 95 Modified: trunk/docs/manual/api.texinfo trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/packages.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: implemented maximum-size and minimum-size slots for top-level windows so apps can constrain resizing by the user Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Thu Apr 13 15:14:13 2006 @@ -301,7 +301,15 @@ @deftp Class top-level Base class for @ref{window}s that are self-contained and parented to the @ref{root-window}. Except for the @code{:palette} style, they are -normally resizable have title bars (also called 'captions'). +normally resizable and have title bars (also called 'captions'). + at deffn Initarg :maximum-size +Sets the maximum @ref{size} to which the user may adjust the +boundaries of the window. + at end deffn + at deffn Initarg :minimum-size +Sets the minimum @ref{size} to which the user may adjust the +boundaries of the window. + at end deffn @deffn Initarg :style The :style initarg is a list of keywords that define the overall look-and-feel of the window being created. Applications may choose @@ -553,14 +561,35 @@ @end deffn @deffn GenericFunction location self -Returns a point object describing the coordinates of the top-left -corner of the object in its parent's coordinate system. @xref{parent}. +Returns a @ref{point} object describing the coordinates of the +top-left corner of the object in its parent's coordinate +system. @xref{parent}. + at end deffn + + at anchor{maximum-size} + at deffn GenericFunction maximum-size self +Returns a @ref{size} object describing the largest dimensions to which +the user may resize this widget; by default returns @code{nil}, +indicating that there is effectively no constraint. The corresponding + at code{setf} function sets this value; if the new maximum size is +smaller than the current size, the widget is resized to the new +maximum. @xref{minimum-size}. @end deffn @deffn GenericFunction menu-bar self Returns the menu object serving as the menubar for this object. @end deffn + at anchor{minimum-size} + at deffn GenericFunction minimum-size self +Returns a @ref{size} object describing the smallest dimensions to +which the user may resize this widget; by default returns @code{nil}, +indicating that the minimum constraint is determined by the windowing +system's configuration. The corresponding @code{setf} function sets +this value; if the new minimum size is larger than the current size, +the widget is resized to the new minimum. @xref{maximum-size}. + at end deffn + @deffn GenericFunction object-to-display self pnt Return a point that is the result of transforming the specified point from this object's coordinate system to display-relative coordinates. @@ -625,6 +654,7 @@ @end quotation @end deffn + at anchor{preferred-size} @deffn GenericFunction preferred-size self width-hint height-hint Implement this function to return @code{self}'s preferred @ref{size}; that is, the dimensions that @code{self} computes as being the best Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Thu Apr 13 15:14:13 2006 @@ -108,7 +108,9 @@ :dispatcher (make-instance 'tiles-panel-events :buffer-size tile-buffer-size))) (setf (gfw:text *unblocked-win*) "Graphic-Forms UnBlocked") - (gfw:pack *unblocked-win*) + (let ((size (gfw:preferred-size *unblocked-win* -1 -1))) + (setf (gfw:minimum-size *unblocked-win*) size) + (setf (gfw:maximum-size *unblocked-win*) size)) (gfw:show *unblocked-win* t))) (defun unblocked () Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu Apr 13 15:14:13 2006 @@ -232,9 +232,6 @@ #:window ;; constants - #:maximized ;; FIXME: should be a keyword - #:minimized ;; FIXME: should be a keyword - #:restored ;; FIXME: should be a keyword #:+vk-break+ #:+vk-backspace+ #:+vk-tab+ Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Thu Apr 13 15:14:13 2006 @@ -661,6 +661,7 @@ (defconstant +wm-activate+ #x0006) (defconstant +wm-paint+ #x000F) (defconstant +wm-close+ #x0010) +(defconstant +wm-getminmaxinfo+ #x0024) (defconstant +wm-setfont+ #x0030) (defconstant +wm-getfont+ #x0031) (defconstant +wm-ncmousemove+ #x00A0) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Thu Apr 13 15:14:13 2006 @@ -169,6 +169,13 @@ (x LONG) (y LONG)) +(defcstruct minmaxinfo + (reserved point) + (maxsize point) + (maxposition point) + (mintracksize point) + (maxtracksize point)) + (defcstruct msg (hwnd HANDLE) (message UINT) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Thu Apr 13 15:14:13 2006 @@ -298,7 +298,7 @@ :y gfs::rcpaint-y)) (setf (gfs:size rct) (gfs:make-size :width gfs::rcpaint-width :height gfs::rcpaint-height)) - (let* ((gc (make-instance 'gfg:graphics-context :handle (gfs::begin-paint hwnd ps-ptr)))) + (let ((gc (make-instance 'gfg:graphics-context :handle (gfs::begin-paint hwnd ps-ptr)))) (unwind-protect (event-paint (dispatcher widget) widget (event-time tc) gc rct) (gfs:dispose gc) @@ -318,14 +318,42 @@ (declare (ignore wparam)) (process-mouse-message #'event-mouse-up hwnd lparam :right-button)) +(defmethod process-message (hwnd (msg (eql gfs::+wm-getminmaxinfo+)) wparam lparam) + (declare (ignore wparam)) + (let* ((tc (thread-context)) + (w (get-widget tc hwnd)) + (info-ptr (cffi:make-pointer lparam))) + (if (typep w 'top-level) + (cffi:with-foreign-slots ((gfs::mintracksize gfs::maxtracksize) + info-ptr gfs::minmaxinfo) + (let ((max-size (maximum-size w)) + (min-size (minimum-size w))) + (if max-size + (cffi:with-foreign-slots ((gfs::x gfs::y) + (cffi:foreign-slot-pointer info-ptr + 'gfs::minmaxinfo + 'gfs::maxtracksize) + gfs::point) + (setf gfs::x (gfs:size-width max-size) + gfs::y (gfs:size-height max-size)))) + (if min-size + (cffi:with-foreign-slots ((gfs::x gfs::y) + (cffi:foreign-slot-pointer info-ptr + 'gfs::minmaxinfo + 'gfs::mintracksize) + gfs::point) + (setf gfs::x (gfs:size-width min-size) + gfs::y (gfs:size-height min-size)))))))) + 0) + (defmethod process-message (hwnd (msg (eql gfs::+wm-size+)) wparam lparam) (declare (ignore lparam)) (let* ((tc (thread-context)) (w (get-widget tc hwnd)) (type (cond - ((= wparam gfs::+size-maximized+) 'maximized) - ((= wparam gfs::+size-minimized+) 'minimized) - ((= wparam gfs::+size-restored+) 'restored) + ((= wparam gfs::+size-maximized+) :maximized) + ((= wparam gfs::+size-minimized+) :minimized) + ((= wparam gfs::+size-restored+) :restored) (t nil)))) (when w (outer-size w (size-event-size tc)) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Thu Apr 13 15:14:13 2006 @@ -54,6 +54,11 @@ gfs::+cs-dblclks+ -1)) +(defun constrain-new-size (new-size current-size compare-fn) + (let ((new-width (funcall compare-fn (gfs:size-width new-size) (gfs:size-width current-size))) + (new-height (funcall compare-fn (gfs:size-height new-size) (gfs:size-height current-size)))) + (gfs:make-size :width new-width :height new-height))) + ;;; ;;; methods ;;; @@ -73,8 +78,6 @@ (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) ((eq sym :min) (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) - ((eq sym :resize) - (setf std-flags (logior std-flags gfs::+ws-thickframe+))) ((eq sym :sysmenu) (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) ((eq sym :title) @@ -152,6 +155,12 @@ (error 'gfs:toolkit-error :detail "no object for menu handle")) m))) +(defmethod (setf maximum-size) :after (max-size (win top-level)) + (unless (gfs:disposed-p win) + (let ((size (constrain-new-size max-size (size win) #'min))) + (setf (size win) size) + (perform-layout win (gfs:size-width size) (gfs:size-height size))))) + (defmethod (setf menu-bar) :before ((m menu) (win top-level)) (declare (ignore m)) (if (gfs:disposed-p win) @@ -168,6 +177,12 @@ (gfs::set-menu hwnd (gfs:handle m)) (gfs::draw-menu-bar hwnd))) +(defmethod (setf minimum-size) :after (min-size (win top-level)) + (unless (gfs:disposed-p win) + (let ((size (constrain-new-size min-size (size win) #'max))) + (setf (size win) size) + (perform-layout win (gfs:size-width size) (gfs:size-height size))))) + (defmethod text :before ((win top-level)) (if (gfs:disposed-p win) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Thu Apr 13 15:14:13 2006 @@ -100,7 +100,15 @@ (defclass root-window (window) () (:documentation "This class encapsulates the root of the desktop window hierarchy.")) -(defclass top-level (window) () +(defclass top-level (window) + ((maximum-size + :accessor maximum-size + :initarg :maximum-size + :initform nil) + (minimum-size + :accessor minimum-size + :initarg :minimum-size + :initform nil)) (:documentation "Base class for windows that can be moved and resized by the user, and which normally have title bars.")) (defclass timer (event-source) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Thu Apr 13 15:14:13 2006 @@ -217,7 +217,7 @@ (:documentation "Returns T if the object is in its maximized state (not necessarily the same as the maximum size); nil otherwise.")) (defgeneric maximum-size (self) - (:documentation "Returns a size object describing the largest size this object can exist.")) + (:documentation "Returns a size object describing the largest dimensions to which the user may resize the widget.")) (defgeneric menu-bar (self) (:documentation "Returns the menu object serving as the menubar for this object.")) From junrue at common-lisp.net Fri Apr 14 23:04:28 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Fri, 14 Apr 2006 19:04:28 -0400 (EDT) Subject: [graphic-forms-cvs] r96 - in trunk: . src src/demos/unblocked src/uitoolkit/graphics Message-ID: <20060414230428.04F2C7E022@common-lisp.net> Author: junrue Date: Fri Apr 14 19:04:26 2006 New Revision: 96 Modified: trunk/build.lisp trunk/config.lisp trunk/graphic-forms-tests.asd trunk/graphic-forms-uitoolkit.asd trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/packages.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/magick-core-api.lisp Log: revised mechanism for specifying ImageMagick library directory; removed in-package forms referring to gfsys where they weren't needed since external apps shouldn't have to define that package to get the toolkit loaded Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Fri Apr 14 19:04:26 2006 @@ -47,39 +47,14 @@ (setf *cells-dir* (concatenate 'string *asdf-repo-root* "cells/")) (setf *cffi-dir* (concatenate 'string *asdf-repo-root* "cffi-0.9.0/")) (setf *closer-mop-dir* (concatenate 'string *asdf-repo-root* "closer-mop/")) -(setf *imagemagick-dir* "c:/Program Files/ImageMagick-6.2.6-Q16/") (setf *lw-compat-dir* (concatenate 'string *asdf-repo-root* "lw-compat/")) (setf *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) (setf *lisp-unit-file* (concatenate 'string *library-root* "lisp-unit")) -(defvar *asdf-system-connections-dir* (concatenate 'string *asdf-repo-root* "asdf-system-connections/")) -(defvar *cl-containers-dir* (concatenate 'string *asdf-repo-root* "cl-containers/")) -(defvar *cl-graph-dir* (concatenate 'string *asdf-repo-root* "cl-graph/")) -(defvar *cl-mathstats-dir* (concatenate 'string *asdf-repo-root* "cl-mathstats/")) -(defvar *metabang-bind-dir* (concatenate 'string *asdf-repo-root* "metabang-bind/")) -(defvar *metatilities-dir* (concatenate 'string *asdf-repo-root* "metatilities/")) -(defvar *moptilities-dir* (concatenate 'string *asdf-repo-root* "moptilities/")) -(defvar *tinaa-dir* (concatenate 'string *asdf-repo-root* "tinaa/")) - (defvar *gf-tests-dir* (concatenate 'string *gf-dir* "src/tests/uitoolkit/")) (defun build () (setf cl-user::*asdf-cache* "c:/projects/public/build/") (configure-asdf) (pushnew *gf-dir* asdf:*central-registry* :test #'equal) -#| - (pushnew *tinaa-dir* asdf:*central-registry* :test #'equal) - (pushnew *cl-graph-dir* asdf:*central-registry* :test #'equal) - (pushnew *asdf-system-connections-dir* asdf:*central-registry* :test #'equal) - (pushnew *cl-mathstats-dir* asdf:*central-registry* :test #'equal) - (pushnew *cl-containers-dir* asdf:*central-registry* :test #'equal) - (pushnew *metatilities-dir* asdf:*central-registry* :test #'equal) - (pushnew *moptilities-dir* asdf:*central-registry* :test #'equal) - (pushnew *metabang-bind-dir* asdf:*central-registry* :test #'equal) - (asdf:operate 'asdf:load-op :tinaa) -|# (asdf:operate 'asdf:load-op :graphic-forms-uitoolkit)) - -#| - (tinaa:document-system 'asdf :graphic-forms-uitoolkit "c:/projects/public/testing/") -|# Modified: trunk/config.lisp ============================================================================== --- trunk/config.lisp (original) +++ trunk/config.lisp Fri Apr 14 19:04:26 2006 @@ -31,6 +31,8 @@ ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; +(defvar *magick-library-directory* "c:/Program Files/ImageMagick-6.2.6-Q16/") + (defpackage #:graphic-forms-system (:nicknames #:gfsys) (:use :common-lisp :asdf)) @@ -40,7 +42,6 @@ (defvar *cells-dir* "cells/") (defvar *cffi-dir* "cffi-0.9.0/") (defvar *closer-mop-dir* "closer-mop/") -(defvar *imagemagick-dir* "c:/Program Files/ImageMagick-6.2.6-Q16/") (defvar *lw-compat-dir* "lw-compat/") (defvar *gf-dir* "graphic-forms/") Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Fri Apr 14 19:04:26 2006 @@ -31,7 +31,7 @@ ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; -(in-package #:graphic-forms-system) +; (in-package #:graphic-forms-system) (defpackage #:graphic-forms.uitoolkit.tests (:nicknames #:gft) @@ -51,7 +51,7 @@ (defsystem graphic-forms-tests :description "Graphic-Forms UI Toolkit Tests" - :version "0.2.0" + :version "0.3.0" :author "Jack D. Unrue" :licence "BSD" :depends-on ("cells") Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Fri Apr 14 19:04:26 2006 @@ -31,7 +31,7 @@ ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; -(in-package #:graphic-forms-system) +;(in-package #:graphic-forms-system) (print "Graphic-Forms UI Toolkit") (print "Copyright (c) 2006 by Jack D. Unrue") @@ -39,7 +39,7 @@ (defsystem graphic-forms-uitoolkit :description "Graphic-Forms UI Toolkit" - :version "0.2.0" + :version "0.3.0" :author "Jack D. Unrue" :licence "BSD" :depends-on ("cffi" "lw-compat" "closer-mop") Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Fri Apr 14 19:04:26 2006 @@ -132,12 +132,13 @@ (defmethod update-buffer ((self tiles-panel-events)) (let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self))) (image-table (tile-image-table-of self))) - (clear-buffer self gc) (unwind-protect - (map-tiles #'(lambda (pnt kind) - (unless (= kind 0) - (gfg:draw-image gc (gethash kind image-table) (tiles->window pnt)))) - (game-tiles)) + (progn + (clear-buffer self gc) + (map-tiles #'(lambda (pnt kind) + (unless (= kind 0) + (gfg:draw-image gc (gethash kind image-table) (tiles->window pnt)))) + (game-tiles))) (gfs:dispose gc)))) (defclass tiles-panel (gfw:panel) ()) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Fri Apr 14 19:04:26 2006 @@ -31,7 +31,7 @@ ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; -(in-package #:graphic-forms-system) +(in-package #:cl-user) ;;; ;;; destination for unique symbols generated by GENTEMP Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Fri Apr 14 19:04:26 2006 @@ -145,17 +145,17 @@ (pix-count (* (gfs:size-width sz) (gfs:size-height sz))) (hbmp (cffi:null-pointer)) (screen-dc (gfs::get-dc (cffi:null-pointer)))) - (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader)) - (setf gfs::biwidth (gfs:size-width sz)) - (setf gfs::biheight (- 0 (gfs:size-height sz))) - (setf gfs::biplanes 1) - (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) - (setf gfs::biypels 0) - (setf gfs::biclrused 0) - (setf gfs::biclrimp 0) + (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader) + gfs::biwidth (gfs:size-width sz) + gfs::biheight (- 0 (gfs:size-height sz)) + gfs::biplanes 1 + gfs::bibitcount 32 ;; 32bpp even if original image file is not + gfs::bicompression gfs::+bi-rgb+ + gfs::bisizeimage 0 + gfs::bixpels 0 + gfs::biypels 0 + gfs::biclrused 0 + gfs::biclrimp 0) ;; create the bitmap ;; Modified: trunk/src/uitoolkit/graphics/magick-core-api.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/magick-core-api.lisp (original) +++ trunk/src/uitoolkit/graphics/magick-core-api.lisp Fri Apr 14 19:04:26 2006 @@ -35,20 +35,20 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (use-package :cffi) - (pushnew gfsys::*imagemagick-dir* *foreign-library-directories*)) + (pushnew cl-user::*magick-library-directory* cffi:*foreign-library-directories* :test #'equal)) -(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 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) From junrue at common-lisp.net Sat Apr 15 00:05:50 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Fri, 14 Apr 2006 20:05:50 -0400 (EDT) Subject: [graphic-forms-cvs] r97 - trunk/src/uitoolkit/system Message-ID: <20060415000550.1E25E5B006@common-lisp.net> Author: junrue Date: Fri Apr 14 20:05:49 2006 New Revision: 97 Modified: trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-constants.lisp Log: added bindings for font resource registration and removal functions Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Fri Apr 14 20:05:49 2006 @@ -40,6 +40,13 @@ (load-foreign-library "msimg32.dll") (defcfun + ("AddFontResourceExA" add-font-resource-ex) + INT + (filename :string) + (flags DWORD) + (reserved LPTR)) + +(defcfun ("Arc" arc) BOOL (hdc HANDLE) @@ -137,6 +144,14 @@ (color COLORREF)) (defcfun + ("CreateScalableFontResourceA" create-scalable-font-resource) + BOOL + (hidden DWORD) + (resfile :string) + (fontfile :string) + (path :string)) + +(defcfun ("DeleteDC" delete-dc) BOOL (hdc HANDLE)) @@ -316,6 +331,11 @@ (y2 INT)) (defcfun + ("RemoveFontResourceA" remove-font-resource) + BOOL + (filename :string)) + +(defcfun ("RoundRect" round-rect) BOOL (hdc HANDLE) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Fri Apr 14 20:05:49 2006 @@ -206,6 +206,9 @@ (defconstant +ff-script+ #x0040) (defconstant +ff-decorative+ #x0050) +(defconstant +fr-private+ #x10) +(defconstant +fr-not-enum+ #x20) + (defconstant +fw-dontcare+ 0) (defconstant +fw-thin+ 100) (defconstant +fw-extralight+ 200) From junrue at common-lisp.net Sun Apr 16 06:14:04 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 16 Apr 2006 02:14:04 -0400 (EDT) Subject: [graphic-forms-cvs] r98 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060416061404.E660916001@common-lisp.net> Author: junrue Date: Sun Apr 16 02:14:03 2006 New Revision: 98 Modified: trunk/docs/manual/api.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/graphics/image.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/window.lisp Log: revised label control to support both text and image content Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Apr 16 02:14:03 2006 @@ -238,9 +238,46 @@ @end deffn @end deftp + at anchor{label} @deftp Class label -This @ref{control} class represents non-selectable controls that -display a string or image. +This @ref{control} subclass represents non-selectable controls that +display a string, image, or etched line. + at deffn Initarg :image +Supply an @ref{image} object as the value of this initarg to configure +the label to display the image rather than text. + at end deffn + at deffn Initarg :separator +Supply @sc{t} for the value of this initarg to configure the label to +render itself as an etched horizontal (or vertical) divider. The + at code{:style} initarg is used to select the desired orientation. + at end deffn + at deffn Initarg :style +When configured as a @code{text} label, the following keyword symbols +are relevant: + at itemize bullet + at item @code{:beginning} + at item @code{:center} + at item @code{:ellipsis} + at item @code{:end} + at item @code{:wrap} + at end itemize +The following style style keywords apply for both @code{text} and + at code{image} modes: + at itemize bullet + at item @code{:raised} + at item @code{:sunken} + at end itemize +Finally, the following style keywords apply when a label is +configured as a @code{separator}: + at itemize bullet + at item @code{:horizontal} + at item @code{:vertical} + at end itemize + at end deffn + at deffn Initarg :text +Supply a string as the value of this initarg to configure the label to +act as a text label. This mode is also the default. + at end deffn @end deftp @anchor{menu} @@ -893,9 +930,22 @@ @end deffn @end deftp + at anchor{image} + at deftp Class image +This subclass of @ref{native-object} wraps a native image object. +Instances may be drawn directly via a graphics-context (see + at ref{draw-image}) or set as the content of a @ref{label} control. + at deffn Initarg :size +Supply a @ref{size} object via this initarg to create a new image +object with the desired width and height. + at end deffn + at xref{image-data}. + at end deftp + + at anchor{image-data} @deftp Class image-data This subclass of @ref{native-object} maintains image attributes, -color, and pixel data. +color, and pixel data. @xref{image}. @end deftp @node graphics functions @@ -1020,6 +1070,7 @@ determined by @code{arc-size}. @end deffn + at anchor{draw-image} @deffn GenericFunction draw-image self image point Draws @code{image} in the receiver where @code{point} identifies the position of the upper-left corner of the image. Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Apr 16 02:14:03 2006 @@ -184,6 +184,7 @@ #:multiply #:pen-style #:pen-width + #:rgb->color #:red-mask #:red-shift #:rotate Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Apr 16 02:14:03 2006 @@ -103,6 +103,12 @@ (setf flag nil) (format nil "~d ~a" (id be) +btn-text-after+)))))) (setf (gfw:text w) (funcall (toggle-fn be)))) + ((eql subtype :image-label) + ;; NOTE: we are leaking a bitmap handle by not tracking the + ;; image being created here + (let ((tmp-image (make-instance 'gfg:image :file "happy.bmp"))) + (gfg:with-image-transparency (tmp-image (gfs:make-point)) + (setf (gfw:image w) tmp-image)))) ((eql subtype :text-label) (setf (gfw:text w) (format nil "~d ~a" (id be) +label-text+)))) (incf *widget-counter*))) @@ -350,6 +356,8 @@ (add-btn-disp (make-instance 'add-child-dispatcher)) (add-panel-disp (make-instance 'add-child-dispatcher :widget-class 'test-panel :subtype :panel)) + (add-image-label-disp (make-instance 'add-child-dispatcher :widget-class 'gfw:label + :subtype :image-label)) (add-text-label-disp (make-instance 'add-child-dispatcher :widget-class 'gfw:label :subtype :text-label)) (rem-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'remove-child-dispatcher)) @@ -366,7 +374,8 @@ (:item "&Children" :submenu ((:item "Add" :submenu ((:item "Button" :dispatcher add-btn-disp) - (:item "Label" :dispatcher add-text-label-disp) + (:item "Label - Image" :dispatcher add-image-label-disp) + (:item "Label - Text" :dispatcher add-text-label-disp) (:item "Panel" :dispatcher add-panel-disp))) (:item "Remove" :dispatcher rem-menu-disp :submenu ((:item ""))) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Sun Apr 16 02:14:03 2006 @@ -82,25 +82,28 @@ (gfs:dispose im)) (setf (slot-value im 'gfs:handle) (data->image id))) -(defmethod initialize-instance :after ((image image) &key size &allow-other-keys) - (unless (null size) - (cffi:with-foreign-object (bih-ptr 'gfs::bitmapinfoheader) - (gfs::zero-mem bih-ptr gfs::bitmapinfoheader) - (cffi:with-foreign-slots ((gfs::bisize gfs::biwidth gfs::biheight gfs::biplanes - gfs::bibitcount gfs::bicompression) - bih-ptr gfs::bitmapinfoheader) - (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader) - gfs::biwidth (gfs:size-width size) - gfs::biheight (- (gfs:size-height size)) - gfs::biplanes 1 - gfs::bibitcount 32 - gfs::bicompression gfs::+bi-rgb+) - (let ((nptr (cffi:null-pointer)) - (hbmp (cffi:null-pointer))) - (cffi:with-foreign-object (buffer :pointer) - (gfs::with-compatible-dcs (nptr memdc) - (setf hbmp (gfs::create-dib-section memdc bih-ptr gfs::+dib-rgb-colors+ buffer nptr 0)))) - (setf (slot-value image 'gfs:handle) hbmp)))))) +(defmethod initialize-instance :after ((image image) &key file size &allow-other-keys) + (cond + (file + (load image file)) + (size + (cffi:with-foreign-object (bih-ptr 'gfs::bitmapinfoheader) + (gfs::zero-mem bih-ptr gfs::bitmapinfoheader) + (cffi:with-foreign-slots ((gfs::bisize gfs::biwidth gfs::biheight gfs::biplanes + gfs::bibitcount gfs::bicompression) + bih-ptr gfs::bitmapinfoheader) + (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader) + gfs::biwidth (gfs:size-width size) + gfs::biheight (- (gfs:size-height size)) + gfs::biplanes 1 + gfs::bibitcount 32 + gfs::bicompression gfs::+bi-rgb+) + (let ((nptr (cffi:null-pointer)) + (hbmp (cffi:null-pointer))) + (cffi:with-foreign-object (buffer :pointer) + (gfs::with-compatible-dcs (nptr memdc) + (setf hbmp (gfs::create-dib-section memdc bih-ptr gfs::+dib-rgb-colors+ buffer nptr 0)))) + (setf (slot-value image 'gfs:handle) hbmp))))))) (defmethod load ((im image) path) (let ((data (make-instance 'image-data))) @@ -127,18 +130,20 @@ (hbmp (gfs:handle im)) (hmask (cffi:null-pointer)) (nptr (cffi:null-pointer))) - (unless (null pixel-pnt) - (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) - (gfs::get-object (gfs: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 (gfs:null-handle-p hmask) - (error 'gfs:win32-error :detail "create-bitmap failed")) - (gfs::with-compatible-dcs (nptr memdc1 memdc2) - (gfs::select-object memdc1 hbmp) - (gfs::set-bk-color memdc1 (gfs::get-pixel memdc1 - (gfs:point-x pixel-pnt) - (gfs: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+))) - (make-instance 'image :handle hmask))))) + (if pixel-pnt + (progn + (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) + (gfs::get-object (gfs: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 (gfs:null-handle-p hmask) + (error 'gfs:win32-error :detail "create-bitmap failed")) + (gfs::with-compatible-dcs (nptr memdc1 memdc2) + (gfs::select-object memdc1 hbmp) + (gfs::set-bk-color memdc1 (gfs::get-pixel memdc1 + (gfs:point-x pixel-pnt) + (gfs: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+)))) + (make-instance 'image :handle hmask)) + nil))) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sun Apr 16 02:14:03 2006 @@ -602,6 +602,17 @@ (defconstant +ss-wordellipsis+ #x0000C000) (defconstant +ss-ellipsismask+ #x0000C000) +(defconstant +stm-seticon+ #x0170) +(defconstant +stm-geticon+ #x0171) +(defconstant +stm-setimage+ #x0172) +(defconstant +stm-getimage+ #x0173) +(defconstant +stm-msgmax+ #x0174) + +(defconstant +stn-clicked+ 0) +(defconstant +stn-dblclk+ 1) +(defconstant +stn-enable+ 2) +(defconstant +stn-disable+ 3) + (defconstant +sw-hide+ 0) (defconstant +sw-shownormal+ 1) (defconstant +sw-normal+ 1) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sun Apr 16 02:14:03 2006 @@ -323,6 +323,11 @@ (pos INT)) (defcfun + ("GetSysColor" get-sys-color) + DWORD + (index INT)) + +(defcfun ("GetSystemMetrics" get-system-metrics) INT (index INT)) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Sun Apr 16 02:14:03 2006 @@ -37,8 +37,8 @@ ;;; methods ;;; -(defmethod compute-style-flags ((btn button) style) - (declare (ignore btn)) +(defmethod compute-style-flags ((btn button) style &rest extra-data) + (declare (ignore btn extra-data)) (let ((std-flags 0) (ex-flags 0)) (setf style (gfs:flatten style)) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Sun Apr 16 02:14:03 2006 @@ -53,6 +53,14 @@ ;;; methods ;;; +(defmethod background-color :before ((ctrl control)) + (if (gfs:disposed-p ctrl) + (error 'gfs:disposed-error))) + +(defmethod background-color ((ctrl control)) + (declare (ignore ctrl)) + (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+))) + (defmethod initialize-instance :after ((ctrl control) &key parent &allow-other-keys) (if (gfs:disposed-p parent) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Sun Apr 16 02:14:03 2006 @@ -37,77 +37,157 @@ ;;; methods ;;; -(defmethod compute-style-flags ((label label) style) - (declare (ignore label)) - (let ((std-flags 0) - (ex-flags 0)) - (setf style (gfs:flatten style)) - (unless (or (find :beginning style) - (find :center style) - (find :end style)) - (setf std-flags gfs::+ss-leftnowordwrap+)) +(defun compute-image-style-flags (style) + (let ((flags (logior gfs::+ss-bitmap+ gfs::+ss-realsizeimage+ gfs::+ss-centerimage+))) + (when (find :raised style) + (setf flags (logand (lognot gfs::+ss-sunken+) flags)) + (setf flags (logior flags gfs::+ss-etchedframe+))) + (when (find :sunken style) + (setf flags (logand (lognot gfs::+ss-etchedframe+) flags)) + (setf flags (logior flags gfs::+ss-sunken+))) + flags)) + +(defun compute-text-style-flags (style) + (let ((flags 0)) + (unless (intersection style (list :beginning :center :end)) + (setf flags gfs::+ss-leftnowordwrap+)) (loop for sym in style do (cond - ;; primary static styles + ;; primary text static styles ;; ((eq sym :beginning) - (setf std-flags gfs::+ss-leftnowordwrap+)) ; FIXME: i18n + (setf flags gfs::+ss-leftnowordwrap+)) ; FIXME: i18n ((eq sym :center) - (setf std-flags gfs::+ss-center+)) + (setf flags gfs::+ss-center+)) ((eq sym :end) - (setf std-flags gfs::+ss-right+)) ; FIXME: i18n + (setf flags gfs::+ss-right+)) ; FIXME: i18n ;; styles that can be combined ;; ((eq sym :ellipsis) - (setf std-flags (logior std-flags gfs::+ss-endellipsis+))) + (setf flags (logior flags gfs::+ss-endellipsis+))) ((eq sym :raised) - (setf std-flags (logand (lognot gfs::+ss-sunken+) std-flags)) - (setf std-flags (logior std-flags gfs::+ss-etchedframe+))) + (setf flags (logand (lognot gfs::+ss-sunken+) flags)) + (setf flags (logior flags gfs::+ss-etchedframe+))) ((eq sym :sunken) - (setf std-flags (logand (lognot gfs::+ss-etchedframe+) std-flags)) - (setf std-flags (logior std-flags gfs::+ss-sunken+))) + (setf flags (logand (lognot gfs::+ss-etchedframe+) flags)) + (setf flags (logior flags gfs::+ss-sunken+))) ((eq sym :wrap) - (setf std-flags (logand (lognot gfs::+ss-leftnowordwrap+) std-flags)) - (setf std-flags (logior std-flags gfs::+ss-left+))))) - (values std-flags ex-flags))) + (setf flags (logand (lognot gfs::+ss-leftnowordwrap+) flags)) + (setf flags (logior flags gfs::+ss-left+))))) + flags)) + +(defmethod compute-style-flags ((label label) style &rest extra-data) + (declare (ignore label)) + (if (> (count-if-not #'null extra-data) 1) + (error 'gfs:toolkit-error :detail "only one of :image, :separator, or :text are allowed")) + (values (cond + ((first extra-data) + (compute-image-style-flags (gfs:flatten style))) + ((second extra-data) + (if (find :vertical style) gfs::+ss-etchedvert+ gfs::+ss-etchedhorz+)) + (t + (compute-text-style-flags (gfs:flatten style)))) + 0)) + +(defmethod image ((label label)) + (if (gfs:disposed-p label) + (error 'gfs:disposed-error)) + (let ((addr (gfs::send-message (gfs:handle label) gfs::+stm-getimage+ gfs::+image-bitmap+ 0))) + (if (zerop addr) + nil + (make-instance 'gfg:image :handle (cffi:make-pointer addr))))) + +(defmethod (setf image) ((image gfg:image) (label label)) + (if (or (gfs:disposed-p label) (gfs:disposed-p image)) + (error 'gfs:disposed-error)) + (let* ((hwnd (gfs:handle label)) + (orig-flags (gfs::get-window-long hwnd gfs::+gwl-style+)) + (etch-flags (logior (logand orig-flags gfs::+ss-etchedframe+) + (logand orig-flags gfs::+ss-sunken+))) + (flags (logior etch-flags + gfs::+ss-bitmap+ + gfs::+ss-realsizeimage+ + gfs::+ss-centerimage+ + gfs::+ws-child+ + gfs::+ws-visible+)) + (tr-pnt (gfg:transparency-pixel-of image))) + (if tr-pnt + (let* ((color (background-color label)) + (size (gfg:size image)) + (bounds (make-instance 'gfs:rectangle :size size)) + (tmp-image (make-instance 'gfg:image :size size)) + (gc (make-instance 'gfg:graphics-context :image tmp-image))) + (unwind-protect + (progn + (setf (gfg:background-color gc) color) + (let ((orig-color (gfg:foreground-color gc))) + (setf (gfg:foreground-color gc) color) + (gfg:draw-filled-rectangle gc bounds) + (setf (gfg:foreground-color gc) orig-color)) + (gfg:draw-image gc image (gfs:location bounds))) + (gfs:dispose gc)) + (setf image tmp-image))) + (if (/= orig-flags flags) + (gfs::set-window-long hwnd gfs::+gwl-style+ flags)) + (gfs::send-message hwnd + gfs::+stm-setimage+ + gfs::+image-bitmap+ + (cffi:pointer-address (gfs:handle image))))) -(defmethod initialize-instance :after ((label label) &key parent style &allow-other-keys) +(defmethod initialize-instance :after ((label label) &key image parent separator style text &allow-other-keys) (if (not (listp style)) (setf style (list style))) (multiple-value-bind (std-style ex-style) - (compute-style-flags label style) + (compute-style-flags label style image separator text) (let ((hwnd (create-window gfs::+static-classname+ - " " + (or text " ") (gfs: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 'gfs:handle) hwnd))) + (setf (slot-value label 'gfs:handle) hwnd) + (if image + (setf (image label) image)))) (init-control label)) - (defmethod preferred-size ((label label) width-hint height-hint) + (declare (ignorable width-hint height-hint)) (let* ((hwnd (gfs:handle label)) (bits (gfs::get-window-long hwnd gfs::+gwl-style+)) (b-width (border-width label)) - (sz nil) - (flags (logior gfs::+dt-editcontrol+ - gfs::+dt-expandtabs+))) - (if (and (= (logand bits gfs::+ss-left+) gfs::+ss-left+) (> width-hint 0)) - (setf flags (logior flags gfs::+dt-wordbreak+))) - (setf sz (widget-text-size label flags)) - (if (>= width-hint 0) - (setf (gfs:size-width sz) width-hint)) - (if (>= height-hint 0) - (setf (gfs:size-height sz) height-hint)) - (incf (gfs:size-width sz) (* b-width 2)) - (incf (gfs:size-height sz) (* b-width 2)) - sz)) + (sz nil)) + (if (= (logand bits gfs::+ss-bitmap+) gfs::+ss-bitmap+) ; SS_BITMAP is not a single bit + (let ((image (image label))) + (if image + (gfg:size image) + (gfs:make-size))) + (let ((flags (logior gfs::+dt-editcontrol+ gfs::+dt-expandtabs+))) + (if (and (= (logand bits gfs::+ss-left+) gfs::+ss-left+) (> width-hint 0)) + (setf flags (logior flags gfs::+dt-wordbreak+))) + (setf sz (widget-text-size label flags)) + (if (>= width-hint 0) + (setf (gfs:size-width sz) width-hint)) + (if (>= height-hint 0) + (setf (gfs:size-height sz) height-hint)) + (incf (gfs:size-width sz) (* b-width 2)) + (incf (gfs:size-height sz) (* b-width 2)) + sz)))) (defmethod text ((label label)) (get-widget-text label)) (defmethod (setf text) (str (label label)) + (let* ((hwnd (gfs:handle label)) + (orig-flags (gfs::get-window-long hwnd gfs::+gwl-style+)) + (etch-flags (logior (logand orig-flags gfs::+ss-etchedframe+) + (logand orig-flags gfs::+ss-sunken+)))) + (multiple-value-bind (std-flags ex-flags) + (compute-style-flags label nil nil nil str) + (declare (ignore ex-flags)) + (gfs::set-window-long hwnd gfs::+gwl-style+ (logior etch-flags + std-flags + gfs::+ws-child+ + gfs::+ws-visible+)))) (set-widget-text label str)) Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Sun Apr 16 02:14:03 2006 @@ -49,7 +49,8 @@ ;;; methods ;;; -(defmethod compute-style-flags ((self panel) style) +(defmethod compute-style-flags ((self panel) style &rest extra-data) + (declare (ignore extra-data)) (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+)) (ex-flags 0)) (mapc #'(lambda (sym) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Sun Apr 16 02:14:03 2006 @@ -63,8 +63,8 @@ ;;; methods ;;; -(defmethod compute-style-flags ((win top-level) style) - (declare (ignore win)) +(defmethod compute-style-flags ((win top-level) style &rest extra-data) + (declare (ignore win extra-data)) (let ((std-flags 0) (ex-flags 0)) (mapc #'(lambda (sym) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sun Apr 16 02:14:03 2006 @@ -105,7 +105,7 @@ (defgeneric columns (self) (:documentation "Returns the column objects displayed by the object.")) -(defgeneric compute-style-flags (self style) +(defgeneric compute-style-flags (self style &rest extra-data) (:documentation "Convert a list of keyword symbols to a pair of native bitmasks; the first conveys normal/standard flags, whereas the second any extended flags that the system supports.")) (defgeneric compute-outer-size (self desired-client-size) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Apr 16 02:14:03 2006 @@ -149,6 +149,9 @@ ;;; methods ;;; +(defmethod background-color ((win window)) + (gfg:rgb->color (gfs::get-class-long (gfs:handle win) gfs::+gclp-hbrbackground+))) + (defmethod compute-outer-size ((win window) desired-client-size) ;; TODO: consider reimplementing this with AdjustWindowRect ;; From junrue at common-lisp.net Sun Apr 16 06:16:53 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 16 Apr 2006 02:16:53 -0400 (EDT) Subject: [graphic-forms-cvs] r99 - trunk/docs/manual Message-ID: <20060416061653.AA8A717032@common-lisp.net> Author: junrue Date: Sun Apr 16 02:16:53 2006 New Revision: 99 Modified: trunk/docs/manual/api.texinfo Log: documented :file initarg for image class Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Apr 16 02:16:53 2006 @@ -935,6 +935,9 @@ This subclass of @ref{native-object} wraps a native image object. Instances may be drawn directly via a graphics-context (see @ref{draw-image}) or set as the content of a @ref{label} control. + at deffn Initarg :file +Supply a path to a file containing image data to be loaded. + at end deffn @deffn Initarg :size Supply a @ref{size} object via this initarg to create a new image object with the desired width and height. From junrue at common-lisp.net Mon Apr 17 03:59:11 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 16 Apr 2006 23:59:11 -0400 (EDT) Subject: [graphic-forms-cvs] r100 - trunk/src/uitoolkit/widgets Message-ID: <20060417035911.45DF023003@common-lisp.net> Author: junrue Date: Sun Apr 16 23:59:10 2006 New Revision: 100 Modified: trunk/src/uitoolkit/widgets/event-source.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: fixed a bug in with-children macro where I shouldn't have been using ancestor-p to filter the results from enum-child-windows; added a couple of debug statements enabled with #+gf-debug-widgets; added a couple strategic implementations of print-object to aid debugging Modified: trunk/src/uitoolkit/widgets/event-source.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-source.lisp (original) +++ trunk/src/uitoolkit/widgets/event-source.lisp Sun Apr 16 23:59:10 2006 @@ -81,3 +81,8 @@ (defmethod parent :before ((self event-source)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) + +(defmethod print-object ((self event-source) stream) + (print-unreadable-object (self stream :type t) + (format stream "handle: ~x " (gfs:handle self)) + (format stream "dispatcher: ~a " (dispatcher self)))) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sun Apr 16 23:59:10 2006 @@ -357,6 +357,7 @@ (t nil)))) (when w (outer-size w (size-event-size tc)) + #+gf-debug-widgets (format t "about to call event-resize: ~a~%" hwnd) (event-resize (dispatcher w) w (event-time tc) (size-event-size tc) type))) 0) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Sun Apr 16 23:59:10 2006 @@ -131,6 +131,7 @@ (defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint) (with-children (win kids) + #+gf-debug-widgets (format t "compute-layout: ~a~%~a~%" win kids) (flow-container-layout layout (visible-p win) kids width-hint height-hint))) (defmethod initialize-instance :after ((layout flow-layout) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Sun Apr 16 23:59:10 2006 @@ -183,6 +183,14 @@ (setf (size win) size) (perform-layout win (gfs:size-width size) (gfs:size-height size))))) +(defmethod print-object ((self top-level) stream) + (print-unreadable-object (self stream :type t) + (format stream "handle: ~x " (gfs:handle self)) + (format stream "dispatcher: ~a " (dispatcher self)) + (format stream "client size: ~a " (size self)) + (format stream "min size: ~a " (minimum-size self)) + (format stream "max size: ~a" (maximum-size self)))) + (defmethod text :before ((win top-level)) (if (gfs:disposed-p win) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Sun Apr 16 23:59:10 2006 @@ -233,6 +233,12 @@ (error 'gfs:toolkit-error :detail "no widget for hwnd"))) widget)) +(defmethod print-object ((self widget) stream) + (print-unreadable-object (self stream :type t) + (format stream "handle: ~x " (gfs:handle self)) + (format stream "dispatcher: ~a " (dispatcher self)) + (format stream "client size: ~a" (size self)))) + (defmethod redraw :before ((w widget)) (if (gfs:disposed-p w) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Apr 16 23:59:10 2006 @@ -138,12 +138,14 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro with-children ((win var) &body body) - `(let ((,var nil)) - (visit-child-widgets ,win #'(lambda (parent child) - (when (gfw:ancestor-p parent child) - (push child ,var)))) - (setf ,var (reverse ,var)) - , at body))) + (let ((hwnd (gensym))) + `(let ((,var nil)) + (visit-child-widgets ,win #'(lambda (parent child) + (let ((,hwnd (gfs::get-ancestor (gfs:handle child) gfs::+ga-parent+))) + (if (cffi:pointer-eq (gfs:handle parent) ,hwnd) + (push child ,var))))) + (setf ,var (reverse ,var)) + , at body)))) ;;; ;;; methods From junrue at common-lisp.net Mon Apr 17 04:31:22 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 17 Apr 2006 00:31:22 -0400 (EDT) Subject: [graphic-forms-cvs] r101 - in trunk/src: demos/unblocked tests/uitoolkit uitoolkit/widgets Message-ID: <20060417043122.309F62608B@common-lisp.net> Author: junrue Date: Mon Apr 17 00:31:21 2006 New Revision: 101 Modified: trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp Log: every event-source gets a default dispatcher now (subclasses or application can override the default, of course); minor cleanup of some places that instantiate gfs:rectangle which can use the default coordinate of (0,0) Modified: trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp ============================================================================== --- trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp (original) +++ trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp Mon Apr 17 00:31:21 2006 @@ -49,8 +49,7 @@ (let ((image (image-buffer-of self))) (setf (gfg:background-color gc) *background-color*) (setf (gfg:foreground-color gc) *background-color*) - (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location (gfs:make-point) - :size (gfg:size image))))) + (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :size (gfg:size image))))) (defmethod dispose ((self double-buffered-event-dispatcher)) (let ((image (image-buffer-of self))) Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Mon Apr 17 00:31:21 2006 @@ -69,9 +69,7 @@ (declare (ignore time rect)) (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-white*) - (gfg:draw-filled-rectangle gc - (make-instance 'gfs:rectangle :location (gfs:make-point) - :size (gfw:client-size window))) + (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :size (gfw:client-size window))) (let ((func (draw-func-of self))) (unless (null func) (funcall func gc)))) Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Mon Apr 17 00:31:21 2006 @@ -48,12 +48,10 @@ (exit-fn disp nil time nil)) (defmethod gfw:event-paint ((disp hellowin-events) window time gc rect) - (declare (ignore time)) - (setf rect (make-instance 'gfs:rectangle :location (gfs:make-point) - :size (gfw:client-size window))) + (declare (ignore time rect)) (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-white*) - (gfg:draw-filled-rectangle gc rect) + (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :size (gfw:client-size window))) (setf (gfg:background-color gc) gfg:*color-red*) (setf (gfg:foreground-color gc) gfg:*color-green*) (gfg:draw-text gc "Hello World!" (gfs:make-point))) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Apr 17 00:31:21 2006 @@ -74,9 +74,7 @@ (declare (ignore time rect)) (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-white*) - (gfg:draw-filled-rectangle gc - (make-instance 'gfs:rectangle :location (gfs:make-point) - :size (gfw:client-size window)))) + (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :size (gfw:client-size window)))) (defclass test-panel (gfw:panel) ()) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Mon Apr 17 00:31:21 2006 @@ -50,12 +50,10 @@ (defclass test-win-events (gfw:event-dispatcher) ()) (defmethod gfw:event-paint ((d test-win-events) window time gc rect) - (declare (ignore time)) - (setf rect (make-instance 'gfs:rectangle :location (gfs:make-point) - :size (gfw:client-size window))) + (declare (ignore time rect)) (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-white*) - (gfg:draw-filled-rectangle gc rect)) + (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :size (gfw:client-size window)))) (defclass test-mini-events (test-win-events) ()) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Apr 17 00:31:21 2006 @@ -46,7 +46,7 @@ ((dispatcher :accessor dispatcher :initarg :dispatcher - :initform nil)) + :initform (make-instance 'event-dispatcher))) (:documentation "This is the base class for user interface objects that generate events.")) (defclass item (event-source) From junrue at common-lisp.net Tue Apr 18 04:51:58 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 18 Apr 2006 00:51:58 -0400 (EDT) Subject: [graphic-forms-cvs] r102 - in trunk: . src/uitoolkit/system Message-ID: <20060418045158.785F56D157@common-lisp.net> Author: junrue Date: Tue Apr 18 00:51:57 2006 New Revision: 102 Added: trunk/src/uitoolkit/system/comdlg32.lisp Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/system/system-conditions.lisp trunk/src/uitoolkit/system/system-types.lisp Log: initial infrastructure for open/save dialogs Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Tue Apr 18 00:51:57 2006 @@ -59,6 +59,7 @@ (:file "system-types") (:file "datastructs") (:file "clib") + (:file "comdlg32") (:file "gdi32") (:file "kernel32") (:file "user32") Added: trunk/src/uitoolkit/system/comdlg32.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/system/comdlg32.lisp Tue Apr 18 00:51:57 2006 @@ -0,0 +1,53 @@ +;;;; +;;;; comdlg32.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.system) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (use-package :cffi)) + +(load-foreign-library "comdlg32.dll") + +(defcfun + ("CommDlgExtendedError" comm-dlg-extended-error) + DWORD) + +(defcfun + ("GetOpenFileNameA" get-open-filename) + BOOL + (ofn LPTR)) + +(defcfun + ("GetSaveFileNameA" get-save-filename) + BOOL + (ofn LPTR)) Modified: trunk/src/uitoolkit/system/system-conditions.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-conditions.lisp (original) +++ trunk/src/uitoolkit/system/system-conditions.lisp Tue Apr 18 00:51:57 2006 @@ -62,3 +62,10 @@ (defmethod print-object ((obj win32-warning) stream) (print-unreadable-object (obj stream :type t) (format stream "~s: error code: ~a" (detail obj) (code obj)))) + +(define-condition comdlg-error (win32-error) + ((dlg-code :reader dlg-code :initarg :dlg-code :initform (comm-dlg-extended-error)))) + +(defmethod print-object ((obj comdlg-error) stream) + (print-unreadable-object (obj stream :type t) + (format stream "~s: common dialog error code: ~a" (detail obj) (dlg-code obj)))) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Tue Apr 18 00:51:57 2006 @@ -208,6 +208,31 @@ (flags DWORD) (device TCHAR :count 32)) ; CCHDEVICENAME +(defcstruct openfilename + (ofnsize DWORD) + (ofnhwnd HANDLE) + (ofnhinst HANDLE) + (ofnfilter :string) + (ofncustomfilter :string) + (ofnmaxcustfilter DWORD) + (ofnfilterindex DWORD) + (ofnfile :string) + (ofnmaxfile DWORD) + (ofnfiletitle :string) + (ofnmaxfiletitle DWORD) + (ofninitialdir :string) + (ofntitle :string) + (ofnflags DWORD) + (ofnfileoffset WORD) + (ofnfileext WORD) + (ofndefext :string) + (ofncustdata LPARAM) + (ofnhookfn LPTR) + (ofntemplname :string) + (ofnpvreserved LPTR) + (ofndwreserved DWORD) + (ofnexflags DWORD)) + (defcstruct rgbquad (rgbblue BYTE) (rgbgreen BYTE) From junrue at common-lisp.net Mon Apr 24 06:38:34 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 24 Apr 2006 02:38:34 -0400 (EDT) Subject: [graphic-forms-cvs] r103 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060424063834.DE4475903A@common-lisp.net> Author: junrue Date: Mon Apr 24 02:38:32 2006 New Revision: 103 Added: trunk/src/uitoolkit/widgets/file-dialog.lisp Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/menu-language.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/widget-with-items.lisp Log: implemented open and save file dialogs; revised widget-with-items to store items as a list rather than a vector Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Apr 24 02:38:32 2006 @@ -186,6 +186,14 @@ @ref{widget}. @end deftp + at anchor{dialog} + at deftp Class dialog +This is the base class for system and user-defined dialogs. A dialog +is a windowed UI component that is @emph{typically} defined to remain +on top of the primary application window(s). Of course, some +applications are entirely dialog-based. + at end deftp + @anchor{display} @deftp Class display primary Instances of this class describe characteristics of monitors attached @@ -227,6 +235,94 @@ @end deffn @end deftp + at anchor{file-dialog} + at deftp Class file-dialog +This class provides a standard @ref{dialog} for navigating the file +system to select or enter file names. A variety of configurations are +possible; however, please note that the following behaviors are +implemented regardless of other style flags or initarg values: + at itemize @bullet + at item in @code{:save} mode, the user will be prompted to confirm +overwrite when an existing file is selected + at end itemize +Applications retrieve selected files by calling the @code{items} +function, which returns a list of @sc{file namestring}s, one for each +selection. Unless the @code{:multiple-select} style keyword is +specified, there will at most be one selected file returned, and +possibly zero if the user cancelled the dialog.@*@* + at deffn Initarg :default-extension +Specifies a default extension to be appended to a file name if +the user fails to provide one. Any embedded periods @samp{.} will +be removed. Also, only the first three characters are used. + at end deffn + at deffn Initarg :filters +This initarg accepts a list of conses, @sc{first} holding a string +that describes a filter, e.g., @samp{Text Files}, and @sc{second} +specifying the actual filter pattern, e.g., @samp{*.TXT}. Note that +multiple filter patterns can be grouped with a single description by +separating them with semicolons, e.g., @samp{*.TXT;*.BAK}. + at end deffn + at deffn Initarg :initial-directory +This initarg accepts a @sc{directory namestring} identifying the +location in the file system whose contents are to be browsed by the +file dialog. @strong{Note:} setting this value will result in the +side-effect of changing the current working directory of the @sc{lisp} +process. Also, the supplied value is used only if the @sc{namestring} +supplied for @code{:initial-filename} does not contain a path. + at end deffn + at deffn Initarg :initial-filename +This initarg accepts a @sc{file namestring} which has several +purposes: + at itemize @bullet + at item populate the edit field in the file dialog with the file name +and extension + at item set the initial directory of the file dialog (and hence +the current working directory of the @sc{lisp} process) if it contains +a directory path + at item if the file actually exists in the directory, set the other +components of the file dialog to reflect the attributes of the file + at end itemize + at end deffn + at deffn Initarg :owner +A value is required for this initarg, and it may be either a + at ref{window} or a @ref{dialog}. The file dialog will remain above the +specified @code{owner} in the window system Z-order. + at end deffn + at deffn Initarg :style +This initarg accepts a list of keyword symbols, as follows: + at table @code + at item :add-to-recent +This enables the system to add a link to the selected file +in the directory that contains the user's most recently +used documents. + at item :multiple-select +This configures the dialog to accept multiple selections. + at item :open +This configures the dialog to be used to select one or more files +for loading data. + at item :path-must-exist +This keyword enables a validation check that constrains the user's +selection to file paths that actually exist. A warning dialog will be +displayed if the user supplies a non-existent path. + at item :save +This configures the dialog to be used to specify a destination file +for data to be saved. + at item :show-hidden +This keyword enables the dialog to display files marked @sc{hidden} by +the system. @strong{Note:} files marked both @sc{hidden} and + at sc{system} will not be displayed in any case. Also, be aware that +using this keyword effectively overrides the user's preference +settings. + at end table + at end deffn + at deffn Initarg :text +This initarg accepts a string that will become the title of the file +dialog. By default, a file dialog with the @code{:open} style flag +will display @samp{Open} whereas the @code{:save} style flag will +result in a title of @samp{Save As}. + at end deffn + at end deftp + @anchor{item} @deftp Class item item-id The @code{item} class is the base class for all non-windowed user @@ -581,14 +677,6 @@ Returns T if the object is enabled; nil otherwise. @end deffn - at deffn GenericFunction item-at self index -Return the item at the given zero-based index from the object. - at end deffn - - at deffn GenericFunction item-count self -Return the number of items possessed by the object. - at end deffn - @deffn GenericFunction item-index self item Return the zero-based index of the location of the other object in this object. @end deffn Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Apr 24 02:38:32 2006 @@ -109,5 +109,6 @@ (:file "root-window") (:file "top-level") (:file "panel") + (:file "file-dialog") (:file "layout") (:file "flow-layout"))))))))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Apr 24 02:38:32 2006 @@ -81,6 +81,7 @@ #:zero-mem ;; conditions + #:comdlg-error #:disposed-error #:toolkit-error #:toolkit-warning @@ -219,6 +220,7 @@ #:display #:event-dispatcher #:event-source + #:file-dialog #:flow-layout #:item #:layout-manager @@ -387,8 +389,6 @@ #:initial-delay-of #:horizontal-scrollbar #:image - #:item-at - #:item-count #:item-height #:item-id #:item-index Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Mon Apr 24 02:38:32 2006 @@ -44,8 +44,8 @@ (defun find-checked-item (disp menu time) (declare (ignore disp time)) - (dotimes (i (gfw:item-count menu)) - (let ((item (gfw:item-at menu i))) + (dotimes (i (length (gfw:items menu))) + (let ((item (elt (gfw:items menu) i))) (when (gfw:checked-p item) (setf *last-checked-drawing-item* item) (return))))) Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Mon Apr 24 02:38:32 2006 @@ -200,7 +200,7 @@ (defun manage-file-menu (disp menu time) (declare (ignore disp time)) - (let ((item (gfw:item-at menu 0))) + (let ((item (elt (gfw:items menu) 0))) (setf (gfw:text item) (if *timer* "Sto&p Timer" "&Start Timer")))) (defun manage-timer (disp item time rect) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Apr 24 02:38:32 2006 @@ -183,8 +183,8 @@ (defun check-flow-orient-items (disp menu time) (declare (ignore disp time)) (let ((layout (gfw:layout-of *layout-tester-win*))) - (gfw:check (gfw:item-at menu 0) (find :horizontal (gfw:style-of layout))) - (gfw:check (gfw:item-at menu 1) (find :vertical (gfw:style-of layout))))) + (gfw:check (elt (gfw:items menu) 0) (find :horizontal (gfw:style-of layout))) + (gfw:check (elt (gfw:items menu) 1) (find :vertical (gfw:style-of layout))))) (defun set-flow-horizontal (disp item time rect) (declare (ignorable disp item time rect)) @@ -216,7 +216,7 @@ (defun enable-flow-spacing-items (disp menu time) (declare (ignore disp time)) (let ((spacing (gfw:spacing-of (gfw:layout-of *layout-tester-win*)))) - (gfw:enable (gfw:item-at menu 0) (> spacing 0)))) + (gfw:enable (elt (gfw:items menu) 0) (> spacing 0)))) (defun decrease-flow-spacing (disp item time rect) (declare (ignore disp item time rect)) @@ -236,22 +236,22 @@ (defun enable-left-flow-margin-items (disp menu time) (declare (ignore disp time)) (let ((layout (gfw:layout-of *layout-tester-win*))) - (gfw:enable (gfw:item-at menu 0) (> (gfw:left-margin-of layout) 0)))) + (gfw:enable (elt (gfw:items menu) 0) (> (gfw:left-margin-of layout) 0)))) (defun enable-top-flow-margin-items (disp menu time) (declare (ignore disp time)) (let ((layout (gfw:layout-of *layout-tester-win*))) - (gfw:enable (gfw:item-at menu 0) (> (gfw:top-margin-of layout) 0)))) + (gfw:enable (elt (gfw:items menu) 0) (> (gfw:top-margin-of layout) 0)))) (defun enable-right-flow-margin-items (disp menu time) (declare (ignore disp time)) (let ((layout (gfw:layout-of *layout-tester-win*))) - (gfw:enable (gfw:item-at menu 0) (> (gfw:right-margin-of layout) 0)))) + (gfw:enable (elt (gfw:items menu) 0) (> (gfw:right-margin-of layout) 0)))) (defun enable-bottom-flow-margin-items (disp menu time) (declare (ignore disp time)) (let ((layout (gfw:layout-of *layout-tester-win*))) - (gfw:enable (gfw:item-at menu 0) (> (gfw:bottom-margin-of layout) 0)))) + (gfw:enable (elt (gfw:items menu) 0) (> (gfw:bottom-margin-of layout) 0)))) (defun inc-left-flow-margin (disp item time rect) (declare (ignore disp item time rect)) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Mon Apr 24 02:38:32 2006 @@ -96,16 +96,40 @@ (setf (gfw:text window) "Palette") (gfw:show window t))) +(defun open-file-dlg (disp item time rect) + (declare (ignore disp item time rect)) + (let ((dlg (make-instance 'gfw:file-dialog :owner *main-win* + :filters '(("FASL Files (*.fas;*.fsl)" . "*.fas;*.fsl") + ("Lisp Source Files (*.lisp;*.lsp)" . "*.lisp;*.lsp") + ("All Files (*.*)" . "*.*")) + :initial-directory #P"c:/" + :style '(:add-to-recent :multiple-select :open) + :text "Select Lisp-related files..."))) + (print (gfw:items dlg)))) + +(defun save-file-dlg (disp item time rect) + (declare (ignore disp item time rect)) + (let ((dlg (make-instance 'gfw:file-dialog :owner *main-win* + :default-extension "dat" + :filters '(("Data files (*.dat)" . "*.dat") + ("All Files (*.*)" . "*.*")) + :initial-directory #P"c:/" + :style '(:save)))) + (print (gfw:items dlg)))) + (defun run-windlg-internal () (let ((menubar nil)) (setf *main-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'main-win-events) :style '(:workspace))) (setf menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'windlg-exit-fn))) + (:item "&Dialogs" + :submenu ((:item "&Open File" :callback #'open-file-dlg) + (:item "&Save File" :callback #'save-file-dlg))) (:item "&Windows" - :submenu ((:item "&Borderless" :callback #'create-borderless-win) - (:item "&Mini Frame" :callback #'create-miniframe-win) - (:item "&Palette" :callback #'create-palette-win)))))) + :submenu ((:item "&Borderless" :callback #'create-borderless-win) + (:item "&Mini Frame" :callback #'create-miniframe-win) + (:item "&Palette" :callback #'create-palette-win)))))) (setf (gfw:menu-bar *main-win*) menubar) (gfw:show *main-win* t))) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Mon Apr 24 02:38:32 2006 @@ -109,6 +109,27 @@ (defconstant +cchdevicename+ 32) +(defconstant +ccerr-choosecolorcodes+ #x5000) + +(defconstant +cderr-dialogfailure+ #xffff) +(defconstant +cderr-generalcodes+ #x0000) +(defconstant +cderr-structsize+ #x0001) +(defconstant +cderr-initialization+ #x0002) +(defconstant +cderr-notemplate+ #x0003) +(defconstant +cderr-nohinstance+ #x0004) +(defconstant +cderr-loadstrfailure+ #x0005) +(defconstant +cderr-findresfailure+ #x0006) +(defconstant +cderr-loadresfailure+ #x0007) +(defconstant +cderr-lockresfailure+ #x0008) +(defconstant +cderr-memallocfailure+ #x0009) +(defconstant +cderr-memlockfailure+ #x000a) +(defconstant +cderr-nohook+ #x000b) +(defconstant +cderr-registermsgfail+ #x000c) + +(defconstant +cferr-choosefontcodes+ #x2000) +(defconstant +cferr-nofonts+ #x2001) +(defconstant +cferr-maxlessthanmin+ #x2002) + (defconstant +color-scrollbar+ 0) (defconstant +color-background+ 1) (defconstant +color-activecaption+ 2) @@ -199,6 +220,11 @@ (defconstant +eto-ignorelanguage+ #x1000) (defconstant +eto-pdy+ #x2000) +(defconstant +fnerr-filenamecodes+ #x3000) +(defconstant +fnerr-subclassfailure+ #x3001) +(defconstant +fnerr-invalidfilename+ #x3002) +(defconstant +fnerr-buffertoosmall+ #x3003) + (defconstant +ff-dontcare+ #x0000) (defconstant +ff-roman+ #x0010) (defconstant +ff-swiss+ #x0020) @@ -209,6 +235,9 @@ (defconstant +fr-private+ #x10) (defconstant +fr-not-enum+ #x20) +(defconstant +frerr-findreplacecodes+ #x4000) +(defconstant +frerr-bufferlengthzero+ #x4001) + (defconstant +fw-dontcare+ 0) (defconstant +fw-thin+ 100) (defconstant +fw-extralight+ 200) @@ -372,6 +401,38 @@ (defconstant +obm-size+ 32766) (defconstant +obm-old-close+ 32767) +(defconstant +ofn-readonly+ #x00000001) +(defconstant +ofn-overwriteprompt+ #x00000002) +(defconstant +ofn-hidereadonly+ #x00000004) +(defconstant +ofn-nochangedir+ #x00000008) +(defconstant +ofn-showhelp+ #x00000010) +(defconstant +ofn-enablehook+ #x00000020) +(defconstant +ofn-enabletemplate+ #x00000040) +(defconstant +ofn-enabletemplatehandle+ #x00000080) +(defconstant +ofn-novalidate+ #x00000100) +(defconstant +ofn-allowmultiselect+ #x00000200) +(defconstant +ofn-extensiondifferent+ #x00000400) +(defconstant +ofn-pathmustexist+ #x00000800) +(defconstant +ofn-filemustexist+ #x00001000) +(defconstant +ofn-createprompt+ #x00002000) +(defconstant +ofn-shareaware+ #x00004000) +(defconstant +ofn-noreadonlyreturn+ #x00008000) +(defconstant +ofn-notestfilecreate+ #x00010000) +(defconstant +ofn-nonetworkbutton+ #x00020000) +(defconstant +ofn-nolongnames+ #x00040000) +(defconstant +ofn-explorer+ #x00080000) +(defconstant +ofn-nodereferencelinks+ #x00100000) +(defconstant +ofn-longnames+ #x00200000) +(defconstant +ofn-enableincludenotify+ #x00400000) +(defconstant +ofn-enablesizing+ #x00800000) +(defconstant +ofn-dontaddtorecent+ #x02000000) +(defconstant +ofn-forceshowhidden+ #x10000000) +(defconstant +ofn-ex-noplacesbar+ #x00000001) + +(defconstant +ofn-sharefallthrough 2) +(defconstant +ofn-sharenowarn 1) +(defconstant +ofn-sharewarn 0) + (defconstant +oic-sample+ 32512) (defconstant +oic-hand+ 32513) (defconstant +oic-ques+ 32514) @@ -408,6 +469,20 @@ (defconstant +out-screen-outline-precis+ 9) (defconstant +out-ps-only-precis+ 10) +(defconstant +pderr-printercodes+ #x1000) +(defconstant +pderr-setupfailure+ #x1001) +(defconstant +pderr-parsefailure+ #x1002) +(defconstant +pderr-retdeffailure+ #x1003) +(defconstant +pderr-loaddrvfailure+ #x1004) +(defconstant +pderr-getdevmodefail+ #x1005) +(defconstant +pderr-initfailure+ #x1006) +(defconstant +pderr-nodevices+ #x1007) +(defconstant +pderr-nodefaultprn+ #x1008) +(defconstant +pderr-dndmmismatch+ #x1009) +(defconstant +pderr-createicfailure+ #x100a) +(defconstant +pderr-printernotfound+ #x100b) +(defconstant +pderr-defaultdifferent+ #x100c) + (defconstant +qs-key+ #x0001) (defconstant +qs-mousemove+ #x0002) (defconstant +qs-mousebutton+ #x0004) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Mon Apr 24 02:38:32 2006 @@ -212,11 +212,11 @@ (ofnsize DWORD) (ofnhwnd HANDLE) (ofnhinst HANDLE) - (ofnfilter :string) - (ofncustomfilter :string) + (ofnfilter LPTR) + (ofncustomfilter LPTR) (ofnmaxcustfilter DWORD) (ofnfilterindex DWORD) - (ofnfile :string) + (ofnfile LPTR) (ofnmaxfile DWORD) (ofnfiletitle :string) (ofnmaxfiletitle DWORD) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Mon Apr 24 02:38:32 2006 @@ -50,6 +50,10 @@ `(loop for ,i from 0 below (foreign-type-size (quote ,type)) do (setf (mem-aref ,object :char ,i) 0)))) +#+lispworks (defun native-object-special-action (obj) + (if (typep obj 'gfs:native-object) + (gfs:dispose obj))) + ;;; ;;; convenience macros ;;; Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Mon Apr 24 02:38:32 2006 @@ -38,7 +38,7 @@ ;;; (defmethod compute-style-flags ((btn button) style &rest extra-data) - (declare (ignore btn extra-data)) + (declare (ignore extra-data)) (let ((std-flags 0) (ex-flags 0)) (setf style (gfs:flatten style)) Added: trunk/src/uitoolkit/widgets/file-dialog.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/file-dialog.lisp Mon Apr 24 02:38:32 2006 @@ -0,0 +1,141 @@ +;;;; +;;;; file-dialog.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) + +;;; +;;; helper functions +;;; + +;;; +;;; methods +;;; + +(defmethod compute-style-flags ((dlg file-dialog) style &rest extra-data) + (declare (ignore extra-data)) + (let ((std-flags (logior gfs::+ofn-dontaddtorecent+ gfs::+ofn-hidereadonly+ + gfs::+ofn-notestfilecreate+ gfs::+ofn-overwriteprompt+ + gfs::+ofn-explorer+))) + (loop for sym in style + do (cond + ((eq sym :add-to-recent) + (setf std-flags (logand std-flags (lognot gfs::+ofn-dontaddtorecent+)))) + ((eq sym :multiple-select) + (setf std-flags (logior std-flags gfs::+ofn-allowmultiselect+))) + ((eq sym :path-must-exist) + (setf std-flags (logior std-flags gfs::+ofn-filemustexist+))) + ((eq sym :show-hidden) + (setf std-flags (logior std-flags gfs::+ofn-forceshowhidden+))))) + (values std-flags 0))) + +(defmethod initialize-instance :after ((dlg file-dialog) &key default-extension filters initial-directory initial-filename owner style text) + ;; FIXME: implement an OFNHookProc to process CDN_SELCHANGE + ;; so that the file buffer can be resized as needed for + ;; multi-select mode. + ;; + (if (null owner) + (error 'gfs:toolkit-error :detail ":owner initarg is required")) + (if (gfs:disposed-p owner) + (error 'gfs:disposed-error)) + (let ((struct-ptr (cffi:foreign-alloc 'gfs::openfilename)) + (filters-buffer (if filters + (collect-foreign-strings (loop for entry in filters + append (list (car entry) (cdr entry)))) + (cffi:null-pointer))) + (title-buffer (cffi:null-pointer)) + (dir-buffer (cffi:null-pointer)) + (ext-buffer (cffi:null-pointer)) + (file-buffer (cffi:foreign-alloc :char :count 1024))) ; see FIXME above + (if text + (setf title-buffer (collect-foreign-strings (list text)))) + (if initial-directory + (setf dir-buffer (collect-foreign-strings (list initial-directory)))) + (if default-extension + (progn + (setf ext-buffer (collect-foreign-strings (list (remove #\. default-extension)))))) + (if initial-filename + (cffi:with-foreign-string (tmp-str (namestring initial-filename)) + (gfs::strncpy file-buffer tmp-str 1023)) + (setf (cffi:mem-ref file-buffer :char) 0)) + (multiple-value-bind (std-style ex-style) + (compute-style-flags dlg style) + (cffi:with-foreign-slots ((gfs::ofnsize gfs::ofnhwnd gfs::ofnhinst gfs::ofnfilter + gfs::ofncustomfilter gfs::ofnmaxcustfilter gfs::ofnfilterindex + gfs::ofnfile gfs::ofnmaxfile gfs::ofnfiletitle gfs::ofnmaxfiletitle + gfs::ofninitialdir gfs::ofntitle gfs::ofnflags gfs::ofnfileoffset + gfs::ofnfileext gfs::ofndefext gfs::ofncustdata gfs::ofnhookfn + gfs::ofntemplname gfs::ofnpvreserved gfs::ofndwreserved gfs::ofnexflags) + struct-ptr gfs::openfilename) + (setf gfs::ofnsize (cffi:foreign-type-size 'gfs::openfilename) + gfs::ofnhwnd (gfs:handle owner) + gfs::ofnhinst (cffi:null-pointer) + gfs::ofnfilter filters-buffer + gfs::ofncustomfilter (cffi:null-pointer) + gfs::ofnmaxcustfilter 0 + gfs::ofnfilterindex 1 ; first pair of filter strings is identified by index 1 not 0 + gfs::ofnfile file-buffer + gfs::ofnmaxfile 1024 + gfs::ofnfiletitle (cffi:null-pointer) + gfs::ofnmaxfiletitle 0 + gfs::ofninitialdir dir-buffer + gfs::ofntitle title-buffer + gfs::ofnflags std-style + gfs::ofnfileoffset 0 + gfs::ofnfileext 0 + gfs::ofndefext ext-buffer + gfs::ofncustdata 0 + gfs::ofnhookfn (cffi:null-pointer) + gfs::ofntemplname (cffi:null-pointer) + gfs::ofnpvreserved (cffi:null-pointer) + gfs::ofndwreserved 0 + gfs::ofnexflags ex-style))) + (unwind-protect + (let ((fn (if (find :save style) #'gfs::get-save-filename #'gfs::get-open-filename))) + (if (and (zerop (funcall fn struct-ptr)) (/= (gfs::comm-dlg-extended-error) 0)) + (error 'gfs:comdlg-error :detail "file dialog function failed")) + (unless (or (cffi:null-pointer-p file-buffer) (= (cffi:mem-ref file-buffer :char) 0)) + (let* ((raw-list (extract-foreign-strings file-buffer)) + (dir-str (first raw-list))) + (if (cdr raw-list) + (setf (items dlg) (loop for filename in (cdr raw-list) + collect (parse-namestring (concatenate 'string dir-str "\\" filename)))) + (setf (items dlg) (list (parse-namestring dir-str))))))) + (cffi:foreign-free file-buffer) + (cffi:foreign-free filters-buffer) + (unless (cffi:null-pointer-p title-buffer) + (cffi:foreign-free title-buffer)) + (unless (cffi:null-pointer-p dir-buffer) + (cffi:foreign-free dir-buffer)) + (unless (cffi:null-pointer-p ext-buffer) + (cffi:foreign-free ext-buffer)) + (cffi:foreign-free struct-ptr)))) Modified: trunk/src/uitoolkit/widgets/menu-language.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-language.lisp Mon Apr 24 02:38:32 2006 @@ -208,7 +208,7 @@ (put-menuitem (thread-context) it) (insert-separator hmenu) (setf (slot-value it 'gfs:handle) hmenu) - (vector-push-extend it (items owner)))) + (push it (items owner)))) (defmethod define-submenu ((gen win32-menu-generator) label dispatcher disabled) (let* ((submenu (make-instance 'menu :handle (gfs::create-popup-menu))) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Mon Apr 24 02:38:32 2006 @@ -119,8 +119,8 @@ nil))) (defun visit-menu-tree (menu fn) - (dotimes (index (item-count menu)) - (let ((it (item-at menu index)) + (dotimes (index (length (items menu))) + (let ((it (elt (items menu) index)) (child (sub-menu menu index))) (unless (null child) (visit-menu-tree child fn)) @@ -139,7 +139,7 @@ (insert-menuitem hmenu id text (cffi:null-pointer)) (setf (item-id item) id) (put-menuitem tc item) - (vector-push-extend item (items owner)) + (push item (items owner)) item)) (defmethod append-submenu ((parent menu) text (submenu menu) disp) @@ -153,7 +153,7 @@ (insert-submenu hparent id text (cffi:null-pointer) hmenu) (setf (item-id item) id) (put-menuitem tc item) - (vector-push-extend item (items parent)) + (push item (items parent)) (put-widget tc submenu) (cond ((null disp)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Apr 24 02:38:32 2006 @@ -77,10 +77,15 @@ (defclass widget-with-items (widget) ((items :accessor items - ;; FIXME: allow subclasses to set initial size? - :initform (make-array 7 :fill-pointer 0 :adjustable t))) + :initform nil)) (:documentation "The widget-with-items class is the base class for objects composed of sub-items.")) +(defclass dialog (widget-with-items) () + (:documentation "The dialog class is the base class for both system-defined and application-defined dialogs.")) + +(defclass file-dialog (dialog) () + (:documentation "This class represents the standard file open/save dialog.")) + (defclass menu (widget-with-items) () (:documentation "The menu class represents a container for menu items (and submenus).")) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Mon Apr 24 02:38:32 2006 @@ -183,12 +183,6 @@ (defgeneric image (self) (:documentation "Returns the object's image object if it has one, or nil otherwise.")) -(defgeneric item-at (self index) - (:documentation "Return the item at the given zero-based index from the object.")) - -(defgeneric item-count (self) - (:documentation "Return the number of items possessed by the object.")) - (defgeneric item-height (self) (:documentation "Return the height of the area if one of the object's items were displayed.")) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Mon Apr 24 02:38:32 2006 @@ -41,6 +41,7 @@ (run-default-message-loop)) #+lispworks (defun startup (thread-name start-fn) + (hcl:add-special-free-action 'gfs::native-object-special-action) (gfg::initialize-magick (cffi:null-pointer)) (when (null (mp:list-all-processes)) (mp:initialize-multiprocessing)) @@ -55,7 +56,7 @@ (gfs::post-quit-message exit-code)) (defun clear-all (w) - (let ((count (gfw:item-count w))) + (let ((count (length (items w)))) (unless (zerop count) (gfw:clear-span w (gfs:make-span :start 0 :end (1- count)))))) @@ -129,3 +130,24 @@ (setf hfont (cffi:make-pointer (gfs::send-message hwnd gfs::+wm-getfont+ 0 0))) (gfs::with-hfont-selected (hdc hfont) (gfg::text-bounds hdc (text widget) dt-flags 0))))) + +(defun extract-foreign-strings (buffer) + (let ((strings nil)) + (do ((curr-ptr buffer)) + ((zerop (cffi:mem-ref curr-ptr :char))) + (let ((tmp (cffi:foreign-string-to-lisp curr-ptr))) + (push tmp strings) + (setf curr-ptr (cffi:make-pointer (+ (cffi:pointer-address curr-ptr) (1+ (length tmp))))))) + (reverse strings))) + +(defun collect-foreign-strings (strings) + (let* ((total-size (1+ (loop for str in strings + sum (1+ (length (namestring str)))))) + (buffer (cffi:foreign-alloc :char :initial-element 0 :count total-size)) + (curr-addr (cffi:pointer-address buffer))) + (loop for str in strings + do (let* ((tmp-str (namestring str)) + (str-len (1+ (length tmp-str)))) + (cffi:lisp-string-to-foreign tmp-str (cffi:make-pointer curr-addr) str-len) + (incf curr-addr str-len))) + buffer)) Modified: trunk/src/uitoolkit/widgets/widget-with-items.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-with-items.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-with-items.lisp Mon Apr 24 02:38:32 2006 @@ -44,8 +44,9 @@ (error 'gfs:disposed-error))) (defmethod clear-item ((w widget-with-items) index) - (let ((it (item-at w index))) - (delete it (items w) :test #'items-equal-p) + (let* ((items (items w)) + (it (elt items index))) + (setf (items w) (remove-if #'(lambda (x) (items-equal-p x it)) items)) (if (gfs:disposed-p it) (error 'gfs:disposed-error)) (gfs:dispose it))) @@ -59,26 +60,6 @@ (dotimes (i (1+ (- (gfs:span-end sp) (gfs:span-start sp)))) (clear-item w (gfs:span-start sp)))) -(defmethod item-at :before ((w widget-with-items) index) - (declare (ignore index)) - (if (gfs:disposed-p w) - (error 'gfs:disposed-error))) - -(defmethod item-at ((w widget-with-items) index) - (elt (items w) index)) - -(defmethod (setf item-at) :before (index (it item) (w widget-with-items)) - (declare (ignorable index it)) - (if (gfs:disposed-p w) - (error 'gfs:disposed-error))) - -(defmethod item-count :before ((w widget-with-items)) - (if (gfs:disposed-p w) - (error 'gfs:disposed-error))) - -(defmethod item-count ((w widget-with-items)) - (length (items w))) - (defmethod item-index :before ((w widget-with-items) (it item)) (declare (ignore it)) (if (gfs:disposed-p w) From junrue at common-lisp.net Mon Apr 24 16:19:54 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 24 Apr 2006 12:19:54 -0400 (EDT) Subject: [graphic-forms-cvs] r104 - in trunk: . docs/manual src/uitoolkit/widgets Message-ID: <20060424161954.BE62A2B177@common-lisp.net> Author: junrue Date: Mon Apr 24 12:19:53 2006 New Revision: 104 Added: trunk/src/uitoolkit/widgets/dialog.lisp Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/menu-language.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-with-items.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: reverted widget-with-items back to storing items as a vector; fixed a bug introduced in print-object for widgets Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Apr 24 12:19:53 2006 @@ -246,9 +246,9 @@ overwrite when an existing file is selected @end itemize Applications retrieve selected files by calling the @code{items} -function, which returns a list of @sc{file namestring}s, one for each -selection. Unless the @code{:multiple-select} style keyword is -specified, there will at most be one selected file returned, and +function, which returns a @sc{vector} of @sc{file namestring}s, one +for each selection. Unless the @code{:multiple-select} style keyword +is specified, there will at most be one selected file returned, and possibly zero if the user cancelled the dialog.@*@* @deffn Initarg :default-extension Specifies a default extension to be appended to a file name if Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Apr 24 12:19:53 2006 @@ -109,6 +109,7 @@ (:file "root-window") (:file "top-level") (:file "panel") + (:file "dialog") (:file "file-dialog") (:file "layout") (:file "flow-layout"))))))))) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Mon Apr 24 12:19:53 2006 @@ -69,3 +69,9 @@ (declare (ignorable width-hint height-hint)) (if (gfs:disposed-p ctrl) (error 'gfs:disposed-error))) + +(defmethod print-object ((self control) stream) + (print-unreadable-object (self stream :type t) + (format stream "handle: ~x " (gfs:handle self)) + (format stream "dispatcher: ~a " (dispatcher self)) + (format stream "size: ~a" (size self)))) Added: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/dialog.lisp Mon Apr 24 12:19:53 2006 @@ -0,0 +1,44 @@ +;;;; +;;;; dialog.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) + +;;; +;;; methods +;;; + +(defmethod print-object ((self dialog) stream) + (print-unreadable-object (self stream :type t) + (format stream "handle: ~x " (gfs:handle self)) + (format stream "dispatcher: ~a " (dispatcher self)) + (format stream "size: ~a" (size self)))) Modified: trunk/src/uitoolkit/widgets/menu-language.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-language.lisp Mon Apr 24 12:19:53 2006 @@ -208,7 +208,7 @@ (put-menuitem (thread-context) it) (insert-separator hmenu) (setf (slot-value it 'gfs:handle) hmenu) - (push it (items owner)))) + (vector-push-extend it (items owner)))) (defmethod define-submenu ((gen win32-menu-generator) label dispatcher disabled) (let* ((submenu (make-instance 'menu :handle (gfs::create-popup-menu))) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Mon Apr 24 12:19:53 2006 @@ -139,7 +139,7 @@ (insert-menuitem hmenu id text (cffi:null-pointer)) (setf (item-id item) id) (put-menuitem tc item) - (push item (items owner)) + (vector-push-extend item (items owner)) item)) (defmethod append-submenu ((parent menu) text (submenu menu) disp) @@ -153,7 +153,7 @@ (insert-submenu hparent id text (cffi:null-pointer) hmenu) (setf (item-id item) id) (put-menuitem tc item) - (push item (items parent)) + (vector-push-extend item (items parent)) (put-widget tc submenu) (cond ((null disp)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Apr 24 12:19:53 2006 @@ -77,7 +77,8 @@ (defclass widget-with-items (widget) ((items :accessor items - :initform nil)) + ;; 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 sub-items.")) (defclass dialog (widget-with-items) () Modified: trunk/src/uitoolkit/widgets/widget-with-items.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-with-items.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-with-items.lisp Mon Apr 24 12:19:53 2006 @@ -46,7 +46,7 @@ (defmethod clear-item ((w widget-with-items) index) (let* ((items (items w)) (it (elt items index))) - (setf (items w) (remove-if #'(lambda (x) (items-equal-p x it)) items)) + (delete it (items w) :test #'items-equal-p) (if (gfs:disposed-p it) (error 'gfs:disposed-error)) (gfs:dispose it))) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Mon Apr 24 12:19:53 2006 @@ -236,8 +236,7 @@ (defmethod print-object ((self widget) stream) (print-unreadable-object (self stream :type t) (format stream "handle: ~x " (gfs:handle self)) - (format stream "dispatcher: ~a " (dispatcher self)) - (format stream "client size: ~a" (size self)))) + (format stream "dispatcher: ~a " (dispatcher self)))) (defmethod redraw :before ((w widget)) (if (gfs:disposed-p w) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Mon Apr 24 12:19:53 2006 @@ -205,6 +205,12 @@ (compute-outer-size win new-client-sz)) (size win)))) +(defmethod print-object ((self window) stream) + (print-unreadable-object (self stream :type t) + (format stream "handle: ~x " (gfs:handle self)) + (format stream "dispatcher: ~a " (dispatcher self)) + (format stream "size: ~a" (size self)))) + (defmethod show ((win window) flag) (declare (ignore flag)) (call-next-method) From junrue at common-lisp.net Mon Apr 24 17:46:06 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 24 Apr 2006 13:46:06 -0400 (EDT) Subject: [graphic-forms-cvs] r105 - in trunk: . src/uitoolkit/graphics Message-ID: <20060424174606.0097568001@common-lisp.net> Author: junrue Date: Mon Apr 24 13:46:06 2006 New Revision: 105 Modified: trunk/README.txt trunk/config.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/tests.lisp Log: revised image loading code such that it relies on merge-pathnames and *default-pathname-defaults* rather than the current working directory; also made some cleanup edits in preparation for 0.3.0 release Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Mon Apr 24 13:46:06 2006 @@ -1,5 +1,5 @@ -Graphic-Forms README for version 0.2.0 +Graphic-Forms README for version 0.3.0 Copyright (c) 2006, Jack D. Unrue Graphic-Forms is a user interface library implemented in Common Lisp focusing @@ -15,6 +15,9 @@ - ASDF http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/ + - Cells + http://common-lisp.net/project/cells/ + - CFFI 0.9.0 http://common-lisp.net/project/cffi/ @@ -34,36 +37,30 @@ Known Problems -------------- -Aside from the fact that there are a myriad number of classes, functions, -and features in general that are not yet implemented, this section lists +Aside from the fact that there are a myriad of classes, functions, and +features in general that are not yet implemented, this section lists known problems in this release: -1. When running the layout-tester application on CLISP, you may experience - intermittent GPFs given sufficient playing around with window sizing, - or adding/removing/hiding/showing controls if the flow layout is set to - wrap. - - This problem needs further in-depth investigation. +1. The following bug filed against CLISP 2.38 -2. When running the event-tester application on CLISP, you may experience - intermittent GPFs after selecting File | Start Timer to start the - timer test. + http://sourceforge.net/tracker/index.php?func=detail&aid=1463994&group_id=1355&atid=101355 - This problem needs further in-depth investigation. + may result in intermittent GPFs when windows with layout managers are + resized or when timer objects are initialized. -3. Image loading currently requires installation of the ImageMagick +2. Image loading currently requires installation of the ImageMagick library as described in the next section. I have tested with Windows BMP files (and this is what the image-tester application displays). ImageMagick itself supports many image formats, but Graphic-Forms has not been tested with all of them. Therefore, images may not display properly, expecially when a transparency is selected. -4. The event-tester application's menu definition specifies that the +3. The event-tester application's menu definition specifies that the Test Menu | Submenu | Item A item should be disabled but it does not get disabled. However, the GFW:ENABLE function does otherwise work correctly for menu items. -5. Graphic-Forms supports CLISP 2.38 and LispWorks 4.4.6. The +4. Graphic-Forms supports CLISP 2.38 and LispWorks 4.4.6. The intention is to support additional Lisp vendors, but currently the library will not run on anything but CLISP or LW due to some vendor-specific features that have to be used. @@ -91,14 +88,15 @@ (load "config.lisp") ;; - ;; If ImageMagic is not installed in the default location, execute: + ;; If ImageMagick is not installed in the default location, execute: ;; - (setf gfsys::*imagemagick-dir* "c:/path/to/your/ImageMagick/install/") + (setf cl-user::*magick-library-directory* "c:/path/to/your/ImageMagick/install/") ;; setf these variables as needed for your specific environment to ;; load the other dependencies besides ImageMagick. Or if your Lisp ;; image already has these systems loaded, set the variables to nil. ;; + ;; gfsys::*cells-dir* ;; gfsys::*cffi-dir* ;; gfsys::*closer-mop-dir* ;; gfsys::*lw-compat-dir* @@ -119,9 +117,14 @@ ;; (asdf:operate 'asdf:load-op :graphic-forms-uitoolkit) -6. Proceed to the next section to run the tests, or start coding! - (note: I will add instructions in the future for building the - documentation) +6. You may optionally compile the reference manual. GNU Make and + makeinfo are prerequisites. Assuming you already have those + components installed, the reference manual can be built by + opening a command prompt and cd'ing to the `docs\manual' + subdirectory, then typing `make'. The output will be + produced within a subdirectory called `reference'. + +7. Proceed to the next section to run the tests, or start coding! How To Run Tests And Samples @@ -136,15 +139,10 @@ (asdf:operate 'asdf:load-op :graphic-forms-tests) - ;; Change the working directory to the uitoolkit tests - ;; directory. - ;; - - (chdir "c:/example/path/graphic-forms/src/tests/uitoolkit/") - - ;; then execute one or more of the following: + ;; execute one or more of the following: ;; + (in-package :gft) (run-tests) ;; runs the unit tests (many more to be added) (gft::run-event-tester) @@ -159,13 +157,15 @@ Support and Feedback -------------------- -Please provide feedback via the development mailing list: +Please provide feedback via the following channels: + +The development mailing list: http://www.common-lisp.net/mailman/listinfo/graphic-forms-devel -Bug reports via the bug tracking system: - http://sourceforge.net/tracker/?group_id=163034&atid=826147 +The bug tracking system: + http://sourceforge.net/tracker/?group_id=163034&atid=826145 -Patches via the patch tracker: +The patch tracker: http://sourceforge.net/tracker/?group_id=163034&atid=826147 Modified: trunk/config.lisp ============================================================================== --- trunk/config.lisp (original) +++ trunk/config.lisp Mon Apr 24 13:46:06 2006 @@ -47,11 +47,6 @@ (defvar *lisp-unit-file* "lisp-unit") -#+lispworks (defmacro chdir (path) - `(hcl:change-directory ,path)) -#+clisp (defmacro chdir (path) - `(ext:cd ,path)) - (defun configure-asdf () (pushnew *cells-dir* asdf:*central-registry* :test #'equal) (pushnew *cffi-dir* asdf:*central-registry* :test #'equal) Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Mon Apr 24 13:46:06 2006 @@ -206,8 +206,8 @@ (defmethod load ((data image-data) path) (setf path (cond - ((typep path 'pathname) (namestring path)) - ((typep path 'string) path) + ((typep path 'pathname) (namestring (merge-pathnames path))) + ((typep path 'string) (namestring (merge-pathnames path))) (t (error 'gfs:toolkit-error :detail "pathname or string required")))) (let ((handle (gfs:handle data))) @@ -220,7 +220,7 @@ (if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined)) (error 'gfs:toolkit-error :detail (format nil "exception reason: ~s" - (cffi:foreign-slot-value ex 'exception-info 'reason)))) + (cffi:foreign-slot-value ex 'exception-info 'reason)))) (if (cffi:null-pointer-p handle) (error 'gfs:toolkit-error :detail (format nil "could not load image: ~a" path))) (setf (slot-value data 'gfs:handle) handle)))) Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Mon Apr 24 13:46:06 2006 @@ -36,5 +36,5 @@ (load (compile-file *lisp-unit-file*)) (defun load-tests () - (asdf:operate 'asdf:load-op :graphic-forms-tests) - (chdir *gf-tests-dir*)) + (setf *default-pathname-defaults* (parse-namestring *gf-tests-dir*)) + (asdf:operate 'asdf:load-op :graphic-forms-tests)) From junrue at common-lisp.net Wed Apr 26 01:24:17 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 25 Apr 2006 21:24:17 -0400 (EDT) Subject: [graphic-forms-cvs] r106 - in trunk: docs/manual src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060426012417.E6C345B00A@common-lisp.net> Author: junrue Date: Tue Apr 25 21:24:16 2006 New Revision: 106 Modified: trunk/docs/manual/api.texinfo trunk/docs/manual/overview.texinfo trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/window.lisp Log: implemented focus-p and give-focus methods for widgets; enabled repeated event delivery for virtual keys; some other miscellaneous doc cleanup Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Tue Apr 25 21:24:16 2006 @@ -674,7 +674,16 @@ @end deffn @deffn GenericFunction enabled-p self -Returns T if the object is enabled; nil otherwise. +Returns @sc{t} if @code{self} is enabled; @sc{nil} otherwise. + at end deffn + + at deffn GenericFunction focus-p self +Returns @sc{t} if @code{self} currently has keyboard focus; @sc{nil} +otherwise. + at end deffn + + at deffn GenericFunction give-focus self +Places keyboard focus on @code{self}. @end deffn @deffn GenericFunction item-index self item @@ -694,9 +703,9 @@ @anchor{maximum-size} @deffn GenericFunction maximum-size self Returns a @ref{size} object describing the largest dimensions to which -the user may resize this widget; by default returns @code{nil}, +the user may resize this widget; by default returns @sc{nil}, indicating that there is effectively no constraint. The corresponding - at code{setf} function sets this value; if the new maximum size is + at sc{setf} function sets this value; if the new maximum size is smaller than the current size, the widget is resized to the new maximum. @xref{minimum-size}. @end deffn @@ -708,9 +717,9 @@ @anchor{minimum-size} @deffn GenericFunction minimum-size self Returns a @ref{size} object describing the smallest dimensions to -which the user may resize this widget; by default returns @code{nil}, +which the user may resize this widget; by default returns @sc{nil}, indicating that the minimum constraint is determined by the windowing -system's configuration. The corresponding @code{setf} function sets +system's configuration. The corresponding @sc{setf} function sets this value; if the new minimum size is larger than the current size, the widget is resized to the new minimum. @xref{maximum-size}. @end deffn @@ -741,7 +750,7 @@ @ref{top-level}s and dialogs. And it is possible for a window to be unowned but still have a @ref{parent}. Consequently, calling @ref{parent} on a @ref{top-level} will return an instance of - at ref{root-window}, but calling @ref{owner} may return @code{nil}. In + at ref{root-window}, but calling @ref{owner} may return @sc{nil}. In a reply to an entry at @url{http://blogs.msdn.com/oldnewthing/archive/2004/02/24/79212.aspx}, Raymond Chen says: @@ -766,7 +775,7 @@ @ref{top-level} window. In the case of a dialog or @ref{top-level}, then a @ref{root-window} is returned. In the case of a @code{submenu}, this will be the @ref{menu}'s ancestor in the hierarchy; but for a -menubar or context @ref{menu}, @code{parent} returns @code{nil}. In a +menubar or context @ref{menu}, @code{parent} returns @sc{nil}. In a reply to an entry at @url{http://blogs.msdn.com/oldnewthing/archive/2004/02/24/79212.aspx}, Raymond Chen says: @@ -1007,7 +1016,7 @@ The default pen style is equivalent to @code{(:flat :square-endcap :round-bevel)}. -Specifying @code{nil} for @code{pen-style} equates to selecting the +Specifying @sc{nil} for @code{pen-style} equates to selecting the Win32 @sc{PS_NULL} pen style, meaning that the pen is invisible. @end deffn @anchor{pen-width} Modified: trunk/docs/manual/overview.texinfo ============================================================================== --- trunk/docs/manual/overview.texinfo (original) +++ trunk/docs/manual/overview.texinfo Tue Apr 25 21:24:16 2006 @@ -61,12 +61,12 @@ @item ASDF @url{http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf} + at item Cells + at url{http://common-lisp.net/project/cells} + @item CFFI @url{http://common-lisp.net/project/cffi} - at item lw-compat - at url{http://common-lisp.net/project/cl-containers/lw-compat/lw-compat_latest.tar.gz} - @item Closer to MOP @url{http://common-lisp.net/project/cl-containers/closer-mop/closer-mop_latest.tar.gz} @@ -75,6 +75,9 @@ @item lisp-unit @url{http://www.cs.northwestern.edu/academics/courses/325/readings/lisp-unit.html} + + at item lw-compat + at url{http://common-lisp.net/project/cl-containers/lw-compat/lw-compat_latest.tar.gz} @end table Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Tue Apr 25 21:24:16 2006 @@ -274,6 +274,10 @@ HANDLE) (defcfun + ("GetFocus" get-focus) + HANDLE) + +(defcfun ("GetKeyState" get-key-state) SHORT (virtkey INT)) @@ -470,6 +474,11 @@ (lparam WPARAM)) (defcfun + ("SetFocus" set-focus) + HANDLE + (hwnd HANDLE)) + +(defcfun ("SetMenu" set-menu) BOOL (hwnd HANDLE) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Tue Apr 25 21:24:16 2006 @@ -61,6 +61,22 @@ (declare (ignore ctrl)) (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+))) +(defmethod focus-p :before ((ctrl control)) + (if (gfs:disposed-p ctrl) + (error 'gfs:disposed-error))) + +(defmethod focus-p ((ctrl control)) + (let ((focus-hwnd (gfs::get-focus))) + (and (not (gfs:null-handle-p focus-hwnd)) (cffi:pointer-eq focus-hwnd (gfs:handle ctrl))))) + +(defmethod give-focus :before ((ctrl control)) + (if (gfs:disposed-p ctrl) + (error 'gfs:disposed-error))) + +(defmethod give-focus ((ctrl control)) + (if (gfs:null-handle-p (gfs::set-focus (gfs:handle ctrl))) + (error 'gfs:toolkit-error "set-focus failed"))) + (defmethod initialize-instance :after ((ctrl control) &key parent &allow-other-keys) (if (gfs:disposed-p parent) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Tue Apr 25 21:24:16 2006 @@ -37,6 +37,22 @@ ;;; methods ;;; +(defmethod focus-p :before ((dlg dialog)) + (if (gfs:disposed-p dlg) + (error 'gfs:disposed-error))) + +(defmethod focus-p ((dlg dialog)) + (let ((focus-hwnd (gfs::get-focus))) + (and (not (gfs:null-handle-p focus-hwnd)) (cffi:pointer-eq focus-hwnd (gfs:handle dlg))))) + +(defmethod give-focus :before ((dlg dialog)) + (if (gfs:disposed-p dlg) + (error 'gfs:disposed-error))) + +(defmethod give-focus ((dlg dialog)) + (if (gfs:null-handle-p (gfs::set-focus (gfs:handle dlg))) + (error 'gfs:toolkit-error "set-focus failed"))) + (defmethod print-object ((self dialog) stream) (print-unreadable-object (self stream :type t) (format stream "handle: ~x " (gfs:handle self)) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Apr 25 21:24:16 2006 @@ -209,12 +209,13 @@ 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-keydown+)) wparam lparam) + (declare (ignore lparam)) (let* ((tc (thread-context)) (wparam-lo (lo-word wparam)) (ch (gfs::map-virtual-key wparam-lo 2)) (w (get-widget tc hwnd))) (setf (virtual-key tc) wparam-lo) - (when (and w (= ch 0) (= (logand lparam #x40000000) 0)) + (when (and w (= ch 0)) (event-key-down (dispatcher w) w (event-time tc) wparam-lo (code-char ch)))) 0) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Tue Apr 25 21:24:16 2006 @@ -183,6 +183,22 @@ (let ((sz (client-size win))) (perform-layout win (gfs:size-width sz) (gfs:size-height sz)))) +(defmethod focus-p :before ((win window)) + (if (gfs:disposed-p win) + (error 'gfs:disposed-error))) + +(defmethod focus-p ((win window)) + (let ((focus-hwnd (gfs::get-focus))) + (and (not (gfs:null-handle-p focus-hwnd)) (cffi:pointer-eq focus-hwnd (gfs:handle win))))) + +(defmethod give-focus :before ((win window)) + (if (gfs:disposed-p win) + (error 'gfs:disposed-error))) + +(defmethod give-focus ((win window)) + (if (gfs:null-handle-p (gfs::set-focus (gfs:handle win))) + (error 'gfs:toolkit-error "set-focus failed"))) + (defmethod location ((win window)) (if (gfs:disposed-p win) (error 'gfs:disposed-error)) From junrue at common-lisp.net Wed Apr 26 03:20:12 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 25 Apr 2006 23:20:12 -0400 (EDT) Subject: [graphic-forms-cvs] r107 - trunk/src/uitoolkit/widgets Message-ID: <20060426032012.5AEE81A040@common-lisp.net> Author: junrue Date: Tue Apr 25 23:20:11 2006 New Revision: 107 Modified: trunk/src/uitoolkit/widgets/event.lisp Log: key event processing bug fix Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Apr 25 23:20:11 2006 @@ -215,19 +215,18 @@ (ch (gfs::map-virtual-key wparam-lo 2)) (w (get-widget tc hwnd))) (setf (virtual-key tc) wparam-lo) - (when (and w (= ch 0)) + (when w (event-key-down (dispatcher w) w (event-time tc) wparam-lo (code-char ch)))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-keyup+)) wparam lparam) (declare (ignore lparam)) (let ((tc (thread-context))) - (unless (zerop (virtual-key tc)) - (let* ((wparam-lo (lo-word wparam)) - (ch (gfs::map-virtual-key wparam-lo 2)) - (w (get-widget tc hwnd))) - (when w - (event-key-up (dispatcher w) w (event-time tc) wparam-lo (code-char ch))))) + (let* ((wparam-lo (lo-word wparam)) + (ch (gfs::map-virtual-key wparam-lo 2)) + (w (get-widget tc hwnd))) + (when w + (event-key-up (dispatcher w) w (event-time tc) wparam-lo (code-char ch)))) (setf (virtual-key tc) 0)) 0) From junrue at common-lisp.net Wed Apr 26 15:46:19 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 26 Apr 2006 11:46:19 -0400 (EDT) Subject: [graphic-forms-cvs] r108 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system Message-ID: <20060426154619.F3F7123003@common-lisp.net> Author: junrue Date: Wed Apr 26 11:46:18 2006 New Revision: 108 Modified: trunk/docs/manual/api.texinfo trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-constants.lisp Log: implemented :transparent style for text drawing Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Wed Apr 26 11:46:18 2006 @@ -1244,15 +1244,15 @@ following text style keywords: @table @code @item :mnemonic -underline the mnemonic character (specified in the original string -by preceding the character with an ampersand @samp{&}) +Underline the mnemonic character (specified in the original string +by preceding the character with an ampersand @samp{&}). @item :tab -expand tabs when the string is rendered; by default the tab-width +Expand tabs when the string is rendered; by default the tab-width is 8 characters, but the optional @code{tab-width} parameter may -be used to specify a different width +be used to specify a different width. @item :transparent - at emph{This style is not yet implemented.} the background of the -rectangular area where text is drawn will not be modified +The background of the rectangular area where text is drawn will not be +modified. @end table @end deffn Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Wed Apr 26 11:46:18 2006 @@ -306,15 +306,13 @@ (setf pnt (draw-a-string gc pnt (format nil "tab~ctab~ctab" #\Tab #\Tab) "Verdana" 10 nil '(:tab))) (setf pnt (draw-a-string gc pnt (format nil "even~cmore~ctabs" #\Tab #\Tab) "Verdana" 10 nil '(:tab))) (setf pnt (draw-a-string gc pnt " " "Verdana" 10 nil nil)) - (setf pnt (draw-a-string gc pnt "and a &mnemonic" "Verdana" 10 nil '(:mnemonic))))) + (setf pnt (draw-a-string gc pnt "and a &mnemonic" "Verdana" 10 nil '(:mnemonic))) -#| (setf pnt (draw-a-string gc pnt " " "Arial" 18 nil nil)) (draw-a-string gc pnt "transparent" "Arial" 18 '(:bold) nil) (incf (gfs:point-x pnt) 50) (setf (gfg:foreground-color gc) gfg:*color-red*) - (draw-a-string gc pnt "text" "Arial" 10 '(:bold) '(:transparent)) -|# + (draw-a-string gc pnt "text" "Arial" 12 nil '(:transparent)))) (defun select-text (disp item time rect) (declare (ignore disp time rect)) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Wed Apr 26 11:46:18 2006 @@ -437,7 +437,10 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (let ((flags (compute-draw-text-style style)) - (tb-width (if (null tab-width) 0 tab-width))) + (tb-width (if (null tab-width) 0 tab-width)) + (old-bk-mode (gfs::get-bk-mode (gfs:handle self)))) + (if (find :transparent style) + (gfs::set-bk-mode (gfs:handle self) gfs::+transparent+)) (cffi:with-foreign-object (dt-ptr 'gfs::drawtextparams) (cffi:with-foreign-slots ((gfs::cbsize gfs::tablength gfs::leftmargin gfs::rightmargin) dt-ptr gfs::drawtextparams) @@ -461,7 +464,8 @@ (length text) rect-ptr flags - dt-ptr))))))) + dt-ptr) + (gfs::set-bk-mode (gfs:handle self) old-bk-mode))))))) (defmethod (setf font) ((font font) (self graphics-context)) (if (gfs:disposed-p self) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Wed Apr 26 11:46:18 2006 @@ -207,6 +207,11 @@ (hdc HANDLE)) (defcfun + ("GetBkMode" get-bk-mode) + INT + (hdc HANDLE)) + +(defcfun ("GetDCBrushColor" get-dc-brush-color) COLORREF (hdc HANDLE)) @@ -365,6 +370,12 @@ (color COLORREF)) (defcfun + ("SetBkMode" set-bk-mode) + INT + (hdc HANDLE) + (mode INT)) + +(defcfun ("SetDCBrushColor" set-dc-brush-color) COLORREF (hdc HANDLE) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Wed Apr 26 11:46:18 2006 @@ -926,3 +926,9 @@ (defconstant +bltalignment+ 119) (defconstant +shadeblendcaps+ 120) (defconstant +colormgmtcaps+ 121) + +;;; +;;; Background modes (Get/SetBkMode) +;;; +(defconstant +transparent+ 1) +(defconstant +opaque+ 2) From junrue at common-lisp.net Wed Apr 26 16:14:58 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 26 Apr 2006 12:14:58 -0400 (EDT) Subject: [graphic-forms-cvs] r109 - in trunk: . docs/manual src/demos/unblocked src/tests/uitoolkit src/uitoolkit/widgets Message-ID: <20060426161458.A6DB64E005@common-lisp.net> Author: junrue Date: Wed Apr 26 12:14:57 2006 New Revision: 109 Modified: trunk/README.txt trunk/docs/manual/api.texinfo trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/uitoolkit/widgets/timer.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: made API change for timers -- use existing enable generic function instead of start/stop; miscellaneous doc updates Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Wed Apr 26 12:14:57 2006 @@ -34,6 +34,12 @@ http://www.cs.northwestern.edu/academics/courses/325/readings/lisp-unit.html +Supported Common Lisp Implementations +------------------------------------- + +Graphic-Forms currently supports CLISP 2.38 and LispWorks 4.4.6. + + Known Problems -------------- @@ -46,7 +52,7 @@ http://sourceforge.net/tracker/index.php?func=detail&aid=1463994&group_id=1355&atid=101355 may result in intermittent GPFs when windows with layout managers are - resized or when timer objects are initialized. + resized or when timer objects are enabled. 2. Image loading currently requires installation of the ImageMagick library as described in the next section. I have tested with Windows @@ -60,10 +66,12 @@ not get disabled. However, the GFW:ENABLE function does otherwise work correctly for menu items. -4. Graphic-Forms supports CLISP 2.38 and LispWorks 4.4.6. The - intention is to support additional Lisp vendors, but currently - the library will not run on anything but CLISP or LW due to some - vendor-specific features that have to be used. +4. The src/demos/unblocked directory contains a start at a demo + program (a simple game where one clicks on block shapes to + score points, where the rest of the blocks fall down to fill + in the gaps). This demo program is not yet finished, but the + source code can still serve as sample code. + How To Configure and Build @@ -145,6 +153,8 @@ (in-package :gft) (run-tests) ;; runs the unit tests (many more to be added) + (gft::run-drawing-tester) + (gft::run-event-tester) (gft::run-image-tester) Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Wed Apr 26 12:14:57 2006 @@ -415,18 +415,24 @@ @end quotation @end deftp + at anchor{timer} @deftp Class timer A timer is a non-windowed object that generates events at a regular -(adjustable) frequency. It derives from @ref{event-source}. - at deffn Reader id-of - at end deffn +(adjustable) frequency. Applications handle timer events by +implementing the @ref{event-timer} generic function. This class +derives from @ref{event-source}. @deffn Initarg :initial-delay - at end deffn - at deffn Reader initial-delay +This initarg accepts a milliseconds value specifying how much of a +delay should occur between the call to @ref{enable} the timer and the +first tick event. If specified, this value must be non-negative. @end deffn @deffn Initarg :delay - at end deffn - at deffn Accessor delay +This initarg accepts a milliseconds value specifying how much delay +should occur between subsequent tick events. If @code{:initial-delay} +was not specified, then this value will be used as the initial delay +time as well. Setting @code{:delay} to zero and setting + at code{:initial-delay} to a positive value has the effect of creating a + at emph{one-shot} timer. @end deffn @end deftp @@ -588,6 +594,7 @@ Implement this to respond to an object (or item within) being selected. @end deffn + at anchor{event-timer} @deffn GenericFunction event-timer dispatcher timer time Implement this to respond to a tick from a specific timer. @end deffn @@ -664,9 +671,11 @@ from display-relative coordinates to this object's coordinate system. @end deffn + at anchor{enable} @deffn GenericFunction enable self flag -Enables or disables the object, causing it to be redrawn with its -default look and allows it to be selected. +For widgets, this function enables or disables the object, causing it +to be redrawn with its default look and allows it to be selected. This +function is also used to start and stop @ref{timer}s. @end deffn @deffn GenericFunction enable-layout self flag @@ -817,14 +826,6 @@ parent's coordinate system. @end deffn - at deffn GenericFunction start self -Enable event generation at regular intervals. - at end deffn - - at deffn GenericFunction stop self -Stop producing events. - at end deffn - @deffn GenericFunction text self Returns the object's text. @end deffn Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Wed Apr 26 12:14:57 2006 @@ -111,6 +111,7 @@ (let ((size (gfw:preferred-size *unblocked-win* -1 -1))) (setf (gfw:minimum-size *unblocked-win*) size) (setf (gfw:maximum-size *unblocked-win*) size)) + (new-unblocked nil nil nil nil) (gfw:show *unblocked-win* t))) (defun unblocked () Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Wed Apr 26 12:14:57 2006 @@ -207,12 +207,12 @@ (declare (ignore disp item time rect)) (if *timer* (progn - (gfw:stop *timer*) + (gfw:enable *timer* nil) (setf *timer* nil) (setf *event-tester-text* "timer stopped by user")) (progn (setf *timer* (make-instance 'gfw:timer :delay 1000 :dispatcher (make-instance 'event-tester-echo-dispatcher))) - (gfw:start *timer*) + (gfw:enable *timer* t) (setf *event-tester-text* (format nil "timer ~d started init delay: ~d delay ~d" (gfw:id-of *timer*) Modified: trunk/src/uitoolkit/widgets/timer.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/timer.lisp (original) +++ trunk/src/uitoolkit/widgets/timer.lisp Wed Apr 26 12:14:57 2006 @@ -108,18 +108,18 @@ (setf (slot-value self 'initial-delay) init-delay) (setf (slot-value self 'delay) delay))) -(defmethod start ((self timer)) - ;; use init-delay as the elapse interval for the very first - ;; tick; the interval will be adjusted (or the timer killed) - ;; as part of processing the first event - ;; - (let ((init-delay (initial-delay-of self))) - (if (> init-delay 0) - (reset-timer-to-delay self init-delay) - (reset-timer-to-delay self (delay-of self))))) - -(defmethod stop ((self timer)) - (remove-timer (thread-context) self)) ;; kill-timer will be called on the next tick +(defmethod enable ((self timer) flag) + (if flag + (progn + ;; use init-delay as the elapse interval for the very first + ;; tick; the interval will be adjusted (or the timer killed) + ;; as part of processing the first event + ;; + (let ((init-delay (initial-delay-of self))) + (if (> init-delay 0) + (reset-timer-to-delay self init-delay) + (reset-timer-to-delay self (delay-of self))))) + (remove-timer (thread-context) self))) ;; kill-timer will be called on the next tick (defmethod running-p ((self timer)) (get-timer (thread-context) (id-of self))) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Wed Apr 26 12:14:57 2006 @@ -330,15 +330,9 @@ (defgeneric size (self) (:documentation "Returns a size object describing the size of the object in its parent's coordinate system.")) -(defgeneric start (self) - (:documentation "Enable event generation at regular intervals.")) - (defgeneric step-increment (self) (:documentation "Return an integer representing the configured step size for the object.")) -(defgeneric stop (self) - (:documentation "Stop producing events.")) - (defgeneric text (self) (:documentation "Returns the object's text.")) From junrue at common-lisp.net Wed Apr 26 16:23:40 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 26 Apr 2006 12:23:40 -0400 (EDT) Subject: [graphic-forms-cvs] r110 - in trunk: . src Message-ID: <20060426162340.E864B50005@common-lisp.net> Author: junrue Date: Wed Apr 26 12:23:40 2006 New Revision: 110 Modified: trunk/README.txt trunk/src/packages.lisp Log: pre-0.3.0 cleanup Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Wed Apr 26 12:23:40 2006 @@ -72,6 +72,11 @@ in the gaps). This demo program is not yet finished, but the source code can still serve as sample code. +5. The text-extent generic function currently does not return + the correct text height. As a workaround, get the text metrics + for the desired font and base height calculations on that + value. The text-extent function does return the correct width. + How To Configure and Build Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Wed Apr 26 12:23:40 2006 @@ -392,7 +392,6 @@ #:item-height #:item-id #:item-index - #:item-owner #:items #:key-down-p #:key-toggled-p From junrue at common-lisp.net Wed Apr 26 16:29:35 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 26 Apr 2006 12:29:35 -0400 (EDT) Subject: [graphic-forms-cvs] r111 - in trunk/src: . uitoolkit/widgets Message-ID: <20060426162935.A4CB552000@common-lisp.net> Author: junrue Date: Wed Apr 26 12:29:35 2006 New Revision: 111 Modified: trunk/src/packages.lisp trunk/src/uitoolkit/widgets/event.lisp Log: remove dangling references to obsolete stop function Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Wed Apr 26 12:29:35 2006 @@ -454,10 +454,8 @@ #:shutdown #:size #:spacing-of - #:start #:startup #:step-increment - #:stop #:style-of #:sub-menu #:text Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Wed Apr 26 12:29:35 2006 @@ -377,7 +377,7 @@ (gfs::kill-timer (cffi:null-pointer) wparam) (progn (if (<= (delay-of timer) 0) - (stop timer) + (enable timer nil) (reset-timer-to-delay timer (delay-of timer))) (event-timer (dispatcher timer) timer (event-time tc))))) 0) From junrue at common-lisp.net Wed Apr 26 17:02:04 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 26 Apr 2006 13:02:04 -0400 (EDT) Subject: [graphic-forms-cvs] r112 - tags/release-0.3.0 Message-ID: <20060426170204.060AF6D157@common-lisp.net> Author: junrue Date: Wed Apr 26 13:02:03 2006 New Revision: 112 Added: tags/release-0.3.0/ - copied from r111, trunk/ Log: tagging the 0.3.0 release From junrue at common-lisp.net Sat Apr 29 15:11:48 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sat, 29 Apr 2006 11:11:48 -0400 (EDT) Subject: [graphic-forms-cvs] r113 - in trunk: docs/manual docs/website src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060429151148.6F2AE7700E@common-lisp.net> Author: junrue Date: Sat Apr 29 11:11:47 2006 New Revision: 113 Modified: trunk/docs/manual/api.texinfo trunk/docs/website/index.html trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/event.lisp Log: implemented event-focus-gain/event-focus-loss methods Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sat Apr 29 11:11:47 2006 @@ -551,6 +551,16 @@ @ref{dispose}, not the garbage collector). @end deffn + at anchor{event-focus-gain} + at deffn GenericFunction event-focus-gain dispatcher widget time +Implement this to respond to an object gaining keyboard focus. + at end deffn + + at anchor{event-focus-loss} + at deffn GenericFunction event-focus-gain dispatcher widget time +Implement this to respond to an object losing keyboard focus. + at end deffn + @deffn GenericFunction event-key-down dispatcher widget time keycode char Implement this to respond to a key down event. @end deffn Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Sat Apr 29 11:11:47 2006 @@ -57,7 +57,7 @@

Status

-

The first release, version 0.2.0, is now available.

+

The current release is version 0.3.0.

This library is in the early implementation stage. Brave souls who experiment with the code should expect significant API and Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sat Apr 29 11:11:47 2006 @@ -748,6 +748,13 @@ (defconstant +wm-move+ #x0003) (defconstant +wm-size+ #x0005) (defconstant +wm-activate+ #x0006) +(defconstant +wm-setfocus+ #x0007) +(defconstant +wm-killfocus+ #x0008) +(defconstant +wm-enable+ #x000A) +(defconstant +wm-setredraw+ #x000B) +(defconstant +wm-settext+ #x000C) +(defconstant +wm-gettext+ #x000D) +(defconstant +wm-gettextlength+ #x000E) (defconstant +wm-paint+ #x000F) (defconstant +wm-close+ #x0010) (defconstant +wm-getminmaxinfo+ #x0024) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sat Apr 29 11:11:47 2006 @@ -318,6 +318,22 @@ (declare (ignore wparam)) (process-mouse-message #'event-mouse-up hwnd lparam :right-button)) +(defmethod process-message (hwnd (msg (eql gfs::+wm-killfocus+)) wparam lparam) + (declare (ignore wparam lparam)) + (let* ((tc (thread-context)) + (widget (get-widget tc hwnd))) + (if widget + (event-focus-loss (dispatcher widget) widget (event-time tc)))) + 0) + +(defmethod process-message (hwnd (msg (eql gfs::+wm-setfocus+)) wparam lparam) + (declare (ignore wparam lparam)) + (let* ((tc (thread-context)) + (widget (get-widget tc hwnd))) + (if widget + (event-focus-gain (dispatcher widget) widget (event-time tc)))) + 0) + (defmethod process-message (hwnd (msg (eql gfs::+wm-getminmaxinfo+)) wparam lparam) (declare (ignore wparam)) (let* ((tc (thread-context)) From junrue at common-lisp.net Sun Apr 30 06:08:27 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 30 Apr 2006 02:08:27 -0400 (EDT) Subject: [graphic-forms-cvs] r114 - in trunk: . docs/manual src src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060430060827.1DF9C34020@common-lisp.net> Author: junrue Date: Sun Apr 30 02:08:25 2006 New Revision: 114 Added: trunk/src/uitoolkit/widgets/heap-layout.lisp Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/layout-classes.lisp trunk/src/uitoolkit/widgets/layout-generics.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/window.lisp Log: initial implementation of heap-layout, possible container cleanup issues needing investigation; also made some layout-related doc enhancements Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Apr 30 02:08:25 2006 @@ -502,7 +502,7 @@ @end deffn @deffn Initarg :layout @end deffn - at deffn Accessor layout + at deffn Accessor layout-of @end deffn @end deftp @@ -513,17 +513,59 @@ @strong{NOTE:} A future release will provide additional layout manager classes. - at anchor{layout-manager} - at deftp Class layout-manager style -Subclasses implement layout strategies on behalf of window objects. + at anchor{flow-layout} + at deftp Class flow-layout spacing +This @ref{layout-manager} subclass arranges dialog or window children +in a row or column, with optional spacing (specified in pixels) +between children. + at deffn Initarg :style +This initarg accepts a list containing one of the following +style keywords: + at table @code + at item :horizontal +Specifies arrangement in a horizontal row. This style is the default. + at item :vertical +Specifies arrangement in a vertical column. + at item :wrap +This style keyword enables the arrangement of children to be +wrapped if the available horizontal (or vertical) space within +the container is less than the layout requests for a full +row (or column). The default behavior is unwrapped. + at end table + at end deffn @end deftp - at anchor{flow-layout} - at deftp Class flow-layout spacing left-margin top-margin right-margin bottom-margin -This @ref{layout-manager} subclass arranges window children in a row -or column, with optional margins around the row/column and spacing in -between children. The layout can wrap the window children if desired -and the available horizontal (or vertical) space is constrained. + at anchor{heap-layout} + at deftp Class heap-layout top-child +This @ref{layout-manager} subclass resizes all children to the same +size and stacks them on top of each other. + at deffn Initarg :top-child +Use this initarg to specify the child widget that should be visible. +The corresponding accessor @code{top-child-of} can be set +subsequently, followed by calling @ref{layout} on the container, in +order to make a different child visible. + at end deffn + at end deftp + + at anchor{layout-manager} + at deftp Class layout-manager style left-margin top-margin right-margin bottom-margin +Subclasses implement layout strategies on behalf of window +objects. Every layout manager allows optional margins (specified in +pixels) within the perimeter of the container being managed.@*@* The +values accepted by the @code{:style} initarg vary depending on the +actual @code{layout-manager} subclass being used. + at deffn Initarg :horizontal-margins +This initarg accepts a horizontal margin value that is applied to both +the left and right sides of the container. + at end deffn + at deffn Initarg :margins +This initarg accepts a margin value that is applied to all sides of +the container. + at end deffn + at deffn Initarg :vertical-margins +This initarg accepts a vertical margin value that is applied to both +the top and bottom of the container. + at end deffn @end deftp @@ -709,6 +751,7 @@ Return the zero-based index of the location of the other object in this object. @end deffn + at anchor{layout} @deffn GenericFunction layout self Set the size and location of this object's children. @end deffn @@ -861,19 +904,42 @@ @node layout functions @section layout functions - at deffn GenericFunction compute-layout layout window width-hint height-hint -Returns a list of conses @code{(window . rectangle)} describing the +These functions comprise the protocol for @ref{layout-manager}s. As +such, they are not normally called by application code, but instead +are the concern of layout-manager implementers. + +The @code{width-hint} and @code{height-hint} parameters are a +mechanism to express the @emph{what-if} scenario where the total width +or height of the container is fixed; the proper response is to +calculate the container's desired dimension on the opposite +axis. While this behavior is primarily the concern of child windows +and/or controls, layout manager implementations should look for +non-negative values for either @code{width-hint} or + at code{height-hint}, indicating that the container's size is +constrained. + + at anchor{compute-layout} + at deffn GenericFunction compute-layout layout container width-hint height-hint +Returns a list of conses @code{(child . rectangle)} describing the new bounds of each child window or control. A @ref{layout-manager} subclass implements this method based on its particular layout strategy, taking into account attributes set by the user. Certain Graphic-Forms functions -call this method to accomplish layout within a window. +call this method to accomplish layout within a container. @end deffn - at deffn GenericFunction compute-size layout window width-hint height-hint -Computes and returns the new @ref{size} of the window's client area. A - at ref{layout-manager} subclass implements this method based on its -particular layout strategy, taking into account attributes set by the -user. The @ref{pack} function ultimately calls this method. + at deffn GenericFunction compute-size layout container width-hint height-hint +Computes and returns the new @ref{size} of the @code{container}'s +client area. A @ref{layout-manager} subclass implements this method +based on its particular layout strategy, taking into account +attributes set by the user. The @ref{pack} function ultimately calls +this method. + at end deffn + + at deffn GenericFunction perform layout container width-hint height-hint +Calls @ref{compute-layout} for @code{container} and then moves and +resizes @code{container}'s children. Layout subclasses may override +this method -- most derivations should call @sc{CALL-NEXT-METHOD} to +allow the base implementation to execute. @end deffn Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sun Apr 30 02:08:25 2006 @@ -112,4 +112,5 @@ (:file "dialog") (:file "file-dialog") (:file "layout") + (:file "heap-layout") (:file "flow-layout"))))))))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Apr 30 02:08:25 2006 @@ -222,6 +222,7 @@ #:event-source #:file-dialog #:flow-layout + #:heap-layout #:item #:layout-manager #:menu @@ -463,6 +464,7 @@ #:text-limit #:thumb-size #:tooltip-text + #:top-child-of #:top-index #:top-margin-of #:traverse Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sun Apr 30 02:08:25 2006 @@ -33,6 +33,14 @@ (in-package :graphic-forms.uitoolkit.system) +;;; +;;; The following variables are used with set-window-pos +;;; +(defvar *hwnd-top* (cffi:null-pointer)) +(defvar *hwnd-bottom* (cffi:make-pointer #x00000001)) +(defvar *hwnd-topmost* (cffi:make-pointer #xFFFFFFFF)) +(defvar *hwnd-notopmost* (cffi:make-pointer #xFFFFFFFE)) + (defconstant +button-classname+ "button") (defconstant +static-classname+ "static") Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Sun Apr 30 02:08:25 2006 @@ -134,22 +134,6 @@ #+gf-debug-widgets (format t "compute-layout: ~a~%~a~%" win kids) (flow-container-layout layout (visible-p win) kids width-hint height-hint))) -(defmethod initialize-instance :after ((layout flow-layout) - &key style margins horz-margins vert-margins - &allow-other-keys) - (unless (listp style) - (setf style (list style))) - (if (and (null (find :horizontal style)) (null (find :vertical style))) - (push :horizontal style)) - (setf (style-of layout) style) - (unless (null margins) - (setf (left-margin-of layout) margins) - (setf (right-margin-of layout) margins) - (setf (top-margin-of layout) margins) - (setf (bottom-margin-of layout) margins)) - (unless (null horz-margins) - (setf (left-margin-of layout) horz-margins) - (setf (right-margin-of layout) horz-margins)) - (unless (null vert-margins) - (setf (top-margin-of layout) vert-margins) - (setf (bottom-margin-of layout) vert-margins))) +(defmethod initialize-instance :after ((layout flow-layout) &key) + (unless (intersection (style-of layout) '(:horizontal :vertical)) + (setf (style-of layout) (list :horizontal)))) Added: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Sun Apr 30 02:08:25 2006 @@ -0,0 +1,104 @@ +;;;; +;;;; heap-layout.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) + +;;; +;;; methods +;;; + +(defmethod compute-size ((self heap-layout) win width-hint height-hint) + (let ((size (gfs:make-size))) + (with-children (win kids) + (loop for kid in kids + do (let ((kid-size (preferred-size kid width-hint height-hint))) + (setf (gfs:size-width size) (max (gfs:size-width size) + (gfs:size-width kid-size)) + (gfs:size-height size) (max (gfs:size-height size) + (gfs:size-height kid-size)))))) + (incf (gfs:size-width size) (+ (left-margin-of self) (right-margin-of self))) + (incf (gfs:size-height size) (+ (top-margin-of self) (bottom-margin-of self))) + size)) + +(defmethod compute-layout ((self heap-layout) win width-hint height-hint) + (let* ((size (client-size win)) + (horz-margin (+ (left-margin-of self) (right-margin-of self))) + (vert-margin (+ (top-margin-of self) (bottom-margin-of self))) + (new-size (gfs:make-size :width (- (if (> width-hint horz-margin) + width-hint + (gfs:size-width size)) + horz-margin) + :height (- (if (> height-hint vert-margin) + height-hint + (gfs:size-height size)) + vert-margin))) + (new-pnt (gfs:make-point :x (left-margin-of self) :y (top-margin-of self))) + (bounds (make-instance 'gfs:rectangle :size new-size :location new-pnt))) + (with-children (win kids) + (loop for kid in kids collect (cons kid bounds))))) + +(defmethod perform ((self heap-layout) win width-hint height-hint) + (let ((kids nil) + (hdwp (cffi:null-pointer)) + (top (top-child-of self))) + (when (layout-p win) + (setf kids (compute-layout self win width-hint height-hint)) + (setf hdwp (gfs::begin-defer-window-pos (length kids))) + (loop for k in kids + do (let* ((rect (cdr k)) + (sz (gfs:size rect)) + (pnt (gfs:location rect)) + (kid-win (car k)) + (hwnd-after (cffi:null-pointer)) + (flags (logior +window-pos-flags+ gfs::+swp-hidewindow+))) + (when (cffi:pointer-eq (gfs:handle kid-win) (gfs:handle top)) + (setf hwnd-after gfs::*hwnd-top* + flags (logior +window-pos-flags+ gfs::+swp-showwindow+))) + (if (gfs:null-handle-p hdwp) + (gfs::set-window-pos (gfs:handle kid-win) + hwnd-after + (gfs:point-x pnt) + (gfs:point-y pnt) + (gfs:size-width sz) + (gfs:size-height sz) + flags) + (setf hdwp (gfs::defer-window-pos hdwp + (gfs:handle kid-win) + hwnd-after + (gfs:point-x pnt) + (gfs:point-y pnt) + (gfs:size-width sz) + (gfs:size-height sz) + flags))))) + (unless (gfs:null-handle-p hdwp) + (gfs::end-defer-window-pos hdwp))))) Modified: trunk/src/uitoolkit/widgets/layout-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/layout-classes.lisp Sun Apr 30 02:08:25 2006 @@ -37,14 +37,7 @@ ((style :accessor style-of :initarg :style - :initform nil)) - (:documentation "Subclasses implement layout strategies on behalf of window objects.")) - -(defclass flow-layout (layout-manager) - ((spacing - :accessor spacing-of - :initarg :spacing - :initform 0) + :initform nil) (left-margin :accessor left-margin-of :initarg :left-margin @@ -61,4 +54,18 @@ :accessor bottom-margin-of :initarg :bottom-margin :initform 0)) + (:documentation "Subclasses implement layout strategies on behalf of window objects.")) + +(defclass flow-layout (layout-manager) + ((spacing + :accessor spacing-of + :initarg :spacing + :initform 0)) (:documentation "Window children are arranged in a row or column.")) + +(defclass heap-layout (layout-manager) + ((top-child + :accessor top-child-of + :initarg :top-child + :initform nil)) + (:documentation "Window children are stacked one on top of the other.")) Modified: trunk/src/uitoolkit/widgets/layout-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/layout-generics.lisp Sun Apr 30 02:08:25 2006 @@ -38,3 +38,6 @@ (defgeneric compute-layout (layout win width-hint height-hint) (:documentation "Returns a list of conses (window . rectangle) describing the new bounds of each child window.")) + +(defgeneric perform (layout window widget-hint height-hint) + (:documentation "Moves and resizes window children based on layout strategy.")) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Sun Apr 30 02:08:25 2006 @@ -38,12 +38,31 @@ gfs::+swp-noactivate+ gfs::+swp-nocopybits+)) -(defun perform-layout (win width-hint height-hint) +;;; +;;; methods +;;; + +(defmethod initialize-instance :after ((layout layout-manager) + &key style margins horizontal-margins vertical-margins + &allow-other-keys) + (setf (style-of layout) (if (listp style) style (list style))) + (unless (null margins) + (setf (left-margin-of layout) margins) + (setf (right-margin-of layout) margins) + (setf (top-margin-of layout) margins) + (setf (bottom-margin-of layout) margins)) + (unless (null horizontal-margins) + (setf (left-margin-of layout) horizontal-margins) + (setf (right-margin-of layout) horizontal-margins)) + (unless (null vertical-margins) + (setf (top-margin-of layout) vertical-margins) + (setf (bottom-margin-of layout) vertical-margins))) + +(defmethod perform ((layout layout-manager) win width-hint height-hint) "Calls compute-layout for a window and then handles the actual moving and resizing of its children." - (let ((layout (layout-of win)) - (kids nil) - (hdwp nil)) - (when (and (layout-p win) layout) + (let ((kids nil) + (hdwp (cffi:null-pointer))) + (when (layout-p win) (setf kids (compute-layout layout win width-hint height-hint)) (setf hdwp (gfs::begin-defer-window-pos (length kids))) (loop for k in kids Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Sun Apr 30 02:08:25 2006 @@ -156,10 +156,10 @@ m))) (defmethod (setf maximum-size) :after (max-size (win top-level)) - (unless (gfs:disposed-p win) + (unless (or (gfs:disposed-p win) (null (layout-of win))) (let ((size (constrain-new-size max-size (size win) #'min))) (setf (size win) size) - (perform-layout win (gfs:size-width size) (gfs:size-height size))))) + (perform (layout-of win) win (gfs:size-width size) (gfs:size-height size))))) (defmethod (setf menu-bar) :before ((m menu) (win top-level)) (declare (ignore m)) @@ -178,10 +178,10 @@ (gfs::draw-menu-bar hwnd))) (defmethod (setf minimum-size) :after (min-size (win top-level)) - (unless (gfs:disposed-p win) + (unless (or (gfs:disposed-p win) (null (layout-of win))) (let ((size (constrain-new-size min-size (size win) #'max))) (setf (size win) size) - (perform-layout win (gfs:size-width size) (gfs:size-height size))))) + (perform (layout-of win) win (gfs:size-width size) (gfs:size-height size))))) (defmethod print-object ((self top-level) stream) (print-unreadable-object (self stream :type t) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Apr 30 02:08:25 2006 @@ -174,14 +174,15 @@ (defmethod enable-layout ((win window) flag) (setf (slot-value win 'layout-p) flag) - (if flag + (if (and flag (layout-of win)) (let ((sz (client-size win))) - (perform-layout win (gfs:size-width sz) (gfs:size-height sz))))) + (perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz))))) (defmethod event-resize ((d event-dispatcher) (win window) time size type) (declare (ignorable d time size type)) - (let ((sz (client-size win))) - (perform-layout win (gfs:size-width sz) (gfs:size-height sz)))) + (unless (null (layout-of win)) + (let ((sz (client-size win))) + (perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz))))) (defmethod focus-p :before ((win window)) (if (gfs:disposed-p win) @@ -207,11 +208,13 @@ pnt)) (defmethod layout ((win window)) - (let ((sz (client-size win))) - (perform-layout win (gfs:size-width sz) (gfs:size-height sz)))) + (unless (null (layout-of win)) + (let ((sz (client-size win))) + (perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz))))) (defmethod pack ((win window)) - (perform-layout win -1 -1) + (unless (null (layout-of win)) + (perform (layout-of win) win -1 -1)) (call-next-method)) (defmethod preferred-size ((win window) width-hint height-hint)