Nulo/menelaus
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Make the gui use mutable data structures.

Browse source 
Making changes to nested vectors inside structs in Racket is really nasty
without lenses.
This commit is contained in:
Phil Hagelberg 2020-03-22 20:27:33 -07:00
parent 7703babd99
commit e12f33abdb
2 changed files with 66 additions and 67 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
Makefile
View file

@ -8,9 +8,9 @@ USB=/dev/ttyACM0
build: $(LAYOUT).hex
upload: $(LAYOUT).hex
echo "Put your device in bootloader mode now..."
echo "Classic Atreus: connect GND pin to RST pin twice in under a secod."
echo "Keyboardio Atreus: press the button on the underside of the board."
@echo "Put your device in bootloader mode now..."
@echo "Classic Atreus: connect GND pin to RST pin twice in under a secod."
@echo "Keyboardio Atreus: press the button on the underside of the board."
while [ ! -r $(USB) ]; do sleep 1; done; \
avrdude -p $(MCU) -c avr109 -U flash:w:$(LAYOUT).hex -P $(USB)

127
gui.rkt
View file

@ -2,17 +2,14 @@
(require racket/match)
(define (vector-set v i o) ; =(
(vector->immutable-vector
(for/vector ([j (in-range (vector-length v))])
(if (= i j)
o
(vector-ref v j)))))
;; TODO:
;; * enter any arbitrary key by name
;; * save/load layouts
;; * emit microscheme
(define call-c-func void) ; for microscheme compatibility
(include "keycodes.scm")
(include "layout.scm")
(define width 260)
(define height 132)
@ -21,6 +18,8 @@
(define rows 4)
(define angle (degrees->radians 10))
;; Drawing
(define alps-switch-width 15.34)
(define alps-switch-height 12.49)
(define cherry-switch-width 13.62)
@ -32,10 +31,7 @@
(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 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)]
@ -48,7 +44,7 @@
(define switch-x-offset -6.5)
(define switch-y-offset (- bottom hand-height -3.5))
(struct state (layers layer row col mode scale) #:transparent)
(struct state (layers layer row col mode scale) #:transparent #:mutable)
(define (selected? st row col)
(and (= row (state-row st)) (= col (state-col st))))
@ -59,32 +55,41 @@
(define font (make-font #:size 8 #:face "Inconsolata"))
(define small-font (make-font #:size 4 #:face "Inconsolata"))
(define ((draw state-box) _ canvas)
(let ((st (unbox state-box)))
(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))
(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))))))))
(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))
(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)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Output
(define (write-layout filename)
(when (file-exists? filename) (delete-file filename))
(call-with-output-file filename
(λ (op)
(for ([f forms])
(pretty-print f op 1)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Updating
(define (move st dx dy)
(struct-copy state st
(row (modulo (+ dy (state-row st)) rows))
(col (modulo (+ dx (state-col st)) cols))))
(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)
(case keycode
@ -92,12 +97,13 @@
[(left) (move st -1 0)]
[(up) (move st 0 -1)]
[(down) (move st 0 1)]
[(#\-) (struct-copy state st (scale (* (state-scale st) 0.9)))]
[(#\=) (struct-copy state st (scale (* (state-scale st) 1.1)))]
['escape (struct-copy state st (mode 'quit))]
[(#\return) (struct-copy state st (mode 'set))]
[(#\-) (set-state-scale! st (* (state-scale st) 0.9))]
[(#\=) (set-state-scale! st (* (state-scale st) 1.1))]
[(escape) (set-state-mode! st 'quit)]
[(#\return) (set-state-mode! st 'set)]
[(#\tab) (printf "~s~n" st) st]
[(release) st]
[(#\space) (write-layout "out.scm")]
[(release) #f]
[else (printf "~s~n" keycode) st]))
(define (key-for keycode)
@ -115,38 +121,31 @@
[(#\return) "enter"]
[else (format "~a" keycode)]))
(define (update-layout st keycode)
(vector-set (state-layers st) (state-layer st)
(vector-set (vector-ref (state-layers st)
(state-layer st))
(selected st) (key-for keycode))))
(define (handle-set st keycode)
(if (equal? 'release keycode)
st
(struct-copy state st
(layers (update-layout st keycode))
(mode 'select))))
(unless (equal? 'release keycode)
(set-state-mode! st 'select)
(vector-set! (vector-ref (state-layers st) (state-layer st))
(selected st) (key-for keycode))))
(define (handle-key canvas state-box keycode)
(let ((st (unbox state-box)))
(case (state-mode st)
['select (set-box! state-box (handle-select st keycode))]
['set (set-box! state-box (handle-set st keycode))])
(send canvas refresh)))
(define (handle-key canvas st keycode)
(case (state-mode st)
['select (handle-select st keycode)]
['set (handle-set st keycode)])
(send canvas refresh))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Main
(define (main)
(let ([frame (new frame% [label "Menelaus"])]
[state-box (box (state (vector (make-vector (* rows cols) #f))
0 0 0 'select 2.5))])
(let ([frame (new frame% [label "Menelaus Keyboard Layout Editor"])]
[st (state (vector (make-vector (* rows cols) #f)) 0 0 0 'select 2.5)])
(new (class canvas%
(define/override (on-char event)
(handle-key this state-box (send event get-key-code))
(when (equal? 'quit (state-mode (unbox state-box)))
(handle-key this st (send event get-key-code))
(when (equal? 'quit (state-mode st))
(send frame show #f)))
(super-new))
[parent frame]
[paint-callback (draw state-box)])
[paint-callback (draw st)])
(send frame show #t)))
(module+ main