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

...

Browse Source 
original commit: 4019c61727371ac44e0db0e12ec0771998084c06
This commit is contained in:
Robby Findler 1999-04-16 23:06:44 +00:00
parent a74c591861
commit db5b82c1f7
4 changed files with 131 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/framework/canvas.ss
View File

@ -17,7 +17,6 @@
[tall-snips null] [tall-snips null]
[update-snip-size [update-snip-size
(lambda (width?) (lambda (width?)
(printf "update-snip-size: ~a~n" width?)
(lambda (s) (lambda (s)
(let* ([width (box 0)] (let* ([width (box 0)]
[height (box 0)] [height (box 0)]

146
collects/framework/frame.ss
View File

@ -389,6 +389,110 @@
'(set! old-search-highlight '(set! old-search-highlight
(send edit highlight-range position position color #f)))))) (send edit highlight-range position position color #f))))))
(define find-string-embedded
(let ([default-direction 'forward]
[default-start 'start]
[default-end 'eof]
[default-get-start #t]
[default-case-sensitive? #t]
[default-pop-out? #t])
(case-lambda
[(edit str)
(find-string-embedded edit str default-direction default-start default-end default-get-start default-case-sensitive? default-pop-out?)]
[(edit str direction)
(find-string-embedded edit str direction default-start default-end default-get-start default-case-sensitive? default-pop-out?)]
[(edit str direction start)
(find-string-embedded edit str direction start default-end default-get-start default-case-sensitive? default-pop-out?)]
[(edit str direction start end)
(find-string-embedded edit str direction start end default-get-start default-case-sensitive? default-pop-out?)]
[(edit str direction start end get-start)
(find-string-embedded edit str direction start end get-start default-case-sensitive? default-pop-out?)]
[(edit str direction start end get-start case-sensitive?)
(find-string-embedded edit str direction start end get-start case-sensitive? default-pop-out?)]
[(edit str direction start end get-start case-sensitive? pop-out?)
(unless (member direction '(forward backward))
(error 'find-string-embedded
"expected ~e or ~e as first argument, got: ~e" 'forward 'backward direction))
(let/ec k
(let* ([start (if (eq? start 'start)
(send edit get-start-position)
start)]
[end (if (eq? 'eof end)
(if (eq? direction 'forward)
(send edit last-position)
0)
end)]
[flat (send edit find-string str direction
start end get-start
case-sensitive?)]
[pop-out
(lambda ()
(let ([admin (send edit get-admin)])
(if (is-a? admin editor-snip-editor-admin%)
(let* ([snip (send admin get-snip)]
[edit-above (send (send snip get-admin) get-editor)]
[pos (send edit-above get-snip-position snip)]
[pop-out-pos (if (eq? direction 'forward) (add1 pos) pos)])
(printf "popping out to ~a~n" pop-out-pos)
(find-string-embedded
edit-above
str
direction
pop-out-pos
(if (eq? direction 'forward) 'eof 0)
get-start
case-sensitive?
pop-out?))
(values edit #f))))])
(printf "flat: ~a start: ~a end: ~a~n" flat start end)
(let loop ([current-snip (send edit find-snip start
(if (eq? direction 'forward)
'after-or-none
'before-or-none))])
(printf "searching snips: ~s ~s~n" current-snip
(and current-snip (send current-snip get-text 0 (send current-snip get-count))))
(let ([next-loop
(lambda ()
(if (eq? direction 'forward)
(loop (send current-snip next))
(loop (send current-snip previous))))])
(cond
[(or (not current-snip)
(and flat
(let* ([start (send edit get-snip-position current-snip)]
[end (+ start (send current-snip get-count))])
(if (eq? direction 'forward)
(and (<= start flat)
(< flat end))
(and (< start flat)
(<= flat end))))))
(if (and (not flat) pop-out?)
(pop-out)
(values edit flat))]
[(is-a? current-snip original:editor-snip%)
(printf "found embedded editor~n")
(let-values ([(embedded embedded-pos)
(let ([media (send current-snip get-editor)])
(if (and media
(is-a? media original:text%))
(begin
(printf "searching in embedded editor~n")
(find-string-embedded
media
str
direction
(if (eq? 'forward direction)
0
(send media last-position))
'eof
get-start case-sensitive?))
(values #f #f)))])
(printf "embedded: ~a embedded-pos ~a~n" embedded embedded-pos)
(if (not embedded-pos)
(next-loop)
(values embedded embedded-pos)))]
[else (next-loop)])))))])))
(define find-text% (define find-text%
(class-asi text% (class-asi text%
(inherit get-text) (inherit get-text)
@ -408,7 +512,13 @@
(opt-lambda ([reset-search-anchor? #t] [beep? #t] [wrap? #t]) (opt-lambda ([reset-search-anchor? #t] [beep? #t] [wrap? #t])
(when searching-frame (when searching-frame
(let* ([string (get-text)] (let* ([string (get-text)]
[searching-edit (get-searching-edit)] [top-searching-edit (get-searching-edit)]
[searching-edit (let ([focus-snip (send top-searching-edit get-focus-snip)])
(if focus-snip
(send focus-snip get-editor)
top-searching-edit))]
[not-found [not-found
(lambda (found-edit) (lambda (found-edit)
(send found-edit set-position search-anchor) (send found-edit set-position search-anchor)
@ -420,32 +530,32 @@
(let ([last-pos ((if (eq? searching-direction 'forward) + -) (let ([last-pos ((if (eq? searching-direction 'forward) + -)
first-pos (string-length string))]) first-pos (string-length string))])
(send* edit (send* edit
(set-caret-owner #f 'display) (set-caret-owner #f 'display)
(set-position (set-position
(min first-pos last-pos) (min first-pos last-pos)
(max first-pos last-pos))) (max first-pos last-pos)))
#t))]) #t))])
(unless (string=? string "") (unless (string=? string "")
(when reset-search-anchor? (when reset-search-anchor?
(reset-search-anchor searching-edit)) (reset-search-anchor searching-edit))
(let-values ([(found-edit first-pos) (let-values ([(found-edit first-pos)
(send searching-edit (find-string-embedded
find-string-embedded searching-edit
string string
searching-direction searching-direction
search-anchor search-anchor
'eof #t #t #t)]) 'eof #t #t #t)])
(cond (cond
[(not first-pos) [(not first-pos)
(if wrap? (if wrap?
(let-values ([(found-edit pos) (let-values ([(found-edit pos)
(send searching-edit (find-string-embedded
find-string-embedded searching-edit
string string
searching-direction searching-direction
(if (eq? 'forward searching-direction) (if (eq? 'forward searching-direction)
0 0
(send searching-edit last-position)))]) (send searching-edit last-position)))])
(if (not pos) (if (not pos)
(not-found found-edit) (not-found found-edit)
(found found-edit pos))) (found found-edit pos)))

2
collects/framework/prefs.ss
View File

@ -103,7 +103,7 @@
(if (checker unmarsh) (if (checker unmarsh)
unmarsh unmarsh
(begin (begin
(printf "WARNING: ~s rejecting invalid pref ~s in favor of ~s (pred: ~s)~n" '(printf "WARNING: ~s rejecting invalid pref ~s in favor of ~s (pred: ~s)~n"
p unmarsh default checker) p unmarsh default checker)
default)))] default)))]
[pref (if (check-callbacks p unmarshalled) [pref (if (check-callbacks p unmarshalled)

84
collects/framework/text.ss
View File

@ -302,9 +302,7 @@
(apply super-init args) (apply super-init args)
(set-autowrap-bitmap (initial-autowrap-bitmap))))) (set-autowrap-bitmap (initial-autowrap-bitmap)))))
(define searching<%> (define searching<%> (interface (editor:keymap<%> basic<%>)))
(interface ()
find-string-embedded))
(define searching-mixin (define searching-mixin
(mixin (editor:keymap<%> basic<%>) (searching<%>) args (mixin (editor:keymap<%> basic<%>) (searching<%>) args
(inherit get-end-position get-start-position last-position (inherit get-end-position get-start-position last-position
@ -316,85 +314,7 @@
(if (eq? type 'text) (if (eq? type 'text)
(make-object editor-snip% (make-object searching%)) (make-object editor-snip% (make-object searching%))
(super-on-new-box)))]) (super-on-new-box)))])
(public (public)
[find-string-embedded
(opt-lambda (str [direction 'forward] [start 'start]
[end 'eof] [get-start #t]
[case-sensitive? #t] [pop-out? #t])
(unless (member direction '(forward backward))
(error 'find-string-embedded
"expected ~e or ~e as first argument, got: ~e" 'forward 'backward direction))
(let/ec k
(let* ([start (if (eq? start 'start)
(get-start-position)
start)]
[end (if (eq? 'eof end)
(if (eq? direction 'forward)
(last-position)
0)
end)]
[flat (find-string str direction
start end get-start
case-sensitive?)]
[pop-out
(lambda ()
(let ([admin (get-admin)])
(if (is-a? admin editor-snip-editor-admin%)
(let* ([snip (send admin get-snip)]
[edit-above (send (send snip get-admin) get-editor)]
[pos (send edit-above get-snip-position snip)])
(send edit-above
find-string-embedded
str
direction
(if (eq? direction 'forward) (add1 pos) pos)
'eof get-start
case-sensitive? pop-out?))
(values this #f))))])
(let loop ([current-snip (find-snip start
(if (eq? direction 'forward)
'after-or-none
'before-or-none))])
(printf "searching snips: ~a~n" current-snip)
(let ([next-loop
(lambda ()
(if (eq? direction 'forward)
(loop (send current-snip next))
(loop (send current-snip previous))))])
(cond
[(or (not current-snip)
(and flat
(let* ([start (get-snip-position current-snip)]
[end (+ start (send current-snip get-count))])
(if (eq? direction 'forward)
(and (<= start flat)
(< flat end))
(and (< start flat)
(<= flat end))))))
(if (and (not flat) pop-out?)
(pop-out)
(values this flat))]
[(is-a? current-snip original:editor-snip%)
(printf "found embedded editor~n")
(let-values ([(embedded embedded-pos)
(let ([media (send current-snip get-editor)])
(if (and media
(is-a? media searching<%>))
(begin
(printf "searching in embedded editor~n")
(send media find-string-embedded str
direction
(if (eq? 'forward direction)
0
(send media last-position))
'eof
get-start case-sensitive?))
(values #f #f)))])
(printf "embedded: ~a embedded-pos ~a~n" embedded embedded-pos)
(if (not embedded-pos)
(next-loop)
(values embedded embedded-pos)))]
[else (next-loop)]))))))])
(rename [super-get-keymaps get-keymaps]) (rename [super-get-keymaps get-keymaps])
(override (override