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))