18404570dd
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
451 lines
16 KiB
Racket
451 lines
16 KiB
Racket
#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))
|
|
|