From e2c49f49632ad7ec590ca14dff70e21887cf9860 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 21 Jul 2008 22:17:54 +0000 Subject: [PATCH] more speedups for the highlighting and some setup for improving docked search svn: r10855 --- collects/framework/private/frame.ss | 108 +++++---- collects/framework/private/text.ss | 266 ++++++++++++++-------- collects/scribblings/framework/text.scrbl | 10 + 3 files changed, 246 insertions(+), 138 deletions(-) diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index ff87f44644..07dcbb87ab 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -1,15 +1,13 @@ #lang scheme/unit (require string-constants - mzlib/class + scheme/class mzlib/include "sig.ss" "../preferences.ss" "../gui-utils.ss" "bday.ss" mred/mred-sig - mzlib/list - scheme/path - mzlib/etc) + scheme/path) (import mred^ [prefix group: framework:group^] @@ -61,7 +59,7 @@ menus)) (define add-snip-menu-items - (opt-lambda (edit-menu c% [func void]) + (lambda (edit-menu c% [func void]) (let* ([get-edit-target-object (λ () (let ([menu-bar @@ -1087,7 +1085,7 @@ (make-object %))) (define/public save - (opt-lambda ([format 'same]) + (lambda ([format 'same]) (let* ([ed (get-editor)] [filename (send ed get-filename)]) (if filename @@ -1095,7 +1093,7 @@ (save-as format))))) (define/public save-as - (opt-lambda ([format 'same]) + (lambda ([format 'same]) (let* ([editor (get-editor)] [name (send editor get-filename)]) (let-values ([(base name) @@ -1837,10 +1835,9 @@ (set! searching-direction x)) (define old-search-highlight void) - (define clear-search-highlight - (λ () - (begin (old-search-highlight) - (set! old-search-highlight void)))) + (define (clear-search-highlight) + (old-search-highlight) + (set! old-search-highlight void)) (define reset-search-anchor (let ([color (make-object color% "BLUE")]) (λ (edit) @@ -1856,14 +1853,14 @@ (send edit highlight-range position position color #f)))))) (define find-string-embedded - (opt-lambda (edit - str - [direction 'forward] - [start 'start] - [end 'eof] - [get-start #t] - [case-sensitive? #t] - [pop-out? #f]) + (lambda (edit + str + [direction 'forward] + [start 'start] + [end 'eof] + [get-start #t] + [case-sensitive? #t] + [pop-out? #f]) (unless (member direction '(forward backward)) (error 'find-string-embedded "expected ~e or ~e as first argument, got: ~e" 'forward 'backward direction)) @@ -1951,7 +1948,7 @@ (and searching-frame (send searching-frame get-text-to-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 (let* ([string (get-text)] [top-searching-edit (get-searching-edit)] @@ -2002,6 +1999,16 @@ (send text end-edit-sequence) #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 "") (not-found top-searching-edit #t) (begin @@ -2141,13 +2148,16 @@ (define/public (get-text-to-search) (error 'get-text-to-search "abstract method in searchable-mixin")) + (define/public hide-search - (opt-lambda ([startup? #f]) + (lambda ([startup? #f]) (when search-gui-built? (send super-root change-children (λ (l) (remove search-panel l)))) (clear-search-highlight) + #; + (send (get-text-to-search) set-searching-str #f #f) (unless startup? (let ([canvas (send (get-text-to-search) get-canvas)]) (when canvas @@ -2168,6 +2178,12 @@ (show/hide-replace (send (get-text-to-search) is-locked?)) (send search-panel focus) (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)) (send super-root add-child search-panel)) (reset-search-anchor (get-text-to-search)))) @@ -2300,33 +2316,31 @@ [else find-canvas]) focus))) - (define move-to-search-or-search - (λ () - (set-searching-frame this) - (unhide-search) - (cond - [(preferences:get 'framework:search-using-dialog?) - (search-dialog this)] - [else - (if (or (send find-canvas has-focus?) - (send replace-canvas has-focus?)) - (search-again 'forward) - (send find-canvas focus))]))) - (define move-to-search-or-reverse-search - (λ () - (set-searching-frame this) - (unhide-search) - (cond - [(preferences:get 'framework:search-using-dialog?) - (search-again 'backward) - (set-searching-direction 'forward)] - [else - (if (or (send find-canvas has-focus?) - (send replace-canvas has-focus?)) - (search-again 'backward) - (send find-canvas focus))]))) + (define (move-to-search-or-search) + (set-searching-frame this) + (unhide-search) + (cond + [(preferences:get 'framework:search-using-dialog?) + (search-dialog this)] + [else + (if (or (send find-canvas has-focus?) + (send replace-canvas has-focus?)) + (search-again 'forward) + (send find-canvas focus))])) + (define (move-to-search-or-reverse-search) + (set-searching-frame this) + (unhide-search) + (cond + [(preferences:get 'framework:search-using-dialog?) + (search-again 'backward) + (set-searching-direction 'forward)] + [else + (if (or (send find-canvas has-focus?) + (send replace-canvas has-focus?)) + (search-again 'backward) + (send find-canvas focus))])) (define search-again - (opt-lambda ([direction searching-direction] [beep? #t]) + (lambda ([direction searching-direction] [beep? #t]) (set-searching-frame this) (unhide-search) (set-search-direction direction) diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index 589d40b59a..49c8bfea65 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -46,7 +46,7 @@ WARNING: printf is rebound in the body of the unit to always (apply fprintf original-output-port args) (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-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 set-file-format get-file-format 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/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 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) (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) (let* ([b1 (box 0)] [b2 (box 0)] + [b3 (box 0)] [new-rectangles - (λ (range) + (λ (range rst) (let* ([start (range-start range)] [end (range-end 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) start-eol? #t)]) - (let-values ([(start-x top-start-y) + (let-values ([(start-x top-start-y bottom-start-y) (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? (+ 1 (unbox b1)) (unbox b1)) - (unbox b2)))] - [(end-x top-end-y) - (begin (position-location end b1 b2 #t end-eol? #t) - (values (unbox b1) (unbox b2)))] - [(bottom-start-y) - (begin (position-location start b1 b2 #f start-eol? #t) - (unbox b2))] - [(bottom-end-y) - (begin (position-location end b1 b2 #f end-eol? #t) - (unbox b2))]) + (unbox b2) + (unbox b3)))] + + + [(end-x top-end-y bottom-end-y) + (begin (send this position-locations end b1 b2 #f b3 end-eol? #t) + (values (unbox b1) + (unbox b2) + (unbox b3)))]) + (cond [(= top-start-y top-end-y) - (list + (cons (make-rectangle start-x top-start-y (if (= end-x start-x) @@ -255,9 +263,10 @@ WARNING: printf is rebound in the body of the unit to always end-x) bottom-start-y b/w-bitmap - color))] + color) + rst)] [else - (list + (list* (make-rectangle start-x top-start-y 'right-edge @@ -275,12 +284,14 @@ WARNING: printf is rebound in the body of the unit to always end-x bottom-end-y b/w-bitmap - color))]))))] + color) + rst)]))))] [old-rectangles range-rectangles]) (set! range-rectangles - (foldl (λ (x l) (append (new-rectangles x) l)) - null ranges)))) + (foldl new-rectangles + null + (get-highlighted-ranges))))) (define delayed-highlights? #f) (define todo void) @@ -311,37 +322,41 @@ WARNING: printf is rebound in the body of the unit to always (unless (is-a? color 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 [delayed-highlights? (set! todo (let ([old-todo todo]) (λ () (old-todo) - (set! ranges (if (eq? priority 'high) (cons l ranges) (append ranges (list l)))))))] + (update-one))))] [else - (redraw-highlights - (λ () - (set! ranges (if (eq? priority 'high) (cons l ranges) (append ranges (list l))))))]) + (redraw-highlights update-one)]) (λ () (unhighlight-range start end color bitmap caret-space?))))) (define/private (redraw-highlights todo) (let ([old-rectangles range-rectangles]) (todo) - (recompute-range-rectangles) - (invalidate-rectangles (append old-rectangles range-rectangles)))) + (cond + [(> (hash-count ranges) 20) + (invalidate-bitmap-cache)] + [else + (recompute-range-rectangles) + (invalidate-rectangles (append old-rectangles range-rectangles))]))) (define/public unhighlight-range (opt-lambda (start end color [bitmap #f] [caret-space? #f]) (let ([new-todo (λ () - (set! ranges - (let loop ([r ranges]) - (cond - [(null? r) r] - [else (if (matching-rectangle? (car r) start end color bitmap caret-space?) - (cdr r) - (cons (car r) (loop (cdr r))))]))))]) + (hash-remove! ranges (make-range start end bitmap color caret-space?)) + (set! ranges-list #f))]) (cond [delayed-highlights? (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) (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 ([b1 (box 0)] [b2 (box 0)] @@ -373,57 +388,65 @@ WARNING: printf is rebound in the body of the unit to always (unbox b3) (unbox b4)))]) - (for-each - (λ (rectangle) - (let* ([old-pen (send dc get-pen)] - [old-brush (send dc get-brush)] - [b/w-bitmap (rectangle-b/w-bitmap rectangle)] - [color (let ([rc (rectangle-color rectangle)]) - (if rc - (begin (unless highlight-tmp-color - (set! highlight-tmp-color (make-object color% 0 0 0))) - (send dc try-color rc highlight-tmp-color) - (if (<= (color-model:rgb-color-distance - (send rc red) - (send rc green) - (send rc blue) - (send highlight-tmp-color red) - (send highlight-tmp-color green) - (send highlight-tmp-color blue)) - 18) - rc - #f)) - rc))] - [first-number (λ (x y) (if (number? x) x y))] - [left (max left-margin (first-number (rectangle-left rectangle) view-x))] - [top (max top-margin (rectangle-top rectangle))] - [right (min right-margin - (first-number - (rectangle-right rectangle) - (+ view-x view-width)))] - [bottom (min bottom-margin (rectangle-bottom rectangle))] - [width (max 0 (- right left))] - [height (max 0 (- bottom top))]) - (let ([skip-it? #f]) - (cond - [(and before color) - (send dc set-pen (send the-pen-list find-or-create-pen color 0 'solid)) - (send dc set-brush (send the-brush-list find-or-create-brush color 'solid))] - [(and (not before) (not color) b/w-bitmap) - (unless highlight-pen - (set! highlight-pen (make-object pen% "BLACK" 0 'solid))) - (unless highlight-brush - (set! highlight-brush (make-object brush% "black" 'solid))) - (send highlight-pen set-stipple b/w-bitmap) - (send highlight-brush set-stipple b/w-bitmap) - (send dc set-pen highlight-pen) - (send dc set-brush highlight-brush)] - [else (set! skip-it? #t)]) - (unless skip-it? - (send dc draw-rectangle (+ left dx) (+ top dy) width height) - (send dc set-pen old-pen) - (send dc set-brush old-brush))))) - range-rectangles))) + (let ([old-pen (send dc get-pen)] + [old-brush (send dc get-brush)] + [last-color #f]) + (for-each + (λ (rectangle) + (let* ([b/w-bitmap (rectangle-b/w-bitmap rectangle)] + [color (let ([rc (rectangle-color rectangle)]) + (cond + [(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))) + (send dc try-color rc highlight-tmp-color) + (if (<= (color-model:rgb-color-distance + (send rc red) + (send rc green) + (send rc blue) + (send highlight-tmp-color red) + (send highlight-tmp-color green) + (send highlight-tmp-color blue)) + 18) + (begin (set! last-color rc) + rc) + #f)] + [else + (set! last-color #f) + rc]))] + [first-number (λ (x y) (if (number? x) x y))] + [left (max left-margin (first-number (rectangle-left rectangle) view-x))] + [top (max top-margin (rectangle-top rectangle))] + [right (min right-margin + (first-number + (rectangle-right rectangle) + (+ view-x view-width)))] + [bottom (min bottom-margin (rectangle-bottom rectangle))] + [width (max 0 (- right left))] + [height (max 0 (- bottom top))]) + (let ([skip-it? #f]) + (cond + [(and before color) + (send dc set-pen (send the-pen-list find-or-create-pen color 0 'solid)) + (send dc set-brush (send the-brush-list find-or-create-brush color 'solid))] + [(and (not before) (not color) b/w-bitmap) + (unless highlight-pen + (set! highlight-pen (make-object pen% "BLACK" 0 'solid))) + (unless highlight-brush + (set! highlight-brush (make-object brush% "black" 'solid))) + (send highlight-pen set-stipple b/w-bitmap) + (send highlight-brush set-stipple b/w-bitmap) + (send dc set-pen highlight-pen) + (send dc set-brush highlight-brush)] + [else (set! skip-it? #t)]) + (unless skip-it? + (send dc draw-rectangle (+ left dx) (+ top dy) width height))))) + range-rectangles) + (send dc set-pen old-pen) + (send dc set-brush old-brush)))) (define styles-fixed? #f) (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)) (super-instantiate ()))) -(define searching<%> (interface (editor:keymap<%> basic<%>))) +(define searching<%> + (interface (editor:keymap<%> basic<%>) + set-searching-str)) (define searching-mixin (mixin (editor:keymap<%> basic<%>) (searching<%>) (define/override (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-mixin diff --git a/collects/scribblings/framework/text.scrbl b/collects/scribblings/framework/text.scrbl index 1ca1378dd2..d9a2e4e2ad 100644 --- a/collects/scribblings/framework/text.scrbl +++ b/collects/scribblings/framework/text.scrbl @@ -206,6 +206,16 @@ } @definterface[text:searching<%> (editor:keymap<%> text:basic<%>)]{ 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<%>)]{ This