diff options
| -rw-r--r-- | README.md | 7 | ||||
| -rw-r--r-- | TODO.org | 2 | ||||
| -rw-r--r-- | src/game.scm | 42 | ||||
| -rw-r--r-- | src/input.scm | 312 |
4 files changed, 162 insertions, 201 deletions
@@ -9,6 +9,7 @@ This is a game written with chicken-scheme and SDL2. It requires the following t - chicken-scheme - SDL2 +- [simple-logger](https://wiki.call-cc.org/egg/simple-logger) egg: `chicken-install simple-logger` ## Quickstart @@ -18,6 +19,12 @@ To build the game, run make ``` +To run with input event logging (for debugging), pass `--debug`: + +``` +./bin/game --debug +``` + ## Credits - Code: Gene Pasquet @@ -6,7 +6,7 @@ *** DONE Render multiple tile layers (simple implementation). :graphics: ** Input & Player Basics -*** TODO Build a simple input-state map (keys pressed/held). :input: +*** DONE Build a simple input-state map (keys pressed/held). :input: *** TODO Create basic player entity (plist data + type). :entities: *** TODO Move the player 1 pixel each frame to test update loop. :entities:update: diff --git a/src/game.scm b/src/game.scm index d22263b..aeb725b 100644 --- a/src/game.scm +++ b/src/game.scm @@ -7,6 +7,7 @@ (srfi 1) (srfi 12) miscmacros + simple-logger (prefix sdl2 "sdl2:") (prefix sdl2-ttf "ttf:") (prefix sdl2-image "img:") @@ -22,6 +23,11 @@ (define +background-color+ (sdl2:make-color 0 0 0)) (define +software-mode?+ (member "--software" (command-line-arguments))) (define +vsync?+ (member "--vsync" (command-line-arguments))) +(define +debug?+ (member "--debug" (command-line-arguments))) + +;; When --debug is passed, show debug/info logs (e.g. input events). +(when +debug?+ + (log-level 0)) (sdl2:set-main-ready!) (sdl2:init! '(video joystick)) @@ -128,35 +134,11 @@ (set! (sdl2:render-draw-color *renderer*) +background-color+) (sdl2:render-clear! *renderer*) -(defstruct keymap - jump - left - right - attack - macro) - -(define keys (make-keymap #f #f #f #f #f)) - -(define-syntax defkeymap - (syntax-rules () - ((defkeymap name - (state (key ...)) ...) - (define name )))) - -(defkeymap keys - (jump ('w 'up)) - (left ('a 'left)) - (right ('d 'right)) - (attack ('q)) - (macro ('space)) - (quit ('escape))) - (let/cc exit-main-loop! (while #t (set! (sdl2:render-draw-color *renderer*) +background-color+) (sdl2:render-clear! *renderer*) (sdl2:pump-events!) - ;; Collect this frame's events (input-state-update! expects a list) (let ((events-this-frame (let collect ((lst '())) (if (not (sdl2:has-events?)) @@ -164,14 +146,10 @@ (let ((e (sdl2:make-event))) (sdl2:poll-event! e) (collect (cons e lst))))))) - (input-state-update! *input* events-this-frame) - ;; Check for escape to exit - (for-each (lambda (event) - (when (and (sdl2:keyboard-event? event) - (eq? (sdl2:event-type event) 'key-down) - (eq? (sdl2:keyboard-event-sym event) 'escape)) - (exit-main-loop!))) - events-this-frame)) + (set! *input* (input-state-update *input* events-this-frame)) + (when (input-pressed? *input* 'quit) + (log-debug "[game] quit pressed") + (exit-main-loop!))) (draw-tilemap *renderer* *level*) (draw-objects *renderer* *level*) diff --git a/src/input.scm b/src/input.scm index f48518b..1cb5853 100644 --- a/src/input.scm +++ b/src/input.scm @@ -1,192 +1,168 @@ (module input (create-input-state - input-state-update! + input-state-update input-pressed? input-held? input-released? input-any-pressed?) - -(import scheme + (import scheme (chicken base) (chicken module) - (only srfi-1 any) + (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)))) -;; Input state record - tracks current and previous frame state -(define-record input-state - up down left right a b start select - prev-up prev-down prev-left prev-right prev-a prev-b prev-start prev-select) +(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)))) -;; Create a new input state with all buttons released -(define (create-input-state) - (make-input-state #f #f #f #f #f #f #f #f - #f #f #f #f #f #f #f #f)) +(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)))) -;; Button name to keyboard scancode mapping -(define *keyboard-map* - '((up . w) - (down . s) - (left . a) - (right . d) - (a . j) - (b . k) - (start . return) - (select . backspace))) +(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)))) -;; Button name to gamepad button mapping -(define *gamepad-button-map* - '((a . 0) ; Button 0 (typically A/Cross) - (b . 1) ; Button 1 (typically B/Circle) - (start . 9) ; Button 9 (Start) - (select . 8))) ; Button 8 (Select) +(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)))) -;; Update input state based on SDL2 events -;; This should be called once per frame AFTER processing events -;; Pass the event list from your game loop -(define (input-state-update! state events) - ;; Save previous frame state - (input-state-prev-up-set! state (input-state-up state)) - (input-state-prev-down-set! state (input-state-down state)) - (input-state-prev-left-set! state (input-state-left state)) - (input-state-prev-right-set! state (input-state-right state)) - (input-state-prev-a-set! state (input-state-a state)) - (input-state-prev-b-set! state (input-state-b state)) - (input-state-prev-start-set! state (input-state-start state)) - (input-state-prev-select-set! state (input-state-select state)) - - ;; Process events to update current state - (for-each - (lambda (event) - (let ((type (sdl2:event-type event))) - (cond - ;; Keyboard events - ((eq? type 'key-down) - (let ((key (sdl2:keyboard-event-sym event))) - (cond - ((eq? key 'w) (input-state-up-set! state #t)) - ((eq? key 's) (input-state-down-set! state #t)) - ((eq? key 'a) (input-state-left-set! state #t)) - ((eq? key 'd) (input-state-right-set! state #t)) - ((eq? key 'j) (input-state-a-set! state #t)) - ((eq? key 'k) (input-state-b-set! state #t)) - ((eq? key 'return) (input-state-start-set! state #t)) - ((eq? key 'backspace) (input-state-select-set! state #t))))) - - ((eq? type 'key-up) - (let ((key (sdl2:keyboard-event-sym event))) - (cond - ((eq? key 'w) (input-state-up-set! state #f)) - ((eq? key 's) (input-state-down-set! state #f)) - ((eq? key 'a) (input-state-left-set! state #f)) - ((eq? key 'd) (input-state-right-set! state #f)) - ((eq? key 'j) (input-state-a-set! state #f)) - ((eq? key 'k) (input-state-b-set! state #f)) - ((eq? key 'return) (input-state-start-set! state #f)) - ((eq? key 'backspace) (input-state-select-set! state #f))))) - - ;; Joystick button events - ((eq? type 'joy-button-down) - (let ((button (sdl2:joy-button-event-button event))) - (cond - ((= button 0) (input-state-a-set! state #t)) - ((= button 1) (input-state-b-set! state #t)) - ((= button 8) (input-state-select-set! state #t)) - ((= button 9) (input-state-start-set! state #t))))) - - ((eq? type 'joy-button-up) - (let ((button (sdl2:joy-button-event-button event))) - (cond - ((= button 0) (input-state-a-set! state #f)) - ((= button 1) (input-state-b-set! state #f)) - ((= button 8) (input-state-select-set! state #f)) - ((= button 9) (input-state-start-set! state #f))))) - - ;; Joystick hat (d-pad) events - ((eq? type 'joy-hat-motion) - (let ((value (sdl2:joy-hat-event-value event))) - (input-state-up-set! state (or (= value 1) (= value 9) (= value 5))) ; UP, LEFT-UP, RIGHT-UP - (input-state-down-set! state (or (= value 4) (= value 6) (= value 10))) ; DOWN, LEFT-DOWN, RIGHT-DOWN - (input-state-left-set! state (or (= value 8) (= value 9) (= value 6))) ; LEFT, LEFT-UP, LEFT-DOWN - (input-state-right-set! state (or (= value 2) (= value 5) (= value 10))))) ; RIGHT, RIGHT-UP, RIGHT-DOWN - - ;; Joystick axis (analog stick as d-pad) - ((eq? type 'joy-axis-motion) - (let ((axis (sdl2:joy-axis-event-axis event)) - (value (sdl2:joy-axis-event-value event))) - (cond - ((= axis 0) ; X-axis - (input-state-left-set! state (< value -8000)) - (input-state-right-set! state (> value 8000))) - ((= axis 1) ; Y-axis - (input-state-up-set! state (< value -8000)) - (input-state-down-set! state (> value 8000))))))))) - events)) +(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))) -;; Check if a button was just pressed this frame (define (input-pressed? state button) - (let ((current (case button - ((up) (input-state-up state)) - ((down) (input-state-down state)) - ((left) (input-state-left state)) - ((right) (input-state-right state)) - ((a) (input-state-a state)) - ((b) (input-state-b state)) - ((start) (input-state-start state)) - ((select) (input-state-select state)) - (else #f))) - (previous (case button - ((up) (input-state-prev-up state)) - ((down) (input-state-prev-down state)) - ((left) (input-state-prev-left state)) - ((right) (input-state-prev-right state)) - ((a) (input-state-prev-a state)) - ((b) (input-state-prev-b state)) - ((start) (input-state-prev-start state)) - ((select) (input-state-prev-select state)) - (else #f)))) - (and current (not previous)))) + "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)) -;; Check if a button is currently held down (define (input-held? state button) - (case button - ((up) (input-state-up state)) - ((down) (input-state-down state)) - ((left) (input-state-left state)) - ((right) (input-state-right state)) - ((a) (input-state-a state)) - ((b) (input-state-b state)) - ((start) (input-state-start state)) - ((select) (input-state-select state)) - (else #f))) + "Return #t if BUTTON is currently held down." + (button-get state button 0)) -;; Check if a button was just released this frame (define (input-released? state button) - (let ((current (case button - ((up) (input-state-up state)) - ((down) (input-state-down state)) - ((left) (input-state-left state)) - ((right) (input-state-right state)) - ((a) (input-state-a state)) - ((b) (input-state-b state)) - ((start) (input-state-start state)) - ((select) (input-state-select state)) - (else #f))) - (previous (case button - ((up) (input-state-prev-up state)) - ((down) (input-state-prev-down state)) - ((left) (input-state-prev-left state)) - ((right) (input-state-prev-right state)) - ((a) (input-state-prev-a state)) - ((b) (input-state-prev-b state)) - ((start) (input-state-prev-start state)) - ((select) (input-state-prev-select state)) - (else #f)))) - (and (not current) previous))) + "Return #t if BUTTON was just released this frame." + (and (not (button-get state button 0)) (button-get state button 1))) -;; Check if any button was pressed this frame (define (input-any-pressed? state) - (any (lambda (button) - (input-pressed? state button)) - '(up down left right a b start select))) + "Return #t if any button was pressed this frame." + (any (cut input-pressed? state <>) (input-config-all-buttons (input-state-config state)))) ) ; end module |