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

more speedups for the highlighting and some setup for improving docked search

Browse Source 
svn: r10855
This commit is contained in:
Robby Findler 2008-07-21 22:17:54 +00:00
parent 9af18d6971
commit e2c49f4963
3 changed files with 246 additions and 138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
collects/framework/private/frame.ss
View File

@ -1,15 +1,13 @@
#lang scheme/unit #lang scheme/unit
(require string-constants (require string-constants
mzlib/class scheme/class
mzlib/include mzlib/include
"sig.ss" "sig.ss"
"../preferences.ss" "../preferences.ss"
"../gui-utils.ss" "../gui-utils.ss"
"bday.ss" "bday.ss"
mred/mred-sig mred/mred-sig
mzlib/list scheme/path)
scheme/path
mzlib/etc)
(import mred^ (import mred^
[prefix group: framework:group^] [prefix group: framework:group^]
@ -61,7 +59,7 @@
menus)) menus))
(define add-snip-menu-items (define add-snip-menu-items
(opt-lambda (edit-menu c% [func void]) (lambda (edit-menu c% [func void])
(let* ([get-edit-target-object (let* ([get-edit-target-object
(λ () (λ ()
(let ([menu-bar (let ([menu-bar
@ -1087,7 +1085,7 @@
(make-object %))) (make-object %)))
(define/public save (define/public save
(opt-lambda ([format 'same]) (lambda ([format 'same])
(let* ([ed (get-editor)] (let* ([ed (get-editor)]
[filename (send ed get-filename)]) [filename (send ed get-filename)])
(if filename (if filename
@ -1095,7 +1093,7 @@
(save-as format))))) (save-as format)))))
(define/public save-as (define/public save-as
(opt-lambda ([format 'same]) (lambda ([format 'same])
(let* ([editor (get-editor)] (let* ([editor (get-editor)]
[name (send editor get-filename)]) [name (send editor get-filename)])
(let-values ([(base name) (let-values ([(base name)
@ -1837,10 +1835,9 @@
(set! searching-direction x)) (set! searching-direction x))
(define old-search-highlight void) (define old-search-highlight void)
(define clear-search-highlight (define (clear-search-highlight)
(λ () (old-search-highlight)
(begin (old-search-highlight) (set! old-search-highlight void))
(set! old-search-highlight void))))
(define reset-search-anchor (define reset-search-anchor
(let ([color (make-object color% "BLUE")]) (let ([color (make-object color% "BLUE")])
(λ (edit) (λ (edit)
@ -1856,7 +1853,7 @@
(send edit highlight-range position position color #f)))))) (send edit highlight-range position position color #f))))))
(define find-string-embedded (define find-string-embedded
(opt-lambda (edit (lambda (edit
str str
[direction 'forward] [direction 'forward]
[start 'start] [start 'start]
@ -1951,7 +1948,7 @@
(and searching-frame (and searching-frame
(send searching-frame get-text-to-search))) (send searching-frame get-text-to-search)))
(define/public search (define/public search
(opt-lambda ([reset-search-anchor? #t] [beep? #t] [wrap? #t]) (lambda ([reset-search-anchor? #t] [beep? #t] [wrap? #t])
(when searching-frame (when searching-frame
(let* ([string (get-text)] (let* ([string (get-text)]
[top-searching-edit (get-searching-edit)] [top-searching-edit (get-searching-edit)]
@ -2002,6 +1999,16 @@
(send text end-edit-sequence) (send text end-edit-sequence)
#t))]) #t))])
#;
(send (get-searching-edit)
set-searching-str
(and (not (preferences:get 'framework:search-using-dialog?))
(if (equal? string "")
#f
string))
case-sensitive?)
(if (string=? string "") (if (string=? string "")
(not-found top-searching-edit #t) (not-found top-searching-edit #t)
(begin (begin
@ -2141,13 +2148,16 @@
(define/public (get-text-to-search) (define/public (get-text-to-search)
(error 'get-text-to-search "abstract method in searchable-mixin")) (error 'get-text-to-search "abstract method in searchable-mixin"))
(define/public hide-search (define/public hide-search
(opt-lambda ([startup? #f]) (lambda ([startup? #f])
(when search-gui-built? (when search-gui-built?
(send super-root change-children (send super-root change-children
(λ (l) (λ (l)
(remove search-panel l)))) (remove search-panel l))))
(clear-search-highlight) (clear-search-highlight)
#;
(send (get-text-to-search) set-searching-str #f #f)
(unless startup? (unless startup?
(let ([canvas (send (get-text-to-search) get-canvas)]) (let ([canvas (send (get-text-to-search) get-canvas)])
(when canvas (when canvas
@ -2168,6 +2178,12 @@
(show/hide-replace (send (get-text-to-search) is-locked?)) (show/hide-replace (send (get-text-to-search) is-locked?))
(send search-panel focus) (send search-panel focus)
(send find-edit set-position 0 (send find-edit last-position)) (send find-edit set-position 0 (send find-edit last-position))
#;
(send (get-text-to-search) set-searching-str
(send find-edit get-text)
(send find-edit get-case-sensitive?))
(unless (memq search-panel (send super-root get-children)) (unless (memq search-panel (send super-root get-children))
(send super-root add-child search-panel)) (send super-root add-child search-panel))
(reset-search-anchor (get-text-to-search)))) (reset-search-anchor (get-text-to-search))))
@ -2300,8 +2316,7 @@
[else [else
find-canvas]) find-canvas])
focus))) focus)))
(define move-to-search-or-search (define (move-to-search-or-search)
(λ ()
(set-searching-frame this) (set-searching-frame this)
(unhide-search) (unhide-search)
(cond (cond
@ -2311,9 +2326,8 @@
(if (or (send find-canvas has-focus?) (if (or (send find-canvas has-focus?)
(send replace-canvas has-focus?)) (send replace-canvas has-focus?))
(search-again 'forward) (search-again 'forward)
(send find-canvas focus))]))) (send find-canvas focus))]))
(define move-to-search-or-reverse-search (define (move-to-search-or-reverse-search)
(λ ()
(set-searching-frame this) (set-searching-frame this)
(unhide-search) (unhide-search)
(cond (cond
@ -2324,9 +2338,9 @@
(if (or (send find-canvas has-focus?) (if (or (send find-canvas has-focus?)
(send replace-canvas has-focus?)) (send replace-canvas has-focus?))
(search-again 'backward) (search-again 'backward)
(send find-canvas focus))]))) (send find-canvas focus))]))
(define search-again (define search-again
(opt-lambda ([direction searching-direction] [beep? #t]) (lambda ([direction searching-direction] [beep? #t])
(set-searching-frame this) (set-searching-frame this)
(unhide-search) (unhide-search)
(set-search-direction direction) (set-search-direction direction)

184
collects/framework/private/text.ss
View File

@ -46,7 +46,7 @@ WARNING: printf is rebound in the body of the unit to always
(apply fprintf original-output-port args) (apply fprintf original-output-port args)
(void)) (void))
(define-struct range (start end b/w-bitmap color caret-space?)) (define-struct range (start end b/w-bitmap color caret-space?) #:inspector #f)
(define-struct rectangle (left top right bottom b/w-bitmap color) #:inspector #f) (define-struct rectangle (left top right bottom b/w-bitmap color) #:inspector #f)
(define-values (register-port-name! lookup-port-name) (define-values (register-port-name! lookup-port-name)
@ -96,7 +96,8 @@ WARNING: printf is rebound in the body of the unit to always
delete find-snip invalidate-bitmap-cache delete find-snip invalidate-bitmap-cache
set-file-format get-file-format set-file-format get-file-format
get-style-list is-modified? change-style set-modified get-style-list is-modified? change-style set-modified
position-location get-extent get-filename) position-location position-locations
get-extent get-filename)
(define port-name-identifier #f) (define port-name-identifier #f)
(define/public (get-port-name) (define/public (get-port-name)
@ -124,9 +125,15 @@ WARNING: printf is rebound in the body of the unit to always
(define highlight-tmp-color #f) (define highlight-tmp-color #f)
(define range-rectangles null) (define range-rectangles null)
(define ranges null) (define ranges (make-hash))
(define ranges-low 0)
(define ranges-high 0)
(define ranges-list #f)
(define/public-final (get-highlighted-ranges) ranges) (define/public-final (get-highlighted-ranges)
(unless ranges-list
(set! ranges-list (hash-map ranges (λ (x y) x))))
ranges-list)
(define/public (get-fixed-style) (define/public (get-fixed-style)
(send (get-style-list) find-named-style "Standard")) (send (get-style-list) find-named-style "Standard"))
@ -218,8 +225,9 @@ WARNING: printf is rebound in the body of the unit to always
(define/private (recompute-range-rectangles) (define/private (recompute-range-rectangles)
(let* ([b1 (box 0)] (let* ([b1 (box 0)]
[b2 (box 0)] [b2 (box 0)]
[b3 (box 0)]
[new-rectangles [new-rectangles
(λ (range) (λ (range rst)
(let* ([start (range-start range)] (let* ([start (range-start range)]
[end (range-end range)] [end (range-end range)]
[b/w-bitmap (range-b/w-bitmap range)] [b/w-bitmap (range-b/w-bitmap range)]
@ -229,25 +237,25 @@ WARNING: printf is rebound in the body of the unit to always
[end-eol? (if (= start end) [end-eol? (if (= start end)
start-eol? start-eol?
#t)]) #t)])
(let-values ([(start-x top-start-y) (let-values ([(start-x top-start-y bottom-start-y)
(begin (begin
(position-location start b1 b2 #t start-eol? #t) (send this position-locations start b1 b2 #f b3 start-eol? #t)
(values (if caret-space? (values (if caret-space?
(+ 1 (unbox b1)) (+ 1 (unbox b1))
(unbox b1)) (unbox b1))
(unbox b2)))] (unbox b2)
[(end-x top-end-y) (unbox b3)))]
(begin (position-location end b1 b2 #t end-eol? #t)
(values (unbox b1) (unbox b2)))]
[(bottom-start-y) [(end-x top-end-y bottom-end-y)
(begin (position-location start b1 b2 #f start-eol? #t) (begin (send this position-locations end b1 b2 #f b3 end-eol? #t)
(unbox b2))] (values (unbox b1)
[(bottom-end-y) (unbox b2)
(begin (position-location end b1 b2 #f end-eol? #t) (unbox b3)))])
(unbox b2))])
(cond (cond
[(= top-start-y top-end-y) [(= top-start-y top-end-y)
(list (cons
(make-rectangle start-x (make-rectangle start-x
top-start-y top-start-y
(if (= end-x start-x) (if (= end-x start-x)
@ -255,9 +263,10 @@ WARNING: printf is rebound in the body of the unit to always
end-x) end-x)
bottom-start-y bottom-start-y
b/w-bitmap b/w-bitmap
color))] color)
rst)]
[else [else
(list (list*
(make-rectangle start-x (make-rectangle start-x
top-start-y top-start-y
'right-edge 'right-edge
@ -275,12 +284,14 @@ WARNING: printf is rebound in the body of the unit to always
end-x end-x
bottom-end-y bottom-end-y
b/w-bitmap b/w-bitmap
color))]))))] color)
rst)]))))]
[old-rectangles range-rectangles]) [old-rectangles range-rectangles])
(set! range-rectangles (set! range-rectangles
(foldl (λ (x l) (append (new-rectangles x) l)) (foldl new-rectangles
null ranges)))) null
(get-highlighted-ranges)))))
(define delayed-highlights? #f) (define delayed-highlights? #f)
(define todo void) (define todo void)
@ -311,37 +322,41 @@ WARNING: printf is rebound in the body of the unit to always
(unless (is-a? color color%) (unless (is-a? color color%)
(error 'highlight-range "expected a color for the third argument, got ~s" color)) (error 'highlight-range "expected a color for the third argument, got ~s" color))
(let ([l (make-range start end bitmap color caret-space?)]) (let* ([l (make-range start end bitmap color caret-space?)]
[update-one
(λ ()
(set! ranges-list #f)
(hash-set! ranges l (if (eq? priority 'high) (+ ranges-high 1) (- ranges-low 1)))
(if (eq? priority 'high)
(set! ranges-high (+ ranges-high 1))
(set! ranges-low (- ranges-low 1))))])
(cond (cond
[delayed-highlights? [delayed-highlights?
(set! todo (set! todo
(let ([old-todo todo]) (let ([old-todo todo])
(λ () (λ ()
(old-todo) (old-todo)
(set! ranges (if (eq? priority 'high) (cons l ranges) (append ranges (list l)))))))] (update-one))))]
[else [else
(redraw-highlights (redraw-highlights update-one)])
(λ ()
(set! ranges (if (eq? priority 'high) (cons l ranges) (append ranges (list l))))))])
(λ () (unhighlight-range start end color bitmap caret-space?))))) (λ () (unhighlight-range start end color bitmap caret-space?)))))
(define/private (redraw-highlights todo) (define/private (redraw-highlights todo)
(let ([old-rectangles range-rectangles]) (let ([old-rectangles range-rectangles])
(todo) (todo)
(cond
[(> (hash-count ranges) 20)
(invalidate-bitmap-cache)]
[else
(recompute-range-rectangles) (recompute-range-rectangles)
(invalidate-rectangles (append old-rectangles range-rectangles)))) (invalidate-rectangles (append old-rectangles range-rectangles))])))
(define/public unhighlight-range (define/public unhighlight-range
(opt-lambda (start end color [bitmap #f] [caret-space? #f]) (opt-lambda (start end color [bitmap #f] [caret-space? #f])
(let ([new-todo (let ([new-todo
(λ () (λ ()
(set! ranges (hash-remove! ranges (make-range start end bitmap color caret-space?))
(let loop ([r ranges]) (set! ranges-list #f))])
(cond
[(null? r) r]
[else (if (matching-rectangle? (car r) start end color bitmap caret-space?)
(cdr r)
(cons (car r) (loop (cdr r))))]))))])
(cond (cond
[delayed-highlights? [delayed-highlights?
(set! todo (set! todo
@ -361,7 +376,7 @@ WARNING: printf is rebound in the body of the unit to always
(define/override (on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret) (define/override (on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret)
(super on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret) (super on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret)
(recompute-range-rectangles) (when before (recompute-range-rectangles)) ;; assume this result cannot change between before & after
(let-values ([(view-x view-y view-width view-height) (let-values ([(view-x view-y view-width view-height)
(let ([b1 (box 0)] (let ([b1 (box 0)]
[b2 (box 0)] [b2 (box 0)]
@ -373,14 +388,19 @@ WARNING: printf is rebound in the body of the unit to always
(unbox b3) (unbox b3)
(unbox b4)))]) (unbox b4)))])
(let ([old-pen (send dc get-pen)]
[old-brush (send dc get-brush)]
[last-color #f])
(for-each (for-each
(λ (rectangle) (λ (rectangle)
(let* ([old-pen (send dc get-pen)] (let* ([b/w-bitmap (rectangle-b/w-bitmap rectangle)]
[old-brush (send dc get-brush)]
[b/w-bitmap (rectangle-b/w-bitmap rectangle)]
[color (let ([rc (rectangle-color rectangle)]) [color (let ([rc (rectangle-color rectangle)])
(if rc (cond
(begin (unless highlight-tmp-color [(and last-color (eq? last-color rc))
rc]
[rc
(set! last-color #f)
(unless highlight-tmp-color
(set! highlight-tmp-color (make-object color% 0 0 0))) (set! highlight-tmp-color (make-object color% 0 0 0)))
(send dc try-color rc highlight-tmp-color) (send dc try-color rc highlight-tmp-color)
(if (<= (color-model:rgb-color-distance (if (<= (color-model:rgb-color-distance
@ -391,9 +411,12 @@ WARNING: printf is rebound in the body of the unit to always
(send highlight-tmp-color green) (send highlight-tmp-color green)
(send highlight-tmp-color blue)) (send highlight-tmp-color blue))
18) 18)
rc (begin (set! last-color rc)
#f)) rc)
rc))] #f)]
[else
(set! last-color #f)
rc]))]
[first-number (λ (x y) (if (number? x) x y))] [first-number (λ (x y) (if (number? x) x y))]
[left (max left-margin (first-number (rectangle-left rectangle) view-x))] [left (max left-margin (first-number (rectangle-left rectangle) view-x))]
[top (max top-margin (rectangle-top rectangle))] [top (max top-margin (rectangle-top rectangle))]
@ -420,10 +443,10 @@ WARNING: printf is rebound in the body of the unit to always
(send dc set-brush highlight-brush)] (send dc set-brush highlight-brush)]
[else (set! skip-it? #t)]) [else (set! skip-it? #t)])
(unless skip-it? (unless skip-it?
(send dc draw-rectangle (+ left dx) (+ top dy) width height) (send dc draw-rectangle (+ left dx) (+ top dy) width height)))))
range-rectangles)
(send dc set-pen old-pen) (send dc set-pen old-pen)
(send dc set-brush old-brush))))) (send dc set-brush old-brush))))
range-rectangles)))
(define styles-fixed? #f) (define styles-fixed? #f)
(public get-styles-fixed set-styles-fixed) (public get-styles-fixed set-styles-fixed)
@ -528,12 +551,73 @@ WARNING: printf is rebound in the body of the unit to always
(inner (void) after-insert start len)) (inner (void) after-insert start len))
(super-instantiate ()))) (super-instantiate ())))
(define searching<%> (interface (editor:keymap<%> basic<%>))) (define searching<%>
(interface (editor:keymap<%> basic<%>)
set-searching-str))
(define searching-mixin (define searching-mixin
(mixin (editor:keymap<%> basic<%>) (searching<%>) (mixin (editor:keymap<%> basic<%>) (searching<%>)
(define/override (get-keymaps) (define/override (get-keymaps)
(cons (keymap:get-search) (super get-keymaps))) (cons (keymap:get-search) (super get-keymaps)))
(super-instantiate ())))
(define searching-str #f)
(define case-sensitive? #f)
(define search-hits 0)
(define/public (get-search-hits) search-hits)
(inherit invalidate-bitmap-cache)
(define/public (set-searching-str s [cs? #t])
(unless (and (equal? searching-str s)
(equal? case-sensitive? cs?))
(set! searching-str s)
(set! case-sensitive? cs?)
(redo-search)))
(define/augment (after-insert start len)
(redo-search)
(inner (void) after-insert start len))
(define/augment (after-delete start len)
(redo-search)
(inner (void) after-delete start len))
(inherit highlight-range begin-edit-sequence end-edit-sequence find-string)
(define clear-regions void)
(define/private (redo-search)
(begin-edit-sequence)
(set! search-hits 0)
(clear-regions)
(cond
[searching-str
(let loop ([pos 0]
[n 0])
(let ([next (do-search searching-str pos 'eof)])
(when next
(let-values ([(end counts) (find-end (+ next (string-length searching-str))
searching-str)])
(set! search-hits (+ search-hits counts))
(let ([old clear-regions]
[new (highlight-range next end (send the-color-database find-color "yellow"))])
(set! clear-regions (λ () (old) (new))))
(loop end (+ n 1))))))]
[else
(invalidate-bitmap-cache)])
(end-edit-sequence))
(define/private (find-end pos searching-str)
(let loop ([pos pos]
[count 1])
(cond
[(do-search searching-str pos (+ pos (string-length searching-str)))
=>
(λ (pos)
;; if find-string returns #t here, then we know that we've found two of the search strings in a row, so just coalesce them
(loop (+ pos (string-length searching-str))
(+ count 1)))]
[else
(values pos count)])))
(define/private (do-search str start end) (find-string str 'forward start end #t case-sensitive?))
(super-new)))
(define return<%> (interface ((class->interface text%)))) (define return<%> (interface ((class->interface text%))))
(define return-mixin (define return-mixin

10
collects/scribblings/framework/text.scrbl
View File

@ -206,6 +206,16 @@
} }
@definterface[text:searching<%> (editor:keymap<%> text:basic<%>)]{ @definterface[text:searching<%> (editor:keymap<%> text:basic<%>)]{
Any object matching this interface can be searched. Any object matching this interface can be searched.
@defmethod[(set-searching-str [str (or/c false/c string?)] [cs? boolean? #t]) void?]{
If @scheme[str] is not @scheme[#f], then this method highlights
every occurrence of @scheme[str] in the editor. If @scheme[str] is
@scheme[#f], then it clears all of the highlighting in the buffer.
If @scheme[cs?] is @scheme[#f], the search is case-insensitive, and
otherwise it is case-sensitive.
}
} }
@defmixin[text:searching-mixin (editor:keymap<%> text:basic<%>) (text:searching<%>)]{ @defmixin[text:searching-mixin (editor:keymap<%> text:basic<%>) (text:searching<%>)]{
This This