--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: alien byte-arrays destructors help.markup help.syntax kernel math
+quotations ;
+IN: gpu.buffers
+
+HELP: <buffer-ptr>
+{ $values
+ { "buffer" buffer } { "offset" integer }
+ { "buffer-ptr" buffer-ptr }
+}
+{ $description "Constructs a " { $link buffer-ptr } " tuple." } ;
+
+HELP: <buffer>
+{ $values
+ { "upload" buffer-upload-pattern }
+ { "usage" buffer-usage-pattern }
+ { "kind" buffer-kind }
+ { "size" integer }
+ { "initial-data" { $maybe c-ptr } }
+ { "buffer" buffer }
+}
+{ $description "Allocates a new " { $link buffer } " object of " { $snippet "size" } " bytes. If " { $snippet "initial-data" } " is not " { $link f } ", " { $snippet "size" } " bytes are copied from " { $snippet "initial-data" } " into the buffer to initialize it; otherwise, the buffer content is left uninitialized. " { $snippet "upload" } ", " { $snippet "usage" } ", and " { $snippet "kind" } " provide hints to the implementation about the expected usage pattern of the buffer as documented in the " { $link buffer } " class documentation." } ;
+
+HELP: allocate-buffer
+{ $values
+ { "buffer" buffer } { "size" integer } { "initial-data" { $maybe c-ptr } }
+}
+{ $description "Discards any memory currently held by " { $snippet "buffer" } " and reallocates a new memory block of " { $snippet "size" } " bytes for it. If " { $snippet "initial-data" } " is not " { $link f } ", " { $snippet "size" } " bytes are copied from " { $snippet "initial-data" } " into the buffer to initialize it; otherwise, the buffer content is left uninitialized." } ;
+
+HELP: buffer
+{ $class-description "Objects of this class represent GPU-accessible memory buffers. Buffer objects can be used to store vertex data and to update or read pixel data from textures and framebuffers without CPU involvement. The data inside buffer objects may be resident in main memory or different parts of GPU memory; the graphics driver will choose a location for a buffer based on usage hints specified when the buffer object is constructed with " { $link <buffer> } " or " { $link byte-array>buffer } ":"
+{ $list
+{ { $snippet "upload-pattern" } " is one of the " { $link buffer-upload-pattern } " values and indicates how frequently the data in the buffer will be updated with new data from CPU memory." }
+{ { $snippet "usage-pattern" } " is one of the " { $link buffer-usage-pattern } " values and indicates how frequently the data in the buffer will be updated with new data from CPU memory." }
+{ { $snippet "kind" } " is one of the " { $link buffer-kind } " values and indicates the primary purpose of the buffer." }
+}
+"These settings are only performance hints and do not restrict the usage of the buffer in any way. For example, a buffer constructed as a " { $link vertex-buffer } " with " { $link static-upload } " can still receive pixel data as though it were a " { $link pixel-pack-buffer } ", and can still be updated with " { $link copy-buffer } " or " { $link update-buffer } ". However, performance may be worse when actual usage conflicts with declared usage."
+} ;
+
+HELP: buffer-access-mode
+{ $class-description "A " { $snippet "buffer-access-mode" } " value is passed to " { $link with-mapped-buffer } " to control access to the mapped address space." }
+{ $list
+{ { $link read-access } " permits the mapped address space only to be read from." }
+{ { $link write-access } " permits the mapped address space only to be written to." }
+{ { $link read-write-access } " permits full access to the mapped address space." }
+} ;
+
+HELP: buffer-kind
+{ $class-description { $snippet "buffer-kind" } " values tell the graphics driver what the primary application of a " { $link buffer } " object will be. Note that any buffer can be used for any purpose; however, performance may be improved if a buffer object is constructed as the same kind as its primary use case."
+{ $list
+{ "A " { $link vertex-buffer } " is used to store vertex attribute data to be rendered as part of a vertex array." }
+{ "An " { $link index-buffer } " is used to store indexes into a vertex array." }
+{ "A " { $link pixel-unpack-buffer } " is used as a source for updating texture image data." }
+{ "A " { $link pixel-pack-buffer } " is used as a destination for reading texture or framebuffer image data." }
+} }
+{ $notes "The " { $snippet "pixel-unpack-buffer" } " and " { $snippet "pixel-pack-buffer" } " kinds require OpenGL 2.1 or the " { $snippet "GL_ARB_pixel_buffer_object" } " extension." } ;
+
+HELP: buffer-ptr
+{ $class-description "A " { $snippet "buffer-ptr" } " references a memory location inside a " { $link buffer } " object. " { $snippet "buffer-ptr" } "s are tuples with the following slots:"
+{ $list
+{ { $snippet "buffer" } " is the " { $link buffer } " object being referenced." }
+{ { $snippet "offset" } " is an integer offset from the beginning of the buffer." }
+} } ;
+
+HELP: buffer-upload-pattern
+{ $class-description { $snippet "buffer-upload-pattern" } " values aid the graphics driver in optimizing access to " { $link buffer } " objects by declaring the frequency with which the buffer will be supplied new data."
+{ $list
+{ { $link stream-upload } " declares that the buffer data will only be used a few times before being deallocated by " { $link dispose } " or replaced by " { $link allocate-buffer } "." }
+{ { $link static-upload } " declares that the buffer data will be provided once and accessed frequently without modification." }
+{ { $link dynamic-upload } " declares that the buffer data will be frequently modified." }
+}
+"A " { $snippet "buffer-upload-pattern" } " is only a declaration and does not actually control access to the underlying buffer data." } ;
+
+HELP: buffer-usage-pattern
+{ $class-description { $snippet "buffer-usage-pattern" } " values aid the graphics driver in optimizing access to " { $link buffer } " objects by declaring the primary provider and consumer of data for the buffer."
+{ $list
+{ { $link draw-usage } " declares that the buffer will be supplied with data from CPU memory and read from by the GPU for vertex or texture image data." }
+{ { $link read-usage } " declares that the buffer will be supplied with data from other GPU resources and read from primarily by the CPU." }
+{ { $link copy-usage } " declares that the buffer will both receive and supply data primarily for other GPU resources." }
+}
+"A " { $snippet "buffer-usage-pattern" } " is only a declaration and does not actually control access to the underlying buffer data." } ;
+
+{ buffer-kind buffer-upload-pattern buffer-usage-pattern } related-words
+
+HELP: byte-array>buffer
+{ $values
+ { "byte-array" byte-array }
+ { "upload" buffer-upload-pattern }
+ { "usage" buffer-usage-pattern }
+ { "kind" buffer-kind }
+ { "buffer" buffer }
+}
+{ $description "Allocates a new " { $link buffer } " object with the size and contents of " { $snippet "byte-array" } ". " { $snippet "upload" } ", " { $snippet "usage" } ", and " { $snippet "kind" } " provide hints to the implementation about the expected usage pattern of the buffer as documented in the " { $link buffer } " class documentation." } ;
+
+HELP: copy-buffer
+{ $values
+ { "to-buffer-ptr" buffer-ptr } { "from-buffer-ptr" buffer-ptr } { "size" integer }
+}
+{ $description "Instructs the GPU to asynchronously copy " { $snippet "size" } " bytes from " { $snippet "from-buffer-ptr" } " into " { $snippet "to-buffer-ptr" } "." }
+{ $notes "This word requires that the graphics context support OpenGL 3.1 or the " { $snippet "GL_ARB_copy_buffer" } " extension." } ;
+
+HELP: copy-usage
+{ $class-description "This " { $link buffer-usage-pattern } " declares that a " { $link buffer } " object will be primarily read from and written to by other GPU resources." } ;
+
+HELP: draw-usage
+{ $class-description "This " { $link buffer-usage-pattern } " declares that a " { $link buffer } " object will be primarily read from by the GPU and written to by the CPU." } ;
+
+HELP: dynamic-upload
+{ $class-description "This " { $link buffer-upload-pattern } " declares that a " { $link buffer } " object's data store will be updated frequently during its lifetime." } ;
+
+HELP: gpu-data-ptr
+{ $class-description "This class is a union of the " { $link c-ptr } " and " { $link buffer-ptr } " classes. It represents a value that can be supplied either from CPU or GPU memory." } ;
+
+HELP: index-buffer
+{ $class-description "This " { $link buffer-kind } " declares that a " { $link buffer } "'s primary use will be to index vertex arrays." } ;
+
+HELP: pixel-pack-buffer
+{ $class-description "This " { $link buffer-kind } " declares that a " { $link buffer } "'s primary use will be as a destination for receiving image data from textures or framebuffers." }
+{ $notes "This word requires OpenGL 2.1 or the " { $snippet "GL_ARB_pixel_buffer_object" } " extension." } ;
+
+HELP: pixel-unpack-buffer
+{ $class-description "This " { $link buffer-kind } " declares that a " { $link buffer } "'s primary use will be as a source for supplying image data to textures." }
+{ $notes "This word requires OpenGL 2.1 or the " { $snippet "GL_ARB_pixel_buffer_object" } " extension." } ;
+
+HELP: read-access
+{ $class-description "This " { $link buffer-access-mode } " value requests read-only access when mapping a " { $link buffer } " object through " { $link with-mapped-buffer } "." } ;
+
+HELP: read-buffer
+{ $values
+ { "buffer-ptr" buffer-ptr } { "size" integer }
+ { "data" byte-array }
+}
+{ $description "Reads " { $snippet "size" } " bytes from " { $snippet "buffer" } " into a new " { $link byte-array } "." } ;
+
+HELP: read-usage
+{ $class-description "This " { $link buffer-usage-pattern } " declares that a " { $link buffer } " object will be primarily read from by the CPU and written to by the GPU." } ;
+
+{ copy-usage draw-usage read-usage } related-words
+
+HELP: read-write-access
+{ $class-description "This " { $link buffer-access-mode } " value requests full access when mapping a buffer object through " { $link with-mapped-buffer } "." } ;
+
+HELP: static-upload
+{ $class-description "This " { $link buffer-upload-pattern } " declares that a " { $link buffer } " object's data store will be read from frequently and modified infrequently." } ;
+
+HELP: stream-upload
+{ $var-description "This " { $link buffer-upload-pattern } " declares that a " { $link buffer } " object's data store will be used only a handful of times before being deallocated or replaced." } ;
+
+{ dynamic-upload static-upload stream-upload } related-words
+
+HELP: update-buffer
+{ $values
+ { "buffer-ptr" buffer-ptr } { "size" integer } { "data" { $maybe c-ptr } }
+}
+{ $description "Replaces " { $snippet "size" } " bytes of data in the " { $link buffer } " referenced by " { $snippet "buffer-ptr" } " with data from " { $snippet "data" } "." } ;
+
+HELP: vertex-buffer
+{ $class-description "This " { $link buffer-kind } " declares that a " { $link buffer } "'s primary use will be to provide vertex attribute information to a vertex array." } ;
+
+{ index-buffer pixel-pack-buffer pixel-unpack-buffer vertex-buffer } related-words
+
+HELP: with-mapped-buffer
+{ $values
+ { "buffer" buffer } { "access" buffer-access-mode } { "quot" { $quotation "( alien -- )" } }
+}
+{ $description "Maps " { $snippet "buffer" } " into CPU address space with " { $snippet "access" } " for the dynamic extent of " { $snippet "quot" } ". " { $snippet "quot" } " is called with a pointer to the mapped memory on top of the stack." } ;
+
+{ allocate-buffer update-buffer read-buffer copy-buffer with-mapped-buffer } related-words
+
+HELP: write-access
+{ $class-description "This " { $link buffer-access-mode } " value requests write-only access when mapping a buffer object through " { $link with-mapped-buffer } "." } ;
+
+{ read-access read-write-access write-access } related-words
+
+ARTICLE: "gpu.buffers" "Buffer objects"
+"The " { $vocab-link "gpu.buffers" } " vocabulary provides words for creating, allocating, updating, and reading GPU data buffers."
+{ $subsection buffer }
+{ $subsection <buffer> }
+{ $subsection byte-array>buffer }
+"Declaring buffer usage:"
+{ $subsection buffer-kind }
+{ $subsection buffer-upload-pattern }
+{ $subsection buffer-usage-pattern }
+"Referencing buffer data:"
+{ $subsection buffer-ptr }
+"Manipulating buffer data:"
+{ $subsection allocate-buffer }
+{ $subsection update-buffer }
+{ $subsection read-buffer }
+{ $subsection copy-buffer }
+{ $subsection with-mapped-buffer }
+;
+
+ABOUT: "gpu.buffers"
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors alien alien.c-types arrays byte-arrays
+combinators destructors gpu kernel locals math opengl opengl.gl
+ui.gadgets.worlds variants ;
+IN: gpu.buffers
+
+VARIANT: buffer-upload-pattern
+ stream-upload static-upload dynamic-upload ;
+
+VARIANT: buffer-usage-pattern
+ draw-usage read-usage copy-usage ;
+
+VARIANT: buffer-access-mode
+ read-access write-access read-write-access ;
+
+VARIANT: buffer-kind
+ vertex-buffer index-buffer
+ pixel-unpack-buffer pixel-pack-buffer ;
+
+TUPLE: buffer < gpu-object
+ { upload-pattern buffer-upload-pattern }
+ { usage-pattern buffer-usage-pattern }
+ { kind buffer-kind } ;
+
+<PRIVATE
+
+: gl-buffer-usage ( buffer -- usage )
+ [ upload-pattern>> ] [ usage-pattern>> ] bi 2array {
+ { { stream-upload draw-usage } [ GL_STREAM_DRAW ] }
+ { { stream-upload read-usage } [ GL_STREAM_READ ] }
+ { { stream-upload copy-usage } [ GL_STREAM_COPY ] }
+
+ { { static-upload draw-usage } [ GL_STATIC_DRAW ] }
+ { { static-upload read-usage } [ GL_STATIC_READ ] }
+ { { static-upload copy-usage } [ GL_STATIC_COPY ] }
+
+ { { dynamic-upload draw-usage } [ GL_DYNAMIC_DRAW ] }
+ { { dynamic-upload read-usage } [ GL_DYNAMIC_READ ] }
+ { { dynamic-upload copy-usage } [ GL_DYNAMIC_COPY ] }
+ } case ; inline
+
+: gl-access ( access -- gl-access )
+ {
+ { read-access [ GL_READ_ONLY ] }
+ { write-access [ GL_WRITE_ONLY ] }
+ { read-write-access [ GL_READ_WRITE ] }
+ } case ; inline
+
+: gl-target ( kind -- target )
+ {
+ { vertex-buffer [ GL_ARRAY_BUFFER ] }
+ { index-buffer [ GL_ELEMENT_ARRAY_BUFFER ] }
+ { pixel-unpack-buffer [ GL_PIXEL_UNPACK_BUFFER ] }
+ { pixel-pack-buffer [ GL_PIXEL_PACK_BUFFER ] }
+ } case ; inline
+
+PRIVATE>
+
+M: buffer dispose
+ [ [ delete-gl-buffer ] when* f ] change-handle drop ;
+
+TUPLE: buffer-ptr
+ { buffer buffer read-only }
+ { offset integer read-only } ;
+C: <buffer-ptr> buffer-ptr
+
+UNION: gpu-data-ptr buffer-ptr c-ptr ;
+
+:: allocate-buffer ( buffer size initial-data -- )
+ buffer kind>> gl-target :> target
+ target buffer handle>> glBindBuffer
+ target size initial-data buffer gl-buffer-usage glBufferData ;
+
+: <buffer> ( upload usage kind size initial-data -- buffer )
+ [ [ gen-gl-buffer ] 3dip buffer boa dup ] 2dip allocate-buffer
+ window-resource ;
+
+: byte-array>buffer ( byte-array upload usage kind -- buffer )
+ [ ] 3curry dip
+ [ byte-length ] [ ] bi <buffer> ;
+
+:: update-buffer ( buffer-ptr size data -- )
+ buffer-ptr buffer>> :> buffer
+ buffer kind>> gl-target :> target
+ target buffer handle>> glBindBuffer
+ target buffer-ptr offset>> size data glBufferSubData ;
+
+:: read-buffer ( buffer-ptr size -- data )
+ buffer-ptr buffer>> :> buffer
+ buffer kind>> gl-target :> target
+ size <byte-array> :> data
+ target buffer handle>> glBindBuffer
+ target buffer-ptr offset>> size data glGetBufferSubData
+ data ;
+
+:: copy-buffer ( to-buffer-ptr from-buffer-ptr size -- )
+ GL_COPY_WRITE_BUFFER to-buffer-ptr buffer>> glBindBuffer
+ GL_COPY_READ_BUFFER from-buffer-ptr buffer>> glBindBuffer
+
+ GL_COPY_READ_BUFFER GL_COPY_WRITE_BUFFER
+ from-buffer-ptr offset>> to-buffer-ptr offset>>
+ size glCopyBufferSubData ;
+
+:: with-mapped-buffer ( buffer access quot: ( alien -- ) -- )
+ buffer kind>> gl-target :> target
+
+ target buffer handle>> glBindBuffer
+ target access gl-access glMapBuffer
+
+ quot call
+
+ target glUnmapBuffer ; inline
+
+:: with-bound-buffer ( buffer target quot: ( -- ) -- )
+ target gl-target buffer glBindBuffer
+ quot call ; inline
+
+: with-buffer-ptr ( buffer-ptr target quot: ( c-ptr -- ) -- )
+ [ [ offset>> <alien> ] [ buffer>> handle>> ] bi ] 2dip
+ with-bound-buffer ; inline
+
+: with-gpu-data-ptr ( gpu-data-ptr target quot: ( c-ptr -- ) -- )
+ pick buffer-ptr?
+ [ with-buffer-ptr ]
+ [ [ gl-target 0 glBindBuffer ] dip call ] if ; inline
+
--- /dev/null
+Buffers in GPU memory
--- /dev/null
+Joe Groff
+Slava Pestov
--- /dev/null
+#version 110
+
+uniform mat4 mv_matrix, p_matrix;
+uniform vec4 color, ambient, diffuse;
+uniform float shininess;
+
+varying vec3 frag_normal;
+varying vec3 frag_light_direction;
+varying vec3 frag_eye_direction;
+
+float
+cel(float d)
+{
+ return smoothstep(0.25, 0.255, d) * 0.4 + smoothstep(0.695, 0.70, d) * 0.5;
+}
+
+vec4
+cel_light()
+{
+ vec3 normal = normalize(frag_normal),
+ light = normalize(frag_light_direction),
+ eye = normalize(frag_eye_direction),
+ reflection = reflect(light, normal);
+
+ float d = dot(light, normal) * 0.5 + 0.5;
+ float s = pow(max(dot(reflection, -eye), 0.0), shininess);
+
+ vec4 amb_diff = ambient + diffuse * vec4(vec3(cel(d)), 1.0);
+ vec4 spec = vec4(vec3(cel(s)), 0.0);
+
+ return amb_diff * color + spec;
+}
+
+void
+main()
+{
+ gl_FragData[0] = cel_light();
+ gl_FragData[1] = vec4(frag_normal, 0.0);
+}
--- /dev/null
+USING: accessors alien.c-types arrays combinators combinators.short-circuit
+game-worlds gpu gpu.buffers gpu.util.wasd gpu.framebuffers gpu.render
+gpu.shaders gpu.state gpu.textures gpu.util grouping http.client images
+images.loader io io.encodings.ascii io.files io.files.temp
+kernel math math.matrices math.parser math.vectors
+method-chains sequences specialized-arrays.direct.float
+specialized-arrays.float specialized-vectors.uint splitting
+struct-vectors threads ui ui.gadgets ui.gadgets.worlds
+ui.pixel-formats ;
+IN: gpu.demos.bunny
+
+GLSL-SHADER-FILE: bunny-vertex-shader vertex-shader "bunny.v.glsl"
+GLSL-SHADER-FILE: bunny-fragment-shader fragment-shader "bunny.f.glsl"
+GLSL-PROGRAM: bunny-program
+ bunny-vertex-shader bunny-fragment-shader ;
+
+GLSL-SHADER-FILE: window-vertex-shader vertex-shader "window.v.glsl"
+
+GLSL-SHADER-FILE: sobel-fragment-shader fragment-shader "sobel.f.glsl"
+GLSL-PROGRAM: sobel-program
+ window-vertex-shader sobel-fragment-shader ;
+
+GLSL-SHADER-FILE: loading-fragment-shader fragment-shader "loading.f.glsl"
+GLSL-PROGRAM: loading-program
+ window-vertex-shader loading-fragment-shader ;
+
+TUPLE: bunny-state
+ vertexes
+ indexes
+ vertex-array
+ index-elements ;
+
+TUPLE: sobel-state
+ vertex-array
+ color-texture
+ normal-texture
+ depth-texture
+ framebuffer ;
+
+TUPLE: loading-state
+ vertex-array
+ texture ;
+
+TUPLE: bunny-world < wasd-world
+ bunny sobel loading ;
+
+VERTEX-FORMAT: bunny-vertex
+ { "vertex" float-components 3 f }
+ { f float-components 1 f }
+ { "normal" float-components 3 f }
+ { f float-components 1 f } ;
+VERTEX-STRUCT: bunny-vertex-struct bunny-vertex
+
+UNIFORM-TUPLE: bunny-uniforms < mvp-uniforms
+ { "light_position" float-uniform 3 }
+ { "color" float-uniform 4 }
+ { "ambient" float-uniform 4 }
+ { "diffuse" float-uniform 4 }
+ { "shininess" float-uniform 1 } ;
+
+UNIFORM-TUPLE: sobel-uniforms
+ { "texcoord_scale" float-uniform 2 }
+ { "color_texture" texture-uniform 1 }
+ { "normal_texture" texture-uniform 1 }
+ { "depth_texture" texture-uniform 1 }
+ { "line_color" float-uniform 4 } ;
+
+UNIFORM-TUPLE: loading-uniforms
+ { "texcoord_scale" float-uniform 2 }
+ { "loading_texture" texture-uniform 1 } ;
+
+: numbers ( str -- seq )
+ " " split [ string>number ] map sift ;
+
+: <bunny-vertex> ( vertex -- struct )
+ >float-array
+ "bunny-vertex-struct" <c-object>
+ [ set-bunny-vertex-struct-vertex ] keep ;
+
+: (parse-bunny-model) ( vs is -- vs is )
+ readln [
+ numbers {
+ { [ dup length 5 = ] [ 3 head <bunny-vertex> pick push ] }
+ { [ dup first 3 = ] [ rest over push-all ] }
+ [ drop ]
+ } cond (parse-bunny-model)
+ ] when* ;
+
+: parse-bunny-model ( -- vertexes indexes )
+ 100000 "bunny-vertex-struct" <struct-vector>
+ 100000 <uint-vector>
+ (parse-bunny-model) ;
+
+: normal ( vertexes -- normal )
+ [ [ second ] [ first ] bi v- ]
+ [ [ third ] [ first ] bi v- ] bi cross
+ vneg normalize ; inline
+
+: calc-bunny-normal ( vertexes indexes -- )
+ swap
+ [ [ nth bunny-vertex-struct-vertex 3 <direct-float-array> ] curry { } map-as normal ]
+ [
+ [
+ nth [ bunny-vertex-struct-normal 3 <direct-float-array> v+ ] keep
+ set-bunny-vertex-struct-normal
+ ] curry with each
+ ] 2bi ;
+
+: calc-bunny-normals ( vertexes indexes -- )
+ 3 <groups>
+ [ calc-bunny-normal ] with each ;
+
+: normalize-bunny-normals ( vertexes -- )
+ [
+ [ bunny-vertex-struct-normal 3 <direct-float-array> normalize ] keep
+ set-bunny-vertex-struct-normal
+ ] each ;
+
+: bunny-data ( filename -- vertexes indexes )
+ ascii [ parse-bunny-model ] with-file-reader
+ [ calc-bunny-normals ]
+ [ drop normalize-bunny-normals ]
+ [ ] 2tri ;
+
+: <bunny-buffers> ( vertexes indexes -- vertex-buffer index-buffer index-count )
+ [ underlying>> static-upload draw-usage vertex-buffer byte-array>buffer ]
+ [
+ [ underlying>> static-upload draw-usage index-buffer byte-array>buffer ]
+ [ length ] bi
+ ] bi* ;
+
+: bunny-model-path ( -- path ) "bun_zipper.ply" temp-file ;
+
+CONSTANT: bunny-model-url "http://factorcode.org/bun_zipper.ply"
+
+: download-bunny ( -- path )
+ bunny-model-path dup exists? [
+ bunny-model-url dup print flush
+ over download-to
+ ] unless ;
+
+: get-bunny-data ( bunny-state -- )
+ download-bunny bunny-data
+ [ >>vertexes ] [ >>indexes ] bi* drop ;
+
+: fill-bunny-state ( bunny-state -- )
+ dup [ vertexes>> ] [ indexes>> ] bi <bunny-buffers>
+ [ bunny-program <program-instance> bunny-vertex buffer>vertex-array >>vertex-array ]
+ [ 0 <buffer-ptr> ]
+ [ uint-indexes <index-elements> >>index-elements ] tri*
+ drop ;
+
+: <bunny-state> ( -- bunny-state )
+ bunny-state new
+ dup [ get-bunny-data ] curry "Downloading bunny model" spawn drop ;
+
+: bunny-loaded? ( bunny-state -- ? )
+ { [ vertexes>> ] [ indexes>> ] } 1&& ;
+
+: bunny-state-filled? ( bunny-state -- ? )
+ { [ vertex-array>> ] [ index-elements>> ] } 1&& ;
+
+: <sobel-state> ( window-vertex-buffer -- sobel-state )
+ sobel-state new
+ swap sobel-program <program-instance> window-vertex buffer>vertex-array >>vertex-array
+
+ RGBA half-components T{ texture-parameters
+ { wrap clamp-texcoord-to-edge }
+ { min-filter filter-linear }
+ { min-mipmap-filter f }
+ } <texture-2d> >>color-texture
+ RGBA half-components T{ texture-parameters
+ { wrap clamp-texcoord-to-edge }
+ { min-filter filter-linear }
+ { min-mipmap-filter f }
+ } <texture-2d> >>normal-texture
+ DEPTH u-24-components T{ texture-parameters
+ { wrap clamp-texcoord-to-edge }
+ { min-filter filter-linear }
+ { min-mipmap-filter f }
+ } <texture-2d> >>depth-texture
+
+ dup
+ [
+ [ color-texture>> 0 <texture-2d-attachment> ]
+ [ normal-texture>> 0 <texture-2d-attachment> ] bi 2array
+ ] [ depth-texture>> 0 <texture-2d-attachment> ] bi f { 1024 768 } <framebuffer> >>framebuffer ;
+
+: <loading-state> ( window-vertex-buffer -- loading-state )
+ loading-state new
+ swap
+ loading-program <program-instance> window-vertex buffer>vertex-array >>vertex-array
+
+ RGBA ubyte-components T{ texture-parameters
+ { wrap clamp-texcoord-to-edge }
+ { min-filter filter-linear }
+ { min-mipmap-filter f }
+ } <texture-2d>
+ dup 0 "vocab:gpu/demos/bunny/loading.tiff" load-image allocate-texture-image
+ >>texture ;
+
+BEFORE: bunny-world begin-world
+ init-gpu
+
+ { -0.2 0.13 0.1 } 1.1 0.2 set-wasd-view
+
+ <bunny-state> >>bunny
+ <window-vertex-buffer>
+ [ <sobel-state> >>sobel ]
+ [ <loading-state> >>loading ] bi
+ drop ;
+
+: <bunny-uniforms> ( world -- uniforms )
+ [ wasd-mv-matrix ] [ wasd-p-matrix ] bi
+ { -10000.0 10000.0 10000.0 } ! light position
+ { 0.6 0.5 0.5 1.0 } ! color
+ { 0.2 0.2 0.2 0.2 } ! ambient
+ { 0.8 0.8 0.8 0.8 } ! diffuse
+ 100.0 ! shininess
+ bunny-uniforms boa ;
+
+: draw-bunny ( world -- )
+ T{ depth-state { comparison cmp-less } } set-gpu-state*
+
+ [
+ sobel>> framebuffer>> {
+ { T{ color-attachment f 0 } { 0.15 0.15 0.15 1.0 } }
+ { T{ color-attachment f 1 } { 0.0 0.0 0.0 0.0 } }
+ { depth-attachment 1.0 }
+ } clear-framebuffer
+ ] [
+ render-set new
+ triangles-mode >>primitive-mode
+ { T{ color-attachment f 0 } T{ color-attachment f 1 } } >>output-attachments
+ swap {
+ [ <bunny-uniforms> >>uniforms ]
+ [ bunny>> vertex-array>> >>vertex-array ]
+ [ bunny>> index-elements>> >>indexes ]
+ [ sobel>> framebuffer>> >>framebuffer ]
+ } cleave
+ render
+ ] bi ;
+
+: <sobel-uniforms> ( sobel -- uniforms )
+ { 1.0 1.0 } swap
+ [ color-texture>> ] [ normal-texture>> ] [ depth-texture>> ] tri
+ { 0.1 0.0 0.1 1.0 } ! line_color
+ sobel-uniforms boa ;
+
+: draw-sobel ( world -- )
+ T{ depth-state { comparison f } } set-gpu-state*
+
+ render-set new
+ triangle-strip-mode >>primitive-mode
+ T{ index-range f 0 4 } >>indexes
+ swap sobel>>
+ [ <sobel-uniforms> >>uniforms ]
+ [ vertex-array>> >>vertex-array ] bi
+ render ;
+
+: draw-sobeled-bunny ( world -- )
+ [ draw-bunny ] [ draw-sobel ] bi ;
+
+: draw-loading ( world -- )
+ T{ depth-state { comparison f } } set-gpu-state*
+
+ render-set new
+ triangle-strip-mode >>primitive-mode
+ T{ index-range f 0 4 } >>indexes
+ swap loading>>
+ [ { 1.0 -1.0 } swap texture>> loading-uniforms boa >>uniforms ]
+ [ vertex-array>> >>vertex-array ] bi
+ render ;
+
+M: bunny-world draw-world*
+ dup bunny>>
+ dup bunny-loaded? [
+ dup bunny-state-filled? [ drop ] [ fill-bunny-state ] if
+ draw-sobeled-bunny
+ ] [ drop draw-loading ] if ;
+
+AFTER: bunny-world resize-world
+ [ sobel>> framebuffer>> ] [ dim>> ] bi resize-framebuffer ;
+
+M: bunny-world pref-dim* drop { 1024 768 } ;
+M: bunny-world tick-length drop 1000 30 /i ;
+M: bunny-world wasd-movement-speed drop 1/160. ;
+M: bunny-world wasd-near-plane drop 1/32. ;
+M: bunny-world wasd-far-plane drop 256.0 ;
+
+: bunny-window ( -- )
+ [
+ f T{ world-attributes
+ { world-class bunny-world }
+ { title "Bunny" }
+ { pixel-format-attributes {
+ windowed
+ double-buffered
+ T{ depth-bits { value 24 } }
+ } }
+ { grab-input? t }
+ } open-window
+ ] with-ui ;
+
+MAIN: bunny-window
--- /dev/null
+#version 110
+
+uniform mat4 mv_matrix, p_matrix;
+uniform vec3 light_position;
+
+attribute vec3 vertex, normal;
+
+varying vec3 frag_normal;
+varying vec3 frag_light_direction;
+varying vec3 frag_eye_direction;
+
+void
+main()
+{
+ vec4 position = mv_matrix * vec4(vertex, 1.0);
+
+ gl_Position = p_matrix * position;
+ frag_normal = (mv_matrix * vec4(normal, 0.0)).xyz;
+ frag_light_direction = (mv_matrix * vec4(light_position, 1.0)).xyz - position.xyz;
+ frag_eye_direction = position.xyz;
+
+}
--- /dev/null
+#version 110
+
+uniform sampler2D loading_texture;
+
+varying vec2 texcoord;
+
+void
+main()
+{
+ gl_FragColor = texture2D(loading_texture, texcoord);
+}
--- /dev/null
+#version 110
+
+uniform sampler2D color_texture, normal_texture, depth_texture;
+uniform vec4 line_color;
+
+varying vec2 texcoord;
+
+const float sample_step = 1.0/512.0;
+const float depth_weight = 8.0;
+
+float
+border_factor(vec2 texcoord)
+{
+ float depth_samples[8];
+
+ depth_samples[0] = texture2D(depth_texture, texcoord + vec2(-sample_step, -sample_step)).x;
+ depth_samples[1] = texture2D(depth_texture, texcoord + vec2( 0, -sample_step)).x;
+ depth_samples[2] = texture2D(depth_texture, texcoord + vec2( sample_step, -sample_step)).x;
+
+ depth_samples[3] = texture2D(depth_texture, texcoord + vec2(-sample_step, 0 )).x;
+
+ depth_samples[4] = texture2D(depth_texture, texcoord + vec2( sample_step, 0 )).x;
+
+ depth_samples[5] = texture2D(depth_texture, texcoord + vec2(-sample_step, sample_step)).x;
+ depth_samples[6] = texture2D(depth_texture, texcoord + vec2( 0, sample_step)).x;
+ depth_samples[7] = texture2D(depth_texture, texcoord + vec2( sample_step, sample_step)).x;
+
+ float horizontal = 1.0 * depth_samples[0] + 2.0 * depth_samples[3] + 1.0 * depth_samples[5]
+ - 1.0 * depth_samples[2] - 2.0 * depth_samples[4] - 1.0 * depth_samples[7];
+
+ float vertical = 1.0 * depth_samples[0] + 2.0 * depth_samples[1] + 1.0 * depth_samples[2]
+ - 1.0 * depth_samples[5] - 2.0 * depth_samples[6] - 1.0 * depth_samples[7];
+
+ return depth_weight * sqrt(horizontal*horizontal + vertical*vertical);
+}
+
+void
+main()
+{
+ gl_FragColor = /*vec4(border_factor(texcoord));*/ mix(
+ texture2D(color_texture, texcoord),
+ line_color,
+ border_factor(texcoord)
+ );
+}
--- /dev/null
+Stanford Bunny with shader effects
--- /dev/null
+#version 110
+
+uniform vec2 texcoord_scale;
+
+attribute vec2 vertex;
+
+varying vec2 texcoord;
+
+void
+main()
+{
+ texcoord = (vertex * texcoord_scale) * vec2(0.5) + vec2(0.5);
+ gl_Position = vec4(vertex, 0.0, 1.0);
+}
--- /dev/null
+#version 110
+
+struct sphere
+{
+ vec3 center;
+ float radius;
+ vec4 color;
+};
+
+uniform sphere spheres[4];
+uniform float floor_height;
+uniform vec4 floor_color[2];
+uniform vec4 background_color;
+uniform vec3 light_direction;
+
+varying vec3 ray_origin, ray_direction;
+
+const float FAR_AWAY = 1.0e20;
+const vec4 reflection_color = vec4(1.0, 0.0, 1.0, 0.0);
+
+float sphere_intersect(sphere s, vec3 ro, vec3 rd)
+{
+ vec3 dist = (ro - s.center);
+
+ float b = dot(dist, normalize(rd));
+ float c = dot(dist, dist) - s.radius*s.radius;
+ float d = b * b - c;
+
+ return d > 0.0 ? -b - sqrt(d) : FAR_AWAY;
+}
+
+float floor_intersect(float height, vec3 ro, vec3 rd)
+{
+ return (height - ro.y) / rd.y;
+}
+
+void
+cast_ray(vec3 ro, vec3 rd, out sphere intersect_sphere, out bool intersect_floor, out float intersect_distance)
+{
+ intersect_floor = false;
+ intersect_distance = FAR_AWAY;
+
+ for (int i = 0; i < 4; ++i) {
+ float d = sphere_intersect(spheres[i], ro, rd);
+
+ if (d > 0.0 && d < intersect_distance) {
+ intersect_distance = d;
+ intersect_sphere = spheres[i];
+ }
+ }
+
+ if (intersect_distance >= FAR_AWAY) {
+ intersect_distance = floor_intersect(floor_height, ro, rd);
+ if (intersect_distance < 0.0)
+ intersect_distance = FAR_AWAY;
+ intersect_floor = intersect_distance < FAR_AWAY;
+ }
+}
+
+vec4 render_floor(vec3 at, float distance, bool shadowed)
+{
+ vec3 at2 = 0.125 * at;
+
+ float dropoff = exp(-0.005 * abs(distance)) * 0.8 + 0.2;
+ float fade = 0.5 * dropoff + 0.5;
+
+ vec4 color = fract((floor(at2.x) + floor(at2.z)) * 0.5) == 0.0
+ ? mix(floor_color[1], floor_color[0], fade)
+ : mix(floor_color[0], floor_color[1], fade);
+
+ float light = shadowed ? 0.2 : dropoff;
+
+ return color * light * dot(vec3(0.0, 1.0, 0.0), -light_direction);
+}
+
+vec4 sphere_color(vec4 color, vec3 normal, vec3 eye_ray, bool shadowed)
+{
+ float light = shadowed
+ ? 0.2
+ : max(dot(normal, -light_direction), 0.0) * 0.8 + 0.2;
+
+ float spec = shadowed
+ ? 0.0
+ : 0.3 * pow(max(dot(reflect(-light_direction, normal), eye_ray), 0.0), 100.0);
+
+ return color * light + vec4(spec);
+}
+
+bool reflection_p(vec4 color)
+{
+ vec4 difference = color - reflection_color;
+ return dot(difference, difference) == 0.0;
+}
+
+vec4 render_sphere(sphere s, vec3 at, vec3 eye_ray, bool shadowed)
+{
+ vec3 normal = normalize(at - s.center);
+
+ vec4 color;
+
+ if (reflection_p(s.color)) {
+ sphere reflect_sphere;
+ bool reflect_floor;
+ float reflect_distance;
+ vec3 reflect_direction = reflect(eye_ray, normal);
+
+ cast_ray(at, reflect_direction, reflect_sphere, reflect_floor, reflect_distance);
+
+ vec3 reflect_at = at + reflect_direction * reflect_distance;
+ if (reflect_floor)
+ color = render_floor(reflect_at, reflect_distance, false);
+ else if (reflect_distance < FAR_AWAY) {
+ vec3 reflect_normal = normalize(reflect_at - reflect_sphere.center);
+
+ color = sphere_color(reflect_sphere.color, reflect_normal, reflect_direction, false);
+ } else {
+ color = background_color;
+ }
+ } else
+ color = s.color;
+
+ return sphere_color(color, normal, eye_ray, shadowed);
+}
+
+void
+main()
+{
+ vec3 ray_direction_normalized = normalize(ray_direction);
+
+ sphere intersect_sphere;
+ bool intersect_floor;
+ float intersect_distance;
+
+ cast_ray(ray_origin, ray_direction_normalized, intersect_sphere, intersect_floor, intersect_distance);
+
+ vec3 at = ray_origin + ray_direction_normalized * intersect_distance;
+
+ sphere shadow_sphere;
+ bool shadow_floor;
+ float shadow_distance;
+
+ cast_ray(at - 0.0001 * light_direction, -light_direction, shadow_sphere, shadow_floor, shadow_distance);
+
+ bool shadowed = shadow_distance < FAR_AWAY;
+
+ if (intersect_floor)
+ gl_FragColor = render_floor(at, intersect_distance, shadowed);
+ else if (intersect_distance < FAR_AWAY)
+ gl_FragColor = render_sphere(intersect_sphere, at, ray_direction_normalized, shadowed);
+ else
+ gl_FragColor = background_color;
+}
+
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors arrays game-loop game-worlds generalizations
+gpu gpu.render gpu.shaders gpu.util gpu.util.wasd kernel
+literals math math.matrices math.order math.vectors
+method-chains sequences ui ui.gadgets ui.gadgets.worlds
+ui.pixel-formats ;
+IN: gpu.demos.raytrace
+
+GLSL-SHADER-FILE: raytrace-vertex-shader vertex-shader "raytrace.v.glsl"
+GLSL-SHADER-FILE: raytrace-fragment-shader fragment-shader "raytrace.f.glsl"
+GLSL-PROGRAM: raytrace-program
+ raytrace-vertex-shader raytrace-fragment-shader ;
+
+UNIFORM-TUPLE: raytrace-uniforms
+ { "mv_inv_matrix" float-uniform { 4 4 } }
+ { "fov" float-uniform 2 }
+
+ { "spheres[0].center" float-uniform 3 }
+ { "spheres[0].radius" float-uniform 1 }
+ { "spheres[0].color" float-uniform 4 }
+
+ { "spheres[1].center" float-uniform 3 }
+ { "spheres[1].radius" float-uniform 1 }
+ { "spheres[1].color" float-uniform 4 }
+
+ { "spheres[2].center" float-uniform 3 }
+ { "spheres[2].radius" float-uniform 1 }
+ { "spheres[2].color" float-uniform 4 }
+
+ { "spheres[3].center" float-uniform 3 }
+ { "spheres[3].radius" float-uniform 1 }
+ { "spheres[3].color" float-uniform 4 }
+
+ { "floor_height" float-uniform 1 }
+ { "floor_color[0]" float-uniform 4 }
+ { "floor_color[1]" float-uniform 4 }
+ { "background_color" float-uniform 4 }
+ { "light_direction" float-uniform 3 } ;
+
+CONSTANT: reflection-color { 1.0 0.0 1.0 0.0 }
+
+TUPLE: sphere
+ { axis array }
+ { home array }
+ { dtheta float }
+ { radius float }
+ { color array }
+ { theta float initial: 0.0 } ;
+
+TUPLE: raytrace-world < wasd-world
+ fov
+ spheres
+ vertex-array ;
+
+: tick-sphere ( sphere -- )
+ dup dtheta>> [ + ] curry change-theta drop ;
+
+: sphere-center ( sphere -- center )
+ [ [ axis>> ] [ theta>> ] bi rotation-matrix4 ]
+ [ home>> ] bi m.v ;
+
+: <sphere-uniforms> ( world -- uniforms )
+ [ wasd-mv-inv-matrix ]
+ [ fov>> ]
+ [
+ spheres>>
+ [ [ sphere-center ] [ radius>> ] [ color>> ] tri 3array ] map
+ first4 [ first3 ] 4 napply
+ ] tri
+ -30.0 ! floor_height
+ { 1.0 0.0 0.0 1.0 } ! floor_color[0]
+ { 1.0 1.0 1.0 1.0 } ! floor_color[1]
+ { 0.15 0.15 1.0 1.0 } ! background_color
+ { 0.0 -1.0 -0.1 } ! light_direction
+ raytrace-uniforms boa ;
+
+CONSTANT: initial-spheres {
+ T{ sphere f { 0.0 1.0 0.0 } { 0.0 0.0 0.0 } 0.0 4.0 $ reflection-color }
+ T{ sphere f { 0.0 1.0 0.0 } { 7.0 0.0 0.0 } 0.02 1.0 { 1.0 0.0 0.0 1.0 } }
+ T{ sphere f { 0.0 0.0 -1.0 } { -9.0 0.0 0.0 } 0.03 1.0 { 0.0 1.0 0.0 1.0 } }
+ T{ sphere f { 1.0 0.0 0.0 } { 0.0 5.0 0.0 } 0.025 1.0 { 1.0 1.0 0.0 1.0 } }
+}
+
+BEFORE: raytrace-world begin-world
+ init-gpu
+ { -2.0 6.25 10.0 } 0.19 0.55 set-wasd-view
+ initial-spheres [ clone ] map >>spheres
+ raytrace-program <program-instance> <window-vertex-array> >>vertex-array
+ drop ;
+
+CONSTANT: fov 0.7
+
+AFTER: raytrace-world resize-world
+ dup dim>> dup first2 min >float v/n fov v*n >>fov drop ;
+
+AFTER: raytrace-world tick*
+ spheres>> [ tick-sphere ] each ;
+
+M: raytrace-world draw-world*
+ render-set new
+ triangle-strip-mode >>primitive-mode
+ T{ index-range f 0 4 } >>indexes
+ swap
+ [ <sphere-uniforms> >>uniforms ]
+ [ vertex-array>> >>vertex-array ] bi
+ render ;
+
+M: raytrace-world pref-dim* drop { 1024 768 } ;
+M: raytrace-world tick-length drop 1000 30 /i ;
+M: raytrace-world wasd-movement-speed drop 1/4. ;
+
+: raytrace-window ( -- )
+ [
+ f T{ world-attributes
+ { world-class raytrace-world }
+ { title "Raytracing" }
+ { pixel-format-attributes {
+ windowed
+ double-buffered
+ } }
+ { grab-input? t }
+ } open-window
+ ] with-ui ;
+
+MAIN: raytrace-window
--- /dev/null
+#version 110
+
+uniform mat4 mv_inv_matrix;
+uniform vec2 fov;
+
+attribute vec2 vertex;
+
+varying vec3 ray_origin, ray_direction;
+
+void
+main()
+{
+ gl_Position = vec4(vertex, 0.0, 1.0);
+ ray_direction = (mv_inv_matrix * vec4(fov * vertex, -1.0, 0.0)).xyz;
+ ray_origin = (mv_inv_matrix * vec4(0.0, 0.0, 0.0, 1.0)).xyz;
+}
+
--- /dev/null
+Real-time GPU-accelerated raytracing of reflective spheres
--- /dev/null
+Runnable demonstrations of the gpu library
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: alien byte-arrays gpu.buffers gpu.textures help.markup
+help.syntax images kernel math math.rectangles sequences ;
+IN: gpu.framebuffers
+
+HELP: <color-attachment>
+{ $values
+ { "index" integer }
+ { "color-attachment" color-attachment }
+}
+{ $description "Constructs an " { $link attachment-ref } " referencing the " { $snippet "index" } "th " { $snippet "color-attachment" } " of a framebuffer." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: <framebuffer-rect>
+{ $values
+ { "framebuffer" any-framebuffer } { "attachment" attachment-ref } { "rect" rect }
+ { "framebuffer-rect" framebuffer-rect }
+}
+{ $description "Constructs a " { $link framebuffer-rect } " tuple that references a rectangular region of " { $snippet "attachment" } " in " { $snippet "framebuffer" } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+{ framebuffer-rect <framebuffer-rect> <full-framebuffer-rect> } related-words
+
+HELP: <framebuffer>
+{ $values
+ { "color-attachments" sequence } { "depth-attachment" framebuffer-attachment } { "stencil-attachment" framebuffer-attachment } { "dim" { $maybe sequence } }
+ { "framebuffer" framebuffer }
+}
+{ $description "Creates a new " { $link framebuffer } " object comprising the given set of " { $snippet "color-attachments" } ", " { $snippet "depth-attachment" } ", and " { $snippet "stencil-attachment" } ". If " { $snippet "dim" } " is not null, all of the attachments will be resized using " { $link resize-framebuffer } "; otherwise, each texture or renderbuffer being attached must have image memory allocated for the framebuffer creation to succeed." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions. If only the " { $snippet "GL_EXT_framebuffer_object" } " is available, all framebuffer attachments must have the same size, and all color attachments must have the same " { $link component-order } " and " { $link component-type } "." } ;
+
+HELP: <full-framebuffer-rect>
+{ $values
+ { "framebuffer" any-framebuffer } { "attachment" attachment-ref }
+ { "framebuffer-rect" framebuffer-rect }
+}
+{ $description "Constructs a " { $link framebuffer-rect } " tuple that spans the entire size of " { $snippet "attachment" } " in " { $snippet "framebuffer" } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: <renderbuffer>
+{ $values
+ { "component-order" component-order } { "component-type" component-type } { "samples" { $maybe integer } } { "dim" { $maybe sequence } }
+ { "renderbuffer" renderbuffer }
+}
+{ $description "Creates a new " { $link renderbuffer } " object. If " { $snippet "samples" } " is not " { $link f } ", it specifies the multisampling level to use. If " { $snippet "dim" } " is not " { $link f } ", image memory of the given dimensions will be allocated for the renderbuffer; otherwise, memory will have to be allocated separately with " { $link allocate-renderbuffer } "." }
+{ $notes "Renderbuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions. Multisampled renderbuffers require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_multisample" } " extensions." } ;
+
+HELP: <system-attachment>
+{ $values
+ { "side" { $maybe framebuffer-attachment-side } } { "face" { $maybe framebuffer-attachment-face } }
+ { "system-attachment" system-attachment }
+}
+{ $description "Constructs an " { $link attachment-ref } " referencing a " { $link system-framebuffer } " color attachment." } ;
+
+HELP: <texture-1d-attachment>
+{ $values
+ { "texture" texture-data-target } { "level" integer }
+ { "texture-1d-attachment" texture-1d-attachment }
+}
+{ $description "Constructs a " { $link framebuffer-attachment } " to the " { $snippet "level" } "th level of detail of one-dimensional texture " { $snippet "texture" } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: <texture-2d-attachment>
+{ $values
+ { "texture" texture-data-target } { "level" integer }
+ { "texture-2d-attachment" texture-2d-attachment }
+}
+{ $description "Constructs a " { $link framebuffer-attachment } " to the " { $snippet "level" } "th level of detail of two-dimensional texture " { $snippet "texture" } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: <texture-3d-attachment>
+{ $values
+ { "texture" texture-data-target } { "z-offset" integer } { "level" integer }
+ { "texture-3d-attachment" texture-3d-attachment }
+}
+{ $description "Constructs a " { $link framebuffer-attachment } " to the " { $snippet "z-offset" } "th plane of the " { $snippet "level" } "th level of detail of three-dimensional texture " { $snippet "texture" } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: <texture-layer-attachment>
+{ $values
+ { "texture" texture-data-target } { "layer" integer } { "level" integer }
+ { "texture-layer-attachment" texture-layer-attachment }
+}
+{ $description "Constructs a " { $link framebuffer-attachment } " to the " { $snippet "layer" } "th layer of the " { $snippet "level" } "th level of detail of three-dimensional texture or array texture " { $snippet "texture" } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions. Array textures require OpenGL 3.0 or the " { $snippet "GL_EXT_texture_array" } " extension." } ;
+
+HELP: allocate-renderbuffer
+{ $values
+ { "renderbuffer" renderbuffer } { "dim" sequence }
+}
+{ $description "Allocates image memory for " { $snippet "renderbuffer" } " with dimension " { $snippet "dim" } "." }
+{ $notes "Renderbuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: any-framebuffer
+{ $class-description "This class is a union of the " { $link framebuffer } " class, which represents user-created framebuffer objects, and the " { $link system-framebuffer } ". Words which accept " { $snippet "any-framebuffer" } " can operate on either the system framebuffer or user framebuffers." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: attachment-ref
+{ $class-description "An " { $snippet "attachment-ref" } " value references a particular color, depth, or stencil attachment to a " { $link framebuffer } " object."
+{ $list
+{ { $link system-attachment } " references one or more of the color attachments to the " { $link system-framebuffer } "." }
+{ { $link color-attachment } " references one of the indexed color attachments to a user-created " { $link framebuffer } "." }
+{ { $link default-attachment } " references the back buffer of the " { $snippet "system-framebuffer" } " or the first color attachment of a user " { $snippet "framebuffer" } "." }
+{ { $link depth-attachment } " references the depth buffer attachment to any framebuffer." }
+{ { $link stencil-attachment } " references the stencil buffer attachment to any framebuffer." }
+} }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: back-face
+{ $class-description "Use this value in the " { $snippet "face" } " slot of a " { $link system-attachment } " reference to select the back face of a double-buffered " { $link system-framebuffer } "." } ;
+
+HELP: clear-framebuffer
+{ $values
+ { "framebuffer" any-framebuffer } { "alist" "a list of " { $link attachment-ref } "/value pairs" }
+}
+{ $description "Clears the active viewport area of the specified attachments to " { $snippet "framebuffer" } " to the associated values." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: clear-framebuffer-attachment
+{ $values
+ { "framebuffer" any-framebuffer } { "attachment-ref" attachment-ref } { "value" object }
+}
+{ $description "Clears the active viewport area of the given attachment to " { $snippet "framebuffer" } " to " { $snippet "value" } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+{ clear-framebuffer clear-framebuffer-attachment } related-words
+
+HELP: color-attachment
+{ $class-description "This " { $link attachment-ref } " type references a color attachment to a user-created " { $link framebuffer } " object. The " { $snippet "index" } " slot of the tuple indicates the color attachment referenced. Color attachments to the " { $link system-framebuffer } " are referenced by the " { $link system-attachment } " type." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+{
+ color-attachment system-attachment default-attachment depth-attachment stencil-attachment
+ attachment-ref color-attachment-ref
+} related-words
+
+HELP: color-attachment-ref
+{ $class-description "A " { $snippet "color-attachment-ref" } " value references a particular color attachment to a " { $link framebuffer } " object."
+{ $list
+{ { $link system-attachment } " references one or more of the color attachments to the " { $link system-framebuffer } "." }
+{ { $link color-attachment } " references one of the indexed color attachments to a user-created " { $link framebuffer } "." }
+{ { $link default-attachment } " references the back buffer of the " { $snippet "system-framebuffer" } " or the first color attachment of a user " { $snippet "framebuffer" } "." }
+} }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: copy-framebuffer
+{ $values
+ { "to-fb-rect" framebuffer-rect } { "from-fb-rect" framebuffer-rect } { "depth?" boolean } { "stencil?" boolean } { "filter" texture-filter }
+}
+{ $description "Copies the rectangular region " { $snippet "from-fb-rect" } " to " { $snippet "to-fb-rect" } ". If " { $snippet "depth?" } " is true, depth values are also copied, and if " { $snippet "stencil?" } " is true, so are stencil values. If the rectangle sizes do not match, the region is scaled using nearest-neighbor or linear filtering based on " { $snippet "filter" } "." }
+{ $notes "This word requires OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_blit" } " extensions." } ;
+
+HELP: default-attachment
+{ $class-description "This " { $link attachment-ref } " references the back buffer of the " { $link system-framebuffer } " or the first color attachment of a user-created " { $link framebuffer } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: depth-attachment
+{ $class-description "This " { $link attachment-ref } " references the depth buffer attachment of a user-created " { $link framebuffer } " or the " { $link system-framebuffer } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: framebuffer
+{ $class-description "Objects of this class represent user-created framebuffer objects. These framebuffer objects provide an offscreen target for rendering operations and can send rendering output either to textures or to dedicated " { $link renderbuffer } "s. A framebuffer consists of a set of one or more color " { $link framebuffer-attachment } "s, an optional depth buffer " { $snippet "framebuffer-attachment" } ", and an optional stencil buffer " { $snippet "framebuffer-attachment" } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: framebuffer-attachment
+{ $class-description "This class is a union of the " { $link renderbuffer } " and " { $link texture-attachment } " classes, either of which can function as an attachment to a user-created " { $link framebuffer } " object." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: framebuffer-attachment-at
+{ $values
+ { "framebuffer" framebuffer } { "attachment-ref" attachment-ref }
+ { "attachment" framebuffer-attachment }
+}
+{ $description "Returns the " { $link texture-attachment } " or " { $link renderbuffer } " referenced by " { $snippet "attachment-ref" } " in " { $snippet "framebuffer" } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: framebuffer-attachment-face
+{ $class-description "The values " { $link front-face } " and " { $link back-face } " select a face of a double-buffered " { $link system-framebuffer } " when stored in the " { $snippet "face" } " slot of a " { $link system-attachment } " reference." } ;
+
+HELP: framebuffer-attachment-side
+{ $class-description "The values " { $link left-side } " and " { $link right-side } " select a face of a stereoscopic " { $link system-framebuffer } " when stored in the " { $snippet "side" } " slot of a " { $link system-attachment } " reference." } ;
+
+HELP: framebuffer-rect
+{ $class-description "This tuple class references a rectangular subregion of a color attachment of a " { $link framebuffer } " object."
+{ $list
+{ { $snippet "framebuffer" } " references either a user-created " { $link framebuffer } " or the " { $link system-framebuffer } "." }
+{ { $snippet "attachment" } " is a " { $link color-attachment-ref } " referencing the color attachment of interest in the framebuffer." }
+{ { $snippet "rect" } " is a " { $link rect } " referencing the rectangular region of interest of the attachment." }
+} }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: front-face
+{ $class-description "Use this value in the " { $snippet "face" } " slot of a " { $link system-attachment } " reference to select the front face of a double-buffered " { $link system-framebuffer } "." } ;
+
+{ front-face back-face } related-words
+
+HELP: left-side
+{ $class-description "Use this value in the " { $snippet "side" } " slot of a " { $link system-attachment } " reference to select the left side of a stereoscopic " { $link system-framebuffer } "." } ;
+
+{ left-side right-side } related-words
+
+HELP: read-framebuffer
+{ $values
+ { "framebuffer-rect" framebuffer-rect }
+ { "byte-array" byte-array }
+}
+{ $description "Reads the rectangular region " { $snippet "framebuffer-rect" } " into a new " { $snippet "byte-array" } ". The format of the byte array is determined by the " { $link component-order } " and " { $link component-type } " of the associated " { $link framebuffer-attachment } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: read-framebuffer-image
+{ $values
+ { "framebuffer-rect" framebuffer-rect }
+ { "image" image }
+}
+{ $description "Reads the rectangular region " { $snippet "framebuffer-rect" } " into a new " { $snippet "image" } ". The format of the image is determined by the " { $link component-order } " and " { $link component-type } " of the associated " { $link framebuffer-attachment } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: read-framebuffer-to
+{ $values
+ { "framebuffer-rect" framebuffer-rect } { "gpu-data-ptr" gpu-data-ptr }
+}
+{ $description "Reads the rectangular region " { $snippet "framebuffer-rect" } " into " { $snippet "gpu-data-ptr" } ", which can reference either CPU memory (a " { $link byte-array } " or " { $link alien } ") or a GPU " { $link buffer-ptr } ". The format of the written data is determined by the " { $link component-order } " and " { $link component-type } " of the associated " { $link framebuffer-attachment } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions. Reading into a " { $snippet "buffer-ptr" } " requires OpenGL 2.1 or the " { $snippet "GL_ARB_pixel_buffer_object" } " extension." } ;
+
+{ read-framebuffer read-framebuffer-image read-framebuffer-to } related-words
+
+HELP: renderbuffer
+{ $class-description "Objects of this type represent renderbuffer objects, two-dimensional image buffers that can serve as " { $link framebuffer-attachment } "s to user-created " { $link framebuffer } " objects." }
+{ $notes "Renderbuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+{ renderbuffer renderbuffer-dim allocate-renderbuffer <renderbuffer> } related-words
+{ framebuffer <framebuffer> resize-framebuffer } related-words
+
+HELP: renderbuffer-dim
+{ $values
+ { "renderbuffer" renderbuffer }
+ { "dim" sequence }
+}
+{ $description "Returns the dimensions of the allocated image memory for " { $snippet "renderbuffer" } "." }
+{ $notes "Renderbuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: resize-framebuffer
+{ $values
+ { "framebuffer" framebuffer } { "dim" sequence }
+}
+{ $description "Reallocates the image memory for all of the textures and renderbuffers bound to " { $snippet "framebuffer" } " to be of the given dimensions." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: right-side
+{ $class-description "Use this value in the " { $snippet "side" } " slot of a " { $link system-attachment } " reference to select the right side of a stereoscopic " { $link system-framebuffer } "." } ;
+
+HELP: stencil-attachment
+{ $class-description "This " { $link attachment-ref } " references the stencil buffer attachment of a user-created " { $link framebuffer } " or the " { $link system-framebuffer } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: system-attachment
+{ $class-description "This " { $link attachment-ref } " references one or more of the color attachments to the " { $link system-framebuffer } ". Depending on the window system pixel format for the window, up to four attachments may be available:"
+{ $list
+{ "If double buffering is available, there is a " { $link back-face } ", which holds the screen image as it is drawn, and a " { $link front-face } ", which holds the current contents of the screen. The two buffers get swapped when a scene is completely drawn." }
+{ "If stereoscopic rendering is available, there is a " { $link left-side } " and " { $link right-side } ", representing the left and right eye viewpoints of a 3D viewing apparatus." }
+}
+"To select a subset of these attachments, the " { $snippet "system-attachment" } " tuple type has two slots:"
+{ $list
+{ { $snippet "side" } " selects either the " { $snippet "left-side" } " or " { $snippet "right-side" } ", or both if set to " { $link f } "." }
+{ { $snippet "face" } " selects either the " { $snippet "back-face" } " or " { $snippet "front-face" } ", or both if set to " { $link f } "." }
+}
+"If stereo or double buffering are not available, then both sides or faces respectively will be equivalent. All attachments can be selected by setting both slots to " { $link f } ", both attachments of a side or face can be selected by setting a single slot, and a single attachment can be targeted by setting both slots." } ;
+
+HELP: system-framebuffer
+{ $class-description "This symbol represents the framebuffer supplied by the window system to store the contents of the window on screen. Since this framebuffer is managed by the window system, it cannot have its attachments modified or resized; however, it is still a valid target for rendering, copying via " { $link copy-framebuffer } ", clearing via " { $link clear-framebuffer } ", and reading via " { $link read-framebuffer } "." } ;
+
+HELP: texture-1d-attachment
+{ $class-description "This class references a single level of detail of a one-dimensional texture for use as a " { $link framebuffer-attachment } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: texture-2d-attachment
+{ $class-description "This class references a single level of detail of a two-dimensional texture for use as a " { $link framebuffer-attachment } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: texture-3d-attachment
+{ $class-description "This class references a single plane and level of detail of a three-dimensional texture for use as a " { $link framebuffer-attachment } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: texture-attachment
+{ $class-description "This class is a union of the " { $link texture-1d-attachment } ", " { $link texture-2d-attachment } ", " { $link texture-3d-attachment } ", and " { $link texture-layer-attachment } " classes, which select layers and levels of detail of " { $link texture } " objects to serve as " { $link framebuffer } " attachments." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: texture-layer-attachment
+{ $class-description "This class references a single layer and level of detail of a three-dimensional texture or array texture for use as a " { $link framebuffer-attachment } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions. Array textures require OpenGL 3.0 or the " { $snippet "GL_EXT_texture_array" } " extension." } ;
+
+{ texture-1d-attachment <texture-1d-attachment> } related-words
+{ texture-2d-attachment <texture-2d-attachment> } related-words
+{ texture-3d-attachment <texture-3d-attachment> } related-words
+{ texture-layer-attachment <texture-layer-attachment> } related-words
+
+ARTICLE: "gpu.framebuffers" "Framebuffer objects"
+"The " { $vocab-link "gpu.framebuffers" } " vocabulary provides words for creating, allocating, and reading from framebuffer objects. Framebuffer objects are used as rendering targets; the " { $link system-framebuffer } " is supplied by the window system and contains the contents of the window on screen. User-created " { $link framebuffer } " objects can also be created to direct rendering output to offscreen " { $link texture } "s or " { $link renderbuffer } "s."
+{ $subsection system-framebuffer }
+{ $subsection framebuffer }
+{ $subsection renderbuffer }
+"The contents of a framebuffer can be cleared to known values before rendering a scene:"
+{ $subsection clear-framebuffer }
+{ $subsection clear-framebuffer-attachment }
+"The image memory for a renderbuffer can be resized, or the full set of textures and renderbuffers attached to a framebuffer can be resized to the same dimensions together:"
+{ $subsection allocate-renderbuffer }
+{ $subsection resize-framebuffer }
+"Rectangular regions of framebuffers can be read into memory, read into GPU " { $link buffer } "s, and copied between framebuffers:"
+{ $subsection framebuffer-rect }
+{ $subsection attachment-ref }
+{ $subsection read-framebuffer }
+{ $subsection read-framebuffer-to }
+{ $subsection read-framebuffer-image }
+{ $subsection copy-framebuffer } ;
+
+ABOUT: "gpu.framebuffers"
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors alien.c-types arrays byte-arrays combinators
+destructors gpu gpu.buffers gpu.private gpu.textures
+gpu.textures.private images kernel locals math math.rectangles opengl
+opengl.framebuffers opengl.gl opengl.textures sequences
+specialized-arrays.int specialized-arrays.uint
+ui.gadgets.worlds variants ;
+IN: gpu.framebuffers
+
+SINGLETON: system-framebuffer
+
+TUPLE: renderbuffer < gpu-object
+ { component-order component-order initial: RGBA }
+ { component-type component-type initial: ubyte-components }
+ { samples integer initial: 0 } ;
+
+<PRIVATE
+
+: get-framebuffer-int ( enum -- value )
+ GL_RENDERBUFFER swap 0 <int> [ glGetRenderbufferParameteriv ] keep *int ;
+
+PRIVATE>
+
+:: allocate-renderbuffer ( renderbuffer dim -- )
+ GL_RENDERBUFFER renderbuffer handle>> glBindRenderbuffer
+ GL_RENDERBUFFER
+ renderbuffer samples>> dup zero?
+ [ drop renderbuffer texture-gl-internal-format dim first2 glRenderbufferStorage ]
+ [ renderbuffer texture-gl-internal-format dim first2 glRenderbufferStorageMultisample ]
+ if ;
+
+:: renderbuffer-dim ( renderbuffer -- dim )
+ GL_RENDERBUFFER renderbuffer handle>> glBindRenderbuffer
+ GL_RENDERBUFFER_WIDTH get-framebuffer-int
+ GL_RENDERBUFFER_HEIGHT get-framebuffer-int 2array ;
+
+: <renderbuffer> ( component-order component-type samples dim -- renderbuffer )
+ [ [ gen-renderbuffer ] 3dip renderbuffer boa dup ] dip
+ [ allocate-renderbuffer ] [ drop ] if*
+ window-resource ;
+
+M: renderbuffer dispose
+ [ [ delete-renderbuffer ] when* f ] change-handle drop ;
+
+TUPLE: texture-1d-attachment
+ { texture texture-1d-data-target read-only initial: T{ texture-1d } }
+ { level integer read-only } ;
+
+C: <texture-1d-attachment> texture-1d-attachment
+
+TUPLE: texture-2d-attachment
+ { texture texture-2d-data-target read-only initial: T{ texture-2d } }
+ { level integer read-only } ;
+
+C: <texture-2d-attachment> texture-2d-attachment
+
+TUPLE: texture-3d-attachment
+ { texture texture-3d read-only initial: T{ texture-3d } }
+ { z-offset integer read-only }
+ { level integer read-only } ;
+
+C: <texture-3d-attachment> texture-3d-attachment
+
+TUPLE: texture-layer-attachment
+ { texture texture-3d-data-target read-only initial: T{ texture-3d } }
+ { layer integer read-only }
+ { level integer read-only } ;
+
+C: <texture-layer-attachment> texture-layer-attachment
+
+UNION: texture-attachment
+ texture-1d-attachment texture-2d-attachment texture-3d-attachment texture-layer-attachment ;
+
+M: texture-attachment dispose texture>> dispose ;
+
+UNION: framebuffer-attachment renderbuffer texture-attachment ;
+UNION: ?framebuffer-attachment framebuffer-attachment POSTPONE: f ;
+
+GENERIC: attachment-object ( attachment -- object )
+M: renderbuffer attachment-object ;
+M: texture-attachment attachment-object texture>> texture-object ;
+
+TUPLE: framebuffer < gpu-object
+ { color-attachments array read-only }
+ { depth-attachment ?framebuffer-attachment read-only initial: f }
+ { stencil-attachment ?framebuffer-attachment read-only initial: f } ;
+
+UNION: any-framebuffer system-framebuffer framebuffer ;
+
+VARIANT: framebuffer-attachment-side
+ left-side right-side ;
+
+VARIANT: framebuffer-attachment-face
+ back-face front-face ;
+
+UNION: ?framebuffer-attachment-side framebuffer-attachment-side POSTPONE: f ;
+UNION: ?framebuffer-attachment-face framebuffer-attachment-face POSTPONE: f ;
+
+VARIANT: color-attachment-ref
+ default-attachment
+ system-attachment: {
+ { side ?framebuffer-attachment-side initial: f }
+ { face ?framebuffer-attachment-face initial: back-face }
+ }
+ color-attachment: { { index integer } } ;
+
+VARIANT: non-color-attachment-ref
+ depth-attachment
+ stencil-attachment ;
+
+UNION: attachment-ref
+ color-attachment-ref
+ non-color-attachment-ref
+ POSTPONE: f ;
+
+TUPLE: framebuffer-rect
+ { framebuffer any-framebuffer read-only initial: system-framebuffer }
+ { attachment color-attachment-ref read-only initial: default-attachment }
+ { rect rect read-only } ;
+
+C: <framebuffer-rect> framebuffer-rect
+
+: framebuffer-attachment-at ( framebuffer attachment-ref -- attachment )
+ {
+ { default-attachment [ color-attachments>> first ] }
+ { color-attachment [ swap color-attachments>> nth ] }
+ { depth-attachment [ depth-attachment>> ] }
+ { stencil-attachment [ stencil-attachment>> ] }
+ } match ;
+
+<PRIVATE
+
+GENERIC: framebuffer-handle ( framebuffer -- handle )
+
+M: system-framebuffer framebuffer-handle drop 0 ;
+M: framebuffer framebuffer-handle handle>> ;
+
+GENERIC# allocate-framebuffer-attachment 1 ( framebuffer-attachment dim -- )
+
+M: texture-attachment allocate-framebuffer-attachment
+ [ [ texture>> ] [ level>> ] bi ] dip f allocate-texture ;
+M: renderbuffer allocate-framebuffer-attachment
+ allocate-renderbuffer ;
+
+GENERIC: framebuffer-attachment-dim ( framebuffer-attachment -- dim )
+
+M: texture-attachment framebuffer-attachment-dim
+ [ texture>> ] [ level>> ] bi texture-dim
+ dup number? [ 1 2array ] [ 2 head ] if ;
+
+M: renderbuffer framebuffer-attachment-dim
+ renderbuffer-dim ;
+
+: each-attachment ( framebuffer quot: ( attachment -- ) -- )
+ [ [ color-attachments>> ] dip each ]
+ [ swap depth-attachment>> [ swap call ] [ drop ] if* ]
+ [ swap stencil-attachment>> [ swap call ] [ drop ] if* ] 2tri ; inline
+
+: each-attachment-target ( framebuffer quot: ( attachment-target attachment -- ) -- )
+ [ [ color-attachments>> ] dip [ GL_COLOR_ATTACHMENT0 + swap ] prepose each-index ]
+ [ swap depth-attachment>> [ GL_DEPTH_ATTACHMENT spin call ] [ drop ] if* ]
+ [ swap stencil-attachment>> [ GL_STENCIL_ATTACHMENT spin call ] [ drop ] if* ] 2tri ; inline
+
+GENERIC: bind-framebuffer-attachment ( attachment-target attachment -- )
+
+M:: renderbuffer bind-framebuffer-attachment ( attachment-target renderbuffer -- )
+ GL_DRAW_FRAMEBUFFER attachment-target
+ GL_RENDERBUFFER renderbuffer handle>>
+ glFramebufferRenderbuffer ;
+
+M:: texture-1d-attachment bind-framebuffer-attachment ( attachment-target texture-attachment -- )
+ GL_DRAW_FRAMEBUFFER attachment-target
+ texture-attachment [ texture>> [ texture-data-gl-target ] [ texture-object handle>> ] bi ] [ level>> ] bi
+ glFramebufferTexture1D ;
+
+M:: texture-2d-attachment bind-framebuffer-attachment ( attachment-target texture-attachment -- )
+ GL_DRAW_FRAMEBUFFER attachment-target
+ texture-attachment [ texture>> [ texture-data-gl-target ] [ texture-object handle>> ] bi ] [ level>> ] bi
+ glFramebufferTexture2D ;
+
+M:: texture-3d-attachment bind-framebuffer-attachment ( attachment-target texture-attachment -- )
+ GL_DRAW_FRAMEBUFFER attachment-target
+ texture-attachment
+ [ texture>> [ texture-data-gl-target ] [ texture-object handle>> ] bi ]
+ [ level>> ] [ z-offset>> ] tri
+ glFramebufferTexture3D ;
+
+M:: texture-layer-attachment bind-framebuffer-attachment ( attachment-target texture-attachment -- )
+ GL_DRAW_FRAMEBUFFER attachment-target
+ texture-attachment
+ [ texture>> texture-object handle>> ]
+ [ level>> ] [ layer>> ] tri
+ glFramebufferTextureLayer ;
+
+GENERIC: (default-gl-attachment) ( framebuffer -- gl-attachment )
+GENERIC: (default-attachment-type) ( framebuffer -- type )
+GENERIC: (default-attachment-image-type) ( framebuffer -- order type )
+
+M: system-framebuffer (default-gl-attachment)
+ drop GL_BACK ;
+M: framebuffer (default-gl-attachment)
+ drop GL_COLOR_ATTACHMENT0 ;
+
+SYMBOLS: float-type int-type uint-type ;
+
+: (color-attachment-type) ( framebuffer index -- type )
+ swap color-attachments>> nth attachment-object component-type>> {
+ { [ dup signed-unnormalized-integer-components? ] [ drop int-type ] }
+ { [ dup unsigned-unnormalized-integer-components? ] [ drop uint-type ] }
+ [ drop float-type ]
+ } cond ;
+
+M: system-framebuffer (default-attachment-type)
+ drop float-type ;
+M: framebuffer (default-attachment-type)
+ 0 (color-attachment-type) ;
+
+M: system-framebuffer (default-attachment-image-type) ( framebuffer -- order type )
+ drop RGBA ubyte-components ;
+M: framebuffer (default-attachment-image-type) ( framebuffer -- order type )
+ color-attachments>> first attachment-object
+ [ component-order>> ] [ component-type>> ] bi ;
+
+: gl-system-attachment ( side face -- attachment )
+ 2array {
+ { { f f } [ GL_FRONT_AND_BACK ] }
+ { { f front-face } [ GL_FRONT ] }
+ { { f back-face } [ GL_BACK ] }
+ { { left-side f } [ GL_LEFT ] }
+ { { left-side front-face } [ GL_FRONT_LEFT ] }
+ { { left-side back-face } [ GL_BACK_LEFT ] }
+ { { right-side f } [ GL_RIGHT ] }
+ { { right-side front-face } [ GL_FRONT_RIGHT ] }
+ { { right-side back-face } [ GL_BACK_RIGHT ] }
+ } case ;
+
+: gl-attachment ( framebuffer attachment-ref -- gl-attachment )
+ [ {
+ { depth-attachment [ GL_DEPTH_ATTACHMENT ] }
+ { stencil-attachment [ GL_STENCIL_ATTACHMENT ] }
+ { color-attachment [ GL_COLOR_ATTACHMENT0 + ] }
+ { system-attachment [ gl-system-attachment ] }
+ { default-attachment [ dup (default-gl-attachment) ] }
+ } match ] [ GL_NONE ] if* nip ;
+
+: color-attachment-image-type ( framebuffer attachment-ref -- order type )
+ {
+ { color-attachment [
+ swap color-attachments>> nth
+ attachment-object [ component-order>> ] [ component-type>> ] bi
+ ] }
+ { system-attachment [ 3drop RGBA ubyte-components ] }
+ { default-attachment [ (default-attachment-image-type) ] }
+ } match ;
+
+: framebuffer-rect-image-type ( framebuffer-rect -- order type )
+ [ framebuffer>> ] [ attachment>> ] bi color-attachment-image-type ;
+
+HOOK: (clear-integer-color-attachment) gpu-api ( type value -- )
+
+M: opengl-2 (clear-integer-color-attachment)
+ 4 0 pad-tail first4
+ swap {
+ { int-type [ glClearColorIiEXT ] }
+ { uint-type [ glClearColorIuiEXT ] }
+ } case GL_COLOR_BUFFER_BIT glClear ;
+
+M: opengl-3 (clear-integer-color-attachment)
+ [ GL_COLOR 0 ] dip 4 0 pad-tail
+ swap {
+ { int-type [ >int-array glClearBufferiv ] }
+ { uint-type [ >uint-array glClearBufferuiv ] }
+ } case ;
+
+:: (clear-color-attachment) ( type attachment value -- )
+ attachment glDrawBuffer
+ type float-type =
+ [ value 4 value last pad-tail first4 glClearColor GL_COLOR_BUFFER_BIT glClear ]
+ [ type value (clear-integer-color-attachment) ] if ;
+
+: framebuffer-rect-size ( framebuffer-rect -- size )
+ [ rect>> dim>> product ]
+ [ framebuffer-rect-image-type (bytes-per-pixel) ] bi * ;
+
+PRIVATE>
+
+: <full-framebuffer-rect> ( framebuffer attachment -- framebuffer-rect )
+ 2dup framebuffer-attachment-at
+ { 0 0 } swap framebuffer-attachment-dim <rect>
+ <framebuffer-rect> ;
+
+: resize-framebuffer ( framebuffer dim -- )
+ [ allocate-framebuffer-attachment ] curry each-attachment ;
+
+:: attach-framebuffer-attachments ( framebuffer -- )
+ GL_DRAW_FRAMEBUFFER framebuffer handle>> glBindFramebuffer
+ framebuffer [ bind-framebuffer-attachment ] each-attachment-target ;
+
+M: framebuffer dispose
+ [ [ delete-framebuffer ] when* f ] change-handle drop ;
+
+: dispose-framebuffer-attachments ( framebuffer -- )
+ [ [ dispose ] when* ] each-attachment ;
+
+: <framebuffer> ( color-attachments depth-attachment stencil-attachment dim -- framebuffer )
+ [ [ 0 ] 3dip framebuffer boa dup ] dip
+ [ resize-framebuffer ] [ drop ] if*
+ gen-framebuffer >>handle
+ dup attach-framebuffer-attachments
+ window-resource ;
+
+:: clear-framebuffer-attachment ( framebuffer attachment-ref value -- )
+ GL_DRAW_FRAMEBUFFER framebuffer framebuffer-handle glBindFramebuffer
+ attachment-ref {
+ { system-attachment [| side face |
+ float-type
+ side face gl-system-attachment
+ value (clear-color-attachment)
+ ] }
+ { color-attachment [| i |
+ framebuffer i (color-attachment-type)
+ GL_COLOR_ATTACHMENT0 i +
+ value (clear-color-attachment)
+ ] }
+ { default-attachment [
+ framebuffer [ (default-attachment-type) ] [ (default-gl-attachment) ] bi
+ value (clear-color-attachment)
+ ] }
+ { depth-attachment [ value glClearDepth GL_DEPTH_BUFFER_BIT glClear ] }
+ { stencil-attachment [ value glClearStencil GL_STENCIL_BUFFER_BIT glClear ] }
+ } match ;
+
+: clear-framebuffer ( framebuffer alist -- )
+ [ first2 clear-framebuffer-attachment ] with each ;
+
+:: read-framebuffer-to ( framebuffer-rect gpu-data-ptr -- )
+ GL_READ_FRAMEBUFFER framebuffer-rect framebuffer>> framebuffer-handle glBindFramebuffer
+ framebuffer-rect [ framebuffer>> ] [ attachment>> ] bi gl-attachment glReadBuffer
+ framebuffer-rect rect>> [ loc>> first2 ] [ dim>> first2 ] bi
+ framebuffer-rect framebuffer-rect-image-type image-data-format
+ gpu-data-ptr pixel-pack-buffer [ glReadPixels ] with-gpu-data-ptr ;
+
+: read-framebuffer ( framebuffer-rect -- byte-array )
+ dup framebuffer-rect-size <byte-array> [ read-framebuffer-to ] keep ;
+
+: read-framebuffer-image ( framebuffer-rect -- image )
+ [ <image> ] dip {
+ [ rect>> dim>> >>dim ]
+ [
+ framebuffer-rect-image-type
+ [ >>component-order ] [ >>component-type ] bi*
+ ]
+ [ read-framebuffer >>bitmap ]
+ } cleave ;
+
+:: copy-framebuffer ( to-fb-rect from-fb-rect depth? stencil? filter -- )
+ GL_DRAW_FRAMEBUFFER to-fb-rect framebuffer>> framebuffer-handle glBindFramebuffer
+ to-fb-rect [ framebuffer>> ] [ attachment>> ] bi gl-attachment glDrawBuffer
+ GL_READ_FRAMEBUFFER from-fb-rect framebuffer>> framebuffer-handle glBindFramebuffer
+ from-fb-rect [ framebuffer>> ] [ attachment>> ] bi gl-attachment glReadBuffer
+ to-fb-rect attachment>> [ GL_COLOR_BUFFER_BIT ] [ 0 ] if
+ depth? [ GL_DEPTH_BUFFER_BIT ] [ 0 ] if bitor
+ stencil? [ GL_STENCIL_BUFFER_BIT ] [ 0 ] if bitor :> mask
+
+ from-fb-rect rect>> rect-extent [ first2 ] bi@
+ to-fb-rect rect>> rect-extent [ first2 ] bi@
+ mask filter gl-mag-filter glBlitFramebuffer ;
+
--- /dev/null
+Render targets for GPU operations
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: help.markup help.syntax ui.gadgets.worlds ;
+IN: gpu
+
+HELP: finish-gpu
+{ $description "Waits for all outstanding GPU commands in the current graphics context to complete." } ;
+
+HELP: flush-gpu
+{ $description "Forces the execution of all outstanding GPU commands in the current graphics context." }
+{ $notes { $snippet "flush-gpu" } " does not wait for execution to finish. For that, use " { $link finish-gpu } "." } ;
+
+{ finish-gpu flush-gpu } related-words
+
+HELP: gpu-object
+{ $class-description "Parent class of all GPU resources." } ;
+
+HELP: init-gpu
+{ $description "Initializes the current graphics context for use with the " { $snippet "gpu" } " library. This should be the first thing called in a world's " { $link begin-world } " method." } ;
+
+HELP: reset-gpu
+{ $description "Clears all framebuffer, GPU buffer, shader, and vertex array bindings. Call this before directly calling OpenGL functions after using " { $snippet "gpu" } " functions." } ;
+
+ARTICLE: "gpu" "Graphics context management"
+"Preparing the GPU library:"
+{ $subsection init-gpu }
+"Forcing execution of queued commands:"
+{ $subsection flush-gpu }
+{ $subsection finish-gpu }
+"Resetting OpenGL state:"
+{ $subsection reset-gpu } ;
+
+ARTICLE: "gpu-summary" "GPU-accelerated rendering"
+"The " { $vocab-link "gpu" } " library is a set of vocabularies that work together to provide a convenient interface to creating, managing, and using GPU resources."
+{ $subsection "gpu" }
+{ $subsection "gpu.state" }
+{ $subsection "gpu.buffers" }
+{ $subsection "gpu.textures" }
+{ $subsection "gpu.framebuffers" }
+{ $subsection "gpu.shaders" }
+{ $subsection "gpu.render" }
+"The library is built on top of the OpenGL API, but it aims to be complete enough that raw OpenGL calls are never needed. OpenGL 2.0 with the vertex array object extension (" { $snippet "GL_APPLE_vertex_array_object" } " or " { $snippet "GL_ARB_vertex_array_object" } ") is required. Some features require later OpenGL versions or additional extensions; these requirements are documented alongside individual words. To make full use of the library, an OpenGL 3.1 or later implementation is recommended." ;
+
+ABOUT: "gpu-summary"
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: kernel namespaces opengl.capabilities opengl.gl variants ;
+IN: gpu
+
+TUPLE: gpu-object < identity-tuple handle ;
+
+<PRIVATE
+
+VARIANT: gpu-api
+ opengl-2 opengl-3 ;
+
+: set-gpu-api ( -- )
+ "2.0" require-gl-version
+ "3.0" has-gl-version? opengl-3 opengl-2 ? gpu-api set-global ;
+
+HOOK: init-gpu-api gpu-api ( -- )
+
+M: opengl-2 init-gpu-api
+ GL_POINT_SPRITE glEnable ;
+M: opengl-3 init-gpu-api
+ ;
+
+PRIVATE>
+
+: init-gpu ( -- )
+ set-gpu-api
+ init-gpu-api ;
+
+: reset-gpu ( -- )
+ "3.0" { { "GL_APPLE_vertex_array_object" "GL_ARB_vertex_array_object" } }
+ has-gl-version-or-extensions?
+ [ 0 glBindVertexArray ] when
+
+ "3.0" { { "GL_EXT_framebuffer_object" "GL_ARB_framebuffer_object" } }
+ has-gl-version-or-extensions? [
+ GL_DRAW_FRAMEBUFFER 0 glBindFramebuffer
+ GL_READ_FRAMEBUFFER 0 glBindFramebuffer
+ GL_RENDERBUFFER 0 glBindRenderbuffer
+ ] when
+
+ "1.5" { "GL_ARB_vertex_buffer_object" }
+ has-gl-version-or-extensions? [
+ GL_ARRAY_BUFFER 0 glBindBuffer
+ GL_ELEMENT_ARRAY_BUFFER 0 glBindBuffer
+ ] when
+
+ "2.1" { "GL_ARB_pixel_buffer_object" }
+ has-gl-version-or-extensions? [
+ GL_PIXEL_PACK_BUFFER 0 glBindBuffer
+ GL_PIXEL_UNPACK_BUFFER 0 glBindBuffer
+ ] when
+
+ "2.0" { "GL_ARB_shader_objects" }
+ has-gl-version-or-extensions?
+ [ 0 glUseProgram ] when ;
+
+: flush-gpu ( -- )
+ glFlush ;
+
+: finish-gpu ( -- )
+ glFinish ;
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: alien alien.syntax byte-arrays classes gpu.buffers
+gpu.framebuffers gpu.shaders gpu.textures help.markup
+help.syntax images kernel math multiline sequences
+specialized-arrays.alien specialized-arrays.uint
+specialized-arrays.ulong strings ;
+IN: gpu.render
+
+HELP: <index-elements>
+{ $values
+ { "ptr" gpu-data-ptr } { "count" integer } { "index-type" index-type }
+ { "index-elements" index-elements }
+}
+{ $description "Constructs an " { $link index-elements } " tuple." } ;
+
+HELP: <index-range>
+{ $values
+ { "start" integer } { "count" integer }
+ { "index-range" index-range }
+}
+{ $description "Constructs an " { $link index-range } " tuple." } ;
+
+HELP: <multi-index-elements>
+{ $values
+ { "buffer" { $maybe buffer } } { "ptrs" "an " { $link uint-array } " or " { $link void*-array } } { "counts" uint-array } { "index-type" index-type }
+ { "multi-index-elements" multi-index-elements }
+}
+{ $description "Constructs a " { $link multi-index-elements } " tuple." } ;
+
+HELP: <multi-index-range>
+{ $values
+ { "starts" uint-array } { "counts" uint-array }
+ { "multi-index-range" multi-index-range }
+}
+{ $description "Constructs a " { $link multi-index-range } " tuple." } ;
+
+HELP: <vertex-array>
+{ $values
+ { "program-instance" program-instance } { "vertex-formats" "a list of " { $link buffer-ptr } "/" { $link vertex-format } " pairs" }
+ { "vertex-array" vertex-array }
+}
+{ $description "Creates a new " { $link vertex-array } " to feed data to " { $snippet "program-instance" } " from the set of " { $link buffer } "s specified in " { $snippet "vertex-formats" } "." } ;
+
+HELP: UNIFORM-TUPLE:
+{ $syntax <" UNIFORM-TUPLE: class-name
+ { "slot" uniform-type dimension }
+ { "slot" uniform-type dimension }
+ ...
+ { "slot" uniform-type dimension } ; "> }
+{ $description "Defines a new " { $link uniform-tuple } " class. Tuples of the new class can be used as the " { $snippet "uniforms" } " slot of a " { $link render-set } " in order to set the uniform parameters of the active shader program. The " { $link uniform-type } " of each slot defines the component type, and the " { $snippet "dimension" } " defines the vector or matrix dimensions; for example, a slot " { $snippet "{ \"foo\" float-uniform { 2 2 } }" } " will define a slot " { $snippet "foo" } " as a 2x2 matrix of floats."
+$nl
+"Uniform parameters are passed from Factor to the shader program through the uniform tuple as follows:"
+{ $list
+{ { $link int-uniform } "s and " { $link uint-uniform } "s take their values from Factor " { $link integer } "s." }
+{ { $link float-uniform } "s take their values from Factor " { $link float } "s." }
+{ { $link bool-uniform } "s take their values from Factor " { $link boolean } "s." }
+{ { $link texture-uniform } "s take their values from " { $link texture } " objects." }
+{ "Vector uniforms are passed as Factor " { $link sequence } "s of the corresponding component type." }
+{ "Matrix uniforms are passed as row-major Factor " { $link sequence } "s of sequences of the corresponding component type." } }
+"A value of a uniform tuple type is a standard Factor tuple. Uniform tuples are constructed with " { $link new } " or " { $link boa } ", and values are placed inside them using standard slot accessors."
+} ;
+
+HELP: VERTEX-FORMAT:
+{ $syntax <" VERTEX-FORMAT: format-name
+ { "attribute"/f component-type dimension normalize? }
+ { "attribute"/f component-type dimension normalize? }
+ ...
+ { "attribute"/f component-type dimension normalize? } ; "> }
+{ $description "Defines a new binary " { $link vertex-format } " for structuring vertex data stored in " { $link buffer } "s. Each " { $snippet "attribute" } " name either corresponds to an input parameter of a vertex shader, or is " { $link f } " to include padding in the vertex format. The " { $link component-type } " determines the format of the components, and the " { $snippet "dimension" } " determines the number of components. If the " { $snippet "component-type" } " is an integer type and " { $snippet "normalize?" } " is true, the component values will be scaled to the range 0.0 to 1.0 when fed to the vertex shader; otherwise, they will be cast to floats retaining their integral values." } ;
+
+HELP: VERTEX-STRUCT:
+{ $syntax <" VERTEX-STRUCT: struct-name format-name "> }
+{ $description "Defines a struct C type (like " { $link POSTPONE: C-STRUCT: } ") with the same binary format and component types as the given " { $link vertex-format } "." } ;
+
+HELP: bool-uniform
+{ $class-description "This " { $link uniform-type } " value indicates a uniform parameter whose components are " { $snippet "bool" } "s." } ;
+
+HELP: buffer>vertex-array
+{ $values
+ { "vertex-buffer" buffer } { "program-instance" program-instance } { "format" vertex-format }
+ { "vertex-array" vertex-array }
+}
+{ $description "Creates a new " { $link vertex-array } " from the entire contents of a single " { $link buffer } " in a single " { $link vertex-format } " for use with " { $snippet "program-instance" } "." } ;
+
+{ vertex-array <vertex-array> buffer>vertex-array } related-words
+
+HELP: define-uniform-tuple
+{ $values
+ { "class" class } { "superclass" class } { "uniforms" sequence }
+}
+{ $description "Defines a new " { $link uniform-tuple } " as a subclass of " { $snippet "superclass" } " with the slots specified by the " { $link uniform } " tuple values in " { $snippet "uniforms" } ". The runtime equivalent of " { $link POSTPONE: UNIFORM-TUPLE: } ". This word must be called inside a compilation unit." } ;
+
+HELP: define-vertex-format
+{ $values
+ { "class" class } { "vertex-attributes" sequence }
+}
+{ $description "Defines a new " { $link vertex-format } " with the binary format specified by the " { $link vertex-attribute } " tuple values in " { $snippet "vertex-attributes" } ". The runtime equivalent of " { $link POSTPONE: VERTEX-FORMAT: } ". This word must be called inside a compilation unit." } ;
+
+HELP: define-vertex-struct
+{ $values
+ { "struct-name" string } { "vertex-format" vertex-format }
+}
+{ $description "Defines a new struct C type from a " { $link vertex-format } ". The runtime equivalent of " { $link POSTPONE: VERTEX-STRUCT: } ". This word must be called inside a compilation unit." } ;
+
+HELP: float-uniform
+{ $class-description "This " { $link uniform-type } " value indicates a uniform parameter whose components are " { $snippet "float" } "s." } ;
+
+{ bool-uniform int-uniform float-uniform texture-uniform } related-words
+
+{ index-elements index-range multi-index-elements multi-index-range } related-words
+
+HELP: index-elements
+{ $class-description "Objects of this tuple class can be passed as the " { $snippet "indexes" } " slot of a " { $link render-set } " to instruct " { $link render } " to assemble primitives from the active " { $link vertex-array } " by using an array of indexes in CPU or GPU memory."
+{ $list
+{ "The " { $snippet "ptr" } " slot contains a " { $link byte-array } ", " { $link alien } ", or " { $link buffer-ptr } " value referencing the beginning of the index array." }
+{ "The " { $snippet "count" } " slot contains an " { $link integer } " value specifying the number of indexes to supply from the array." }
+{ "The " { $snippet "index-type" } " slot contains an " { $link index-type } " value specifying whether the array consists of " { $link ubyte-indexes } ", " { $link ushort-indexes } ", or " { $link uint-indexes } "." }
+} } ;
+
+HELP: index-range
+{ $class-description "Objects of this tuple class can be passed as the " { $snippet "indexes" } " slot of a " { $link render-set } " to instruct " { $link render } " to assemble primitives sequentially from a slice of the active " { $link vertex-array } "."
+{ $list
+{ "The " { $snippet "start" } " slot contains an " { $link integer } " value indicating the first element of the array to draw." }
+{ "The " { $snippet "count" } " slot contains an " { $link integer } " value indicating the number of elements to draw." }
+} } ;
+
+HELP: index-type
+{ $class-description "The " { $snippet "index-type" } " slot of an " { $link index-elements } " or " { $link multi-index-elements } " tuple indicates the type of the index array's elements: one-byte " { $link ubyte-indexes } ", two-byte " { $link ushort-indexes } ", or four-byte " { $link uint-indexes } "." } ;
+
+{ index-type ubyte-indexes ushort-indexes uint-indexes } related-words
+
+HELP: int-uniform
+{ $class-description "This " { $link uniform-type } " value indicates a uniform parameter whose components are " { $snippet "int" } "s." } ;
+
+HELP: invalid-uniform-type
+{ $values
+ { "uniform" uniform }
+}
+{ $description "Throws an error indicating that a slot of a " { $link uniform-tuple } " has been declared to have an invalid type." } ;
+
+HELP: lines-mode
+{ $class-description "This " { $link primitive-mode } " value instructs " { $link render } " to assemble a line from each pair of indexed vertex array elements." } ;
+
+HELP: line-loop-mode
+{ $class-description "This " { $link primitive-mode } " value instructs " { $link render } " to assemble a connected loop of lines from each consecutive pair of indexed vertex array elements, adding another line to close the last and first elements." } ;
+
+HELP: line-strip-mode
+{ $class-description "This " { $link primitive-mode } " value instructs " { $link render } " to assemble a connected strip of lines from each consecutive pair of indexed vertex array elements." } ;
+
+HELP: multi-index-elements
+{ $class-description "Objects of this tuple class can be passed as the " { $snippet "indexes" } " slot of a non-instanced " { $link render-set } " to instruct " { $link render } " to assemble primitives from the active " { $link vertex-array } " by using multiple arrays of indexes in CPU or GPU memory."
+{ $list
+{ "The " { $snippet "buffer" } " slot contains either a " { $link buffer } " object to read indexes from, or " { $link f } " to read from CPU memory." }
+{ "The " { $snippet "ptrs" } " slot contains either a " { $link void*-array } " of pointers to the starts of index data, or a pointer-sized " { $link ulong-array } " of offsets into " { $snippet "buffer" } "." }
+{ "The " { $snippet "counts" } " slot contains a " { $link uint-array } " containing the number of indexes to read from each pointer or offset in " { $snippet "ptrs" } "." }
+{ "The " { $snippet "index-type" } " slot contains an " { $link index-type } " value specifying whether the arrays consist of " { $link ubyte-indexes } ", " { $link ushort-indexes } ", or " { $link uint-indexes } "." }
+} } ;
+
+HELP: multi-index-range
+{ $class-description "Objects of this tuple class can be passed as the " { $snippet "indexes" } " slot of a non-instanced " { $link render-set } " to instruct " { $link render } " to assemble primitives from the active " { $link vertex-array } " by using multiple consecutive slices of its elements."
+{ $list
+{ "The " { $snippet "starts" } " slot contains a " { $link uint-array } " of indexes into the array from which to start generating primitives." }
+{ "The " { $snippet "counts" } " slot contains a " { $link uint-array } " of corresponding counts of indexes to read from each specified " { $snippet "start" } " index." }
+} } ;
+
+HELP: points-mode
+{ $class-description "This " { $link primitive-mode } " value instructs " { $link render } " to generate a point for each indexed vertex array element." } ;
+
+HELP: primitive-mode
+{ $class-description "The " { $snippet "primitive-mode" } " slot of a " { $link render-set } " tells " { $link render } " what kind of primitives to generate and how to assemble them from the selected elements of the active " { $link vertex-array } "." }
+{ $list
+{ { $link points-mode } " causes each element to generate a point." }
+{ { $link lines-mode } " causes each pair of elements to generate a disconnected line." }
+{ { $link line-strip-mode } " causes each consecutive pair of elements to generate a connected strip of lines." }
+{ { $link line-loop-mode } " causes each consecutive pair of elements to generate a connected loop of lines, with an extra line connecting the last and first elements." }
+{ { $link triangles-mode } " causes every 3 elements to generate an independent triangle." }
+{ { $link triangle-strip-mode } " causes every consecutive group of 3 elements to generate a connected strip of triangles." }
+{ { $link triangle-fan-mode } " causes a triangle to be generated from the first element and every subsequent consecutive pair of elements in a fan pattern." } } ;
+
+{ primitive-mode points-mode lines-mode line-strip-mode line-loop-mode triangles-mode triangle-strip-mode triangle-fan-mode } related-words
+
+HELP: render
+{ $values
+ { "render-set" render-set }
+}
+{ $description "Submits a rendering job to the GPU. The values in the " { $link render-set } " tuple describe the job." } ;
+
+HELP: render-set
+{ $class-description "A " { $snippet "render-set" } " tuple describes a GPU rendering job."
+{ $list
+{ "The " { $link primitive-mode } " slot determines what kind of primitives should be rendered, and how they should be assembled." }
+{ "The " { $link vertex-array } " slot supplies the shader program and vertex data to be rendered." }
+{ "The " { $snippet "uniforms" } " slot contains a " { $link uniform-tuple } " with values for the shader program's uniform parameters." }
+{ "The " { $snippet "indexes" } " slot contains one of the " { $link vertex-indexes } " types and selects elements from the vertex array to be rendered." }
+{ "The " { $snippet "instances" } " slot, if not " { $link f } ", instructs the GPU to render several instances of the same set of vertexes. Instancing requires OpenGL 3.1 or one of the " { $snippet "GL_EXT_draw_instanced" } " or " { $snippet "GL_ARB_draw_instanced" } " extensions." }
+{ "The " { $snippet "framebuffer" } " slot determines the target for the rendering output. Either the " { $link system-framebuffer } " or a user-created " { $link framebuffer } " object can be specified. User-created framebuffers require OpenGL 3.0 or one of the " { $snippet "GL_EXT_framebuffer_object" } " or " { $snippet "GL_ARB_framebuffer_object" } " extensions." }
+{ "The " { $snippet "output-attachments" } " slot specifies which of the framebuffer's " { $link color-attachment-ref } "s to write the fragment shader's color output to. If the shader uses " { $snippet "gl_FragColor" } " or " { $snippet "gl_FragData[n]" } " to write its output, then " { $snippet "output-attachments" } " should be an array of " { $link color-attachment-ref } "s, and the output to color attachment binding is determined positionally. If the shader uses named output values, then " { $snippet "output-attachments" } " should be a list of string/" { $link color-attachment-ref } " pairs, mapping output names to color attachments. Named output values are available in GLSL 1.30 or later, and GLSL 1.20 and earlier using the " { $snippet "GL_EXT_gpu_shader4" } " extension." }
+} } ;
+
+{ render render-set } related-words
+
+HELP: texture-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " is a texture. The dimension of the corresponding " { $link uniform } " slot must be " { $snippet "1" } "." } ;
+
+HELP: triangle-fan-mode
+{ $class-description "This " { $link primitive-mode } " value instructs " { $link render } " to generate a fan of triangles using the first indexed vertex array element and every subsequent consecutive pair of elements." } ;
+
+HELP: triangle-strip-mode
+{ $class-description "This " { $link primitive-mode } " value instructs " { $link render } " to generate a strip of triangles using every consecutive group of 3 indexed vertex array elements." } ;
+
+HELP: triangles-mode
+{ $class-description "This " { $link primitive-mode } " value instructs " { $link render } " to generate a triangle for each group of 3 indexed vertex array elements." } ;
+
+HELP: ubyte-indexes
+{ $class-description "This " { $link index-type } " indicates that an " { $link index-elements } " or " { $link multi-index-elements } " buffer consists of unsigned byte indexes." } ;
+
+HELP: uint-indexes
+{ $class-description "This " { $link index-type } " indicates that an " { $link index-elements } " or " { $link multi-index-elements } " buffer consists of four-byte unsigned int indexes." } ;
+
+HELP: uint-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " is a scalar or vector of unsigned integers." } ;
+
+HELP: uniform
+{ $class-description "Values of this tuple type are passed to " { $link define-uniform-tuple } " to define a new " { $link uniform-tuple } " type." } ;
+
+HELP: uniform-tuple
+{ $class-description "The base class for tuple types defined with " { $link POSTPONE: UNIFORM-TUPLE: } ". A uniform tuple is used as part of a " { $link render-set } " to supply values for a shader program's uniform parameters. See the " { $link POSTPONE: UNIFORM-TUPLE: } " documentation for details on how uniform tuples are defined and used." } ;
+
+HELP: uniform-type
+{ $class-description { $snippet "uniform-type" } " values are used as part of a " { $link POSTPONE: UNIFORM-TUPLE: } " definition to define the types of uniform slots." } ;
+
+{ uniform-type bool-uniform int-uniform float-uniform texture-uniform uint-uniform } related-words
+
+HELP: ushort-indexes
+{ $class-description "This " { $link index-type } " indicates that an " { $link index-elements } " or " { $link multi-index-elements } " buffer consists of two-byte unsigned short indexes." } ;
+
+{ index-type ubyte-indexes ushort-indexes uint-indexes } related-words
+
+HELP: vertex-array
+{ $class-description "A " { $snippet "vertex-array" } " object associates a shader " { $link program-instance } " with vertex attribute data from one or more " { $link buffer } "s. The format of the binary data inside these buffers is described using " { $link vertex-format } "s. " { $snippet "vertex-array" } "s are constructed using the " { $link <vertex-array> } " or " { $link buffer>vertex-array } " words." } ;
+
+HELP: vertex-array-buffer
+{ $values
+ { "vertex-array" vertex-array }
+ { "vertex-buffer" buffer }
+}
+{ $description "Returns the first " { $link buffer } " object comprised in " { $snippet "vertex-array" } "." } ;
+
+HELP: vertex-attribute
+{ $class-description "This tuple type is passed to " { $link define-vertex-format } " to define a new " { $link vertex-format } " type." } ;
+
+HELP: vertex-format
+{ $class-description "This class encompasses all vertex formats defined by " { $link POSTPONE: VERTEX-FORMAT: } ". A vertex format defines the binary layout of vertex attribute data in a " { $link buffer } " for use as part of a " { $link vertex-array } ". See the " { $link POSTPONE: VERTEX-FORMAT: } " documentation for details on how vertex formats are defined." } ;
+
+HELP: vertex-format-size
+{ $values
+ { "format" vertex-format }
+ { "size" integer }
+}
+{ $description "Returns the size in bytes of a set of vertex attributes in " { $snippet "format" } "." } ;
+
+HELP: vertex-indexes
+{ $class-description "This class is a union of the following tuple types, any of which can be used as the " { $snippet "indexes" } " slot of a " { $link render-set } " to select elements from a " { $link vertex-array } " for rendering."
+{ $list
+{ "An " { $link index-range } " value submits a sequential slice of a vertex array for rendering." }
+{ "An " { $link index-elements } " value submits vertex array elements in an order specified by an array of indexes." }
+{ "A " { $link multi-index-range } " value submits multiple sequential slices of a vertex array." }
+{ "A " { $link multi-index-elements } " value submits multiple separate lists of indexed vertex array elements." }
+} } ;
+
+ARTICLE: "gpu.render" "Rendering"
+"The " { $vocab-link "gpu.render" } " vocabulary contains words for organizing and submitting data to the GPU for rendering."
+{ $subsection render }
+{ $subsection render-set }
+"Render data inside GPU " { $link buffer } "s is organized into " { $link vertex-array } "s for consumption by shader code:"
+{ $subsection vertex-array }
+{ $subsection <vertex-array> }
+{ $subsection buffer>vertex-array }
+{ $subsection POSTPONE: VERTEX-FORMAT: }
+{ $link uniform-tuple } "s provide Factor types for containing and submitting shader uniform parameters:"
+{ $subsection POSTPONE: UNIFORM-TUPLE: }
+;
+
+ABOUT: "gpu.render"
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors alien alien.c-types alien.structs arrays
+assocs classes.mixin classes.parser classes.singleton
+classes.tuple classes.tuple.private combinators destructors fry
+generic generic.parser gpu gpu.buffers gpu.framebuffers
+gpu.framebuffers.private gpu.shaders gpu.state gpu.textures
+gpu.textures.private half-floats images kernel lexer locals
+math math.order math.parser namespaces opengl opengl.gl parser
+quotations sequences slots sorting specialized-arrays.alien
+specialized-arrays.float specialized-arrays.int
+specialized-arrays.uint strings ui.gadgets.worlds variants
+vocabs.parser words ;
+IN: gpu.render
+
+UNION: ?string string POSTPONE: f ;
+UNION: uniform-dim integer sequence ;
+
+TUPLE: vertex-attribute
+ { name ?string read-only initial: f }
+ { component-type component-type read-only initial: float-components }
+ { dim integer read-only initial: 4 }
+ { normalize? boolean read-only initial: f } ;
+
+VARIANT: uniform-type
+ bool-uniform
+ uint-uniform
+ int-uniform
+ float-uniform
+ texture-uniform ;
+
+TUPLE: uniform
+ { name string read-only initial: "" }
+ { uniform-type uniform-type read-only initial: float-uniform }
+ { dim uniform-dim read-only initial: 4 } ;
+
+VARIANT: index-type
+ ubyte-indexes
+ ushort-indexes
+ uint-indexes ;
+
+TUPLE: index-range
+ { start integer read-only }
+ { count integer read-only } ;
+
+C: <index-range> index-range
+
+TUPLE: multi-index-range
+ { starts uint-array read-only }
+ { counts uint-array read-only } ;
+
+C: <multi-index-range> multi-index-range
+
+UNION: ?integer integer POSTPONE: f ;
+
+TUPLE: index-elements
+ { ptr gpu-data-ptr read-only }
+ { count integer read-only }
+ { index-type index-type read-only } ;
+
+C: <index-elements> index-elements
+
+UNION: ?buffer buffer POSTPONE: f ;
+
+TUPLE: multi-index-elements
+ { buffer ?buffer read-only }
+ { ptrs read-only }
+ { counts uint-array read-only }
+ { index-type index-type read-only } ;
+
+C: <multi-index-elements> multi-index-elements
+
+UNION: vertex-indexes
+ index-range
+ multi-index-range
+ index-elements
+ multi-index-elements ;
+
+VARIANT: primitive-mode
+ points-mode
+ lines-mode
+ line-strip-mode
+ line-loop-mode
+ triangles-mode
+ triangle-strip-mode
+ triangle-fan-mode ;
+
+MIXIN: vertex-format
+
+TUPLE: uniform-tuple ;
+
+GENERIC: vertex-format-size ( format -- size )
+
+ERROR: invalid-uniform-type uniform ;
+
+<PRIVATE
+
+: gl-vertex-type ( component-type -- gl-type )
+ {
+ { ubyte-components [ GL_UNSIGNED_BYTE ] }
+ { ushort-components [ GL_UNSIGNED_SHORT ] }
+ { uint-components [ GL_UNSIGNED_INT ] }
+ { half-components [ GL_HALF_FLOAT ] }
+ { float-components [ GL_FLOAT ] }
+ { byte-integer-components [ GL_BYTE ] }
+ { short-integer-components [ GL_SHORT ] }
+ { int-integer-components [ GL_INT ] }
+ { ubyte-integer-components [ GL_UNSIGNED_BYTE ] }
+ { ushort-integer-components [ GL_UNSIGNED_SHORT ] }
+ { uint-integer-components [ GL_UNSIGNED_INT ] }
+ } case ;
+
+: vertex-type-size ( component-type -- size )
+ {
+ { ubyte-components [ 1 ] }
+ { ushort-components [ 2 ] }
+ { uint-components [ 4 ] }
+ { half-components [ 2 ] }
+ { float-components [ 4 ] }
+ { byte-integer-components [ 1 ] }
+ { short-integer-components [ 2 ] }
+ { int-integer-components [ 4 ] }
+ { ubyte-integer-components [ 1 ] }
+ { ushort-integer-components [ 2 ] }
+ { uint-integer-components [ 4 ] }
+ } case ;
+
+: vertex-attribute-size ( vertex-attribute -- size )
+ [ component-type>> vertex-type-size ] [ dim>> ] bi * ;
+
+: vertex-attributes-size ( vertex-attributes -- size )
+ [ vertex-attribute-size ] [ + ] map-reduce ;
+
+: gl-index-type ( index-type -- gl-index-type )
+ {
+ { ubyte-indexes [ GL_UNSIGNED_BYTE ] }
+ { ushort-indexes [ GL_UNSIGNED_SHORT ] }
+ { uint-indexes [ GL_UNSIGNED_INT ] }
+ } case ;
+
+: gl-primitive-mode ( primitive-mode -- gl-primitive-mode )
+ {
+ { points-mode [ GL_POINTS ] }
+ { lines-mode [ GL_LINES ] }
+ { line-strip-mode [ GL_LINE_STRIP ] }
+ { line-loop-mode [ GL_LINE_LOOP ] }
+ { triangles-mode [ GL_TRIANGLES ] }
+ { triangle-strip-mode [ GL_TRIANGLE_STRIP ] }
+ { triangle-fan-mode [ GL_TRIANGLE_FAN ] }
+ } case ;
+
+GENERIC: render-vertex-indexes ( primitive-mode vertex-indexes -- )
+
+GENERIC# render-vertex-indexes-instanced 1 ( primitive-mode vertex-indexes instances -- )
+
+M: index-range render-vertex-indexes
+ [ gl-primitive-mode ] [ [ start>> ] [ count>> ] bi ] bi* glDrawArrays ;
+
+M: index-range render-vertex-indexes-instanced
+ [ gl-primitive-mode ] [ [ start>> ] [ count>> ] bi ] [ ] tri*
+ glDrawArraysInstanced ;
+
+M: multi-index-range render-vertex-indexes
+ [ gl-primitive-mode ] [ [ starts>> ] [ counts>> dup length ] bi ] bi*
+ glMultiDrawArrays ;
+
+M: index-elements render-vertex-indexes
+ [ gl-primitive-mode ]
+ [ [ count>> ] [ index-type>> gl-index-type ] [ ptr>> ] tri ] bi*
+ index-buffer [ glDrawElements ] with-gpu-data-ptr ;
+
+M: index-elements render-vertex-indexes-instanced
+ [ gl-primitive-mode ]
+ [ [ count>> ] [ index-type>> gl-index-type ] [ ptr>> ] tri ]
+ [ ] tri*
+ swap index-buffer [ swap glDrawElementsInstanced ] with-gpu-data-ptr ;
+
+M: multi-index-elements render-vertex-indexes
+ [ gl-primitive-mode ]
+ [ { [ counts>> ] [ index-type>> gl-index-type ] [ ptrs>> dup length ] [ buffer>> ] } cleave ]
+ bi*
+ GL_ELEMENT_ARRAY_BUFFER swap [ handle>> ] [ 0 ] if* glBindBuffer glMultiDrawElements ;
+
+: (bind-texture-unit) ( texture-unit texture -- )
+ [ GL_TEXTURE0 + glActiveTexture ] [ bind-texture drop ] bi* ; inline
+
+:: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot )
+ vertex-attribute name>> :> name
+ vertex-attribute component-type>> :> type
+ type gl-vertex-type :> gl-type
+ vertex-attribute dim>> :> dim
+ vertex-attribute normalize?>> >c-bool :> normalize?
+ vertex-attribute vertex-attribute-size :> size
+
+ stride offset size +
+ {
+ { [ name not ] [ [ 2drop ] ] }
+ {
+ [ type unnormalized-integer-components? ]
+ [
+ {
+ name attribute-index [ glEnableVertexAttribArray ] keep
+ dim gl-type stride offset
+ } >quotation :> dip-block
+
+ { dip-block dip <displaced-alien> glVertexAttribIPointer } >quotation
+ ]
+ }
+ [
+ {
+ name attribute-index [ glEnableVertexAttribArray ] keep
+ dim gl-type normalize? stride offset
+ } >quotation :> dip-block
+
+ { dip-block dip <displaced-alien> glVertexAttribPointer } >quotation
+ ]
+ } cond ;
+
+:: [bind-vertex-format] ( vertex-attributes -- quot )
+ vertex-attributes vertex-attributes-size :> stride
+ stride 0 vertex-attributes [ [bind-vertex-attribute] ] { } map-as 2nip :> attributes-cleave
+ { attributes-cleave 2cleave } >quotation :> with-block
+
+ { drop vertex-buffer with-block with-buffer-ptr } >quotation ;
+
+GENERIC: bind-vertex-format ( program-instance buffer-ptr format -- )
+
+: define-vertex-format-methods ( class vertex-attributes -- )
+ [
+ [ \ bind-vertex-format create-method-in ] dip
+ [bind-vertex-format] define
+ ] [
+ [ \ vertex-format-size create-method-in ] dip
+ [ \ drop ] dip vertex-attributes-size [ ] 2sequence define
+ ] 2bi ;
+
+GENERIC: bind-uniform-textures ( program-instance uniform-tuple -- )
+GENERIC: bind-uniforms ( program-instance uniform-tuple -- )
+
+M: uniform-tuple bind-uniform-textures
+ 2drop ;
+M: uniform-tuple bind-uniforms
+ 2drop ;
+
+: uniform-slot-type ( uniform -- type )
+ dup dim>> 1 = [
+ uniform-type>> {
+ { bool-uniform [ boolean ] }
+ { uint-uniform [ integer ] }
+ { int-uniform [ integer ] }
+ { float-uniform [ float ] }
+ { texture-uniform [ texture ] }
+ } case
+ ] [ drop sequence ] if ;
+
+: uniform>slot ( uniform -- slot )
+ [ name>> ] [ uniform-slot-type ] bi 2array ;
+
+:: [bind-uniform-texture] ( uniform index -- quot )
+ uniform name>> reader-word :> value>>-word
+ { index swap value>>-word (bind-texture-unit) } >quotation ;
+
+:: [bind-uniform-textures] ( superclass uniforms -- quot )
+ superclass "uniform-tuple-texture-units" word-prop 0 or :> first-texture-unit
+ superclass \ bind-uniform-textures method :> next-method
+ uniforms
+ [ uniform-type>> texture-uniform = ] filter
+ [ first-texture-unit + [bind-uniform-texture] ] map-index
+ :> texture-uniforms-cleave
+
+ {
+ 2dup next-method
+ nip texture-uniforms-cleave cleave
+ } >quotation ;
+
+:: [bind-uniform] ( texture-unit uniform -- texture-unit' quot )
+ uniform name>> :> name
+ { name uniform-index } >quotation :> index-quot
+ uniform name>> reader-word 1quotation :> value>>-quot
+ { index-quot value>>-quot bi* } >quotation :> pre-quot
+
+ uniform [ uniform-type>> ] [ dim>> ] bi 2array H{
+ { { bool-uniform 1 } [ >c-bool glUniform1i ] }
+ { { int-uniform 1 } [ glUniform1i ] }
+ { { uint-uniform 1 } [ glUniform1ui ] }
+ { { float-uniform 1 } [ glUniform1f ] }
+
+ { { bool-uniform 2 } [ [ >c-bool ] map first2 glUniform2i ] }
+ { { int-uniform 2 } [ first2 glUniform2i ] }
+ { { uint-uniform 2 } [ first2 glUniform2ui ] }
+ { { float-uniform 2 } [ first2 glUniform2f ] }
+
+ { { bool-uniform 3 } [ [ >c-bool ] map first3 glUniform3i ] }
+ { { int-uniform 3 } [ first3 glUniform3i ] }
+ { { uint-uniform 3 } [ first3 glUniform3ui ] }
+ { { float-uniform 3 } [ first3 glUniform3f ] }
+
+ { { bool-uniform 4 } [ [ >c-bool ] map first4 glUniform4i ] }
+ { { int-uniform 4 } [ first4 glUniform4i ] }
+ { { uint-uniform 4 } [ first4 glUniform4ui ] }
+ { { float-uniform 4 } [ first4 glUniform4f ] }
+
+ { { float-uniform { 2 2 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix2fv ] }
+ { { float-uniform { 3 2 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix2x3fv ] }
+ { { float-uniform { 4 2 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix2x4fv ] }
+
+ { { float-uniform { 2 3 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix3x2fv ] }
+ { { float-uniform { 3 3 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix3fv ] }
+ { { float-uniform { 4 3 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix3x4fv ] }
+
+ { { float-uniform { 2 4 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix4x2fv ] }
+ { { float-uniform { 3 4 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix4x3fv ] }
+ { { float-uniform { 4 4 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix4fv ] }
+
+ { { texture-uniform 1 } { drop texture-unit glUniform1i } }
+ } at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot
+
+ uniform uniform-type>> texture-uniform =
+ [ texture-unit 1 + ] [ texture-unit ] if
+ pre-quot value-quot append ;
+
+:: [bind-uniforms] ( superclass uniforms -- quot )
+ superclass "uniform-tuple-texture-units" word-prop 0 or :> first-texture-unit
+ superclass \ bind-uniforms method :> next-method
+ first-texture-unit uniforms [ [bind-uniform] ] map nip :> uniforms-cleave
+
+ {
+ 2dup next-method
+ uniforms-cleave 2cleave
+ } >quotation ;
+
+: define-uniform-tuple-methods ( class superclass uniforms -- )
+ [
+ [ \ bind-uniform-textures create-method-in ] 2dip
+ [bind-uniform-textures] define
+ ] [
+ [ \ bind-uniforms create-method-in ] 2dip
+ [bind-uniforms] define
+ ] 3bi ;
+
+: parse-uniform-tuple-definition ( -- class superclass uniforms )
+ CREATE-CLASS scan {
+ { ";" [ uniform-tuple f ] }
+ { "<" [ scan-word parse-definition [ first3 uniform boa ] map ] }
+ { "{" [
+ uniform-tuple
+ \ } parse-until parse-definition swap prefix
+ [ first3 uniform boa ] map
+ ] }
+ } case ;
+
+: component-type>c-type ( component-type -- c-type )
+ {
+ { ubyte-components [ "uchar" ] }
+ { ushort-components [ "ushort" ] }
+ { uint-components [ "uint" ] }
+ { half-components [ "half" ] }
+ { float-components [ "float" ] }
+ { byte-integer-components [ "char" ] }
+ { ubyte-integer-components [ "uchar" ] }
+ { short-integer-components [ "short" ] }
+ { ushort-integer-components [ "ushort" ] }
+ { int-integer-components [ "int" ] }
+ { uint-integer-components [ "uint" ] }
+ } case ;
+
+: c-array-dim ( dim -- string )
+ dup 1 = [ drop "" ] [ number>string "[" "]" surround ] if ;
+
+SYMBOL: padding-no
+padding-no [ 0 ] initialize
+
+: padding-name ( -- name )
+ "padding-"
+ padding-no get number>string append
+ "(" ")" surround
+ padding-no inc ;
+
+: vertex-attribute>c-type ( vertex-attribute -- {type,name} )
+ [
+ [ component-type>> component-type>c-type ]
+ [ dim>> c-array-dim ] bi append
+ ] [ name>> [ padding-name ] unless* ] bi 2array ;
+
+: (define-uniform-tuple) ( class superclass uniforms -- )
+ {
+ [ [ uniform>slot ] map define-tuple-class ]
+ [ define-uniform-tuple-methods ]
+ [
+ [ "uniform-tuple-texture-units" word-prop 0 or ]
+ [ [ uniform-type>> texture-uniform = ] filter length ] bi* +
+ "uniform-tuple-texture-units" set-word-prop
+ ]
+ [ nip "uniform-tuple-slots" set-word-prop ]
+ } 3cleave ;
+
+: true-subclasses ( class -- seq )
+ [ subclasses ] keep [ = not ] curry filter ;
+
+: redefine-uniform-tuple-subclass-methods ( class -- )
+ [ true-subclasses ] keep
+ [ over "uniform-tuple-slots" word-prop (define-uniform-tuple) ] curry each ;
+
+PRIVATE>
+
+: define-vertex-format ( class vertex-attributes -- )
+ [
+ [
+ [ define-singleton-class ]
+ [ vertex-format add-mixin-instance ]
+ [ ] tri
+ ] [ define-vertex-format-methods ] bi*
+ ]
+ [ "vertex-format-attributes" set-word-prop ] 2bi ;
+
+SYNTAX: VERTEX-FORMAT:
+ CREATE-CLASS parse-definition
+ [ first4 vertex-attribute boa ] map
+ define-vertex-format ;
+
+: define-vertex-struct ( struct-name vertex-format -- )
+ [ current-vocab ] dip
+ "vertex-format-attributes" word-prop [ vertex-attribute>c-type ] map
+ define-struct ;
+
+SYNTAX: VERTEX-STRUCT:
+ scan scan-word define-vertex-struct ;
+
+: define-uniform-tuple ( class superclass uniforms -- )
+ [ (define-uniform-tuple) ]
+ [ 2drop redefine-uniform-tuple-subclass-methods ] 3bi ;
+
+SYNTAX: UNIFORM-TUPLE:
+ parse-uniform-tuple-definition define-uniform-tuple ;
+
+TUPLE: vertex-array < gpu-object
+ { program-instance program-instance read-only }
+ { vertex-buffers sequence read-only } ;
+
+M: vertex-array dispose
+ [ [ delete-vertex-array ] when* f ] change-handle drop ;
+
+: <vertex-array> ( program-instance vertex-formats -- vertex-array )
+ gen-vertex-array
+ [ glBindVertexArray [ first2 bind-vertex-format ] with each ]
+ [ -rot [ first buffer>> ] map vertex-array boa ] 3bi
+ window-resource ;
+
+: buffer>vertex-array ( vertex-buffer program-instance format -- vertex-array )
+ [ swap ] dip
+ [ 0 <buffer-ptr> ] dip 2array 1array <vertex-array> ; inline
+
+: vertex-array-buffer ( vertex-array -- vertex-buffer )
+ vertex-buffers>> first ;
+
+<PRIVATE
+
+: bind-vertex-array ( vertex-array -- )
+ handle>> glBindVertexArray ;
+
+: bind-unnamed-output-attachments ( framebuffer attachments -- )
+ [ gl-attachment ] with map
+ dup length 1 =
+ [ first glDrawBuffer ]
+ [ [ length ] [ >int-array ] bi glDrawBuffers ] if ;
+
+: bind-named-output-attachments ( program-instance framebuffer attachments -- )
+ rot '[ [ first _ swap output-index ] bi@ <=> ] sort [ second ] map
+ bind-unnamed-output-attachments ;
+
+: bind-output-attachments ( program-instance framebuffer attachments -- )
+ dup first sequence?
+ [ bind-named-output-attachments ] [ [ drop ] 2dip bind-unnamed-output-attachments ] if ;
+
+PRIVATE>
+
+TUPLE: render-set
+ { primitive-mode primitive-mode }
+ { vertex-array vertex-array }
+ { uniforms uniform-tuple }
+ { indexes vertex-indexes initial: T{ index-range } }
+ { instances ?integer initial: f }
+ { framebuffer any-framebuffer initial: system-framebuffer }
+ { output-attachments sequence initial: { default-attachment } } ;
+
+: render ( render-set -- )
+ {
+ [ vertex-array>> program-instance>> handle>> glUseProgram ]
+ [
+ [ vertex-array>> program-instance>> ] [ uniforms>> ] bi
+ [ bind-uniform-textures ] [ bind-uniforms ] 2bi
+ ]
+ [ GL_DRAW_FRAMEBUFFER swap framebuffer>> framebuffer-handle glBindFramebuffer ]
+ [
+ [ vertex-array>> program-instance>> ]
+ [ framebuffer>> ]
+ [ output-attachments>> ] tri
+ bind-output-attachments
+ ]
+ [ vertex-array>> bind-vertex-array ]
+ [
+ [ primitive-mode>> ] [ indexes>> ] [ instances>> ] tri
+ [ render-vertex-indexes-instanced ]
+ [ render-vertex-indexes ] if*
+ ]
+ } cleave ; inline
+
--- /dev/null
+Execution of GPU jobs
--- /dev/null
+USING: accessors debugger gpu.shaders io kernel prettyprint ;
+IN: gpu.shaders.prettyprint
+
+M: compile-shader-error error.
+ "The GLSL shader " write
+ [ shader>> name>> pprint-short " failed to compile." write nl ]
+ [ log>> write nl ] bi ;
+
+M: link-program-error error.
+ "The GLSL program " write
+ [ shader>> name>> pprint-short " failed to link." write nl ]
+ [ log>> write nl ] bi ;
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: help.markup help.syntax kernel math multiline quotations strings ;
+IN: gpu.shaders
+
+HELP: <program-instance>
+{ $values
+ { "program" program }
+ { "instance" program-instance }
+}
+{ $description "Compiles and links an instance of " { $snippet "program" } " for the current graphics context. If an instance already exists for " { $snippet "program" } " in the current context, it is reused." } ;
+
+HELP: <shader-instance>
+{ $values
+ { "shader" shader }
+ { "instance" shader-instance }
+}
+{ $description "Compiles an instance of " { $snippet "shader" } " for the current graphics context. If an instance already exists for " { $snippet "shader" } " in the current context, it is reused." } ;
+
+HELP: GLSL-PROGRAM:
+{ $syntax "GLSL-PROGRAM: program-name shader shader ... shader ;" }
+{ $description "Defines a new " { $link program } " named " { $snippet "program-name" } ". When the program is instantiated with " { $link <program-instance> } ", it will link together instances of all of the specified " { $link shader } "s to create the program instance." } ;
+
+HELP: GLSL-SHADER-FILE:
+{ $syntax "GLSL-SHADER-FILE: shader-name shader-kind \"filename\"" }
+{ $description "Defines a new " { $link shader } " of kind " { $link shader-kind } " named " { $snippet "shader-name" } ". The shader will read its source code from " { $snippet "filename" } " in the current Factor source file's directory." } ;
+
+HELP: GLSL-SHADER:
+{ $syntax <" GLSL-SHADER-FILE: shader-name shader-kind
+
+shader source
+
+; "> }
+{ $description "Defines a new " { $link shader } " of kind " { $link shader-kind } " named " { $snippet "shader-name" } ". The shader will read its source code from the current Factor source file between the " { $snippet "GLSL-SHADER:" } " line and the first subsequent line with a single semicolon on it." } ;
+
+{ POSTPONE: GLSL-PROGRAM: POSTPONE: GLSL-SHADER-FILE: POSTPONE: GLSL-SHADER: } related-words
+
+HELP: attribute-index
+{ $values
+ { "program-instance" program-instance } { "attribute-name" string }
+ { "index" integer }
+}
+{ $description "Returns the numeric index of the vertex attribute named " { $snippet "attribute-name" } " in " { $snippet "program-instance" } "." } ;
+
+HELP: compile-shader-error
+{ $class-description "An error compiling the source for a " { $link shader } "."
+{ $list
+{ "The " { $snippet "shader" } " slot indicates the shader that failed to compile." }
+{ "The " { $snippet "log" } " slot contains the error string from the GLSL compiler." }
+} } ;
+
+HELP: fragment-shader
+{ $class-description "This " { $link shader-kind } " indicates that a " { $link shader } " is a fragment shader." } ;
+
+HELP: link-program-error
+{ $class-description "An error linking the constituent shaders of a " { $link program } "."
+{ $list
+{ "The " { $snippet "program" } " slot indicates the program that failed to link." }
+{ "The " { $snippet "log" } " slot contains the error string from the GLSL linker." }
+} } ;
+
+{ compile-shader-error link-program-error } related-words
+
+HELP: output-index
+{ $values
+ { "program-instance" program-instance } { "output-name" string }
+ { "index" integer }
+}
+{ $description "Returns the numeric index of the fragment shader output named " { $snippet "output-name" } " in " { $snippet "program-instance" } "." }
+{ $notes "Named fragment shader outputs require OpenGL 3.0 or later and GLSL 1.30 or later, or OpenGL 2.0 or later and GLSL 1.20 or earlier with the " { $snippet "GL_EXT_gpu_shader4" } " extension." } ;
+
+HELP: program
+{ $class-description "A " { $snippet "program" } " provides a specification for linking a " { $link program-instance } " in a graphics context. Programs are defined with " { $link POSTPONE: GLSL-PROGRAM: } " and instantiated in a context with " { $link <program-instance> } "." } ;
+
+HELP: program-instance
+{ $class-description "A " { $snippet "program-instance" } " is a shader " { $link program } " that has been compiled and linked for a graphics context using " { $link <program-instance> } "." } ;
+
+HELP: refresh-program
+{ $values
+ { "program" program }
+}
+{ $description "Rereads the source code for every " { $link shader } " in " { $link program } " and attempts to refresh all the existing " { $link shader-instance } "s and " { $link program-instance } "s for those programs. If the new source code fails to compile or link, the existing instances are untouched; otherwise, they are updated on the fly to reference the newly compiled code." } ;
+
+HELP: shader
+{ $class-description "A " { $snippet "shader" } " provides a block of GLSL source code that can be compiled into a " { $link shader-instance } " in a graphics context. Shaders are defined with " { $link POSTPONE: GLSL-SHADER: } " or " { $link POSTPONE: GLSL-SHADER-FILE: } " and instantiated in a context with " { $link <shader-instance> } "." } ;
+
+HELP: shader-instance
+{ $class-description "A " { $snippet "shader-instance" } " is a " { $link shader } " that has been compiled for a graphics context using " { $link <shader-instance> } "." } ;
+
+HELP: shader-kind
+{ $class-description "A " { $snippet "shader-kind" } " value is passed as part of a " { $link POSTPONE: GLSL-SHADER: } " or " { $link POSTPONE: GLSL-SHADER-FILE: } " definition to indicate the kind of " { $link shader } " being defined."
+{ $list
+{ { $link vertex-shader } "s run during primitive assembly and map input vertex data to positions in screen space for rasterization." }
+{ { $link fragment-shader } "s run as part of rasterization and decide the final rendered output of a primitive as the outputs of the vertex shader are interpolated across its surface." }
+} } ;
+
+HELP: uniform-index
+{ $values
+ { "program-instance" program-instance } { "uniform-name" string }
+ { "index" integer }
+}
+{ $description "Returns the numeric index of the uniform parameter named " { $snippet "output-name" } " in " { $snippet "program-instance" } "." } ;
+
+HELP: vertex-shader
+{ $class-description "This " { $link shader-kind } " indicates that a " { $link shader } " is a vertex shader." } ;
+
+ARTICLE: "gpu.shaders" "Shader objects"
+"The " { $vocab-link "gpu.shaders" } " vocabulary supports defining, compiling, and linking " { $link shader } "s into " { $link program } "s that run on the GPU and control rendering."
+{ $subsection POSTPONE: GLSL-PROGRAM: }
+{ $subsection POSTPONE: GLSL-SHADER: }
+{ $subsection POSTPONE: GLSL-SHADER-FILE: }
+"A program must be instantiated for each graphics context it is used in:"
+{ $subsection <program-instance> }
+"Program instances can be updated on the fly, allowing for interactive development of shaders:"
+{ $subsection refresh-program } ;
+
+ABOUT: "gpu.shaders"
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: multiline gpu.shaders gpu.shaders.private tools.test ;
+IN: gpu.shaders.tests
+
+[ <" ERROR: foo.factor:20: Bad command or filename
+INFO: foo.factor:30: The operation completed successfully
+NOT:A:LOG:LINE "> ]
+[ T{ shader { filename "foo.factor" } { line 19 } }
+<" ERROR: 0:1: Bad command or filename
+INFO: 0:11: The operation completed successfully
+NOT:A:LOG:LINE "> replace-log-line-numbers ] unit-test
+
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors arrays assocs combinators
+combinators.short-circuit definitions destructors gpu
+io.encodings.ascii io.files io.pathnames kernel lexer
+locals math math.parser memoize multiline namespaces
+opengl.gl opengl.shaders parser sequences
+specialized-arrays.int splitting strings ui.gadgets.worlds
+variants hashtables vectors vocabs vocabs.loader words
+words.constant ;
+IN: gpu.shaders
+
+VARIANT: shader-kind
+ vertex-shader fragment-shader ;
+
+TUPLE: shader
+ { name word read-only initial: t }
+ { kind shader-kind read-only }
+ { filename read-only }
+ { line integer read-only }
+ { source string }
+ { instances hashtable read-only } ;
+
+TUPLE: program
+ { name word read-only initial: t }
+ { filename read-only }
+ { line integer read-only }
+ { shaders array read-only }
+ { instances hashtable read-only } ;
+
+TUPLE: shader-instance < gpu-object
+ { shader shader }
+ { world world } ;
+
+TUPLE: program-instance < gpu-object
+ { program program }
+ { world world } ;
+
+<PRIVATE
+
+: shader-filename ( shader/program -- filename )
+ dup filename>> [ nip ] [ name>> where first ] if* file-name ;
+
+: numbered-log-line? ( log-line-components -- ? )
+ {
+ [ length 4 >= ]
+ [ third string>number ]
+ } 1&& ;
+
+: replace-log-line-number ( object log-line -- log-line' )
+ ":" split dup numbered-log-line? [
+ {
+ [ nip first ]
+ [ drop shader-filename " " prepend ]
+ [ [ line>> ] [ third string>number ] bi* + number>string ]
+ [ nip 3 tail ]
+ } 2cleave [ 3array ] dip append
+ ] [ nip ] if ":" join ;
+
+: replace-log-line-numbers ( object log -- log' )
+ "\n" split [ empty? not ] filter
+ [ replace-log-line-number ] with map
+ "\n" join ;
+
+: gl-shader-kind ( shader-kind -- shader-kind )
+ {
+ { vertex-shader [ GL_VERTEX_SHADER ] }
+ { fragment-shader [ GL_FRAGMENT_SHADER ] }
+ } case ;
+
+PRIVATE>
+
+TUPLE: compile-shader-error shader log ;
+TUPLE: link-program-error program log ;
+
+: compile-shader-error ( shader instance -- * )
+ [ dup ] dip [ gl-shader-info-log ] [ delete-gl-shader ] bi replace-log-line-numbers
+ \ compile-shader-error boa throw ;
+
+: link-program-error ( program instance -- * )
+ [ dup ] dip [ gl-program-info-log ] [ delete-gl-program ] bi replace-log-line-numbers
+ \ link-program-error boa throw ;
+
+DEFER: <shader-instance>
+
+MEMO: uniform-index ( program-instance uniform-name -- index )
+ [ handle>> ] dip glGetUniformLocation ;
+MEMO: attribute-index ( program-instance attribute-name -- index )
+ [ handle>> ] dip glGetAttribLocation ;
+MEMO: output-index ( program-instance output-name -- index )
+ [ handle>> ] dip glGetFragDataLocation ;
+
+<PRIVATE
+
+: valid-handle? ( handle -- ? )
+ { [ ] [ zero? not ] } 1&& ;
+
+: compile-shader ( shader -- instance )
+ [ ] [ source>> ] [ kind>> gl-shader-kind ] tri <gl-shader>
+ dup gl-shader-ok?
+ [ swap world get \ shader-instance boa window-resource ]
+ [ compile-shader-error ] if ;
+
+: (link-program) ( program shader-instances -- program-instance )
+ [ handle>> ] map <gl-program>
+ dup gl-program-ok?
+ [ swap world get \ program-instance boa window-resource ]
+ [ link-program-error ] if ;
+
+: link-program ( program -- program-instance )
+ dup shaders>> [ <shader-instance> ] map (link-program) ;
+
+: in-word's-path ( word kind filename -- word kind filename' )
+ [ over ] dip [ where first parent-directory ] dip append-path ;
+
+: become-shader-instance ( shader-instance new-shader-instance -- )
+ handle>> [ swap delete-gl-shader ] curry change-handle drop ;
+
+: refresh-shader-source ( shader -- )
+ dup filename>>
+ [ ascii file-contents >>source drop ]
+ [ drop ] if* ;
+
+: become-program-instance ( program-instance new-program-instance -- )
+ handle>> [ swap delete-gl-program-only ] curry change-handle drop ;
+
+: reset-memos ( -- )
+ \ uniform-index reset-memoized
+ \ attribute-index reset-memoized
+ \ output-index reset-memoized ;
+
+: ?delete-at ( key assoc value -- )
+ 2over at = [ delete-at ] [ 2drop ] if ;
+
+: find-shader-instance ( shader -- instance )
+ world get over instances>> at*
+ [ nip ] [ drop compile-shader ] if ;
+
+: find-program-instance ( program -- instance )
+ world get over instances>> at*
+ [ nip ] [ drop link-program ] if ;
+
+PRIVATE>
+
+:: refresh-program ( program -- )
+ program shaders>> [ refresh-shader-source ] each
+ program instances>> [| world old-instance |
+ old-instance valid-handle? [
+ world [
+ [
+ program shaders>> [ compile-shader |dispose ] map :> new-shader-instances
+ program new-shader-instances (link-program) |dispose :> new-program-instance
+
+ old-instance new-program-instance become-program-instance
+ new-shader-instances [| new-shader-instance |
+ world new-shader-instance shader>> instances>> at
+ new-shader-instance become-shader-instance
+ ] each
+ ] with-destructors
+ ] with-gl-context
+ ] when
+ ] assoc-each
+ reset-memos ;
+
+: <shader-instance> ( shader -- instance )
+ [ find-shader-instance dup world get ] keep instances>> set-at ;
+
+: <program-instance> ( program -- instance )
+ [ find-program-instance dup world get ] keep instances>> set-at ;
+
+SYNTAX: GLSL-SHADER:
+ CREATE-WORD dup
+ scan-word
+ f
+ lexer get line>>
+ parse-here
+ H{ } clone
+ shader boa
+ define-constant ;
+
+SYNTAX: GLSL-SHADER-FILE:
+ CREATE-WORD dup
+ scan-word execute( -- kind )
+ scan-object in-word's-path
+ 0
+ over ascii file-contents
+ H{ } clone
+ shader boa
+ define-constant ;
+
+SYNTAX: GLSL-PROGRAM:
+ CREATE-WORD dup
+ f
+ lexer get line>>
+ \ ; parse-until >array [ def>> first ] map
+ H{ } clone
+ program boa
+ define-constant ;
+
+M: shader-instance dispose
+ [ dup valid-handle? [ delete-gl-shader ] [ drop ] if f ] change-handle
+ [ world>> ] [ shader>> instances>> ] [ ] tri ?delete-at ;
+
+M: program-instance dispose
+ [ dup valid-handle? [ delete-gl-program-only ] [ drop ] if f ] change-handle
+ [ world>> ] [ program>> instances>> ] [ ] tri ?delete-at
+ reset-memos ;
+
+"prettyprint" vocab [ "gpu.shaders.prettyprint" require ] when
--- /dev/null
+GPU programs that control vertex transformation and shading
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: help.markup help.syntax kernel math math.rectangles multiline sequences ;
+IN: gpu.state
+
+HELP: <blend-mode>
+{ $values
+ { "equation" blend-equation } { "source-function" blend-function } { "dest-function" blend-function }
+ { "blend-mode" blend-mode }
+}
+{ $description "Constructs a " { $link blend-mode } " tuple." } ;
+
+{ blend-mode <blend-mode> } related-words
+
+HELP: <blend-state>
+{ $values
+ { "constant-color" sequence } { "rgb-mode" { $maybe blend-mode } } { "alpha-mode" { $maybe blend-mode } }
+ { "blend-state" blend-state }
+}
+{ $description "Constructs a " { $link blend-state } " tuple." } ;
+
+{ blend-state <blend-state> get-blend-state } related-words
+
+HELP: <depth-range-state>
+{ $values
+ { "near" float } { "far" float }
+ { "depth-range-state" depth-range-state }
+}
+{ $description "Constructs a " { $link depth-range-state } " tuple." } ;
+
+{ depth-range-state <depth-range-state> get-depth-range-state } related-words
+
+HELP: <depth-state>
+{ $values
+ { "comparison" comparison }
+ { "depth-state" depth-state }
+}
+{ $description "Constructs a " { $link depth-state } " tuple." } ;
+
+{ depth-state <depth-state> get-depth-state } related-words
+
+HELP: <line-state>
+{ $values
+ { "width" float } { "antialias?" boolean }
+ { "line-state" line-state }
+}
+{ $description "Constructs a " { $link line-state } " tuple." } ;
+
+{ line-state <line-state> get-line-state } related-words
+
+HELP: <mask-state>
+{ $values
+ { "color" sequence } { "depth" boolean } { "stencil-front" boolean } { "stencil-back" boolean }
+ { "mask-state" mask-state }
+}
+{ $description "Constructs a " { $link mask-state } " tuple." } ;
+
+{ mask-state <mask-state> get-mask-state } related-words
+
+HELP: <multisample-state>
+{ $values
+ { "multisample?" boolean } { "sample-alpha-to-coverage?" boolean } { "sample-alpha-to-one?" boolean } { "sample-coverage" { $maybe float } } { "invert-sample-coverage?" boolean }
+ { "multisample-state" multisample-state }
+}
+{ $description "Constructs a " { $link multisample-state } " tuple." } ;
+
+{ multisample-state <multisample-state> get-multisample-state } related-words
+
+HELP: <point-state>
+{ $values
+ { "size" { $maybe float } } { "sprite-origin" point-sprite-origin } { "fade-threshold" float }
+ { "point-state" point-state }
+}
+{ $description "Constructs a " { $link point-state } " tuple." } ;
+
+{ point-state <point-state> get-point-state } related-words
+
+HELP: <scissor-state>
+{ $values
+ { "rect" { $maybe rect } }
+ { "scissor-state" scissor-state }
+}
+{ $description "Constructs a " { $link scissor-state } " tuple." } ;
+
+{ scissor-state <scissor-state> get-scissor-state } related-words
+
+HELP: <stencil-mode>
+{ $values
+ { "value" integer } { "mask" integer } { "comparison" comparison } { "stencil-fail-op" stencil-op } { "depth-fail-op" stencil-op } { "depth-pass-op" stencil-op }
+ { "stencil-mode" stencil-mode }
+}
+{ $description "Constructs a " { $link stencil-mode } " tuple." } ;
+
+{ stencil-mode <stencil-mode> } related-words
+
+HELP: <stencil-state>
+{ $values
+ { "front-mode" { $maybe stencil-mode } } { "back-mode" { $maybe stencil-mode } }
+ { "stencil-state" stencil-state }
+}
+{ $description "Constructs a " { $link stencil-state } " tuple." } ;
+
+{ stencil-state <stencil-state> get-stencil-state } related-words
+
+HELP: <triangle-cull-state>
+{ $values
+ { "front-face" triangle-face } { "cull" { $maybe triangle-cull } }
+ { "triangle-cull-state" triangle-cull-state }
+}
+{ $description "Constructs a " { $link triangle-cull-state } " tuple." } ;
+
+{ triangle-cull-state <triangle-cull-state> get-triangle-cull-state } related-words
+
+HELP: <triangle-state>
+{ $values
+ { "front-mode" triangle-mode } { "back-mode" triangle-mode } { "antialias?" boolean }
+ { "triangle-state" triangle-state }
+}
+{ $description "Constructs a " { $link triangle-state } " tuple." } ;
+
+{ triangle-state <triangle-state> get-triangle-state } related-words
+
+HELP: <viewport-state>
+{ $values
+ { "rect" rect }
+ { "viewport-state" viewport-state }
+}
+{ $description "Constructs a " { $link viewport-state } " tuple." } ;
+
+{ viewport-state <viewport-state> get-viewport-state } related-words
+
+HELP: blend-equation
+{ $class-description "The " { $snippet "blend-equation" } " of a " { $link blend-mode } " determines how the source and destination color values are combined after they have been multiplied by the result of their respective " { $link blend-function } "s."
+{ $list
+{ { $link eq-add } " indicates that the source and destination results are added." }
+{ { $link eq-subtract } " indicates that the destination result is subtracted from the source." }
+{ { $link eq-reverse-subtract } " indicates that the source result is subtracted from the destination." }
+{ { $link eq-min } " indicates that the componentwise minimum of the source and destination results is taken." }
+{ { $link eq-max } " indicates that the componentwise maximum of the source and destination results is taken." }
+} } ;
+
+HELP: blend-function
+{ $class-description "The " { $snippet "blend-function" } "s of a " { $link blend-mode } " multiply the source and destination colors being blended by a function of their values before they are combined by the " { $link blend-equation } "."
+{ $list
+ { { $link func-zero } " returns a constant factor of zero." }
+ { { $link func-one } " returns a constant factor of one." }
+ { { $link func-source } " returns the corresponding source color component for every result component." }
+ { { $link func-one-minus-source } " returns one minus the corresponding source color component for every result component." }
+ { { $link func-dest } " returns the corresponding destination color component for every result component." }
+ { { $link func-one-minus-dest } " returns one minus the corresponding destination color component for every result component." }
+ { { $link func-constant } " returns the corresponding component of the current " { $link blend-state } "'s " { $snippet "constant-color" } " for every result component." }
+ { { $link func-one-minus-constant } " returns one minus the corresponding component of the current " { $link blend-state } "'s " { $snippet "constant-color" } " for every result component." }
+ { { $link func-source-alpha } " returns the source alpha component for every result component." }
+ { { $link func-one-minus-source-alpha } " returns one minus the source alpha component for every result component." }
+ { { $link func-dest-alpha } " returns the destination alpha component for every result component." }
+ { { $link func-one-minus-dest-alpha } " returns one minus the destination alpha component for every result component." }
+ { { $link func-constant-alpha } " returns the alpha component of the current " { $link blend-state } "'s " { $snippet "constant-color" } " for every result component." }
+ { { $link func-one-minus-constant-alpha } " returns one minus the alpha component of the current " { $link blend-state } "'s " { $snippet "constant-color" } " for every result component." }
+} } ;
+
+HELP: blend-mode
+{ $class-description "A " { $link blend-mode } " is specified as part of the " { $link blend-state } " to determine the blending equation used between the source (incoming fragment) and destination (existing framebuffer value) colors of blended pixels."
+{ $list
+{ "The " { $snippet "equation" } " slot determines how the source and destination colors are combined after the " { $snippet "source-function" } " and " { $snippet "dest-function" } " have been applied."
+ { $list
+ { { $link eq-add } " indicates that the source and destination results are added." }
+ { { $link eq-subtract } " indicates that the destination result is subtracted from the source." }
+ { { $link eq-reverse-subtract } " indicates that the source result is subtracted from the destination." }
+ { { $link eq-min } " indicates that the componentwise minimum of the source and destination results is taken." }
+ { { $link eq-max } " indicates that the componentwise maximum of the source and destination results is taken." }
+ }
+}
+{ "The " { $snippet "source-function" } " and " { $snippet "dest-function" } " slots each specify a function to apply to the source, destination, or constant color values to generate a blending factor that is multiplied respectively against the source or destination value before feeding the results to the " { $snippet "equation" } "."
+}
+ { $list
+ { { $link func-zero } " returns a constant factor of zero." }
+ { { $link func-one } " returns a constant factor of one." }
+ { { $link func-source } " returns the corresponding source color component for every result component." }
+ { { $link func-one-minus-source } " returns one minus the corresponding source color component for every result component." }
+ { { $link func-dest } " returns the corresponding destination color component for every result component." }
+ { { $link func-one-minus-dest } " returns one minus the corresponding destination color component for every result component." }
+ { { $link func-constant } " returns the corresponding component of the current " { $link blend-state } "'s " { $snippet "constant-color" } " for every result component." }
+ { { $link func-one-minus-constant } " returns one minus the corresponding component of the current " { $link blend-state } "'s " { $snippet "constant-color" } " for every result component." }
+ { { $link func-source-alpha } " returns the source alpha component for every result component." }
+ { { $link func-one-minus-source-alpha } " returns one minus the source alpha component for every result component." }
+ { { $link func-dest-alpha } " returns the destination alpha component for every result component." }
+ { { $link func-one-minus-dest-alpha } " returns one minus the destination alpha component for every result component." }
+ { { $link func-constant-alpha } " returns the alpha component of the current " { $link blend-state } "'s " { $snippet "constant-color" } " for every result component." }
+ { { $link func-one-minus-constant-alpha } " returns one minus the alpha component of the current " { $link blend-state } "'s " { $snippet "constant-color" } " for every result component." }
+}
+"A typical transparency effect will use the values:"
+{ $code <" T{ blend-mode
+ { equation eq-add }
+ { source-function func-source-alpha }
+ { dest-function func-one-minus-source-alpha }
+} "> }
+} } ;
+
+HELP: blend-state
+{ $class-description "The " { $snippet "blend-state" } " controls how alpha blending between the current framebuffer contents and newly drawn pixels."
+{ $list
+{ "The " { $snippet "constant-color" } " slot contains an optional four-" { $link float } " sequence that specifies a constant parameter to the " { $snippet "func-*constant*" } " " { $link blend-function } "s. If constant blend functions are not used, the slot can be " { $link f } "." }
+{ "The " { $snippet "rgb-mode" } " and " { $snippet "alpha-mode" } " slots both contain " { $link blend-mode } " values that determine the blending equation used between RGB and alpha channel values, respectively. If both slots are " { $link f } ", blending is disabled." }
+} } ;
+
+HELP: cmp-always
+{ $class-description "This " { $link comparison } " test always succeeds." } ;
+
+HELP: cmp-equal
+{ $class-description "This " { $link comparison } " test succeeds if the compared values are equal." } ;
+
+HELP: cmp-greater
+{ $class-description "This " { $link comparison } " test succeeds if the incoming value is greater than the buffer value." } ;
+
+HELP: cmp-greater-equal
+{ $class-description "This " { $link comparison } " test succeeds if the incoming value is greater than or equal to the buffer value." } ;
+
+HELP: cmp-less
+{ $class-description "This " { $link comparison } " test succeeds if the incoming value is less than the buffer value." } ;
+
+HELP: cmp-less-equal
+{ $class-description "This " { $link comparison } " test succeeds if the incoming value is less than or equal to the buffer value." } ;
+
+HELP: cmp-never
+{ $class-description "This " { $link comparison } " test always fails." } ;
+
+HELP: cmp-not-equal
+{ $class-description "This " { $link comparison } " test succeeds if the compared values are not equal." } ;
+
+HELP: comparison
+{ $class-description { $snippet "comparison" } " values are used in the " { $link stencil-state } " and " { $link depth-state } " and control how the fragment stencil and depth tests are performed. For the stencil test, a reference value (the " { $snippet "value" } " slot of the active " { $link stencil-mode } ") is compared to the stencil buffer value using the comparison operator. For the depth test, the incoming fragment depth is compared to the depth buffer value."
+{ $list
+{ { $link cmp-always } " always succeeds." }
+{ { $link cmp-never } " always fails." }
+{ { $link cmp-equal } " succeeds if the compared values are equal." }
+{ { $link cmp-not-equal } " succeeds if the compared values are not equal." }
+{ { $link cmp-less } " succeeds if the incoming value is less than the buffer value." }
+{ { $link cmp-less-equal } " succeeds if the incoming value is less than or equal to the buffer value." }
+{ { $link cmp-greater } " succeeds if the incoming value is greater than the buffer value." }
+{ { $link cmp-greater-equal } " succeeds if the incoming value is greater than or equal to the buffer value." }
+} } ;
+
+HELP: cull-all
+{ $class-description "This " { $link triangle-cull } " value culls all triangles." } ;
+
+HELP: cull-back
+{ $class-description "This " { $link triangle-cull } " value culls back-facing triangles." } ;
+
+HELP: cull-front
+{ $class-description "This " { $link triangle-cull } " value culls front-facing triangles." } ;
+
+HELP: depth-range-state
+{ $class-description "The " { $snippet "depth-range-state" } " controls the range of depth values that are generated for fragments and used for depth testing and writing to the depth buffer."
+{ $list
+{ "The " { $snippet "near" } " slot contains a " { $link float } " value that will be assigned to fragments on the near plane. The default value is " { $snippet "0.0" } "." }
+{ "The " { $snippet "far" } " slot contains a " { $link float } " value that will be assigned to fragments on the far plane. The default value is " { $snippet "1.0" } "." }
+} } ;
+
+HELP: depth-state
+{ $class-description "The " { $snippet "depth-state" } " controls how incoming fragments' depth values are tested against the depth buffer. The " { $link comparison } " slot, if not " { $link f } ", determines the condition that must be true between the incoming fragment depth and depth buffer depth to pass a fragment. If the " { $snippet "comparison" } " is " { $link f } ", depth testing is disabled and all fragments pass. " { $link cmp-less } " is typically used for depth culling." } ;
+
+HELP: eq-add
+{ $var-description "This " { $link blend-equation } " adds the source and destination colors together." } ;
+
+HELP: eq-max
+{ $var-description "This " { $link blend-equation } " takes the componentwise maximum of the source and destination colors." } ;
+
+HELP: eq-min
+{ $var-description "This " { $link blend-equation } " takes the componentwise minimum of the source and destination colors." } ;
+
+HELP: eq-reverse-subtract
+{ $var-description "This " { $link blend-equation } " subtracts the source color from the destination color." } ;
+
+HELP: eq-subtract
+{ $var-description "This " { $link blend-equation } " subtracts the destination color from the source color." } ;
+
+HELP: face-ccw
+{ $class-description "This " { $link triangle-face } " value refers to the face with counterclockwise-wound vertices." } ;
+
+HELP: face-cw
+{ $class-description "This " { $link triangle-face } " value refers to the face with clockwise-wound vertices." } ;
+
+HELP: func-constant
+{ $class-description "This " { $link blend-function } " componentwise multiplies the input color by the current " { $link blend-state } "'s " { "constant-color" } " slot value." } ;
+
+HELP: func-constant-alpha
+{ $class-description "This " { $link blend-function } " multiplies the input color by the alpha component of the current " { $link blend-state } "'s " { "constant-color" } " slot value." } ;
+
+HELP: func-dest
+{ $class-description "This " { $link blend-function } " componentwise multiplies the input color by the destination color value." } ;
+
+HELP: func-dest-alpha
+{ $class-description "This " { $link blend-function } " componentwise multiplies the input color by the alpha component of the destination color value." } ;
+
+HELP: func-one
+{ $class-description "This " { $link blend-function } " multiplies the input color by one; that is, the input color is unchanged." } ;
+
+HELP: func-one-minus-constant
+{ $class-description "This " { $link blend-function } " componentwise multiplies the input color by one minus the current " { $link blend-state } "'s " { "constant-color" } " slot value." } ;
+
+HELP: func-one-minus-constant-alpha
+{ $class-description "This " { $link blend-function } " multiplies the input color by one minus the alpha component of the current " { $link blend-state } "'s " { "constant-color" } " slot value." } ;
+
+HELP: func-one-minus-dest
+{ $class-description "This " { $link blend-function } " componentwise multiplies the input color by one minus the destination color value." } ;
+
+HELP: func-one-minus-dest-alpha
+{ $class-description "This " { $link blend-function } " multiplies the input color by one minus the alpha component of the destination color value." } ;
+
+HELP: func-one-minus-source
+{ $class-description "This " { $link blend-function } " componentwise multiplies the input color by one minus the source color value." } ;
+
+HELP: func-one-minus-source-alpha
+{ $class-description "This " { $link blend-function } " multiplies the input color by one minus the alpha component source color value." } ;
+
+HELP: func-source
+{ $class-description "This " { $link blend-function } " componentwise multiplies the input color by the source color value." } ;
+
+HELP: func-source-alpha
+{ $class-description "This " { $link blend-function } " multiplies the input color by the alpha component of the source color value." } ;
+
+HELP: func-source-alpha-saturate
+{ $class-description "This " { $link blend-function } " multiplies the input color by the minimum of the alpha component of the source color value and one minus the alpha component of the destination color value. It is only valid as the " { $snippet "source-function" } " of a " { $link blend-mode } "." } ;
+
+HELP: func-zero
+{ $class-description "This " { $link blend-function } " multiplies the input color by zero." } ;
+
+HELP: get-blend-state
+{ $values
+
+ { "blend-state" blend-state }
+}
+{ $description "Retrieves the current GPU " { $link blend-state } "." } ;
+
+HELP: get-depth-range-state
+{ $values
+
+ { "depth-range-state" depth-range-state }
+}
+{ $description "Retrieves the current GPU " { $link depth-range-state } "." } ;
+
+HELP: get-depth-state
+{ $values
+
+ { "depth-state" depth-state }
+}
+{ $description "Retrieves the current GPU " { $link depth-state } "." } ;
+
+HELP: get-line-state
+{ $values
+
+ { "line-state" line-state }
+}
+{ $description "Retrieves the current GPU " { $link line-state } "." } ;
+
+HELP: get-mask-state
+{ $values
+
+ { "mask-state" mask-state }
+}
+{ $description "Retrieves the current GPU " { $link mask-state } "." } ;
+
+HELP: get-multisample-state
+{ $values
+
+ { "multisample-state" multisample-state }
+}
+{ $description "Retrieves the current GPU " { $link multisample-state } "." } ;
+
+HELP: get-point-state
+{ $values
+
+ { "point-state" point-state }
+}
+{ $description "Retrieves the current GPU " { $link point-state } "." } ;
+
+HELP: get-scissor-state
+{ $values
+
+ { "scissor-state" scissor-state }
+}
+{ $description "Retrieves the current GPU " { $link scissor-state } "." } ;
+
+HELP: get-stencil-state
+{ $values
+
+ { "stencil-state" stencil-state }
+}
+{ $description "Retrieves the current GPU " { $link stencil-state } "." } ;
+
+HELP: get-triangle-cull-state
+{ $values
+
+ { "triangle-cull-state" triangle-cull-state }
+}
+{ $description "Retrieves the current GPU " { $link triangle-cull-state } "." } ;
+
+HELP: get-triangle-state
+{ $values
+
+ { "triangle-state" triangle-state }
+}
+{ $description "Retrieves the current GPU " { $link triangle-state } "." } ;
+
+HELP: get-viewport-state
+{ $values
+
+ { "viewport-state" viewport-state }
+}
+{ $description "Retrieves the current GPU " { $link viewport-state } "." } ;
+
+HELP: gpu-state
+{ $class-description "This class is a union of all the GPU state tuple classes that can be passed to " { $link set-gpu-state } ":"
+{ $list
+{ { $link viewport-state } }
+{ { $link scissor-state } }
+{ { $link multisample-state } }
+{ { $link stencil-state } }
+{ { $link depth-range-state } }
+{ { $link depth-state } }
+{ { $link blend-state } }
+{ { $link mask-state } }
+{ { $link triangle-cull-state } }
+{ { $link triangle-state } }
+{ { $link point-state } }
+{ { $link line-state } }
+} } ;
+
+HELP: line-state
+{ $class-description "The " { $snippet "line-state" } " controls how lines are rendered."
+{ $list
+{ "The " { $snippet "width" } " slot is a " { $link float } " value specifying the line width in pixels." }
+{ "The " { $snippet "antialias?" } " slot is a " { $link boolean } " value specifying whether line edges should be smoothed." }
+}
+} ;
+
+HELP: mask-state
+{ $class-description "The " { $snippet "mask-state" } " controls what parts of the framebuffer are written to."
+{ $list
+{ "The " { $snippet "color" } " slot is a sequence of four " { $link boolean } " values specifying whether the red, green, blue, and alpha channels of the color buffer will be written to." }
+{ "The " { $snippet "depth" } " slot is a " { $link boolean } " value specifying whether the depth buffer will be written to." }
+{ "The " { $snippet "stencil-front" } " and " { $snippet "stencil-back" } " slots are " { $link integer } " values that indicate which bits of the stencil buffer will be written to for front- and back-facing triangles, respectively." }
+} } ;
+
+HELP: multisample-state
+{ $class-description "The " { $snippet "multisample-state" } " controls whether and how multisampling occurs."
+{ $list
+{ "The " { $snippet "multisample?" } " slot is a " { $link boolean } " value that determines whether multisampling is enabled." }
+{ "The " { $snippet "sample-alpha-to-coverage?" } " slot is a " { $link boolean } " value that determines whether sample coverage values are determined from their alpha components." }
+{ "The " { $snippet "sample-alpha-to-one?" } " slot is a " { $link boolean } " value that determines whether a sample's alpha value is replaced with one after its alpha-based coverage is calculated." }
+{ "The " { $snippet "sample-coverage" } " slot is an optional " { $link float } " value that is used to calculate another coverage value that is then combined with the alpha-based coverage. If " { $link f } ", the alpha-based coverage is untouched." }
+{ "The " { $snippet "invert-sample-coverage?" } " slot is a " { $link boolean } " value that, if true, indicates that the coverage value derived from " { $snippet "sample-coverage" } " should be inverted before being combined." }
+} } ;
+
+HELP: op-dec-sat
+{ $class-description "This " { $link stencil-op } " subtracts one from the stencil buffer value, leaving it unchanged if it is already zero." } ;
+
+HELP: op-dec-wrap
+{ $class-description "This " { $link stencil-op } " subtracts one from the stencil buffer value, wrapping the value to the maximum storable value if it was zero." } ;
+
+HELP: op-inc-sat
+{ $class-description "This " { $link stencil-op } " adds one to the stencil buffer value, leaving it unchanged if it is already the maximum storable value." } ;
+
+HELP: op-inc-wrap
+{ $class-description "This " { $link stencil-op } " adds one to the stencil buffer value, wrapping the value to zero if it was the maximum storable value." } ;
+
+HELP: op-invert
+{ $class-description "This " { $link stencil-op } " bitwise NOTs the stencil buffer value." } ;
+
+HELP: op-keep
+{ $class-description "This " { $link stencil-op } " leaves the stencil buffer value unchanged." } ;
+
+HELP: op-replace
+{ $class-description "This " { $link stencil-op } " sets the stencil buffer value to the reference " { $snippet "value" } "." } ;
+
+HELP: op-zero
+{ $class-description "This " { $link stencil-op } " sets the stencil buffer value to zero." } ;
+
+HELP: origin-lower-left
+{ "This " { $link point-sprite-origin } " value sets the point sprite coordinate origin to the lower left corner of the point and increases the Y coordinate upward." } ;
+
+HELP: origin-upper-left
+{ "This " { $link point-sprite-origin } " value sets the point sprite coordinate origin to the upper left corner of the point and increases the Y coordinate downward." } ;
+
+HELP: point-sprite-origin
+{ $class-description "The " { $snippet "point-sprite-origin" } " is set as part of the " { $link point-state } " and determines how point sprite coordinates are generated over the rendered area of a point."
+{ $list
+{ { $link origin-lower-left } " sets the coordinate origin to the lower left corner of the point and increases the Y coordinate upward." }
+{ { $link origin-upper-left } " sets the coordinate origin to the upper left corner of the point and increases the Y coordinate downward." }
+} } ;
+
+HELP: point-state
+{ $class-description "The " { $snippet "point-state" } " controls how points are drawn."
+{ $list
+{ "The " { $snippet "size" } " slot contains either a " { $link float } " value specifying a constant pixel radius for all points drawn, or " { $link f } ", in which case the vertex shader determines the size of each point independently." }
+{ "The " { $snippet "sprite-origin" } " slot contains either " { $link origin-lower-left } " or " { $link origin-upper-left } ", and determines whether the vertical point sprite coordinates fed to the fragment shader start at zero in the bottom corner and increase upward or start at zero in the upper corner and increase downward." }
+{ "If multisampling is enabled in the " { $link multisample-state } ", the " { $snippet "fade-threshold" } " slot specifies a pixel width at which the multisampling implementation may fade the alpha component of point fragments." }
+} } ;
+
+HELP: scissor-state
+{ $class-description "The " { $snippet "scissor-state" } " allows rendering output to be clipped to a rectangular region of the framebuffer. If the " { $snippet "rect" } " slot is set to a " { $link rect } " value, fragments outside that rectangle will be discarded. If it is " { $link f } ", fragments are allowed anywhere on the framebuffer." } ;
+
+HELP: set-gpu-state
+{ $values
+ { "states" "a " { $link sequence } " or " { $link gpu-state } }
+}
+{ $description "Changes the GPU state using the values passed in " { $snippet "states" } "." } ;
+
+HELP: set-gpu-state*
+{ $values
+ { "state" gpu-state }
+}
+{ $description "Changes the GPU state using a single " { $link gpu-state } " value." } ;
+
+HELP: stencil-mode
+{ $class-description "A " { $snippet "stencil-mode" } " is specified as part of the " { $link stencil-state } " to define the interaction between an incoming fragment and the stencil buffer."
+{ $list
+{ "The " { $snippet "value" } " slot contains an " { $link integer } " value that is used as the reference value for the " { $snippet "comparison" } " of the stencil test." }
+{ "The " { $snippet "mask" } " slot contains an " { $link integer } " mask value that indicates which bits are relevant to the stencil test." }
+{ "The " { $snippet "comparison" } " slot contains a " { $link comparison } " value that indicates the comparison taken between the masked reference value and stored stencil buffer value to determine whether the fragment is allowed to pass." }
+{ "The " { $snippet "stencil-fail-op" } ", " { $snippet "depth-fail-op" } ", and " { $snippet "depth-pass-op" } " slots all contain " { $link stencil-op } " values that determine how the value in the stencil buffer is affected when the stencil test fails, the stencil test succeeds but depth test fails, and both stencil and depth tests succeed, respectively."
+ { $list
+ { { $link op-keep } " leaves the stencil buffer value unchanged." }
+ { { $link op-zero } " sets the stencil buffer value to zero." }
+ { { $link op-replace } " sets the stencil buffer value to the reference " { $snippet "value" } "." }
+ { { $link op-invert } " bitwise NOTs the stencil buffer value." }
+ { { $link op-inc-sat } " adds one to the stencil buffer value, leaving it unchanged if it is already the maximum storable value." }
+ { { $link op-dec-sat } " subtracts one from the stencil buffer value, leaving it unchanged if it is already zero." }
+ { { $link op-inc-wrap } " adds one to the stencil buffer value, wrapping the value to zero if it was the maximum storable value." }
+ { { $link op-dec-wrap } " subtracts one from the stencil buffer value, wrapping the value to the maximum storable value if it was zero." }
+ }
+}
+} } ;
+
+HELP: stencil-op
+{ $class-description { $snippet "stencil-op" } "s are set as part of a " { $link stencil-mode } " and determine how the stencil buffer is modified by incoming fragments."
+{ $list
+{ { $link op-keep } " leaves the stencil buffer value unchanged." }
+{ { $link op-zero } " sets the stencil buffer value to zero." }
+{ { $link op-replace } " sets the stencil buffer value to the reference " { $snippet "value" } "." }
+{ { $link op-invert } " bitwise NOTs the stencil buffer value." }
+{ { $link op-inc-sat } " adds one to the stencil buffer value, leaving it unchanged if it is already the maximum storable value." }
+{ { $link op-dec-sat } " subtracts one from the stencil buffer value, leaving it unchanged if it is already zero." }
+{ { $link op-inc-wrap } " adds one to the stencil buffer value, wrapping the value to zero if it was the maximum storable value." }
+{ { $link op-dec-wrap } " subtracts one from the stencil buffer value, wrapping the value to the maximum storable value if it was zero." }
+} } ;
+
+HELP: stencil-state
+{ $class-description "The " { $snippet "stencil-state" } " controls how incoming fragments interact with the stencil buffer. The " { $snippet "front-mode" } " and " { $snippet "back-mode" } " slots are both " { $link stencil-mode } " tuples that define the stencil buffer interaction for front- and back-facing triangle fragments, respectively. If both slots are " { $link f } ", stencil testing is disabled." } ;
+
+HELP: triangle-cull
+{ $class-description "The " { $snippet "cull" } " slot of the " { $link triangle-cull-state } " determines which triangle faces are culled, if any."
+{ $list
+{ { $link cull-all } " culls all triangles." }
+{ { $link cull-front } " culls front-facing triangles." }
+{ { $link cull-back } " culls back-facing triangles." }
+} } ;
+
+HELP: triangle-cull-state
+{ $class-description "The " { $snippet "triangle-cull-state" } " controls what faces of triangles are rasterized."
+{ $list
+{ "The " { $snippet "front-face" } " slot determines which vertex winding order is considered the front face of a triangle: " { $link face-ccw } " or " { $link face-cw } "." }
+{ "The " { $snippet "cull" } " slot determines which triangle faces are discarded: " { $link cull-front } ", " { $link cull-back } ", " { $link cull-all } ", or " { $link f } " to disable triangle culling." }
+} } ;
+
+HELP: triangle-face
+{ $class-description "A " { $snippet "triangle-face" } " value names a vertex winding order for triangles."
+{ $list
+{ { $link face-ccw } " indicates counterclockwise winding." }
+{ { $link face-cw } " indicates clockwise winding." }
+} } ;
+
+HELP: triangle-fill
+{ $class-description "This " { $link triangle-mode } " fills the entire surface of triangles." } ;
+
+HELP: triangle-lines
+{ $class-description "This " { $link triangle-mode } " renders lines across the edges of triangles." } ;
+
+HELP: triangle-mode
+{ $class-description "The " { $snippet "triangle-mode" } " is set as part of the " { $link triangle-state } " to determine how triangles are rendered."
+{ $list
+{ { $link triangle-points } " renders the vertices of triangles as if they were points." }
+{ { $link triangle-lines } " renders lines across the edges of triangles." }
+{ { $link triangle-fill } ", the default, fills the entire surface of triangles." }
+} } ;
+
+HELP: triangle-points
+{ $class-description "This " { $link triangle-mode } " renders the vertices of triangles as if they were points." } ;
+
+HELP: triangle-state
+{ $class-description "The " { $snippet "triangle-state" } " controls how triangles are rasterized."
+{ $list
+{ "The " { $snippet "front-mode" } " and " { $snippet "back-mode" } " slots determine how a front- or back-facing triangle is rendered."
+ { $list
+ { { $link triangle-points } " renders the vertices of triangles as if they were points." }
+ { { $link triangle-lines } " renders lines across the edges of triangles." }
+ { { $link triangle-fill } ", the default, fills the entire surface of triangles." }
+ }
+}
+{ "The " { $snippet "antialias?" } " slot contains a " { $link boolean } " value that decides whether the edges of triangles should be smoothed." }
+} } ;
+
+HELP: viewport-state
+{ $class-description "The " { $snippet "viewport-state" } " controls the rectangular region of the framebuffer to which window-space coordinates are mapped. Window-space vertices are mapped from the rectangle <-1.0, -1.0>Â<1.0, 1.0> to the rectangular region specified by the " { $snippet "rect" } " slot." } ;
+
+ARTICLE: "gpu.state" "GPU state"
+"The " { $vocab-link "gpu.state" } " vocabulary provides words for querying and setting GPU state."
+{ $subsection set-gpu-state }
+"The following state tuples are available:"
+{ $subsection viewport-state }
+{ $subsection scissor-state }
+{ $subsection multisample-state }
+{ $subsection stencil-state }
+{ $subsection depth-range-state }
+{ $subsection depth-state }
+{ $subsection blend-state }
+{ $subsection mask-state }
+{ $subsection triangle-cull-state }
+{ $subsection triangle-state }
+{ $subsection point-state }
+{ $subsection line-state } ;
+
+ABOUT: "gpu.state"
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors alien.c-types arrays byte-arrays combinators gpu
+kernel literals math math.rectangles opengl opengl.gl sequences
+variants specialized-arrays.int specialized-arrays.float ;
+IN: gpu.state
+
+UNION: ?rect rect POSTPONE: f ;
+UNION: ?float float POSTPONE: f ;
+
+TUPLE: viewport-state
+ { rect rect read-only } ;
+C: <viewport-state> viewport-state
+
+TUPLE: scissor-state
+ { rect ?rect read-only } ;
+C: <scissor-state> scissor-state
+
+TUPLE: multisample-state
+ { multisample? boolean read-only }
+ { sample-alpha-to-coverage? boolean read-only }
+ { sample-alpha-to-one? boolean read-only }
+ { sample-coverage ?float read-only }
+ { invert-sample-coverage? boolean read-only } ;
+C: <multisample-state> multisample-state
+
+VARIANT: comparison
+ cmp-never cmp-always
+ cmp-less cmp-less-equal cmp-equal
+ cmp-greater-equal cmp-greater cmp-not-equal ;
+VARIANT: stencil-op
+ op-keep op-zero
+ op-replace op-invert
+ op-inc-sat op-dec-sat
+ op-inc-wrap op-dec-wrap ;
+
+UNION: ?comparison comparison POSTPONE: f ;
+
+TUPLE: stencil-mode
+ { value integer initial: 0 read-only }
+ { mask integer initial: HEX: FFFFFFFF read-only }
+ { comparison comparison initial: cmp-always read-only }
+ { stencil-fail-op stencil-op initial: op-keep read-only }
+ { depth-fail-op stencil-op initial: op-keep read-only }
+ { depth-pass-op stencil-op initial: op-keep read-only } ;
+C: <stencil-mode> stencil-mode
+
+UNION: ?stencil-mode stencil-mode POSTPONE: f ;
+
+TUPLE: stencil-state
+ { front-mode ?stencil-mode initial: f read-only }
+ { back-mode ?stencil-mode initial: f read-only } ;
+C: <stencil-state> stencil-state
+
+TUPLE: depth-range-state
+ { near float initial: 0.0 read-only }
+ { far float initial: 1.0 read-only } ;
+C: <depth-range-state> depth-range-state
+
+TUPLE: depth-state
+ { comparison ?comparison initial: f read-only } ;
+C: <depth-state> depth-state
+
+VARIANT: blend-equation
+ eq-add eq-subtract eq-reverse-subtract eq-min eq-max ;
+VARIANT: blend-function
+ func-zero func-one
+ func-source func-one-minus-source
+ func-dest func-one-minus-dest
+ func-constant func-one-minus-constant
+ func-source-alpha func-one-minus-source-alpha
+ func-dest-alpha func-one-minus-dest-alpha
+ func-constant-alpha func-one-minus-constant-alpha ;
+
+VARIANT: source-only-blend-function
+ func-source-alpha-saturate ;
+
+UNION: source-blend-function blend-function source-only-blend-function ;
+
+TUPLE: blend-mode
+ { equation blend-equation initial: eq-add read-only }
+ { source-function source-blend-function initial: func-source-alpha read-only }
+ { dest-function blend-function initial: func-one-minus-source-alpha read-only } ;
+C: <blend-mode> blend-mode
+
+UNION: ?blend-mode blend-mode POSTPONE: f ;
+
+TUPLE: blend-state
+ { constant-color sequence initial: f read-only }
+ { rgb-mode ?blend-mode read-only }
+ { alpha-mode ?blend-mode read-only } ;
+C: <blend-state> blend-state
+
+TUPLE: mask-state
+ { color sequence initial: { t t t t } read-only }
+ { depth boolean initial: t read-only }
+ { stencil-front integer initial: HEX: FFFFFFFF read-only }
+ { stencil-back integer initial: HEX: FFFFFFFF read-only } ;
+C: <mask-state> mask-state
+
+VARIANT: triangle-face
+ face-ccw face-cw ;
+VARIANT: triangle-cull
+ cull-front cull-back cull-all ;
+VARIANT: triangle-mode
+ triangle-points triangle-lines triangle-fill ;
+
+UNION: ?triangle-cull triangle-cull POSTPONE: f ;
+
+TUPLE: triangle-cull-state
+ { front-face triangle-face initial: face-ccw read-only }
+ { cull ?triangle-cull initial: f read-only } ;
+C: <triangle-cull-state> triangle-cull-state
+
+TUPLE: triangle-state
+ { front-mode triangle-mode initial: triangle-fill read-only }
+ { back-mode triangle-mode initial: triangle-fill read-only }
+ { antialias? boolean initial: f read-only } ;
+C: <triangle-state> triangle-state
+
+VARIANT: point-sprite-origin
+ origin-upper-left origin-lower-left ;
+
+TUPLE: point-state
+ { size ?float initial: 1.0 read-only }
+ { sprite-origin point-sprite-origin initial: origin-upper-left read-only }
+ { fade-threshold float initial: 1.0 read-only } ;
+C: <point-state> point-state
+
+TUPLE: line-state
+ { width float initial: 1.0 read-only }
+ { antialias? boolean initial: f read-only } ;
+C: <line-state> line-state
+
+UNION: gpu-state
+ viewport-state
+ triangle-cull-state
+ triangle-state
+ point-state
+ line-state
+ scissor-state
+ multisample-state
+ stencil-state
+ depth-range-state
+ depth-state
+ blend-state
+ mask-state ;
+
+<PRIVATE
+
+: gl-triangle-face ( triangle-face -- face )
+ {
+ { face-ccw [ GL_CCW ] }
+ { face-cw [ GL_CW ] }
+ } case ;
+
+: gl-triangle-face> ( triangle-face -- face )
+ {
+ { $ GL_CCW [ face-ccw ] }
+ { $ GL_CW [ face-cw ] }
+ } case ;
+
+: gl-triangle-cull ( triangle-cull -- cull )
+ {
+ { cull-front [ GL_FRONT ] }
+ { cull-back [ GL_BACK ] }
+ { cull-all [ GL_FRONT_AND_BACK ] }
+ } case ;
+
+: gl-triangle-cull> ( triangle-cull -- cull )
+ {
+ { $ GL_FRONT [ cull-front ] }
+ { $ GL_BACK [ cull-back ] }
+ { $ GL_FRONT_AND_BACK [ cull-all ] }
+ } case ;
+
+: gl-triangle-mode ( triangle-mode -- mode )
+ {
+ { triangle-points [ GL_POINT ] }
+ { triangle-lines [ GL_LINE ] }
+ { triangle-fill [ GL_FILL ] }
+ } case ;
+
+: gl-triangle-mode> ( triangle-mode -- mode )
+ {
+ { $ GL_POINT [ triangle-points ] }
+ { $ GL_LINE [ triangle-lines ] }
+ { $ GL_FILL [ triangle-fill ] }
+ } case ;
+
+: gl-point-sprite-origin ( point-sprite-origin -- sprite-origin )
+ {
+ { origin-upper-left [ GL_UPPER_LEFT ] }
+ { origin-lower-left [ GL_LOWER_LEFT ] }
+ } case ;
+
+: gl-point-sprite-origin> ( point-sprite-origin -- sprite-origin )
+ {
+ { $ GL_UPPER_LEFT [ origin-upper-left ] }
+ { $ GL_LOWER_LEFT [ origin-lower-left ] }
+ } case ;
+
+: gl-comparison ( comparison -- comparison )
+ {
+ { cmp-never [ GL_NEVER ] }
+ { cmp-always [ GL_ALWAYS ] }
+ { cmp-less [ GL_LESS ] }
+ { cmp-less-equal [ GL_LEQUAL ] }
+ { cmp-equal [ GL_EQUAL ] }
+ { cmp-greater-equal [ GL_GEQUAL ] }
+ { cmp-greater [ GL_GREATER ] }
+ { cmp-not-equal [ GL_NOTEQUAL ] }
+ } case ;
+
+: gl-comparison> ( comparison -- comparison )
+ {
+ { $ GL_NEVER [ cmp-never ] }
+ { $ GL_ALWAYS [ cmp-always ] }
+ { $ GL_LESS [ cmp-less ] }
+ { $ GL_LEQUAL [ cmp-less-equal ] }
+ { $ GL_EQUAL [ cmp-equal ] }
+ { $ GL_GEQUAL [ cmp-greater-equal ] }
+ { $ GL_GREATER [ cmp-greater ] }
+ { $ GL_NOTEQUAL [ cmp-not-equal ] }
+ } case ;
+
+: gl-stencil-op ( stencil-op -- op )
+ {
+ { op-keep [ GL_KEEP ] }
+ { op-zero [ GL_ZERO ] }
+ { op-replace [ GL_REPLACE ] }
+ { op-invert [ GL_INVERT ] }
+ { op-inc-sat [ GL_INCR ] }
+ { op-dec-sat [ GL_DECR ] }
+ { op-inc-wrap [ GL_INCR_WRAP ] }
+ { op-dec-wrap [ GL_DECR_WRAP ] }
+ } case ;
+
+: gl-stencil-op> ( op -- op )
+ {
+ { $ GL_KEEP [ op-keep ] }
+ { $ GL_ZERO [ op-zero ] }
+ { $ GL_REPLACE [ op-replace ] }
+ { $ GL_INVERT [ op-invert ] }
+ { $ GL_INCR [ op-inc-sat ] }
+ { $ GL_DECR [ op-dec-sat ] }
+ { $ GL_INCR_WRAP [ op-inc-wrap ] }
+ { $ GL_DECR_WRAP [ op-dec-wrap ] }
+ } case ;
+
+: (set-stencil-mode) ( gl-face stencil-mode -- )
+ {
+ [ [ comparison>> gl-comparison ] [ value>> ] [ mask>> ] tri glStencilFuncSeparate ]
+ [
+ [ stencil-fail-op>> ] [ depth-fail-op>> ] [ depth-pass-op>> ] tri
+ [ gl-stencil-op ] tri@ glStencilOpSeparate
+ ]
+ } 2cleave ;
+
+: gl-blend-equation ( blend-equation -- blend-equation )
+ {
+ { eq-add [ GL_FUNC_ADD ] }
+ { eq-subtract [ GL_FUNC_SUBTRACT ] }
+ { eq-reverse-subtract [ GL_FUNC_REVERSE_SUBTRACT ] }
+ { eq-min [ GL_MIN ] }
+ { eq-max [ GL_MAX ] }
+ } case ;
+
+: gl-blend-equation> ( blend-equation -- blend-equation )
+ {
+ { $ GL_FUNC_ADD [ eq-add ] }
+ { $ GL_FUNC_SUBTRACT [ eq-subtract ] }
+ { $ GL_FUNC_REVERSE_SUBTRACT [ eq-reverse-subtract ] }
+ { $ GL_MIN [ eq-min ] }
+ { $ GL_MAX [ eq-max ] }
+ } case ;
+
+: gl-blend-function ( blend-function -- blend-function )
+ {
+ { func-zero [ GL_ZERO ] }
+ { func-one [ GL_ONE ] }
+ { func-source [ GL_SRC_COLOR ] }
+ { func-one-minus-source [ GL_ONE_MINUS_SRC_COLOR ] }
+ { func-dest [ GL_DST_COLOR ] }
+ { func-one-minus-dest [ GL_ONE_MINUS_DST_COLOR ] }
+ { func-constant [ GL_CONSTANT_COLOR ] }
+ { func-one-minus-constant [ GL_ONE_MINUS_CONSTANT_COLOR ] }
+ { func-source-alpha [ GL_SRC_ALPHA ] }
+ { func-one-minus-source-alpha [ GL_ONE_MINUS_SRC_ALPHA ] }
+ { func-dest-alpha [ GL_DST_ALPHA ] }
+ { func-one-minus-dest-alpha [ GL_ONE_MINUS_DST_ALPHA ] }
+ { func-constant-alpha [ GL_CONSTANT_ALPHA ] }
+ { func-one-minus-constant-alpha [ GL_ONE_MINUS_CONSTANT_ALPHA ] }
+ { func-source-alpha-saturate [ GL_SRC_ALPHA_SATURATE ] }
+ } case ;
+
+: gl-blend-function> ( blend-function -- blend-function )
+ {
+ { $ GL_ZERO [ func-zero ] }
+ { $ GL_ONE [ func-one ] }
+ { $ GL_SRC_COLOR [ func-source ] }
+ { $ GL_ONE_MINUS_SRC_COLOR [ func-one-minus-source ] }
+ { $ GL_DST_COLOR [ func-dest ] }
+ { $ GL_ONE_MINUS_DST_COLOR [ func-one-minus-dest ] }
+ { $ GL_CONSTANT_COLOR [ func-constant ] }
+ { $ GL_ONE_MINUS_CONSTANT_COLOR [ func-one-minus-constant ] }
+ { $ GL_SRC_ALPHA [ func-source-alpha ] }
+ { $ GL_ONE_MINUS_SRC_ALPHA [ func-one-minus-source-alpha ] }
+ { $ GL_DST_ALPHA [ func-dest-alpha ] }
+ { $ GL_ONE_MINUS_DST_ALPHA [ func-one-minus-dest-alpha ] }
+ { $ GL_CONSTANT_ALPHA [ func-constant-alpha ] }
+ { $ GL_ONE_MINUS_CONSTANT_ALPHA [ func-one-minus-constant-alpha ] }
+ { $ GL_SRC_ALPHA_SATURATE [ func-source-alpha-saturate ] }
+ } case ;
+
+PRIVATE>
+
+GENERIC: set-gpu-state* ( state -- )
+
+M: viewport-state set-gpu-state*
+ rect>> [ loc>> first2 ] [ dim>> first2 ] bi glViewport ;
+
+M: triangle-cull-state set-gpu-state*
+ {
+ [ front-face>> gl-triangle-face glFrontFace ]
+ [ GL_CULL_FACE swap cull>> [ gl-triangle-cull glCullFace glEnable ] [ glDisable ] if* ]
+ } cleave ;
+
+M: triangle-state set-gpu-state*
+ {
+ [ GL_FRONT swap front-mode>> gl-triangle-mode glPolygonMode ]
+ [ GL_BACK swap back-mode>> gl-triangle-mode glPolygonMode ]
+ [ GL_POLYGON_SMOOTH swap antialias?>> [ glEnable ] [ glDisable ] if ]
+ } cleave ;
+
+M: point-state set-gpu-state*
+ {
+ [ GL_VERTEX_PROGRAM_POINT_SIZE swap size>> [ glPointSize glDisable ] [ glEnable ] if* ]
+ [ GL_POINT_SPRITE_COORD_ORIGIN swap sprite-origin>> gl-point-sprite-origin glPointParameteri ]
+ [ GL_POINT_FADE_THRESHOLD_SIZE swap fade-threshold>> glPointParameterf ]
+ } cleave ;
+
+M: line-state set-gpu-state*
+ {
+ [ width>> glLineWidth ]
+ [ GL_LINE_SMOOTH swap antialias?>> [ glEnable ] [ glDisable ] if ]
+ } cleave ;
+
+M: scissor-state set-gpu-state*
+ GL_SCISSOR_TEST swap rect>>
+ [ [ loc>> first2 ] [ dim>> first2 ] bi glViewport glEnable ]
+ [ glDisable ] if* ;
+
+M: multisample-state set-gpu-state*
+ dup multisample?>> [
+ GL_MULTISAMPLE glEnable
+ {
+ [ GL_SAMPLE_ALPHA_TO_COVERAGE swap sample-alpha-to-coverage?>>
+ [ glEnable ] [ glDisable ] if
+ ]
+ [ GL_SAMPLE_ALPHA_TO_ONE swap sample-alpha-to-one?>>
+ [ glEnable ] [ glDisable ] if
+ ]
+ [ GL_SAMPLE_COVERAGE swap [ invert-sample-coverage?>> >c-bool ] [ sample-coverage>> ] bi
+ [ swap glSampleCoverage glEnable ] [ drop glDisable ] if*
+ ]
+ } cleave
+ ] [ drop GL_MULTISAMPLE glDisable ] if ;
+
+M: stencil-state set-gpu-state*
+ [ ] [ front-mode>> ] [ back-mode>> ] tri or
+ [
+ GL_STENCIL_TEST glEnable
+ [ front-mode>> GL_FRONT swap (set-stencil-mode) ]
+ [ back-mode>> GL_BACK swap (set-stencil-mode) ] bi
+ ] [ drop GL_STENCIL_TEST glDisable ] if ;
+
+M: depth-range-state set-gpu-state*
+ [ near>> ] [ far>> ] bi glDepthRange ;
+
+M: depth-state set-gpu-state*
+ GL_DEPTH_TEST swap comparison>> [ gl-comparison glDepthFunc glEnable ] [ glDisable ] if* ;
+
+M: blend-state set-gpu-state*
+ [ ] [ rgb-mode>> ] [ alpha-mode>> ] tri or
+ [
+ GL_BLEND glEnable
+ [ constant-color>> [ first4 glBlendColor ] when* ]
+ [
+ [ rgb-mode>> ] [ alpha-mode>> ] bi {
+ [ [ equation>> gl-blend-equation ] bi@ glBlendEquationSeparate ]
+ [
+ [
+ [ source-function>> gl-blend-function ]
+ [ dest-function>> gl-blend-function ] bi
+ ] bi@ glBlendFuncSeparate
+ ]
+ } 2cleave
+ ] bi
+ ] [ drop GL_BLEND glDisable ] if ;
+
+M: mask-state set-gpu-state*
+ {
+ [ color>> [ >c-bool ] map first4 glColorMask ]
+ [ depth>> >c-bool glDepthMask ]
+ [ GL_FRONT swap stencil-front>> glStencilMaskSeparate ]
+ [ GL_BACK swap stencil-back>> glStencilMaskSeparate ]
+ } cleave ;
+
+: set-gpu-state ( states -- )
+ dup sequence?
+ [ [ set-gpu-state* ] each ]
+ [ set-gpu-state* ] if ; inline
+
+<PRIVATE
+
+: get-gl-bool ( enum -- value )
+ 0 <uchar> [ glGetBooleanv ] keep *uchar c-bool> ;
+: get-gl-int ( enum -- value )
+ 0 <int> [ glGetIntegerv ] keep *int ;
+: get-gl-float ( enum -- value )
+ 0 <float> [ glGetFloatv ] keep *float ;
+
+: get-gl-bools ( enum count -- value )
+ <byte-array> [ glGetBooleanv ] keep [ c-bool> ] { } map-as ;
+: get-gl-ints ( enum count -- value )
+ <int-array> [ glGetIntegerv ] keep ;
+: get-gl-floats ( enum count -- value )
+ <float-array> [ glGetFloatv ] keep ;
+
+: get-gl-rect ( enum -- value )
+ 4 get-gl-ints first4 [ 2array ] 2bi@ <rect> ;
+
+: gl-enabled? ( enum -- ? )
+ glIsEnabled c-bool> ;
+
+PRIVATE>
+
+: get-viewport-state ( -- viewport-state )
+ GL_VIEWPORT get-gl-rect <viewport-state> ;
+
+: get-scissor-state ( -- scissor-state )
+ GL_SCISSOR_TEST get-gl-bool
+ [ GL_SCISSOR_BOX get-gl-rect ] [ f ] if
+ <scissor-state> ;
+
+: get-multisample-state ( -- multisample-state )
+ GL_MULTISAMPLE gl-enabled?
+ GL_SAMPLE_ALPHA_TO_COVERAGE gl-enabled?
+ GL_SAMPLE_ALPHA_TO_ONE gl-enabled?
+ GL_SAMPLE_COVERAGE gl-enabled? [
+ GL_SAMPLE_COVERAGE_VALUE get-gl-float
+ GL_SAMPLE_COVERAGE_INVERT get-gl-bool
+ ] [ f f ] if
+ <multisample-state> ;
+
+: get-stencil-state ( -- stencil-state )
+ GL_STENCIL_TEST gl-enabled? [
+ GL_STENCIL_REF get-gl-int
+ GL_STENCIL_VALUE_MASK get-gl-int
+ GL_STENCIL_FUNC get-gl-int gl-comparison>
+ GL_STENCIL_FAIL get-gl-int gl-stencil-op>
+ GL_STENCIL_PASS_DEPTH_FAIL get-gl-int gl-stencil-op>
+ GL_STENCIL_PASS_DEPTH_PASS get-gl-int gl-stencil-op>
+ <stencil-mode>
+
+ GL_STENCIL_BACK_REF get-gl-int
+ GL_STENCIL_BACK_VALUE_MASK get-gl-int
+ GL_STENCIL_BACK_FUNC get-gl-int gl-comparison>
+ GL_STENCIL_BACK_FAIL get-gl-int gl-stencil-op>
+ GL_STENCIL_BACK_PASS_DEPTH_FAIL get-gl-int gl-stencil-op>
+ GL_STENCIL_BACK_PASS_DEPTH_PASS get-gl-int gl-stencil-op>
+ <stencil-mode>
+ ] [ f f ] if
+ <stencil-state> ;
+
+: get-depth-range-state ( -- depth-range-state )
+ GL_DEPTH_RANGE 2 get-gl-floats first2 <depth-range-state> ;
+
+: get-depth-state ( -- depth-state )
+ GL_DEPTH_TEST gl-enabled?
+ [ GL_DEPTH_FUNC get-gl-int gl-comparison> ] [ f ] if
+ <depth-state> ;
+
+: get-blend-state ( -- blend-state )
+ GL_BLEND gl-enabled? [
+ GL_BLEND_COLOR 4 get-gl-floats
+
+ GL_BLEND_EQUATION_RGB get-gl-int gl-blend-equation>
+ GL_BLEND_SRC_RGB get-gl-int gl-blend-function>
+ GL_BLEND_DST_RGB get-gl-int gl-blend-function>
+ <blend-mode>
+
+ GL_BLEND_EQUATION_ALPHA get-gl-int gl-blend-equation>
+ GL_BLEND_SRC_ALPHA get-gl-int gl-blend-function>
+ GL_BLEND_DST_ALPHA get-gl-int gl-blend-function>
+ <blend-mode>
+ ] [ f f f ] if
+ <blend-state> ;
+
+: get-mask-state ( -- mask-state )
+ GL_COLOR_WRITEMASK 4 get-gl-bools
+ GL_DEPTH_WRITEMASK get-gl-bool
+ GL_STENCIL_WRITEMASK get-gl-int
+ GL_STENCIL_BACK_WRITEMASK get-gl-int
+ <mask-state> ;
+
+: get-triangle-cull-state ( -- triangle-cull-state )
+ GL_FRONT_FACE get-gl-int gl-triangle-face>
+ GL_CULL_FACE gl-enabled?
+ [ GL_CULL_FACE_MODE get-gl-int gl-triangle-cull> ]
+ [ f ] if
+ <triangle-cull-state> ;
+
+: get-triangle-state ( -- triangle-state )
+ GL_POLYGON_MODE 2 get-gl-ints
+ first2 [ gl-triangle-mode> ] bi@
+ GL_POLYGON_SMOOTH gl-enabled?
+ <triangle-state> ;
+
+: get-point-state ( -- point-state )
+ GL_VERTEX_PROGRAM_POINT_SIZE gl-enabled?
+ [ f ] [ GL_POINT_SIZE get-gl-float ] if
+ GL_POINT_SPRITE_COORD_ORIGIN get-gl-int gl-point-sprite-origin>
+ GL_POINT_FADE_THRESHOLD_SIZE get-gl-float
+ <point-state> ;
+
+: get-line-state ( -- line-state )
+ GL_LINE_WIDTH get-gl-float
+ GL_LINE_SMOOTH gl-enabled?
+ <line-state> ;
--- /dev/null
+GPU state manipulation
--- /dev/null
+High-level OpenGL-based GPU resource management and rendering library
--- /dev/null
+Multidimensional image data in GPU memory
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: byte-arrays classes gpu.buffers help.markup help.syntax
+images kernel math ;
+IN: gpu.textures
+
+HELP: +X
+{ $class-description "This " { $link cube-map-axis } " references the positive X face of a " { $link texture-cube-map } "." } ;
+
+HELP: +Y
+{ $class-description "This " { $link cube-map-axis } " references the positive Y face of a " { $link texture-cube-map } "." } ;
+
+HELP: +Z
+{ $class-description "This " { $link cube-map-axis } " references the positive Z face of a " { $link texture-cube-map } "." } ;
+
+HELP: -X
+{ $class-description "This " { $link cube-map-axis } " references the negative X face of a " { $link texture-cube-map } "." } ;
+
+HELP: -Y
+{ $class-description "This " { $link cube-map-axis } " references the negative Y face of a " { $link texture-cube-map } "." } ;
+
+HELP: -Z
+{ $class-description "This " { $link cube-map-axis } " references the negative Z face of a " { $link texture-cube-map } "." } ;
+
+HELP: <cube-map-face>
+{ $values
+ { "texture" texture-cube-map } { "axis" cube-map-axis }
+ { "cube-map-face" cube-map-face }
+}
+{ $description "Constructs a new " { $link cube-map-face } " reference." } ;
+
+HELP: <texture-1d-array>
+{ $values
+ { "component-order" component-order } { "component-type" component-type } { "parameters" texture-parameters }
+ { "texture" texture-1d-array }
+}
+{ $description "Creates a new one-dimensional array texture. The new texture starts out with no image data; " { $link allocate-texture } " or " { $link allocate-texture-image } " must be used to allocate memory for the required levels of detail of the texture." }
+{ $notes "Array textures require OpenGL 3.0 or the " { $snippet "GL_EXT_texture_array" } " extension." } ;
+
+HELP: <texture-1d>
+{ $values
+ { "component-order" component-order } { "component-type" component-type } { "parameters" texture-parameters }
+ { "texture" texture-1d }
+}
+{ $description "Creates a new one-dimensional texture. The new texture starts out with no image data; " { $link allocate-texture } " or " { $link allocate-texture-image } " must be used to allocate memory for the required levels of detail of the texture." } ;
+
+HELP: <texture-2d-array>
+{ $values
+ { "component-order" component-order } { "component-type" component-type } { "parameters" texture-parameters }
+ { "texture" texture-2d-array }
+}
+{ $description "Creates a new two-dimensional array texture. The new texture starts out with no image data; " { $link allocate-texture } " or " { $link allocate-texture-image } " must be used to allocate memory for the required levels of detail of the texture." }
+{ $notes "Array textures require OpenGL 3.0 or the " { $snippet "GL_EXT_texture_array" } " extension." } ;
+
+HELP: <texture-2d>
+{ $values
+ { "component-order" component-order } { "component-type" component-type } { "parameters" texture-parameters }
+ { "texture" texture-2d }
+}
+{ $description "Creates a new two-dimensional texture. The new texture starts out with no image data; " { $link allocate-texture } " or " { $link allocate-texture-image } " must be used to allocate memory for the required levels of detail of the texture." } ;
+
+HELP: <texture-3d>
+{ $values
+ { "component-order" component-order } { "component-type" component-type } { "parameters" texture-parameters }
+ { "texture" texture-3d }
+}
+{ $description "Creates a new three-dimensional texture. The new texture starts out with no image data; " { $link allocate-texture } " or " { $link allocate-texture-image } " must be used to allocate memory for the required levels of detail of the texture." } ;
+
+HELP: <texture-cube-map>
+{ $values
+ { "component-order" component-order } { "component-type" component-type } { "parameters" texture-parameters }
+ { "texture" texture-cube-map }
+}
+{ $description "Creates a new cube map texture. The new texture starts out with no image data; " { $link allocate-texture } " or " { $link allocate-texture-image } " must be used to allocate memory for the required levels of detail of each " { $link cube-map-face } " of the new texture." } ;
+
+HELP: <texture-data>
+{ $values
+ { "ptr" gpu-data-ptr } { "component-order" component-order } { "component-type" component-type }
+ { "texture-data" texture-data }
+}
+{ $description "Constructs a new " { $link texture-data } " tuple." }
+{ $notes "Using a " { $link buffer-ptr } " as the " { $snippet "ptr" } " of a " { $snippet "texture-data" } " object requires OpenGL 2.1 or later or the " { $snippet "GL_ARB_pixel_buffer_object" } " extension." } ;
+
+HELP: <texture-rectangle>
+{ $values
+ { "component-order" component-order } { "component-type" component-type } { "parameters" texture-parameters }
+ { "texture" texture-rectangle }
+}
+{ $description "Creates a new rectangle texture. The new texture starts out with no image data; " { $link allocate-texture } " or " { $link allocate-texture-image } " must be used to allocate memory for the texture." }
+{ $notes "Rectangle textures require OpenGL 3.1 or the " { $snippet "GL_ARB_texture_rectangle" } " extension." } ;
+
+HELP: allocate-texture
+{ $values
+ { "tdt" texture-data-target } { "level" integer } { "dim" "an " { $link integer } " or sequence of " { $link integer } "s" } { "data" { $maybe texture-data } }
+}
+{ $description "Allocates a new block of GPU memory for the " { $snippet "level" } "th level of detail of a " { $link texture-data-target } ". If " { $snippet "data" } " is not " { $link f } ", the new data is initialized from the given " { $link texture-data } " object; otherwise, the new image is left uninitialized." }
+{ $notes "Using a " { $link buffer-ptr } " as the " { $snippet "ptr" } " of a " { $snippet "texture-data" } " object requires OpenGL 2.1 or later or the " { $snippet "GL_ARB_pixel_buffer_object" } " extension." } ;
+
+HELP: allocate-texture-image
+{ $values
+ { "tdt" texture-data-target } { "level" integer } { "image" image }
+}
+{ $description "Allocates a new block of GPU memory for the " { $snippet "level" } "th level of detail of a " { $link texture-data-target } " and initializes it with the contents of an " { $link image } "." } ;
+
+{ allocate-texture allocate-texture-image } related-words
+
+HELP: clamp-texcoord-to-border
+{ $class-description "This " { $link texture-wrap } " value clamps texture coordinates to a texture's border." } ;
+
+HELP: clamp-texcoord-to-edge
+{ $class-description "This " { $link texture-wrap } " value clamps texture coordinates to a texture image's edge." } ;
+
+HELP: cube-map-axis
+{ $class-description "Objects of this class are stored in the " { $snippet "axis" } " slot of a " { $link cube-map-face } " to choose the referenced face: " { $link +X } ", " { $link +Y } ", " { $link +Z } ", " { $link -X } ", " { $link -Y } ", or " { $link -Z } "."
+} ;
+
+HELP: cube-map-face
+{ $class-description "A " { $snippet "cube-map-face" } " tuple references a single face of a " { $link texture-cube-map } " object for use with " { $link allocate-texture } ", " { $link update-texture } ", or " { $link read-texture } "."
+{ $list
+{ "The " { $snippet "texture" } " slot indicates the cube map texture being referenced." }
+{ "The " { $snippet "axis" } " slot indicates which face to reference: " { $link +X } ", " { $link +Y } ", " { $link +Z } ", " { $link -X } ", " { $link -Y } ", or " { $link -Z } "." }
+} } ;
+
+HELP: filter-linear
+{ $class-description "This " { $link texture-filter } " value selects linear filtering between pixel samples." } ;
+
+HELP: filter-nearest
+{ $class-description "This " { $link texture-filter } " value selects nearest-neighbor sampling." } ;
+
+HELP: generate-mipmaps
+{ $values
+ { "texture" texture }
+}
+{ $description "Replaces the image data for all levels of detail of " { $snippet "texture" } " below the highest level with images automatically generated from the highest level of detail image." }
+{ $notes "This word requires OpenGL 3.0 or one of the " { $snippet "GL_EXT_framebuffer_object" } " or " { $snippet "GL_ARB_framebuffer_object" } " extensions." } ;
+
+HELP: image>texture-data
+{ $values
+ { "image" image }
+ { "dim" "a sequence of " { $link integer } "s" } { "texture-data" texture-data }
+}
+{ $description "Constructs a " { $link texture-data } " tuple referencing the pixel data from an " { $link image } "." } ;
+
+HELP: read-texture
+{ $values
+ { "tdt" texture-data-target } { "level" integer }
+ { "byte-array" byte-array }
+}
+{ $description "Reads the entire image for the " { $snippet "level" } "th level of detail of a texture into a new " { $link byte-array } ". The format of the data in the byte array is determined by the " { $link component-order } " and " { $link component-type } " of the texture." } ;
+
+HELP: read-texture-image
+{ $values
+ { "tdt" texture-data-target } { "level" integer }
+ { "image" image }
+}
+{ $description "Reads the entire image for the " { $snippet "level" } "th level of detail of a texture into a new " { $link image } ". The format of the image is determined by the " { $link component-order } " and " { $link component-type } " of the texture." } ;
+
+HELP: read-texture-to
+{ $values
+ { "tdt" texture-data-target } { "level" integer } { "gpu-data-ptr" gpu-data-ptr }
+}
+{ $description "Reads the entire image for the " { $snippet "level" } "th level of detail of a texture into the CPU or GPU memory referenced by " { $link gpu-data-ptr } ". The format of the data in the byte array is determined by the " { $link component-order } " and " { $link component-type } " of the texture." }
+{ $notes "Reading texture data into a GPU " { $snippet "buffer-ptr" } " requires OpenGL 2.1 or later or the " { $snippet "GL_ARB_pixel_buffer_object" } " extension." } ;
+
+{ read-texture read-texture-image read-texture-to } related-words
+
+HELP: repeat-texcoord
+{ $class-description "This " { $link texture-wrap } " value causes the texture image to be repeated through texture coordinate space." } ;
+
+HELP: repeat-texcoord-mirrored
+{ $class-description "This " { $link texture-wrap } " value causes the texture image to be repeated through texture coordinate space, mirroring the image on every repetition." } ;
+
+HELP: set-texture-parameters
+{ $values
+ { "texture" texture } { "parameters" texture-parameters }
+}
+{ $description "Changes the " { $link texture-parameters } " of a " { $link texture } "." } ;
+
+HELP: texture
+{ $class-description "Textures are typed, multidimensional arrays of GPU memory used for storing image data, lookup tables, and other kinds of multidimensional data for use with shader programs. They come in different types depending on dimensionality and intended usage:"
+{ $subsection texture-1d }
+{ $subsection texture-2d }
+{ $subsection texture-3d }
+{ $subsection texture-cube-map }
+{ $subsection texture-rectangle }
+{ $subsection texture-1d-array }
+{ $subsection texture-2d-array }
+"Textures are constructed using the corresponding " { $snippet "<constructor word>" } " for their type. The constructor sets the texture's " { $link component-order } ", " { $link component-type } ", and " { $link texture-parameters } ". Once created, memory for a texture can be allocated with " { $link allocate-texture } ", updated with " { $link update-texture } ", or retrieved with " { $link read-texture } "." } ;
+
+HELP: texture-1d
+{ $class-description "A one-dimensional " { $link texture } " object. Textures of this type are dimensioned by single integers in calls to " { $link allocate-texture } " and " { $link update-texture } "." } ;
+
+{ texture-1d <texture-1d> } related-words
+
+HELP: texture-1d-array
+{ $class-description "A one-dimensional array " { $link texture } " object. Textures of this type are dimensioned by pairs of integers in calls to " { $link allocate-texture } " and " { $link update-texture } ". A 1D array texture is distinct from a 2D texture (" { $link texture-2d } ") in that each row of the texture is independent; texture values are not filtered between rows, and lower levels of detail retain the same height, only losing detail in the width direction." }
+{ $notes "Array textures require OpenGL 3.0 or the " { $snippet "GL_EXT_texture_array" } " extension." } ;
+
+{ texture-1d-array <texture-1d-array> } related-words
+
+HELP: texture-2d
+{ $class-description "A two-dimensional " { $link texture } " object. Textures of this type are dimensioned by pairs of integers in calls to " { $link allocate-texture } " and " { $link update-texture } "." } ;
+
+{ texture-2d <texture-2d> } related-words
+
+HELP: texture-2d-array
+{ $class-description "A two-dimensional array " { $link texture } " object. Textures of this type are dimensioned by sequences of three integers in calls to " { $link allocate-texture } " and " { $link update-texture } ". A 2D array texture is distinct from a 3D texture (" { $link texture-3d } ") in that each plane of the texture is independent; texture values are not filtered between planes, and lower levels of detail retain the same depth, only losing detail in the width and height directions." }
+{ $notes "Array textures require OpenGL 3.0 or the " { $snippet "GL_EXT_texture_array" } " extension." } ;
+
+{ texture-2d-array <texture-2d-array> } related-words
+
+HELP: texture-3d
+{ $class-description "A three-dimensional " { $link texture } " object. Textures of this type are dimensioned by sequences of three integers in calls to " { $link allocate-texture } " and " { $link update-texture } "." } ;
+
+{ texture-3d <texture-3d> } related-words
+
+HELP: texture-wrap
+{ $class-description "Values of this class are used in the " { $snippet "wrap" } " slot of a set of " { $link texture-parameters } " to specify how texture coordinates outside the 0.0 to 1.0 range should be mapped onto the texture image."
+{ $list
+{ { $link clamp-texcoord-to-edge } " clamps coordinates to the edge of the texture image." }
+{ { $link clamp-texcoord-to-border } " clamps coordinates to the border of the texture image." }
+{ { $link repeat-texcoord } " repeats the texture image." }
+{ { $link repeat-texcoord-mirrored } " repeats the texture image, mirroring it with each repetition." }
+} } ;
+
+HELP: texture-cube-map
+{ $class-description "A cube map " { $link texture } " object. Textures of this type comprise six two-dimensional image sets, which are independently referenced by " { $link cube-map-face } " objects and dimensioned by pairs of integers in calls to " { $link allocate-texture } " and " { $link update-texture } ". When a cube map is sampled in shader code, the three-dimensional texture coordinates are projected onto the unit cube, and the cube face that is hit by the vector is used to select a face of the cube map texture." } ;
+
+{ texture-cube-map <texture-cube-map> } related-words
+
+HELP: texture-data
+{ $class-description { $snippet "texture-data" } " tuples are used to feed image data to " { $link allocate-texture } " and " { $link update-texture } ". In addition to providing a " { $snippet "ptr" } " to CPU memory or a GPU " { $link buffer-ptr } ", the " { $link texture-data } " object also specifies the " { $link component-order } " and " { $link component-type } " of the referenced data." }
+{ $notes "Using a " { $link buffer-ptr } " as the " { $snippet "ptr" } " of a " { $snippet "texture-data" } " object requires OpenGL 2.1 or later or the " { $snippet "GL_ARB_pixel_buffer_object" } " extension." } ;
+
+{ texture-data <texture-data> } related-words
+
+HELP: texture-data-size
+{ $values
+ { "tdt" texture-data-target } { "level" integer }
+ { "size" integer }
+}
+{ $description "Returns the size in bytes of the image data allocated for the " { $snippet "level" } "th level of detail of a " { $link texture-data-target } "." } ;
+
+HELP: texture-data-target
+{ $class-description "Most " { $link texture } " types can have image data assigned to themselves directly by " { $link allocate-texture } " and " { $link update-texture } "; however, " { $link texture-cube-map } " objects comprise six independent image sets, each of which must be referenced separately with a " { $link cube-map-face } " tuple when allocating or updating images. The " { $snippet "texture-data-target" } " class is a union of all " { $link texture } " classes (except " { $snippet "texture-cube-map" } ") and the " { $snippet "cube-map-face" } " class." } ;
+
+HELP: texture-dim
+{ $values
+ { "tdt" texture-data-target } { "level" integer }
+ { "dim" "an " { $link integer } " or sequence of integers" }
+}
+{ $description "Returns the dimensions of the memory allocated for the " { $snippet "level" } "th level of detail of the given " { $link texture-data-target } "." } ;
+
+HELP: texture-filter
+{ $class-description { $snippet "texture-filter" } " values are used in a " { $link texture-parameters } " tuple to determine how a texture should be sampled between pixels or between levels of detail. " { $link filter-linear } " selects linear filtering, while " { $link filter-nearest } " selects nearest-neighbor sampling." } ;
+
+HELP: texture-parameters
+{ $class-description "When a " { $link texture } " is created, the following " { $snippet "texture-parameter" } "s are set to control how the texture is sampled:"
+{ $list
+{ "The " { $snippet "wrap" } " slot determines how texture coordinates outside the 0.0 to 1.0 range are mapped to the texture image. The slot either contains a single " { $link texture-wrap } " value, which will apply to all three axes, or a sequence of up to three values, which will apply to the S, T, and R axes, respectively." }
+{ "The " { $snippet "min-filter" } " and " { $snippet "min-mipmap-filter" } " determine how the texture image is filtered when sampled below its highest level of detail, the former controlling filtering between pixels within a level of detail and the latter filtering between levels of detail. A setting of " { $link filter-linear } " uses linear, bilinear, or trilinear filtering among sampled pixels, while a setting of " { $link filter-nearest } " uses nearest-neighbor sampling. The " { $snippet "min-mipmap-filter" } " slot may additionally be set to " { $link f } " to disable mipmapping and only sample the highest level of detail." }
+{ "The " { $snippet "mag-filter" } " analogously determines how the texture image is filtered when sampled above its highest level of detail." }
+{ "The " { $snippet "min-lod" } " and " { $snippet "max-lod" } " slots contain integer values that will clamp the range of levels of detail that will be sampled from the texture." }
+{ "The " { $snippet "lod-bias" } " slot contains an integer value that will offset the levels of detail that would normally be sampled from the texture." }
+{ "The " { $snippet "base-level" } " slot contains an integer value that identifies the highest level of detail for the image, typically zero." }
+{ "The " { $snippet "max-level" } " slot contains an integer value that identifies the lowest level of detail for the image. This value will automatically be clamped to the maximum of the base-2 logarithm of the dimensions of the highest level of detail image." }
+} } ;
+
+{ texture-parameters set-texture-parameters } related-words
+
+HELP: texture-rectangle
+{ $class-description "A two-dimensional rectangle " { $link texture } " object. Textures of this type are dimensioned by pairs of integers in calls to " { $link allocate-texture } " and " { $link update-texture } ". Rectangle textures differ from normal 2D textures (" { $link texture-2d } ") in that texture coordinates map directly to pixel coordinates when they are sampled from shader code, rather than being normalized into the 0.0 to 1.0 range as with other texture types. Also, rectangle textures do not support mipmapping or texture wrapping." }
+{ $notes "Rectangle textures require OpenGL 3.1 or the " { $snippet "GL_ARB_texture_rectangle" } " extension." } ;
+
+HELP: update-texture
+{ $values
+ { "tdt" texture-data-target } { "level" integer } { "loc" "an " { $link integer } " or sequence of integers" } { "dim" "an " { $link integer } " or sequence of integers" } { "data" texture-data }
+}
+{ $description "Updates the linear, rectangular, or cubic subregion of a " { $link texture-data-target } " bounded by " { $snippet "loc" } " and " { $snippet "dim" } " with new image data from a " { $link texture-data } " tuple." }
+{ $notes "Using a " { $link buffer-ptr } " as the " { $snippet "ptr" } " of a " { $snippet "texture-data" } " object requires OpenGL 2.1 or later or the " { $snippet "GL_ARB_pixel_buffer_object" } " extension." } ;
+
+HELP: update-texture-image
+{ $values
+ { "tdt" texture-data-target } { "level" integer } { "loc" "an " { $link integer } " or sequence of integers" } { "image" image }
+}
+{ $description "Updates the linear, rectangular, or cubic subregion of a " { $link texture-data-target } " bounded by " { $snippet "loc" } " and " { $snippet "dim" } " with new image data from an " { $link image } " object." } ;
+
+{ update-texture update-texture-image } related-words
+
+ARTICLE: "gpu.textures" "Texture objects"
+"The " { $vocab-link "gpu.textures" } " vocabulary provides words for creating, allocating, updating, and reading GPU texture objects."
+{ $subsection texture }
+{ $subsection allocate-texture }
+{ $subsection update-texture }
+{ $subsection read-texture }
+"Words are also provided to interface textures with the " { $vocab-link "images" } " library:"
+{ $subsection allocate-texture-image }
+{ $subsection update-texture-image }
+{ $subsection read-texture-image }
+;
+
+ABOUT: "gpu.textures"
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors alien.c-types arrays byte-arrays combinators
+destructors fry gpu gpu.buffers images kernel locals math
+opengl opengl.gl opengl.textures sequences
+specialized-arrays.float ui.gadgets.worlds variants ;
+IN: gpu.textures
+
+TUPLE: texture < gpu-object
+ { component-order component-order read-only initial: RGBA }
+ { component-type component-type read-only initial: ubyte-components } ;
+
+TUPLE: texture-1d < texture ;
+TUPLE: texture-2d < texture ;
+TUPLE: texture-rectangle < texture ;
+TUPLE: texture-3d < texture ;
+TUPLE: texture-cube-map < texture ;
+
+TUPLE: texture-1d-array < texture ;
+TUPLE: texture-2d-array < texture ;
+
+VARIANT: cube-map-axis
+ -X -Y -Z +X +Y +Z ;
+
+TUPLE: cube-map-face
+ { texture texture-cube-map read-only }
+ { axis cube-map-axis read-only } ;
+C: <cube-map-face> cube-map-face
+
+UNION: texture-data-target
+ texture-1d texture-2d texture-3d cube-map-face ;
+UNION: texture-1d-data-target
+ texture-1d ;
+UNION: texture-2d-data-target
+ texture-2d texture-rectangle texture-1d-array cube-map-face ;
+UNION: texture-3d-data-target
+ texture-3d texture-2d-array ;
+
+M: texture dispose
+ [ [ delete-texture ] when* f ] change-handle drop ;
+
+TUPLE: texture-data
+ { ptr read-only }
+ { component-order component-order read-only initial: RGBA }
+ { component-type component-type read-only initial: ubyte-components } ;
+
+C: <texture-data> texture-data
+UNION: ?texture-data texture-data POSTPONE: f ;
+UNION: ?float-array float-array POSTPONE: f ;
+
+VARIANT: texture-wrap
+ clamp-texcoord-to-edge clamp-texcoord-to-border repeat-texcoord repeat-texcoord-mirrored ;
+VARIANT: texture-filter
+ filter-nearest filter-linear ;
+
+UNION: wrap-set texture-wrap sequence ;
+UNION: ?texture-filter texture-filter POSTPONE: f ;
+
+TUPLE: texture-parameters
+ { wrap wrap-set initial: { repeat-texcoord repeat-texcoord repeat-texcoord } }
+ { min-filter texture-filter initial: filter-nearest }
+ { min-mipmap-filter ?texture-filter initial: filter-linear }
+ { mag-filter texture-filter initial: filter-linear }
+ { min-lod integer initial: -1000 }
+ { max-lod integer initial: 1000 }
+ { lod-bias integer initial: 0 }
+ { base-level integer initial: 0 }
+ { max-level integer initial: 1000 } ;
+
+<PRIVATE
+
+GENERIC: texture-object ( texture-data-target -- texture )
+M: cube-map-face texture-object
+ texture>> ;
+M: texture texture-object
+ ;
+
+: gl-wrap ( wrap -- gl-wrap )
+ {
+ { clamp-texcoord-to-edge [ GL_CLAMP_TO_EDGE ] }
+ { clamp-texcoord-to-border [ GL_CLAMP_TO_BORDER ] }
+ { repeat-texcoord [ GL_REPEAT ] }
+ { repeat-texcoord-mirrored [ GL_MIRRORED_REPEAT ] }
+ } case ;
+
+: set-texture-gl-wrap ( target wraps -- )
+ dup sequence? [ 1array ] unless 3 over last pad-tail {
+ [ [ GL_TEXTURE_WRAP_S ] dip first gl-wrap glTexParameteri ]
+ [ [ GL_TEXTURE_WRAP_T ] dip second gl-wrap glTexParameteri ]
+ [ [ GL_TEXTURE_WRAP_R ] dip third gl-wrap glTexParameteri ]
+ } 2cleave ;
+
+: gl-mag-filter ( filter -- gl-filter )
+ {
+ { filter-nearest [ GL_NEAREST ] }
+ { filter-linear [ GL_LINEAR ] }
+ } case ;
+
+: gl-min-filter ( filter mipmap-filter -- gl-filter )
+ 2array {
+ { { filter-nearest f } [ GL_NEAREST ] }
+ { { filter-linear f } [ GL_LINEAR ] }
+ { { filter-nearest filter-nearest } [ GL_NEAREST_MIPMAP_NEAREST ] }
+ { { filter-linear filter-nearest } [ GL_LINEAR_MIPMAP_NEAREST ] }
+ { { filter-linear filter-linear } [ GL_LINEAR_MIPMAP_LINEAR ] }
+ { { filter-nearest filter-linear } [ GL_NEAREST_MIPMAP_LINEAR ] }
+ } case ;
+
+GENERIC: texture-gl-target ( texture -- target )
+GENERIC: texture-data-gl-target ( texture -- target )
+
+M: texture-1d texture-gl-target drop GL_TEXTURE_1D ;
+M: texture-2d texture-gl-target drop GL_TEXTURE_2D ;
+M: texture-rectangle texture-gl-target drop GL_TEXTURE_RECTANGLE ;
+M: texture-3d texture-gl-target drop GL_TEXTURE_3D ;
+M: texture-cube-map texture-gl-target drop GL_TEXTURE_CUBE_MAP ;
+M: texture-1d-array texture-gl-target drop GL_TEXTURE_1D_ARRAY ;
+M: texture-2d-array texture-gl-target drop GL_TEXTURE_2D_ARRAY ;
+
+M: texture-1d texture-data-gl-target drop GL_TEXTURE_1D ;
+M: texture-2d texture-data-gl-target drop GL_TEXTURE_2D ;
+M: texture-rectangle texture-data-gl-target drop GL_TEXTURE_RECTANGLE ;
+M: texture-3d texture-data-gl-target drop GL_TEXTURE_3D ;
+M: texture-1d-array texture-data-gl-target drop GL_TEXTURE_1D_ARRAY ;
+M: texture-2d-array texture-data-gl-target drop GL_TEXTURE_2D_ARRAY ;
+M: cube-map-face texture-data-gl-target
+ axis>> {
+ { -X [ GL_TEXTURE_CUBE_MAP_NEGATIVE_X ] }
+ { -Y [ GL_TEXTURE_CUBE_MAP_NEGATIVE_Y ] }
+ { -Z [ GL_TEXTURE_CUBE_MAP_NEGATIVE_Z ] }
+ { +X [ GL_TEXTURE_CUBE_MAP_POSITIVE_X ] }
+ { +Y [ GL_TEXTURE_CUBE_MAP_POSITIVE_Y ] }
+ { +Z [ GL_TEXTURE_CUBE_MAP_POSITIVE_Z ] }
+ } case ;
+
+: texture-gl-internal-format ( texture -- internal-format )
+ [ component-order>> ] [ component-type>> ] bi image-internal-format ; inline
+
+: texture-data-gl-args ( texture data -- format type ptr )
+ [
+ nip
+ [ [ component-order>> ] [ component-type>> ] bi image-data-format ]
+ [ ptr>> ] bi
+ ] [
+ [ component-order>> ] [ component-type>> ] bi image-data-format f
+ ] if* ;
+
+:: bind-tdt ( tdt -- texture )
+ tdt texture-object :> texture
+ texture [ texture-gl-target ] [ handle>> ] bi glBindTexture
+ texture ;
+
+: get-texture-float ( target level enum -- value )
+ 0 <float> [ glGetTexLevelParameterfv ] keep *float ;
+: get-texture-int ( texture level enum -- value )
+ 0 <int> [ glGetTexLevelParameteriv ] keep *int ;
+
+: ?product ( x -- y )
+ dup number? [ product ] unless ;
+
+PRIVATE>
+
+GENERIC# allocate-texture 3 ( tdt level dim data -- )
+
+M:: texture-1d-data-target allocate-texture ( tdt level dim data -- )
+ tdt bind-tdt :> texture
+ tdt texture-data-gl-target level texture texture-gl-internal-format
+ dim 0 texture data texture-data-gl-args
+ pixel-unpack-buffer [ glTexImage1D ] with-gpu-data-ptr ;
+
+M:: texture-2d-data-target allocate-texture ( tdt level dim data -- )
+ tdt bind-tdt :> texture
+ tdt texture-data-gl-target level texture texture-gl-internal-format
+ dim first2 0 texture data texture-data-gl-args
+ pixel-unpack-buffer [ glTexImage2D ] with-gpu-data-ptr ;
+
+M:: texture-3d-data-target allocate-texture ( tdt level dim data -- )
+ tdt bind-tdt :> texture
+ tdt texture-data-gl-target level texture texture-gl-internal-format
+ dim first3 0 texture data texture-data-gl-args
+ pixel-unpack-buffer [ glTexImage3D ] with-gpu-data-ptr ;
+
+GENERIC# update-texture 4 ( tdt level loc dim data -- )
+
+M:: texture-1d-data-target update-texture ( tdt level loc dim data -- )
+ tdt bind-tdt :> texture
+ tdt texture-data-gl-target level
+ loc dim texture data texture-data-gl-args
+ pixel-unpack-buffer [ glTexSubImage1D ] with-gpu-data-ptr ;
+
+M:: texture-2d-data-target update-texture ( tdt level loc dim data -- )
+ tdt bind-tdt :> texture
+ tdt texture-data-gl-target level
+ loc dim [ first2 ] bi@
+ texture data texture-data-gl-args
+ pixel-unpack-buffer [ glTexSubImage2D ] with-gpu-data-ptr ;
+
+M:: texture-3d-data-target update-texture ( tdt level loc dim data -- )
+ tdt bind-tdt :> texture
+ tdt texture-data-gl-target level
+ loc dim [ first3 ] bi@
+ texture data texture-data-gl-args
+ pixel-unpack-buffer [ glTexSubImage3D ] with-gpu-data-ptr ;
+
+: image>texture-data ( image -- dim texture-data )
+ { [ dim>> ] [ bitmap>> ] [ component-order>> ] [ component-type>> ] } cleave
+ <texture-data> ; inline
+
+GENERIC# texture-dim 1 ( tdt level -- dim )
+
+M:: texture-1d-data-target texture-dim ( tdt level -- dim )
+ tdt bind-tdt :> texture
+ tdt texture-data-gl-target level GL_TEXTURE_WIDTH get-texture-int ;
+
+M:: texture-2d-data-target texture-dim ( tdt level -- dim )
+ tdt bind-tdt :> texture
+ tdt texture-data-gl-target level
+ [ GL_TEXTURE_WIDTH get-texture-int ] [ GL_TEXTURE_HEIGHT get-texture-int ] 2bi
+ 2array ;
+
+M:: texture-3d-data-target texture-dim ( tdt level -- dim )
+ tdt bind-tdt :> texture
+ tdt texture-data-gl-target level
+ [ GL_TEXTURE_WIDTH get-texture-int ]
+ [ GL_TEXTURE_HEIGHT get-texture-int ]
+ [ GL_TEXTURE_DEPTH get-texture-int ] 2tri
+ 3array ;
+
+: texture-data-size ( tdt level -- size )
+ [ texture-dim ?product ] [ drop texture-object bytes-per-pixel ] 2bi * ;
+
+:: read-texture-to ( tdt level gpu-data-ptr -- )
+ tdt bind-tdt :> texture
+ tdt texture-data-gl-target level
+ texture [ component-order>> ] [ component-type>> ] bi image-data-format
+ gpu-data-ptr pixel-pack-buffer [ glGetTexImage ] with-gpu-data-ptr ;
+
+: read-texture ( tdt level -- byte-array )
+ 2dup texture-data-size <byte-array>
+ [ read-texture-to ] keep ;
+
+: allocate-texture-image ( tdt level image -- )
+ image>texture-data allocate-texture ;
+
+: update-texture-image ( tdt level loc image -- )
+ image>texture-data update-texture ;
+
+: read-texture-image ( tdt level -- image )
+ [ texture-dim ]
+ [ drop texture-object [ component-order>> ] [ component-type>> ] bi f ]
+ [ read-texture ] 2tri
+ image boa ;
+
+<PRIVATE
+: bind-texture ( texture -- gl-target )
+ [ texture-gl-target dup ] [ handle>> ] bi glBindTexture ;
+PRIVATE>
+
+: generate-mipmaps ( texture -- )
+ bind-texture glGenerateMipmap ;
+
+: set-texture-parameters ( texture parameters -- )
+ [ bind-texture ] dip {
+ [ wrap>> set-texture-gl-wrap ]
+ [
+ [ GL_TEXTURE_MIN_FILTER ] dip
+ [ min-filter>> ] [ min-mipmap-filter>> ] bi gl-min-filter glTexParameteri
+ ] [
+ [ GL_TEXTURE_MAG_FILTER ] dip
+ mag-filter>> gl-mag-filter glTexParameteri
+ ]
+ [ [ GL_TEXTURE_MIN_LOD ] dip min-lod>> glTexParameteri ]
+ [ [ GL_TEXTURE_MAX_LOD ] dip max-lod>> glTexParameteri ]
+ [ [ GL_TEXTURE_LOD_BIAS ] dip lod-bias>> glTexParameteri ]
+ [ [ GL_TEXTURE_BASE_LEVEL ] dip base-level>> glTexParameteri ]
+ [ [ GL_TEXTURE_MAX_LEVEL ] dip max-level>> glTexParameteri ]
+ } 2cleave ;
+
+<PRIVATE
+
+: <texture> ( component-order component-type parameters class -- texture )
+ '[ [ gen-texture ] 2dip _ boa dup window-resource ] dip
+ [ T{ texture-parameters } clone ] unless* set-texture-parameters ; inline
+
+PRIVATE>
+
+: <texture-1d> ( component-order component-type parameters -- texture )
+ texture-1d <texture> ;
+: <texture-2d> ( component-order component-type parameters -- texture )
+ texture-2d <texture> ;
+: <texture-3d> ( component-order component-type parameters -- texture )
+ texture-3d <texture> ;
+: <texture-cube-map> ( component-order component-type parameters -- texture )
+ texture-cube-map <texture> ;
+: <texture-rectangle> ( component-order component-type parameters -- texture )
+ texture-rectangle <texture> ;
+: <texture-1d-array> ( component-order component-type parameters -- texture )
+ texture-1d-array <texture> ;
+: <texture-2d-array> ( component-order component-type parameters -- texture )
+ texture-2d-array <texture> ;
+
--- /dev/null
+Miscellaneous functions useful for GPU library apps
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: gpu.buffers gpu.render gpu.textures images kernel
+specialized-arrays.float ;
+IN: gpu.util
+
+CONSTANT: environment-cube-map-mv-matrices
+ H{
+ { +X {
+ { 0.0 0.0 -1.0 0.0 }
+ { 0.0 -1.0 0.0 0.0 }
+ { -1.0 0.0 0.0 0.0 }
+ { 0.0 0.0 0.0 1.0 }
+ } }
+ { +Y {
+ { 1.0 0.0 0.0 0.0 }
+ { 0.0 0.0 1.0 0.0 }
+ { 0.0 -1.0 0.0 0.0 }
+ { 0.0 0.0 0.0 1.0 }
+ } }
+ { +Z {
+ { 1.0 0.0 0.0 0.0 }
+ { 0.0 -1.0 0.0 0.0 }
+ { 0.0 0.0 -1.0 0.0 }
+ { 0.0 0.0 0.0 1.0 }
+ } }
+ { -X {
+ { 0.0 0.0 1.0 0.0 }
+ { 0.0 -1.0 0.0 0.0 }
+ { 1.0 0.0 0.0 0.0 }
+ { 0.0 0.0 0.0 1.0 }
+ } }
+ { -Y {
+ { 1.0 0.0 0.0 0.0 }
+ { 0.0 0.0 -1.0 0.0 }
+ { 0.0 1.0 0.0 0.0 }
+ { 0.0 0.0 0.0 1.0 }
+ } }
+ { -Z {
+ { -1.0 0.0 0.0 0.0 }
+ { 0.0 -1.0 0.0 0.0 }
+ { 0.0 0.0 1.0 0.0 }
+ { 0.0 0.0 0.0 1.0 }
+ } }
+ }
+
+VERTEX-FORMAT: window-vertex
+ { "vertex" float-components 2 f } ;
+
+CONSTANT: window-vertexes
+ float-array{
+ -1.0 -1.0
+ -1.0 1.0
+ 1.0 -1.0
+ 1.0 1.0
+ }
+
+: <window-vertex-buffer> ( -- buffer )
+ window-vertexes
+ static-upload draw-usage vertex-buffer
+ byte-array>buffer ;
+
+: <window-vertex-array> ( program-instance -- vertex-array )
+ [ <window-vertex-buffer> ] dip window-vertex buffer>vertex-array ;
--- /dev/null
+Scaffolding for demo scenes that can be explored using FPS-style controls
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors arrays combinators.smart game-input
+game-input.scancodes game-loop game-worlds
+gpu.render gpu.state kernel literals
+locals math math.constants math.functions math.matrices
+math.order math.vectors opengl.gl sequences
+specialized-arrays.float ui ui.gadgets.worlds ;
+IN: gpu.util.wasd
+
+UNIFORM-TUPLE: mvp-uniforms
+ { "mv_matrix" float-uniform { 4 4 } }
+ { "p_matrix" float-uniform { 4 4 } } ;
+
+CONSTANT: -pi/2 $[ pi -2.0 / ]
+CONSTANT: pi/2 $[ pi 2.0 / ]
+
+TUPLE: wasd-world < game-world location yaw pitch p-matrix ;
+
+GENERIC: wasd-near-plane ( world -- near-plane )
+M: wasd-world wasd-near-plane drop 0.25 ;
+
+GENERIC: wasd-far-plane ( world -- far-plane )
+M: wasd-world wasd-far-plane drop 1024.0 ;
+
+GENERIC: wasd-movement-speed ( world -- speed )
+M: wasd-world wasd-movement-speed drop 1/16. ;
+
+GENERIC: wasd-mouse-scale ( world -- scale )
+M: wasd-world wasd-mouse-scale drop 1/600. ;
+
+GENERIC: wasd-pitch-range ( world -- min max )
+M: wasd-world wasd-pitch-range drop -pi/2 pi/2 ;
+
+GENERIC: wasd-fly-vertically? ( world -- ? )
+M: wasd-world wasd-fly-vertically? drop t ;
+
+: wasd-mv-matrix ( world -- matrix )
+ [ { 1.0 0.0 0.0 } swap pitch>> rotation-matrix4 ]
+ [ { 0.0 1.0 0.0 } swap yaw>> rotation-matrix4 ]
+ [ location>> vneg translation-matrix4 ] tri m. m. ;
+
+: wasd-mv-inv-matrix ( world -- matrix )
+ [ location>> translation-matrix4 ]
+ [ { 0.0 -1.0 0.0 } swap yaw>> rotation-matrix4 ]
+ [ { -1.0 0.0 0.0 } swap pitch>> rotation-matrix4 ] tri m. m. ;
+
+: wasd-p-matrix ( world -- matrix )
+ p-matrix>> ;
+
+CONSTANT: fov 0.7
+
+:: generate-p-matrix ( world -- matrix )
+ world wasd-near-plane :> near-plane
+ world wasd-far-plane :> far-plane
+
+ world dim>> dup first2 min >float v/n fov v*n near-plane v*n
+ near-plane far-plane frustum-matrix4 ;
+
+: set-wasd-view ( world location yaw pitch -- world )
+ [ >>location ] [ >>yaw ] [ >>pitch ] tri* ;
+
+:: eye-rotate ( yaw pitch v -- v' )
+ yaw neg :> y
+ pitch neg :> p
+ y cos :> cosy
+ y sin :> siny
+ p cos :> cosp
+ p sin :> sinp
+
+ cosy 0.0 siny neg 3array
+ siny sinp * cosp cosy sinp * 3array
+ siny cosp * sinp neg cosy cosp * 3array 3array
+ v swap v.m ;
+
+: ?pitch ( world -- pitch )
+ dup wasd-fly-vertically? [ pitch>> ] [ drop 0.0 ] if ;
+
+: forward-vector ( world -- v )
+ [ yaw>> ] [ ?pitch ] [ wasd-movement-speed ] tri
+ { 0.0 0.0 -1.0 } n*v eye-rotate ;
+: rightward-vector ( world -- v )
+ [ yaw>> ] [ ?pitch ] [ wasd-movement-speed ] tri
+ { 1.0 0.0 0.0 } n*v eye-rotate ;
+
+: walk-forward ( world -- )
+ dup forward-vector [ v+ ] curry change-location drop ;
+: walk-backward ( world -- )
+ dup forward-vector [ v- ] curry change-location drop ;
+: walk-leftward ( world -- )
+ dup rightward-vector [ v- ] curry change-location drop ;
+: walk-rightward ( world -- )
+ dup rightward-vector [ v+ ] curry change-location drop ;
+: walk-upward ( world -- )
+ dup wasd-movement-speed { 0.0 1.0 0.0 } n*v [ v+ ] curry change-location drop ;
+: walk-downward ( world -- )
+ dup wasd-movement-speed { 0.0 1.0 0.0 } n*v [ v- ] curry change-location drop ;
+
+: clamp-pitch ( world -- world )
+ dup [ wasd-pitch-range clamp ] curry change-pitch ;
+
+: rotate-with-mouse ( world mouse -- )
+ [ [ dup wasd-mouse-scale ] [ dx>> ] bi* * [ + ] curry change-yaw ]
+ [ [ dup wasd-mouse-scale ] [ dy>> ] bi* * [ + ] curry change-pitch clamp-pitch ] bi
+ drop ;
+
+:: wasd-keyboard-input ( world -- )
+ read-keyboard keys>> :> keys
+ key-w keys nth key-, keys nth or [ world walk-forward ] when
+ key-s keys nth key-o keys nth or [ world walk-backward ] when
+ key-a keys nth [ world walk-leftward ] when
+ key-d keys nth key-e keys nth or [ world walk-rightward ] when
+ key-space keys nth [ world walk-upward ] when
+ key-c keys nth key-j keys nth or [ world walk-downward ] when
+ key-escape keys nth [ world close-window ] when ;
+
+: wasd-mouse-input ( world -- )
+ read-mouse rotate-with-mouse ;
+
+M: wasd-world tick*
+ dup focused?>> [
+ [ wasd-keyboard-input ] [ wasd-mouse-input ] bi
+ reset-mouse
+ ] [ drop ] if ;
+
+M: wasd-world resize-world
+ [ <viewport-state> set-gpu-state* ]
+ [ dup generate-p-matrix >>p-matrix drop ] bi ;
+
projects / factor.git / commitdiff