diff --git a/gui.rkt b/gui.rkt index d3de877..606333a 100644 --- a/gui.rkt +++ b/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)))) - (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))))) + (λ (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 diff --git a/keycodes.scm b/keycodes.scm index 835d541..63547f9 100644 --- a/keycodes.scm +++ b/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)