[graphic-forms-cvs] r157 - in trunk: . src/demos/unblocked src/tests/uitoolkit
junrue at common-lisp.net
junrue at common-lisp.net
Thu Jun 22 17:10:05 UTC 2006
Author: junrue
Date: Thu Jun 22 13:10:03 2006
New Revision: 157
Added:
trunk/src/demos/unblocked/about.bmp (contents, props changed)
trunk/src/demos/unblocked/blue-tile.bmp
- copied unchanged from r90, trunk/src/tests/uitoolkit/blue-tile.bmp
trunk/src/demos/unblocked/brown-tile.bmp
- copied unchanged from r90, trunk/src/tests/uitoolkit/brown-tile.bmp
trunk/src/demos/unblocked/gold-tile.bmp
- copied unchanged from r90, trunk/src/tests/uitoolkit/gold-tile.bmp
trunk/src/demos/unblocked/green-tile.bmp
- copied unchanged from r90, trunk/src/tests/uitoolkit/green-tile.bmp
trunk/src/demos/unblocked/pink-tile.bmp
- copied unchanged from r90, trunk/src/tests/uitoolkit/pink-tile.bmp
trunk/src/demos/unblocked/red-tile.bmp
- copied unchanged from r90, trunk/src/tests/uitoolkit/red-tile.bmp
Removed:
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/pink-tile.bmp
trunk/src/tests/uitoolkit/red-tile.bmp
Modified:
trunk/build.lisp
trunk/graphic-forms-tests.asd
trunk/src/demos/unblocked/tiles-panel.lisp
trunk/src/demos/unblocked/unblocked-window.lisp
trunk/src/tests/uitoolkit/image-tester.lisp
trunk/src/tests/uitoolkit/layout-tester.lisp
trunk/tests.lisp
Log:
added about dialog to unblocked demo; revised code that loads images for tests
Modified: trunk/build.lisp
==============================================================================
--- trunk/build.lisp (original)
+++ trunk/build.lisp Thu Jun 22 13:10:03 2006
@@ -45,7 +45,7 @@
(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 *cffi-dir* (concatenate 'string *asdf-repo-root* "cffi-060606/"))
(setf *closer-mop-dir* (concatenate 'string *asdf-repo-root* "closer-mop/"))
(setf *lw-compat-dir* (concatenate 'string *asdf-repo-root* "lw-compat/"))
(setf *gf-dir* (concatenate 'string *project-root* "graphic-forms/"))
Modified: trunk/graphic-forms-tests.asd
==============================================================================
--- trunk/graphic-forms-tests.asd (original)
+++ trunk/graphic-forms-tests.asd Thu Jun 22 13:10:03 2006
@@ -31,8 +31,6 @@
;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;;
-; (in-package #:graphic-forms-system)
-
(defpackage #:graphic-forms.uitoolkit.tests
(:nicknames #:gft)
(:use :common-lisp :lisp-unit)
Added: trunk/src/demos/unblocked/about.bmp
==============================================================================
Binary file. No diff available.
Modified: trunk/src/demos/unblocked/tiles-panel.lisp
==============================================================================
--- trunk/src/demos/unblocked/tiles-panel.lisp (original)
+++ trunk/src/demos/unblocked/tiles-panel.lisp Thu Jun 22 13:10:03 2006
@@ -89,7 +89,9 @@
(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)
+ (gfg:load image (complete-pathname (concatenate 'string
+ "src/demos/unblocked/"
+ filename)))
(setf (gethash kind table) image)
(incf kind)))))
Modified: trunk/src/demos/unblocked/unblocked-window.lisp
==============================================================================
--- trunk/src/demos/unblocked/unblocked-window.lisp (original)
+++ trunk/src/demos/unblocked/unblocked-window.lisp Thu Jun 22 13:10:03 2006
@@ -34,11 +34,15 @@
(in-package :graphic-forms.uitoolkit.tests)
(defconstant +spacing+ 4)
-(defconstant +margin+ 4)
+(defconstant +margin+ 4)
-(defvar *scoreboard-panel* nil)
-(defvar *tiles-panel* nil)
-(defvar *unblocked-win* nil)
+(defvar *scoreboard-panel* nil)
+(defvar *unblocked-startup-dir* nil)
+(defvar *tiles-panel* nil)
+(defvar *unblocked-win* nil)
+
+(defun complete-pathname (path-segment)
+ (merge-pathnames path-segment *unblocked-startup-dir*))
(defun get-tiles-panel ()
*tiles-panel*)
@@ -76,7 +80,78 @@
(declare (ignore window time))
(quit-unblocked disp nil nil nil))
+(defclass unblocked-about-dialog-events (gfw:event-dispatcher) ())
+
+(defmethod gfw:event-close ((disp unblocked-about-dialog-events) (dlg gfw:dialog) time)
+ (declare (ignore time))
+ (call-next-method)
+ (gfs:dispose dlg))
+
+(defun about-unblocked (disp item time rect)
+ (declare (ignore disp item time rect))
+ (let* ((image (make-instance 'gfg:image :file (complete-pathname "src/demos/unblocked/about.bmp")))
+ (dlg (make-instance 'gfw:dialog :owner *unblocked-win*
+ :dispatcher (make-instance 'unblocked-about-dialog-events)
+ :layout (make-instance 'gfw:flow-layout
+ :margins 8
+ :spacing 8)
+ :style '(:owner-modal)
+ :text (concatenate 'string "About UnBlocked")))
+ (label (make-instance 'gfw:label :parent dlg))
+ (text-panel (make-instance 'gfw:panel
+ :layout (make-instance 'gfw:flow-layout
+ :margins 0
+ :spacing 2
+ :style '(:vertical))
+ :parent dlg))
+ (line1 (make-instance 'gfw:label
+ :parent text-panel
+ :text "UnBlocked version 0.4"))
+ (line2 (make-instance 'gfw:label
+ :parent text-panel
+ :text " "))
+ (line3 (make-instance 'gfw:label
+ :parent text-panel
+ :text (format nil "Copyright ~c 2006 by Jack D. Unrue" (code-char 169))))
+ (line4 (make-instance 'gfw:label
+ :parent text-panel
+ :text "All Rights Reserved."))
+ (line5 (make-instance 'gfw:label
+ :parent text-panel
+ :text " "))
+ (line6 (make-instance 'gfw:label
+ :parent text-panel
+ :text " "))
+ (btn-panel (make-instance 'gfw:panel
+ :parent dlg
+ :layout (make-instance 'gfw:flow-layout
+ :margins 0
+ :spacing 0
+ :style '(:vertical :normalize))))
+ (close-btn (make-instance 'gfw:button
+ :callback (lambda (disp btn time rect)
+ (declare (ignore disp btn time rect))
+ (gfs:dispose dlg))
+ :style '(:cancel-button)
+ :text "Close"
+ :parent btn-panel)))
+ (declare (ignore line1 line2 line3 line4 line5 line6 close-btn))
+ (unwind-protect
+ (gfg:with-image-transparency (image (gfs:make-point))
+ (setf (gfw:image label) image))
+ (gfs:dispose image))
+ (gfw:pack dlg)
+ (gfw:center-on-owner dlg)
+ ;; FIXME: Close button not getting initial focus; looks like
+ ;; labels or panels are getting it, because I can tab to the
+ ;; button with enough tabs
+ (gfw:show dlg t)))
+
(defun unblocked-startup ()
+#+clisp
+ (setf *unblocked-startup-dir* (ext:cd))
+#+lispworks
+ (setf *unblocked-startup-dir* (hcl:get-working-directory))
(let ((menubar (gfw:defmenu ((:item "&File"
:submenu ((:item "&New" :callback #'new-unblocked)
(:item "&Restart" :callback #'restart-unblocked)
@@ -84,7 +159,7 @@
(:item "" :separator)
(:item "E&xit" :callback #'quit-unblocked)))
(:item "&Help"
- :submenu ((:item "&About"))))))
+ :submenu ((:item "&About" :callback #'about-unblocked))))))
(scoreboard-buffer-size (compute-scoreboard-size))
(tile-buffer-size (gfs:make-size :width (+ (* +horz-tile-count+ +tile-bmp-width+)
2)
Modified: trunk/src/tests/uitoolkit/image-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/image-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/image-tester.lisp Thu Jun 22 13:10:03 2006
@@ -94,6 +94,7 @@
(gfw:shutdown 0))
(defun run-image-tester-internal ()
+ (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*))
(let ((menubar nil))
(setf *happy-image* (make-instance 'gfg:image))
(setf *bw-image* (make-instance 'gfg:image))
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp Thu Jun 22 13:10:03 2006
@@ -383,6 +383,7 @@
(exit-layout-tester))
(defun run-layout-tester-internal ()
+ (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*))
(setf *widget-counter* 0)
(let ((menubar nil)
(pack-disp (make-instance 'pack-layout-dispatcher))
Modified: trunk/tests.lisp
==============================================================================
--- trunk/tests.lisp (original)
+++ trunk/tests.lisp Thu Jun 22 13:10:03 2006
@@ -36,5 +36,6 @@
(load (compile-file *lisp-unit-file*))
(defun load-tests ()
- (setf *default-pathname-defaults* (parse-namestring *gf-tests-dir*))
+#+lispworks
+ (hcl:change-directory *gf-dir*)
(asdf:operate 'asdf:load-op :graphic-forms-tests))
More information about the Graphic-forms-cvs
mailing list