(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