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

add a keystroke to widen a rectangle

Browse Source
This commit is contained in:
Robby Findler 2013-02-23 20:11:24 -06:00
parent fe515e3ac7
commit 814b9e490c
2 changed files with 163 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

198
collects/framework/private/keymap.rkt
View File

@ -4,13 +4,14 @@
racket/class
racket/match
racket/list
racket/set
racket/unit
mred/mred-sig
"../preferences.rkt"
unstable/2d/dir-chars
mrlib/tex-table
(only-in srfi/13 string-prefix? string-prefix-length)
"sig.rkt"
racket/unit)
"sig.rkt")
(provide keymap@)
(define-unit keymap@
@ -1015,12 +1016,18 @@
(send txt extend-position pos)))]
[unicode-ascii-art-boxes
[normalize-unicode-ascii-art-box
(λ (txt evt)
(define start (send txt get-start-position))
(when (= start (send txt get-end-position))
(do-unicode-ascii-art-boxes txt start)
(send txt set-position start)))])
(normalize-unicode-ascii-art-box txt start)
(send txt set-position start)))]
[widen-unicode-ascii-art-box
(λ (txt evt)
(define start (send txt get-start-position))
(when (= start (send txt get-end-position))
(widen-unicode-ascii-art-box txt start)))])
(λ (kmap)
(let* ([map (λ (key func)
@ -1041,8 +1048,8 @@
(λ (txt evt) (send txt insert c)))))
(string->list (string-append greek-letters Greek-letters)))
(add "unicode-ascii-art-boxes" unicode-ascii-art-boxes)
(add "normalize-unicode-ascii-art-box" normalize-unicode-ascii-art-box)
(add "widen-unicode-ascii-art-box" widen-unicode-ascii-art-box)
(add "shift-focus" (shift-focus values))
(add "shift-focus-backwards" (shift-focus reverse))
@ -1137,7 +1144,8 @@
(setup-mappings greek-letters #f)
(setup-mappings Greek-letters #t))
(map "c:x;r;a" "unicode-ascii-art-boxes")
(map "c:x;r;a" "normalize-unicode-ascii-art-box")
(map "c:x;r;w" "widen-unicode-ascii-art-box")
(map "~m:c:\\" "TeX compress")
(map "~c:m:\\" "TeX compress")
@ -1493,47 +1501,82 @@
(f click-pos eol start-pos click-pos)
(f click-pos eol click-pos end-pos)))))
(define (do-unicode-ascii-art-boxes t 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
(define visited (make-hash))
(send t begin-edit-sequence)
(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 (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))
(cond
[(and i-up? i-dn? i-lt? i-rt?) (set t pos "╬")]
[(and i-dn? i-lt? i-rt?) (set t pos "╦")]
[(and i-up? i-lt? i-rt?) (set t pos "╩")]
[(and i-up? i-dn? i-rt?) (set t pos "╠")]
[(and i-up? i-dn? i-lt?) (set t pos "╣")]
[(and i-up? i-lt?) (set t pos "╝")]
[(and i-up? i-rt?) (set t pos "╚")]
[(and i-dn? i-lt?) (set t pos "╗")]
[(and i-dn? i-rt?) (set t pos "╔")]
[(or i-up? i-dn?) (set t pos "║")]
[else (set t pos "═")])
(when i-up? (loop up))
(when i-dn? (loop dn))
(when i-lt? (loop lt))
(when i-rt? (loop rt))))
(send t end-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 (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))
@ -1549,7 +1592,7 @@
(member (send t get-character pos)
adjustable-chars)))
(define (set t pos s)
(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)))
@ -1614,7 +1657,7 @@
(send t insert (string-append "+-+\n"
"| |\n"
"+-+\n"))
(do-unicode-ascii-art-boxes t 0)
(normalize-unicode-ascii-art-box t 0)
(check-equal? (send t get-text)
(string-append
"╔═╗\n"
@ -1625,7 +1668,7 @@
(send t insert (string-append "+=+\n"
"| |\n"
"+=+\n"))
(do-unicode-ascii-art-boxes t 0)
(normalize-unicode-ascii-art-box t 0)
(check-equal? (send t get-text)
(string-append
"╔═╗\n"
@ -1638,7 +1681,7 @@
"+-+-+\n"
"| | |\n"
"+-+-+\n"))
(do-unicode-ascii-art-boxes t 0)
(normalize-unicode-ascii-art-box t 0)
(check-equal? (send t get-text)
(string-append
"╔═╦═╗\n"
@ -1653,11 +1696,62 @@
"║ - ║\n"
"╚═══╝\n"))
(do-unicode-ascii-art-boxes t 0)
(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")))
)

17
collects/scribblings/drracket/keybindings.scrbl
View File

@ -170,6 +170,23 @@ selected.
mixed Unicode and ASCII, it will all be converted to
the Unicode characters.
}
@keybinding["C-x r w"]{Widen the nearby ASCII art rectangles.
For example, if the insertion point is just to the left of
the middle line of this rectangle:
@tabular[(list (list @litchar{╔═╦══╗})
(list @litchar{║ ║ ║})
(list @litchar{╠═╬══╣})
(list @litchar{║ ║ ║})
(list @litchar{╚═╩══╝}))]
then the keystroke will turn it into this one:
@tabular[(list (list @litchar{╔══╦══╗})
(list @litchar{║ ║ ║})
(list @litchar{╠══╬══╣})
(list @litchar{║ ║ ║})
(list @litchar{╚══╩══╝}))]
}
]
@section{File Operations}