add a keystroke to widen a rectangle

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"
+         "sig.rkt")
-         racket/unit)
 (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)
+                (normalize-unicode-ascii-art-box txt start)
-                (send txt set-position 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])
+    (trace-unicode-ascii-art-box 
-      (unless (hash-ref visited pos #f)
+     t start-pos #f 
-        (hash-set! visited pos #t)
+     (λ (pos x y i-up? i-dn? i-lt? i-rt?)
-        (define-values (x y) (pos->xy t pos))
+       (cond
-        (define c (send t get-character pos))
+         [(and i-up? i-dn? i-lt? i-rt?) (set-c t pos "╬")]
-        (define-values (up upc) (xy->pos t x (- y 1)))
+         [(and i-dn? i-lt? i-rt?)       (set-c t pos "╦")]
-        (define-values (dn dnc) (xy->pos t x (+ y 1)))
+         [(and i-up? i-lt? i-rt?)       (set-c t pos "╩")]
-        (define-values (lt ltc) (xy->pos t (- x 1) y))
+         [(and i-up? i-dn? i-rt?)       (set-c t pos "╠")]
-        (define-values (rt rtc) (xy->pos t (+ x 1) y))
+         [(and i-up? i-dn? i-lt?)       (set-c t pos "╣")]
-        
+         [(and i-up? i-lt?)             (set-c t pos "╝")]
-        (define (interesting-dir? dir-c dir-chars) 
+         [(and i-up? i-rt?)             (set-c t pos "╚")]
-          (or (and (member dir-c adjustable-chars)
+         [(and i-dn? i-lt?)             (set-c t pos "╗")]
-                   (member c dir-chars))
+         [(and i-dn? i-rt?)             (set-c t pos "╔")]
-              (and (member dir-c double-barred-chars)
+         [(or i-up? i-dn?)              (set-c t pos "║")]
-                   (member c double-barred-chars))))
+         [else                          (set-c t pos "═")])))
-        (define i-up? (interesting-dir? upc up-chars))
+     (send t end-edit-sequence)))
-        (define i-dn? (interesting-dir? dnc dn-chars))
+
-        (define i-lt? (interesting-dir? ltc lt-chars))
+(define (trace-unicode-ascii-art-box t start-pos only-double-barred-chars? f)
-        (define i-rt? (interesting-dir? rtc rt-chars))
+  (define visited (make-hash))
-        (cond
+  (let loop ([pos start-pos])
-          [(and i-up? i-dn? i-lt? i-rt?) (set t pos "╬")]
+    (unless (hash-ref visited pos #f)
-          [(and i-dn? i-lt? i-rt?)       (set t pos "╦")]
+      (hash-set! visited pos #t)
-          [(and i-up? i-lt? i-rt?)       (set t pos "╩")]
+      (define-values (x y) (pos->xy t pos))
-          [(and i-up? i-dn? i-rt?)       (set t pos "╠")]
+      (define c (send t get-character pos))
-          [(and i-up? i-dn? i-lt?)       (set t pos "╣")]
+      (define-values (up upc) (xy->pos t x (- y 1)))
-          [(and i-up? i-lt?)             (set t pos "╝")]
+      (define-values (dn dnc) (xy->pos t x (+ y 1)))
-          [(and i-up? i-rt?)             (set t pos "╚")]
+      (define-values (lt ltc) (xy->pos t (- x 1) y))
-          [(and i-dn? i-lt?)             (set t pos "╗")]
+      (define-values (rt rtc) (xy->pos t (+ x 1) y))
-          [(and i-dn? i-rt?)             (set t pos "╔")]
+      (define (interesting-dir? dir-c dir-chars) 
-          [(or i-up? i-dn?)              (set t pos "║")]
+        (or (and (not only-double-barred-chars?)
-          [else                          (set t pos "═")])
+                 (member dir-c adjustable-chars)
-        (when i-up? (loop up))
+                 (member c dir-chars))
-        (when i-dn? (loop dn))
+            (and (member dir-c double-barred-chars)
-        (when i-lt? (loop lt))
+                 (member c double-barred-chars))))
-        (when i-rt? (loop rt))))
+      (define i-up? (interesting-dir? upc up-chars))
-    (send t end-edit-sequence)))
+      (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")))
+  
   )

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}