repos
/
repl
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
initial commit
Annotate for file src/locate-widget.lisp
2009-06-04 tobias
1
(in-package :cl-smoke.repl)
20:48:44 '
2
'
3
(defclass highlight-widget (qt:widget)
'
4
()
'
5
(:metaclass cxx:class)
'
6
(:documentation "A red border."))
'
7
'
8
(defun make-highligh-mask (rectangle &optional (border 10))
'
9
(let* ((border/2 (/ border 2))
'
10
(mask (make-instance 'qt:region
'
11
:args (list (cxx:adjusted rectangle
'
12
(- border/2) (- border/2)
'
13
border/2 border/2))))
'
14
(inner (cxx:adjusted rectangle border/2 border/2
'
15
(- border/2) (- border/2))))
'
16
(cxx:subtracted mask inner)))
'
17
'
18
(defmethod initialize-instance :after ((widget highlight-widget) &key)
'
19
(cxx:set-window-flags widget (enum-logior
'
20
qt:+window-stays-on-top-hint+
'
21
qt:+frameless-window-hint+
'
22
qt:+x11bypass-window-manager-hint+))
'
23
(cxx:set-palette widget
'
24
(make-instance 'qt:palette :args '("Red")))
'
25
(cxx:set-auto-fill-background widget t))
'
26
'
27
(defun blink-and-follow (widget follow times &optional (intervall 0.5))
'
28
(let ((timer (make-instance 'qt:timer :args (list widget))))
'
29
(qt:connect (qt:get-signal timer "timeout()")
'
30
#'(lambda ()
'
31
(when (<= times 1)
'
32
(cxx:stop timer))
'
33
;; Track the follow widgets geometry
'
34
(cxx:set-geometry widget (cxx:geometry follow))
'
35
(cxx:set-mask widget
'
36
(make-highligh-mask (cxx:rect follow)))
'
37
'
38
(if (evenp times)
'
39
(cxx:show widget)
'
40
(cxx:hide widget))
'
41
(decf times)))
'
42
(cxx:start timer (floor (* intervall 1000)))))
'
43
'
44
(defun locate-widget (widget)
'
45
"Shows the location of WIDGET on the screen."
'
46
(unless (cxx:is-visible widget)
'
47
(cerror "show the widget" "The widget ~A is not visible." widget)
'
48
(cxx:show widget))
'
49
(cxx:raise widget) ;; Focus stealing prevention might intercept this.
'
50
(let ((highlight (make-instance 'highlight-widget)))
'
51
(blink-and-follow highlight widget 5)))