Author: junrue Date: Mon Jun 5 13:18:09 2006 New Revision: 151
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/graphics/font.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: enabled and fixed the :check-box, :radio-button, and :toggle button styles; fixed a problem with creating a font with an existing font handle
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Jun 5 13:18:09 2006 @@ -35,7 +35,7 @@
(defconstant +btn-text-before+ "Push Me") (defconstant +btn-text-after+ "Again!") -(defconstant +label-text+ "Test Label") +(defconstant +label-text+ "Label") (defconstant +margin-delta+ 4) (defconstant +spacing-delta+ 3)
@@ -86,30 +86,51 @@ (declare (ignore win)) "Test Panel")
+(defun create-button-toggler (be) + (let ((flag nil)) + (lambda () + (if (null flag) + (progn + (setf flag t) + (format nil "~d ~a" (id be) +btn-text-before+)) + (progn + (setf flag nil) + (format nil "~d ~a" (id be) +btn-text-after+)))))) + (defun add-layout-tester-widget (widget-class subtype) - (let* ((be (make-instance 'layout-tester-widget-events :id *widget-counter*)) - (w (make-instance widget-class :parent *layout-tester-win* :dispatcher be))) + (let ((be (make-instance 'layout-tester-widget-events :id *widget-counter*)) + (w nil)) (cond - ((eql subtype :push-button) - (setf (toggle-fn be) (let ((flag nil)) - (lambda () - (if (null flag) - (progn - (setf flag t) - (format nil "~d ~a" (id be) +btn-text-before+)) - (progn - (setf flag nil) - (format nil "~d ~a" (id be) +btn-text-after+)))))) + ((or (eql subtype :check-box) + (eql subtype :push-button) + (eql subtype :radio-button) + (eql subtype :toggle-button)) + (setf w (make-instance widget-class + :parent *layout-tester-win* + :dispatcher be + :style (list subtype))) + (setf (toggle-fn be) (create-button-toggler be)) (setf (gfw:text w) (funcall (toggle-fn be)))) ((eql subtype :image-label) ;; NOTE: we are leaking a bitmap handle by not tracking the ;; image being created here + (setf w (make-instance widget-class + :parent *layout-tester-win* + :dispatcher be)) (setf (gfg:background-color w) (gfg:background-color *layout-tester-win*)) (let ((tmp-image (make-instance 'gfg:image :file "happy.bmp"))) (gfg:with-image-transparency (tmp-image (gfs:make-point)) (setf (gfw:image w) tmp-image)))) ((eql subtype :text-label) - (setf (gfw:text w) (format nil "~d ~a" (id be) +label-text+)))) + (setf w (make-instance widget-class + :parent *layout-tester-win* + :dispatcher be + :style '(:sunken))) + (setf (gfw:text w) (format nil "~d ~a" (id be) +label-text+))) + (t + (setf w (make-instance widget-class + :parent *layout-tester-win* + :dispatcher be)))) (incf *widget-counter*)))
(defmethod gfw:event-select ((d layout-tester-widget-events) btn time rect) @@ -365,6 +386,9 @@ (let ((menubar nil) (pack-disp (make-instance 'pack-layout-dispatcher)) (add-btn-disp (make-instance 'add-child-dispatcher)) + (add-checkbox-disp (make-instance 'add-child-dispatcher :subtype :check-box)) + (add-radio-disp (make-instance 'add-child-dispatcher :subtype :radio-button)) + (add-toggle-disp (make-instance 'add-child-dispatcher :subtype :toggle-button)) (add-panel-disp (make-instance 'add-child-dispatcher :widget-class 'test-panel :subtype :panel)) (add-image-label-disp (make-instance 'add-child-dispatcher :widget-class 'gfw:label @@ -385,9 +409,12 @@ (:item "&Children" :submenu ((:item "Add" :submenu ((:item "Button" :dispatcher add-btn-disp) + (:item "Checkbox" :dispatcher add-checkbox-disp) (:item "Label - Image" :dispatcher add-image-label-disp) (:item "Label - Text" :dispatcher add-text-label-disp) - (:item "Panel" :dispatcher add-panel-disp))) + (:item "Panel" :dispatcher add-panel-disp) + (:item "Radiobutton" :dispatcher add-radio-disp) + (:item "Toggle" :dispatcher add-toggle-disp))) (:item "Remove" :dispatcher rem-menu-disp :submenu ((:item ""))) (:item "Visible" :dispatcher vis-menu-disp
Modified: trunk/src/uitoolkit/graphics/font.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/font.lisp (original) +++ trunk/src/uitoolkit/graphics/font.lisp Mon Jun 5 13:18:09 2006 @@ -44,4 +44,5 @@ (setf (slot-value fn 'gfs:handle) nil))
(defmethod initialize-instance :after ((font font) &key gc data &allow-other-keys) - (setf (slot-value font 'gfs:handle) (data->font (gfs:handle gc) data))) + (if gc + (setf (slot-value font 'gfs:handle) (data->font (gfs:handle gc) data))))
Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Mon Jun 5 13:18:09 2006 @@ -476,6 +476,12 @@ (id UINT))
(defcfun + ("LoadBitmapA" load-bitmap) + HANDLE + (hinst HANDLE) + (name LPTR)) ; LPTR to make it easier to pass constants like +obm-checkboxes+ + +(defcfun ("LoadImageA" load-image) HANDLE (instance HANDLE)
Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Mon Jun 5 13:18:09 2006 @@ -49,15 +49,15 @@ ;; primary button styles ;; ((eq sym :check-box) - (setf std-flags (logior std-flags gfs::+bs-checkbox+))) + (setf std-flags (logior std-flags gfs::+bs-autocheckbox+))) ((eq sym :default-button) (setf std-flags (logior std-flags gfs::+bs-defpushbutton+))) ((or (eq sym :push-button) (eq sym :cancel-button)) (setf std-flags (logior std-flags gfs::+bs-pushbutton+))) ((eq sym :radio-button) - (setf std-flags (logior std-flags gfs::+bs-radiobutton+))) + (setf std-flags (logior std-flags gfs::+bs-autoradiobutton+))) ((eq sym :toggle-button) - (setf std-flags (logior std-flags gfs::+bs-pushbox+))))) + (setf std-flags (logior std-flags gfs::+bs-autocheckbox+ gfs::+bs-pushlike+))))) (if (null style) (logior std-flags gfs::+bs-pushbutton+)) (values std-flags 0))) @@ -85,15 +85,33 @@ (init-control btn))
(defmethod preferred-size ((self button) width-hint height-hint) - (let ((size (widget-text-size self gfs::+dt-singleline+))) - (if (>= width-hint 0) - (setf (gfs:size-width size) width-hint) - (setf (gfs:size-width size) (+ (gfs:size-width size) - (* +horizontal-button-text-margin+ 2)))) - (if (>= height-hint 0) - (setf (gfs:size-height size) height-hint) - (setf (gfs:size-height size) (+ (gfs:size-height size) - ( * +vertical-button-text-margin+ 2)))) + (let ((text-size (widget-text-size self gfs::+dt-singleline+)) + (size (gfs:make-size)) + (b-width (* (border-width self) 2)) + (need-cb-size (intersection '(:check-box :radio-button) (style-of self))) + (cb-size (check-box-size))) + (cond + ((>= width-hint 0) + (setf (gfs:size-width size) width-hint)) + (need-cb-size + (setf (gfs:size-width size) (+ +horizontal-button-text-margin+ + (gfs:size-width cb-size) + (gfs:size-width text-size)))) + (t + (setf (gfs:size-width size) (+ b-width + (* +horizontal-button-text-margin+ 2) + (gfs:size-width text-size))))) + (cond + ((>= height-hint 0) + (setf (gfs:size-height size) height-hint)) + (need-cb-size + (setf (gfs:size-height size) (+ (* +vertical-button-text-margin+ 2) + (max (gfs:size-height text-size) + (gfs:size-height cb-size))))) + (t + (setf (gfs:size-height size) (+ b-width + (* +vertical-button-text-margin+ 2) + (gfs:size-height text-size))))) size))
(defmethod text ((self button)) @@ -103,6 +121,4 @@ (set-widget-text self str))
(defmethod text-baseline ((self button)) - (let ((font (gfg:font self)) - (gc (make-instance 'gfg:graphics-context :widget self))) - (+ +vertical-button-text-margin+ (gfg:ascent (gfg:metrics gc font))))) + (widget-text-baseline self +vertical-button-text-margin+))
Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Mon Jun 5 13:18:09 2006 @@ -103,12 +103,14 @@ (defmethod gfg:font ((self control)) (let ((font (font-of self))) (unless font - (let ((result (gfs::send-message (gfs:handle self) gfs::+wm-getfont+ 0 0))) + (let ((result (gfs::send-message (gfs:handle self) gfs::+wm-getfont+ 0 0)) + (gc nil)) (if (zerop result) - (let ((gc (make-instance 'gfg:graphics-context :widget self))) - (unwind-protect + (unwind-protect + (progn + (setf gc (make-instance 'gfg:graphics-context :widget self)) (setf font (gfg:font gc))) - (gfs:dispose gc)) + (gfs:dispose gc)) (setf font (make-instance 'gfg:font :handle (cffi:make-pointer result)))))) font))
Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Mon Jun 5 13:18:09 2006 @@ -314,8 +314,15 @@ (textcolor (text-color-of widget)) (ret-val 0)) (when widget - (if (not (typep widget 'label)) - (error 'gfs:toolkit-error :detail "incorrect widget type received WM_CTLCOLORSTATIC")) +#| + ;; temporarily disabling this until I decide whether this sort + ;; of sanity check really makes sense (for one thing, I didn't + ;; expect buttons with BS_CHECKBOX or BS_RADIOBUTTON to send + ;; WM_CTLCOLORSTATIC, but I guess it makes sense). + ;; + (if (not (or (typep widget 'button) (typep widget 'label))) + (warn 'gfs:toolkit-warning :detail "incorrect widget type received WM_CTLCOLORSTATIC")) +|# (let ((font (font-of widget))) (if font (gfs::select-object hdc (gfs:handle font))))
Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Mon Jun 5 13:18:09 2006 @@ -39,7 +39,7 @@
(defun compute-image-style-flags (style) (let ((flags (logior gfs::+ss-bitmap+ gfs::+ss-realsizeimage+ gfs::+ss-centerimage+))) - (when (find :raised style) + (when (find :raised style) ; FIXME: this style not yet working (setf flags (logand (lognot gfs::+ss-sunken+) flags)) (setf flags (logior flags gfs::+ss-etchedframe+))) (when (find :sunken style) @@ -50,23 +50,23 @@ (defun compute-text-style-flags (style) (let ((flags 0)) (unless (intersection style (list :beginning :center :end)) - (setf flags gfs::+ss-leftnowordwrap+)) + (setf flags (logior gfs::+ss-center+ gfs::+ss-centerimage+ flags))) (loop for sym in style do (cond ;; primary text static styles ;; ((eq sym :beginning) - (setf flags gfs::+ss-leftnowordwrap+)) ; FIXME: i18n + (setf flags (logior flags gfs::+ss-leftnowordwrap+))) ; FIXME: i18n ((eq sym :center) - (setf flags gfs::+ss-center+)) + (setf flags (logior flags gfs::+ss-center+))) ((eq sym :end) - (setf flags gfs::+ss-right+)) ; FIXME: i18n + (setf flags (logior flags gfs::+ss-right+))) ; FIXME: i18n
;; styles that can be combined ;; ((eq sym :ellipsis) (setf flags (logior flags gfs::+ss-endellipsis+))) - ((eq sym :raised) + ((eq sym :raised) ; FIXME: this style not yet working (setf flags (logand (lognot gfs::+ss-sunken+) flags)) (setf flags (logior flags gfs::+ss-etchedframe+))) ((eq sym :sunken) @@ -169,55 +169,54 @@ (setf (image label) image)))) (init-control label))
-(defmethod preferred-size ((label label) width-hint height-hint) - (declare (ignorable width-hint height-hint)) - (let* ((hwnd (gfs:handle label)) +(defmethod preferred-size ((self label) width-hint height-hint) + (let* ((hwnd (gfs:handle self)) (bits (gfs::get-window-long hwnd gfs::+gwl-style+)) - (b-width (border-width label)) - (sz nil)) + (b-width (* (border-width self) 2))) (if (= (logand bits gfs::+ss-bitmap+) gfs::+ss-bitmap+) - (let ((image (image label))) + (let ((image (image self))) (if image - (gfg:size image) + (let ((size (gfg:size image))) + (gfs:make-size :width (+ (gfs:size-width size) b-width) + :height (+ (gfs:size-height size) b-width))) (gfs:make-size))) - (let ((flags (logior gfs::+dt-editcontrol+ gfs::+dt-expandtabs+))) + (let ((flags (logior gfs::+dt-editcontrol+ gfs::+dt-expandtabs+)) + (size nil)) (if (and (= (logand bits gfs::+ss-left+) gfs::+ss-left+) (> width-hint 0)) (setf flags (logior flags gfs::+dt-wordbreak+))) - (setf sz (widget-text-size label flags)) + (setf size (widget-text-size self flags)) (if (>= width-hint 0) - (setf (gfs:size-width sz) width-hint)) + (setf (gfs:size-width size) width-hint) + (incf (gfs:size-width size) b-width)) (if (>= height-hint 0) - (setf (gfs:size-height sz) height-hint)) - (incf (gfs:size-width sz) (* b-width 2)) - (incf (gfs:size-height sz) (* b-width 2)) - sz)))) + (setf (gfs:size-height size) height-hint) + (incf (gfs:size-width size) b-width)) + size))))
-(defmethod text ((label label)) - (get-widget-text label)) +(defmethod text ((self label)) + (get-widget-text self))
-(defmethod (setf text) (str (label label)) - (let* ((hwnd (gfs:handle label)) +(defmethod (setf text) (str (self label)) + (let* ((hwnd (gfs:handle self)) (orig-flags (gfs::get-window-long hwnd gfs::+gwl-style+)) (etch-flags (logior (logand orig-flags gfs::+ss-etchedframe+) (logand orig-flags gfs::+ss-sunken+)))) (multiple-value-bind (std-flags ex-flags) - (compute-style-flags label nil nil str) + (compute-style-flags self nil nil str) (declare (ignore ex-flags)) (gfs::set-window-long hwnd gfs::+gwl-style+ (logior etch-flags std-flags gfs::+ws-child+ gfs::+ws-visible+)))) - (set-widget-text label str)) + (set-widget-text self str))
(defmethod text-baseline ((self label)) - (if (= (logand (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+) - gfs::+ss-bitmap+) - gfs::+ss-bitmap+) - (let ((image (image self))) - (if image - (gfs:size-height (gfg:size image)) - 0)) - (let ((font (gfg:font self)) - (gc (make-instance 'gfg:graphics-context :widget self)) - (b-width (border-width self))) - (+ b-width (gfg:ascent (gfg:metrics gc font)))))) + (let ((b-width (border-width self))) + (if (= (logand (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+) + gfs::+ss-bitmap+) + gfs::+ss-bitmap+) + (let ((image (image self))) + (if image + (+ (gfs:size-height (gfg:size image)) b-width) + b-width)) + (widget-text-baseline self 0))))
Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Mon Jun 5 13:18:09 2006 @@ -33,6 +33,9 @@
(in-package #:graphic-forms.uitoolkit.widgets)
+(defvar *check-box-size* nil) + + (defun translate-and-dispatch (msg-ptr) (gfs::translate-message msg-ptr) (gfs::dispatch-message msg-ptr)) @@ -148,6 +151,50 @@ (gfs::with-hfont-selected (hdc hfont) (gfg::text-bounds hdc (text widget) dt-flags 0)))))
+;;; +;;; This algorithm adapted from the calculate_best_bounds() +;;; function in ui_core_implementation.cpp from the +;;; Adobe Source Libraries / UI Core Widget API +;;; +(defun widget-text-baseline (widget top-margin) + (let ((size (gfw:size widget)) + (b-width (border-width widget)) + (font (gfg:font widget)) + (gc (make-instance 'gfg:graphics-context :widget widget)) + (baseline 0)) + (unwind-protect + (let ((metrics (gfg:metrics gc font))) + (setf baseline (+ b-width + top-margin + (gfg:ascent metrics) + (floor (/ (- (gfs:size-height size) + (+ (gfg:ascent metrics) (gfg:descent metrics))) + 2))))) + (gfs:dispose gc)) + baseline)) + +(defun check-box-size () + (if *check-box-size* + (return-from check-box-size (gfs:copy-size *check-box-size*))) + (let ((hbitmap (gfs::load-bitmap (cffi:null-pointer) + (cffi:make-pointer gfs::+obm-checkboxes+)))) + (if (gfs:null-handle-p hbitmap) + ;; if for some reason the OBM_CHECKBOXES resource could not be retrieved, + ;; use scrollbar system metric values as a rough approximation + ;; + (return-from check-box-size + (gfs:make-size :width (gfs::get-system-metrics gfs::+sm-cxvscroll+) + :height (gfs::get-system-metrics gfs::+sm-cyvscroll+)))) + + (unwind-protect + (cffi:with-foreign-object (bm-ptr 'gfs::bitmap) + (cffi:with-foreign-slots ((gfs::width gfs::height) bm-ptr gfs::bitmap) + (gfs::get-object hbitmap (cffi:foreign-type-size 'gfs::bitmap) bm-ptr) + (setf *check-box-size* (gfs:make-size :width (floor (/ gfs::width 4)) + :height (floor (/ gfs::height 3)))))) + (gfs::delete-object hbitmap))) + (gfs:copy-size *check-box-size*)) + (defun extract-foreign-strings (buffer) (let ((strings nil)) (do ((curr-ptr buffer))