Вот попытка реализовать добавление всплывающих подсказок к произвольным помеченным изображениям.Скорее всего, это неуклюже и неправильно.Я предлагаю это здесь, чтобы проиллюстрировать мою путаницу.Надеюсь, вы можете опубликовать ответ, который показывает подход, который более целесообразно использовать многие инструменты в ракетке / графическом интерфейсе.Известные проблемы отмечены в комментариях в коде и кратко описаны ниже.
#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.(Некоторые части заимствуют идеи непосредственно из их исходного кода.) Я полагаю, что более разумный подход будет использовать то, что библиотеки уже делают, а не реализовывать его заново.
Эта версия позволяет легко добавлять всплывающие подсказки к большинству элементов графического интерфейса, напримеркак сообщения и кнопки, но он не использует canvas или editor-canvas.Следовательно, он не позволяет прокручивать большее количество отмеченных точек, чем может поместиться в окне.Я полагаю, что следующее, что нужно сделать, это получить класс snip%, чтобы нарисовать всплывающую подсказку vertical-panel%, содержащую метку и точку.Но так как фрагмент должен рисовать себя в контексте рисования, я не уверен, как это сделать.В любом случае, пришло время попросить кого-то более опытного в использовании racket / gui предложить подход, более соответствующий принципам работы библиотеки.