path: root/chickadee/graphics/engine.scm

(define-module (chickadee graphics engine)
  #:use-module (chickadee data array-list)
  #:use-module (chickadee graphics gl)
  #:use-module (chickadee math matrix)
  #:use-module (gl)
  #:use-module (ice-9 atomic)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (system foreign)
  #:export (define-graphics-state
            define-graphics-finalizer
            define-graphics-variable
            make-graphics-engine
            graphics-engine?
            graphics-engine-gl-context
            graphics-engine-gl-version
            graphics-engine-glsl-version
            graphics-engine-max-texture-size
            graphics-engine-state-ref
            graphics-variable-ref
            graphics-variable-set!
            graphics-engine-commit!
            graphics-engine-guard!
            graphics-engine-reap!
            current-graphics-engine
            assert-current-graphics-engine
            current-projection
            with-projection
            with-graphics-state
            with-graphics-state!))


;;;
;;; States
;;;

;; A "graphics state" is CPU-side storage for GPU-side state.  The
;; goal is to track changes and minimize the number of GPU state
;; changes (because they are expensive) by only communicating with the
;; GPU when the value really needs updating.

(define-record-type <graphics-state-spec>
  (%make-graphics-state-spec id name default binder)
  graphics-state-spec?
  (id graphics-state-spec-id)
  (name graphics-state-spec-name)
  (default graphics-state-spec-default)
  (binder graphics-state-spec-binder))

(define* (make-graphics-state-spec id name #:key default bind)
  (%make-graphics-state-spec id name default bind))

(define-record-type <graphics-state>
  (%make-graphics-state binder value bound-value dirty? stack)
  graphics-state?
  (binder graphics-state-binder)
  (value graphics-state-ref %graphics-state-set!)
  (bound-value graphics-state-bound-value set-graphics-state-bound-value!)
  (dirty? graphics-state-dirty? set-graphics-state-dirty!)
  (stack graphics-state-stack))

(define (make-graphics-state bind default)
  (%make-graphics-state bind default default #f (make-array-list)))

(define (graphics-state-set! state new-value)
  (graphics-state-binder state) new-value
  (let ((current-value (graphics-state-bound-value state)))
    (%graphics-state-set! state new-value)
    (set-graphics-state-dirty! state (not (eq? new-value current-value)))))

(define (graphics-state-push! state new-value)
  (array-list-push! (graphics-state-stack state) (graphics-state-ref state))
  (graphics-state-set! state new-value))

(define (graphics-state-pop! state)
  (graphics-state-set! state (array-list-pop! (graphics-state-stack state))))

(define (graphics-state-bind-maybe state)
  (when (graphics-state-dirty? state)
    (let ((x (graphics-state-ref state)))
      ((graphics-state-binder state) x)
      (set-graphics-state-bound-value! state x)
      (set-graphics-state-dirty! state #f))))

(define *graphics-states* (make-array-list))

;; Box the counter so the compiler doesn't do constant propagation on
;; it and screw everything up.
(define *graphics-state-id-counter* (vector 0))

(define (next-graphics-state-id)
  (let ((id (vector-ref *graphics-state-id-counter* 0)))
    (vector-set! *graphics-state-id-counter* 0 (+ id 1))
    id))

(define-syntax-rule (define-graphics-state name getter args ...)
  (begin
    (define name
      (let* ((id (next-graphics-state-id))
             (spec (make-graphics-state-spec id 'name args ...)))
        (array-list-push! *graphics-states* spec)
        (when (current-graphics-engine)
          (install-graphics-state (current-graphics-engine) spec))
        spec))
    (define* (getter #:optional (engine (current-graphics-engine)))
      (graphics-engine-state-ref name engine))))


;;;
;;; Finalizers
;;;

;; Graphics finalizers delete GPU-side resources when Guile is ready
;; to GC them.

(define-record-type <graphics-finalizer>
  (%make-graphics-finalizer name predicate free)
  graphics-finalizer?
  (name graphics-finalizer-name)
  (predicate graphics-finalizer-predicate)
  (free graphics-finalizer-free))

(define* (make-graphics-finalizer name #:key predicate free)
  (%make-graphics-finalizer name predicate free))

;; Need to box this value so that the compiler doesn't inline the
;; initial value everywhere.
(define *graphics-finalizers* (make-atomic-box '()))

(define-syntax-rule (define-graphics-finalizer name args ...)
  (define name
    (let ((finalizer (make-graphics-finalizer 'name args ...)))
      (atomic-box-set! *graphics-finalizers*
                       (cons (cons 'name finalizer)
                             (atomic-box-ref *graphics-finalizers*)))
      finalizer)))


;;;
;;; Variables
;;;

;; Graphics variables are a special type of variable storage that is
;; dynamically scoped to the currently active graphics engine.  Their
;; initial values are lazily evaluated upon graphics engine creation.

(define-record-type <graphics-variable>
  (make-graphics-variable name init)
  graphics-variable?
  (name graphics-variable-name)
  (init graphics-variable-init))

(define (eval-graphics-variable var)
  ((graphics-variable-init var)))

(define *graphics-variables* (make-hash-table))

(define-syntax-rule (define-graphics-variable name init-form)
  (define name
    (let ((var (make-graphics-variable 'name (lambda () init-form))))
      (hashq-set! *graphics-variables* var var)
      (when (current-graphics-engine)
        (install-graphics-variable (current-graphics-engine) var))
      var)))


;;;
;;; Engine
;;;

(define-record-type <graphics-engine>
  (%make-graphics-engine gl-context gl-version glsl-version max-texture-size
                         projection-matrix guardian states variables)
  graphics-engine?
  (gl-context %graphics-engine-gl-context)
  (gl-version %graphics-engine-gl-version)
  (glsl-version %graphics-engine-glsl-version)
  (max-texture-size %graphics-engine-max-texture-size)
  (projection-matrix %graphics-engine-projection-matrix
                     %set-graphics-engine-projection-matrix!)
  (guardian graphics-engine-guardian)
  (states graphics-engine-states)
  (variables graphics-engine-variables))

(define (install-graphics-state engine spec)
  (let ((binder (graphics-state-spec-binder spec))
        (default (graphics-state-spec-default spec))
        (states (graphics-engine-states engine))
        (id (graphics-state-spec-id spec)))
    (unless (> (array-list-size states) id)
      (let loop ((i (array-list-size states)))
        (unless (> i id)
          (array-list-push! states #f)
          (loop (+ i 1)))))
    (array-list-set! states id (make-graphics-state binder default))))

(define (install-graphics-variable engine var)
  (hashq-set! (graphics-engine-variables engine)
              var
              (eval-graphics-variable var)))

(define (make-graphics-engine gl-context)
  (define (max-texture-size)
    (let ((bv (make-s32vector 1)))
      (gl-get-integer-v (get-p-name max-texture-size)
                        (bytevector->pointer bv))
      (s32vector-ref bv 0)))
  (define (extract-version attr)
    (car (string-split (pointer->string (gl-get-string attr)) #\space)))
  (define (glsl-version)
    (extract-version (version-2-0 shading-language-version)))
  (let ((engine (%make-graphics-engine gl-context
                                       (extract-version (string-name version))
                                       (glsl-version)
                                       (max-texture-size)
                                       (make-identity-matrix4)
                                       (make-guardian)
                                       (make-array-list)
                                       (make-hash-table))))
    ;; Variable initialization must be delayed until after engine
    ;; creation because variable initializers may modify graphics
    ;; engine state to create shaders, textures, etc.
    (parameterize ((current-graphics-engine engine))
      (array-list-for-each (lambda (i spec)
                             (install-graphics-state engine spec))
                           *graphics-states*)
      (hash-for-each (lambda (key var)
                       (install-graphics-variable engine var))
                     *graphics-variables*))
    engine))

(define current-graphics-engine (make-parameter #f))

(define-syntax-rule (assert-current-graphics-engine)
  (unless (current-graphics-engine)
    (error "No active graphics engine.  Make sure the game loop is running before calling this procedure.")))

(define* (graphics-engine-gl-context #:optional (engine (current-graphics-engine)))
  (%graphics-engine-gl-context engine))

(define* (graphics-engine-gl-version #:optional (engine (current-graphics-engine)))
  (%graphics-engine-gl-version engine))

(define* (graphics-engine-glsl-version #:optional (engine (current-graphics-engine)))
  (%graphics-engine-glsl-version engine))

(define* (graphics-engine-max-texture-size #:optional (engine (current-graphics-engine)))
  (%graphics-engine-max-texture-size engine))

(define* (current-projection #:optional (engine (current-graphics-engine)))
  (%graphics-engine-projection-matrix engine))

(define-syntax-rule (with-projection matrix body ...)
  (let ((old (current-projection)))
    (set-graphics-engine-projection-matrix! matrix)
    (let ((result (begin body ...)))
      (set-graphics-engine-projection-matrix! old)
      result)))

(define* (set-graphics-engine-projection-matrix! matrix #:optional (engine (current-graphics-engine)))
  (%set-graphics-engine-projection-matrix! engine matrix))

(define (graphics-engine-lookup-state engine spec)
  (array-list-ref (graphics-engine-states engine)
                  (graphics-state-spec-id spec)))

(define* (graphics-engine-state-ref spec #:optional
                                    (engine (current-graphics-engine)))
  (let ((state (graphics-engine-lookup-state engine spec)))
    (and state (graphics-state-ref state))))

(define* (graphics-engine-state-push! spec value #:optional
                                      (engine (current-graphics-engine)))
  (graphics-state-push! (graphics-engine-lookup-state engine spec) value))

(define* (graphics-engine-state-pop! spec #:optional
                                     (engine (current-graphics-engine)))
  (graphics-state-pop! (graphics-engine-lookup-state engine spec)))

(define* (graphics-variable-ref var #:optional
                                (engine (current-graphics-engine)))
  (hashq-ref (graphics-engine-variables engine) var))

(define* (graphics-variable-set! var value #:optional
                                        (engine (current-graphics-engine)))
  (hashq-set! (graphics-engine-variables engine) var value))

(define* (graphics-engine-commit! #:optional (engine (current-graphics-engine)))
  (array-list-for-each (lambda (id state)
                         (graphics-state-bind-maybe state))
                       (graphics-engine-states engine)))

(define* (graphics-engine-guard! obj #:optional
                                 (engine (current-graphics-engine)))
  ((graphics-engine-guardian engine) obj))

(define* (graphics-engine-reap! #:optional (engine (current-graphics-engine)))
  (let ((guardian (graphics-engine-guardian engine)))
    (let loop ((obj (guardian)))
      (when obj
        (unless (find (match-lambda
                        ((name . f)
                         (and ((graphics-finalizer-predicate f) obj)
                              ((graphics-finalizer-free f) obj)
                              #t)))
                      (atomic-box-ref *graphics-finalizers*))
          (error "no finalizer for graphics engine object" obj))
        (loop (guardian))))))

(define-syntax-rule (with-graphics-state ((spec value) ...) body ...)
  (dynamic-wind
    (lambda ()
      (graphics-engine-state-push! spec value) ...)
    (lambda ()
      body ...)
    (lambda ()
      (graphics-engine-state-pop! spec) ...)))

(define-syntax-rule (with-graphics-state! ((spec value) ...) body ...)
  (with-graphics-state ((spec value) ...)
    (graphics-engine-commit!)
    body ...))