path: root/catbird/kernel.scm

(define-module (catbird kernel)
  #:use-module (catbird asset)
  #:use-module (catbird camera)
  #:use-module (catbird config)
  #:use-module (catbird input-map)
  #:use-module (catbird mixins)
  #:use-module (catbird mode)
  #:use-module (catbird region)
  #:use-module (catbird scene)
  #:use-module (chickadee)
  #:use-module (chickadee data array-list)
  #:use-module (chickadee math rect)
  #:use-module (ice-9 atomic)
  #:use-module (ice-9 match)
  #:use-module (oop goops)
  #:use-module (srfi srfi-1)
  #:use-module (system repl coop-server)
  #:export (all-regions
            create-full-region
            create-region
            find-region-by-name
            frames-per-second
            kill-region
            current-keyboard-focus
            take-keyboard-focus
            current-controller-focus
            take-controller-focus
            bind-input/global
            unbind-input/global
            run-catbird
            exit-catbird))


;;;
;;; Kernel
;;;

(define-root-class <kernel> ()
  (controllers #:getter controllers #:init-thunk make-array-list)
  (regions #:accessor regions #:init-value '())
  (input-map #:accessor input-map #:init-thunk make-input-map)
  (keyboard-focus #:accessor keyboard-focus #:init-value #f)
  (controller-focus #:getter controller-focus #:init-thunk make-hash-table)
  (repl #:accessor repl #:init-value #f)
  (frame-start-time #:accessor frame-start-time #:init-value 0.0)
  (average-frame-time #:accessor average-frame-time #:init-value 0.0))

(define-method (load* (kernel <kernel>))
  (when developer-mode?
    (set! (repl kernel) (spawn-coop-repl-server))))

;; Add the system notification and debugging overlay.
(define-method (add-overlay (kernel <kernel>))
  (let ((region (create-full-region #:name 'overlay #:rank 9999)))
    (set! (camera region)
          (make <camera-2d>
            #:width (rect-width (area region))
            #:height (rect-height (area region))))
    ;; Use resolve-module to avoid a circular dependency.
    (replace-scene region
                   ((module-ref (resolve-module '(catbird overlay))
                                'make-overlay)))))

(define-method (overlay-scene (kernel <kernel>))
  (scene (lookup-region kernel 'overlay)))

(define-method (notify (kernel <kernel>) message)
  (let ((notify (module-ref (resolve-module '(catbird overlay)) 'notify)))
    (notify (overlay-scene kernel) message)))

(define-method (update (kernel <kernel>) dt)
  (when developer-mode?
    (poll-coop-repl-server (repl kernel))
    (reload-modified-assets))
  (for-each (lambda (region) (update/around region dt))
            (regions kernel)))

(define-method (render (kernel <kernel>) alpha)
  (for-each (lambda (region)
              (render/around region alpha))
            (regions kernel))
  ;; Compute FPS.
  (let ((current-time (elapsed-time)))
    (set! (average-frame-time kernel)
          (+ (* (- current-time (frame-start-time kernel)) 0.1)
             (* (average-frame-time kernel) 0.9)))
    (set! (frame-start-time kernel) current-time)))

(define-method (lookup-region (kernel <kernel>) region-name)
  (find (lambda (region)
          (eq? (name region) region-name))
        (regions kernel)))

(define-method (add-region (kernel <kernel>) (region <region>))
  (let ((r (regions kernel)))
    ;; The first region added gets keyboard focus by default.
    (when (null? r)
      (set! (keyboard-focus kernel) region))
    (set! (regions kernel)
          (sort-by-rank/ascending (cons region (regions kernel))))))

(define-method (bind-input (kernel <kernel>) spec handler)
  (set! (input-map kernel) (add-input (input-map kernel) spec handler)))

(define-method (unbind-input (kernel <kernel>) spec)
  (set! (input-map kernel) (remove-input (input-map kernel) spec)))


;;;
;;; Keyboard
;;;

(define-method (on-key-press (kernel <kernel>) key modifiers)
  (or (let ((handler (key-press-handler (input-map kernel) key modifiers)))
        (and handler (handler)))
      (let* ((r (keyboard-focus kernel))
             (s (and r (scene r))))
        (and s (on-key-press s key modifiers)))))

(define-method (on-key-release (kernel <kernel>) key modifiers)
  (or (let ((handler (key-release-handler (input-map kernel) key modifiers)))
        (and handler (handler)))
      (let* ((r (keyboard-focus kernel))
             (s (and r (scene r))))
        (and s (on-key-release s key modifiers)))))

(define-method (on-text-input (kernel <kernel>) text)
  (or (let ((handler (text-input-handler (input-map kernel))))
        (and handler (handler text)))
      (let* ((r (keyboard-focus kernel))
             (s (and r (scene r))))
        (and s (on-text-input s text)))))


;;;
;;; Mouse
;;;

(define (mouse-search kernel proc)
  (let loop ((regions* (regions kernel)))
    (match regions*
      (() #f)
      ((r . rest)
       (or (loop rest)
           (let ((s (scene r)))
             (and s (proc s))))))))

(define-method (on-mouse-press (kernel <kernel>) button x y)
  (or (let ((handler (mouse-press-handler (input-map kernel) button)))
        (and handler (handler x y)))
      (mouse-search kernel
                    (lambda (s)
                      (on-mouse-press s button x y)))))

(define-method (on-mouse-release (kernel <kernel>) button x y)
  (or (let ((handler (mouse-release-handler (input-map kernel) button)))
        (and handler (handler x y)))
      (mouse-search kernel
                    (lambda (s)
                      (on-mouse-release s button x y)))))

(define-method (on-mouse-move (kernel <kernel>) x y x-rel y-rel buttons)
  (or (let ((handler (mouse-move-handler (input-map kernel) buttons)))
        (and handler (handler x y x-rel y-rel)))
      (mouse-search kernel
                    (lambda (s)
                      (on-mouse-move s x y x-rel y-rel buttons)))))

(define-method (on-mouse-wheel (kernel <kernel>) x y)
  (or (let ((handler (mouse-wheel-handler (input-map kernel))))
        (and handler (handler x y)))
      (mouse-search kernel
                    (lambda (s)
                      (on-mouse-wheel s x y)))))


;;;
;;; Controllers
;;;

(define-method (controller-focus (kernel <kernel>) slot)
  (hashv-ref (controller-focus kernel) (controller-slot-id slot)))

(define (make-controller-slot id)
  (vector id #f))

(define (controller-slot-id slot)
  (vector-ref slot 0))

(define (controller-slot-controller slot)
  (vector-ref slot 1))

(define (controller-slot-empty? slot)
  (not (controller-slot-controller slot)))

(define (fill-controller-slot! slot controller)
  (vector-set! slot 1 controller))

(define (clear-controller-slot! slot)
  (fill-controller-slot! slot #f))

(define-method (empty-controller-slot (kernel <kernel>))
  (let* ((c (controllers kernel))
         (n (array-list-size c)))
    (let loop ((i 0))
      (if (= i n)
          (let ((slot (make-controller-slot i)))
            (array-list-push! c slot)
            slot)
          (let ((slot (array-list-ref c i)))
            (if (controller-slot-empty? slot)
                slot
                (loop (+ i 1))))))))

(define-method (find-controller-slot (kernel <kernel>) controller)
  (let* ((c (controllers kernel))
         (n (array-list-size c)))
    (let loop ((i 0))
      (if (= i n)
          #f
          (let ((slot (array-list-ref c i)))
            (if (eq? (controller-slot-controller slot) controller)
                slot
                (loop (+ i 1))))))))

(define-method (on-controller-add (kernel <kernel>) controller)
  (let ((slot (empty-controller-slot kernel)))
    (notify kernel (string-append "Controller "
                                  (number->string
                                   (+ (controller-slot-id slot) 1))
                                  " connected: "
                                  (controller-name controller)))
    (fill-controller-slot! slot controller)))

(define-method (on-controller-remove (kernel <kernel>) controller)
  (let ((slot (find-controller-slot kernel controller)))
    (notify kernel (string-append "Controller "
                                  (number->string
                                   (+ (controller-slot-id slot) 1))
                                  " disconnected: "
                                  (controller-name controller)))
    (clear-controller-slot! (find-controller-slot kernel controller))))

(define-method (on-controller-press (kernel <kernel>) controller button)
  (let ((slot (find-controller-slot kernel controller)))
    (or (let ((handler (controller-press-handler (input-map kernel)
                                                 (controller-slot-id slot)
                                                 button)))
          (and handler (handler)))
        (let* ((r (controller-focus kernel slot))
               (s (and r (scene r))))
          (and r (on-controller-press s
                                      (controller-slot-id slot)
                                      button))))))

(define-method (on-controller-release (kernel <kernel>) controller button)
  (let ((slot (find-controller-slot kernel controller)))
    (or (let ((handler (controller-release-handler (input-map kernel)
                                                   (controller-slot-id slot)
                                                   button)))
          (and handler (handler)))
        (let* ((r (controller-focus kernel slot))
               (s (and r (scene r))))
          (and s (on-controller-release s
                                        (controller-slot-id slot)
                                        button))))))

(define-method (on-controller-move (kernel <kernel>) controller axis value)
  (let ((slot (find-controller-slot kernel controller)))
    (or (let ((handler (controller-move-handler (input-map kernel)
                                                (controller-slot-id slot)
                                                axis)))
          (and handler (handler value)))
        (let* ((r (controller-focus kernel slot))
               (s (and r (scene r))))
          (and s (on-controller-move s
                                     (controller-slot-id slot)
                                     axis
                                     value))))))


;;;
;;; Global kernel API
;;;

(define current-kernel (make-parameter #f))

(define (unique-region-name)
  (gensym "region-"))

(define* (create-region area #:key (rank 0) (name (unique-region-name)))
  (let ((region (make-region area name rank)))
    (add-region (current-kernel) region)
    region))

(define* (create-full-region #:key (rank 0) (name (unique-region-name)))
  (let ((w (window-width (current-window)))
        (h (window-height (current-window))))
    (create-region (make-rect 0.0 0.0 w h) #:rank rank #:name name)))

(define (kill-region region)
  (let ((k (current-kernel)))
    (set! (regions k) (delq region (regions k)))))

(define (all-regions)
  (regions (current-kernel)))

(define (find-region-by-name name)
  (lookup-region (current-kernel) name))

(define (current-keyboard-focus)
  (keyboard-focus (current-kernel)))

(define (take-keyboard-focus region)
  (set! (keyboard-focus (current-kernel)) region))

(define (current-controller-focus controller-id)
  (hashv-ref (controller-focus (current-kernel)) controller-id))

(define (take-controller-focus controller-id region)
  (hashv-set! (controller-focus (current-kernel)) controller-id region))

(define (bind-input/global spec handler)
  (bind-input (current-kernel) spec handler))

(define (unbind-input/global spec handler)
  (unbind-input (current-kernel) spec handler))

(define (frames-per-second)
  (/ 1.0 (average-frame-time (current-kernel))))

(define* (run-catbird thunk #:key (width 1366) (height 768)
                      (title "^~Catbird~^") (fullscreen? #f)
                      (resizable? #t) (update-hz 60))
  (let ((kernel (make <kernel>)))
    (parameterize ((current-kernel kernel))
      (run-game #:window-title title
                #:window-width width
                #:window-height height
                #:window-fullscreen? fullscreen?
                #:window-resizable? resizable?
                #:update-hz update-hz
                #:load
                (lambda ()
                  (load* kernel)
                  (thunk)
                  (add-overlay kernel))
                #:draw
                (lambda (alpha)
                  (render kernel alpha))
                #:update
                (lambda (dt)
                  (update kernel dt))
                #:key-press
                (lambda (key modifiers repeat?)
                  (on-key-press kernel key modifiers))
                #:key-release
                (lambda (key modifiers)
                  (on-key-release kernel key modifiers))
                #:text-input
                (lambda (text)
                  (on-text-input kernel text))
                #:mouse-press
                ;; TODO: Handle click counter?
                (lambda (button clicks x y)
                  (on-mouse-press kernel button x y))
                #:mouse-release
                (lambda (button x y)
                  (on-mouse-release kernel button x y))
                #:mouse-move
                (lambda (x y x-rel y-rel buttons)
                  (on-mouse-move kernel x y x-rel y-rel buttons))
                #:mouse-wheel
                (lambda (x y)
                  (on-mouse-wheel kernel x y))
                #:controller-add
                (lambda (controller)
                  (on-controller-add kernel controller))
                #:controller-remove
                (lambda (controller)
                  (on-controller-remove kernel controller))
                #:controller-press
                (lambda (controller button)
                  (on-controller-press kernel controller button))
                #:controller-release
                (lambda (controller button)
                  (on-controller-release kernel controller button))
                #:controller-move
                (lambda (controller axis value)
                  (on-controller-move kernel controller axis value))))))

(define (exit-catbird)
  "Stop the Catbird engine."
  (abort-game))