New implementation of move/copy-to-edit plus docs and tests
This commit is contained in:
Daniel Feltey
Robby Findler
parent
6c173c19e9
commit
0354106ed8
|
|
@ -1,6 +1,6 @@
|
|||
#lang scribble/doc
|
||||
@(require scribble/manual scribble/extract)
|
||||
@(require (for-label framework racket/gui))
|
||||
@(require (for-label framework racket/gui racket/contract/base))
|
||||
@title{Text}
|
||||
|
||||
@definterface[text:basic<%> (editor:basic<%> text%)]{
|
||||
|
|
@ -139,24 +139,41 @@
|
|||
}
|
||||
|
||||
@defmethod[(move/copy-to-edit [dest-text (is-a?/c text%)]
|
||||
[start exact-integer?]
|
||||
[end exact-integer?]
|
||||
[dest-pos exact-integer?]
|
||||
[start natural?]
|
||||
[end (and/c natural? (>=/c start))]
|
||||
[dest-pos natural?]
|
||||
[#:try-to-move? try-to-move? boolean? #t])
|
||||
void?]{
|
||||
This moves or copies text and snips to another edit.
|
||||
This moves or copies text and snips to @racket[dest-text].
|
||||
|
||||
Moves or copies from the edit starting at @racket[start] and ending at
|
||||
Moves or copies from @racket[this] starting at @racket[start] and ending at
|
||||
@racket[end]. It puts the copied text and snips in @racket[dest-text]
|
||||
starting at location @racket[dest-pos].
|
||||
starting at location @racket[dest-pos]. If @racket[start] and @racket[end]
|
||||
are equal then nothing is moved or copied.
|
||||
|
||||
If @racket[try-to-move] is @racket[#t], then the snips are removed;
|
||||
and if it is @racket[#f], then they are copied.
|
||||
If @racket[try-to-move?] is @racket[#t], then the snips are removed;
|
||||
and if it is @racket[#f], then they are copied. If @racket[try-to-move?] is
|
||||
@racket[#t] and @racket[dest-pos] is between @racket[start] and @racket[end]
|
||||
then @racket[this] is unchanged.
|
||||
|
||||
If a snip refused to be moved, it will be copied and deleted from the editor,
|
||||
If a snip refuses to be moved, it will be copied and deleted from the editor,
|
||||
otherwise it will be moved. A snip may refuse to be moved by returning
|
||||
@racket[#f] from @method[snip% release-from-owner].
|
||||
}
|
||||
@defmethod[(move-to [dest-text (is-a?/c text%)]
|
||||
[start natural?]
|
||||
[end (and/c natural? (>=/c start))]
|
||||
[dest-pos natural?])
|
||||
void?]{
|
||||
Like @racket[move/copy-to-edit] when the @racket[#:try-to-move?] argument is @racket[#t].
|
||||
}
|
||||
@defmethod[(copy-to [dest-text (is-a?/c text%)]
|
||||
[start natural?]
|
||||
[end (and/c natural? (>=/c start))]
|
||||
[dest-pos natural?])
|
||||
void?]{
|
||||
Like @racket[move/copy-to-edit] when the @racket[#:try-to-move?] argument is @racket[#f].
|
||||
}
|
||||
|
||||
@defmethod*[(((initial-autowrap-bitmap) (or/c #f (is-a?/c bitmap%))))]{
|
||||
The result of this method is used as the initial autowrap bitmap. Override
|
||||
|
|
|
|||
|
|
@ -530,7 +530,7 @@
|
|||
delete find-snip
|
||||
get-style-list change-style
|
||||
position-line line-start-position
|
||||
get-filename)
|
||||
get-filename get-end-position)
|
||||
|
||||
(define/public (get-fixed-style)
|
||||
(send (get-style-list) find-named-style "Standard"))
|
||||
|
|
@ -585,29 +585,80 @@
|
|||
(define/augment (after-delete start len)
|
||||
(set! edition (+ edition 1))
|
||||
(inner (void) after-delete start len))
|
||||
|
||||
(define/public (move-to dest-edit start end dest-position)
|
||||
(unless (and (<= 0 start) (<= 0 end) (<= 0 dest-position))
|
||||
(error 'move-to
|
||||
"expected start, end, and dest-pos to be non-negative"))
|
||||
(when (> start end)
|
||||
(error 'move-to
|
||||
"expected start position smaller than end position"))
|
||||
(define (release-or-copy snip)
|
||||
(cond
|
||||
[(send snip release-from-owner) snip]
|
||||
[else
|
||||
(define copy (send snip copy))
|
||||
(define snip-start (get-snip-position snip))
|
||||
(define snip-end (+ snip-start (send snip get-count)))
|
||||
(delete snip-start snip-end)
|
||||
copy]))
|
||||
(define move-to-self? (object=? this dest-edit))
|
||||
(unless (or (= start end) (and move-to-self? (<= start dest-position end)))
|
||||
(let loop ([current-start start]
|
||||
[current-end (min end (get-end-position))]
|
||||
[current-dest dest-position])
|
||||
(split-snip current-start)
|
||||
(split-snip current-end)
|
||||
(define snip (find-snip current-end 'before-or-none))
|
||||
(cond
|
||||
[(or (not snip) (< (get-snip-position snip) current-start)) (void)]
|
||||
[else
|
||||
(define released/copied (release-or-copy snip))
|
||||
(define snip-count (send released/copied get-count))
|
||||
(define new-start
|
||||
(cond
|
||||
[(or (not move-to-self?) (> current-dest current-start)) current-start]
|
||||
[else (+ current-start snip-count)]))
|
||||
(define new-end
|
||||
(cond
|
||||
[(and move-to-self? (< current-dest current-end)) current-end]
|
||||
[else (- current-end snip-count)]))
|
||||
(define new-dest
|
||||
(cond
|
||||
[(or (not move-to-self?) (< current-dest current-start)) current-dest]
|
||||
[else (- current-dest snip-count)]))
|
||||
(send dest-edit insert released/copied new-dest new-dest)
|
||||
(loop new-start new-end new-dest)]))))
|
||||
|
||||
(define/public (copy-to dest-edit start end dest-position)
|
||||
(unless (and (<= 0 start) (<= 0 end) (<= 0 dest-position))
|
||||
(error 'copy-to
|
||||
"expected start, end, and dest-pos to be non-negative"))
|
||||
(when (> start end)
|
||||
(error 'copy-to
|
||||
"expected start position smaller than end position"))
|
||||
(unless (= start end)
|
||||
(split-snip start)
|
||||
(split-snip end)
|
||||
(define snips
|
||||
(let loop ([snip (find-snip end 'before)] [snips '()])
|
||||
(cond
|
||||
[(or (not snip) (< (get-snip-position snip) start)) (reverse snips)]
|
||||
[else (loop (send snip previous) (cons (send snip copy) snips))])))
|
||||
(for ([snip (in-list snips)])
|
||||
(send dest-edit insert snip dest-position dest-position))))
|
||||
|
||||
(define/public (move/copy-to-edit dest-edit start end dest-position
|
||||
#:try-to-move? [try-to-move? #t])
|
||||
(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 try-to-move?
|
||||
(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))
|
||||
(send snip copy))])
|
||||
(send dest-edit insert released/copied dest-position dest-position)
|
||||
(loop prev))])))
|
||||
(unless (and (<= 0 start) (<= 0 end) (<= 0 dest-position))
|
||||
(error 'move/copy-to-edit
|
||||
"expected start, end, and dest-pos to be non-negative"))
|
||||
(when (> start end)
|
||||
(error 'move/copy-to-edit
|
||||
"expected start position smaller than end position"))
|
||||
(cond
|
||||
[try-to-move? (move-to dest-edit start end dest-position)]
|
||||
[else (copy-to dest-edit start end dest-position)]))
|
||||
|
||||
(public initial-autowrap-bitmap)
|
||||
(define (initial-autowrap-bitmap) (icon:get-autowrap-bitmap))
|
||||
|
|
|
|||
|
|
@ -571,6 +571,278 @@
|
|||
(define after (get-colors))
|
||||
(list before after)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; move/copy-to-edit tests
|
||||
;;
|
||||
|
||||
(define (get-snips text)
|
||||
(define the-snips
|
||||
(let loop ([current (send text find-first-snip)]
|
||||
[snips '()])
|
||||
(if current
|
||||
(loop (send current next) (cons current snips))
|
||||
(reverse snips))))
|
||||
(for/list ([snip (in-list the-snips)]
|
||||
[i (in-naturals)])
|
||||
(send snip get-text 0 (send snip get-count))))
|
||||
|
||||
(define (edit-style t posns)
|
||||
(define (maybe-cdr p) (if (empty? p) '() (cdr p)))
|
||||
(for ([i (in-list posns)]
|
||||
[j (in-list (append (maybe-cdr posns) '(end)))]
|
||||
[s (in-naturals)])
|
||||
(define sd (make-object style-delta%
|
||||
(if (even? s) 'change-normal 'change-normal-color)))
|
||||
(send t change-style sd i j)))
|
||||
|
||||
(check-equal? (let ([t (new text%)])
|
||||
(send t insert "ABCDEF")
|
||||
(edit-style t '(3))
|
||||
(get-snips t))
|
||||
'("ABC" "DEF"))
|
||||
|
||||
(check-equal? (let ([t (new text%)])
|
||||
(send t insert "ABCDEFGH")
|
||||
(edit-style t '(3 5))
|
||||
(get-snips t))
|
||||
'("ABC" "DE" "FGH"))
|
||||
|
||||
(define (edit-string/text str start end dest-pos [this? #f] [style #f]
|
||||
#:try-to-move? [try-to-move? #f]
|
||||
#:contract-this? [contract-this? #f])
|
||||
(define t1 (new text:basic%))
|
||||
(define t2 (if this?
|
||||
(if contract-this? (contract (object/c) t1 'p 'n) t1)
|
||||
(new text:basic%)))
|
||||
(send t1 insert str)
|
||||
(when style
|
||||
(edit-style t1 style))
|
||||
(send t1 move/copy-to-edit t2
|
||||
start
|
||||
end
|
||||
(if this? dest-pos 0)
|
||||
#:try-to-move? try-to-move?)
|
||||
(unless this?
|
||||
(send t2 move/copy-to-edit
|
||||
t1
|
||||
0
|
||||
(send t2 get-end-position)
|
||||
(cond
|
||||
[(and try-to-move? (>= dest-pos end))
|
||||
(- dest-pos (- end start))]
|
||||
[(and try-to-move? (>= dest-pos start))
|
||||
start]
|
||||
[else dest-pos])
|
||||
#:try-to-move? #t))
|
||||
(send t1 get-text))
|
||||
|
||||
(check-equal? (edit-string/text "lR" 0 2 1 #f '(1) #:try-to-move? #t) "lR")
|
||||
(check-equal? (edit-string/text "DaMoe" 0 5 1 #:try-to-move? #t) "DaMoe")
|
||||
(check-equal? (edit-string/text "lR" 0 2 1 #f '(1) #:try-to-move? #t) "lR")
|
||||
(check-equal? (edit-string/text "ABC" 2 3 0 #t '(0 1 2)) "CABC")
|
||||
(check-equal? (edit-string/text "ABC" 2 3 0 #t #f) "CABC")
|
||||
(check-equal? (edit-string/text "ABC" 2 3 0 #f '(0 1 2)) "CABC")
|
||||
(check-equal? (edit-string/text "ABC" 2 3 0 #f #f) "CABC")
|
||||
(check-equal? (edit-string/text "ABC" 2 3 0 #t '(0 1 2) #:try-to-move? #t) "CAB")
|
||||
(check-equal? (edit-string/text "ABC" 2 3 0 #t #f #:try-to-move? #t) "CAB")
|
||||
(check-equal? (edit-string/text "ABC" 2 3 0 #f '(0 1 2) #:try-to-move? #t) "CAB")
|
||||
(check-equal? (edit-string/text "ABC" 2 3 0 #f #f #:try-to-move? #t) "CAB")
|
||||
(check-equal? (edit-string/text "X" 0 0 0 #t #f) "X")
|
||||
(check-equal? (edit-string/text "ji" 0 0 0 #t #f) "ji")
|
||||
(check-equal? (edit-string/text "ABCDE" 2 4 4 #t #f) "ABCDCDE")
|
||||
(check-equal? (edit-string/text "ABCDE" 2 4 2 #t #f) "ABCDCDE")
|
||||
|
||||
(check-equal? (edit-string/text "ABCDE" 2 4 3 #t #f) "ABCCDDE")
|
||||
(check-equal? (edit-string/text "ABCDE" 2 4 3 #t '(0 1 2 3 4)) "ABCCDDE")
|
||||
(check-equal? (edit-string/text "ABCDE" 2 4 3 #t #f #:try-to-move? #t) "ABCDE")
|
||||
(check-equal? (edit-string/text "ABCDE" 2 4 3 #t '(0 1 2 3 4) #:try-to-move? #t) "ABCDE")
|
||||
|
||||
(check-exn
|
||||
#rx"expected start position smaller than end position"
|
||||
(thunk (edit-string/text "ABCDE" 4 2 0 #t #f)))
|
||||
(check-exn
|
||||
#rx"expected start position smaller than end position"
|
||||
(thunk (edit-string/text "ABCDE" 4 2 0 #t '(0 1 2 3 4))))
|
||||
(check-exn
|
||||
#rx"expected start position smaller than end position"
|
||||
(thunk (edit-string/text "ABCDE" 4 2 0 #t #f #:try-to-move? #t)))
|
||||
(check-exn
|
||||
#rx"expected start position smaller than end position"
|
||||
(thunk (edit-string/text "ABCDE" 4 2 0 #t '(0 1 2 3 4) #:try-to-move? #t)))
|
||||
|
||||
(check-exn
|
||||
#rx"expected start, end, and dest-pos to be non-negative"
|
||||
(thunk (edit-string/text "ABCDE" -1 4 4 #t #f)))
|
||||
(check-exn
|
||||
#rx"expected start, end, and dest-pos to be non-negative"
|
||||
(thunk (edit-string/text "ABCDE" -1 4 4 #t '(0 1 2 3 4))))
|
||||
(check-exn
|
||||
#rx"expected start, end, and dest-pos to be non-negative"
|
||||
(thunk (edit-string/text "ABCDE" -1 4 4 #t #f #:try-to-move? #t)))
|
||||
(check-exn
|
||||
#rx"expected start, end, and dest-pos to be non-negative"
|
||||
(thunk (edit-string/text "ABCDE" -1 4 4 #t '(0 1 2 3 4) #:try-to-move? #t)))
|
||||
(check-exn
|
||||
#rx"expected start, end, and dest-pos to be non-negative"
|
||||
(thunk (edit-string/text "ABCDE" 0 -1 4 #t #f)))
|
||||
(check-exn
|
||||
#rx"expected start, end, and dest-pos to be non-negative"
|
||||
(thunk (edit-string/text "ABCDE" 0 -1 4 #t '(0 1 2 3 4))))
|
||||
(check-exn
|
||||
#rx"expected start, end, and dest-pos to be non-negative"
|
||||
(thunk (edit-string/text "ABCDE" 0 -1 4 #t #f #:try-to-move? #t)))
|
||||
(check-exn
|
||||
#rx"expected start, end, and dest-pos to be non-negative"
|
||||
(thunk (edit-string/text "ABCDE" 0 -1 4 #t '(0 1 2 3 4) #:try-to-move? #t)))
|
||||
(check-exn
|
||||
#rx"expected start, end, and dest-pos to be non-negative"
|
||||
(thunk (edit-string/text "ABCDE" 0 4 -1 #t #f)))
|
||||
(check-exn
|
||||
#rx"expected start, end, and dest-pos to be non-negative"
|
||||
(thunk (edit-string/text "ABCDE" 0 4 -1 #t '(0 1 2 3 4))))
|
||||
(check-exn
|
||||
#rx"expected start, end, and dest-pos to be non-negative"
|
||||
(thunk (edit-string/text "ABCDE" 0 4 -1 #t #f #:try-to-move? #t)))
|
||||
(check-exn
|
||||
#rx"expected start, end, and dest-pos to be non-negative"
|
||||
(thunk (edit-string/text "ABCDE" 0 4 -1 #t '(0 1 2 3 4) #:try-to-move? #t)))
|
||||
(check-exn
|
||||
#rx"expected start, end, and dest-pos to be non-negative"
|
||||
(thunk (edit-string/text "ABCDE" -1 -1 0 #t #f)))
|
||||
(check-exn
|
||||
#rx"expected start, end, and dest-pos to be non-negative"
|
||||
(thunk (edit-string/text "ABCDE" -1 -1 0 #t '(0 1 2 3 4))))
|
||||
(check-exn
|
||||
#rx"expected start, end, and dest-pos to be non-negative"
|
||||
(thunk (edit-string/text "ABCDE" -1 -1 0 #t #f #:try-to-move? #t)))
|
||||
(check-exn
|
||||
#rx"expected start, end, and dest-pos to be non-negative"
|
||||
(thunk (edit-string/text "ABCDE" -1 -1 0 #t '(0 1 2 3 4) #:try-to-move? #t)))
|
||||
|
||||
;; non-string snips
|
||||
(let ([t (new text:basic%)])
|
||||
(define snip (make-object image-snip% (collection-file-path "plt.gif" "icons")))
|
||||
(send t insert "ABCD")
|
||||
(check-equal? (send t get-text) "ABCD")
|
||||
(send t insert snip 0)
|
||||
(check-equal? (send t get-text) ".ABCD")
|
||||
(send t move/copy-to-edit t 0 3 5 #:try-to-move? #t)
|
||||
(check-equal? (send t get-text) "CD.AB")
|
||||
(check-equal? (send t get-snip-position snip) 2)
|
||||
(check-equal? (send t find-snip 2 'after) snip))
|
||||
|
||||
(let ([t (new text:basic%)])
|
||||
(define snip (make-object image-snip% (collection-file-path "plt.gif" "icons")))
|
||||
(send t insert "ABCD")
|
||||
(send t insert snip 0)
|
||||
(send t move/copy-to-edit t 0 3 5 #:try-to-move? #f)
|
||||
(check-equal? (send t get-text) ".ABCD.AB")
|
||||
(check-equal? (send t get-snip-position snip) 0)
|
||||
(check-equal? (send t find-snip 0 'after) snip))
|
||||
|
||||
(let ([t1 (new text:basic%)]
|
||||
[t2 (new text:basic%)])
|
||||
(define snip (make-object image-snip% (collection-file-path "plt.gif" "icons")))
|
||||
(send t1 insert "ABCD")
|
||||
(send t1 insert snip 0)
|
||||
(send t1 move/copy-to-edit t2 0 3 0 #:try-to-move? #t)
|
||||
(check-equal? (send t1 get-text) "CD")
|
||||
(check-equal? (send t2 get-text) ".AB")
|
||||
(check-equal? (send t2 get-snip-position snip) 0)
|
||||
(check-equal? (send t2 find-snip 0 'after) snip))
|
||||
|
||||
(let ([t1 (new text:basic%)]
|
||||
[t2 (new text:basic%)])
|
||||
(define snip (make-object image-snip% (collection-file-path "plt.gif" "icons")))
|
||||
(send t1 insert "ABCD")
|
||||
(send t1 insert snip 0)
|
||||
(send t1 move/copy-to-edit t2 0 3 0 #:try-to-move? #f)
|
||||
(check-equal? (send t1 get-text) ".ABCD")
|
||||
(check-equal? (send t2 get-text) ".AB"))
|
||||
|
||||
;; Random Tests
|
||||
(define (random-sequence n [div 2])
|
||||
(for/list ([i (in-range n)]
|
||||
#:when (zero? (random div)))
|
||||
i))
|
||||
|
||||
(define (edit-string str start end dest-pos move?)
|
||||
(define strlen (string-length str))
|
||||
(define sub (substring str start end))
|
||||
(cond
|
||||
[(and move? (<= start dest-pos end)) str]
|
||||
[else
|
||||
(string-append
|
||||
(if (and move? (<= end dest-pos))
|
||||
(string-append
|
||||
(substring str 0 start)
|
||||
(substring str end dest-pos))
|
||||
(substring str 0 dest-pos))
|
||||
sub
|
||||
(if (and move? (<= dest-pos start))
|
||||
(string-append
|
||||
(substring str dest-pos start)
|
||||
(substring str end strlen))
|
||||
(substring str dest-pos strlen)))]))
|
||||
|
||||
(check-equal? (edit-string "ABCDEF" 1 3 0 #f) "BCABCDEF")
|
||||
(check-equal? (edit-string "ABCDEF" 1 3 0 #t) "BCADEF")
|
||||
(check-equal? (edit-string "ABCDEF" 1 3 5 #f) "ABCDEBCF")
|
||||
(check-equal? (edit-string "ABCDEF" 1 3 5 #t) "ADEBCF")
|
||||
|
||||
(define (random-string n)
|
||||
(define letters "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ")
|
||||
(list->string
|
||||
(for/list ([i (in-range (add1 (random n)))])
|
||||
(define ix (random (string-length letters)))
|
||||
(string-ref letters ix))))
|
||||
|
||||
(define (random-check-edit-string)
|
||||
(define str (random-string 1000))
|
||||
(define strlen (string-length str))
|
||||
(define start (random strlen))
|
||||
(define end (+ start (random (add1 (- strlen start)))))
|
||||
(define dest-pos (random (add1 strlen)))
|
||||
(define random-style (random-sequence (add1 strlen)))
|
||||
(define this? (zero? (random 2)))
|
||||
(define contract-this? (zero? (random 2)))
|
||||
(define try-to-move? (zero? (random 2)))
|
||||
(check-equal?
|
||||
(edit-string/text str start end dest-pos this? random-style
|
||||
#:try-to-move? try-to-move?
|
||||
#:contract-this? contract-this?)
|
||||
(edit-string str start end dest-pos try-to-move?)))
|
||||
(for ([i (in-range 1000)])
|
||||
(random-check-edit-string))
|
||||
|
||||
(define (check-move/copy+delete-property)
|
||||
(define t1 (new text:basic%))
|
||||
(define t2 (new text:basic%))
|
||||
(define str (random-string 1000))
|
||||
(define strlen (string-length str))
|
||||
(define start (random strlen))
|
||||
(define end (+ start (random (add1 (- strlen start)))))
|
||||
(define dest-pos (random (add1 strlen)))
|
||||
(define random-style (random-sequence (add1 strlen)))
|
||||
(send t1 insert str)
|
||||
(send t2 insert str)
|
||||
(edit-style t1 random-style)
|
||||
(edit-style t2 random-style)
|
||||
(send t1 move-to t1 start end dest-pos)
|
||||
(send t2 copy-to t2 start end dest-pos)
|
||||
(cond
|
||||
[(<= start dest-pos end)
|
||||
(send t2 delete (+ dest-pos (- end start)) (+ end (- end start)))
|
||||
(send t2 delete start dest-pos)]
|
||||
[(<= dest-pos start)
|
||||
(send t2 delete (+ start (- end start)) (+ end (- end start)))]
|
||||
[(<= end dest-pos)
|
||||
(send t2 delete start end)])
|
||||
(check-equal? (send t1 get-text) (send t2 get-text)))
|
||||
(for ([i (in-range 1000)])
|
||||
(check-move/copy+delete-property))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; ascii art boxes
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user