Update of /project/pal/cvsroot/pal-gui In directory clnet:/tmp/cvs-serv3131

Modified Files: gob.lisp gui.lisp package.lisp widgets.lisp Log Message: Added tooltips.

--- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/29 21:09:20 1.12 +++ /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/30 00:20:41 1.13 @@ -60,6 +60,14 @@ (point-inside-rectangle-p (absolute-pos-of g) (width-of g) (height-of g) point))

+(defgeneric on-inspect (gob)) +(defmethod on-inspect ((g gob)) + nil) + +(defgeneric on-over (gob)) +(defmethod on-over ((gob gob)) + nil) + (defgeneric on-enter (gob)) (defmethod on-enter ((gob gob)) nil) --- /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/29 21:09:20 1.8 +++ /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/30 00:20:41 1.9 @@ -16,6 +16,8 @@ (otherwise (pal::funcall? ,key-up-fn key))))) (key-down (lambda (key) (case key + (:key-mouse-2 (when *pointed-gob* + (on-inspect *pointed-gob*))) (:key-escape (unless ,key-down-fn (return-from event-loop))) (:key-mouse-1 (cond @@ -36,15 +38,16 @@ (pal::do-event ,event key-up key-down ,mouse-motion-fn ,quit-fn) ,@redraw (let ((g (first (last (active-gobs-at-point (get-mouse-pos) *root*))))) - (setf *pointed-gob* g) (cond (*armed-gob* (on-drag *armed-gob* *relative-drag-start-pos* (v- *drag-start-pos* (get-mouse-pos)))) - (t - (when (and g (not (activep g))) - (when *pointed-gob* - (on-leave *pointed-gob*)) - (on-enter g))))) + ((and g (not (eq g *pointed-gob*))) + (on-enter g))) + (when g + (on-over g)) + (when (and *pointed-gob* (not (eq *pointed-gob* g))) + (on-leave *pointed-gob*)) + (setf *pointed-gob* g)) (update-gui)))))))

--- /project/pal/cvsroot/pal-gui/package.lisp 2007/10/29 21:09:20 1.3 +++ /project/pal/cvsroot/pal-gui/package.lisp 2007/10/30 00:20:41 1.4 @@ -4,9 +4,10 @@

#:present

- #:window #:button #:list-widget #:text-widget #:choice-widget #:pin #:label #:h-gauge #:v-slider #:h-meter #:filler + #:window #:button #:list-widget #:text-widget #:choice-widget #:pin #:label #:h-gauge + #:v-slider #:h-meter #:filler #:tooltip #:sliding #:clipping #:highlighted #:constrained - #:on-select #:on-button-down #:on-button-up #:on-key-down #:on-enter #:on-leave #:on-repaint #:on-drag #:repaint + #:on-select #:on-button-down #:on-button-up #:on-key-down #:on-enter #:on-leave #:on-repaint #:on-drag #:on-over #:repaint

#:box #:v-box #:h-box

--- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/29 21:09:20 1.12 +++ /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/30 00:20:41 1.13 @@ -5,6 +5,8 @@ (defparameter *widget-color* '(180 180 180 128)) (defparameter *text-color* '(0 0 0 255)) (defparameter *paper-color* '(255 255 200 255)) +(defparameter *tooltip-delay* 1) +(defparameter *widget-enter-time* nil) (defvar *gui-font* nil)

@@ -50,8 +52,10 @@

(defclass widget (gob) - ((on-drag :accessor on-drag-of :initarg :on-drag :initform (lambda (widget pos d) (declare (ignore widget pos d)) nil)) + ((tooltip :accessor tooltip-of :initarg :tooltip :initform nil) + (on-drag :accessor on-drag-of :initarg :on-drag :initform (lambda (widget pos d) (declare (ignore widget pos d)) nil)) (on-select :accessor on-select-of :initarg :on-select :initform (lambda (widget) (declare (ignore widget)) nil)) + (on-over :accessor on-over-of :initarg :on-over :initform (lambda (widget) (declare (ignore widget)) nil)) (on-repaint :accessor on-repaint-of :initarg :on-repaint :initform (lambda (widget) (declare (ignore widget)) nil)) (on-button-down :accessor on-button-down-of :initarg :on-button-down :initform (lambda (widget pos) (declare (ignore widget pos)) nil)) (on-button-up :accessor on-button-up-of :initarg :on-button-up :initform (lambda (widget pos) (declare (ignore widget pos)) nil)) @@ -60,6 +64,10 @@ (on-leave :accessor on-leave-of :initarg :on-leave :initform (lambda (widget) (declare (ignore widget)) nil))) (:default-initargs :width (get-m) :height (get-m)))

+ +(defmethod on-inspect ((g widget)) + (message g)) + (defmethod on-drag :around ((g widget) pos d) (unless (funcall (on-drag-of g) g pos d) (call-next-method))) @@ -72,6 +80,13 @@ (unless (funcall (on-repaint-of g) g) (call-next-method)))

+(defmethod on-over :around ((g widget)) + (when (and *widget-enter-time* (tooltip-of g) (> (- (get-universal-time) *widget-enter-time*) *tooltip-delay*)) + (setf *widget-enter-time* nil) + (make-instance 'tooltip :text (tooltip-of g) :host g)) + (unless (funcall (on-over-of g) g) + (call-next-method))) + (defmethod on-button-down :around ((g widget) pos) (unless (funcall (on-button-down-of g) g pos) (call-next-method))) @@ -85,6 +100,7 @@ (call-next-method)))

(defmethod on-enter :around ((g widget)) + (setf *widget-enter-time* (get-universal-time)) (unless (funcall (on-enter-of g) g) (call-next-method)))

@@ -115,7 +131,7 @@ (draw-line (v (- (get-text-bounds label) (vx text-offset)) 0) (v width 0) 0 0 0 160)

(with-blend (:color *text-color*) - (draw-text label (v- text-offset (v 0 (truncate (get-m) 2))))))))) + (draw-text label (v- text-offset (v 0 (truncate (get-m) 2))) *gui-font*))))))

@@ -175,7 +191,7 @@ (draw-line (v 0 (1+ (get-m))) (v width (1+ (get-m))) 0 0 0 64) (draw-line (v 0 (+ (get-m) 2)) (v width (+ (get-m) 2)) 0 0 0 32) (with-blend (:color '(255 255 255 255)) - (draw-text label (get-text-offset))))) + (draw-text label (get-text-offset) *gui-font*))))

@@ -265,7 +281,7 @@ (draw-frame (v+ kpos (v (truncate sw 2) 0)) 3 (/ m 4) '(0 0 0 0) :style :sunken :fill nil) (draw-frame (v+ kpos (v (truncate sw 2) m)) 3 (- (/ m 4)) '(0 0 0 0) :style :sunken :fill nil) (with-blend (:color *text-color*) - (draw-text vt (v+ kpos (get-text-offset))))))) + (draw-text vt (v+ kpos (get-text-offset)) *gui-font*)))))

@@ -324,9 +340,9 @@ (loop for x from 1 to (- k 3) by 2 do (draw-line (v x 1) (v x (1- height)) 148 148 148 255)) (with-blend (:color *widget-color*) - (draw-text (princ-to-string value) (v+ (v 1 1) (get-text-offset)))) + (draw-text (princ-to-string value) (v+ (v 1 1) (get-text-offset)) *gui-font*)) (with-blend (:color *text-color*) - (draw-text (princ-to-string value) (get-text-offset)))))) + (draw-text (princ-to-string value) (get-text-offset) *gui-font*)))))

@@ -544,7 +560,7 @@ (let* ((offset (get-text-offset)) (point-x (+ (vx offset) (get-text-size (subseq text 0 point))))) (with-blend (:color *text-color*) - (draw-text text offset) + (draw-text text offset *gui-font*) (when (focusedp g) (draw-rectangle (v point-x (vy offset)) 2 (- height (* 2 (vy offset))) @@ -552,4 +568,25 @@

(defmethod on-key-down ((g text-widget) char) (setf (text-of g) (concatenate 'string (text-of g) (string char))) - (incf (point-of g))) \ No newline at end of file + (incf (point-of g))) + + + + +(defclass tooltip (gob) + ((host :accessor host-of :initarg :host) + (text :reader text-of :initarg :text :initform "")) + (:default-initargs :activep nil :width 100 :height (get-m) :pos (get-mouse-pos))) + +(defmethod initialize-instance :after ((g tooltip) &key text &allow-other-keys) + (setf (width-of g) (get-text-bounds text)) + (raise g)) + + +(defmethod repaint ((g tooltip)) + (unless (pointedp (host-of g)) + (setf (parent-of g) nil)) + (draw-rectangle (v 0 0) (width-of g) (height-of g) (first *paper-color*) (second *paper-color*) (third *paper-color*) (fourth *paper-color*)) + (draw-rectangle (v 0 0) (width-of g) (height-of g) 0 0 0 255 :fill nil) + (with-blend (:color *text-color*) + (draw-text (text-of g) (get-text-offset) *gui-font*))) \ No newline at end of file