[graphic-forms-cvs] r17 - in trunk: . src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Tue Feb 21 06:31:23 UTC 2006
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))
More information about the Graphic-forms-cvs
mailing list