Support loading and saving in GUI layout editor.
This commit is contained in:
parent
d4c91e2cbe
commit
8951819d18
2 changed files with 182 additions and 58 deletions
211
gui.rkt
211
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
|
||||
|
|
29
keycodes.scm
29
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)
|
||||
|
|
Loading…
Reference in a new issue