path: root/lisparuga/kernel.scm

;;; Lisparuga
;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu>
;;;
;;; Lisparuga 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.
;;;
;;; Lisparuga 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 Lisparuga.  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 (lisparuga kernel)
  #:use-module (chickadee audio)
  #:use-module (chickadee game-loop)
  #:use-module (chickadee render)
  #:use-module (chickadee render gpu)
  #:use-module (chickadee render viewport)
  #:use-module (gl)
  #:use-module (ice-9 match)
  #:use-module (oop goops)
  #:use-module (sdl2)
  #:use-module (sdl2 events)
  #:use-module (sdl2 input game-controller)
  #:use-module (sdl2 input joystick)
  #:use-module (sdl2 input text)
  #:use-module ((sdl2 video) #:prefix sdl2:)
  #:use-module (lisparuga asset)
  #:use-module (lisparuga config)
  #:use-module (lisparuga node)
  #:use-module (lisparuga repl)
  #:use-module (lisparuga scene)
  #: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
            elapsed-time
            fps
            reboot-current-scene)
  #:re-export (abort-game))

(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 "Lisparuga"
         #:init-keyword #:title)
  (fullscreen? #:accessor window-fullscreen? #:init-form #f
               #:init-keyword #:fullscreen?))

(define-class <kernel> (<scene-mux>)
  (name #:accessor name #:init-form "lisparuga-kernel"
        #:init-keyword #:name)
  (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))

(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)
    ;; Start REPL server.
    (attach-to kernel (make <repl> #:name 'repl))))

(define-method (on-key-press (kernel <kernel>) key scancode modifiers repeat?)
  ;; Hot keys when in dev mode
  (when developer-mode?
    (match key
      ('f5 (reboot-current-scene))
      ('escape (abort-game))
      (_ #t)))
  (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.
    (match (sdl2:window-size (window kernel))
      ((_ 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-scancode event)
                    (keyboard-event-modifiers event)
                    (keyboard-event-repeat? event)))
     ((keyboard-up-event? event)
      (on-key-release kernel
                      (keyboard-event-key event)
                      (keyboard-event-scancode 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.
  (gpu-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-viewport (default-viewport kernel)
      (clear-screen)
      (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) stack key args)
        (sdl2:set-window-title! (window kernel) title))
      (apply throw key args)))

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

(define (elapsed-time)
  (sdl-ticks))

(define-method (fps kernel)
  (/ 1000.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-gpu (make-gpu (gl-context kernel))))
          (activate kernel)
          (push-scene kernel (thunk))
          (run-game* #: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 (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-meta-command ((debug-game lisparuga) repl)
  "debug-game
Enter a debugger for the current game loop error."
  (debugger (& (current-kernel) repl)))

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

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