path: root/chickadee.scm

;;; Chickadee Game Toolkit
;;; Copyright © 2018, 2021 David Thompson <dthompson2@worcester.edu>
;;; Copyright © 2020 Peter Elliott <pelliott@ualberta.ca>
;;;
;;; 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:
;;
;; Simple SDL + OpenGL game loop implementation.
;;
;;; Code:

(define-module (chickadee)
  #:use-module (chickadee audio)
  #:use-module (chickadee config)
  #:use-module (chickadee game-loop)
  #:use-module (chickadee math matrix)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics engine)
  #:use-module (chickadee graphics gl)
  #:use-module (chickadee graphics viewport)
  #:use-module (chickadee utils)
  #:use-module (gl)
  #:use-module (gl enums)
  #:use-module (ice-9 atomic)
  #:use-module (ice-9 match)
  #:use-module (sdl2)
  #:use-module (sdl2 events)
  #:use-module ((sdl2 input game-controller) #:prefix sdl2:)
  #:use-module (sdl2 input joystick)
  #:use-module ((sdl2 input keyboard) #:prefix sdl2:)
  #:use-module ((sdl2 input mouse) #:prefix sdl2:)
  #:use-module (sdl2 input text)
  #:use-module ((sdl2 video) #:prefix sdl2:)
  #:use-module (srfi srfi-9)
  #:export (current-window
            window?
            window-width
            window-height
            window-x
            window-y
            window-title
            hide-window!
            show-window!
            maximize-window!
            minimize-window!
            raise-window!
            restore-window!
            set-window-border!
            set-window-title!
            set-window-size!
            set-window-position!
            set-window-fullscreen!
            elapsed-time
            controller-button-pressed?
            controller-button-released?
            controller-axis
            controller-name
            key-pressed?
            key-released?
            mouse-x
            mouse-y
            mouse-button-pressed?
            mouse-button-released?
            warp-mouse
            set-show-cursor!
            run-game)
  #:re-export (abort-game
               current-timestep))

(define %time-freq (exact->inexact internal-time-units-per-second))

(define (elapsed-time)
  "Return the current value of the system timer in seconds."
  (/ (get-internal-real-time) %time-freq))

(define (key-pressed? key)
  "Return #t if KEY is currently being pressed."
  (sdl2:key-pressed? key))

(define (key-released? key)
  "Return #t if KEY is not currently being pressed."
  (sdl2:key-released? key))

(define (mouse-x)
  "Return the current X coordinate of the mouse cursor."
  (sdl2:mouse-x))

(define (mouse-y)
  "Return the current Y coordinate of the mouse cursor."
  (sdl2:mouse-y))

(define (mouse-button-pressed? button)
  "Return #t if BUTTON is currently being pressed."
  (sdl2:mouse-button-pressed? button))

(define (mouse-button-released? button)
  "Return #t if BUTTON is not currently being pressed."
  (sdl2:mouse-button-released? button))

(define (set-show-cursor! show?)
  (sdl2:set-show-cursor! show?))

(define *controllers* (make-hash-table))

(define (lookup-controller joystick-id)
  (hashv-ref *controllers* joystick-id))

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

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

(define (controller-button-pressed? controller button)
  "Return #t if BUTTON is currently being pressed on CONTROLLER."
  (sdl2:game-controller-button-pressed? controller button))

(define (controller-button-released? controller button)
  "Return #t if BUTTON is not currently being pressed on CONTROLLER."
  (not (controller-button-pressed? controller button)))

(define (controller-axis controller axis)
  "Return a floating point value in the range [-1, 1] corresponding to
how much AXIS is being pushed on CONTROLLER.  0 is returned if AXIS is
not being pushed at all."
  (/ (sdl2:game-controller-axis controller axis)
     32768.0))

(define controller-name
  ;; Memoize to avoid repeated allocation of strings via
  ;; pointer->string.
  (memoize
   (lambda (controller)
     (sdl2:game-controller-name controller))))

(define-record-type <window>
  (wrap-window sdl-window gl-context)
  window?
  (sdl-window unwrap-window)
  (gl-context window-gl-context))

(define* (make-window #:key (title "Chickadee") fullscreen? resizable?
                      (width 640) (height 480) (multisample? #t))
  ;; Hint that we want OpenGL 3.2 Core profile.  Doesn't mean we'll
  ;; get it, though!
  (sdl2:set-gl-attribute! 'context-major-version 3)
  (sdl2:set-gl-attribute! 'context-major-version 2)
  (sdl2:set-gl-attribute! 'context-profile-mask 1) ; core profile
  (sdl2:set-gl-attribute! 'stencil-size 8) ; 8-bit stencil buffer
  (if multisample?
      (begin
        (sdl2:set-gl-attribute! 'multisample-buffers 1)
        (sdl2:set-gl-attribute! 'multisample-samples 4))
      (begin
        (sdl2:set-gl-attribute! 'multisample-buffers 0)
        (sdl2:set-gl-attribute! 'multisample-samples 0)))
  (let* ((window (sdl2:make-window #:opengl? #t
                                   #:title title
                                   #:size (list width height)
                                   #:fullscreen? fullscreen?
                                   #:resizable? resizable?))
         (gl-context (sdl2:make-gl-context window)))
    (wrap-window window gl-context)))

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

(define-syntax-rule (define-window-wrapper (name args ...) sdl-proc docstring)
  (define (name window args ...)
    docstring
    (sdl-proc (unwrap-window window) args ...)))

(define-window-wrapper (window-title) sdl2:window-title
  "Return the title of WINDOW.")

(define-window-wrapper (hide-window!) sdl2:hide-window!
  "Hide WINDOW.")

(define-window-wrapper (show-window!) sdl2:show-window!
  "Show WINDOW.")

(define-window-wrapper (maximize-window!) sdl2:maximize-window!
  "Maximize WINDOW.")

(define-window-wrapper (minimize-window!) sdl2:minimize-window!
  "Minimize WINDOW.")

(define-window-wrapper (raise-window!) sdl2:raise-window!
  "Make WINDOW visible over all other windows.")

(define-window-wrapper (restore-window!) sdl2:restore-window!
  "Restore the size and position of a minimized or maximized WINDOW.")

(define-window-wrapper (set-window-border! border?) sdl2:set-window-border!
  "Enable/disable the border around WINDOW.  If BORDER? is #f, the
border is disabled, otherwise it is enabled.")

(define-window-wrapper (set-window-title! title) sdl2:set-window-title!
  "Set the title of WINDOW to TITLE.")

(define-window-wrapper (set-window-fullscreen! fullscreen?) sdl2:set-window-fullscreen!
  "Enable or disable fullscreen mode for WINDOW.  If FULLSCREEN? is
#f, fullscreen mode is disabled, otherwise it is enabled.")

(define (window-width window)
  "Return the width of WINDOW."
  (call-with-values (lambda () (sdl2:window-size (unwrap-window window)))
    (lambda (w h) w)))

(define (window-height window)
  "Return the height of WINDOW."
  (call-with-values (lambda () (sdl2:window-size (unwrap-window window)))
    (lambda (w h) h)))

(define (window-x window)
  "Return the X coordinate of the upper-left corner of WINDOW."
  (call-with-values (lambda () (sdl2:window-position (unwrap-window window)))
    (lambda (x y) x)))

(define (window-y window)
  "Return the Y coordinate of the upper-left corner of WINDOW."
  (call-with-values (lambda () (sdl2:window-position (unwrap-window window)))
    (lambda (x y) y)))

(define (set-window-size! window width height)
  "Change the dimensions of WINDOW to WIDTH x HEIGHT pixels."
  (sdl2:set-window-size! (unwrap-window window) width height))

(define (set-window-position! window x y)
  "Move the upper-left corner of WINDOW to pixel coordinates (X, Y)."
  (sdl2:set-window-position! (unwrap-window window) x y))

(define (warp-mouse x y)
  (sdl2:warp-mouse x y (unwrap-window (current-window))))

(define noop (const #t))

(define* (run-game #:key
                   (window-title "Chickadee!")
                   (window-width 640)
                   (window-height 480)
                   window-fullscreen?
                   window-resizable?
                   (clear-color %default-clear-color)
                   (update-hz 60)
                   (load noop)
                   (update noop)
                   (draw noop)
                   (quit abort-game)
                   (key-press noop)
                   (key-release noop)
                   (text-input noop)
                   (mouse-press noop)
                   (mouse-release noop)
                   (mouse-move noop)
                   (mouse-wheel noop)
                   (controller-add noop)
                   (controller-remove noop)
                   (controller-press noop)
                   (controller-release noop)
                   (controller-move noop)
                   (window-keyboard-enter noop)
                   (window-keyboard-leave noop)
                   (window-mouse-enter noop)
                   (window-mouse-leave noop)
                   (window-show noop)
                   (window-hide noop)
                   (window-minimize noop)
                   (window-maximize noop)
                   (window-move noop)
                   (window-resize noop)
                   error)
  (sdl-init)
  (start-text-input)
  (init-audio)
  ;; We assume here that if window creation fails it is because
  ;; multisampling is not supported and that we need to try again with
  ;; multisampling disabled.  This is obviously hacky but it solves a
  ;; real world user issue and I'm not sure how to test for driver
  ;; features before opening the window.  SDL's display mode
  ;; information doesn't seem to be enough.  Help wanted!
  (let* ((window (or (false-if-exception
                      (make-window #:title window-title
                                   #:width window-width
                                   #:height window-height
                                   #:fullscreen? window-fullscreen?
                                   #:resizable? window-resizable?))
                     (make-window #:title window-title
                                  #:width window-width
                                  #:height window-height
                                  #:fullscreen? window-fullscreen?
                                  #:resizable? window-resizable?
                                  #:multisample? #f)))
         (gfx (make-graphics-engine (window-gl-context window)))
         (default-viewport (make-atomic-box
                            (make-viewport 0 0 window-width window-height
                                           #:clear-color clear-color)))
         (default-projection (make-atomic-box
                              (orthographic-projection 0 window-width
                                                       window-height 0
                                                       0 1))))
    (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.
      (- window-height y))
    (define (input-sdl)
      (define (process-event event)
        (cond
         ((quit-event? event)
          (quit))
         ((keyboard-down-event? event)
          (key-press (keyboard-event-key event)
                     (keyboard-event-modifiers event)
                     (keyboard-event-repeat? event)))
         ((keyboard-up-event? event)
          (key-release (keyboard-event-key event)
                       (keyboard-event-modifiers event)))
         ((text-input-event? event)
          (text-input (text-input-event-text event)))
         ((mouse-button-down-event? event)
          (mouse-press (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)
          (mouse-release (mouse-button-event-button event)
                         (mouse-button-event-x event)
                         (invert-y (mouse-button-event-y event))))
         ((mouse-motion-event? event)
          (mouse-move (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)))
         ((mouse-wheel-event? event)
          (mouse-wheel (mouse-wheel-event-x event)
                       (mouse-wheel-event-y event)))
         ((and (controller-device-event? event)
               (eq? (controller-device-event-action event) 'added))
          (controller-add (add-controller
                           (controller-device-event-which event))))
         ((and (controller-device-event? event)
               (eq? (controller-device-event-action event) 'removed))
          (let ((controller (lookup-controller
                             (controller-device-event-which event))))
            (controller-remove controller)
            (remove-controller (controller-device-event-which event))
            (sdl2:close-game-controller controller)))
         ((controller-button-down-event? event)
          (controller-press (lookup-controller
                             (controller-button-event-which event))
                            (controller-button-event-button event)))
         ((controller-button-up-event? event)
          (controller-release (lookup-controller
                               (controller-button-event-which event))
                              (controller-button-event-button event)))
         ((controller-axis-event? event)
          (controller-move (lookup-controller
                            (controller-axis-event-which event))
                           (controller-axis-event-axis event)
                           (/ (controller-axis-event-value event) 32768.0)))
         ((window-focus-gained-event? event)
          (window-keyboard-enter))
         ((window-focus-lost-event? event)
          (window-keyboard-leave))
         ((window-enter-event? event)
          (window-mouse-enter))
         ((window-leave-event? event)
          (window-mouse-leave))
         ((window-shown-event? event)
          (window-show))
         ((window-hidden-event? event)
          (window-hide))
         ((window-minimized-event? event)
          (window-minimize))
         ((window-maximized-event? event)
          (window-maximize))
         ((window-moved-event? event)
          (match (window-event-vector event)
            ((x y)
             (window-move x y))))
         ((window-size-changed-event? event)
          (match (window-event-vector event)
            ((width height)
             (set! window-width width)
             (set! window-height height)
             (atomic-box-set! default-viewport
                              (make-viewport 0 0 width height
                                             #:clear-color clear-color))
             (atomic-box-set! default-projection
                              (orthographic-projection 0 width height 0 0 1))
             (window-resize width height))))))
      ;; Process all pending events.
      (let loop ((event (poll-event)))
        (when event
          (process-event event)
          (loop (poll-event)))))
    (define (update-sdl dt)
      (input-sdl)
      (update dt)
      ;; Update audio after updating game state so that any sounds
      ;; that were queued to play this frame start playing immediately.
      (update-audio)
      ;; Free any GPU resources that have been GC'd.
      (graphics-engine-reap! gfx))
    (define (render-sdl-opengl alpha)
      (with-graphics-state! ((g:viewport (atomic-box-ref default-viewport)))
        (clear-viewport)
        (with-projection (atomic-box-ref default-projection)
          (draw alpha)))
      (sdl2:swap-gl-window (unwrap-window window)))
    (define (on-error e stack)
      (error e stack)
      ;; Flush all input events that have occurred while in the error
      ;; state.
      (while (poll-event) #t))
    (dynamic-wind
      (const #t)
      (lambda ()
        (parameterize ((current-window window)
                       (current-graphics-engine gfx))
          ;; 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))))
          ;; Turn off multisampling by default.
          (gl-disable (version-1-3 multisample))
          ;; Enable seamless cube maps.
          (gl-enable (version-3-2 texture-cube-map-seamless))
          (sdl2:load-game-controller-mappings!
           (scope-datadir "gamecontrollerdb.txt"))
          (run-game* #:init load
                     #:update update-sdl
                     #:render render-sdl-opengl
                     #:error (and error on-error)
                     #:time elapsed-time
                     #:update-hz update-hz)))
      (lambda ()
        (quit-audio)
        (sdl2:delete-gl-context! (window-gl-context window))
        (sdl2:close-window! (unwrap-window window))))))