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)
