Thu Jun 4 22:48:44 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* initial commit

--- old-repl/src/locate-widget.lisp 1970-01-01 01:00:00.000000000 +0100

+++ new-repl/src/locate-widget.lisp 2014-10-30 08:04:16.000000000 +0100

@@ -0,0 +1,51 @@

+(in-package :cl-smoke.repl)

+

+(defclass highlight-widget (qt:widget)

+ ()

+ (:metaclass cxx:class)

+ (:documentation "A red border."))

+

+(defun make-highligh-mask (rectangle &optional (border 10))

+ (let* ((border/2 (/ border 2))

+ (mask (make-instance 'qt:region

+ :args (list (cxx:adjusted rectangle

+ (- border/2) (- border/2)

+ border/2 border/2))))

+ (inner (cxx:adjusted rectangle border/2 border/2

+ (- border/2) (- border/2))))

+ (cxx:subtracted mask inner)))

+

+(defmethod initialize-instance :after ((widget highlight-widget) &key)

+ (cxx:set-window-flags widget (enum-logior

+ qt:+window-stays-on-top-hint+

+ qt:+frameless-window-hint+

+ qt:+x11bypass-window-manager-hint+))

+ (cxx:set-palette widget

+ (make-instance 'qt:palette :args '("Red")))

+ (cxx:set-auto-fill-background widget t))

+

+(defun blink-and-follow (widget follow times &optional (intervall 0.5))

+ (let ((timer (make-instance 'qt:timer :args (list widget))))

+ (qt:connect (qt:get-signal timer "timeout()")

+ #'(lambda ()

+ (when (<= times 1)

+ (cxx:stop timer))

+ ;; Track the follow widgets geometry

+ (cxx:set-geometry widget (cxx:geometry follow))

+ (cxx:set-mask widget

+ (make-highligh-mask (cxx:rect follow)))

+

+ (if (evenp times)

+ (cxx:show widget)

+ (cxx:hide widget))

+ (decf times)))

+ (cxx:start timer (floor (* intervall 1000)))))

+

+(defun locate-widget (widget)

+ "Shows the location of WIDGET on the screen."

+ (unless (cxx:is-visible widget)

+ (cerror "show the widget" "The widget ~A is not visible." widget)

+ (cxx:show widget))

+ (cxx:raise widget) ;; Focus stealing prevention might intercept this.

+ (let ((highlight (make-instance 'highlight-widget)))

+ (blink-and-follow highlight widget 5)))