path: root/chickadee/graphics/engine.scm

(define-module (chickadee graphics engine)
  #:use-module (chickadee data array-list)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics gpu)
  #: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-variable
            make-graphics-engine
            graphics-engine?
            graphics-engine-gpu
            graphics-engine-glsl-version
            graphics-engine-max-texture-size
            graphics-engine-context
            graphics-variable-ref
            graphics-variable-set!
            graphics-engine-reset!
            graphics-engine-commit!
            graphics-engine-gc
            current-graphics-engine
            current-gpu
            current-projection
            current-viewport
            assert-current-graphics-engine
            with-graphics-state
            with-graphics-state!))


;;;
;;; 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)))


;;;
;;; Render Context
;;;

(define-record-type <render-context>
  (%make-render-context textures)
  render-context?
  (projection render-context-projection set-render-context-projection!)
  (front-face render-context-front-face set-render-context-front-face!)
  (blend-mode render-context-blend-mode set-render-context-blend-mode!)
  (cull-face-mode render-context-cull-face-mode set-render-context-cull-face-mode!)
  (polygon-mode render-context-polygon-mode set-render-context-polygon-mode!)
  (color-mask render-context-color-mask set-render-context-color-mask!)
  (depth-test render-context-depth-test set-render-context-depth-test!)
  (stencil-test render-context-stencil-test set-render-context-stencil-test!)
  (scissor-test render-context-scissor-test set-render-context-scissor-test!)
  (viewport render-context-viewport set-render-context-viewport!)
  (clear-color render-context-clear-color set-render-context-clear-color!)
  (multisample? render-context-multisample? set-render-context-multisample!)
  (framebuffer render-context-framebuffer set-render-context-framebuffer!)
  (vertex-array render-context-vertex-array set-render-context-vertex-array!)
  (buffer render-context-buffer set-render-context-buffer!)
  (program render-context-program set-render-context-program!)
  (textures render-context-textures))

(define (make-render-context n-textures)
  (let ((context (%make-render-context (make-vector n-textures))))
    (render-context-reset! context)
    context))

(define (render-context-texture context i)
  (vector-ref (render-context-textures context) i))

(define (set-render-context-texture! context i texture)
  (vector-set! (render-context-textures context) i texture))

(define %identity-matrix (make-identity-matrix4))

(define (render-context-reset! context)
  (set-render-context-projection! context %identity-matrix)
  (set-render-context-front-face! context front-face:ccw)
  (set-render-context-blend-mode! context blend:replace)
  (set-render-context-cull-face-mode! context cull-face:back)
  (set-render-context-polygon-mode! context polygon:fill)
  (set-render-context-color-mask! context color-mask:all)
  (set-render-context-depth-test! context #f)
  (set-render-context-stencil-test! context #f)
  (set-render-context-scissor-test! context #f)
  (set-render-context-viewport! context window-rect:empty)
  (set-render-context-clear-color! context black)
  (set-render-context-multisample! context #f)
  (set-render-context-framebuffer! context gpu-framebuffer:null)
  (set-render-context-buffer! context gpu-buffer:null)
  (set-render-context-vertex-array! context gpu-vertex-array:null)
  (set-render-context-program! context gpu-program:null)
  (let ((textures (render-context-textures context)))
    (let loop ((i 0))
      (when (< i (vector-length textures))
        (set-render-context-texture! context i gpu-texture:null)
        (loop (+ i 1))))))

(define (render-context-apply! context gpu)
  (set-gpu-front-face! gpu (render-context-front-face context))
  (set-gpu-blend-mode! gpu (render-context-blend-mode context))
  (set-gpu-cull-face-mode! gpu (render-context-cull-face-mode context))
  (set-gpu-polygon-mode! gpu (render-context-polygon-mode context))
  (set-gpu-color-mask! gpu (render-context-color-mask context))
  (set-gpu-depth-test! gpu (render-context-depth-test context))
  (set-gpu-stencil-test! gpu (render-context-stencil-test context))
  (set-gpu-scissor-test! gpu (render-context-scissor-test context))
  (set-gpu-viewport! gpu (render-context-viewport context))
  (set-gpu-clear-color! gpu (render-context-clear-color context))
  (set-gpu-multisample! gpu (render-context-multisample? context))
  (set-gpu-framebuffer! gpu (render-context-framebuffer context))
  (set-gpu-buffer! gpu (render-context-buffer context))
  (set-gpu-vertex-array! gpu (render-context-vertex-array context))
  (set-gpu-program! gpu (render-context-program context))
  (let ((textures (render-context-textures context)))
    (let loop ((i 0))
      (when (< i (vector-length textures))
        (set-gpu-texture! gpu i (vector-ref textures i))
        (loop (+ i 1))))))


;;;
;;; Engine
;;;

(define-record-type <graphics-engine>
  (%make-graphics-engine gpu context variables)
  graphics-engine?
  (gpu graphics-engine-gpu)
  (context graphics-engine-context)
  (variables graphics-engine-variables))

(define (graphics-engine-glsl-version engine)
  (gpu-glsl-version (graphics-engine-gpu engine)))

(define (graphics-engine-max-texture-size engine)
  (gpu-max-texture-size (graphics-engine-gpu engine)))

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

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

(define (current-gpu)
  (graphics-engine-gpu (current-graphics-engine)))

(define (current-projection)
  (render-context-projection
   (graphics-engine-context
    (current-graphics-engine))))

(define (current-viewport)
  (render-context-viewport
   (graphics-engine-context
    (current-graphics-engine))))

(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 (make-graphics-engine gpu)
  (let* ((context (make-render-context (gpu-max-texture-units gpu)))
         (engine (%make-graphics-engine gpu context (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))
      (hash-for-each (lambda (key var)
                       (install-graphics-variable engine var))
                     *graphics-variables*))
    engine))

(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-reset! engine)
  (gpu-reset! (graphics-engine-gpu engine))
  (render-context-reset! (graphics-engine-context engine)))

(define (graphics-engine-commit! engine)
  (render-context-apply! (graphics-engine-context engine)
                         (graphics-engine-gpu engine)))

(define (graphics-engine-gc engine)
  (gpu-gc (graphics-engine-gpu engine)))

;; (define-syntax context-getter
;;   (syntax-rules (projection front-face blend-mode cull-face-mode polygon-mode
;;                             color-mask depth-test stencil-test scissor-test
;;                             viewport clear-color multisample? framebuffer
;;                             vertex-array program)
;;     ((_ projection) render-context-projection)
;;     ((_ front-face) render-context-front-face)
;;     ((_ blend-mode) render-context-blend-mode)
;;     ((_ cull-face-mode) render-context-cull-face-mode)
;;     ((_ polygon-mode) render-context-polygon-mode)
;;     ((_ color-mask) render-context-color-mask)
;;     ((_ depth-test) render-context-depth-test)
;;     ((_ stencil-test) render-context-stencil-test)
;;     ((_ scissor-test) render-context-scissor-test)
;;     ((_ viewport) render-context-viewport)
;;     ((_ clear-color) render-context-clear-color)
;;     ((_ multisample?) render-context-multisample?)
;;     ((_ framebuffer) render-context-framebuffer)
;;     ((_ vertex-array) render-context-vertex-array)
;;     ((_ program) render-context-program)))

;; (define-syntax context-setter
;;   (syntax-rules (projection front-face blend-mode cull-face-mode polygon-mode
;;                             color-mask depth-test stencil-test scissor-test
;;                             viewport clear-color multisample? framebuffer
;;                             vertex-array program)
;;     ((_ projection) set-render-context-projection!)
;;     ((_ front-face) set-render-context-front-face!)
;;     ((_ blend-mode) set-render-context-blend-mode!)
;;     ((_ cull-face-mode) set-render-context-cull-face-mode!)
;;     ((_ polygon-mode) set-render-context-polygon-mode!)
;;     ((_ color-mask) set-render-context-color-mask!)
;;     ((_ depth-test) set-render-context-depth-test!)
;;     ((_ stencil-test) set-render-context-stencil-test!)
;;     ((_ scissor-test) set-render-context-scissor-test!)
;;     ((_ viewport) set-render-context-viewport!)
;;     ((_ clear-color) set-render-context-clear-color!)
;;     ((_ multisample?) set-render-context-multisample!)
;;     ((_ framebuffer) set-render-context-framebuffer!)
;;     ((_ vertex-array) set-render-context-vertex-array!)
;;     ((_ program) set-render-context-program!)))

;; (define-syntax current-state
;;   (syntax-rules (projection front-face blend-mode cull-face-mode polygon-mode
;;                             color-mask depth-test stencil-test scissor-test
;;                             viewport clear-color multisample? framebuffer
;;                             vertex-array program)
;;     ((_ context projection)
;;      (render-context-projection context))
;;     ((_ context front-face)
;;      (render-context-front-face context))
;;     ((_ context blend-mode)
;;      (render-context-blend-mode context))
;;     ((_ context cull-face-mode)
;;      (render-context-cull-face-mode context))
;;     ((_ context polygon-mode)
;;      (render-context-polygon-mode context))
;;     ((_ context color-mask)
;;      (render-context-color-mask context))
;;     ((_ context depth-test)
;;      (render-context-depth-test context))
;;     ((_ context stencil-test)
;;      (render-context-stencil-test context))
;;     ((_ context scissor-test)
;;      (render-context-scissor-test context))
;;     ((_ context viewport)
;;      (render-context-viewport context))
;;     ((_ context clear-color)
;;      (render-context-clear-color context))
;;     ((_ context multisample?)
;;      (render-context-multisample? context))
;;     ((_ context framebuffer)
;;      (render-context-framebuffer context))
;;     ((_ context vertex-array)
;;      (render-context-vertex-array context))
;;     ((_ context program)
;;      (render-context-program context))))

;; (define-syntax change-state
;;   (syntax-rules (projection front-face blend-mode cull-face-mode polygon-mode
;;                             color-mask depth-test stencil-test scissor-test
;;                             viewport clear-color multisample? framebuffer
;;                             vertex-array program)
;;     ((_ context projection new)
;;      (set-render-context-projection! context new))
;;     ((_ context front-face new)
;;      (set-render-context-front-face! context new))
;;     ((_ context blend-mode new)
;;      (set-render-context-blend-mode! context new))
;;     ((_ context cull-face-mode new)
;;      (set-render-context-cull-face-mode! context new))
;;     ((_ context polygon-mode new)
;;      (set-render-context-polygon-mode! context new))
;;     ((_ context color-mask new)
;;      (set-render-context-color-mask! context new))
;;     ((_ context depth-test new)
;;      (set-render-context-depth-test! context new))
;;     ((_ context stencil-test new)
;;      (set-render-context-stencil-test! context new))
;;     ((_ context scissor-test new)
;;      (set-render-context-scissor-test! context new))
;;     ((_ context viewport new)
;;      (set-render-context-viewport! context new))
;;     ((_ context clear-color new)
;;      (set-render-context-clear-color! context new))
;;     ((_ context multisample? new)
;;      (set-render-context-multisample?! context new))
;;     ((_ context framebuffer new)
;;      (set-render-context-framebuffer! context new))
;;     ((_ context vertex-array new)
;;      (set-render-context-vertex-array! context new))
;;     ((_ context program new)
;;      (set-render-context-program! context new))))

;; (define-syntax %with-graphics-state
;;   (syntax-rules (projection front-face blend-mode cull-face-mode polygon-mode
;;                             color-mask depth-test stencil-test scissor-test
;;                             viewport clear-color multisample? framebuffer
;;                             vertex-array program texture)
;;     ((_ context () body ...)
;;      (begin body ...))
;;     ((_ context ((texture i new) . rest) body ...)
;;      (let ((old (render-context-texture context i)))
;;        (set-render-context-texture! context i new)
;;        (%with-graphics-state context rest body ...)
;;        (set-render-context-texture! context i old)))
;;     ((_ context ((param new) . rest) body ...)
;;      (let ((old ((context-getter param) context)))
;;        ((context-setter param) context new)
;;        (%with-graphics-state context rest body ...)
;;        ((context-setter param) context old)))))

(define-syntax context-getter
  (lambda (x)
    (syntax-case x ()
      ((_ name)
       (match (syntax->datum #'name)
         ('projection #'render-context-projection)
         ('front-face #'render-context-front-face)
         ('blend-mode #'render-context-blend-mode)
         ('cull-face-mode #'render-context-cull-face-mode)
         ('polygon-mode #'render-context-polygon-mode)
         ('color-mask #'render-context-color-mask)
         ('depth-test #'render-context-depth-test)
         ('stencil-test #'render-context-stencil-test)
         ('scissor-test #'render-context-scissor-test)
         ('viewport #'render-context-viewport)
         ('clear-color #'render-context-clear-color)
         ('multisample? #'render-context-multisample?)
         ('framebuffer #'render-context-framebuffer)
         ('buffer #'render-context-buffer)
         ('vertex-array #'render-context-vertex-array)
         ('program #'render-context-program))))))

(define-syntax context-setter
  (lambda (x)
    (syntax-case x ()
      ((_ name)
       (match (syntax->datum #'name)
         ('projection #'set-render-context-projection!)
         ('front-face #'set-render-context-front-face!)
         ('blend-mode #'set-render-context-blend-mode!)
         ('cull-face-mode #'set-render-context-cull-face-mode!)
         ('polygon-mode #'set-render-context-polygon-mode!)
         ('color-mask #'set-render-context-color-mask!)
         ('depth-test #'set-render-context-depth-test!)
         ('stencil-test #'set-render-context-stencil-test!)
         ('scissor-test #'set-render-context-scissor-test!)
         ('viewport #'set-render-context-viewport!)
         ('clear-color #'set-render-context-clear-color!)
         ('multisample? #'set-render-context-multisample!)
         ('framebuffer #'set-render-context-framebuffer!)
         ('buffer #'set-render-context-buffer!)
         ('vertex-array #'set-render-context-vertex-array!)
         ('program #'set-render-context-program!))))))

(define-syntax %with-graphics-state
  (lambda (x)
    (syntax-case x ()
      ((_ context () body ...)
       #'(let () body ...))
      ((_ context ((name i new) . rest) body ...)
       (and (identifier? #'name) (eq? (syntax->datum #'name) 'texture))
       #'(let ((old (render-context-texture context i)))
           (set-render-context-texture! context i new)
           (let ((result (%with-graphics-state context rest body ...)))
             (set-render-context-texture! context i old)
             result)))
      ((_ context ((name new) . rest) body ...)
       (identifier? #'name)
       #'(let ((old ((context-getter name) context)))
           ((context-setter name) context new)
           (let ((result (%with-graphics-state context rest body ...)))
             ((context-setter name) context old)
             result))))))

(define-syntax-rule (with-graphics-state settings body ...)
  (let ((context (graphics-engine-context (current-graphics-engine))))
    (%with-graphics-state context settings body ...)))

(define-syntax-rule (with-graphics-state! settings body ...)
  (let* ((engine (current-graphics-engine))
         (context (graphics-engine-context engine)))
    (%with-graphics-state context settings
                          (let ()
                            (graphics-engine-commit! engine)
                            body ...))))