April 2007 - graphic-forms-cvs@common-lisp.net

[graphic-forms-cvs] r454 - in branches/graphic-forms-newtypes/src: demos/unblocked uitoolkit/widgets
by junrue＠common-lisp.net 01 Apr '07

01 Apr '07

Author: junrue Date: Sun Apr 1 00:30:17 2007 New Revision: 454 Modified: branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-controller.lisp branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-window.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/status-bar.lisp Log: implemented text and (setf text) for status-bar; unblocked now displays shape count and points scored via status-bar messages Modified: branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-controller.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-controller.lisp (original) +++ branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-controller.lisp Sun Apr 1 00:30:17 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; unblocked-controller.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -37,11 +37,13 @@ (defun ctrl-start-game () (model-new) + (update-status-bar "Ready.") (update-panel (get-scoreboard-panel)) (update-panel (get-tiles-panel))) (defun ctrl-restart-game () (model-rollback) + (update-status-bar "Ready.") (update-panel (get-scoreboard-panel)) (update-panel (get-tiles-panel))) @@ -82,10 +84,17 @@ (let ((tile-pnt (window->tiles point))) (when (and (eql button :left-button) shape-pnts) (if (and tile-pnt (find tile-pnt shape-pnts :test #'eql-point)) - (let ((prev-level (model-level))) + (let ((prev-level (model-level)) + (orig-score (score-of *game*))) (update-model-score shape-pnts) + (update-status-bar (format nil + "Removed ~d tiles for ~d points." + (length shape-pnts) + (- (score-of *game*) orig-score))) (if (> (model-level) prev-level) - (regenerate-model-tiles) + (progn + (regenerate-model-tiles) + (update-status-bar "Ready.")) (update-model-tiles shape-pnts)) (update-panel (get-scoreboard-panel)) (update-panel (get-tiles-panel))) Modified: branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-window.lisp (original) +++ branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-window.lisp Sun Apr 1 00:30:17 2007 @@ -61,6 +61,10 @@ (update-buffer (gfw:dispatcher panel)) (gfw:redraw panel)) +(defun update-status-bar (msg) + (if *unblocked-win* + (setf (gfw:text (gfw:status-bar-of *unblocked-win*)) msg))) + (defun reveal-unblocked (disp item) (declare (ignore disp item)) (ctrl-reveal-move)) @@ -129,7 +133,8 @@ (new-unblocked nil nil) (let ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*))) - (setf (gfw:image *unblocked-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "unblocked.ico")))) + (setf (gfw:image *unblocked-win*) + (make-instance 'gfg:icon-bundle :file (merge-pathnames "unblocked.ico")))) (gfw:show *unblocked-win* t))) (defun unblocked () Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/status-bar.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/status-bar.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/status-bar.lisp Sun Apr 1 00:30:17 2007 @@ -127,3 +127,9 @@ (widths (stb-get-border-widths self))) (gfs:make-size :width 0 :height (+ (gfs:size-height tmp-size) (* (second widths) 2) 1)))) + +(defmethod text ((sbar status-bar)) + (stb-get-text sbar 0)) + +(defmethod (setf text) (str (sbar status-bar)) + (stb-set-text sbar str))

1 0

[graphic-forms-cvs] r453 - in trunk/src: tests/uitoolkit uitoolkit/widgets
by junrue＠common-lisp.net 01 Apr '07

01 Apr '07

Author: junrue Date: Sat Mar 31 23:02:09 2007 New Revision: 453 Modified: trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/window.lisp Log: stop double-counting status-bar height; add additional testcase Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Sat Mar 31 23:02:09 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; widget-tester.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -275,7 +275,7 @@ (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (setf *widget-tester-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'widget-tester-events) :layout (make-instance 'gfw:heap-layout) - :style '(:frame))) + :style '(:frame :status-bar))) (let* ((layout (gfw:layout-of *widget-tester-win*)) (test-panels (list (populate-list-box-test-panel) (populate-slider-test-panel))) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Sat Mar 31 23:02:09 2007 @@ -122,9 +122,6 @@ (let ((kid-count (length (data-of self))) (horz-margin-total (+ (left-margin-of self) (right-margin-of self))) (vert-margin-total (+ (top-margin-of self) (bottom-margin-of self))) - (sbar-height (if (status-bar-of container) - (gfs:size-height (preferred-size (status-bar-of container) -1 -1)) - 0)) (vertical (find :vertical (style-of self))) (horizontal (find :horizontal (style-of self)))) (let ((spacing-total (* (spacing-of self) (1- kid-count))) @@ -140,16 +137,14 @@ (gfs:make-size :width (+ (flow-data-distance-total state) horz-margin-total spacing-total) - :height (- (+ (flow-data-max-extent state) - vert-margin-total) - sbar-height))) + :height (+ (flow-data-max-extent state) + vert-margin-total))) (vertical (gfs:make-size :width (+ (flow-data-max-extent state) horz-margin-total) - :height (- (+ (flow-data-distance-total state) + :height (+ (flow-data-distance-total state) vert-margin-total - spacing-total) - sbar-height))) + spacing-total))) (t (error 'gfs:toolkit-error :detail (format nil "unrecognized flow layout style: ~a" (style-of self)))))))) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Sat Mar 31 23:02:09 2007 @@ -68,14 +68,6 @@ ;;; methods ;;; -(defmethod compute-outer-size ((self top-level) desired-client-size) - (declare (ignore desired-client-size)) - (let ((size (call-next-method)) - (sbar (status-bar-of self))) - (if sbar - (incf (gfs:size-height size) (gfs:size-height (preferred-size sbar -1 -1)))) - size)) - (defmethod compute-style-flags ((self top-level) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags 0) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sat Mar 31 23:02:09 2007 @@ -75,7 +75,7 @@ (let* ((tc (thread-context)) (child (get-widget tc hwnd)) (parent (get-widget tc (cffi:make-pointer lparam)))) - (unless (or (null parent) (null child)) + (unless (or (null parent) (null child) (typep child 'status-bar)) (let ((ancestor-hwnd (gfs::get-ancestor (gfs:handle child) gfs::+ga-parent+)) (tmp-list (child-visitor-results tc))) (if (cffi:pointer-eq (gfs:handle parent) ancestor-hwnd)

1 0

[graphic-forms-cvs] r452 - in branches/graphic-forms-newtypes/src: tests/uitoolkit uitoolkit/widgets
by junrue＠common-lisp.net 01 Apr '07

01 Apr '07

Author: junrue Date: Sat Mar 31 23:01:47 2007 New Revision: 452 Modified: branches/graphic-forms-newtypes/src/tests/uitoolkit/widget-tester.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/flow-layout.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/window.lisp Log: stop double-counting status-bar height; add additional testcase Modified: branches/graphic-forms-newtypes/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/tests/uitoolkit/widget-tester.lisp (original) +++ branches/graphic-forms-newtypes/src/tests/uitoolkit/widget-tester.lisp Sat Mar 31 23:01:47 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; widget-tester.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -275,7 +275,7 @@ (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (setf *widget-tester-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'widget-tester-events) :layout (make-instance 'gfw:heap-layout) - :style '(:frame))) + :style '(:frame :status-bar))) (let* ((layout (gfw:layout-of *widget-tester-win*)) (test-panels (list (populate-list-box-test-panel) (populate-slider-test-panel))) Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/flow-layout.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/flow-layout.lisp Sat Mar 31 23:01:47 2007 @@ -122,9 +122,6 @@ (let ((kid-count (length (data-of self))) (horz-margin-total (+ (left-margin-of self) (right-margin-of self))) (vert-margin-total (+ (top-margin-of self) (bottom-margin-of self))) - (sbar-height (if (status-bar-of container) - (gfs:size-height (preferred-size (status-bar-of container) -1 -1)) - 0)) (vertical (find :vertical (style-of self))) (horizontal (find :horizontal (style-of self)))) (let ((spacing-total (* (spacing-of self) (1- kid-count))) @@ -140,16 +137,14 @@ (gfs:make-size :width (+ (flow-data-distance-total state) horz-margin-total spacing-total) - :height (- (+ (flow-data-max-extent state) - vert-margin-total) - sbar-height))) + :height (+ (flow-data-max-extent state) + vert-margin-total))) (vertical (gfs:make-size :width (+ (flow-data-max-extent state) horz-margin-total) - :height (- (+ (flow-data-distance-total state) - vert-margin-total - spacing-total) - sbar-height))) + :height (+ (flow-data-distance-total state) + vert-margin-total + spacing-total))) (t (error 'gfs:toolkit-error :detail (format nil "unrecognized flow layout style: ~a" (style-of self)))))))) Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp Sat Mar 31 23:01:47 2007 @@ -68,14 +68,6 @@ ;;; methods ;;; -(defmethod compute-outer-size ((self top-level) desired-client-size) - (declare (ignore desired-client-size)) - (let ((size (call-next-method)) - (sbar (status-bar-of self))) - (if sbar - (incf (gfs:size-height size) (gfs:size-height (preferred-size sbar -1 -1)))) - size)) - (defmethod compute-style-flags ((self top-level) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags 0) Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/window.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/window.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/window.lisp Sat Mar 31 23:01:47 2007 @@ -75,7 +75,7 @@ (let* ((tc (thread-context)) (child (get-widget tc hwnd)) (parent (get-widget tc (cffi:make-pointer lparam)))) - (unless (or (null parent) (null child)) + (unless (or (null parent) (null child) (typep child 'status-bar)) (let ((ancestor-hwnd (gfs::get-ancestor (gfs:handle child) gfs::+ga-parent+)) (tmp-list (child-visitor-results tc))) (if (cffi:pointer-eq (gfs:handle parent) ancestor-hwnd)

1 0