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)
  #:use-module ((chickadee graphics backend) #:prefix gpu:)
  #:use-module (chickadee graphics backend opengl)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics pass)
  #:use-module (chickadee graphics texture)
  #: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!
            default-color-texture-view
            default-depth+stencil-texture-view
            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 default-color-texture-view (make-parameter #f))
(define default-depth+stencil-texture-view (make-parameter #f))
(define default-resolve-target (make-parameter #f))

(define* (make-window #:key (title "Chickadee") fullscreen? resizable?
                      (width 640) (height 480))
  (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)
  (let* ((window (make-window #:title window-title
                              #:width window-width
                              #:height window-height
                              #:fullscreen? window-fullscreen?
                              #:resizable? window-resizable?))
         (gpu (make-opengl-gpu (window-gl-context window)
                               (lambda ()
                                 (sdl2:swap-gl-window
                                  (unwrap-window window)))
                               window-width window-height))
         (default-viewport (make-viewport 0 0 window-width window-height))
         (default-projection (orthographic-projection 0 window-width
                                                      window-height 0
                                                      0 1))
         (default-render-pass
           (make-render-pass
            #:color-attachments
            (vector
             (make-color-attachment
              #:view default-color-texture-view
              #:resolve-target default-resolve-target
              #:operation (make-color-operation
                           #:clear-color db32-viking)))
            #:depth+stencil-attachment
            (make-depth+stencil-attachment
             #:view default-depth+stencil-texture-view))))
    (pk (gpu:gpu-description gpu))
    (pk (gpu:gpu-limits gpu))
    (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)
             (refresh-default-texture-views! width height)
             (set! default-viewport (make-viewport 0 0 width height))
             (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))
    (define (draw-frame alpha)
      ((@@ (chickadee graphics) begin-frame))
      (parameterize ((current-viewport default-viewport)
                     (current-projection default-projection)
                     (current-pass default-render-pass))
        (draw alpha))
      ((@@ (chickadee graphics) end-frame) (default-resolve-target)))
    (define (on-error e stack)
      (error e stack)
      ;; Flush all input events that have occurred while in the error
      ;; state.
      (while (poll-event) #t))
    (define (refresh-default-texture-views! width height)
      (let* ((old-color (default-color-texture-view))
             (old-depth+stencil (default-depth+stencil-texture-view))
             (old-resolve-target (default-resolve-target))
             (color-texture (make-texture #:name "Default color texture"
                                          #:width width
                                          #:height height
                                          #:samples 4))
             (color-view (make-texture-view color-texture
                                            #:name "Default color texture view"))
             (depth+stencil-texture (make-texture #:name "Default depth/stencil texture"
                                                  #:width width
                                                  #:height height
                                                  #:format 'depth24plus-stencil8))
             (depth+stencil-view (make-texture-view depth+stencil-texture
                                                    #:name "Default depth/stencil texture view"))
             (resolve-target-texture (make-texture #:name "Default resolve target texture"
                                                   #:width width
                                                   #:height height))
             (resolve-target (make-texture-view resolve-target-texture
                                                #:name "Default resolve target texture view")))
        ;; TODO: Destroy the underlying textures, too?
        (when old-color (destroy-texture-view old-color))
        (when old-depth+stencil (destroy-texture-view old-depth+stencil))
        (when old-resolve-target (destroy-texture-view old-resolve-target))
        (default-color-texture-view color-view)
        (default-depth+stencil-texture-view depth+stencil-view)
        (default-resolve-target resolve-target)))
    (parameterize ((current-window window)
                   (gpu:current-gpu gpu))
      (refresh-default-texture-views! window-width window-height)
      ;; 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))))
      ;; 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 draw-frame
                 #:error (and error on-error)
                 #:time elapsed-time
                 #:update-hz update-hz))
    (quit-audio)
    (sdl2:delete-gl-context! (window-gl-context window))
    (sdl2:close-window! (unwrap-window window))))