[pal-cvs] CVS pal-gui
tneste
tneste at common-lisp.net
Tue Oct 30 00:20:41 UTC 2007
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)
, at 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
More information about the Pal-cvs
mailing list