1391 lines
58 KiB
Racket
1391 lines
58 KiB
Racket
#lang racket/base
|
|
(require racket/gui/base
|
|
racket/class
|
|
racket/contract
|
|
mrlib/tex-table
|
|
"interfaces.rkt"
|
|
"../preferences.rkt"
|
|
"gen-standard-menus.rkt"
|
|
(only-in srfi/13 string-prefix? string-prefix-length)
|
|
2d/dir-chars
|
|
racket/list)
|
|
|
|
(provide has-control-regexp
|
|
keymap:region-click
|
|
keymap:make-meta-prefix-list
|
|
keymap:send-map-function-meta
|
|
keymap:setup-global
|
|
keymap:add-to-right-button-menu
|
|
keymap:add-to-right-button-menu/before)
|
|
|
|
(define keymap:add-to-right-button-menu (make-parameter void))
|
|
(define keymap:add-to-right-button-menu/before (make-parameter void))
|
|
|
|
(define has-control-regexp #rx"(?:^|:)c:")
|
|
|
|
(define (keymap:make-meta-prefix-list key [mask-control? #f])
|
|
;; Note: key canonicalization will remove "~g" when redundant
|
|
(list (if mask-control?
|
|
(string-append "~g:m:" key)
|
|
(string-append "~c:~g:m:" key))
|
|
(string-append "ESC;" key)))
|
|
|
|
(define (keymap:send-map-function-meta keymap key func [mask-control? #f]
|
|
#:alt-as-meta-keymap [alt-as-meta-keymap #f])
|
|
(for ([key (in-list (keymap:make-meta-prefix-list key mask-control?))])
|
|
(send keymap map-function key func))
|
|
(when alt-as-meta-keymap
|
|
(unless (send alt-as-meta-keymap is-function-added? func)
|
|
(error 'keymap:send-map-function-meta
|
|
"expected to find ~s mapped in alt-as-meta-keymap"
|
|
func))
|
|
(send alt-as-meta-keymap map-function (string-append "?:a:" key) func)))
|
|
|
|
(define keymap:setup-global
|
|
; Define some useful keyboard functions
|
|
(let* ([ring-bell
|
|
(λ (edit event)
|
|
(bell))]
|
|
|
|
[mouse-popup-menu
|
|
(λ (edit event)
|
|
(when (send event button-up?)
|
|
(let ([a (send edit get-admin)])
|
|
(when a
|
|
(let ([m (make-object popup-menu%)])
|
|
|
|
((keymap:add-to-right-button-menu/before) m edit event)
|
|
|
|
(append-editor-operation-menu-items
|
|
m #:popup-position
|
|
(list edit
|
|
(send edit find-position (send event get-x) (send event get-y))))
|
|
(for-each
|
|
(λ (i)
|
|
(when (is-a? i selectable-menu-item<%>)
|
|
(send i set-shortcut #f)))
|
|
(send m get-items))
|
|
|
|
((keymap:add-to-right-button-menu) m edit event)
|
|
|
|
(let-values ([(x y) (send edit
|
|
dc-location-to-editor-location
|
|
(send event get-x)
|
|
(send event get-y))])
|
|
(send a popup-menu m (+ x 1) (+ y 1))))))))]
|
|
|
|
[toggle-anchor
|
|
(λ (edit event)
|
|
(send edit set-anchor
|
|
(not (send edit get-anchor))))]
|
|
[center-view-on-line
|
|
(λ (edit event)
|
|
(let ([new-mid-line (send edit position-line
|
|
(send edit get-start-position))]
|
|
[bt (box 0)]
|
|
[bb (box 0)])
|
|
(send edit get-visible-line-range bt bb #f)
|
|
(let* ([half (sub1 (quotient (- (unbox bb) (unbox bt)) 2))]
|
|
[last-pos (send edit position-line (send edit last-position))]
|
|
[top-pos (send edit line-start-position
|
|
(max (min (- new-mid-line half) last-pos) 0))]
|
|
[bottom-pos (send edit line-start-position
|
|
(max 0
|
|
(min (+ new-mid-line half)
|
|
last-pos)))])
|
|
(send edit scroll-to-position
|
|
top-pos
|
|
#f
|
|
bottom-pos)))
|
|
#t)]
|
|
|
|
|
|
[collapse-variable-space
|
|
;; As per emacs: collapse tabs & spaces around the point,
|
|
;; perhaps leaving a single space.
|
|
;; drscheme bonus: if at end-of-line, collapse into the next line.
|
|
(λ (leave-one? edit event)
|
|
(letrec ([last-pos (send edit last-position)]
|
|
[sel-start (send edit get-start-position)]
|
|
[sel-end (send edit get-end-position)]
|
|
[collapsible? (λ (c) (and (char-whitespace? c)
|
|
(not (char=? #\newline c))))]
|
|
[find-noncollapsible
|
|
; Return index of next non-collapsible char,
|
|
; starting at pos in direction dir.
|
|
; NB returns -1 or last-pos, if examining
|
|
; initial/final whitespace
|
|
; (or, when initial pos is outside of [0,last-pos).)
|
|
(λ (pos dir)
|
|
(let loop ([pos pos])
|
|
(cond [(< pos 0) -1]
|
|
[(>= pos last-pos) last-pos]
|
|
[(collapsible? (send edit get-character pos))
|
|
(loop (+ pos dir))]
|
|
[else pos])))])
|
|
(when (= sel-start sel-end) ; Only when no selection:
|
|
(let* ([start (add1 (find-noncollapsible (sub1 sel-start) -1))]
|
|
[end-heeding-eol (find-noncollapsible sel-start +1)]
|
|
; This is the end of the range, were we to always heed newlines.
|
|
|
|
; Special case: if we're sitting at EOL,
|
|
; and we're not affecting much else,
|
|
; then delete that EOL and collapse spaces
|
|
; at the start of next line, too:
|
|
[end (if (and (<= (- end-heeding-eol start)
|
|
(if leave-one? 1 0))
|
|
(char=? #\newline (send edit get-character end-heeding-eol))
|
|
; If you wish to avoid deleting an newline at EOF, do so here.
|
|
)
|
|
(find-noncollapsible (add1 end-heeding-eol) +1)
|
|
end-heeding-eol)]
|
|
[making-no-difference?
|
|
; Don't introduce edits into undo-chain, if no effect.
|
|
(if leave-one?
|
|
(and (= (- end start) 1)
|
|
(char=? #\space (send edit get-character start)))
|
|
(= (- end start) 0))])
|
|
(unless making-no-difference?
|
|
(send edit begin-edit-sequence)
|
|
(send edit set-position end) ; Even after delete, caret will be at "end".
|
|
(send edit delete start end)
|
|
(when leave-one? (send edit insert #\space start))
|
|
(send edit end-edit-sequence))))))]
|
|
|
|
[collapse-space
|
|
(λ (edit event)
|
|
(collapse-variable-space #t edit event))]
|
|
|
|
[remove-space
|
|
(λ (edit event)
|
|
(collapse-variable-space #f edit event))]
|
|
|
|
[collapse-newline
|
|
(λ (edit event)
|
|
(define (find-nonwhite pos d offset)
|
|
(define done (if (= offset -1) 0 (send edit last-position)))
|
|
(let/ec escape
|
|
(let loop ([pos pos])
|
|
(cond
|
|
[(= pos done) (escape pos)]
|
|
[else
|
|
(define c (send edit get-character (+ pos offset)))
|
|
(cond
|
|
[(char=? #\newline c)
|
|
(loop (+ pos d))
|
|
(escape pos)]
|
|
[(char-whitespace? c)
|
|
(loop (+ pos d))]
|
|
[else pos])]))))
|
|
(define sel-start (send edit get-start-position))
|
|
(define sel-end (send edit get-end-position))
|
|
(when (= sel-start sel-end)
|
|
(define pos-para (send edit position-paragraph sel-start #f))
|
|
(define pos-para-start (send edit paragraph-start-position pos-para))
|
|
(define pos-para-end (send edit paragraph-end-position pos-para))
|
|
|
|
(define whitepara?
|
|
(let loop ([pos pos-para-start])
|
|
(if (>= pos pos-para-end)
|
|
#t
|
|
(and (char-whitespace? (send edit get-character pos))
|
|
(loop (add1 pos))))))
|
|
|
|
(define start (find-nonwhite pos-para-start -1 -1))
|
|
(define end (find-nonwhite pos-para-end 1 0))
|
|
|
|
(define start-para (send edit position-paragraph start #f))
|
|
(define start-para-start (send edit paragraph-start-position start-para))
|
|
(define end-para (send edit position-paragraph end #f))
|
|
(define end-para-start (send edit paragraph-start-position (add1 end-para)))
|
|
(cond
|
|
[(and whitepara?
|
|
(= start-para pos-para)
|
|
(= end-para pos-para))
|
|
; Special case: just delete this para
|
|
(send edit delete pos-para-start (add1 pos-para-end))]
|
|
[(and whitepara? (< start-para pos-para))
|
|
; Can delete before & after
|
|
(send* edit
|
|
(begin-edit-sequence)
|
|
(delete (add1 pos-para-end) end-para-start)
|
|
(delete start-para-start pos-para-start)
|
|
(end-edit-sequence))]
|
|
[else
|
|
; Only delete after
|
|
(send edit delete (add1 pos-para-end) end-para-start)])))]
|
|
|
|
[open-line
|
|
(λ (edit event)
|
|
(let ([sel-start (send edit get-start-position)]
|
|
[sel-end (send edit get-end-position)])
|
|
(when (= sel-start sel-end)
|
|
(send* edit
|
|
(insert #\newline)
|
|
(set-position sel-start)))))]
|
|
|
|
[transpose-chars
|
|
(λ (edit event)
|
|
(let ([sel-start (send edit get-start-position)]
|
|
[sel-end (send edit get-end-position)])
|
|
(when (and (= sel-start sel-end)
|
|
(not (= sel-start 0)))
|
|
|
|
(let ([sel-start
|
|
(if (= sel-start
|
|
(send edit line-end-position
|
|
(send edit position-line sel-start)))
|
|
(sub1 sel-start)
|
|
sel-start)])
|
|
(let ([s (send edit get-text
|
|
sel-start (add1 sel-start))])
|
|
(send* edit
|
|
(begin-edit-sequence)
|
|
(delete sel-start (add1 sel-start))
|
|
(insert s (- sel-start 1))
|
|
(set-position (add1 sel-start))
|
|
(end-edit-sequence)))))))]
|
|
|
|
[transpose-words
|
|
(λ (edit event)
|
|
(let ([sel-start (send edit get-start-position)]
|
|
[sel-end (send edit get-end-position)])
|
|
(when (= sel-start sel-end)
|
|
(let ([word-1-start (box sel-start)])
|
|
(send edit find-wordbreak word-1-start #f 'caret)
|
|
(let ([word-1-end (box (unbox word-1-start))])
|
|
(send edit find-wordbreak #f word-1-end 'caret)
|
|
(let ([word-2-end (box (unbox word-1-end))])
|
|
(send edit find-wordbreak #f word-2-end 'caret)
|
|
(let ([word-2-start (box (unbox word-2-end))])
|
|
(send edit find-wordbreak word-2-start #f 'caret)
|
|
(let ([text-1 (send edit get-text
|
|
(unbox word-1-start)
|
|
(unbox word-1-end))]
|
|
[text-2 (send edit get-text
|
|
(unbox word-2-start)
|
|
(unbox word-2-end))])
|
|
(send* edit
|
|
(begin-edit-sequence)
|
|
(insert text-1
|
|
(unbox word-2-start)
|
|
(unbox word-2-end))
|
|
(insert text-2
|
|
(unbox word-1-start)
|
|
(unbox word-1-end))
|
|
(set-position (unbox word-2-end))
|
|
(end-edit-sequence))))))))))]
|
|
|
|
[capitalize-it
|
|
(λ (edit char-case1 char-case2)
|
|
(let ([sel-start (send edit get-start-position)]
|
|
[sel-end (send edit get-end-position)]
|
|
[real-end (send edit last-position)])
|
|
(when (= sel-start sel-end)
|
|
(let ([word-end (let ([b (box sel-start)])
|
|
(send edit find-wordbreak #f b 'caret)
|
|
(min real-end (unbox b)))])
|
|
(send edit begin-edit-sequence)
|
|
(let loop ([pos sel-start]
|
|
[char-case char-case1])
|
|
(when (< pos word-end)
|
|
(let ([c (send edit get-character pos)])
|
|
(cond
|
|
[(char-alphabetic? c)
|
|
(send edit insert
|
|
(list->string
|
|
(list (char-case c)))
|
|
pos (add1 pos))
|
|
(loop (add1 pos) char-case2)]
|
|
[else
|
|
(loop (add1 pos) char-case)]))))
|
|
(send* edit
|
|
(end-edit-sequence)
|
|
(set-position word-end))))))]
|
|
|
|
[capitalize-word
|
|
(λ (edit event)
|
|
(capitalize-it edit char-upcase char-downcase))]
|
|
[upcase-word
|
|
(λ (edit event)
|
|
(capitalize-it edit char-upcase char-upcase))]
|
|
[downcase-word
|
|
(λ (edit event)
|
|
(capitalize-it edit char-downcase char-downcase))]
|
|
|
|
[kill-word
|
|
(λ (edit event)
|
|
(let ([sel-start (send edit get-start-position)]
|
|
[sel-end (send edit get-end-position)])
|
|
(let ([end-box (box sel-end)])
|
|
(send edit find-wordbreak #f end-box 'caret)
|
|
(send edit kill 0 sel-start (unbox end-box)))))]
|
|
|
|
[backward-kill-word
|
|
(λ (edit event)
|
|
(let ([sel-start (send edit get-start-position)]
|
|
[sel-end (send edit get-end-position)])
|
|
(let ([start-box (box sel-start)])
|
|
(send edit find-wordbreak start-box #f 'caret)
|
|
(send edit kill 0 (unbox start-box) sel-end))))]
|
|
[copy-click-region
|
|
(λ (edit event)
|
|
(region-click/internal edit event
|
|
(λ (click eol start end)
|
|
(send edit flash-on start end)
|
|
(send edit copy #f 0 start end))))]
|
|
[cut-click-region
|
|
(λ (edit event)
|
|
(region-click/internal edit event
|
|
(λ (click eol start end)
|
|
(send edit cut #f 0 start end))))]
|
|
[paste-click-region
|
|
(λ (edit event)
|
|
(region-click/internal edit event
|
|
(λ (click eol start end)
|
|
(send edit set-position click)
|
|
(send edit paste-x-selection 0 click))))]
|
|
|
|
[mouse-copy-clipboard
|
|
(λ (edit event)
|
|
(send edit copy #f (send event get-time-stamp)))]
|
|
|
|
[mouse-copy-clipboard/disable-anchor
|
|
(λ (edit event)
|
|
(send edit set-anchor #f)
|
|
(send edit copy #f (send event get-time-stamp)))]
|
|
|
|
[mouse-paste-clipboard
|
|
(λ (edit event)
|
|
(send edit paste (send event get-time-stamp)))]
|
|
|
|
[mouse-cut-clipboard
|
|
(λ (edit event)
|
|
(send edit cut #f (send event get-time-stamp)))]
|
|
|
|
[select-click-word
|
|
(λ (edit event)
|
|
(keymap:region-click edit event
|
|
(λ (click eol)
|
|
(let ([start-box (box click)]
|
|
[end-box (box click)])
|
|
(send edit find-wordbreak
|
|
start-box
|
|
end-box
|
|
'selection)
|
|
(send edit set-position
|
|
(unbox start-box)
|
|
(unbox end-box))))))]
|
|
[select-click-line
|
|
(λ (edit event)
|
|
(keymap:region-click edit event
|
|
(λ (click eol)
|
|
(let* ([line (send edit position-line
|
|
click eol)]
|
|
[start (send edit line-start-position
|
|
line #f)]
|
|
[end (send edit line-end-position
|
|
line #f)])
|
|
(send edit set-position start end)))))]
|
|
[repeater
|
|
(λ (n edit)
|
|
(let* ([km (send edit get-keymap)]
|
|
[done
|
|
(λ ()
|
|
(send km set-break-sequence-callback void)
|
|
(send km remove-grab-key-function))])
|
|
(send km set-grab-key-function
|
|
(λ (name local-km edit event)
|
|
(if name
|
|
(begin
|
|
(done)
|
|
(dynamic-wind
|
|
(λ ()
|
|
(send edit begin-edit-sequence))
|
|
(λ ()
|
|
(let loop ([n n])
|
|
(unless (zero? n)
|
|
(send local-km call-function name edit event)
|
|
(loop (sub1 n)))))
|
|
(λ ()
|
|
(send edit end-edit-sequence))))
|
|
(let ([k (send event get-key-code)])
|
|
(if (and (char? k) (char<=? #\0 k #\9))
|
|
(set! n (+ (* n 10) (- (char->integer k)
|
|
(char->integer #\0))))
|
|
(begin
|
|
(done)
|
|
(dynamic-wind
|
|
(λ ()
|
|
(send edit begin-edit-sequence))
|
|
(λ ()
|
|
(let loop ([n n])
|
|
(unless (zero? n)
|
|
(send edit on-char event)
|
|
(loop (sub1 n)))))
|
|
(λ ()
|
|
(send edit end-edit-sequence)))))))
|
|
#t))
|
|
(send km set-break-sequence-callback done)
|
|
#t))]
|
|
[make-make-repeater
|
|
(λ (n)
|
|
(λ (edit event)
|
|
(repeater n edit)))]
|
|
[current-macro '()]
|
|
[building-macro #f] [build-macro-km #f] [build-protect? #f]
|
|
[show/hide-keyboard-macro-icon
|
|
(λ (edit on?)
|
|
(when (is-a? edit editor:basic<%>)
|
|
(let ([frame (send edit get-top-level-window)])
|
|
(when (is-a? frame frame:text-info<%>)
|
|
(send frame set-macro-recording on?)
|
|
(send frame update-shown)))))]
|
|
|
|
[do-macro
|
|
(λ (edit event)
|
|
; If c:x;e during record, copy the old macro
|
|
(when building-macro
|
|
(set! building-macro (append (reverse current-macro)
|
|
(cdr building-macro))))
|
|
(let ([bm building-macro]
|
|
[km (send edit get-keymap)])
|
|
(dynamic-wind
|
|
(λ ()
|
|
(set! building-macro #f)
|
|
(send edit begin-edit-sequence))
|
|
(λ ()
|
|
(let/ec escape
|
|
(for-each
|
|
(λ (f)
|
|
(let ([name (car f)]
|
|
[event (cdr f)])
|
|
(if name
|
|
(unless (send km call-function name edit event #t)
|
|
(escape #t))
|
|
(send edit on-char event))))
|
|
current-macro)))
|
|
(λ ()
|
|
(send edit end-edit-sequence)
|
|
(set! building-macro bm))))
|
|
#t)]
|
|
[start-macro
|
|
(λ (edit event)
|
|
(if building-macro
|
|
(send build-macro-km break-sequence)
|
|
(letrec ([km (send edit get-keymap)]
|
|
[done
|
|
(λ ()
|
|
(if build-protect?
|
|
(send km set-break-sequence-callback done)
|
|
(begin
|
|
(set! building-macro #f)
|
|
(show/hide-keyboard-macro-icon edit #f)
|
|
(send km set-break-sequence-callback void)
|
|
(send km remove-grab-key-function))))])
|
|
(set! building-macro '())
|
|
(show/hide-keyboard-macro-icon edit #t)
|
|
(set! build-macro-km km)
|
|
(send km set-grab-key-function
|
|
(λ (name local-km edit event)
|
|
(dynamic-wind
|
|
(λ ()
|
|
(set! build-protect? #t))
|
|
(λ ()
|
|
(if name
|
|
(send local-km call-function name edit event)
|
|
(send edit on-default-char event)))
|
|
(λ ()
|
|
(set! build-protect? #f)))
|
|
(when building-macro
|
|
(set! building-macro
|
|
(cons (cons name event)
|
|
building-macro)))
|
|
#t))
|
|
(send km set-break-sequence-callback done)))
|
|
#t)]
|
|
[end-macro
|
|
(λ (edit event)
|
|
(when building-macro
|
|
(set! current-macro (reverse building-macro))
|
|
(set! build-protect? #f)
|
|
(send build-macro-km break-sequence))
|
|
#t)]
|
|
[delete-key
|
|
(λ (edit event)
|
|
(let ([kmap (send edit get-keymap)])
|
|
(send kmap call-function
|
|
(if (preferences:get 'framework:delete-forward?)
|
|
"delete-next-character"
|
|
"delete-previous-character")
|
|
edit event #t)))]
|
|
|
|
[toggle-overwrite
|
|
(λ (edit event)
|
|
(when (preferences:get 'framework:overwrite-mode-keybindings)
|
|
(send edit set-overwrite-mode
|
|
(not (send edit get-overwrite-mode)))))]
|
|
|
|
[down-into-embedded-editor
|
|
(λ (text event)
|
|
(let ([start (send text get-start-position)]
|
|
[end (send text get-end-position)])
|
|
(when (= start end)
|
|
(let* ([bx (box 0)]
|
|
[after-snip (send text find-snip start 'after-or-none bx)])
|
|
(cond
|
|
[(and (= (unbox bx) start)
|
|
after-snip
|
|
(is-a? after-snip editor-snip%))
|
|
(let ([embedded-editor (send after-snip get-editor)])
|
|
(when (is-a? embedded-editor text%)
|
|
(send embedded-editor set-position 0))
|
|
(send embedded-editor set-caret-owner #f 'global))]
|
|
[else
|
|
(let ([before-snip (send text find-snip start 'before-or-none bx)])
|
|
(when (and (= (+ (unbox bx) 1) start)
|
|
before-snip
|
|
(is-a? before-snip editor-snip%))
|
|
(let ([embedded-editor (send before-snip get-editor)])
|
|
(when (is-a? embedded-editor text%)
|
|
(send embedded-editor set-position
|
|
(send embedded-editor last-position)))
|
|
(send embedded-editor set-caret-owner #f 'global))))]))))
|
|
#t)]
|
|
|
|
[forward-to-next-embedded-editor
|
|
(λ (text event)
|
|
(let ([start-pos (send text get-start-position)]
|
|
[end-pos (send text get-end-position)])
|
|
(when (= start-pos end-pos)
|
|
(let loop ([snip (send text find-snip start-pos 'after-or-none)])
|
|
(cond
|
|
[(not snip) (void)]
|
|
[(is-a? snip editor-snip%)
|
|
(send text set-position (send text get-snip-position snip))]
|
|
[else (loop (send snip next))]))))
|
|
#t)]
|
|
|
|
[back-to-prev-embedded-editor
|
|
(λ (text event)
|
|
(let ([start-pos (send text get-start-position)]
|
|
[end-pos (send text get-end-position)])
|
|
(when (= start-pos end-pos)
|
|
(let loop ([snip (send text find-snip start-pos 'before-or-none)])
|
|
(cond
|
|
[(not snip) (void)]
|
|
[(is-a? snip editor-snip%)
|
|
(send text set-position (+ (send text get-snip-position snip) 1))]
|
|
[else (loop (send snip previous))]))))
|
|
#t)]
|
|
|
|
[up-out-of-embedded-editor
|
|
(λ (text event)
|
|
(let ([start (send text get-start-position)]
|
|
[end (send text get-end-position)])
|
|
(when (= start end)
|
|
(let ([editor-admin (send text get-admin)])
|
|
(when (is-a? editor-admin editor-snip-editor-admin<%>)
|
|
(let* ([snip (send editor-admin get-snip)]
|
|
[snip-admin (send snip get-admin)])
|
|
(when snip-admin
|
|
(let ([editor (send snip-admin get-editor)])
|
|
(when (is-a? editor text%)
|
|
(let ([new-pos (send editor get-snip-position snip)])
|
|
(send editor set-position new-pos new-pos))
|
|
(send editor set-caret-owner #f 'display)))))))))
|
|
#t)]
|
|
|
|
[make-read-only
|
|
(λ (text event)
|
|
(send text lock #t)
|
|
#t)]
|
|
|
|
[newline
|
|
(λ (text event)
|
|
(send text insert "\n")
|
|
#t)]
|
|
|
|
[shift-focus
|
|
(λ (adjust)
|
|
(λ (text event)
|
|
(when (is-a? text editor:basic<%>)
|
|
(let ([frame (send text get-top-level-window)]
|
|
[found-one? #f])
|
|
(let/ec k
|
|
(let ([go
|
|
(λ ()
|
|
(let loop ([obj frame])
|
|
(cond
|
|
[(and found-one?
|
|
(is-a? obj editor-canvas%)
|
|
(is-a? (send obj get-editor) editor:keymap<%>))
|
|
(send obj focus)
|
|
(k (void))]
|
|
[(and (is-a? obj window<%>) (send obj has-focus?))
|
|
(set! found-one? #t)]
|
|
[(is-a? obj area-container<%>)
|
|
(for-each loop (adjust (send obj get-children)))])))])
|
|
(go)
|
|
;;; when we get here, we either didn't find the focus anywhere,
|
|
;;; or the last editor-canvas had the focus. either way,
|
|
;;; the next thing should get the focus
|
|
(set! found-one? #t)
|
|
(go)))))))]
|
|
|
|
[TeX-compress
|
|
(let* ([biggest (apply max (map (λ (x) (string-length (car x))) tex-shortcut-table))])
|
|
(define (meet s t)
|
|
(substring s 0 (string-prefix-length s t 0)))
|
|
(λ (text event)
|
|
(define pos (send text get-start-position))
|
|
(when (= pos (send text get-end-position))
|
|
(define slash (send text find-string "\\" 'backward pos (max 0 (- pos biggest 1))))
|
|
(when slash
|
|
(define entered (send text get-text slash pos))
|
|
(define completions
|
|
(filter (λ (shortcut) (string-prefix? entered (first shortcut)))
|
|
tex-shortcut-table))
|
|
(unless (empty? completions)
|
|
(define-values (replacement partial?)
|
|
(let ([complete-match
|
|
(findf (λ (shortcut) (equal? entered (first shortcut)))
|
|
completions)])
|
|
(if complete-match
|
|
(values (second complete-match) #f)
|
|
(if (= 1 (length completions))
|
|
(values (second (first completions)) #f)
|
|
(let ([tex-names (map first completions)])
|
|
(values (foldl meet (first tex-names) (rest tex-names))
|
|
#t))))))
|
|
(send text begin-edit-sequence)
|
|
(send text delete (if partial? slash (- slash 1)) pos)
|
|
(send text insert replacement)
|
|
(send text end-edit-sequence))))))]
|
|
|
|
[greek-letters "αβγδεζηθι κλμνξοπρςστυφχψω"]
|
|
[Greek-letters "ΑΒΓΔΕΖΗΘΙ ΚΛΜΝΞΟΠΡ ΣΤΥΦΧΨΩ"]
|
|
;; don't have a capital ς, just comes out as \u03A2 (or junk)
|
|
|
|
|
|
[find-beginning-of-line
|
|
(λ (txt)
|
|
(define pos-to-start-with
|
|
(cond
|
|
[(= (send txt get-extend-start-position)
|
|
(send txt get-start-position))
|
|
(send txt get-end-position)]
|
|
[else
|
|
(send txt get-start-position)]))
|
|
|
|
(cond
|
|
[(is-a? txt text:basic<%>)
|
|
(send txt get-start-of-line pos-to-start-with)]
|
|
[(is-a? txt text%)
|
|
(send txt line-start-position (send txt position-line pos-to-start-with))]
|
|
[else #f]))]
|
|
[beginning-of-line
|
|
(λ (txt event)
|
|
(define pos (find-beginning-of-line txt))
|
|
(when pos
|
|
(send txt set-position pos pos)))]
|
|
[select-to-beginning-of-line
|
|
(λ (txt event)
|
|
(define pos (find-beginning-of-line txt))
|
|
(when pos
|
|
(send txt extend-position pos)))]
|
|
|
|
|
|
[normalize-unicode-ascii-art-box
|
|
(λ (txt evt)
|
|
(define start (send txt get-start-position))
|
|
(when (= start (send txt get-end-position))
|
|
(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)))]
|
|
|
|
[center-in-unicode-ascii-art-box
|
|
(λ (txt evt)
|
|
(define start (send txt get-start-position))
|
|
(when (= start (send txt get-end-position))
|
|
(center-in-unicode-ascii-art-box txt start)))])
|
|
|
|
(λ (kmap #:alt-as-meta-keymap [alt-as-meta-keymap #f])
|
|
(let* ([map (λ (key func)
|
|
(send kmap map-function key func))]
|
|
[map-meta (λ (key func)
|
|
(keymap:send-map-function-meta kmap key func
|
|
(regexp-match? has-control-regexp key)
|
|
#:alt-as-meta-keymap alt-as-meta-keymap))]
|
|
[add (λ (name func)
|
|
(send kmap add-function name func))]
|
|
[add-m (λ (name func)
|
|
(send kmap add-function name func)
|
|
(when alt-as-meta-keymap
|
|
(send alt-as-meta-keymap add-function name func)))])
|
|
|
|
; Map names to keyboard functions
|
|
|
|
(for-each
|
|
(λ (c)
|
|
(unless (equal? c #\space)
|
|
(add (format "insert ~a" c)
|
|
(λ (txt evt) (send txt insert c)))))
|
|
(string->list (string-append greek-letters Greek-letters)))
|
|
|
|
(add "normalize-unicode-ascii-art-box" normalize-unicode-ascii-art-box)
|
|
(add "widen-unicode-ascii-art-box" widen-unicode-ascii-art-box)
|
|
(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))
|
|
|
|
(add "TeX compress" TeX-compress)
|
|
(add "newline" newline)
|
|
(add-m "down-into-embedded-editor" down-into-embedded-editor)
|
|
(add-m "up-out-of-embedded-editor" up-out-of-embedded-editor)
|
|
(add-m "forward-to-next-embedded-editor" forward-to-next-embedded-editor)
|
|
(add-m "back-to-prev-embedded-editor" back-to-prev-embedded-editor)
|
|
|
|
(add-m "toggle-overwrite (when enabled in prefs)" toggle-overwrite)
|
|
|
|
(add "exit" (λ (edit event)
|
|
(let ([frame (send edit get-frame)])
|
|
(if (and frame
|
|
(is-a? frame frame:standard-menus<%>))
|
|
(send frame file-menu:quit)
|
|
(bell)))))
|
|
|
|
(add "ring-bell" ring-bell)
|
|
|
|
|
|
(add "toggle-anchor" toggle-anchor)
|
|
(add "center-view-on-line" center-view-on-line)
|
|
(add-m "collapse-space" collapse-space)
|
|
(add "remove-space" remove-space)
|
|
(add "collapse-newline" collapse-newline)
|
|
(add "open-line" open-line)
|
|
(add "transpose-chars" transpose-chars)
|
|
(add-m "transpose-words" transpose-words)
|
|
(add-m "capitalize-word" capitalize-word)
|
|
(add-m "upcase-word" upcase-word)
|
|
(add-m "downcase-word" downcase-word)
|
|
(add-m "kill-word" kill-word)
|
|
(add-m "backward-kill-word" backward-kill-word)
|
|
|
|
(let loop ([n 9])
|
|
(unless (negative? n)
|
|
(let ([s (number->string n)])
|
|
(add-m (string-append "command-repeat-" s)
|
|
(make-make-repeater n))
|
|
(loop (sub1 n)))))
|
|
|
|
(add "keyboard-macro-run-saved" do-macro)
|
|
(add "keyboard-macro-start-record" start-macro)
|
|
(add "keyboard-macro-end-record" end-macro)
|
|
|
|
(add-m "copy-clipboard" mouse-copy-clipboard)
|
|
(add-m "copy-clipboard/disable-anchor" mouse-copy-clipboard/disable-anchor)
|
|
(add-m "cut-clipboard" mouse-cut-clipboard)
|
|
(add-m "paste-clipboard" mouse-paste-clipboard)
|
|
(add-m "copy-click-region" copy-click-region)
|
|
(add-m "cut-click-region" cut-click-region)
|
|
(add-m "paste-click-region" paste-click-region)
|
|
(add-m "select-click-word" select-click-word)
|
|
(add-m "select-click-line" select-click-line)
|
|
|
|
(add "delete-key" delete-key)
|
|
|
|
(add "mouse-popup-menu" mouse-popup-menu)
|
|
|
|
(add "make-read-only" make-read-only)
|
|
|
|
(add "beginning-of-line" beginning-of-line)
|
|
(add "select-to-beginning-of-line" select-to-beginning-of-line)
|
|
|
|
; Map keys to functions
|
|
|
|
(let ([setup-mappings
|
|
(λ (greek-chars shift?)
|
|
(let loop ([i 0])
|
|
(when (< i (string-length greek-chars))
|
|
(let ([greek-char (string-ref greek-chars i)])
|
|
(unless (equal? greek-char #\space)
|
|
(let ([roman-char
|
|
(integer->char
|
|
(+ (char->integer #\a) i))])
|
|
(map (format "a:g;~a~a"
|
|
(if shift? "s:" "")
|
|
roman-char)
|
|
(format "insert ~a" greek-char))
|
|
(map (format "~~c:m:x;c:g;~a~a"
|
|
(if shift? "s:" "")
|
|
roman-char)
|
|
(format "insert ~a" greek-char))
|
|
(map (format "c:x;c:g;~a~a"
|
|
(if shift? "s:" "")
|
|
roman-char)
|
|
(format "insert ~a" greek-char)))))
|
|
(loop (+ i 1)))))])
|
|
(setup-mappings greek-letters #f)
|
|
(setup-mappings Greek-letters #t))
|
|
|
|
(map "c:x;r;a" "normalize-unicode-ascii-art-box")
|
|
(map "c:x;r;w" "widen-unicode-ascii-art-box")
|
|
(map "c:x;r;c" "center-in-unicode-ascii-art-box")
|
|
|
|
(map "~m:c:\\" "TeX compress")
|
|
(map "~c:m:\\" "TeX compress")
|
|
(map "c:x;t" "TeX compress")
|
|
|
|
(map "c:j" "newline")
|
|
|
|
(map-meta "c:down" "down-into-embedded-editor")
|
|
(map "a:c:down" "down-into-embedded-editor")
|
|
(map-meta "c:up" "up-out-of-embedded-editor")
|
|
(map "a:c:up" "up-out-of-embedded-editor")
|
|
(map-meta "c:right" "forward-to-next-embedded-editor")
|
|
(map "a:c:right" "forward-to-next-embedded-editor")
|
|
(map-meta "c:left" "back-to-prev-embedded-editor")
|
|
(map "a:c:left" "back-to-prev-embedded-editor")
|
|
|
|
(map "c:c;c:g" "ring-bell")
|
|
|
|
(map "c:p" "previous-line")
|
|
(map "up" "previous-line")
|
|
(map "s:c:p" "select-up")
|
|
(map "s:up" "select-up")
|
|
|
|
(map "c:n" "next-line")
|
|
(map "down" "next-line")
|
|
(map "s:c:n" "select-down")
|
|
(map "s:down" "select-down")
|
|
|
|
(map "c:e" "end-of-line")
|
|
(map "d:right" "end-of-line")
|
|
(map "end" "end-of-line")
|
|
(map "s:end" "select-to-end-of-line")
|
|
(map "s:c:e" "select-to-end-of-line")
|
|
(map "s:d:right" "select-to-end-of-line")
|
|
|
|
(map "c:a" "beginning-of-line")
|
|
(map "d:left" "beginning-of-line")
|
|
(map "home" "beginning-of-line")
|
|
(map "s:home" "select-to-beginning-of-line")
|
|
(map "s:c:a" "select-to-beginning-of-line")
|
|
(map "s:d:left" "select-to-beginning-of-line")
|
|
|
|
(map "c:f" "forward-character")
|
|
(map "right" "forward-character")
|
|
(map "s:c:f" "forward-select")
|
|
(map "s:right" "forward-select")
|
|
|
|
(map "c:b" "backward-character")
|
|
(map "left" "backward-character")
|
|
(map "s:c:b" "backward-select")
|
|
(map "s:left" "backward-select")
|
|
|
|
(map-meta "f" "forward-word")
|
|
(map "c:right" "forward-word")
|
|
(map-meta "s:f" "forward-select-word")
|
|
(map "c:s:right" "forward-select-word")
|
|
|
|
(map-meta "b" "backward-word")
|
|
|
|
(map "c:left" "backward-word")
|
|
(map-meta "s:b" "backward-select-word")
|
|
(map "c:s:left" "backward-select-word")
|
|
|
|
(map-meta "<" "beginning-of-file")
|
|
(map "d:up" "beginning-of-file")
|
|
(map "c:home" "beginning-of-file")
|
|
(map "s:c:home" "select-to-beginning-of-file")
|
|
(map "s:d:up" "select-to-beginning-of-file")
|
|
|
|
(map-meta ">" "end-of-file")
|
|
(map "d:down" "end-of-file")
|
|
(map "c:end" "end-of-file")
|
|
(map "s:c:end" "select-to-end-of-file")
|
|
(map "s:d:down" "select-to-end-of-file")
|
|
|
|
(map "c:v" "next-page")
|
|
(map "pagedown" "next-page")
|
|
(map "c:down" "next-page")
|
|
(map "s:c:v" "select-page-down")
|
|
(map "s:pagedown" "select-page-down")
|
|
(map "s:c:down" "select-page-down")
|
|
|
|
(map-meta "v" "previous-page")
|
|
(map "pageup" "previous-page")
|
|
(map "c:up" "previous-page")
|
|
(map-meta "s:v" "select-page-up")
|
|
(map "s:pageup" "select-page-up")
|
|
(map "s:c:up" "select-page-up")
|
|
|
|
(map "c:h" "delete-previous-character")
|
|
(map "c:d" "delete-next-character")
|
|
(map "del" "delete-key")
|
|
|
|
(map-meta "d" "kill-word")
|
|
(map-meta "del" "kill-word")
|
|
(map-meta "backspace" "backward-kill-word")
|
|
(map-meta "c" "capitalize-word")
|
|
(map-meta "u" "upcase-word")
|
|
(map-meta "l" "downcase-word")
|
|
|
|
(map "c:l" "center-view-on-line")
|
|
|
|
(map "c:k" "delete-to-end-of-line")
|
|
(map "c:y" "paste-clipboard")
|
|
(map-meta "y" "paste-next")
|
|
(map "a:v" "paste-clipboard")
|
|
(map "d:v" "paste-clipboard")
|
|
(map "c:_" "undo")
|
|
(map "c:/" "undo")
|
|
(map (format "~a" (integer->char 31)) "undo") ; for Windows - strange
|
|
(map "c:+" "redo")
|
|
(map "a:z" "undo")
|
|
(map "d:z" "undo")
|
|
(map "c:x;u" "undo")
|
|
(map "c:w" "cut-clipboard")
|
|
(map "a:x" "cut-clipboard")
|
|
(map "d:x" "cut-clipboard")
|
|
(map-meta "w" "copy-clipboard/disable-anchor")
|
|
(map "a:c" "copy-clipboard")
|
|
(map "d:c" "copy-clipboard")
|
|
|
|
(map "s:delete" "cut-clipboard")
|
|
(map "c:insert" "copy-clipboard")
|
|
(map "s:insert" "paste-clipboard")
|
|
|
|
(map-meta "space" "collapse-space")
|
|
(when (eq? (system-type) 'macosx)
|
|
(map "a:space" "collapse-space"))
|
|
;(map-meta "\\" "remove-space") ; Conflicts with european keyboards.
|
|
(map "c:x;c:o" "collapse-newline")
|
|
(map "c:o" "open-line")
|
|
(map "c:t" "transpose-chars")
|
|
(map-meta "t" "transpose-words")
|
|
|
|
(map "c:space" "toggle-anchor")
|
|
|
|
(map "insert" "toggle-overwrite (when enabled in prefs)")
|
|
(map-meta "o" "toggle-overwrite (when enabled in prefs)")
|
|
|
|
(map "c:u" "command-repeat-0")
|
|
(let loop ([n 9])
|
|
(unless (negative? n)
|
|
(let ([s (number->string n)])
|
|
(map-meta s (string-append "command-repeat-" s))
|
|
(loop (sub1 n)))))
|
|
|
|
(map "c:x;e" "keyboard-macro-run-saved")
|
|
(map "c:x;(" "keyboard-macro-start-record")
|
|
(map "c:x;)" "keyboard-macro-end-record")
|
|
|
|
(map "leftbuttontriple" "select-click-line")
|
|
(map "leftbuttondouble" "select-click-word")
|
|
|
|
;; the "roller ball" mice map clicking the ball to button 2.
|
|
(unless (eq? (system-type) 'windows)
|
|
(map "middlebutton" "paste-click-region"))
|
|
|
|
(map ":rightbuttonseq" "mouse-popup-menu")
|
|
|
|
(map "c:c;c:r" "make-read-only")
|
|
|
|
(map "c:x;o" "shift-focus")
|
|
(map "c:x;p" "shift-focus-backwards")
|
|
(map "c:f6" "shift-focus")
|
|
(map "a:tab" "shift-focus")
|
|
(map "a:s:tab" "shift-focus-backwards")))))
|
|
|
|
(define (keymap:region-click text event f)
|
|
(region-click/internal text event
|
|
(λ (click-pos eol start end) (f click-pos eol))))
|
|
|
|
(define (region-click/internal text event f)
|
|
(when (and (is-a? event mouse-event%)
|
|
(send event button-down?)
|
|
(is-a? text text%))
|
|
(define x-box (box (send event get-x)))
|
|
(define y-box (box (send event get-y)))
|
|
(define eol-box (box #f))
|
|
(send text global-to-local x-box y-box)
|
|
(define click-pos (send text find-position
|
|
(unbox x-box)
|
|
(unbox y-box)
|
|
eol-box))
|
|
(define start-pos (send text get-start-position))
|
|
(define end-pos (send text get-end-position))
|
|
(define eol (unbox eol-box))
|
|
(if (< start-pos click-pos)
|
|
(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%))
|
|
(list/c string? exact-nonnegative-integer? exact-nonnegative-integer?))
|
|
(define k (new keymap%))
|
|
(define t (new text%))
|
|
(send t set-keymap k)
|
|
(keymap:setup-global k)
|
|
(send t insert (list-ref before 0))
|
|
(send t set-position (list-ref before 1) (list-ref before 2))
|
|
(for ([key-evt (in-list key-evts)])
|
|
(send t on-local-char key-evt))
|
|
(list (send t get-text)
|
|
(send t get-start-position)
|
|
(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"))
|
|
|
|
(check-equal? (run-some-keystrokes '("abc" 0 0)
|
|
(list (new key-event% [key-code 'escape])
|
|
(new key-event% [key-code #\c])))
|
|
'("Abc" 3 3))
|
|
(check-equal? (run-some-keystrokes '(" abc " 0 0)
|
|
(list (new key-event% [key-code 'escape])
|
|
(new key-event% [key-code #\c])))
|
|
'(" Abc " 5 5)))
|