...
original commit: b8eec9ad84cfde135910f68a6e484d140785415f
This commit is contained in:
Robby Findler
parent
6ddacd57a6
commit
b588d16de8
|
|
@ -309,7 +309,7 @@
|
|||
move-to-search-or-reverse-search
|
||||
search))
|
||||
(define search-anchor 0)
|
||||
(define searching-direction 1)
|
||||
(define searching-direction 'forward)
|
||||
(define old-search-highlight void)
|
||||
(define get-active-embedded-edit
|
||||
(lambda (edit)
|
||||
|
|
@ -328,7 +328,7 @@
|
|||
(lambda (edit)
|
||||
(old-search-highlight)
|
||||
(let ([position
|
||||
(if (= 1 searching-direction)
|
||||
(if (eq? 'forward searching-direction)
|
||||
(send edit get-end-position)
|
||||
(send edit get-start-position))])
|
||||
(set! search-anchor position)
|
||||
|
|
@ -363,7 +363,7 @@
|
|||
#f)]
|
||||
[found
|
||||
(lambda (edit first-pos)
|
||||
(let ([last-pos (+ first-pos (* searching-direction
|
||||
(let ([last-pos (+ first-pos (* (if (eq? searching-direction 'forward) 1 -1)
|
||||
(string-length string)))])
|
||||
(send* edit
|
||||
(set-caret-owner #f 'display)
|
||||
|
|
@ -379,22 +379,22 @@
|
|||
string
|
||||
searching-direction
|
||||
search-anchor
|
||||
-1 #t #t #t)])
|
||||
'eof #t #t #t)])
|
||||
(cond
|
||||
[(= -1 first-pos)
|
||||
[(not first-pos)
|
||||
(if wrap?
|
||||
(let-values ([(found-edit pos)
|
||||
(send searching-edit
|
||||
find-string-embedded
|
||||
string
|
||||
searching-direction
|
||||
(if (= 1 searching-direction)
|
||||
(if (eq? 'forward searching-direction)
|
||||
0
|
||||
(send searching-edit last-position)))])
|
||||
(if (= -1 pos)
|
||||
(if (not pos)
|
||||
(not-found found-edit)
|
||||
(found found-edit
|
||||
((if (= searching-direction 1)
|
||||
((if (eq? searching-direction 'forward)
|
||||
+
|
||||
-)
|
||||
pos
|
||||
|
|
@ -518,14 +518,14 @@
|
|||
[replace-all
|
||||
(lambda ()
|
||||
(let* ([replacee-edit (get-text-to-search)]
|
||||
[pos (if (= searching-direction 1)
|
||||
[pos (if (eq? searching-direction 'forward)
|
||||
(send replacee-edit get-start-position)
|
||||
(send replacee-edit get-end-position))]
|
||||
[get-pos
|
||||
(if (= searching-direction 1)
|
||||
(if (eq? searching-direction 'forward)
|
||||
(ivar replacee-edit get-end-position)
|
||||
(ivar replacee-edit get-start-position))]
|
||||
[done? (if (= 1 searching-direction)
|
||||
[done? (if (eq? 'forward searching-direction)
|
||||
(lambda (x) (>= x (send replacee-edit last-position)))
|
||||
(lambda (x) (<= x 0)))])
|
||||
(send* replacee-edit
|
||||
|
|
@ -558,9 +558,9 @@
|
|||
(lambda ()
|
||||
(unhide-search)
|
||||
(send (cond
|
||||
[(send find-canvas is-focus-on?)
|
||||
[(send find-canvas has-focus?)
|
||||
replace-canvas]
|
||||
[(send replace-canvas is-focus-on?)
|
||||
[(send replace-canvas has-focus?)
|
||||
(send (get-text-to-search) get-canvas)]
|
||||
[else
|
||||
find-canvas])
|
||||
|
|
@ -568,15 +568,15 @@
|
|||
[move-to-search-or-search
|
||||
(lambda ()
|
||||
(unhide-search)
|
||||
(if (or (send find-canvas is-focus-on?)
|
||||
(send replace-canvas is-focus-on?))
|
||||
(if (or (send find-canvas has-focus?)
|
||||
(send replace-canvas has-focus?))
|
||||
(search 1)
|
||||
(send find-canvas focus)))]
|
||||
[move-to-search-or-reverse-search
|
||||
(lambda ()
|
||||
(unhide-search)
|
||||
(if (or (send find-canvas is-focus-on?)
|
||||
(send replace-canvas is-focus-on?))
|
||||
(if (or (send find-canvas has-focus?)
|
||||
(send replace-canvas has-focus?))
|
||||
(search -1)
|
||||
(send find-canvas focus)))]
|
||||
[search
|
||||
|
|
@ -620,8 +620,8 @@
|
|||
middle-right-panel
|
||||
(lambda (dir-radio evt)
|
||||
(let ([forward (if (= 0 (send evt get-command-int))
|
||||
1
|
||||
-1)])
|
||||
'forward
|
||||
'backward)])
|
||||
(set-search-direction forward)
|
||||
(reset-search-anchor (get-text-to-search)))))]
|
||||
[close-button (make-object button% "Hide"
|
||||
|
|
|
|||
|
|
@ -5,15 +5,15 @@
|
|||
[keymap : framework:keymap^]
|
||||
[gui-utils : framework:gui-utils^]
|
||||
[mzlib:function : mzlib:function^])
|
||||
|
||||
|
||||
(rename [-keymap% keymap%])
|
||||
|
||||
|
||||
(define-struct range (start end b/w-bitmap color caret-space?))
|
||||
(define-struct rectangle (left top right bottom b/w-bitmap color))
|
||||
|
||||
|
||||
;; wx: `default-wrapping?', add as the initial value for auto-wrap bitmap,
|
||||
;; unless matthew makes it primitive
|
||||
|
||||
|
||||
(define basic<%>
|
||||
(interface (text<%>)
|
||||
highlight-range
|
||||
|
|
@ -21,502 +21,499 @@
|
|||
set-styles-fixed
|
||||
move/copy-to-edit
|
||||
initial-autowrap-bitmap))
|
||||
|
||||
|
||||
(define basic-mixin
|
||||
(mixin (editor:basic<%> text<%>) (basic<%>) args
|
||||
(inherit get-canvases get-admin split-snip get-snip-position
|
||||
delete find-snip invalidate-bitmap-cache
|
||||
set-autowrap-bitmap
|
||||
set-file-format get-file-format
|
||||
get-style-list is-modified? change-style set-modified
|
||||
position-location get-extent)
|
||||
|
||||
(private
|
||||
[b1 (box 0)]
|
||||
[b2 (box 0)]
|
||||
[b3 (box 0)]
|
||||
[b4 (box 0)]
|
||||
[range-rectangles null]
|
||||
[recompute-range-rectangles
|
||||
(lambda ()
|
||||
(let ([new-rectangles
|
||||
(lambda (range)
|
||||
(let* ([start (range-start range)]
|
||||
[end (range-end range)]
|
||||
[b/w-bitmap (range-b/w-bitmap range)]
|
||||
[color (range-color range)]
|
||||
[caret-space? (range-caret-space? range)]
|
||||
[start-eol? #f]
|
||||
[end-eol? (if (= start end)
|
||||
start-eol?
|
||||
#t)])
|
||||
(let-values ([(start-x top-start-y)
|
||||
(begin
|
||||
(position-location start b1 b2 #t 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))])
|
||||
(inherit get-canvases get-admin split-snip get-snip-position
|
||||
delete find-snip invalidate-bitmap-cache
|
||||
set-autowrap-bitmap
|
||||
set-file-format get-file-format
|
||||
get-style-list is-modified? change-style set-modified
|
||||
position-location get-extent)
|
||||
|
||||
(private
|
||||
[b1 (box 0)]
|
||||
[b2 (box 0)]
|
||||
[b3 (box 0)]
|
||||
[b4 (box 0)]
|
||||
[range-rectangles null]
|
||||
[recompute-range-rectangles
|
||||
(lambda ()
|
||||
(let ([new-rectangles
|
||||
(lambda (range)
|
||||
(let* ([start (range-start range)]
|
||||
[end (range-end range)]
|
||||
[b/w-bitmap (range-b/w-bitmap range)]
|
||||
[color (range-color range)]
|
||||
[caret-space? (range-caret-space? range)]
|
||||
[start-eol? #f]
|
||||
[end-eol? (if (= start end)
|
||||
start-eol?
|
||||
#t)])
|
||||
(let-values ([(start-x top-start-y)
|
||||
(begin
|
||||
(position-location start b1 b2 #t 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))])
|
||||
(cond
|
||||
[(= top-start-y top-end-y)
|
||||
(list
|
||||
(make-rectangle start-x
|
||||
top-start-y
|
||||
(if (= end-x start-x)
|
||||
(+ end-x 1)
|
||||
end-x)
|
||||
bottom-start-y
|
||||
b/w-bitmap
|
||||
color))]
|
||||
[else
|
||||
(list
|
||||
(make-rectangle start-x
|
||||
top-start-y
|
||||
'right-edge
|
||||
bottom-start-y
|
||||
b/w-bitmap
|
||||
color)
|
||||
(make-rectangle 'left-edge
|
||||
bottom-start-y
|
||||
'max-width
|
||||
top-end-y
|
||||
b/w-bitmap
|
||||
color)
|
||||
(make-rectangle 'left-edge
|
||||
top-end-y
|
||||
end-x
|
||||
bottom-end-y
|
||||
b/w-bitmap
|
||||
color))]))))]
|
||||
|
||||
[invalidate-rectangles
|
||||
(lambda (rectangles)
|
||||
(let-values ([(min-left max-right)
|
||||
(let loop ([left #f]
|
||||
[right #f]
|
||||
[canvases (get-canvases)])
|
||||
(cond
|
||||
[(null? canvases)
|
||||
(values left right)]
|
||||
[else
|
||||
(let-values ([(this-left this-right)
|
||||
(send (car canvases)
|
||||
call-as-primary-owner
|
||||
(lambda ()
|
||||
(send (get-admin) get-view b1 b2 b3 b4)
|
||||
(let* ([this-left (unbox b1)]
|
||||
[this-width (unbox b3)]
|
||||
[this-right (+ this-left this-width)])
|
||||
(values this-left
|
||||
this-right))))])
|
||||
(if (and left right)
|
||||
(loop (min this-left left)
|
||||
(max this-right right)
|
||||
(cdr canvases))
|
||||
(loop this-left
|
||||
this-right
|
||||
(cdr canvases))))]))])
|
||||
(let loop ([left #f]
|
||||
[top #f]
|
||||
[right #f]
|
||||
[bottom #f]
|
||||
[rectangles rectangles])
|
||||
(cond
|
||||
[(null? rectangles)
|
||||
(when left
|
||||
(invalidate-bitmap-cache left top (- right left) (- bottom top)))]
|
||||
[else (let* ([r (car rectangles)]
|
||||
|
||||
[rleft (rectangle-left r)]
|
||||
[rright (rectangle-right r)]
|
||||
[rtop (rectangle-top r)]
|
||||
[rbottom (rectangle-bottom r)]
|
||||
|
||||
[this-left (if (number? rleft)
|
||||
rleft
|
||||
min-left)]
|
||||
[this-right (if (number? rright)
|
||||
rright
|
||||
max-right)]
|
||||
[this-bottom rbottom]
|
||||
[this-top rtop])
|
||||
(if (and left top right bottom)
|
||||
(loop (min this-left left)
|
||||
(min this-top top)
|
||||
(max this-right right)
|
||||
(max this-bottom bottom)
|
||||
(cdr rectangles))
|
||||
(loop this-left
|
||||
this-top
|
||||
this-right
|
||||
this-bottom
|
||||
(cdr rectangles))))]))))]
|
||||
[old-rectangles range-rectangles])
|
||||
|
||||
(set! range-rectangles
|
||||
(mzlib:function:foldl (lambda (x l) (append (new-rectangles x) l))
|
||||
null ranges))
|
||||
(invalidate-rectangles (append old-rectangles
|
||||
range-rectangles))))]
|
||||
[ranges null]
|
||||
[pen (make-object pen% "BLACK" 0 'solid)]
|
||||
[brush (make-object brush% "black" 'solid)])
|
||||
(public
|
||||
;; the bitmap is used in b/w and the color is used in color.
|
||||
[highlight-range
|
||||
(opt-lambda (start end color bitmap [caret-space? #f])
|
||||
(let ([l (make-range start end bitmap color caret-space?)])
|
||||
(set! ranges (cons l ranges))
|
||||
(recompute-range-rectangles)
|
||||
(lambda ()
|
||||
(set! ranges
|
||||
(let loop ([r ranges])
|
||||
(cond
|
||||
[(null? r) r]
|
||||
[else (if (eq? (car r) l)
|
||||
(cdr r)
|
||||
(cons (car r) (loop (cdr r))))])))
|
||||
(recompute-range-rectangles))))])
|
||||
(rename [super-on-paint on-paint])
|
||||
(override
|
||||
[on-paint
|
||||
(lambda (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)
|
||||
(for-each
|
||||
(lambda (rectangle)
|
||||
(let-values ([(view-x view-y view-width view-height)
|
||||
(begin
|
||||
(send (get-admin) get-view b1 b2 b3 b4)
|
||||
(values (unbox b1)
|
||||
(unbox b2)
|
||||
(unbox b3)
|
||||
(unbox b4)))])
|
||||
(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)]
|
||||
[tmpc (make-object color% 0 0 0)])
|
||||
(if rc
|
||||
(begin (send dc try-color rc tmpc)
|
||||
(and (<= (max (abs (- (send rc red) (send tmpc red)))
|
||||
(abs (- (send rc blue) (send tmpc blue)))
|
||||
(abs (- (send rc green) (send tmpc green))))
|
||||
15)
|
||||
rc))
|
||||
rc))]
|
||||
[first-number (lambda (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
|
||||
(if (number? (rectangle-right rectangle))
|
||||
(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/ec k
|
||||
(cond
|
||||
[(= top-start-y top-end-y)
|
||||
(list
|
||||
(make-rectangle start-x
|
||||
top-start-y
|
||||
(if (= end-x start-x)
|
||||
(+ end-x 1)
|
||||
end-x)
|
||||
bottom-start-y
|
||||
b/w-bitmap
|
||||
color))]
|
||||
[else
|
||||
(list
|
||||
(make-rectangle start-x
|
||||
top-start-y
|
||||
'right-edge
|
||||
bottom-start-y
|
||||
b/w-bitmap
|
||||
color)
|
||||
(make-rectangle 'left-edge
|
||||
bottom-start-y
|
||||
'max-width
|
||||
top-end-y
|
||||
b/w-bitmap
|
||||
color)
|
||||
(make-rectangle 'left-edge
|
||||
top-end-y
|
||||
end-x
|
||||
bottom-end-y
|
||||
b/w-bitmap
|
||||
color))]))))]
|
||||
|
||||
[invalidate-rectangles
|
||||
(lambda (rectangles)
|
||||
(let-values ([(min-left max-right)
|
||||
(let loop ([left #f]
|
||||
[right #f]
|
||||
[canvases (get-canvases)])
|
||||
(cond
|
||||
[(null? canvases)
|
||||
(values left right)]
|
||||
[else
|
||||
(let-values ([(this-left this-right)
|
||||
(send (car canvases)
|
||||
call-as-primary-owner
|
||||
(lambda ()
|
||||
(send (get-admin) get-view b1 b2 b3 b4)
|
||||
(let* ([this-left (unbox b1)]
|
||||
[this-width (unbox b3)]
|
||||
[this-right (+ this-left this-width)])
|
||||
(values this-left
|
||||
this-right))))])
|
||||
(if (and left right)
|
||||
(loop (min this-left left)
|
||||
(max this-right right)
|
||||
(cdr canvases))
|
||||
(loop this-left
|
||||
this-right
|
||||
(cdr canvases))))]))])
|
||||
(let loop ([left #f]
|
||||
[top #f]
|
||||
[right #f]
|
||||
[bottom #f]
|
||||
[rectangles rectangles])
|
||||
(cond
|
||||
[(null? rectangles)
|
||||
(when left
|
||||
(invalidate-bitmap-cache left top (- right left) (- bottom top)))]
|
||||
[else (let* ([r (car rectangles)]
|
||||
|
||||
[rleft (rectangle-left r)]
|
||||
[rright (rectangle-right r)]
|
||||
[rtop (rectangle-top r)]
|
||||
[rbottom (rectangle-bottom r)]
|
||||
|
||||
[this-left (if (number? rleft)
|
||||
rleft
|
||||
min-left)]
|
||||
[this-right (if (number? rright)
|
||||
rright
|
||||
max-right)]
|
||||
[this-bottom rbottom]
|
||||
[this-top rtop])
|
||||
(if (and left top right bottom)
|
||||
(loop (min this-left left)
|
||||
(min this-top top)
|
||||
(max this-right right)
|
||||
(max this-bottom bottom)
|
||||
(cdr rectangles))
|
||||
(loop this-left
|
||||
this-top
|
||||
this-right
|
||||
this-bottom
|
||||
(cdr rectangles))))]))))]
|
||||
[old-rectangles range-rectangles])
|
||||
|
||||
(set! range-rectangles
|
||||
(mzlib:function:foldl (lambda (x l) (append (new-rectangles x) l))
|
||||
null ranges))
|
||||
(invalidate-rectangles (append old-rectangles
|
||||
range-rectangles))))]
|
||||
[ranges null]
|
||||
[pen (make-object pen% "BLACK" 0 'solid)]
|
||||
[brush (make-object brush% "black" 'solid)])
|
||||
(public
|
||||
;; the bitmap is used in b/w and the color is used in color.
|
||||
[highlight-range
|
||||
(opt-lambda (start end color bitmap [caret-space? #f])
|
||||
(let ([l (make-range start end bitmap color caret-space?)])
|
||||
(set! ranges (cons l ranges))
|
||||
(recompute-range-rectangles)
|
||||
(lambda ()
|
||||
(set! ranges
|
||||
(let loop ([r ranges])
|
||||
(cond
|
||||
[(null? r) r]
|
||||
[else (if (eq? (car r) l)
|
||||
(cdr r)
|
||||
(cons (car r) (loop (cdr r))))])))
|
||||
(recompute-range-rectangles))))])
|
||||
(rename [super-on-paint on-paint])
|
||||
(override
|
||||
[on-paint
|
||||
(lambda (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)
|
||||
(for-each
|
||||
(lambda (rectangle)
|
||||
(let-values ([(view-x view-y view-width view-height)
|
||||
(begin
|
||||
(send (get-admin) get-view b1 b2 b3 b4)
|
||||
(values (unbox b1)
|
||||
(unbox b2)
|
||||
(unbox b3)
|
||||
(unbox b4)))])
|
||||
(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)]
|
||||
[tmpc (make-object color% 0 0 0)])
|
||||
(if rc
|
||||
(begin (send dc try-color rc tmpc)
|
||||
(and (<= (max (abs (- (send rc red) (send tmpc red)))
|
||||
(abs (- (send rc blue) (send tmpc blue)))
|
||||
(abs (- (send rc green) (send tmpc green))))
|
||||
15)
|
||||
rc))
|
||||
rc))]
|
||||
[first-number (lambda (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
|
||||
(if (number? (rectangle-right rectangle))
|
||||
(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/ec k
|
||||
[(and before color)
|
||||
(send pen set-color color)
|
||||
(send brush set-color color)]
|
||||
[(and (not before) (not color) b/w-bitmap)
|
||||
(send pen set-stipple b/w-bitmap)
|
||||
(send brush set-stipple b/w-bitmap)]
|
||||
[else (k (void))])
|
||||
(send dc set-pen pen)
|
||||
(send dc set-brush brush)
|
||||
(send dc draw-rectangle
|
||||
(+ left dx)
|
||||
(+ top dy)
|
||||
width
|
||||
height)
|
||||
(send dc set-pen old-pen)
|
||||
(send dc set-brush old-brush)))))
|
||||
range-rectangles))])
|
||||
|
||||
|
||||
(private
|
||||
[styles-fixed? #f]
|
||||
[styles-fixed-edit-modified? #f])
|
||||
(public
|
||||
[get-styles-fixed (lambda () styles-fixed?)]
|
||||
[set-styles-fixed (lambda (b) (set! styles-fixed? b))])
|
||||
(rename
|
||||
[super-on-change-style on-change-style]
|
||||
[super-after-change-style after-change-style]
|
||||
[super-after-insert after-insert])
|
||||
(override
|
||||
[on-change-style
|
||||
(lambda (start len)
|
||||
(when styles-fixed?
|
||||
(set! styles-fixed-edit-modified? (is-modified?)))
|
||||
(super-on-change-style start len))]
|
||||
[after-insert
|
||||
(lambda (start len)
|
||||
(when styles-fixed?
|
||||
(change-style (send (get-style-list) find-named-style "Standard")
|
||||
start
|
||||
(+ start len)))
|
||||
(super-after-insert start len))]
|
||||
[after-change-style
|
||||
(lambda (start len)
|
||||
(super-after-change-style start len)
|
||||
(when styles-fixed?
|
||||
(set-modified styles-fixed-edit-modified?)))])
|
||||
|
||||
(public
|
||||
[move/copy-to-edit
|
||||
(lambda (dest-edit start end dest-position)
|
||||
(let ([insert-edit (ivar dest-edit insert)])
|
||||
(split-snip start)
|
||||
(split-snip end)
|
||||
(let loop ([snip (find-snip end 'before)])
|
||||
(cond
|
||||
[(and before color)
|
||||
(send pen set-color color)
|
||||
(send brush set-color color)]
|
||||
[(and (not before) (not color) b/w-bitmap)
|
||||
(send pen set-stipple b/w-bitmap)
|
||||
(send brush set-stipple b/w-bitmap)]
|
||||
[else (k (void))])
|
||||
(send dc set-pen pen)
|
||||
(send dc set-brush brush)
|
||||
(send dc draw-rectangle
|
||||
(+ left dx)
|
||||
(+ top dy)
|
||||
width
|
||||
height)
|
||||
(send dc set-pen old-pen)
|
||||
(send dc set-brush old-brush)))))
|
||||
range-rectangles))])
|
||||
|
||||
|
||||
(private
|
||||
[styles-fixed? #f]
|
||||
[styles-fixed-edit-modified? #f])
|
||||
(public
|
||||
[get-styles-fixed (lambda () styles-fixed?)]
|
||||
[set-styles-fixed (lambda (b) (set! styles-fixed? b))])
|
||||
(rename
|
||||
[super-on-change-style on-change-style]
|
||||
[super-after-change-style after-change-style]
|
||||
[super-after-insert after-insert])
|
||||
(override
|
||||
[on-change-style
|
||||
(lambda (start len)
|
||||
(when styles-fixed?
|
||||
(set! styles-fixed-edit-modified? (is-modified?)))
|
||||
(super-on-change-style start len))]
|
||||
[after-insert
|
||||
(lambda (start len)
|
||||
(when styles-fixed?
|
||||
(change-style (send (get-style-list) find-named-style "Standard")
|
||||
start
|
||||
(+ start len)))
|
||||
(super-after-insert start len))]
|
||||
[after-change-style
|
||||
(lambda (start len)
|
||||
(super-after-change-style start len)
|
||||
(when styles-fixed?
|
||||
(set-modified styles-fixed-edit-modified?)))])
|
||||
|
||||
(public
|
||||
[move/copy-to-edit
|
||||
(lambda (dest-edit start end dest-position)
|
||||
(let ([insert-edit (ivar dest-edit insert)])
|
||||
(split-snip start)
|
||||
(split-snip end)
|
||||
(let loop ([snip (find-snip end 'before)])
|
||||
(cond
|
||||
[(or (not snip) (< (get-snip-position snip) start))
|
||||
(void)]
|
||||
[else
|
||||
(let ([prev (send snip previous)]
|
||||
[released/copied (if (send snip release-from-owner)
|
||||
snip
|
||||
(let* ([copy (send snip copy)]
|
||||
[snip-start (get-snip-position snip)]
|
||||
[snip-end (+ snip-start (send snip get-count))])
|
||||
(delete snip-start snip-end)
|
||||
snip))])
|
||||
(insert-edit released/copied dest-position dest-position)
|
||||
(loop prev))]))))])
|
||||
|
||||
|
||||
(public
|
||||
[initial-autowrap-bitmap (lambda () #f)])
|
||||
|
||||
(sequence
|
||||
(apply super-init args)
|
||||
(set-autowrap-bitmap (initial-autowrap-bitmap)))))
|
||||
[(or (not snip) (< (get-snip-position snip) start))
|
||||
(void)]
|
||||
[else
|
||||
(let ([prev (send snip previous)]
|
||||
[released/copied (if (send snip release-from-owner)
|
||||
snip
|
||||
(let* ([copy (send snip copy)]
|
||||
[snip-start (get-snip-position snip)]
|
||||
[snip-end (+ snip-start (send snip get-count))])
|
||||
(delete snip-start snip-end)
|
||||
snip))])
|
||||
(insert-edit released/copied dest-position dest-position)
|
||||
(loop prev))]))))])
|
||||
|
||||
|
||||
(public
|
||||
[initial-autowrap-bitmap (lambda () #f)])
|
||||
|
||||
(sequence
|
||||
(apply super-init args)
|
||||
(set-autowrap-bitmap (initial-autowrap-bitmap)))))
|
||||
|
||||
(define searching<%>
|
||||
(interface ()
|
||||
find-string-embedded))
|
||||
(define searching-mixin
|
||||
(mixin (editor:keymap<%> basic<%>) (searching<%>) args
|
||||
(inherit get-end-position get-start-position last-position
|
||||
find-string get-snip-position get-admin find-snip)
|
||||
(public
|
||||
[find-string-embedded
|
||||
(opt-lambda (str [direction 1] [start -1]
|
||||
[end -1] [get-start #t]
|
||||
[case-sensitive? #t] [pop-out? #f])
|
||||
(let/ec k
|
||||
(let* ([start (if (= -1 start)
|
||||
(if (= direction 1)
|
||||
(get-end-position)
|
||||
(get-start-position))
|
||||
start)]
|
||||
[end (if (= -1 end)
|
||||
(if (= direction 1)
|
||||
(last-position)
|
||||
0)
|
||||
end)]
|
||||
[flat (find-string str direction
|
||||
start end get-start
|
||||
case-sensitive?)]
|
||||
[end-test
|
||||
(lambda (snip)
|
||||
(cond
|
||||
[(null? snip) flat]
|
||||
[(and (not (= -1 flat))
|
||||
(let* ([start (get-snip-position snip)]
|
||||
[end (+ start (send snip get-count))])
|
||||
(if (= direction 1)
|
||||
(and (<= start flat)
|
||||
(< flat end))
|
||||
(and (< start flat)
|
||||
(<= flat end)))))
|
||||
flat]
|
||||
[else #f]))]
|
||||
[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-media)]
|
||||
[pos (send edit-above get-snip-position snip)])
|
||||
(send edit-above
|
||||
find-string-embedded
|
||||
str
|
||||
direction
|
||||
(if (= direction 1) (add1 pos) pos)
|
||||
-1 get-start
|
||||
case-sensitive? pop-out?))
|
||||
(values this -1))))])
|
||||
(let loop ([current-snip (find-snip start
|
||||
(if (= direction 1)
|
||||
'after-or-none
|
||||
'before-or-none))])
|
||||
(let ([next-loop
|
||||
(lambda ()
|
||||
(if (= direction 1)
|
||||
(loop (send current-snip next))
|
||||
(loop (send current-snip previous))))])
|
||||
(cond
|
||||
[(end-test current-snip) =>
|
||||
(lambda (x)
|
||||
(if (and (= x -1) pop-out?)
|
||||
(pop-out)
|
||||
(values this x)))]
|
||||
[(is-a? current-snip original:editor-snip%)
|
||||
(let-values ([(embedded embedded-pos)
|
||||
(let ([media (send current-snip get-this-media)])
|
||||
(and (not (null? media))
|
||||
(send media find-string-embedded str
|
||||
direction
|
||||
(if (= 1 direction)
|
||||
0
|
||||
(send media last-position))
|
||||
-1
|
||||
get-start case-sensitive?)))])
|
||||
(if (= -1 embedded-pos)
|
||||
(next-loop)
|
||||
(values embedded embedded-pos)))]
|
||||
[else (next-loop)]))))))])
|
||||
|
||||
(rename [super-get-keymaps get-keymaps])
|
||||
(override
|
||||
[get-keymaps
|
||||
(lambda ()
|
||||
(cons (keymap:get-search) (super-get-keymaps)))])
|
||||
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
(inherit get-end-position get-start-position last-position
|
||||
find-string get-snip-position get-admin find-snip)
|
||||
(public
|
||||
[find-string-embedded
|
||||
(opt-lambda (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 'forward or 'backward as first argument, got: ~e" 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-media)]
|
||||
[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))])
|
||||
(let ([next-loop
|
||||
(lambda ()
|
||||
(if (eq? direction 'forward)
|
||||
(loop (send current-snip next))
|
||||
(loop (send current-snip previous))))])
|
||||
(cond
|
||||
[(not current-snip)
|
||||
(if (and (not flat) pop-out?)
|
||||
(pop-out)
|
||||
(values this flat))]
|
||||
[(and (not 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 pop-out?
|
||||
(pop-out)
|
||||
(values this #f))]
|
||||
[(is-a? current-snip original:editor-snip%)
|
||||
(let-values ([(embedded embedded-pos)
|
||||
(let ([media (send current-snip get-this-media)])
|
||||
(and (not (null? media))
|
||||
(send media find-string-embedded str
|
||||
direction
|
||||
(if (eq? 'forward direction)
|
||||
0
|
||||
(send media last-position))
|
||||
'eof
|
||||
get-start case-sensitive?)))])
|
||||
(if (not embedded-pos)
|
||||
(next-loop)
|
||||
(values embedded embedded-pos)))]
|
||||
[else (next-loop)]))))))])
|
||||
|
||||
(rename [super-get-keymaps get-keymaps])
|
||||
(override
|
||||
[get-keymaps
|
||||
(lambda ()
|
||||
(cons (keymap:get-search) (super-get-keymaps)))])
|
||||
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
|
||||
(define return<%> (interface (text<%>)))
|
||||
|
||||
|
||||
(define return-mixin
|
||||
(mixin (text<%>) (return<%>) (return . args)
|
||||
(rename [super-on-local-char on-local-char])
|
||||
(override
|
||||
[on-local-char
|
||||
(lambda (key)
|
||||
(let ([cr-code #\return]
|
||||
[lf-code #\newline]
|
||||
[code (send key get-key-code)])
|
||||
(or (and (char? code)
|
||||
(or (char=? lf-code code)
|
||||
(char=? cr-code code))
|
||||
(return))
|
||||
(super-on-local-char key))))])
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
|
||||
(rename [super-on-local-char on-local-char])
|
||||
(override
|
||||
[on-local-char
|
||||
(lambda (key)
|
||||
(let ([cr-code #\return]
|
||||
[lf-code #\newline]
|
||||
[code (send key get-key-code)])
|
||||
(or (and (char? code)
|
||||
(or (char=? lf-code code)
|
||||
(char=? cr-code code))
|
||||
(return))
|
||||
(super-on-local-char key))))])
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
|
||||
(define info<%> (interface (editor:basic<%> text<%>)))
|
||||
|
||||
|
||||
(define info-mixin
|
||||
(mixin (editor:keymap<%> text<%>) (info<%>) args
|
||||
(inherit get-start-position get-end-position get-canvas
|
||||
run-after-edit-sequence)
|
||||
(rename [super-after-set-position after-set-position]
|
||||
[super-after-edit-sequence after-edit-sequence]
|
||||
[super-on-edit-sequence on-edit-sequence]
|
||||
[super-after-insert after-insert]
|
||||
[super-after-delete after-delete]
|
||||
[super-set-overwrite-mode set-overwrite-mode]
|
||||
[super-set-anchor set-anchor])
|
||||
(private
|
||||
[enqueue-for-frame
|
||||
(lambda (ivar-sym tag)
|
||||
(run-after-edit-sequence
|
||||
(rec from-enqueue-for-frame
|
||||
(lambda ()
|
||||
(let ([canvas (get-canvas)])
|
||||
(when canvas
|
||||
((ivar/proc (send canvas get-top-level-window) ivar-sym))))))
|
||||
tag))])
|
||||
(override
|
||||
[set-anchor
|
||||
(lambda (x)
|
||||
(super-set-anchor x)
|
||||
(enqueue-for-frame 'anchor-status-changed
|
||||
'framework:anchor-status-changed))]
|
||||
[set-overwrite-mode
|
||||
(lambda (x)
|
||||
(super-set-overwrite-mode x)
|
||||
(enqueue-for-frame 'overwrite-status-changed
|
||||
'framework:overwrite-status-changed))]
|
||||
[after-set-position
|
||||
(lambda ()
|
||||
(super-after-set-position)
|
||||
(enqueue-for-frame 'editor-position-changed
|
||||
'framework:editor-position-changed))]
|
||||
[after-insert
|
||||
(lambda (start len)
|
||||
(super-after-insert start len)
|
||||
(enqueue-for-frame 'editor-position-changed
|
||||
'framework:editor-position-changed))]
|
||||
[after-delete
|
||||
(lambda (start len)
|
||||
(super-after-delete start len)
|
||||
(enqueue-for-frame 'editor-position-changed
|
||||
'framework:editor-position-changed))])
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
|
||||
(inherit get-start-position get-end-position get-canvas
|
||||
run-after-edit-sequence)
|
||||
(rename [super-after-set-position after-set-position]
|
||||
[super-after-edit-sequence after-edit-sequence]
|
||||
[super-on-edit-sequence on-edit-sequence]
|
||||
[super-after-insert after-insert]
|
||||
[super-after-delete after-delete]
|
||||
[super-set-overwrite-mode set-overwrite-mode]
|
||||
[super-set-anchor set-anchor])
|
||||
(private
|
||||
[enqueue-for-frame
|
||||
(lambda (ivar-sym tag)
|
||||
(run-after-edit-sequence
|
||||
(rec from-enqueue-for-frame
|
||||
(lambda ()
|
||||
(let ([canvas (get-canvas)])
|
||||
(when canvas
|
||||
((ivar/proc (send canvas get-top-level-window) ivar-sym))))))
|
||||
tag))])
|
||||
(override
|
||||
[set-anchor
|
||||
(lambda (x)
|
||||
(super-set-anchor x)
|
||||
(enqueue-for-frame 'anchor-status-changed
|
||||
'framework:anchor-status-changed))]
|
||||
[set-overwrite-mode
|
||||
(lambda (x)
|
||||
(super-set-overwrite-mode x)
|
||||
(enqueue-for-frame 'overwrite-status-changed
|
||||
'framework:overwrite-status-changed))]
|
||||
[after-set-position
|
||||
(lambda ()
|
||||
(super-after-set-position)
|
||||
(enqueue-for-frame 'editor-position-changed
|
||||
'framework:editor-position-changed))]
|
||||
[after-insert
|
||||
(lambda (start len)
|
||||
(super-after-insert start len)
|
||||
(enqueue-for-frame 'editor-position-changed
|
||||
'framework:editor-position-changed))]
|
||||
[after-delete
|
||||
(lambda (start len)
|
||||
(super-after-delete start len)
|
||||
(enqueue-for-frame 'editor-position-changed
|
||||
'framework:editor-position-changed))])
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
|
||||
(define clever-file-format<%> (interface (text<%>)))
|
||||
|
||||
|
||||
(define clever-file-format-mixin
|
||||
(mixin (text<%>) (clever-file-format<%>) args
|
||||
(inherit get-file-format set-file-format find-first-snip)
|
||||
(rename [super-on-save-file on-save-file]
|
||||
[super-after-save-file after-save-file])
|
||||
|
||||
(private [restore-file-format void])
|
||||
|
||||
(override
|
||||
[after-save-file
|
||||
(lambda (success)
|
||||
(restore-file-format)
|
||||
(super-after-save-file success))]
|
||||
[on-save-file
|
||||
(let ([has-non-string-snips
|
||||
(lambda ()
|
||||
(let loop ([s (find-first-snip)])
|
||||
(cond
|
||||
[(null? s) #f]
|
||||
[(is-a? s original:string-snip%)
|
||||
(loop (send s next))]
|
||||
[else #t])))])
|
||||
(lambda (name format)
|
||||
(when (and (or (eq? format 'same)
|
||||
(eq? format 'copy))
|
||||
(not (eq? (get-file-format)
|
||||
'standard)))
|
||||
(cond
|
||||
[(eq? format 'copy)
|
||||
(set! restore-file-format
|
||||
(let ([f (get-file-format)])
|
||||
(lambda ()
|
||||
(set! restore-file-format void)
|
||||
(set-file-format f))))
|
||||
(set-file-format 'standard)]
|
||||
[(and (has-non-string-snips)
|
||||
(or (not (preferences:get 'framework:verify-change-format))
|
||||
(gui-utils:get-choice "Save this file as plain text?" "No" "Yes")))
|
||||
(set-file-format 'standard)]
|
||||
[else (void)]))
|
||||
(or (super-on-save-file name format)
|
||||
(begin
|
||||
(restore-file-format)
|
||||
#f))))])
|
||||
(sequence (apply super-init args))))
|
||||
|
||||
(inherit get-file-format set-file-format find-first-snip)
|
||||
(rename [super-on-save-file on-save-file]
|
||||
[super-after-save-file after-save-file])
|
||||
|
||||
(private [restore-file-format void])
|
||||
|
||||
(override
|
||||
[after-save-file
|
||||
(lambda (success)
|
||||
(restore-file-format)
|
||||
(super-after-save-file success))]
|
||||
[on-save-file
|
||||
(let ([has-non-string-snips
|
||||
(lambda ()
|
||||
(let loop ([s (find-first-snip)])
|
||||
(cond
|
||||
[(not s) #f]
|
||||
[(is-a? s original:string-snip%)
|
||||
(loop (send s next))]
|
||||
[else #t])))])
|
||||
(lambda (name format)
|
||||
(when (and (or (eq? format 'same)
|
||||
(eq? format 'copy))
|
||||
(not (eq? (get-file-format)
|
||||
'standard)))
|
||||
(cond
|
||||
[(eq? format 'copy)
|
||||
(set! restore-file-format
|
||||
(let ([f (get-file-format)])
|
||||
(lambda ()
|
||||
(set! restore-file-format void)
|
||||
(set-file-format f))))
|
||||
(set-file-format 'standard)]
|
||||
[(and (has-non-string-snips)
|
||||
(or (not (preferences:get 'framework:verify-change-format))
|
||||
(gui-utils:get-choice "Save this file as plain text?" "No" "Yes")))
|
||||
(set-file-format 'standard)]
|
||||
[else (void)]))
|
||||
(or (super-on-save-file name format)
|
||||
(begin
|
||||
(restore-file-format)
|
||||
#f))))])
|
||||
(sequence (apply super-init args))))
|
||||
|
||||
(define basic% (basic-mixin (editor:basic-mixin text%)))
|
||||
(define -keymap% (editor:keymap-mixin basic%))
|
||||
(define return% (return-mixin -keymap%))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user