1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
|
(module input
(create-input-state
input-state-update
input-pressed?
input-held?
input-released?
input-any-pressed?)
(import scheme
(chicken base)
(chicken module)
(chicken syntax)
(only srfi-1 any filter-map fold)
simple-logger
(prefix sdl2 sdl2:))
(import-for-syntax (chicken base) (only srfi-1 filter-map fold))
;; Single source of truth: (define-inputs (NAME (key K) ... (button B) ... (dpad D) ...) ...)
;; Expands to: input-state record, input-config record, create-input-state, create-input-config,
;; input-state-roll, input-state-with-button (no globals).
(define-syntax define-inputs
(er-macro-transformer
(lambda (form rename compare?)
(define (sym . parts)
(string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((string? x) x) (else ""))) parts))))
(define clauses (cdr form))
(define names (map car clauses))
;; Collect (tag binding) entries; outside macro Chicken doesn't load syntax helpers at expand time.
(define (collect-entries clauses tag entry-form)
(apply append
(map (lambda (clause)
(let ((name (car clause)))
(filter-map (lambda (b)
(and (pair? b) (eq? (car b) tag) (entry-form (cadr b) name)))
(cdr clause))))
clauses)))
(define key-entries
(collect-entries clauses 'key (lambda (k name) (list 'cons (list 'quote k) (list 'quote name)))))
(define gamepad-entries
(collect-entries clauses 'button (lambda (b name) (list 'cons b (list 'quote name)))))
(define (hat-values name)
(define c (assoc name clauses))
(reverse (fold (lambda (b acc) (if (and (pair? b) (eq? (car b) 'dpad)) (cons (cadr b) acc) acc)) '() (if c (cdr c) '()))))
(define hat-entries
(map (lambda (n) (list 'cons (list 'quote n) (cons 'list (hat-values n)))) names))
(define record-prev-fields (map (lambda (n) (list (sym "prev-" n))) names))
(define (make-falses n) (if (zero? n) '() (cons #f (make-falses (- n 1)))))
(define falses (make-falses (* 2 (length names))))
(define button-proc-entries
(map (lambda (n)
(list 'cons (list 'quote n)
(list 'list
(list 'lambda '(s) (list (sym "input-state-" n) 's))
(list 'lambda '(s) (list (sym "input-state-prev-" n) 's)))))
names))
;; Roll: new state with prev = old current; current and prev slots both read from current
(define roll-fields (map (lambda (n) (list (sym "input-state-" n) 'state)) names))
(define (with-current n)
(list 'if (list 'eq? 'button (list 'quote n)) 'value (list (sym "input-state-" n) 'state)))
(define with-prev (map (lambda (n) (list (sym "input-state-prev-" n) 'state)) names))
(define config-slot (list (sym "input-state-config") 'state))
`(begin
(define-record input-config
all-buttons key-to-button gamepad-to-button hat-button-values button-procs)
(define-record input-state
config ,@names ,@(apply append record-prev-fields))
(define (create-input-config)
(make-input-config (quote ,names)
(list ,@key-entries)
(list ,@gamepad-entries)
(list ,@hat-entries)
(list ,@button-proc-entries)))
(define (create-input-state)
"Return a new input state with all buttons released. Config is stored inside."
(make-input-state (create-input-config) ,@falses))
(define (input-state-roll state)
(make-input-state ,config-slot ,@roll-fields ,@roll-fields))
(define (input-state-with-button state button value)
(make-input-state ,config-slot ,@(map with-current names) ,@with-prev))
))))
(define-inputs
(up (key w) (key up) (dpad 1) (dpad 9) (dpad 5))
(down (key s) (dpad 4) (dpad 6) (dpad 10))
(left (key a) (dpad 8) (dpad 9) (dpad 6))
(right (key d) (dpad 2) (dpad 5) (dpad 10))
(a (key j) (button 0))
(b (key k) (button 1))
(start (key return) (button 9))
(select (key backspace) (button 8))
(quit (key escape) (key Escape)))
(define (button-get state button which)
"Return getter result for BUTTON in STATE. WHICH: 0 = current, 1 = prev."
(let* ((config (input-state-config state))
(p (assq button (input-config-button-procs config))))
(and p ((list-ref (cdr p) which) state))))
(define (apply-key-or-button state key-or-button value key->button)
(let ((entry (assq key-or-button key->button)))
(if (and entry (pair? entry))
(let ((button (cdr entry)))
(if button (input-state-with-button state button value) state))
state)))
(define (handle-key-event state event pressed?)
(apply-key-or-button state (sdl2:keyboard-event-sym event) pressed?
(input-config-key-to-button (input-state-config state))))
(define (handle-joy-button-event state event pressed?)
(apply-key-or-button state (sdl2:joy-button-event-button event) pressed?
(input-config-gamepad-to-button (input-state-config state))))
(define (handle-joy-hat-event state event)
(let ((config (input-state-config state))
(value (sdl2:joy-hat-event-value event)))
(fold (lambda (button st)
(let ((values (assq button (input-config-hat-button-values config))))
(if values
(input-state-with-button st button (not (not (member value (cdr values)))))
st)))
state
(input-config-all-buttons config))))
(define (handle-joy-axis-event state event)
(let ((axis (sdl2:joy-axis-event-axis event))
(value (sdl2:joy-axis-event-value event)))
(case axis
((0) (input-state-with-button
(input-state-with-button state 'left (< value -8000)) 'right (> value 8000)))
((1) (input-state-with-button
(input-state-with-button state 'up (< value -8000)) 'down (> value 8000)))
(else state))))
(define (handle-event state event)
(let ((type (sdl2:event-type event)))
(case type
((key-down) (handle-key-event state event #t))
((key-up) (handle-key-event state event #f))
((joy-button-down) (handle-joy-button-event state event #t))
((joy-button-up) (handle-joy-button-event state event #f))
((joy-hat-motion) (handle-joy-hat-event state event))
((joy-axis-motion) (handle-joy-axis-event state event))
(else state))))
(define (input-state-update state events)
"Copy-on-update: roll state then fold events. Returns new state; config is preserved."
(let ((rolled (input-state-roll state)))
(fold (lambda (event st) (handle-event st event)) rolled events)))
(define (input-pressed? state button)
"Return #t if BUTTON was just pressed this frame (edge: not held previous frame)."
(let ((result (and (button-get state button 0) (not (button-get state button 1)))))
(when result (log-debug "[input] pressed ~a" button))
result))
(define (input-held? state button)
"Return #t if BUTTON is currently held down."
(button-get state button 0))
(define (input-released? state button)
"Return #t if BUTTON was just released this frame."
(and (not (button-get state button 0)) (button-get state button 1)))
(define (input-any-pressed? state)
"Return #t if any button was pressed this frame."
(any (cut input-pressed? state <>) (input-config-all-buttons (input-state-config state))))
) ; end module
|
