#lang racket/base
(require racket/gui/base
         racket/class
         racket/contract
         mrlib/tex-table
         "interfaces.rkt"
         "../preferences.rkt"
         "gen-standard-menus.rkt"
         "unicode-ascii-art.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))))))]
         
         [roman-letters "abgdezhji klmnxopr stufqyw"]
         [greek-letters "αβγδεζηθι κλμνξοπρςστυφχψω"]
         [Greek-letters "ΑΒΓΔΕΖΗΘΙ ΚΛΜΝΞΟΠΡ ΣΤΥΦΧΨΩ"]
         ;; ς is Σ in word-final position, so it has no 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)))]

         [heighten-unicode-ascii-art-box
          (λ (txt evt)
            (define start (send txt get-start-position))
            (when (= start (send txt get-end-position))
              (heighten-unicode-ascii-art-box txt start)))]

         [toggle-unicode-ascii-art-enlarge-mode
          (λ (txt evt)
            (when (is-a? txt text:ascii-art-enlarge-boxes<%>)
              (send txt set-ascii-art-enlarge (not (send txt get-ascii-art-enlarge)))))]
         
         [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 "heighten-unicode-ascii-art-box" heighten-unicode-ascii-art-box)
        (add "toggle-unicode-ascii-art-enlarge-mode" toggle-unicode-ascii-art-enlarge-mode)
        (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)]
                           [roman-char (string-ref roman-letters i)])
                       (unless (or (equal? greek-char #\space)
                                   (equal? roman-char #\space))
                           (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;v" "highten-unicode-ascii-art-box")
        (map "c:x;r;c" "center-in-unicode-ascii-art-box")
        (map "c:x;r;o" "toggle-unicode-ascii-art-enlarge-mode")
        
        (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/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)
  (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)))
