darcs - repl

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

3 (defclass highlight-widget (qt:widget)

4 ()

5 (:metaclass cxx:class)

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

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)))

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))

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)))

38 (if (evenp times)

39 (cxx:show widget)

40 (cxx:hide widget))

41 (decf times)))

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

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)))