Support loading and saving in GUI layout editor.

gui.rkt

@@ -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))
 
+(struct state (layers layer row col mode scale) #:transparent #:mutable)
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Drawing
 
-(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))
-
+(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))
+  (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)))))
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Output
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 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))))
+    (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))))
+          (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)))))
+    (λ (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)))))
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Updating
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 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

keycodes.scm

@@ -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)