diff --git a/collects/framework/private/keymap.rkt b/collects/framework/private/keymap.rkt index afe5c38410..1e2921a802 100644 --- a/collects/framework/private/keymap.rkt +++ b/collects/framework/private/keymap.rkt @@ -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"))) + ) diff --git a/collects/scribblings/drracket/keybindings.scrbl b/collects/scribblings/drracket/keybindings.scrbl index 7e894f3c8f..ced44296b8 100644 --- a/collects/scribblings/drracket/keybindings.scrbl +++ b/collects/scribblings/drracket/keybindings.scrbl @@ -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}