Author: junrue Date: Tue Feb 21 00:31:22 2006 New Revision: 17
Added: trunk/src/uitoolkit/widgets/text-label.lisp Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: implemented text-label widget, although mouse events currently cause a foreign type error
Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Tue Feb 21 00:31:22 2006 @@ -97,6 +97,7 @@ (:file "item") (:file "widget") (:file "control") + (:file "text-label") (:file "button") (:file "widget-with-items") (:file "menu")
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Tue Feb 21 00:31:22 2006 @@ -35,8 +35,9 @@
(defconstant +btn-text-before+ "Push Me") (defconstant +btn-text-after+ "Again!") +(defconstant +label-text+ "Test Label")
-(defvar *button-counter* 0) +(defvar *widget-counter* 0)
(defparameter *layout-tester-win* nil)
@@ -68,7 +69,7 @@ :initform 0)))
(defun add-layout-tester-widget (widget-class subtype) - (let* ((be (make-instance 'layout-tester-widget-events :id *button-counter*)) + (let* ((be (make-instance 'layout-tester-widget-events :id *widget-counter*)) (w (make-instance widget-class :dispatcher be))) (cond ((eql subtype :push-button) @@ -80,10 +81,12 @@ (format nil "~d ~a" (id be) +btn-text-before+)) (progn (setf flag nil) - (format nil "~d ~a" (id be) +btn-text-after+)))))) - (incf *button-counter*))) + (format nil "~d ~a" (id be) +btn-text-after+))))))) + ((eql subtype :text-label) + (setf (toggle-fn be) #'(lambda () (format nil "~d ~a" (id be) +label-text+))))) (gfw:realize w *layout-tester-win* subtype) - (setf (gfw:text w) (funcall (toggle-fn be))))) + (setf (gfw:text w) (funcall (toggle-fn be))) + (incf *widget-counter*)))
(defmethod gfw:event-select ((d layout-tester-widget-events) btn time rect) (declare (ignorable time rect)) @@ -167,11 +170,13 @@ (exit-layout-tester))
(defun run-layout-tester-internal () - (setf *button-counter* 0) + (setf *widget-counter* 0) (let ((menubar nil) (exit-disp (make-instance 'layout-tester-exit-dispatcher)) (pack-disp (make-instance 'pack-layout-dispatcher)) (add-btn-disp (make-instance 'add-child-dispatcher)) + (add-text-label-disp (make-instance 'add-child-dispatcher :widget-class 'gfw::text-label + :subtype :text-label)) (rem-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'remove-child-dispatcher)) (vis-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'visibility-child-dispatcher :check-test-fn #'gfw:visible-p))) @@ -182,7 +187,8 @@ (:menuitem "E&xit" :dispatcher ,exit-disp)) ((:menu "&Children") (:menuitem :submenu ((:menu "Add") - (:menuitem "Button" :dispatcher ,add-btn-disp))) + (:menuitem "Button" :dispatcher ,add-btn-disp) + (:menuitem "Label" :dispatcher ,add-text-label-disp))) (:menuitem :submenu ((:menu "Remove" :dispatcher ,rem-menu-disp))) (:menuitem :submenu ((:menu "Set Visibility" :dispatcher ,vis-menu-disp)))) ((:menu "&Window")
Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Tue Feb 21 00:31:22 2006 @@ -34,6 +34,7 @@ (in-package :graphic-forms.uitoolkit.system)
(defconstant +button-classname+ "button") +(defconstant +static-classname+ "static")
(defconstant +bi-rgb+ 0) (defconstant +bi-rle8+ 1) @@ -467,6 +468,39 @@ (defconstant +sm-remotecontrol+ #x2001) (defconstant +sm-caretblinkingenabled+ #x2002)
+(defconstant +ss-left+ #x00000000) +(defconstant +ss-center+ #x00000001) +(defconstant +ss-right+ #x00000002) +(defconstant +ss-icon+ #x00000003) +(defconstant +ss-blackrect+ #x00000004) +(defconstant +ss-grayrect+ #x00000005) +(defconstant +ss-whiterect+ #x00000006) +(defconstant +ss-blackframe+ #x00000007) +(defconstant +ss-grayframe+ #x00000008) +(defconstant +ss-whiteframe+ #x00000009) +(defconstant +ss-useritem+ #x0000000A) +(defconstant +ss-simple+ #x0000000B) +(defconstant +ss-leftnowordwrap+ #x0000000C) +(defconstant +ss-ownerdraw+ #x0000000D) +(defconstant +ss-bitmap+ #x0000000E) +(defconstant +ss-enhmetafile+ #x0000000F) +(defconstant +ss-etchedhorz+ #x00000010) +(defconstant +ss-etchedvert+ #x00000011) +(defconstant +ss-etchedframe+ #x00000012) +(defconstant +ss-typemask+ #x0000001F) +(defconstant +ss-realsizecontrol+ #x00000040) +(defconstant +ss-noprefix+ #x00000080) +(defconstant +ss-notify+ #x00000100) +(defconstant +ss-centerimage+ #x00000200) +(defconstant +ss-rightjust+ #x00000400) +(defconstant +ss-realsizeimage+ #x00000800) +(defconstant +ss-sunken+ #x00001000) +(defconstant +ss-editcontrol+ #x00002000) +(defconstant +ss-endellipsis+ #x00004000) +(defconstant +ss-pathellipsis+ #x00008000) +(defconstant +ss-wordellipsis+ #x0000C000) +(defconstant +ss-ellipsismask+ #x0000C000) + (defconstant +sw-hide+ 0) (defconstant +sw-shownormal+ 1) (defconstant +sw-normal+ 1)
Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Tue Feb 21 00:31:22 2006 @@ -41,40 +41,34 @@ (declare (ignore btn)) (let ((std-flags 0) (ex-flags 0)) - (mapcar #'(lambda (sym) - (cond - ;; primary button styles - ;; - ((eq sym :check-box) - (setf std-flags gfs::+bs-checkbox+)) - ((eq sym :default-button) - (setf std-flags gfs::+bs-defpushbutton+)) - ((eq sym :push-button) - (setf std-flags gfs::+bs-pushbutton+)) - ((eq sym :radio-button) - (setf std-flags gfs::+bs-radiobutton+)) - ((eq sym :toggle-button) - (setf std-flags gfs::+bs-pushbox+)))) - (flatten style)) + (setf style (flatten style)) + ;; FIXME: check whether any of the primary button + ;; styles were specified, default to :push-button + ;; + (loop for sym in style + do (cond + ;; primary button styles + ;; + ((eq sym :check-box) + (setf std-flags gfs::+bs-checkbox+)) + ((eq sym :default-button) + (setf std-flags gfs::+bs-defpushbutton+)) + ((eq sym :push-button) + (setf std-flags gfs::+bs-pushbutton+)) + ((eq sym :radio-button) + (setf std-flags gfs::+bs-radiobutton+)) + ((eq sym :toggle-button) + (setf std-flags gfs::+bs-pushbox+)))) (values std-flags ex-flags)))
(defmethod preferred-size ((btn button) width-hint height-hint) - (declare (ignorable width-hint height-hint)) - (let ((hwnd (gfi:handle btn)) - (sz (gfi:make-size)) - (count (length (text btn)))) - (cffi:with-foreign-object (tm-ptr 'gfs::textmetrics) - (cffi:with-foreign-slots ((gfs::tmheight - gfs::tmexternalleading - gfs::tmavgcharwidth) - tm-ptr gfs::textmetrics) - (gfs:with-retrieved-dc (hwnd dc) - (if (zerop (gfs::get-text-metrics dc tm-ptr)) - (error 'gfs:win32-error :detail "get-text-metrics failed")) - (setf (gfi:size-width sz) (* gfs::tmavgcharwidth (+ count 2))) - (let ((tmp (+ gfs::tmexternalleading gfs::tmheight) )) - (setf (gfi:size-height sz) (+ (floor (/ (* tmp 7) 5)) 1)))))) - sz)) + (text-widget-preferred-size btn + width-hint + height-hint + #'(lambda (char-width char-count) + (* char-width (+ char-count 2))) + #'(lambda (char-height) + (+ (floor (/ (* char-height 7) 5)) 1))))
(defmethod realize ((btn button) parent &rest style) (multiple-value-bind (std-style ex-style)
Added: trunk/src/uitoolkit/widgets/text-label.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/text-label.lisp Tue Feb 21 00:31:22 2006 @@ -0,0 +1,100 @@ +;;;; +;;;; text-label.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.widgets) + +;;; +;;; methods +;;; + +(defmethod compute-style-flags ((label text-label) &rest style) + (declare (ignore label)) + (let ((std-flags 0) + (ex-flags 0)) + (setf style (flatten style)) + (unless (or (find :beginning style) + (find :center style) + (find :end style)) + (setf std-flags gfs::+ss-leftnowordwrap+)) + (loop for sym in style + do (cond + ;; primary static styles + ;; + ((eq sym :beginning) + (setf std-flags gfs::+ss-leftnowordwrap+)) ; FIXME: i18n + ((eq sym :center) + (setf std-flags gfs::+ss-center+)) + ((eq sym :end) + (setf std-flags gfs::+ss-right+)) ; FIXME: i18n + + ;; styles that can be combined + ;; + ((eq sym :ellipsis) + (setf std-flags (logior std-flags gfs::+ss-endellipsis+))) + ((eq sym :raised) + (setf std-flags (logand (lognot gfs::+ss-sunken+) std-flags)) + (setf std-flags (logior std-flags gfs::+ss-etchedframe+))) + ((eq sym :sunken) + (setf std-flags (logand (lognot gfs::+ss-etchedframe+) std-flags)) + (setf std-flags (logior std-flags gfs::+ss-sunken+))) + ((eq sym :wrap) + (setf std-flags (logand (lognot gfs::+ss-leftnowordwrap+) std-flags)) + (setf std-flags (logior std-flags gfs::+ss-left+))))) + (values std-flags ex-flags))) + +(defmethod preferred-size ((label text-label) width-hint height-hint) + (text-widget-preferred-size label + width-hint + height-hint + #'(lambda (char-width char-count) + (+ (* char-width char-count) 2)) + #'(lambda (char-height) + (+ char-height 2)))) + +(defmethod realize ((label text-label) parent &rest style) + (multiple-value-bind (std-style ex-style) + (compute-style-flags label style) + (let ((hwnd (create-window gfs::+static-classname+ + " " + (gfi:handle parent) + (logior std-style gfs::+ws-child+ gfs::+ws-visible+) + ex-style))) + (if (not hwnd) + (error 'gfs:win32-error :detail "create-window failed")) + (setf (slot-value label 'gfi:handle) hwnd)))) + +(defmethod text ((label text-label)) + (get-widget-text label)) + +(defmethod (setf text) (str (label text-label)) + (set-widget-text label str))
Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Tue Feb 21 00:31:22 2006 @@ -65,6 +65,12 @@ (defclass button (control) () (:documentation "This class represents selectable controls that issue notifications when clicked."))
+(defclass image-label (control) () + (:documentation "This class represents non-selectable controls that display an image.")) + +(defclass text-label (control) () + (:documentation "This class represents non-selectable controls that display a string.")) + (defclass widget-with-items (widget) ((items :accessor items
Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Tue Feb 21 00:31:22 2006 @@ -123,3 +123,23 @@ (if (gfi:disposed-p w) (error 'gfi:disposed-error)) (gfs::set-window-text (gfi:handle w) str)) + +(defun text-widget-preferred-size (widget width-hint height-hint width-calc height-calc) + ;; FIXME: implement width-hint and height-hint constraints + ;; + (declare (ignorable width-hint height-hint)) + (let ((hwnd (gfi:handle widget)) + (sz (gfi:make-size)) + (count (length (text widget)))) + (cffi:with-foreign-object (tm-ptr 'gfs::textmetrics) + (cffi:with-foreign-slots ((gfs::tmheight + gfs::tmexternalleading + gfs::tmavgcharwidth) + tm-ptr gfs::textmetrics) + (gfs:with-retrieved-dc (hwnd dc) + (if (zerop (gfs::get-text-metrics dc tm-ptr)) + (error 'gfs:win32-error :detail "get-text-metrics failed")) + (setf (gfi:size-width sz) (funcall width-calc gfs::tmavgcharwidth count)) + (setf (gfi:size-height sz) (funcall height-calc (+ gfs::tmexternalleading + gfs::tmheight)))))) + sz))