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)

89
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,8 +55,7 @@
(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)))
(define ((draw st) _ canvas)
(send canvas set-scale (state-scale st) (state-scale st))
(for/list ([col (in-range cols)]
#:when true
@ -79,12 +74,22 @@
(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))))))))
(+ (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))
(define (handle-set st keycode)
(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-set st keycode)
(if (equal? 'release keycode)
st
(struct-copy state st
(layers (update-layout st keycode))
(mode 'select))))
(define (handle-key canvas state-box keycode)
(let ((st (unbox state-box)))
(define (handle-key canvas st keycode)
(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)))
['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