improve support for editing the ascii art (unicode) #2d rectangles
specifically, add a mode that avoids breaking the edges of the rectangle when you type and add a keystroke for adding a new in the existing row
This commit is contained in:
Robby Findler
parent
fcd134eebe
commit
18404570dd
|
|
@ -268,6 +268,39 @@
|
|||
preference changes.
|
||||
}
|
||||
|
||||
@definterface[text:ascii-art-enlarge-boxes<%> ()]{
|
||||
@defmethod[(set-ascii-art-enlarge [e? any/c]) void?]{
|
||||
Enables or disables the ascii art box enlarging mode based on @racket[e?]'s true value.
|
||||
}
|
||||
@defmethod[(get-ascii-art-enlarge) boolean?]{
|
||||
Returns @racket[#t] if ascii art box enlarging mode is enabled and @racket[#f] otherwise.
|
||||
}
|
||||
}
|
||||
|
||||
@defmixin[text:ascii-art-enlarge-boxes-mixin (text%) (text:ascii-art-enlarge-boxes<%>)]{
|
||||
@defmethod[#:mode override (on-local-char [event (is-a?/c key-event%)]) void?]{
|
||||
When the @method[key-event% get-key-code] method of @racket[event] returns either
|
||||
@racket['numpad-enter] or @racket[#\return] and
|
||||
@method[text:ascii-art-enlarge-boxes<%> get-ascii-art-enlarge] returns
|
||||
@racket[#t], this method handles
|
||||
the return key by adding an additional line in the containing unicode ascii art
|
||||
box and moving the insertion point to the first character on the new line that
|
||||
is in the containing cell.
|
||||
|
||||
It does not call the @racket[super] method (in that case).
|
||||
}
|
||||
@defmethod[#:mode override (on-default-char [event (is-a?/c key-event%)]) void?]{
|
||||
When the @method[key-event% get-key-code] method of @racket[event] returns either
|
||||
a character or symbol that corresponds to the insertion of a single character
|
||||
@method[text:ascii-art-enlarge-boxes<%> get-ascii-art-enlarge] returns
|
||||
@racket[#t], this method first makes room in the box and then calls the
|
||||
@racket[super] method. If the @method[text% get-overwrite-mode] returns
|
||||
@racket[#f], then it always opens up a column in the box. If @method[text% get-overwrite-mode]
|
||||
returns @racket[#t], then it opens up a column only when the character to
|
||||
be inserted would overwrite one of the walls.
|
||||
}
|
||||
}
|
||||
|
||||
@definterface[text:first-line<%> (text%)]{
|
||||
|
||||
Objects implementing this interface, when @method[text:first-line<%>
|
||||
|
|
|
|||
|
|
@ -1118,6 +1118,29 @@
|
|||
|
||||
[define anchor-last-state? #f]
|
||||
[define overwrite-last-state? #f]
|
||||
|
||||
(define/private (update-ascii-art-enlarge-msg)
|
||||
(define ascii-art-enlarge-mode?
|
||||
(let ([e (get-info-editor)])
|
||||
(and (is-a? e text:ascii-art-enlarge-boxes<%>)
|
||||
(send e get-ascii-art-enlarge))))
|
||||
(unless (eq? (and (member ascii-art-enlarge-mode-msg (send uncommon-parent get-children)) #t)
|
||||
ascii-art-enlarge-mode?)
|
||||
(if ascii-art-enlarge-mode?
|
||||
(add-uncommon-child ascii-art-enlarge-mode-msg)
|
||||
(remove-uncommon-child ascii-art-enlarge-mode-msg))))
|
||||
|
||||
;; this callback is kind of a hack. we know that when the set-ascii-art-enlarge
|
||||
;; method of text:ascii-art-enlarge<%> is called that it changes the preferences
|
||||
;; value so we will get called back here; it would be better if we could just
|
||||
;; have the callback happen directly by overriding that method, but that causes
|
||||
;; backwards incompatibility problems.
|
||||
(define callback (λ (p v)
|
||||
(queue-callback
|
||||
(λ () (update-ascii-art-enlarge-msg))
|
||||
#f)))
|
||||
(preferences:add-callback 'framework:ascii-art-enlarge callback)
|
||||
|
||||
|
||||
(field (macro-recording? #f))
|
||||
(define/private (update-macro-recording-icon)
|
||||
|
|
@ -1193,6 +1216,7 @@
|
|||
(define/override (update-info)
|
||||
(super update-info)
|
||||
(update-macro-recording-icon)
|
||||
(update-ascii-art-enlarge-msg)
|
||||
(overwrite-status-changed)
|
||||
(anchor-status-changed)
|
||||
(editor-position-changed)
|
||||
|
|
@ -1233,6 +1257,11 @@
|
|||
|
||||
(send (get-info-panel) change-children
|
||||
(λ (l) (cons uncommon-parent (remq uncommon-parent l))))
|
||||
|
||||
(define ascii-art-enlarge-mode-msg (new message%
|
||||
[parent uncommon-parent]
|
||||
[label "╠╬╣"]
|
||||
[auto-resize #t]))
|
||||
(define anchor-message
|
||||
(new message%
|
||||
[font small-control-font]
|
||||
|
|
@ -1254,6 +1283,7 @@
|
|||
(define/private (add-uncommon-child c)
|
||||
(define (child->num c)
|
||||
(cond
|
||||
[(eq? c ascii-art-enlarge-mode-msg) -1]
|
||||
[(eq? c anchor-message) 0]
|
||||
[(eq? c overwrite-message) 1]
|
||||
[(eq? c macro-recording-message) 2]))
|
||||
|
|
|
|||
|
|
@ -9,7 +9,8 @@
|
|||
frame:basic<%>
|
||||
frame:standard-menus<%>
|
||||
frame:info<%>
|
||||
frame:text-info<%>)
|
||||
frame:text-info<%>
|
||||
text:ascii-art-enlarge-boxes<%>)
|
||||
|
||||
(define editor:basic<%>
|
||||
(interface (editor<%>)
|
||||
|
|
@ -32,6 +33,12 @@
|
|||
(interface (editor:basic<%>)
|
||||
get-keymaps))
|
||||
|
||||
|
||||
(define text:ascii-art-enlarge-boxes<%>
|
||||
(interface ()
|
||||
set-ascii-art-enlarge
|
||||
get-ascii-art-enlarge))
|
||||
|
||||
(define text:basic<%>
|
||||
(interface (editor:basic<%> (class->interface text%))
|
||||
highlight-range
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@
|
|||
"interfaces.rkt"
|
||||
"../preferences.rkt"
|
||||
"gen-standard-menus.rkt"
|
||||
"unicode-ascii-art.rkt"
|
||||
(only-in srfi/13 string-prefix? string-prefix-length)
|
||||
2d/dir-chars
|
||||
racket/list)
|
||||
|
|
@ -708,6 +709,17 @@
|
|||
(define start (send txt get-start-position))
|
||||
(when (= start (send txt get-end-position))
|
||||
(widen-unicode-ascii-art-box txt start)))]
|
||||
|
||||
[heighten-unicode-ascii-art-box
|
||||
(λ (txt evt)
|
||||
(define start (send txt get-start-position))
|
||||
(when (= start (send txt get-end-position))
|
||||
(heighten-unicode-ascii-art-box txt start)))]
|
||||
|
||||
[toggle-unicode-ascii-art-enlarge-mode
|
||||
(λ (txt evt)
|
||||
(when (is-a? txt text:ascii-art-enlarge-boxes<%>)
|
||||
(send txt set-ascii-art-enlarge (not (send txt get-ascii-art-enlarge)))))]
|
||||
|
||||
[center-in-unicode-ascii-art-box
|
||||
(λ (txt evt)
|
||||
|
|
@ -740,6 +752,8 @@
|
|||
|
||||
(add "normalize-unicode-ascii-art-box" normalize-unicode-ascii-art-box)
|
||||
(add "widen-unicode-ascii-art-box" widen-unicode-ascii-art-box)
|
||||
(add "heighten-unicode-ascii-art-box" heighten-unicode-ascii-art-box)
|
||||
(add "toggle-unicode-ascii-art-enlarge-mode" toggle-unicode-ascii-art-enlarge-mode)
|
||||
(add "center-in-unicode-ascii-art-box" center-in-unicode-ascii-art-box)
|
||||
(add "shift-focus" (shift-focus values))
|
||||
(add "shift-focus-backwards" (shift-focus reverse))
|
||||
|
|
@ -836,7 +850,9 @@
|
|||
|
||||
(map "c:x;r;a" "normalize-unicode-ascii-art-box")
|
||||
(map "c:x;r;w" "widen-unicode-ascii-art-box")
|
||||
(map "c:x;r;v" "highten-unicode-ascii-art-box")
|
||||
(map "c:x;r;c" "center-in-unicode-ascii-art-box")
|
||||
(map "c:x;r;o" "toggle-unicode-ascii-art-enlarge-mode")
|
||||
|
||||
(map "~m:c:\\" "TeX compress")
|
||||
(map "~c:m:\\" "TeX compress")
|
||||
|
|
@ -1027,166 +1043,6 @@
|
|||
(f click-pos eol start-pos click-pos)
|
||||
(f click-pos eol click-pos end-pos))))
|
||||
|
||||
|
||||
|
||||
(define (widen-unicode-ascii-art-box t orig-pos)
|
||||
(define start-pos (scan-for-start-pos t orig-pos))
|
||||
(when start-pos
|
||||
(send t begin-edit-sequence)
|
||||
(define-values (start-x start-y) (pos->xy t orig-pos))
|
||||
(define min-y #f)
|
||||
(define max-y #f)
|
||||
(trace-unicode-ascii-art-box
|
||||
t start-pos #f
|
||||
(λ (pos x y i-up? i-dn? i-lt? i-rt?)
|
||||
(when (= x start-x)
|
||||
(unless min-y
|
||||
(set! min-y y)
|
||||
(set! max-y y))
|
||||
(set! min-y (min y min-y))
|
||||
(set! max-y (max y max-y)))))
|
||||
(define to-adjust 0)
|
||||
(for ([y (in-range max-y (- min-y 1) -1)])
|
||||
(define-values (pos char) (xy->pos t start-x y))
|
||||
(when (< pos start-pos)
|
||||
(set! to-adjust (+ to-adjust 1)))
|
||||
(send t insert
|
||||
(cond
|
||||
[(member char lt-chars) #\═]
|
||||
[else #\space])
|
||||
pos pos))
|
||||
(send t set-position (+ orig-pos to-adjust 1) (+ orig-pos to-adjust 1))
|
||||
(send t end-edit-sequence)))
|
||||
|
||||
(define (normalize-unicode-ascii-art-box t pos)
|
||||
(define start-pos (scan-for-start-pos t pos))
|
||||
(when start-pos
|
||||
(send t begin-edit-sequence)
|
||||
(trace-unicode-ascii-art-box
|
||||
t start-pos #f
|
||||
(λ (pos x y i-up? i-dn? i-lt? i-rt?)
|
||||
(cond
|
||||
[(and i-up? i-dn? i-lt? i-rt?) (set-c t pos "╬")]
|
||||
[(and i-dn? i-lt? i-rt?) (set-c t pos "╦")]
|
||||
[(and i-up? i-lt? i-rt?) (set-c t pos "╩")]
|
||||
[(and i-up? i-dn? i-rt?) (set-c t pos "╠")]
|
||||
[(and i-up? i-dn? i-lt?) (set-c t pos "╣")]
|
||||
[(and i-up? i-lt?) (set-c t pos "╝")]
|
||||
[(and i-up? i-rt?) (set-c t pos "╚")]
|
||||
[(and i-dn? i-lt?) (set-c t pos "╗")]
|
||||
[(and i-dn? i-rt?) (set-c t pos "╔")]
|
||||
[(or i-up? i-dn?) (set-c t pos "║")]
|
||||
[else (set-c t pos "═")])))
|
||||
(send t end-edit-sequence)))
|
||||
|
||||
(define (center-in-unicode-ascii-art-box txt insertion-pos)
|
||||
(define (find-something start-pos inc char-p?)
|
||||
(define-values (x y) (pos->xy txt start-pos))
|
||||
(let loop ([pos start-pos])
|
||||
(cond
|
||||
[(char-p? (send txt get-character pos))
|
||||
pos]
|
||||
[else
|
||||
(define new-pos (inc pos))
|
||||
(cond
|
||||
[(<= 0 new-pos (send txt last-position))
|
||||
(define-values (x2 y2) (pos->xy txt new-pos))
|
||||
(cond
|
||||
[(= y2 y)
|
||||
(loop new-pos)]
|
||||
[else #f])]
|
||||
[else #f])])))
|
||||
|
||||
(define (adjust-space before-space after-space pos)
|
||||
(cond
|
||||
[(< before-space after-space)
|
||||
(send txt insert (make-string (- after-space before-space) #\space) pos pos)]
|
||||
[(> before-space after-space)
|
||||
(send txt delete pos (+ pos (- before-space after-space)))]))
|
||||
|
||||
(define left-bar (find-something insertion-pos sub1 (λ (x) (equal? x #\║))))
|
||||
(define right-bar (find-something insertion-pos add1 (λ (x) (equal? x #\║))))
|
||||
(when (and left-bar right-bar (< left-bar right-bar))
|
||||
(define left-space-edge (find-something (+ left-bar 1) add1 (λ (x) (not (char-whitespace? x)))))
|
||||
(define right-space-edge (find-something (- right-bar 1) sub1 (λ (x) (not (char-whitespace? x)))))
|
||||
(when (and left-space-edge right-space-edge)
|
||||
(define before-left-space-count (- left-space-edge left-bar 1))
|
||||
(define before-right-space-count (- right-bar right-space-edge 1))
|
||||
(define tot-space (+ before-left-space-count before-right-space-count))
|
||||
(define after-left-space-count (floor (/ tot-space 2)))
|
||||
(define after-right-space-count (ceiling (/ tot-space 2)))
|
||||
(send txt begin-edit-sequence)
|
||||
(adjust-space before-right-space-count after-right-space-count (+ right-space-edge 1))
|
||||
(adjust-space before-left-space-count after-left-space-count (+ left-bar 1))
|
||||
(send txt end-edit-sequence))))
|
||||
|
||||
(define (trace-unicode-ascii-art-box t start-pos only-double-barred-chars? f)
|
||||
(define visited (make-hash))
|
||||
(let loop ([pos start-pos])
|
||||
(unless (hash-ref visited pos #f)
|
||||
(hash-set! visited pos #t)
|
||||
(define-values (x y) (pos->xy t pos))
|
||||
(define c (send t get-character pos))
|
||||
(define-values (up upc) (xy->pos t x (- y 1)))
|
||||
(define-values (dn dnc) (xy->pos t x (+ y 1)))
|
||||
(define-values (lt ltc) (xy->pos t (- x 1) y))
|
||||
(define-values (rt rtc) (xy->pos t (+ x 1) y))
|
||||
(define (interesting-dir? dir-c dir-chars)
|
||||
(or (and (not only-double-barred-chars?)
|
||||
(member dir-c adjustable-chars)
|
||||
(member c dir-chars))
|
||||
(and (member dir-c double-barred-chars)
|
||||
(member c double-barred-chars))))
|
||||
(define i-up? (interesting-dir? upc up-chars))
|
||||
(define i-dn? (interesting-dir? dnc dn-chars))
|
||||
(define i-lt? (interesting-dir? ltc lt-chars))
|
||||
(define i-rt? (interesting-dir? rtc rt-chars))
|
||||
(f pos x y i-up? i-dn? i-lt? i-rt?)
|
||||
(when i-up? (loop up))
|
||||
(when i-dn? (loop dn))
|
||||
(when i-lt? (loop lt))
|
||||
(when i-rt? (loop rt)))))
|
||||
|
||||
(define (scan-for-start-pos t pos)
|
||||
(define-values (x y) (pos->xy t pos))
|
||||
(findf
|
||||
(λ (p) (adj? t p))
|
||||
(for*/list ([xadj '(0 -1)]
|
||||
[yadj '(0 -1 1)])
|
||||
(define-values (d dc) (xy->pos t (+ x xadj) (+ y yadj)))
|
||||
d)))
|
||||
|
||||
(define (adj? t pos)
|
||||
(and pos
|
||||
(member (send t get-character pos)
|
||||
adjustable-chars)))
|
||||
|
||||
(define (set-c t pos s)
|
||||
(unless (equal? (string-ref s 0) (send t get-character pos))
|
||||
(send t delete pos (+ pos 1))
|
||||
(send t insert s pos pos)))
|
||||
|
||||
(define (pos->xy text pos)
|
||||
(define para (send text position-paragraph pos))
|
||||
(define start (send text paragraph-start-position para))
|
||||
(values (- pos start) para))
|
||||
|
||||
(define (xy->pos text x y)
|
||||
(cond
|
||||
[(and (<= 0 x) (<= 0 y (send text last-paragraph)))
|
||||
(define para-start (send text paragraph-start-position y))
|
||||
(define para-end (send text paragraph-end-position y))
|
||||
(define pos (+ para-start x))
|
||||
(define res-pos
|
||||
(and (< pos para-end)
|
||||
;; the newline at the end of the
|
||||
;; line is not on the line, so use this guard
|
||||
pos))
|
||||
(if res-pos
|
||||
(values res-pos (send text get-character res-pos))
|
||||
(values #f #f))]
|
||||
[else (values #f #f)]))
|
||||
|
||||
(define/contract (run-some-keystrokes before key-evts)
|
||||
(-> (list/c string? exact-nonnegative-integer? exact-nonnegative-integer?)
|
||||
(listof (is-a?/c key-event%))
|
||||
|
|
@ -1204,182 +1060,7 @@
|
|||
(send t get-end-position)))
|
||||
|
||||
(module+ test
|
||||
(require rackunit
|
||||
racket/gui/base)
|
||||
(define sa string-append)
|
||||
|
||||
(define (first-value-xy->pos a b c)
|
||||
(define-values (d e) (xy->pos a b c))
|
||||
d)
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (sa "abc\n"
|
||||
"d\n"
|
||||
"ghi\n"))
|
||||
(check-equal? (first-value-xy->pos t 0 0) 0)
|
||||
(check-equal? (first-value-xy->pos t 1 0) 1)
|
||||
(check-equal? (first-value-xy->pos t 0 1) 4)
|
||||
(check-equal? (first-value-xy->pos t 3 0) #f)
|
||||
(check-equal? (first-value-xy->pos t 0 3) #f)
|
||||
(check-equal? (first-value-xy->pos t 1 1) #f)
|
||||
(check-equal? (first-value-xy->pos t 2 1) #f)
|
||||
(check-equal? (first-value-xy->pos t 0 2) 6)
|
||||
(check-equal? (first-value-xy->pos t 1 2) 7)
|
||||
(check-equal? (first-value-xy->pos t 2 -1) #f)
|
||||
(check-equal? (first-value-xy->pos t -1 0) #f)
|
||||
(check-equal? (first-value-xy->pos t 2 2) 8)
|
||||
(check-equal? (first-value-xy->pos t 2 3) #f))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (sa "abc\n"
|
||||
"d\n"
|
||||
"ghi"))
|
||||
(check-equal? (first-value-xy->pos t 2 2) 8)
|
||||
(check-equal? (first-value-xy->pos t 2 3) #f))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (string-append "+-+\n"
|
||||
"| |\n"
|
||||
"+-+\n"))
|
||||
(normalize-unicode-ascii-art-box t 0)
|
||||
(check-equal? (send t get-text)
|
||||
(string-append
|
||||
"╔═╗\n"
|
||||
"║ ║\n"
|
||||
"╚═╝\n")))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (string-append "+=+\n"
|
||||
"| |\n"
|
||||
"+=+\n"))
|
||||
(normalize-unicode-ascii-art-box t 0)
|
||||
(check-equal? (send t get-text)
|
||||
(string-append
|
||||
"╔═╗\n"
|
||||
"║ ║\n"
|
||||
"╚═╝\n")))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (string-append "+-+-+\n"
|
||||
"| | |\n"
|
||||
"+-+-+\n"
|
||||
"| | |\n"
|
||||
"+-+-+\n"))
|
||||
(normalize-unicode-ascii-art-box t 0)
|
||||
(check-equal? (send t get-text)
|
||||
(string-append
|
||||
"╔═╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"╠═╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚═╩═╝\n")))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (string-append
|
||||
"╔═══╗\n"
|
||||
"║ - ║\n"
|
||||
"╚═══╝\n"))
|
||||
|
||||
(normalize-unicode-ascii-art-box t 0)
|
||||
(check-equal? (send t get-text)
|
||||
(string-append
|
||||
"╔═══╗\n"
|
||||
"║ - ║\n"
|
||||
"╚═══╝\n")))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (string-append
|
||||
"╔═╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"╠═╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚═╩═╝\n"))
|
||||
(send t set-position 1 1)
|
||||
(widen-unicode-ascii-art-box t 1)
|
||||
(check-equal? (send t get-start-position) 2)
|
||||
(check-equal? (send t get-text)
|
||||
(string-append
|
||||
"╔══╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"╠══╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚══╩═╝\n")))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (string-append
|
||||
"╔═╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"╠═╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚═╩═╝\n"))
|
||||
(send t set-position 8 8)
|
||||
(widen-unicode-ascii-art-box t 8)
|
||||
(check-equal? (send t get-start-position) 10)
|
||||
(check-equal? (send t get-text)
|
||||
(string-append
|
||||
"╔══╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"╠══╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚══╩═╝\n")))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (string-append
|
||||
"╔═╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"╠═╬═╣\n"
|
||||
"║ ║ ║\n"))
|
||||
(send t set-position 8 8)
|
||||
(widen-unicode-ascii-art-box t 8)
|
||||
(check-equal? (send t get-text)
|
||||
(string-append
|
||||
"╔══╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"╠══╬═╣\n"
|
||||
"║ ║ ║\n")))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert "║ x ║\n")
|
||||
(center-in-unicode-ascii-art-box t 1)
|
||||
(check-equal? (send t get-text)
|
||||
"║ x ║\n"))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert "║x ║\n")
|
||||
(center-in-unicode-ascii-art-box t 1)
|
||||
(check-equal? (send t get-text)
|
||||
"║ x ║\n"))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert "║ x║\n")
|
||||
(center-in-unicode-ascii-art-box t 1)
|
||||
(check-equal? (send t get-text)
|
||||
"║ x ║\n"))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert "║abcde║\n")
|
||||
(center-in-unicode-ascii-art-box t 1)
|
||||
(check-equal? (send t get-text)
|
||||
"║abcde║\n"))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert "║║\n")
|
||||
(center-in-unicode-ascii-art-box t 1)
|
||||
(check-equal? (send t get-text)
|
||||
"║║\n"))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert "║abcde \n")
|
||||
(center-in-unicode-ascii-art-box t 1)
|
||||
(check-equal? (send t get-text)
|
||||
"║abcde \n"))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert " abcde║\n")
|
||||
(center-in-unicode-ascii-art-box t 1)
|
||||
(check-equal? (send t get-text)
|
||||
" abcde║\n"))
|
||||
|
||||
(require rackunit)
|
||||
(check-equal? (run-some-keystrokes '("abc" 0 0)
|
||||
(list (new key-event% [key-code 'escape])
|
||||
(new key-event% [key-code #\c])))
|
||||
|
|
|
|||
|
|
@ -25,6 +25,8 @@
|
|||
|
||||
(application-preferences-handler (λ () (preferences:show-dialog)))
|
||||
|
||||
(preferences:set-default 'framework:ascii-art-enlarge #f boolean?)
|
||||
|
||||
(preferences:set-default 'framework:color-scheme 'classic symbol?)
|
||||
|
||||
(preferences:set-default 'framework:column-guide-width
|
||||
|
|
|
|||
|
|
@ -182,6 +182,7 @@
|
|||
(define-signature text-class^
|
||||
(basic<%>
|
||||
line-spacing<%>
|
||||
ascii-art-enlarge-boxes<%>
|
||||
first-line<%>
|
||||
line-numbers<%>
|
||||
foreground-color<%>
|
||||
|
|
@ -225,6 +226,7 @@
|
|||
|
||||
basic-mixin
|
||||
line-spacing-mixin
|
||||
ascii-art-enlarge-boxes-mixin
|
||||
first-line-mixin
|
||||
line-numbers-mixin
|
||||
foreground-color-mixin
|
||||
|
|
|
|||
|
|
@ -16,6 +16,7 @@
|
|||
racket/list
|
||||
"logging-timer.rkt"
|
||||
"coroutine.rkt"
|
||||
"unicode-ascii-art.rkt"
|
||||
data/queue
|
||||
racket/unit)
|
||||
|
||||
|
|
@ -870,6 +871,89 @@
|
|||
|
||||
(super-new)))
|
||||
|
||||
(define ascii-art-enlarge-boxes<%> text:ascii-art-enlarge-boxes<%>)
|
||||
|
||||
(define ascii-art-enlarge-boxes-mixin
|
||||
(mixin ((class->interface text%)) (ascii-art-enlarge-boxes<%>)
|
||||
(inherit get-overwrite-mode set-overwrite-mode
|
||||
get-start-position get-end-position set-position last-position
|
||||
get-character
|
||||
begin-edit-sequence end-edit-sequence
|
||||
position-paragraph paragraph-start-position)
|
||||
|
||||
(define ascii-art-enlarge? (preferences:get 'framework:ascii-art-enlarge))
|
||||
(define/public (get-ascii-art-enlarge) ascii-art-enlarge?)
|
||||
(define/public (set-ascii-art-enlarge _e?)
|
||||
(define e? (and _e? #t))
|
||||
(preferences:set 'framework:ascii-art-enlarge e?)
|
||||
(set! ascii-art-enlarge? e?))
|
||||
|
||||
(define/override (on-default-char c)
|
||||
(define kc (send c get-key-code))
|
||||
(define overwrite? (get-overwrite-mode))
|
||||
(cond
|
||||
[(not ascii-art-enlarge?) (super on-default-char c)]
|
||||
[(or (and (char? kc)
|
||||
(not (member kc '(#\return #\tab #\backspace #\rubout))))
|
||||
(member (send c get-key-code)
|
||||
going-to-insert-something))
|
||||
(begin-edit-sequence)
|
||||
(define pos (get-start-position))
|
||||
(define widen? (and (= pos (get-end-position))
|
||||
(or (not overwrite?)
|
||||
(insertion-point-at-double-barred-char?))))
|
||||
(when widen?
|
||||
(define para (position-paragraph pos))
|
||||
(define delta-from-start (- pos (paragraph-start-position para)))
|
||||
(widen-unicode-ascii-art-box this pos)
|
||||
(define new-pos (+ (paragraph-start-position para) delta-from-start))
|
||||
(set-position new-pos new-pos))
|
||||
(unless overwrite? (set-overwrite-mode #t))
|
||||
(super on-default-char c)
|
||||
(unless overwrite? (set-overwrite-mode #f))
|
||||
(end-edit-sequence)]
|
||||
[else
|
||||
(super on-default-char c)]))
|
||||
|
||||
(define/override (on-local-char c)
|
||||
(define kc (send c get-key-code))
|
||||
(define overwrite? (get-overwrite-mode))
|
||||
(cond
|
||||
[(not ascii-art-enlarge?) (super on-local-char c)]
|
||||
[(member kc '(numpad-enter #\return))
|
||||
(define pos (get-start-position))
|
||||
(cond
|
||||
[(= pos (get-end-position))
|
||||
(heighten-unicode-ascii-art-box this pos)
|
||||
(define pos-para (position-paragraph pos))
|
||||
(define pos-para-start (paragraph-start-position pos-para))
|
||||
(define next-para-start (paragraph-start-position (+ pos-para 1)))
|
||||
(define just-below-pos (+ next-para-start (- pos pos-para-start)))
|
||||
(define new-pos
|
||||
(let loop ([pos just-below-pos])
|
||||
(cond
|
||||
[(<= pos next-para-start)
|
||||
pos]
|
||||
[(equal? (get-character (- pos 1)) #\║)
|
||||
pos]
|
||||
[else (loop (- pos 1))])))
|
||||
(set-position new-pos new-pos)]
|
||||
[else
|
||||
(super on-local-char c)])]
|
||||
[else
|
||||
(super on-local-char c)]))
|
||||
|
||||
(define/private (insertion-point-at-double-barred-char?)
|
||||
(define sp (get-start-position))
|
||||
(and (< sp (last-position))
|
||||
(equal? (get-character sp) #\║)))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define going-to-insert-something
|
||||
'(multiply
|
||||
add subtract decimal divide
|
||||
numpad0 numpad1 numpad2 numpad3 numpad4 numpad5 numpad6 numpad7 numpad8 numpad9))
|
||||
|
||||
(define foreground-color<%>
|
||||
(interface (basic<%> editor:standard-style-list<%>)
|
||||
|
|
|
|||
450
gui-lib/framework/private/unicode-ascii-art.rkt
Normal file
450
gui-lib/framework/private/unicode-ascii-art.rkt
Normal file
|
|
@ -0,0 +1,450 @@
|
|||
#lang racket/base
|
||||
(require racket/gui/base
|
||||
racket/class
|
||||
racket/contract
|
||||
2d/dir-chars)
|
||||
|
||||
(provide normalize-unicode-ascii-art-box
|
||||
widen-unicode-ascii-art-box
|
||||
heighten-unicode-ascii-art-box
|
||||
center-in-unicode-ascii-art-box)
|
||||
|
||||
(define (widen-unicode-ascii-art-box t orig-pos)
|
||||
(widen/highten-unicode-ascii-art-box t orig-pos #t))
|
||||
|
||||
(define (heighten-unicode-ascii-art-box t orig-pos)
|
||||
(widen/highten-unicode-ascii-art-box t orig-pos #f))
|
||||
|
||||
(define (widen/highten-unicode-ascii-art-box t orig-pos widen?)
|
||||
(define start-pos (scan-for-start-pos t orig-pos))
|
||||
(when start-pos
|
||||
(send t begin-edit-sequence)
|
||||
(define-values (start-x start-y) (pos->xy t orig-pos))
|
||||
(define start-major (if widen? start-x start-y))
|
||||
(define min-minor #f)
|
||||
(define max-minor #f)
|
||||
(trace-unicode-ascii-art-box
|
||||
t start-pos #f
|
||||
(λ (pos x y i-up? i-dn? i-lt? i-rt?)
|
||||
(define minor (if widen? y x))
|
||||
(define major (if widen? x y))
|
||||
(when (= major start-major)
|
||||
(unless min-minor
|
||||
(set! min-minor minor)
|
||||
(set! max-minor minor))
|
||||
(set! min-minor (min minor min-minor))
|
||||
(set! max-minor (max minor max-minor)))))
|
||||
(cond
|
||||
[widen?
|
||||
(define to-adjust 0)
|
||||
(for ([minor (in-range max-minor (- min-minor 1) -1)])
|
||||
(define-values (pos char) (xy->pos t start-major minor))
|
||||
(when (< pos start-pos)
|
||||
(set! to-adjust (+ to-adjust 1)))
|
||||
(send t insert
|
||||
(cond
|
||||
[(member char lt-chars) #\═]
|
||||
[else #\space])
|
||||
pos pos))
|
||||
(send t set-position (+ orig-pos to-adjust 1) (+ orig-pos to-adjust 1))]
|
||||
[else
|
||||
(define-values (min-pos _1) (xy->pos t min-minor start-major))
|
||||
(define-values (max-pos _2) (xy->pos t max-minor start-major))
|
||||
(define para (send t position-paragraph max-pos))
|
||||
(define para-start (send t paragraph-start-position para))
|
||||
(define para-end (send t paragraph-end-position para))
|
||||
(send t insert "\n" para-end para-end)
|
||||
(for ([to-copy-pos (in-range para-start (+ max-pos 1))])
|
||||
(define to-insert-pos (+ para-end 1 (- to-copy-pos para-start)))
|
||||
(define char
|
||||
(cond
|
||||
[(< to-copy-pos min-pos) " "]
|
||||
[else
|
||||
(define above-char (send t get-character to-copy-pos))
|
||||
(if (and (member above-char dn-chars)
|
||||
(member above-char double-barred-chars))
|
||||
"║"
|
||||
" ")]))
|
||||
(send t insert char to-insert-pos to-insert-pos))
|
||||
(void)])
|
||||
(send t end-edit-sequence)))
|
||||
|
||||
(define (normalize-unicode-ascii-art-box t pos)
|
||||
(define start-pos (scan-for-start-pos t pos))
|
||||
(when start-pos
|
||||
(send t begin-edit-sequence)
|
||||
(trace-unicode-ascii-art-box
|
||||
t start-pos #f
|
||||
(λ (pos x y i-up? i-dn? i-lt? i-rt?)
|
||||
(cond
|
||||
[(and i-up? i-dn? i-lt? i-rt?) (set-c t pos "╬")]
|
||||
[(and i-dn? i-lt? i-rt?) (set-c t pos "╦")]
|
||||
[(and i-up? i-lt? i-rt?) (set-c t pos "╩")]
|
||||
[(and i-up? i-dn? i-rt?) (set-c t pos "╠")]
|
||||
[(and i-up? i-dn? i-lt?) (set-c t pos "╣")]
|
||||
[(and i-up? i-lt?) (set-c t pos "╝")]
|
||||
[(and i-up? i-rt?) (set-c t pos "╚")]
|
||||
[(and i-dn? i-lt?) (set-c t pos "╗")]
|
||||
[(and i-dn? i-rt?) (set-c t pos "╔")]
|
||||
[(or i-up? i-dn?) (set-c t pos "║")]
|
||||
[else (set-c t pos "═")])))
|
||||
(send t end-edit-sequence)))
|
||||
|
||||
(define (center-in-unicode-ascii-art-box txt insertion-pos)
|
||||
(define (find-something start-pos inc char-p?)
|
||||
(define-values (x y) (pos->xy txt start-pos))
|
||||
(let loop ([pos start-pos])
|
||||
(cond
|
||||
[(char-p? (send txt get-character pos))
|
||||
pos]
|
||||
[else
|
||||
(define new-pos (inc pos))
|
||||
(cond
|
||||
[(<= 0 new-pos (send txt last-position))
|
||||
(define-values (x2 y2) (pos->xy txt new-pos))
|
||||
(cond
|
||||
[(= y2 y)
|
||||
(loop new-pos)]
|
||||
[else #f])]
|
||||
[else #f])])))
|
||||
|
||||
(define (adjust-space before-space after-space pos)
|
||||
(cond
|
||||
[(< before-space after-space)
|
||||
(send txt insert (make-string (- after-space before-space) #\space) pos pos)]
|
||||
[(> before-space after-space)
|
||||
(send txt delete pos (+ pos (- before-space after-space)))]))
|
||||
|
||||
(define left-bar (find-something insertion-pos sub1 (λ (x) (equal? x #\║))))
|
||||
(define right-bar (find-something insertion-pos add1 (λ (x) (equal? x #\║))))
|
||||
(when (and left-bar right-bar (< left-bar right-bar))
|
||||
(define left-space-edge (find-something (+ left-bar 1) add1 (λ (x) (not (char-whitespace? x)))))
|
||||
(define right-space-edge (find-something (- right-bar 1) sub1 (λ (x) (not (char-whitespace? x)))))
|
||||
(when (and left-space-edge right-space-edge)
|
||||
(define before-left-space-count (- left-space-edge left-bar 1))
|
||||
(define before-right-space-count (- right-bar right-space-edge 1))
|
||||
(define tot-space (+ before-left-space-count before-right-space-count))
|
||||
(define after-left-space-count (floor (/ tot-space 2)))
|
||||
(define after-right-space-count (ceiling (/ tot-space 2)))
|
||||
(send txt begin-edit-sequence)
|
||||
(adjust-space before-right-space-count after-right-space-count (+ right-space-edge 1))
|
||||
(adjust-space before-left-space-count after-left-space-count (+ left-bar 1))
|
||||
(send txt end-edit-sequence))))
|
||||
|
||||
(define (trace-unicode-ascii-art-box t start-pos only-double-barred-chars? f)
|
||||
(define visited (make-hash))
|
||||
(let loop ([pos start-pos])
|
||||
(unless (hash-ref visited pos #f)
|
||||
(hash-set! visited pos #t)
|
||||
(define-values (x y) (pos->xy t pos))
|
||||
(define c (send t get-character pos))
|
||||
(define-values (up upc) (xy->pos t x (- y 1)))
|
||||
(define-values (dn dnc) (xy->pos t x (+ y 1)))
|
||||
(define-values (lt ltc) (xy->pos t (- x 1) y))
|
||||
(define-values (rt rtc) (xy->pos t (+ x 1) y))
|
||||
(define (interesting-dir? dir-c dir-chars)
|
||||
(or (and (not only-double-barred-chars?)
|
||||
(member dir-c adjustable-chars)
|
||||
(member c dir-chars))
|
||||
(and (member dir-c double-barred-chars)
|
||||
(member c double-barred-chars))))
|
||||
(define i-up? (interesting-dir? upc up-chars))
|
||||
(define i-dn? (interesting-dir? dnc dn-chars))
|
||||
(define i-lt? (interesting-dir? ltc lt-chars))
|
||||
(define i-rt? (interesting-dir? rtc rt-chars))
|
||||
(f pos x y i-up? i-dn? i-lt? i-rt?)
|
||||
(when i-up? (loop up))
|
||||
(when i-dn? (loop dn))
|
||||
(when i-lt? (loop lt))
|
||||
(when i-rt? (loop rt)))))
|
||||
|
||||
(define (scan-for-start-pos t pos)
|
||||
(define-values (x y) (pos->xy t pos))
|
||||
(findf
|
||||
(λ (p) (adj? t p))
|
||||
(for*/list ([xadj '(0 -1)]
|
||||
[yadj '(0 -1 1)])
|
||||
(define-values (d dc) (xy->pos t (+ x xadj) (+ y yadj)))
|
||||
d)))
|
||||
|
||||
(define (adj? t pos)
|
||||
(and pos
|
||||
(member (send t get-character pos)
|
||||
adjustable-chars)))
|
||||
|
||||
(define (set-c t pos s)
|
||||
(unless (equal? (string-ref s 0) (send t get-character pos))
|
||||
(send t delete pos (+ pos 1))
|
||||
(send t insert s pos pos)))
|
||||
|
||||
(define (pos->xy text pos)
|
||||
(define para (send text position-paragraph pos))
|
||||
(define start (send text paragraph-start-position para))
|
||||
(values (- pos start) para))
|
||||
|
||||
(define (xy->pos text x y)
|
||||
(cond
|
||||
[(and (<= 0 x) (<= 0 y (send text last-paragraph)))
|
||||
(define para-start (send text paragraph-start-position y))
|
||||
(define para-end (send text paragraph-end-position y))
|
||||
(define pos (+ para-start x))
|
||||
(define res-pos
|
||||
(and (< pos para-end)
|
||||
;; the newline at the end of the
|
||||
;; line is not on the line, so use this guard
|
||||
pos))
|
||||
(if res-pos
|
||||
(values res-pos (send text get-character res-pos))
|
||||
(values #f #f))]
|
||||
[else (values #f #f)]))
|
||||
|
||||
(module+ test
|
||||
(require rackunit
|
||||
racket/gui/base)
|
||||
(define sa string-append)
|
||||
|
||||
(define (first-value-xy->pos a b c)
|
||||
(define-values (d e) (xy->pos a b c))
|
||||
d)
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (sa "abc\n"
|
||||
"d\n"
|
||||
"ghi\n"))
|
||||
(check-equal? (first-value-xy->pos t 0 0) 0)
|
||||
(check-equal? (first-value-xy->pos t 1 0) 1)
|
||||
(check-equal? (first-value-xy->pos t 0 1) 4)
|
||||
(check-equal? (first-value-xy->pos t 3 0) #f)
|
||||
(check-equal? (first-value-xy->pos t 0 3) #f)
|
||||
(check-equal? (first-value-xy->pos t 1 1) #f)
|
||||
(check-equal? (first-value-xy->pos t 2 1) #f)
|
||||
(check-equal? (first-value-xy->pos t 0 2) 6)
|
||||
(check-equal? (first-value-xy->pos t 1 2) 7)
|
||||
(check-equal? (first-value-xy->pos t 2 -1) #f)
|
||||
(check-equal? (first-value-xy->pos t -1 0) #f)
|
||||
(check-equal? (first-value-xy->pos t 2 2) 8)
|
||||
(check-equal? (first-value-xy->pos t 2 3) #f))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (sa "abc\n"
|
||||
"d\n"
|
||||
"ghi"))
|
||||
(check-equal? (first-value-xy->pos t 2 2) 8)
|
||||
(check-equal? (first-value-xy->pos t 2 3) #f))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (string-append "+-+\n"
|
||||
"| |\n"
|
||||
"+-+\n"))
|
||||
(normalize-unicode-ascii-art-box t 0)
|
||||
(check-equal? (send t get-text)
|
||||
(string-append
|
||||
"╔═╗\n"
|
||||
"║ ║\n"
|
||||
"╚═╝\n")))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (string-append "+=+\n"
|
||||
"| |\n"
|
||||
"+=+\n"))
|
||||
(normalize-unicode-ascii-art-box t 0)
|
||||
(check-equal? (send t get-text)
|
||||
(string-append
|
||||
"╔═╗\n"
|
||||
"║ ║\n"
|
||||
"╚═╝\n")))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (string-append "+-+-+\n"
|
||||
"| | |\n"
|
||||
"+-+-+\n"
|
||||
"| | |\n"
|
||||
"+-+-+\n"))
|
||||
(normalize-unicode-ascii-art-box t 0)
|
||||
(check-equal? (send t get-text)
|
||||
(string-append
|
||||
"╔═╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"╠═╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚═╩═╝\n")))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (string-append
|
||||
"╔═══╗\n"
|
||||
"║ - ║\n"
|
||||
"╚═══╝\n"))
|
||||
|
||||
(normalize-unicode-ascii-art-box t 0)
|
||||
(check-equal? (send t get-text)
|
||||
(string-append
|
||||
"╔═══╗\n"
|
||||
"║ - ║\n"
|
||||
"╚═══╝\n")))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (string-append
|
||||
"╔═╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"╠═╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚═╩═╝\n"))
|
||||
(send t set-position 1 1)
|
||||
(widen-unicode-ascii-art-box t 1)
|
||||
(check-equal? (send t get-start-position) 2)
|
||||
(check-equal? (send t get-text)
|
||||
(string-append
|
||||
"╔══╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"╠══╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚══╩═╝\n")))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (string-append
|
||||
"╔═╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"╠═╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚═╩═╝\n"))
|
||||
(send t set-position 8 8)
|
||||
(widen-unicode-ascii-art-box t 8)
|
||||
(check-equal? (send t get-start-position) 10)
|
||||
(check-equal? (send t get-text)
|
||||
(string-append
|
||||
"╔══╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"╠══╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚══╩═╝\n")))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (string-append
|
||||
"╔═╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"╠═╬═╣\n"
|
||||
"║ ║ ║\n"))
|
||||
(send t set-position 8 8)
|
||||
(widen-unicode-ascii-art-box t 8)
|
||||
(check-equal? (send t get-text)
|
||||
(string-append
|
||||
"╔══╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"╠══╬═╣\n"
|
||||
"║ ║ ║\n")))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (string-append
|
||||
"╔═╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"╠═╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚═╩═╝\n"))
|
||||
(send t set-position 8 8)
|
||||
(heighten-unicode-ascii-art-box t 8)
|
||||
(check-equal? (send t get-start-position) 8)
|
||||
(check-equal? (send t get-text)
|
||||
(string-append
|
||||
"╔═╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"║ ║ ║\n"
|
||||
"╠═╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚═╩═╝\n")))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (string-append
|
||||
"1 ╔═╦═╗\n"
|
||||
"2 ║ ║ ║\n"
|
||||
"3 ╠═╬═╣\n"
|
||||
"4 ║ ║ ║\n"
|
||||
"5 ╚═╩═╝\n"))
|
||||
(send t set-position 11 11)
|
||||
(heighten-unicode-ascii-art-box t 11)
|
||||
(check-equal? (send t get-text)
|
||||
(string-append
|
||||
"1 ╔═╦═╗\n"
|
||||
"2 ║ ║ ║\n"
|
||||
" ║ ║ ║\n"
|
||||
"3 ╠═╬═╣\n"
|
||||
"4 ║ ║ ║\n"
|
||||
"5 ╚═╩═╝\n")))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (string-append
|
||||
"1 ╔═╦═╗\n"
|
||||
"2 ║ ║ ║\n"
|
||||
"3 ╠═╬═╣\n"
|
||||
"4 ║ ║ ║\n"
|
||||
"5 ╚═╩═╝\n"))
|
||||
(send t set-position 19 19)
|
||||
(heighten-unicode-ascii-art-box t 19)
|
||||
(check-equal? (send t get-text)
|
||||
(string-append
|
||||
"1 ╔═╦═╗\n"
|
||||
"2 ║ ║ ║\n"
|
||||
"3 ╠═╬═╣\n"
|
||||
" ║ ║ ║\n"
|
||||
"4 ║ ║ ║\n"
|
||||
"5 ╚═╩═╝\n")))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert "║ x ║\n")
|
||||
(center-in-unicode-ascii-art-box t 1)
|
||||
(check-equal? (send t get-text)
|
||||
"║ x ║\n"))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert "║x ║\n")
|
||||
(center-in-unicode-ascii-art-box t 1)
|
||||
(check-equal? (send t get-text)
|
||||
"║ x ║\n"))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert "║ x║\n")
|
||||
(center-in-unicode-ascii-art-box t 1)
|
||||
(check-equal? (send t get-text)
|
||||
"║ x ║\n"))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert "║abcde║\n")
|
||||
(center-in-unicode-ascii-art-box t 1)
|
||||
(check-equal? (send t get-text)
|
||||
"║abcde║\n"))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert "║║\n")
|
||||
(center-in-unicode-ascii-art-box t 1)
|
||||
(check-equal? (send t get-text)
|
||||
"║║\n"))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert "║abcde \n")
|
||||
(center-in-unicode-ascii-art-box t 1)
|
||||
(check-equal? (send t get-text)
|
||||
"║abcde \n"))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert " abcde║\n")
|
||||
(center-in-unicode-ascii-art-box t 1)
|
||||
(check-equal? (send t get-text)
|
||||
" abcde║\n")))
|
||||
|
||||
#;
|
||||
(module+ main
|
||||
(require framework)
|
||||
(define f (new frame% [label ""] [width 500] [height 500]))
|
||||
(define t (new (ascii-art-enlarge-boxes-mixin racket:text%)))
|
||||
(send t set-overwrite-mode #t)
|
||||
(define ec (new editor-canvas% [parent f] [editor t]))
|
||||
(send t insert
|
||||
(string-append
|
||||
"╔═╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"║ ║ ║\n"
|
||||
"╠═╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚═╩═╝\n"))
|
||||
(send t set-position 14 14)
|
||||
(send f show #t))
|
||||
|
||||
|
|
@ -30,4 +30,4 @@
|
|||
|
||||
(define pkg-authors '(mflatt robby))
|
||||
|
||||
(define version "1.27")
|
||||
(define version "1.28")
|
||||
|
|
|
|||
|
|
@ -754,3 +754,82 @@
|
|||
(loop)))
|
||||
(define after (get-colors))
|
||||
(list before after)))))
|
||||
|
||||
(define (test-ascii-art-enlarge-boxes-mixin name before position overwrite? after)
|
||||
(test
|
||||
name
|
||||
(λ (got) (equal? got after))
|
||||
(λ ()
|
||||
(queue-sexp-to-mred
|
||||
`(let ([t (new (ascii-art-enlarge-boxes-mixin text%))])
|
||||
(define f (new frame% [label ""]))
|
||||
(define ec (new editor-canvas% [parent f] [editor t]))
|
||||
(send t insert
|
||||
,before)
|
||||
(send t set-position ,position ,position)
|
||||
,@(if overwrite? (list '(send t set-overwrite-mode #t)) '())
|
||||
(send ec on-char (new key-event% [key-code #\a]))
|
||||
(send t get-text))))))
|
||||
|
||||
|
||||
(test-ascii-art-enlarge-boxes-mixin 'ascii-art-enlarge.1
|
||||
(string-append
|
||||
"╔═╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"╠═╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚═╩═╝\n")
|
||||
7 #t
|
||||
(string-append
|
||||
"╔═╦═╗\n"
|
||||
"║a║ ║\n"
|
||||
"╠═╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚═╩═╝\n"))
|
||||
|
||||
(test-ascii-art-enlarge-boxes-mixin 'ascii-art-enlarge.2
|
||||
(string-append
|
||||
"╔═╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"╠═╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚═╩═╝\n")
|
||||
7 #t
|
||||
(string-append
|
||||
"╔══╦═╗\n"
|
||||
"║ab║ ║\n"
|
||||
"╠══╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚══╩═╝\n"))
|
||||
|
||||
(test-ascii-art-enlarge-boxes-mixin 'ascii-art-enlarge.3
|
||||
(string-append
|
||||
"╔═╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"╠═╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚═╩═╝\n")
|
||||
7 #f
|
||||
(string-append
|
||||
"╔══╦═╗\n"
|
||||
"║a ║ ║\n"
|
||||
"╠══╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚══╩═╝\n"))
|
||||
|
||||
(test-ascii-art-enlarge-boxes-mixin 'ascii-art-enlarge.4
|
||||
(string-append
|
||||
"╔═╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"║ ║ ║\n"
|
||||
"╠═╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚═╩═╝\n")
|
||||
14 #f
|
||||
(string-append
|
||||
"╔══╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"║ f║ ║\n"
|
||||
"╠══╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚══╩═╝\n"))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user