;;; Catbird Game Engine
;;; Copyright © 2022 David Thompson <davet@gnu.org>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary:
;;
;; Keyboard, mouse, controller input specification.
;;
;;; Code:
(define-module (catbird input-map)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:export (make-input-map
            add-input
            remove-input
            key-press
            key-release
            text-input
            mouse-press
            mouse-release
            mouse-move
            mouse-wheel
            controller-press
            controller-release
            controller-move
            key-press-handler
            key-release-handler
            text-input-handler
            mouse-press-handler
            mouse-release-handler
            mouse-move-handler
            mouse-wheel-handler
            controller-press-handler
            controller-release-handler
            controller-move-handler))

(define (make-input-map)
  '())

(define (add-input input-map spec handler)
  (cons (cons spec handler)
        input-map))

(define (remove-input input-map spec)
  (delete spec input-map
          (match-lambda*
            ((a (b . _))
             (equal? a b)))))

(define* (key-press key #:optional (modifiers '()))
  `(keyboard ,key ,modifiers down))

(define* (key-release key #:optional (modifiers '()))
  `(keyboard ,key ,modifiers up))

(define (text-input)
  '(text-input))

(define (mouse-press button)
  `(mouse button ,button down))

(define (mouse-release button)
  `(mouse button ,button up))

(define* (mouse-move #:optional (buttons '()))
  `(mouse move ,buttons))

(define* (mouse-wheel)
  '(mouse wheel))

(define (controller-press id button)
  `(controller button ,id ,button down))

(define (controller-release id button)
  `(controller button ,id ,button up))

(define (controller-move id axis)
  `(controller axis ,id ,axis))

;; Chickadee is specific about which modifier keys are pressed and
;; makes distinctions between left and right ctrl, for example.  For
;; convenience, we want users to be able to specify simply 'ctrl' and
;; it will match both left and right.
(define (modifiers-match? spec-modifiers modifiers)
  (every (lambda (k)
           (case k
             ;; The specification is looking for a specific modifier
             ;; key.
             ((left-ctrl right-ctrl left-alt right-alt left-shift right-shift)
              (memq k modifiers))
             ;; The specification is looking for either left/right
             ;; modifier key.
             ((ctrl)
              (or (memq 'left-control modifiers)
                  (memq 'right-control modifiers)))
             ((alt)
              (or (memq 'left-alt modifiers)
                  (memq 'right-alt modifiers)))
             ((shift)
              (or (memq 'left-shift modifiers)
                  (memq 'right-shift modifiers)))))
         spec-modifiers))

(define (key-press-handler input-map key modifiers)
  (any (match-lambda
         ((('keyboard key* modifiers* 'down) . handler)
          (and (eq? key key*)
               (modifiers-match? modifiers* modifiers)
               handler))
         (_ #f))
       input-map))

(define (key-release-handler input-map key modifiers)
  (any (match-lambda
         ((('keyboard key* modifiers* 'up) . handler)
          (and (eq? key key*)
               (modifiers-match? modifiers modifiers*)
               handler))
         (_ #f))
       input-map))

(define (text-input-handler input-map)
  (any (match-lambda
         ((('text-input) . handler) handler)
         (_ #f))
       input-map))

(define (mouse-press-handler input-map button)
  (any (match-lambda
         ((('mouse 'button button* 'down) . handler)
          (and (eq? button button*)
               handler))
         (_ #f))
       input-map))

(define (mouse-release-handler input-map button)
  (any (match-lambda
         ((('mouse 'button button* 'up) . handler)
          (and (eq? button button*)
               handler))
         (_ #f))
       input-map))

(define (mouse-move-handler input-map buttons)
  (any (match-lambda
         ((('mouse 'move buttons*) . handler)
          (and (= (length buttons) (length buttons*))
               (every (lambda (b) (memq b buttons*)) buttons)
               handler))
         (_ #f))
       input-map))

(define (mouse-wheel-handler input-map)
  (any (match-lambda
         ((('mouse 'wheel) . handler)
          handler)
         (_ #f))
       input-map))

(define (controller-press-handler input-map controller-id button)
  (any (match-lambda
         ((('controller 'button controller-id* button* 'down) . handler)
          (and (= controller-id controller-id*)
               (eq? button button*)
               handler))
         (_ #f))
       input-map))

(define (controller-release-handler input-map controller-id button)
  (any (match-lambda
         ((('controller 'button controller-id* button* 'up) . handler)
          (and (= controller-id controller-id*)
               (eq? button button*)
               handler))
         (_ #f))
       input-map))

(define (controller-move-handler input-map controller-id axis)
  (any (match-lambda
         ((('controller 'axis controller-id* axis*) . handler)
          (and (= controller-id controller-id*)
               (eq? axis axis*)
               handler))
         (_ #f))
       input-map))