extra/opengl/shaders/shaders.factor

   1 ! Copyright (C) 2008 Joe Groff.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel opengl.gl alien.c-types continuations namespaces
   4 assocs alien libc opengl math sequences combinators.lib
   5 macros arrays ;
   6 IN: opengl.shaders
   7
   8 : with-gl-shader-source-ptr ( string quot -- )
   9     swap string>char-alien malloc-byte-array [
  10         <void*> swap call
  11     ] keep free ; inline
  12
  13 : <gl-shader> ( source kind -- shader )
  14     glCreateShader dup rot
  15     [ 1 swap f glShaderSource ] with-gl-shader-source-ptr
  16     [ glCompileShader ] keep
  17     gl-error ;
  18
  19 : (gl-shader?) ( object -- ? )
  20     dup integer? [ glIsShader c-bool> ] [ drop f ] if ;
  21
  22 : gl-shader-get-int ( shader enum -- value )
  23     0 <int> [ glGetShaderiv ] keep *int ;
  24
  25 : gl-shader-ok? ( shader -- ? )
  26     GL_COMPILE_STATUS gl-shader-get-int c-bool> ;
  27
  28 : <vertex-shader> ( source -- vertex-shader )
  29     GL_VERTEX_SHADER <gl-shader> ; inline
  30
  31 : (vertex-shader?) ( object -- ? )
  32     dup (gl-shader?)
  33     [ GL_SHADER_TYPE gl-shader-get-int GL_VERTEX_SHADER = ]
  34     [ drop f ] if ;
  35
  36 : <fragment-shader> ( source -- fragment-shader )
  37     GL_FRAGMENT_SHADER <gl-shader> ; inline
  38
  39 : (fragment-shader?) ( object -- ? )
  40     dup (gl-shader?)
  41     [ GL_SHADER_TYPE gl-shader-get-int GL_FRAGMENT_SHADER = ]
  42     [ drop f ] if ;
  43
  44 : gl-shader-info-log-length ( shader -- log-length )
  45     GL_INFO_LOG_LENGTH gl-shader-get-int ; inline
  46
  47 : gl-shader-info-log ( shader -- log )
  48     dup gl-shader-info-log-length dup [
  49         [ 0 <int> swap glGetShaderInfoLog ] keep
  50         alien>char-string
  51     ] with-malloc ;
  52
  53 : check-gl-shader ( shader -- shader )
  54     dup gl-shader-ok? [ dup gl-shader-info-log throw ] unless ;
  55
  56 : delete-gl-shader ( shader -- ) glDeleteShader ; inline
  57
  58 PREDICATE: integer gl-shader (gl-shader?) ;
  59 PREDICATE: gl-shader vertex-shader (vertex-shader?) ;
  60 PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
  61
  62 ! Programs
  63
  64 : <gl-program> ( shaders -- program )
  65     glCreateProgram swap
  66     [ dupd glAttachShader ] each
  67     [ glLinkProgram ] keep
  68     gl-error ;
  69
  70 : (gl-program?) ( object -- ? )
  71     dup integer? [ glIsProgram c-bool> ] [ drop f ] if ;
  72
  73 : gl-program-get-int ( program enum -- value )
  74     0 <int> [ glGetProgramiv ] keep *int ;
  75
  76 : gl-program-ok? ( program -- ? )
  77     GL_LINK_STATUS gl-program-get-int c-bool> ;
  78
  79 : gl-program-info-log-length ( program -- log-length )
  80     GL_INFO_LOG_LENGTH gl-program-get-int ; inline
  81
  82 : gl-program-info-log ( program -- log )
  83     dup gl-program-info-log-length dup [
  84         [ 0 <int> swap glGetProgramInfoLog ] keep
  85         alien>char-string
  86     ] with-malloc ;
  87
  88 : check-gl-program ( program -- program )
  89     dup gl-program-ok? [ dup gl-program-info-log throw ] unless ;
  90
  91 : gl-program-shaders-length ( program -- shaders-length )
  92     GL_ATTACHED_SHADERS gl-program-get-int ; inline
  93
  94 : gl-program-shaders ( program -- shaders )
  95     dup gl-program-shaders-length
  96     dup "GLuint" <c-array>
  97     0 <int> swap
  98     [ glGetAttachedShaders ] { 3 1 } multikeep
  99     c-uint-array> ;
 100
 101 : delete-gl-program-only ( program -- )
 102     glDeleteProgram ; inline
 103
 104 : detach-gl-program-shader ( program shader -- )
 105     glDetachShader ; inline
 106
 107 : delete-gl-program ( program -- )
 108     dup gl-program-shaders [
 109         2dup detach-gl-program-shader delete-gl-shader
 110     ] each delete-gl-program-only ;
 111
 112 : (with-gl-program) ( program quot -- )
 113     swap glUseProgram [ 0 glUseProgram ] [ ] cleanup ; inline
 114
 115 : (with-gl-program-uniforms) ( uniforms -- quot )
 116     [ [ swap , \ glGetUniformLocation , % ] [ ] make ]
 117     { } assoc>map ;
 118 : (make-with-gl-program) ( uniforms quot -- q )
 119     [
 120         \ dup ,
 121         [ swap (with-gl-program-uniforms) , \ call-with , % ]
 122         [ ] make ,
 123         \ (with-gl-program) ,
 124     ] [ ] make ;
 125
 126 MACRO: with-gl-program ( uniforms quot -- )
 127     (make-with-gl-program) ;
 128
 129 PREDICATE: integer gl-program (gl-program?) ;
 130
 131 : <simple-gl-program> ( vertex-shader-source fragment-shader-source -- program )
 132     >r <vertex-shader> check-gl-shader
 133     r> <fragment-shader> check-gl-shader
 134     2array <gl-program> check-gl-program ;
 135