如何获得canvas％对象以响应鼠标悬停？

Question

此刻，我有一个看起来像这样的窗口：

每个绿色磁盘代表一个数字。我该如何做，以便当您将鼠标移到磁盘上时，出现工具提示或某些内容并为您显示数字？

当然，这只是一个简单的例子。目的是大致了解如何在不为每种情况编写大量新代码的情况下进行此操作。

当前，我正在画布上绘制一个大的“ pict”图像，这似乎是错误的方法。重写它以其他方式工作没什么大不了的。我只需要知道正确的方法是什么：哪个工具，哪个库，如何将这些东西放在一起以实现鼠标悬停。

我一直在搜索Racket文档，但到目前为止，尚未找到该问题的明确答案。

Answer 1

您需要使用新的on-event方法扩展String myVariable = 'Hello'; 类。 canvas%方法采用一个mouse-event%对象，该对象包含相对于目标窗口的鼠标on-event和x坐标。

从那里，您可以将其与用于计算在画布上绘制圆的位置的任何数据结构进行比较。

所以这样的事情应该起作用：

y

现在，您只需将(define clicky-canvas% (class canvas% (define/override (on-event e) (define window-x (send e get-x)) (define window-y (send e get-y)) (when (eq? (send e get-event-type) 'left-down) .... your code here ....))) 对象插入先前插入clicky-canvas%对象的窗口即可。

Answer 2

这里是尝试为任意标签的图像添加工具提示。它很可能笨拙而错误地进行了操作。我在这里提供它来说明我的困惑。希望您可以发布一个答案，该答案显示了一种可以更适当地使用球拍/ GUI中许多工具的方法。已知问题在代码的注释中标记，并在下面进行简要讨论。

#lang debug at-exp racket/gui

(require (prefix-in pict: pict) pict/snip mrlib/snip-canvas)

;; Adding tooltips to windows ==========================================

;CONFUSION: This is needed only because pane% doesn't support client->screen.
;Is the reason why it doesn't also a reason why this function shouldn't exist?
(define (window-parent-of window)
  (let ([parent (send window get-parent)])
    (cond
      [(not parent)
       #f]
      [(is-a? parent window<%>)
       parent]
      [else (window-parent-of parent)])))

;CONFUSION: Is the documentation on client->screen or get-current-mouse-state
;wrong?
(define-values (screen-x-offset screen-y-offset)
  (let-values ([(xo yo) (get-display-left-top-inset)])
    (values (- xo) (- yo))))
(define (window-top-left-in-screen-coordinates window)
  (let ([parent (window-parent-of window)])
    (if parent
      (let-values ([(wx wy) (send parent client->screen (send window get-x)
                                                        (send window get-y))])
        (values (+ wx screen-x-offset) (+ wy screen-y-offset)))
      (values (send window get-x) (send window get-y)))))

(define (in-window? window point)  ; <--- CODE SMELL: reinventing the wheel?
  (define-values (wx wy) (window-top-left-in-screen-coordinates window))
  (define-values (ww wh) (send window get-size))
  (define-values (px py) (values (send point get-x) (send point get-y)))
  (and (<= wx px (+ wx ww))
       (<= wy py (+ wy wh))))

(define (text->tooltip-pict text)
  (let* ([text (if (pair? text) (map ~a text) (string-split (~a text) "\n"))]
         [text-image (for/fold ([text-image (pict:blank)])
                               ([line text])
                       (pict:vl-append text-image (pict:text line)))]
         [text-image (pict:inset text-image 4 2)]
         [background (pict:filled-rectangle
                       (ceiling (pict:pict-width text-image))
                       (ceiling (pict:pict-height text-image))
                       #:color "LemonChiffon"
                       #:draw-border? #t)])
    (pict:cc-superimpose background text-image)))

(define -pict-canvas%  ; <--- CODE SMELL: reinventing the wheel (pict.rkt)
  (class canvas%
    (init-field pict
                [style '()])
    (inherit get-dc)
    (define/override (on-paint)
      (pict:draw-pict pict (get-dc) 0 0))
    (super-new [min-width (exact-ceiling (pict:pict-width pict))]
               [min-height (exact-ceiling (pict:pict-height pict))]
               [stretchable-width #f]
               [stretchable-height #f]
               [style (cons 'transparent style)])))

(define tooltip-window%
  (class frame%
    (init-field text
                point ; will place window above this point
                [pict (text->tooltip-pict text)])
    (define width (exact-ceiling (pict:pict-width pict)))
    (define height (exact-ceiling (pict:pict-height pict)))
    (super-new [style '(no-resize-border no-caption float)]
               [label ""]
               [width width]
               [height height]
               [stretchable-width #f]
               [stretchable-height #f]
               [x (exact-ceiling (- (send point get-x) (/ width 2) 3))]
               [y (exact-ceiling (- (send point get-y) height 8))])
    (define canvas (new -pict-canvas% [pict pict] [parent this]))
    (send this show #t)))

(define TOOLTIP-HOVER-DELAY 600)
  ;When mouse cursor sits motionless over relevant window for this long,
  ;tooltip appears.

(define tooltip-mixin
  (mixin (window<%>) (window<%>)
    (init-field [tooltip (void)]
                [tooltip-window #f])
    (super-new)

    (define (maybe-open-tooltip-window)
      (define-values (point buttons) (get-current-mouse-state))
      (when (and (null? buttons) (in-window? this point))
        (set! tooltip-window (new tooltip-window% [text tooltip]
                                                  [point point]))))

    (define timer
      (new timer% [notify-callback maybe-open-tooltip-window]))

    (define/public (close-tooltip-window)
      (send tooltip-window show #f) ;<--- MEMORY LEAK: Should close, not hide
      (set! tooltip-window #f))

    (define/override (on-subwindow-event receiver e)
      (if (and (not (void? tooltip))
               (eq? this receiver)
               (eq? 'motion (send e get-event-type)))
               ;STRANGE: We never get 'enter or 'leave events
        (begin
          (if tooltip-window
            ; If tooltip is showing, mouse motion closes it
            (close-tooltip-window)
            ; Mouse motion followed by a pause opens it
            (send timer start TOOLTIP-HOVER-DELAY #t))
          #t)  ; UNSURE: What is on-subwindow-event supposed to return here?
        #f))))
      ;BUG: Often no 'motion event comes when the mouse leaves this window,
      ;so the tooltip stays up.

;; Labeled dots with tooltips ==========================================

(define fr (new frame% [label "xtooltip"] [width 200] [height 100]))

(define hp (new horizontal-pane% [parent fr] [alignment '(left top)]))

(define pict-canvas% (tooltip-mixin -pict-canvas%))

(define (disk d)
  (pict:cc-superimpose
    (pict:ghost (pict:disk 50))
    (pict:disk d #:color "aquamarine" #:draw-border? #f)))

(define (make-dot parent label activation)
  (define vp (new vertical-pane% [parent parent]
                                 [stretchable-width #f]
                                 [stretchable-height #f]))
  (define l (new message% [parent vp] [label label]))
  (define d (new pict-canvas% [parent vp]
                              [pict (disk (* 8.0 activation))]
                              [tooltip activation]))
  vp)

(define d1 (make-dot hp "archetype4" 4.1))
(define d2 (make-dot hp "some-sa-node" 2.26))
(define d3 (make-dot hp "this-dot" 0.4))

(send fr show #t)

某些代码被标记为“重塑方向”，例如in-window?，因为它复制了Racket库中可能已经实现的功能。 （某些部分直接从其源代码中借用了想法。）我认为，一种更聪明的方法将利用库已完成的工作，而不是重新实施。

此版本可让您轻松地将工具提示添加到大多数GUI元素（例如消息和按钮），但不使用canvas或editor-canvas。因此，它不允许滚动超出窗口数量的标记点。我认为接下来要做的是派生一个snip%类来绘制带有标签和点的工具提示vertical-panel%。但是由于片段需要在绘图上下文中进行绘制，因此我不确定如何执行此操作。无论如何，显然现在是时候让经验丰富的球拍/ GUI的人来建议一种更符合图书馆工作原理的方法了。