~technomancy/menelaus

e12f33abdbf817ff4431cc680f8d8293d63fdff6 — Phil Hagelberg 8 months ago 7703bab
Make the gui use mutable data structures.

Making changes to nested vectors inside structs in Racket is really nasty
without lenses.
2 files changed, 67 insertions(+), 68 deletions(-)

M Makefile
M gui.rkt
M Makefile => Makefile +3 -3
@@ 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)


M gui.rkt => gui.rkt +64 -65
@@ 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))))

(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)))
  (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 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