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

attempt to try to make the contour window feel faster by delaying the work until nothing has happened for 250 msec

Browse Source 
original commit: 24d11805ac25fcb3a0505009ff47ff8c95392f5e
This commit is contained in:
Robby Findler 2011-06-17 12:40:31 +08:00
parent fed9746be7
commit 5c21353cb5
1 changed files with 106 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

192
collects/framework/private/text.rkt
View File

@ -1505,6 +1505,19 @@
(send new-snip set-style (send snip get-style)) (send new-snip set-style (send snip get-style))
new-snip)) new-snip))
(define todo '())
(define timer (new timer%
[notify-callback
(λ ()
(for ([th (in-list (reverse todo))])
(th))
(set! todo '()))]))
(define/private (to-delegate thunk)
(when delegate
(send timer stop)
(send timer start 250 #t)
(set! todo (cons thunk todo))))
(define delegate #f) (define delegate #f)
(inherit get-highlighted-ranges) (inherit get-highlighted-ranges)
(define/public-final (get-delegate) delegate) (define/public-final (get-delegate) delegate)
@ -1516,52 +1529,57 @@
(refresh-delegate)) (refresh-delegate))
(define/private (refresh-delegate) (define/private (refresh-delegate)
(when delegate (set! todo '())
(send delegate begin-edit-sequence) (to-delegate (λ () (refresh-delegate/do-work))))
(send delegate lock #f)
(when (is-a? this scheme:text<%>) (define/private (refresh-delegate/do-work)
(send delegate set-tabs null (send this get-tab-size) #f)) (send delegate begin-edit-sequence)
(send delegate hide-caret #t) (send delegate lock #f)
(send delegate erase) (when (is-a? this scheme:text<%>)
(send delegate set-style-list (get-style-list)) (send delegate set-tabs null (send this get-tab-size) #f))
(let loop ([snip (find-first-snip)]) (send delegate hide-caret #t)
(when snip (send delegate erase)
(let ([copy-of-snip (copy snip)]) (send delegate set-style-list (get-style-list))
(send delegate insert (let loop ([snip (find-first-snip)])
copy-of-snip (when snip
(send delegate last-position) (let ([copy-of-snip (copy snip)])
(send delegate last-position)) (send delegate insert
(loop (send snip next))))) copy-of-snip
(for-each (send delegate last-position)
(λ (range) (send delegate last-position))
(send delegate unhighlight-range (loop (send snip next)))))
(range-start range) (for-each
(range-end range) (λ (range)
(range-color range) (send delegate unhighlight-range
(range-caret-space? range) (range-start range)
(range-style range))) (range-end range)
(send delegate get-highlighted-ranges)) (range-color range)
(for-each (range-caret-space? range)
(λ (range) (range-style range)))
(send delegate highlight-range (send delegate get-highlighted-ranges))
(range-start range) (for-each
(range-end range) (λ (range)
(range-color range) (send delegate highlight-range
(range-caret-space? range) (range-start range)
'high (range-end range)
(range-style range))) (range-color range)
(reverse (get-highlighted-ranges))) (range-caret-space? range)
(send delegate lock #t) 'high
(send delegate end-edit-sequence))) (range-style range)))
(reverse (get-highlighted-ranges)))
(send delegate lock #t)
(send delegate end-edit-sequence))
(define/override (highlight-range start end color [caret-space? #f] [priority 'low] [style 'rectangle]) (define/override (highlight-range start end color [caret-space? #f] [priority 'low] [style 'rectangle])
(when delegate (to-delegate
(send delegate highlight-range start end color caret-space? priority style)) (λ ()
(send delegate highlight-range start end color caret-space? priority style)))
(super highlight-range start end color caret-space? priority style)) (super highlight-range start end color caret-space? priority style))
(define/override (unhighlight-range start end color [caret-space? #f] [style 'rectangle]) (define/override (unhighlight-range start end color [caret-space? #f] [style 'rectangle])
(when delegate (to-delegate
(send delegate unhighlight-range start end color caret-space? style)) (λ ()
(send delegate unhighlight-range start end color caret-space? style)))
(super unhighlight-range start end color caret-space? style)) (super unhighlight-range start end color caret-space? style))
(inherit get-canvases get-active-canvas has-focus?) (inherit get-canvases get-active-canvas has-focus?)
@ -1570,77 +1588,77 @@
(unless before? (unless before?
(let ([active-canvas (get-active-canvas)]) (let ([active-canvas (get-active-canvas)])
(when active-canvas (when active-canvas
(send (send active-canvas get-top-level-window) delegate-moved))))) (to-delegate
(λ ()
(send (send active-canvas get-top-level-window) delegate-moved)))))))
(define/augment (on-edit-sequence) (define/augment (on-edit-sequence)
(when delegate (to-delegate
(send delegate begin-edit-sequence)) (λ ()
(send delegate begin-edit-sequence)))
(inner (void) on-edit-sequence)) (inner (void) on-edit-sequence))
(define/augment (after-edit-sequence) (define/augment (after-edit-sequence)
(when delegate (to-delegate
(send delegate end-edit-sequence)) (λ ()
(send delegate end-edit-sequence)))
(inner (void) after-edit-sequence)) (inner (void) after-edit-sequence))
(define/override (resized snip redraw-now?) (define/override (resized snip redraw-now?)
(super resized snip redraw-now?) (super resized snip redraw-now?)
(when (and delegate (when (and delegate
linked-snips
(not (is-a? snip string-snip%))) (not (is-a? snip string-snip%)))
(let ([delegate-copy (hash-ref linked-snips snip (λ () #f))]) (to-delegate
(when delegate-copy (λ ()
(send delegate resized delegate-copy redraw-now?))))) (when linked-snips
(let ([delegate-copy (hash-ref linked-snips snip (λ () #f))])
(when delegate-copy
(send delegate resized delegate-copy redraw-now?))))))))
(define/augment (after-insert start len) (define/augment (after-insert start len)
(when delegate (to-delegate
(send delegate begin-edit-sequence) (λ ()
(send delegate lock #f) (send delegate begin-edit-sequence)
(split-snip start) (send delegate lock #f)
(split-snip (+ start len)) (split-snip start)
(let loop ([snip (find-snip (+ start len) 'before-or-none)]) (split-snip (+ start len))
(when snip (let loop ([snip (find-snip (+ start len) 'before-or-none)])
(unless ((get-snip-position snip) . < . start) (when snip
(send delegate insert (copy snip) start start) (unless ((get-snip-position snip) . < . start)
(loop (send snip previous))))) (send delegate insert (copy snip) start start)
(send delegate lock #t) (loop (send snip previous)))))
(send delegate end-edit-sequence)) (send delegate lock #t)
(send delegate end-edit-sequence)))
(inner (void) after-insert start len)) (inner (void) after-insert start len))
(define/augment (after-delete start len) (define/augment (after-delete start len)
(when delegate (to-delegate
(send delegate lock #f) (λ ()
(send delegate begin-edit-sequence) (send delegate lock #f)
(send delegate delete start (+ start len)) (send delegate begin-edit-sequence)
(send delegate end-edit-sequence) (send delegate delete start (+ start len))
(send delegate lock #t)) (send delegate end-edit-sequence)
(send delegate lock #t)))
(inner (void) after-delete start len)) (inner (void) after-delete start len))
(define/augment (after-change-style start len) (define/augment (after-change-style start len)
(when delegate (to-delegate
(send delegate begin-edit-sequence) (λ ()
(send delegate lock #f) (send delegate begin-edit-sequence)
(split-snip start) (send delegate lock #f)
(let* ([snip (find-snip start 'after)] (split-snip start)
[style (send snip get-style)] (let* ([snip (find-snip start 'after)]
[other-style [style (send snip get-style)])
'(send (send delegate get-style-list) find-or-create-style (send delegate change-style style start (+ start len)))
style delegate-style-delta)]) (send delegate lock #f)
(send delegate change-style style start (+ start len))) (send delegate end-edit-sequence)))
(send delegate lock #f)
(send delegate end-edit-sequence))
(inner (void) after-change-style start len)) (inner (void) after-change-style start len))
(define filename #f)
(define format #f)
(define/augment (on-load-file _filename _format)
(set! filename _filename)
(set! format _format)
(inner (void) on-load-file _filename _format))
(define/augment (after-load-file success?) (define/augment (after-load-file success?)
(when success? (when success?
(refresh-delegate)) (refresh-delegate))
(inner (void) after-load-file success?)) (inner (void) after-load-file success?))
(super-instantiate ()))) (super-new)))
(define info<%> (interface (basic<%>))) (define info<%> (interface (basic<%>)))