319 lines
12 KiB
Racket
319 lines
12 KiB
Racket
#lang racket/gui
|
|
|
|
(require racket/match)
|
|
|
|
;; TODO:
|
|
;; * add/remove layers
|
|
|
|
(include "keycodes.scm")
|
|
|
|
(define width 260)
|
|
(define height 132)
|
|
|
|
(define cols 12)
|
|
(define rows 4)
|
|
(define angle (degrees->radians 10))
|
|
|
|
(struct state (layers layer row col mode scale) #:transparent #:mutable)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Drawing
|
|
|
|
(define switch-width 15.34)
|
|
(define switch-height 12.49)
|
|
(define switch-spacing 19.0)
|
|
(define bottom 95) ; outer bottom
|
|
|
|
(define column-offsets `(8 5 0 6 11 8 8 11 6 0 5 8))
|
|
|
|
(define (draw-switch canvas row col)
|
|
(let* ([x (* (+ 1 col) switch-spacing)]
|
|
[y (+ (list-ref column-offsets col) (* switch-spacing (+ row 1)))])
|
|
(send canvas draw-rectangle x y switch-width switch-height)
|
|
(list x y)))
|
|
|
|
(define hand-height (+ (* switch-spacing rows) (- switch-spacing switch-height)
|
|
(list-ref column-offsets 0)))
|
|
(define switch-x-offset -6.5)
|
|
(define switch-y-offset (- bottom hand-height -3.5))
|
|
|
|
(define (selected? st row col)
|
|
(and (= row (state-row st)) (= col (state-col st))))
|
|
|
|
(define (selected st)
|
|
(+ (state-col st) (* (state-row st) cols)))
|
|
|
|
(define font (make-font #:size 8 #:face "Inconsolata"))
|
|
(define small-font (make-font #:size 4 #:face "Inconsolata"))
|
|
|
|
(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)
|
|
(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))
|
|
(+ col (* row cols))))
|
|
(special? (and key (< 1 (string-length key)))))
|
|
(when key
|
|
(send canvas set-font (if special? small-font font))
|
|
(send canvas draw-text key
|
|
(+ (first xy) (if special? 2 4))
|
|
(+ (second xy) (if special? 2 0))))))
|
|
(send canvas set-font small-font)
|
|
(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")
|
|
(define rows (list 0 1 2 3))
|
|
(define columns (list 0 1 2 3 4 5 6 7 8 9 10))
|
|
(define row-pins (vector 3 2 1 0))
|
|
(define column-pins (vector 6 5 9 8 7 4 10 19 18 12 11))
|
|
(define layers #f)
|
|
(define current-layer #f)
|
|
(define momentary-layer #f)
|
|
|
|
(define (fn on?) (set! momentary-layer (and on? (vector-ref layers 1))))
|
|
(define (set-layer n)
|
|
(lambda (_) (set! current-layer (vector-ref layers n))))))
|
|
|
|
(define postlude
|
|
'((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)))))
|
|
|
|
(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 (fix-columns layer)])
|
|
(racket-key->ms-key key))))))))
|
|
|
|
(define (write-layout filename st)
|
|
(when (file-exists? filename) (delete-file filename))
|
|
(call-with-output-file filename
|
|
(λ (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"]
|
|
[(next) "pgdn"]
|
|
[(prior) "pgup"]
|
|
[(#\rubout) "del"]
|
|
[(#\space) "spc"]
|
|
[(#\tab) "tab"]
|
|
[(#\backspace) "bksp"]
|
|
[(#\return) "enter"]
|
|
[(#f) #f]
|
|
[else (format "~a" 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) (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 (non-existent-key? row col)
|
|
(and (< row 2) (or (= col 5) (= col 6))))
|
|
|
|
(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))
|
|
(when (non-existent-key? (state-row st) (state-col st))
|
|
(move st dx dy)))
|
|
|
|
(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)]
|
|
[(up) (move st 0 -1)]
|
|
[(down) (move st 0 1)]
|
|
[(#\-) (set-state-scale! st (* (state-scale st) 0.9))]
|
|
[(#\=) (set-state-scale! st (* (state-scale st) 1.1))]
|
|
[(#\[) (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)]
|
|
[(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 reset)
|
|
(case (state-mode st)
|
|
['select (handle-select st keycode reset)]
|
|
['set (handle-set st keycode false)]
|
|
['set-shifted (handle-set st keycode true)])
|
|
(send canvas refresh))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Main
|
|
|
|
(define (main)
|
|
(let ([frame (new frame% [label "Menelaus Keyboard Layout Editor"])]
|
|
[st (state (vector (make-vector (* rows cols) #f)
|
|
(make-vector (* rows cols) #f)
|
|
(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)
|
|
(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 (lambda (_ canvas)
|
|
(draw st canvas))])
|
|
(send frame show #t)))
|
|
|
|
(module+ main
|
|
(main))
|