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