~technomancy/menelaus

8951819d189267359078cec19d783c23174301c3 — Phil Hagelberg 7 months ago d4c91e2
Support loading and saving in GUI layout editor.
2 files changed, 184 insertions(+), 60 deletions(-)

M gui.rkt
M keycodes.scm
M gui.rkt => gui.rkt +169 -46
@@ 3,9 3,7 @@
(require racket/match)

;; TODO:
;; * enter any arbitrary key by name
;; * save/load layouts
;; * keycode translation
;; * add/remove layers

(include "keycodes.scm")



@@ 16,16 14,12 @@
(define rows 4)
(define angle (degrees->radians 10))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Drawing
(struct state (layers layer row col mode scale) #:transparent #:mutable)

(define alps-switch-width 15.34)
(define alps-switch-height 12.49)
(define cherry-switch-width 13.62)
(define cherry-switch-height 13.72)
(define cherry? false)
(define switch-height (if cherry? cherry-switch-height alps-switch-height))
(define switch-width (if cherry? cherry-switch-width alps-switch-width))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Drawing

(define switch-width 15.34)
(define switch-height 12.49)
(define switch-spacing 19.0)
(define bottom 95) ; outer bottom



@@ 42,8 36,6 @@
(define switch-x-offset -6.5)
(define switch-y-offset (- bottom hand-height -3.5))

(struct state (layers layer row col mode scale) #:transparent #:mutable)

(define (selected? st row col)
  (and (= row (state-row st)) (= col (state-col st))))



@@ 53,16 45,22 @@
(define font (make-font #:size 8 #:face "Inconsolata"))
(define small-font (make-font #:size 4 #:face "Inconsolata"))

(define ((draw st) _ canvas)
(define (layer-text st)
  (format "Layer ~s/~s" (state-layer st)
          (sub1 (vector-length (state-layers st)))))

(define (draw st canvas)
  (send canvas set-scale (state-scale st) (state-scale st))
  (for/list ([col (in-range cols)]
             #:when true
             [row (if (or (= 5 col) (= 6 col)) '(2 3) (in-range rows))])
    (send canvas set-pen (if (selected? st row col)
                             "red" "black") 1 'solid)
    (if (and (equal? (state-mode st) 'set) (selected? st row col))
        (send canvas set-brush "black" 'solid)
        (send canvas set-brush "black" 'transparent))
    (cond [(and (equal? (state-mode st) 'set) (selected? st row col))
           (send canvas set-brush "black" 'solid)]
          [(and (equal? (state-mode st) 'set-shifted) (selected? st row col))
           (send canvas set-brush "black" 'cross-hatch)]
          ['else (send canvas set-brush "black" 'transparent)])
    (let* ((xy (draw-switch canvas row col))
           (key (vector-ref (vector-ref (state-layers st)
                                        (state-layer st))


@@ 74,11 72,32 @@
              (+ (first xy) (if special? 2 4))
              (+ (second xy) (if special? 2 0))))))
  (send canvas set-font small-font)
  (send canvas draw-text "Select a key with the arrows." 10 100)
  (send canvas draw-text "Set its keycode with space." 10 108)
  (send canvas draw-text "Press enter to write the layout to disk." 10 116))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Output
  (send canvas draw-text (layer-text st) 180 108)
  (for ([msg '("Arrows: select key" "Space: set keycode"
                                    "Shift: set shifted keycode"
                                    "Tab: set special keycode"
                                    "[ and ]: change layer"
                                    "Enter: save layout"
                                    "L: load layout")]
        [i (in-range 5)])
    (send canvas draw-text msg 15 (+ 108 (* i 8)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Scheme Output

(define some-shifts
  #hash((#\1 . #\!) (#\2 . #\@) (#\3 . #\#) (#\4 . #\$) (#\5 . #\%)
        (#\6 . #\^) (#\7 . #\&) (#\8 . #\*) (#\9 . #\() (#\0 . #\))
        (#\= . #\+) (#\' . #\") (#\, . #\<) (#\. . #\>) (#\/ . #\?)
        (#\; . #\:) (#\[ . #\{) (#\] . #\}) (#\\ . #\|) (#\- . #\_)
        (#\` . #\~)))

;; Add in shifted ASCII letters programmatically
(define shifts (for/fold ([all some-shifts])
                         ([n (in-range 97 123)])
                 (hash-set all (integer->char n) (integer->char (- n 32)))))

(define (shift keycode) (hash-ref shifts keycode keycode))
(define (unshift keycode) (for/first ([(k v) shifts] #:when (eq? v keycode)) k))

(define prelude
  '((include "keycodes.scm")


@@ 98,31 117,107 @@
  '((set! current-layer (vector-ref layers 0))
    (include "menelaus.scm")))

;; These are the exceptions to the symbol->keycode translation rules:
(define special-keycodes #hash(("ctrl" . mod-ctrl)
                               ("alt" . mod-alt)
                               ("shft" . mod-shift)
                               ("super" . mod-super)
                               (";" . key-semicolon)
                               ("`" . key-backtick)
                               ("," . key-comma)
                               ("'" . key-quote)
                               ("\\" . key-backslash)
                               ("[" . key-left-bracket)
                               ("]" . key-right-bracket)
                               ("fn" . fn)))

;; L1, L2, L3, etc are treated as layer-switching functions.
(define (layer-switching-keycode key)
  (and (string? key) (regexp-match #rx"^L[0-9]+$" key)
       `(set-layer ,(string->number (substring key 1)))))

;; Convert a shifted character into a (sft key-N) form microscheme expects.
(define (shifted-keycode key convert)
  (and (unshift key)
       (let* ([char (first (string->list (symbol->string key)))]
              [new-char (unshift char)]
              [sym (string->symbol (list->string (list new-char)))])
         `(sft ,(convert sym)))))

;; Convert keys from our label to microscheme's representation.
(define (racket-key->ms-key key)
  (let ((sym (string->symbol (format "key-~a" key))))
    (with-handlers ([exn? (λ (_) 0)])
      ;; Try to see if the key is defined in keycodes.scm
      ;; TODO: find a way to do this without eval
      (and (eval sym) sym))))
    (or (hash-ref special-keycodes key #f)
        (layer-switching-keycode key)
        (shifted-keycode key racket-key->ms-key)
        (with-handlers ([exn? (λ (_) 0)])
          ;; Try to see if the key is defined in keycodes.scm
          ;; TODO: find a way to do this without eval
          (and (eval sym) sym)))))

(define (fix-row row mid)
  (append (take row 5) (list mid) (take (drop row 7) 5)))

;; In the GUI, we have 12 columns, the middle two of which are half-columns;
;; in Microscheme we have 11 columns; the 4 middle keys are all in the middle
;; column. This function converts a 4x12 grid into an 11-column vector.
(define (fix-columns layer)
  (let ([layer (vector->list layer)])
    (append (fix-row layer (list-ref layer 29))
            (fix-row (drop layer 12) (list-ref layer 30))
            (fix-row (drop layer 24) (list-ref layer 41))
            (fix-row (drop layer 36) (list-ref layer 42)))))

(define (layers-form layers)
  `((set! layers (vector ,@(for/list ([layer layers])
                             `(vector ,@(for/list ([key layer])
                             `(vector ,@(for/list ([key (fix-columns layer)])
                                          (racket-key->ms-key key))))))))

(define (write-layout filename layers)
(define (write-layout filename st)
  (when (file-exists? filename) (delete-file filename))
  (call-with-output-file filename
    (λ (op)
      (for ([f (append prelude (layers-form layers) postlude)])
        (pretty-print f op 1)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Updating
    (λ (out)
      (display ";; " out)
      (write st out)
      (display "\n;; This file was generated by the Menelaus GUI.\n\n" out)
      (for ([f (append prelude (layers-form (state-layers st)) postlude)])
        (pretty-print f out 1)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Save/load

(define (load-state reset)
  (let ([filename (get-file "Load layout:")])
    (when filename
      (call-with-input-file filename
        (lambda (in)
          (read-bytes 2 in) ; skip initial comment
          ;; reading it back in gives us a vector starting with 'struct:state
          ;; instead of an actual state struct for some reason, so we convert
          ;; to a list, drop the car, and call the state constructor.
          (reset (apply state (cdr (vector->list (read in))))))))))

(define (save-state st)
  (let ([filename (put-file "Save to:")])
    (when filename
      (write-layout filename st)
      (let ([dia (new dialog% [label "Layout saved"])])
        (new message%
             [label (format "Layout saved to ~a."
                            (path->string filename))]
             [parent dia])
        (new button%
             [label "OK"]
             [parent dia]
             [callback (lambda _ (send dia show #f))])
        (send dia show #t)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Handlers

(define (key-for keycode)
  (case keycode
    [(control) "ctrl"]
    ;; TODO: alt and super for some reason don't show at all??
    ;; for now they're handled as specials
    [(escape) "esc"]
    [(shift) "shft"]
    [(insert) "ins"]


@@ 130,22 225,44 @@
    [(prior) "pgup"]
    [(#\rubout) "del"]
    [(#\space) "spc"]
    [(#\tab) "tab"]
    [(#\backspace) "bksp"]
    [(#\return) "enter"]
    [(#f) #f]
    [else (format "~a" keycode)]))

(define (handle-set st keycode)
(define (handle-set st keycode shifted?)
  (unless (equal? 'release keycode)
    (set-state-mode! st 'select)
    (vector-set! (vector-ref (state-layers st) (state-layer st))
                 (selected st) (key-for keycode))))
                 (selected st) (if shifted?
                                   (key-for (shift keycode))
                                   (key-for keycode)))))

;; Some keys can't be represented with a single keypress, such as fn or L2.
(define (set-special! st)
  (let* ([dia (new dialog% [label "Select special key"])]
         [choice (new choice%
                      [label "Special key:"]
                      [parent dia]
                      [choices '["fn" "L2" "super" "alt"]])])
    (new button%
         [label "OK"]
         [parent dia]
         [callback (lambda _
                     (handle-set st (send choice get-string-selection) false)
                     (send dia show #f))])
    (send dia show #t)))

(define (move st dx dy)
  (set-state-row! st (modulo (+ dy (state-row st)) rows))
  (set-state-col! st (modulo (+ dx (state-col st)) cols)))

(define (handle-select st keycode)
(define (change-layer st dir)
  (set-state-layer! st (modulo (+ dir (state-layer st))
                               (vector-length (state-layers st)))))

(define (handle-select st keycode reset)
  (case keycode
    [(right) (move st 1 0)]
    [(left) (move st -1 0)]


@@ 153,20 270,24 @@
    [(down) (move st 0 1)]
    [(#\-) (set-state-scale! st (* (state-scale st) 0.9))]
    [(#\=) (set-state-scale! st (* (state-scale st) 1.1))]
    [(#\backspace) (handle-set st #f)]
    [(#\[) (change-layer st 1)]
    [(#\]) (change-layer st 1)]
    [(#\backspace) (handle-set st false)]
    [(escape) (set-state-mode! st 'quit)]
    [(#\space) (set-state-mode! st 'set)]
    [(#\tab) (printf "~s~n" st) st]
    [(#\return) (let ([filename (put-file "Save to:")])
                  (when filename
                    (write-layout filename (state-layers st))))]
    [(shift) (set-state-mode! st 'set-shifted)]
    [(#\`) (printf "~a~n" st)]
    [(#\tab) (set-special! st)]
    [(#\return) (save-state st)]
    [(#\l) (load-state reset)]
    [(release) #f]
    [else (printf "~s~n" keycode) st]))

(define (handle-key canvas st keycode)
(define (handle-key canvas st keycode reset)
  (case (state-mode st)
    ['select (handle-select st keycode)]
    ['set (handle-set st keycode)])
    ['select (handle-select st keycode reset)]
    ['set (handle-set st keycode false)]
    ['set-shifted (handle-set st keycode true)])
  (send canvas refresh))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Main


@@ 178,12 299,14 @@
                           (make-vector (* rows cols) #f)) 0 0 0 'select 2.5)])
    (new (class canvas%
           (define/override (on-char event)
             (handle-key this st (send event get-key-code))
             (handle-key this st (send event get-key-code)
                         (lambda (new-st) (set! st new-st) (send this refresh)))
             (when (equal? 'quit (state-mode st))
               (send frame show #f)))
           (super-new))
         [parent frame]
         [paint-callback (draw st)])
         [paint-callback (lambda (_ canvas)
                           (draw st canvas))])
    (send frame show #t)))

(module+ main

M keycodes.scm => keycodes.scm +15 -14
@@ 43,34 43,35 @@
(define key-left 80)
(define key-right 79)

(define key-page-up 75)
(define key-page-down 78)
;; Longer keys get shorthand aliases:
(define key-page-up 75) (define key-pgup 75)
(define key-page-down 78) (define key-pgdn 78)
(define key-home 74)
(define key-end 77)
(define key-insert 73)
(define key-delete 76)
(define key-insert 73) (define key-ins 73)
(define key-delete 76) (define key-del 76)

(define key-semicolon 51)
(define key-comma 54)
(define key-period 55)
(define key-slash 56)
(define key-dash 45)
(define key-quote 52)
(define key-equal 46)
(define key-backslash 49)
(define key-backtick 53)
(define key-left-bracket 47)
(define key-right-bracket 48)

(define key-space 44)
(define key-backspace 42)
(define key-period 55) (define key-. 55)
(define key-slash 56) (define key-/ 56)
(define key-dash 45) (define key-- 45)
(define key-equal 46) (define key-= 46)

(define key-space 44) (define key-spc 44)
(define key-backspace 42) (define key-bksp 42)
(define key-esc 41)
(define key-tab 43)
(define key-enter 40)

(define key-backslash 49)
(define key-backtick 53)

(define key-vol-up 128)
(define key-vol-down 129)
(define key-vol-down 129) (define key-vol-dn 129)

(define key-f1 58)
(define key-f2 59)