path: root/starling/kernel.scm

;;; Starling Game Engine
;;; Copyright © 2018, 2020 David Thompson <davet@gnu.org>
;;;
;;; This program is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Starling.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; This is the core of the game engine, the root node, that is
;; responsible for starting up the game loop and passing along render,
;; update, and input events to the other parts of the game.
;;
;;; Code:

(define-module (starling kernel)
  #:use-module (chickadee audio)
  #:use-module (chickadee game-loop)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics engine)
  #:use-module (chickadee graphics font)
  #:use-module (chickadee graphics path)
  #:use-module (chickadee graphics viewport)
  #:use-module (chickadee math rect)
  #:use-module (chickadee math vector)
  #:use-module (chickadee scripting)
  #:use-module (gl)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (oop goops)
  #:use-module ((sdl2) #:select (sdl-init))
  #:use-module (sdl2 events)
  #:use-module (sdl2 input game-controller)
  #:use-module (sdl2 input joystick)
  #:use-module (sdl2 input text)
  #:use-module (starling asset)
  #:use-module (starling config)
  #:use-module (starling node)
  #:use-module (starling node-2d)
  #:use-module (starling repl)
  #:use-module (starling repl-server)
  #:use-module (starling minibuffer)
  #:use-module (starling scene)
  #:use-module (starling system)
  #:use-module ((sdl2 video) #:prefix sdl2:)
  #:use-module (system repl command)
  #:export (<window-config>
            window-width
            window-height
            window-title
            window-fullscreen?

            <kernel>
            window-config
            update-hz
            window
            gl-context
            avg-frame-time
            current-kernel
            boot-kernel
            fps
            reboot-current-scene)
  #:re-export (abort-game))


;;;
;;; FPS Display
;;;

(define-class <fps-display> (<node>))

(define-method (on-boot (fps-display <fps-display>))
  (let* ((display (make <display-2d> #:name 'display))
         (font (default-font))
         (padding 4.0)
         (box-width (+ (font-line-width font "60.0")
                       (* padding 2.0)))
         (box-height (+ (font-line-height font) (* padding 2.0))))
    (call-with-values current-window-size
      (lambda (window-width window-height)
        (attach-to display
                   (make <canvas>
                     #:painter (with-style ((fill-color (make-color 0 0 0 0.5)))
                                 (fill
                                  (rectangle (vec2 0.0
                                                   (- window-height box-height))
                                             box-width
                                             box-height))))
                   (make <label>
                     #:name 'fps-label
                     #:rank 9
                     #:text "60.0"
                     #:font font
                     #:position (vec2 padding
                                      (+ (- window-height box-height)
                                         padding))))))
    (attach-to fps-display display)))

(define-method (update-fps (fps-display <fps-display>) fps)
  (set! (text (& fps-display display fps-label))
    (format #f "~1,1f" fps)))


;;;
;;; Kernel
;;;

(define-class <window-config> ()
  (width #:accessor window-width #:init-form 640 #:init-keyword #:width)
  (height #:accessor window-height #:init-form 480 #:init-keyword #:height)
  (title #:accessor window-title #:init-form "Starling"
         #:init-keyword #:title)
  (fullscreen? #:accessor window-fullscreen? #:init-form #f
               #:init-keyword #:fullscreen?))

(define-class <kernel> (<scene-mux>)
  (window-config #:accessor window-config #:init-form (make <window-config>)
                 #:init-keyword #:window-config)
  (update-hz #:accessor update-hz #:init-form 60
             #:init-keyword #:update-hz)
  (window #:accessor window)
  (gl-context #:accessor gl-context)
  (default-viewport #:accessor default-viewport)
  (avg-frame-time #:accessor avg-frame-time #:init-form 0.0)
  (controllers #:accessor controllers #:init-thunk make-hash-table)
  (repl #:accessor repl)
  (minibuffer #:accessor minibuffer))

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

;; game controller bookkeeping.
(define (lookup-controller kernel joystick-id)
  (hashv-ref (controllers kernel) joystick-id))

(define (add-controller kernel joystick-index)
  (let ((controller (open-game-controller joystick-index)))
    (hashv-set! (controllers kernel)
                (joystick-instance-id
                 (game-controller-joystick controller))
                controller)
    controller))

(define (remove-controller kernel joystick-id)
  (hashv-remove! (controllers kernel) joystick-id))

(define (initialize-controllers kernel)
  (let loop ((i 0))
    (when (< i (num-joysticks))
      (when (game-controller-index? i)
        (add-controller kernel i))
      (loop (+ i 1)))))

(define-method (on-boot (kernel <kernel>))
  (when developer-mode?
    ;; Enable live asset reloading.
    (watch-assets #t)
    (attach-to kernel
               ;; FPS counter
               (make <fps-display> #:name 'fps)
               ;; REPL server
               (make <repl-server> #:name 'repl-server))
    (set! (repl kernel)
      (make <repl>
        #:name 'repl
        #:scene-mux kernel))
    (set! (minibuffer kernel)
      (make <minibuffer>
        #:name 'minibuffer
        #:scene-mux kernel))
    (run-script kernel
      (forever
       (sleep 1.0)
       (update-fps (& kernel fps) (fps kernel))))))

(define-method (on-key-press (kernel <kernel>) key modifiers repeat?)
  ;; Hot keys when in dev mode
  (if (and developer-mode?
           (not (or (eq? (current-scene kernel) (minibuffer kernel))
                    (eq? (current-scene kernel) (repl kernel)))))
      (match key
        ('backquote
         (run-script kernel
           (sleep (current-timestep))
           (open-repl (repl kernel))))
        ('x
         (if (or (memq 'left-alt modifiers)
                 (memq 'right-alt modifiers))
             ;; We need to delay the minibuffer by one frame so that
             ;; the text input event for the "x" character (part of
             ;; the M-x key shortcut) is not processed by the
             ;; minibuffer, thus adding an "x" to the user text entry
             ;; area before the user has actually typed anything.
             (run-script kernel
               (sleep (current-timestep))
               (open-minibuffer (minibuffer kernel)))
             (next-method)))
        ('escape (abort-game))
        (_ (next-method)))
      (next-method)))

(define-method (update-tree (kernel <kernel>) dt)
  (define (invert-y y)
    ;; SDL's origin is the top-left, but our origin is the bottom
    ;; left so we need to invert Y coordinates that SDL gives us.
    (call-with-values (lambda () (sdl2:window-size (window kernel)))
      (lambda (width height)
        (- height y))))
  (define (process-event event)
    (cond
     ((quit-event? event)
      (on-quit kernel))
     ((keyboard-down-event? event)
      (on-key-press kernel
                    (keyboard-event-key event)
                    (keyboard-event-modifiers event)
                    (keyboard-event-repeat? event)))
     ((keyboard-up-event? event)
      (on-key-release kernel
                      (keyboard-event-key event)
                      (keyboard-event-modifiers event)))
     ((text-input-event? event)
      (on-text-input kernel
                     (text-input-event-text event)))
     ((mouse-button-down-event? event)
      (on-mouse-press kernel
                      (mouse-button-event-button event)
                      (mouse-button-event-clicks event)
                      (mouse-button-event-x event)
                      (invert-y (mouse-button-event-y event))))
     ((mouse-button-up-event? event)
      (on-mouse-release kernel
                        (mouse-button-event-button event)
                        (mouse-button-event-x event)
                        (invert-y (mouse-button-event-y event))))
     ((mouse-motion-event? event)
      (on-mouse-move kernel
                     (mouse-motion-event-x event)
                     (invert-y (mouse-motion-event-y event))
                     (mouse-motion-event-x-rel event)
                     (- (mouse-motion-event-y-rel event))
                     (mouse-motion-event-buttons event)))
     ((and (controller-device-event? event)
           (eq? (controller-device-event-action event) 'added))
      (let ((controller
             (add-controller kernel
                             (controller-device-event-which event))))
        (on-controller-add kernel controller)))
     ((and (controller-device-event? event)
           (eq? (controller-device-event-action event) 'removed))
      (let ((controller
             (lookup-controller kernel
                                (controller-device-event-which event))))
        (on-controller-remove kernel controller)
        (remove-controller kernel (controller-device-event-which event))
        (close-game-controller controller)))
     ((controller-button-down-event? event)
      (let ((controller
             (lookup-controller kernel
                                (controller-button-event-which event))))
        (on-controller-press kernel
                             controller
                             (controller-button-event-button event))))
     ((controller-button-up-event? event)
      (let ((controller
             (lookup-controller kernel
                                (controller-button-event-which event))))
        (on-controller-release kernel
                               controller
                               (controller-button-event-button event))))
     ((controller-axis-event? event)
      (let ((controller
             (lookup-controller kernel
                                (controller-axis-event-which event))))
        (on-controller-move kernel
                            controller
                            (controller-axis-event-axis event)
                            (/ (controller-axis-event-value event) 32768.0))))))
  (define (poll-events)
    (let ((event (poll-event)))
      (when event
        (process-event event)
        (poll-events))))
  ;; Process all pending events before we update any other node.
  (poll-events)
  ;; Proceed with standard update procedure.
  (next-method))

(define-method (update (kernel <kernel>) dt)
  (update-audio)
  (when developer-mode?
    (reload-modified-assets))
  ;; Free any GPU resources that have been GC'd.
  (graphics-engine-reap!))

(define %clear-mask
  (logior (attrib-mask color-buffer)
          (attrib-mask depth-buffer)
          (attrib-mask stencil-buffer)
          (attrib-mask accum-buffer)))

(define-method (render-tree (kernel <kernel>) alpha)
  (let ((start-time (elapsed-time)))
    (with-graphics-state! ((g:viewport (default-viewport kernel)))
      (clear-viewport)
      (next-method))
    (sdl2:swap-gl-window (window kernel))
    ;; Compute FPS.
    (set! (avg-frame-time kernel)
          (+ (* (- (elapsed-time) start-time) 0.1)
             (* (avg-frame-time kernel) 0.9)))))

(define-method (on-error (kernel <kernel>) stack key args)
  (if developer-mode?
      (let ((title (sdl2:window-title (window kernel))))
        (sdl2:set-window-title! (window kernel) (string-append "[ERROR] " title))
        (on-error (& kernel repl-server) stack key args)
        (sdl2:set-window-title! (window kernel) title))
      (apply throw key args)))

(define-method (on-scenes-empty (kernel <kernel>))
  (abort-game))

(define-method (fps kernel)
  (/ 1.0 (avg-frame-time kernel)))

(define-method (boot-kernel (kernel <kernel>) thunk)
  (sdl-init)
  ;; This will throw an error if any audio subsystem is unavailable,
  ;; but not every audio subsystem is needed so don't crash the
  ;; program over it.
  (start-text-input)
  ;; Discover all game controllers that are already connected.  New
  ;; connections/disconnections will be handled by events as they occur.
  (initialize-controllers kernel)
  (init-audio)
  (let ((wc (window-config kernel)))
    (set! (window kernel)
      (sdl2:make-window #:opengl? #t
                        #:title (window-title wc)
                        #:size (list (window-width wc) (window-height wc))
                        #:fullscreen? (window-fullscreen? wc)))
    (set! (gl-context kernel) (sdl2:make-gl-context (window kernel)))
    (set! (default-viewport kernel)
          (make-viewport 0 0 (window-width wc) (window-height wc)))
    ;; Attempt to activate vsync, if possible.  Some systems do
    ;; not support setting the OpenGL swap interval.
    (catch #t
      (lambda ()
        (sdl2:set-gl-swap-interval! 'vsync))
      (lambda args
        (display "warning: could not enable vsync\n"
                 (current-error-port))))
    (dynamic-wind
      (const #t)
      (lambda ()
        (parameterize ((current-kernel kernel)
                       (current-graphics-engine (make-graphics-engine (gl-context kernel)))
                       (current-window (window kernel)))
          (run-game* #:init (lambda ()
                              (activate kernel)
                              (push-scene kernel (thunk)))
                     #:update (lambda (dt) (update-tree kernel dt))
                     #:render (lambda (alpha) (render-tree kernel alpha))
                     #:error (lambda (stack key args)
                               (on-error kernel stack key args))
                     #:time elapsed-time
                     #:update-hz (update-hz kernel))))
      (lambda ()
        (deactivate kernel)
        (quit-audio)
        (sdl2:delete-gl-context! (gl-context kernel))
        (sdl2:close-window! (window kernel))))))

(define-method (current-scene)
  (current-scene (current-kernel)))

(define (reboot-current-scene)
  "Reboot the currently active scene being managed by the game engine
kernel.  A convenient procedure for developers."
  (display "rebooting\n")
  (reboot (current-scene (current-kernel))))

(define-minibuffer-command pause
  (pause (current-scene (current-kernel))))

(define-minibuffer-command resume
  (resume (current-scene (current-kernel))))

(define-minibuffer-command show-fps
  (show (& (current-kernel) fps)))

(define-minibuffer-command hide-fps
  (hide (& (current-kernel) fps)))

(define-minibuffer-command reboot
  (reboot-current-scene))

(define-meta-command ((debug-game starling) repl)
  "debug-game
Enter a debugger for the current game loop error."
  (debugger (& (current-kernel) repl-server)))

(define-meta-command ((resume-game starling) repl)
  "resume-game
Resume the game loop without entering a debugger."
  (set! (repl-debugging? (& (current-kernel) repl-server)) #f))

(define-meta-command ((reboot starling) repl)
  "reboot
Reboot the current scene."
  (reboot-current-scene))