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'). +@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: +@table @code +@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 +@item :miniframe +a resizable window with a shorter than normal caption; has a close box +but no system menu or minimize/maximize buttons +@item :palette +similar to the @code{:miniframe} style, but in this case the window +does not have resize frame +@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 +@end table +@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)