path: root/chickadee/render/shader.scm

;;; Chickadee Game Toolkit
;;; Copyright © 2016 David Thompson <davet@gnu.org>
;;;
;;; Chickadee 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.
;;;
;;; Chickadee 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 this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

(define-module (chickadee render shader)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 match)
  #:use-module (oop goops)
  #:use-module (system foreign)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-4)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (gl)
  #:use-module (chickadee math matrix)
  #:use-module (chickadee math vector)
  #:use-module (chickadee render color)
  #:use-module (chickadee render gl)
  #:use-module (chickadee render gpu)
  #:use-module (chickadee render texture)
  #:export (make-shader
            shader?
            null-shader
            load-shader
            strings->shader
            shader-uniform
            shader-uniforms
            shader-attributes
            shader-uniform-set!
            uniform?
            uniform-name
            uniform-type
            uniform-value
            attribute?
            attribute-name
            attribute-location
            attribute-type
            *shader-state*))


;;;
;;; Data Types
;;;

(define-record-type <shader-data-type>
  (%make-shader-data-type name size serializer setter null)
  shader-data-type?
  (name shader-data-type-name)
  (size shader-data-type-size)
  (serializer shader-data-type-serializer)
  (setter shader-data-type-setter)
  (null shader-data-type-null))

(define* (make-shader-data-type #:key name size serializer setter null)
  (%make-shader-data-type name size serializer setter null))

(define (shader-data-type-serialize type bv data)
  (let ((serialize (shader-data-type-serializer type)))
    (if (vector? data)
        (let ((size (shader-data-type-size type)))
          (let loop ((i 0))
            (when (< i (vector-length data))
              (serialize bv (* i size) (vector-ref data i))
              (loop (+ i 1)))))
        (serialize bv 0 data))))

(define (shader-data-type-apply-uniform type location count pointer)
  ((shader-data-type-setter type) location count pointer))

;; Primitive types:
(define %bool
  (make-shader-data-type
   #:name 'bool
   #:size 4
   #:serializer
   (lambda (bv i bool)
     (bytevector-s32-native-set! bv i (if bool 1 0)))
   #:setter gl-uniform1iv
   #:null #false))

(define %int
  (make-shader-data-type
   #:name 'int
   #:size 4
   #:serializer
   (lambda (bv i n)
     (bytevector-s32-native-set! bv i n))
   #:setter gl-uniform1iv
   #:null 0))

(define %unsigned-int
  (make-shader-data-type
   #:name 'unsigned-int
   #:size 4
   #:serializer
   (lambda (bv i u)
     (bytevector-u32-native-set! bv i u))
   #:setter gl-uniform1uiv
   #:null 0))

(define %float
  (make-shader-data-type
   #:name 'float
   #:size 4
   #:serializer
   (lambda (bv i f)
     (bytevector-ieee-single-native-set! bv i f))
   #:setter gl-uniform1fv
   #:null 0.0))

(define %float-vec2
  (make-shader-data-type
   #:name 'float-vec2
   #:size 8 ; 8 bytes = 2 floats = 1 vec2
   #:serializer
   (let ((unwrap-vec2 (@@ (chickadee math vector) unwrap-vec2)))
     (lambda (bv i v)
       (bytevector-copy! (unwrap-vec2 v) 0 bv i 8)))
   #:setter gl-uniform2fv
   #:null (vec2 0.0 0.0)))

(define %float-vec3
  (make-shader-data-type
   #:name 'float-vec3
   #:size 12 ; 12 bytes = 3 floats = 1 vec3
   #:serializer
   (let ((unwrap-vec3 (@@ (chickadee math vector) unwrap-vec3)))
     (lambda (bv i v)
       (bytevector-copy! (unwrap-vec3 v) 0 bv i 12)))
   #:setter gl-uniform3fv
   #:null (vec3 0.0 0.0 0.0)))

(define %float-vec4
  (make-shader-data-type
   #:name 'float-vec4
   #:size 16 ; 16 bytes = 4 floats = 1 vec4
   #:serializer
   (lambda (bv i v)
     ;; As of now, there is no vec4 Scheme type, but we do want to
     ;; accept colors as vec4s since there is no special color type in
     ;; GLSL.
     (bytevector-ieee-single-native-set! bv i (color-r v))
     (bytevector-ieee-single-native-set! bv (+ i 4) (color-g v))
     (bytevector-ieee-single-native-set! bv (+ i 8) (color-b v))
     (bytevector-ieee-single-native-set! bv (+ i 12) (color-a v)))
   #:setter gl-uniform4fv
   #:null (color 0.0 0.0 0.0 0.0)))

(define %mat4
  (make-shader-data-type
   #:name 'mat4
   #:size 64 ; 4 rows x 4 columns = 16 floats x 4 bytes each = 64 bytes
   #:serializer
   (let ((matrix4-bv (@@ (chickadee math matrix) matrix4-bv)))
     (lambda (bv i m)
       ;; 4 rows x 4 columns x 4 bytes per float = 4^3
       (bytevector-copy! (matrix4-bv m) 0 bv i (* 4 4 4))))
   #:setter (lambda (location count ptr)
              (gl-uniform-matrix4fv location count #f ptr))
   #:null (make-identity-matrix4)))

(define %sampler-2d
  (make-shader-data-type
   #:name 'sampler-2d
   #:size 4
   #:serializer
   (lambda (bv i texture-unit)
     (bytevector-s32-native-set! bv i texture-unit))
   #:setter gl-uniform1iv
   #:null 0))


;;;
;;; Shaders
;;;

(define-record-type <shader>
  (%make-shader id attributes uniforms scratch scratch-pointer)
  shader?
  (id shader-id)
  (attributes shader-attributes)
  (uniforms shader-uniforms)
  ;; Scratch space for serializing uniform values.
  (scratch shader-scratch)
  ;; Create the pointer once and hold onto it to reduce needless
  ;; garbage creation.
  (scratch-pointer shader-scratch-pointer))

(define-record-type <uniform>
  (make-uniform name location type size value)
  uniform?
  (name uniform-name)
  (location uniform-location)
  (type uniform-type)
  (size uniform-size)
  (value uniform-value %set-uniform-value!))

(define-record-type <attribute>
  (make-attribute name location type)
  attribute?
  (name attribute-name)
  (location attribute-location)
  (type attribute-type))

(define null-shader (%make-shader 0 (make-hash-table) (make-hash-table) #f #f))

(define <<shader>> (class-of null-shader))

(define-method (gpu-finalize (shader <<shader>>))
  (gl-delete-program (shader-id shader)))

(define (apply-shader shader)
  (gl-use-program (shader-id shader)))

(define *shader-state* (make-gpu-state apply-shader null-shader))

(define (make-shader vertex-port fragment-port)
  "Read GLSL source from VERTEX-PORT and FRAGMENT-PORT and compile
them into a GPU shader program."
  (define (shader-compiled? id)
    (let ((status (make-u32vector 1)))
      (gl-get-shaderiv id (version-2-0 compile-status)
                       (bytevector->pointer status))
      (= (u32vector-ref status 0) 1)))
  (define (shader-linked? id)
    (let ((status (make-u32vector 1)))
      (gl-get-programiv id (version-2-0 link-status)
                        (bytevector->pointer status))
      (= (u32vector-ref status 0) 1)))
  (define (info-log length-proc log-proc id)
    (let ((log-length-bv (make-u32vector 1)))
      (length-proc id (version-2-0 info-log-length)
                   (bytevector->pointer log-length-bv))
      (u32vector-ref log-length-bv 0)
      ;; Add one byte to account for the null string terminator.
      (let* ((log-length (u32vector-ref log-length-bv 0))
             (log (make-u8vector (1+ log-length))))
        (log-proc id log-length %null-pointer (bytevector->pointer log))
        (utf8->string log))))
  (define (compilation-error id)
    (info-log gl-get-shaderiv gl-get-shader-info-log id))
  (define (linking-error id)
    (info-log gl-get-programiv gl-get-program-info-log id))
  (define (make-shader-stage type port)
    (let ((id (gl-create-shader type))
          (source (get-bytevector-all port)))
      (gl-shader-source id 1
                        (bytevector->pointer
                         (u64vector
                          (pointer-address (bytevector->pointer source))))
                        (bytevector->pointer
                         (u32vector (bytevector-length source))))
      (gl-compile-shader id)
      (unless (shader-compiled? id)
        (let ((error-log (compilation-error id)))
          (gl-delete-shader id) ; clean up GPU resource.
          (display "shader compilation failed:\n")
          (display error-log (current-error-port))
          (error "failed to compile shader")))
      id))
  (define (uniform-count id)
    (let ((bv (make-u32vector 1)))
      (gl-get-programiv id
                        (arb-shader-objects active-uniforms)
                        (bytevector->pointer bv))
      (u32vector-ref bv 0)))
  (define (utf8->string* bv length)
    (let ((bv* (make-bytevector length)))
      (bytevector-copy! bv 0 bv* 0 length)
      (utf8->string bv*)))
  (define (parse-data-type type)
    (cond
     ((= type (version-2-0 bool)) %bool)
     ((= type (data-type int)) %int)
     ((= type (data-type unsigned-int)) %unsigned-int)
     ((= type (data-type float)) %float)
     ((= type (version-2-0 float-vec2)) %float-vec2)
     ((= type (version-2-0 float-vec3)) %float-vec3)
     ((= type (version-2-0 float-vec4)) %float-vec4)
     ((= type (version-2-0 float-mat4)) %mat4)
     ((= type (version-2-0 sampler-2d)) %sampler-2d)
     (else
      (error "unsupported OpenGL type" type))))
  (define (parse-name name)
    ;; Primitive array uniform names have a suffix of "[0]" that needs
    ;; to be removed to produce the actual uniform variable name.
    (if (string-suffix? "[0]" name)
        (substring name 0 (- (string-length name) 3))
        name))
  (define (extract-uniforms id)
    (let ((total (uniform-count id))
          (table (make-hash-table)))
      (let loop ((i 0)
                 (texture-unit 0)
                 (scratch-size 0))
        (if (< i total)
            (let ((length-bv (make-u32vector 1))
                  (size-bv (make-u32vector 1))
                  (type-bv (make-u32vector 1))
                  (name-bv (make-bytevector 255)))
              (gl-get-active-uniform id i
                                     (bytevector-length name-bv)
                                     (bytevector->pointer length-bv)
                                     (bytevector->pointer size-bv)
                                     (bytevector->pointer type-bv)
                                     (bytevector->pointer name-bv))
              (let* ((name-length (u32vector-ref length-bv 0))
                     (name (utf8->string* name-bv name-length))
                     (location (gl-get-uniform-location id name))
                     (size (u32vector-ref size-bv 0))
                     (type (parse-data-type (u32vector-ref type-bv 0)))
                     (sampler? (eq? type %sampler-2d))
                     (default (if sampler?
                                  texture-unit
                                  (shader-data-type-null type))))
                (hash-set! table
                           (parse-name name)
                           (make-uniform name location type size default))
                (loop (1+ i)
                      (if sampler?
                          (1+ texture-unit)
                          texture-unit)
                      (max scratch-size
                           (* size
                              (shader-data-type-size type))))))
            (values table scratch-size)))))
  (define (attribute-count id)
    (let ((bv (make-u32vector 1)))
      (gl-get-programiv id
                        (arb-shader-objects active-attributes)
                        (bytevector->pointer bv))
      (u32vector-ref bv 0)))
  (define (extract-attributes id)
    (let ((total (attribute-count id))
          (table (make-hash-table)))
      (let loop ((i 0))
        (unless (= i total)
          (let ((length-bv (make-u32vector 1))
                (size-bv (make-u32vector 1))
                (type-bv (make-u32vector 1))
                (name-bv (make-bytevector 255)))
            (gl-get-active-attrib id i
                                  (bytevector-length name-bv)
                                  (bytevector->pointer length-bv)
                                  (bytevector->pointer size-bv)
                                  (bytevector->pointer type-bv)
                                  (bytevector->pointer name-bv))
            (let* ((length (u32vector-ref length-bv 0))
                   (name (utf8->string* name-bv length))
                   (size (u32vector-ref size-bv 0))
                   (type (parse-data-type (u32vector-ref type-bv 0)))
                   (location (gl-get-attrib-location id name)))
              (unless (= size 1)
                (error "unsupported attribute size" name size))
              (hash-set! table name (make-attribute name location type))))
          (loop (1+ i))))
      table))
  (let ((vertex-id (make-shader-stage (version-2-0 vertex-shader)
                                      vertex-port))
        (fragment-id (make-shader-stage (version-2-0 fragment-shader)
                                        fragment-port))
        (id (gl-create-program)))
    (gl-attach-shader id vertex-id)
    (gl-attach-shader id fragment-id)
    (gl-link-program id)
    (unless (shader-linked? id)
      (let ((error-log (linking-error id)))
        (gl-delete-program id)
        (error "failed to link shader" error-log)))
    (gl-delete-shader vertex-id)
    (gl-delete-shader fragment-id)
    (call-with-values
        (lambda () (extract-uniforms id))
      (lambda (uniforms scratch-size)
        (let ((scratch (make-bytevector scratch-size)))
          (gpu-guard
           (%make-shader id (extract-attributes id) uniforms
                         scratch (bytevector->pointer scratch))))))))

(define (load-shader vertex-source-file fragment-source-file)
  "Compile the GLSL source code within VERTEX-SOURCE-FILE and
FRAGMENT-SOURCE-FILE into a GPU shader program."
  (call-with-input-file vertex-source-file
    (lambda (vertex-port)
      (call-with-input-file fragment-source-file
        (lambda (fragment-port)
          (make-shader vertex-port fragment-port))))))

(define (strings->shader vertex-source fragment-source)
  "Compile VERTEX-SOURCE, the GLSL code for the vertex shader,
and FRAGMENT-SOURCE, the GLSL code for the fragment shader, into a GPU
shader program."
  (call-with-input-string vertex-source
    (lambda (vertex-port)
      (call-with-input-string fragment-source
        (lambda (fragment-port)
          (make-shader vertex-port fragment-port))))))

(define (shader-uniform shader name)
  "Return the metadata for the uniform NAME in SHADER."
  (let ((uniform (hash-ref (shader-uniforms shader) name)))
    (or uniform (error "no such uniform" name))))

(define (shader-uniform-set! shader uniform-name x)
  (let* ((uniform (shader-uniform shader uniform-name))
         (type (uniform-type uniform)))
    (when (and (> (uniform-size uniform) 1)
               (not (= (uniform-size uniform) (vector-length x))))
      (error "vector size mismatch for uniform" uniform-name))
    ;; TODO: Figure out a way to avoid unnecessary uniform updates.
    (shader-data-type-serialize type (shader-scratch shader) x)
    (shader-data-type-apply-uniform type (uniform-location uniform) 1 (shader-scratch-pointer shader))
    (%set-uniform-value! uniform x)))