suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

avoid xor for pasteboard rubberband hiliting

Browse Source
This commit is contained in:
Matthew Flatt 2010-11-05 20:26:24 -06:00
parent d065fb39e1
commit 59bf78b6c8
1 changed files with 38 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
collects/mred/private/wxme/pasteboard.rkt
View File

@ -34,8 +34,9 @@
(define black-brush (send the-brush-list find-or-create-brush "black" 'xor)) (define black-brush (send the-brush-list find-or-create-brush "black" 'xor))
(define white-brush (send the-brush-list find-or-create-brush "white" 'solid)) (define white-brush (send the-brush-list find-or-create-brush "white" 'solid))
(define invisi-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) (define invisi-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
(define rb-brush (send the-brush-list find-or-create-brush "black" 'transparent)) (define invisi-brush (send the-brush-list find-or-create-brush "black" 'transparent))
(define rb-pen (send the-pen-list find-or-create-pen "black" 1 'xor-dot)) (define rb-pen (send the-pen-list find-or-create-pen (get-highlight-background-color) 1 'xor-dot))
(define rb-brush (send the-brush-list find-or-create-brush (get-highlight-background-color) 'solid))
(define arrow (make-object cursor% 'arrow)) (define arrow (make-object cursor% 'arrow))
@ -122,6 +123,11 @@
(define dragging? #f) (define dragging? #f)
(define rubberband? #f) (define rubberband? #f)
(define rb-x 0.0)
(define rb-y 0.0)
(define rb-w 0.0)
(define rb-h 0.0)
(define need-resize? #f) (define need-resize? #f)
(define resizing #f) ; a snip (define resizing #f) ; a snip
@ -167,7 +173,7 @@
;; ---------------------------------------- ;; ----------------------------------------
(define/private (rubber-band x y w h) (define/private (rubber-band-update x y w h)
(when (and s-admin (when (and s-admin
(not (zero? w)) (not (zero? w))
(not (zero? h))) (not (zero? h)))
@ -192,22 +198,11 @@
[b (min b (+ vy vh))]) [b (min b (+ vy vh))])
(unless (or (x . >= . r) (unless (or (x . >= . r)
(y . >= . b)) (y . >= . b))
(let-boxes ([dc #f] (set! rb-x x)
[dx 0.0] (set! rb-y y)
[dy 0.0]) (set! rb-w (- r x))
(set-box! dc (send s-admin get-dc dx dy)) (set! rb-h (- b y))
(let ([old-pen (send dc get-pen)] (update rb-x rb-y rb-w rb-h))))))))
[old-brush (send dc get-brush)])
(send dc set-pen rb-pen)
(send dc set-brush rb-brush)
(send dc draw-rectangle
(- x dx) (- y dy)
(- r x)
(- b y))
(send dc set-pen old-pen)
(send dc set-brush old-brush))))))))))
(def/override (adjust-cursor [mouse-event% event]) (def/override (adjust-cursor [mouse-event% event])
(if (not s-admin) (if (not s-admin)
@ -317,7 +312,7 @@
(when rubberband? (when rubberband?
(set! rubberband? #f) (set! rubberband? #f)
(rubber-band start-x start-y (- last-x start-x) (- last-y start-y)) (rubber-band-update start-x start-y (- last-x start-x) (- last-y start-y))
(add-selected start-x start-y (- last-x start-x) (- last-y start-y)) (add-selected start-x start-y (- last-x start-x) (- last-y start-y))
(update-all))) (update-all)))
@ -377,10 +372,12 @@
(when (send event dragging?) (when (send event dragging?)
(cond (cond
[rubberband? [rubberband?
(begin-edit-sequence)
;; erase old ;; erase old
(rubber-band start-x start-y (- last-x start-x) (- last-y start-y)) (rubber-band-update start-x start-y (- last-x start-x) (- last-y start-y))
;; draw new: ;; draw new:
(rubber-band start-x start-y (- x start-x) (- y start-y))] (rubber-band-update start-x start-y (- x start-x) (- y start-y))
(end-edit-sequence)]
[resizing [resizing
(do-event-resize x y)] (do-event-resize x y)]
[else [else
@ -916,6 +913,8 @@
(on-resize snip w h) (on-resize snip w h)
(set! write-locked (sub1 write-locked)) (set! write-locked (sub1 write-locked))
(update-location loc)
(let ([rv? (let ([rv?
(and (send snip resize w h) (and (send snip resize w h)
(begin (begin
@ -935,6 +934,8 @@
(after-resize snip w h rv?) (after-resize snip w h rv?)
(update-location loc)
(set! write-locked (add1 write-locked)) (set! write-locked (add1 write-locked))
(end-edit-sequence) (end-edit-sequence)
(set! write-locked (sub1 write-locked)) (set! write-locked (sub1 write-locked))
@ -1275,6 +1276,17 @@
show-caret show-caret
'no-caret)) 'no-caret))
(when rubberband?
(let ([a (send dc get-alpha)])
(send dc set-alpha (* a 0.5))
(send dc set-brush rb-brush)
(send dc set-pen invisi-pen)
(send dc draw-rectangle (+ rb-x dx) (+ rb-y dy) rb-w rb-h)
(send dc set-pen rb-pen)
(send dc set-alpha a)
(send dc set-brush invisi-brush)
(send dc draw-rectangle (+ rb-x dx) (+ rb-y dy) rb-w rb-h)))
(set! flow-locked? #f) (set! flow-locked? #f)
(set! write-locked (sub1 write-locked)))))) (set! write-locked (sub1 write-locked))))))
@ -1440,14 +1452,14 @@
(set! update-top (min y update-top)) (set! update-top (min y update-top))
(set! update-left (min x update-left)) (set! update-left (min x update-left))
(set! update-bottom (max b update-bottom)) (set! update-bottom (max b update-bottom))
(when (symbol? b) (when (symbol? h)
(if (eq? b 'display-end) (if (eq? h 'display-end)
(set! update-bottom-end 'display-end) (set! update-bottom-end 'display-end)
(unless (eq? update-bottom-end 'display-end) (unless (eq? update-bottom-end 'display-end)
(set! update-bottom-end 'end)))) (set! update-bottom-end 'end))))
(set! update-right (max r update-right)) (set! update-right (max r update-right))
(when (symbol? r) (when (symbol? w)
(if (eq? r 'display-end) (if (eq? w 'display-end)
(set! update-right-end 'display-end) (set! update-right-end 'display-end)
(unless (eq? update-right-end 'display-end) (unless (eq? update-right-end 'display-end)
(set! update-right-end 'end)))))) (set! update-right-end 'end))))))