Fix conflict
Slava Pestov
commit
578ee72509
|
|
@ -372,7 +372,7 @@ HELP: 2keep
|
|||
{ $description "Call a quotation with two values on the stack, restoring the values when the quotation returns." } ;
|
||||
|
||||
HELP: 3keep
|
||||
{ $values { "quot" "a quotation with stack effect " { $snippet "( x y -- )" } } { "x" object } { "y" object } { "z" object } }
|
||||
{ $values { "quot" "a quotation with stack effect " { $snippet "( x y z -- )" } } { "x" object } { "y" object } { "z" object } }
|
||||
{ $description "Call a quotation with three values on the stack, restoring the values when the quotation returns." } ;
|
||||
|
||||
HELP: 2apply
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! Copyright (C) 2007 Slava Pestov
|
||||
! Copyright (C) 2007 Doug Coleman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien assocs init inspector kernel namespaces ;
|
||||
USING: alien assocs continuations init inspector kernel namespaces ;
|
||||
IN: libc
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -84,4 +84,4 @@ PRIVATE>
|
|||
"void" "libc" "memcpy" { "void*" "void*" "ulong" } alien-invoke ;
|
||||
|
||||
: with-malloc ( size quot -- )
|
||||
swap 1 calloc swap keep free ; inline
|
||||
swap 1 calloc [ swap keep ] [ free ] [ ] cleanup ; inline
|
||||
|
|
|
|||
|
|
@ -1,51 +1,15 @@
|
|||
USING: arrays bunny io io.files kernel
|
||||
math math.functions math.vectors multiline
|
||||
namespaces
|
||||
opengl opengl.gl
|
||||
prettyprint
|
||||
sequences ui ui.gadgets ui.gestures ui.render ;
|
||||
USING: arrays bunny combinators.lib io io.files kernel
|
||||
math math.functions multiline
|
||||
opengl opengl.gl opengl-demo-support
|
||||
sequences ui ui.gadgets ui.render ;
|
||||
IN: cel-shading
|
||||
|
||||
: NEAR-PLANE 1.0 64.0 / ; inline
|
||||
: FAR-PLANE 4.0 ; inline
|
||||
: FOV 2.0 sqrt 1+ ; inline
|
||||
: MOUSE-MOTION-SCALE 0.5 ; inline
|
||||
: MOUSE-DISTANCE-SCALE 1.0 64.0 / ; inline
|
||||
: KEY-ROTATE-STEP 1.0 ; inline
|
||||
: KEY-DISTANCE-STEP 1.0 64.0 / ; inline
|
||||
: DIMS { 640 480 } ; inline
|
||||
|
||||
: FOV-RATIO ( -- fov ) DIMS dup first2 min v/n ;
|
||||
|
||||
SYMBOL: last-drag-loc
|
||||
|
||||
TUPLE: cel-shading-gadget yaw pitch distance model program ;
|
||||
TUPLE: cel-shading-gadget model program ;
|
||||
|
||||
: <cel-shading-gadget> ( -- cel-shading-gadget )
|
||||
cel-shading-gadget construct-gadget
|
||||
0.0 over set-cel-shading-gadget-yaw
|
||||
0.0 over set-cel-shading-gadget-pitch
|
||||
0.375 over set-cel-shading-gadget-distance
|
||||
maybe-download read-model over set-cel-shading-gadget-model ;
|
||||
|
||||
: yaw-cel-shading-gadget ( yaw gadget -- )
|
||||
[ [ cel-shading-gadget-yaw + ] keep set-cel-shading-gadget-yaw ] keep relayout-1 ;
|
||||
|
||||
: pitch-cel-shading-gadget ( pitch gadget -- )
|
||||
[ [ cel-shading-gadget-pitch + ] keep set-cel-shading-gadget-pitch ] keep relayout-1 ;
|
||||
|
||||
: zoom-cel-shading-gadget ( distance gadget -- )
|
||||
[ [ cel-shading-gadget-distance + ] keep set-cel-shading-gadget-distance ] keep relayout-1 ;
|
||||
|
||||
M: cel-shading-gadget pref-dim* ( gadget -- dim )
|
||||
drop DIMS ;
|
||||
|
||||
: -+ ( x -- -x x )
|
||||
dup neg swap ;
|
||||
|
||||
: cel-shading-frustum ( -- -x x -y y near far )
|
||||
FOV-RATIO NEAR-PLANE FOV / v*n
|
||||
first2 [ -+ ] 2apply NEAR-PLANE FAR-PLANE ;
|
||||
0.0 0.0 0.375 <demo-gadget>
|
||||
maybe-download read-model
|
||||
{ set-delegate set-cel-shading-gadget-model } cel-shading-gadget construct ;
|
||||
|
||||
STRING: cel-shading-vertex-shader-source
|
||||
varying vec3 position, normal;
|
||||
|
|
@ -90,11 +54,11 @@ main()
|
|||
;
|
||||
|
||||
: cel-shading-program ( -- program )
|
||||
cel-shading-vertex-shader-source <vertex-shader> check-gl-shader
|
||||
cel-shading-fragment-shader-source <fragment-shader> check-gl-shader
|
||||
2array <gl-program> check-gl-program ;
|
||||
cel-shading-vertex-shader-source cel-shading-fragment-shader-source
|
||||
<simple-gl-program> ;
|
||||
|
||||
M: cel-shading-gadget graft* ( gadget -- )
|
||||
"2.0" { "GL_ARB_shader_objects" } require-gl-version-or-extensions
|
||||
0.0 0.0 0.0 1.0 glClearColor
|
||||
GL_CULL_FACE glEnable
|
||||
GL_DEPTH_TEST glEnable
|
||||
|
|
@ -104,19 +68,13 @@ M: cel-shading-gadget ungraft* ( gadget -- )
|
|||
cel-shading-gadget-program delete-gl-program ;
|
||||
|
||||
: cel-shading-draw-setup ( gadget -- gadget )
|
||||
GL_PROJECTION glMatrixMode
|
||||
glLoadIdentity
|
||||
cel-shading-frustum glFrustum
|
||||
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
|
||||
GL_MODELVIEW glMatrixMode
|
||||
glLoadIdentity
|
||||
[ >r 0.0 0.0 r> cel-shading-gadget-distance neg glTranslatef ] keep
|
||||
[ cel-shading-gadget-pitch 1.0 0.0 0.0 glRotatef ] keep
|
||||
[ cel-shading-gadget-yaw 0.0 1.0 0.0 glRotatef ] keep
|
||||
[ cel-shading-gadget-program [ "light_direction" glGetUniformLocation -25.0 45.0 80.0 glUniform3f ] keep
|
||||
[ "color" glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f ] keep
|
||||
[ "ambient" glGetUniformLocation 0.2 0.2 0.2 0.2 glUniform4f ] keep
|
||||
"diffuse" glGetUniformLocation 0.8 0.8 0.8 0.8 glUniform4f ] keep ;
|
||||
[ demo-gadget-set-matrices ] keep
|
||||
[ cel-shading-gadget-program
|
||||
{ [ "light_direction" glGetUniformLocation -25.0 45.0 80.0 glUniform3f ]
|
||||
[ "color" glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f ]
|
||||
[ "ambient" glGetUniformLocation 0.2 0.2 0.2 0.2 glUniform4f ]
|
||||
[ "diffuse" glGetUniformLocation 0.8 0.8 0.8 0.8 glUniform4f ] } call-with
|
||||
] keep ;
|
||||
|
||||
M: cel-shading-gadget draw-gadget* ( gadget -- )
|
||||
dup cel-shading-gadget-program [
|
||||
|
|
@ -125,27 +83,6 @@ M: cel-shading-gadget draw-gadget* ( gadget -- )
|
|||
cel-shading-gadget-model first3 draw-bunny
|
||||
] with-gl-program ;
|
||||
|
||||
: reset-last-drag-rel ( -- )
|
||||
{ 0 0 } last-drag-loc set ;
|
||||
: last-drag-rel ( -- rel )
|
||||
drag-loc [ last-drag-loc get v- ] keep last-drag-loc set ;
|
||||
|
||||
: drag-yaw-pitch ( -- yaw pitch )
|
||||
last-drag-rel MOUSE-MOTION-SCALE v*n first2 ;
|
||||
|
||||
cel-shading-gadget H{
|
||||
{ T{ key-down f f "LEFT" } [ KEY-ROTATE-STEP neg swap yaw-cel-shading-gadget ] }
|
||||
{ T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP swap yaw-cel-shading-gadget ] }
|
||||
{ T{ key-down f f "DOWN" } [ KEY-ROTATE-STEP neg swap pitch-cel-shading-gadget ] }
|
||||
{ T{ key-down f f "UP" } [ KEY-ROTATE-STEP swap pitch-cel-shading-gadget ] }
|
||||
{ T{ key-down f f "=" } [ KEY-DISTANCE-STEP neg swap zoom-cel-shading-gadget ] }
|
||||
{ T{ key-down f f "-" } [ KEY-DISTANCE-STEP swap zoom-cel-shading-gadget ] }
|
||||
|
||||
{ T{ button-down f f 1 } [ drop reset-last-drag-rel ] }
|
||||
{ T{ drag f 1 } [ drag-yaw-pitch rot [ pitch-cel-shading-gadget ] keep yaw-cel-shading-gadget ] }
|
||||
{ T{ mouse-scroll } [ scroll-direction get second MOUSE-DISTANCE-SCALE * swap zoom-cel-shading-gadget ] }
|
||||
} set-gestures
|
||||
|
||||
: cel-shading-window ( -- )
|
||||
[ <cel-shading-gadget> "Cel Shading" open-window ] with-ui ;
|
||||
|
||||
|
|
|
|||
|
|
@ -171,14 +171,24 @@ MACRO: parallel-call ( quots -- )
|
|||
! map-call and friends
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: (make-call-with) ( quots -- quot )
|
||||
[ [ keep ] curry ] map concat [ drop ] append ;
|
||||
|
||||
MACRO: call-with ( quots -- )
|
||||
(make-call-with) ;
|
||||
|
||||
MACRO: map-call-with ( quots -- )
|
||||
[ [ [ keep ] curry ] map concat ] keep length [ nip narray ] curry compose ;
|
||||
[ (make-call-with) ] keep length [ narray ] curry compose ;
|
||||
|
||||
: (make-call-with2) ( quots -- quot )
|
||||
[ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat
|
||||
[ 2drop ] append ;
|
||||
|
||||
MACRO: call-with2 ( quots -- )
|
||||
(make-call-with2) ;
|
||||
|
||||
MACRO: map-call-with2 ( quots -- )
|
||||
dup >r
|
||||
[ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat
|
||||
[ 2drop ] append
|
||||
r> length [ narray ] curry append ;
|
||||
dup >r (make-call-with2) r> length [ narray ] curry append ;
|
||||
|
||||
MACRO: map-exec-with ( words -- ) [ 1quotation ] map [ map-call-with ] curry ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
||||
|
|
@ -0,0 +1,251 @@
|
|||
USING: arrays bunny combinators.lib continuations io io.files kernel
|
||||
math math.functions math.vectors multiline
|
||||
namespaces
|
||||
opengl opengl.gl opengl-demo-support
|
||||
prettyprint
|
||||
sequences ui ui.gadgets ui.gestures ui.render ;
|
||||
IN: line-art
|
||||
|
||||
TUPLE: line-art-gadget
|
||||
model step1-program step2-program
|
||||
framebuffer color-texture normal-texture depth-texture framebuffer-dim ;
|
||||
|
||||
: <line-art-gadget> ( -- line-art-gadget )
|
||||
40.0 -5.0 0.275 <demo-gadget>
|
||||
maybe-download read-model
|
||||
{ set-delegate set-line-art-gadget-model } line-art-gadget construct ;
|
||||
|
||||
STRING: line-art-step1-vertex-shader-source
|
||||
varying vec3 normal;
|
||||
|
||||
void
|
||||
main()
|
||||
{
|
||||
gl_Position = ftransform();
|
||||
normal = gl_Normal;
|
||||
}
|
||||
|
||||
;
|
||||
|
||||
STRING: line-art-step1-fragment-shader-source
|
||||
varying vec3 normal;
|
||||
uniform vec4 color;
|
||||
|
||||
void
|
||||
main()
|
||||
{
|
||||
gl_FragData[0] = color;
|
||||
gl_FragData[1] = vec4(normal, 1);
|
||||
}
|
||||
|
||||
;
|
||||
|
||||
STRING: line-art-step2-vertex-shader-source
|
||||
varying vec2 coord;
|
||||
|
||||
void
|
||||
main()
|
||||
{
|
||||
gl_Position = ftransform();
|
||||
coord = (gl_Vertex * vec4(0.5) + vec4(0.5)).xy;
|
||||
}
|
||||
|
||||
;
|
||||
|
||||
STRING: line-art-step2-fragment-shader-source
|
||||
uniform sampler2D colormap, normalmap, depthmap;
|
||||
uniform vec4 line_color;
|
||||
varying vec2 coord;
|
||||
|
||||
const float DEPTH_RATIO_THRESHOLD = 1.001, NORMAL_DOT_THRESHOLD = 1.0, SAMPLE_SPREAD = 1.0/512.0;
|
||||
|
||||
bool
|
||||
is_normal_border(vec3 norm1, vec3 norm2)
|
||||
{
|
||||
return dot(norm1, norm2) < NORMAL_DOT_THRESHOLD;
|
||||
}
|
||||
|
||||
float
|
||||
depth_sample(vec2 c)
|
||||
{
|
||||
return texture2D(depthmap, c).x;
|
||||
}
|
||||
bool
|
||||
are_depths_border(vec3 depths)
|
||||
{
|
||||
return any(lessThan(depths, vec3(1.0/DEPTH_RATIO_THRESHOLD)))
|
||||
|| any(greaterThan(depths, vec3(DEPTH_RATIO_THRESHOLD)));
|
||||
}
|
||||
|
||||
vec3
|
||||
normal_sample(vec2 c)
|
||||
{
|
||||
return texture2D(normalmap, c).xyz;
|
||||
}
|
||||
|
||||
float
|
||||
min6(float a, float b, float c, float d, float e, float f)
|
||||
{
|
||||
return min(min(min(min(min(a, b), c), d), e), f);
|
||||
}
|
||||
|
||||
float
|
||||
border_factor(vec2 c)
|
||||
{
|
||||
vec2 coord1 = c + vec2(-SAMPLE_SPREAD, -SAMPLE_SPREAD),
|
||||
coord2 = c + vec2( SAMPLE_SPREAD, -SAMPLE_SPREAD),
|
||||
coord3 = c + vec2(-SAMPLE_SPREAD, SAMPLE_SPREAD),
|
||||
coord4 = c + vec2( SAMPLE_SPREAD, SAMPLE_SPREAD);
|
||||
|
||||
vec4 depths = vec4(depth_sample(coord1),
|
||||
depth_sample(coord2),
|
||||
depth_sample(coord3),
|
||||
depth_sample(coord4));
|
||||
if (depths == vec4(1, 1, 1, 1))
|
||||
return 0.0;
|
||||
|
||||
vec3 ratios1 = depths.xxx/depths.yzw, ratios2 = depths.yyz/depths.zww;
|
||||
|
||||
if (are_depths_border(ratios1) || are_depths_border(ratios2))
|
||||
return 1.0;
|
||||
|
||||
vec3 normal1 = normal_sample(coord1),
|
||||
normal2 = normal_sample(coord2),
|
||||
normal3 = normal_sample(coord3),
|
||||
normal4 = normal_sample(coord4);
|
||||
|
||||
float normal_border = 1.0 - min6(
|
||||
dot(normal1, normal2),
|
||||
dot(normal1, normal3),
|
||||
dot(normal1, normal4),
|
||||
dot(normal2, normal3),
|
||||
dot(normal2, normal4),
|
||||
dot(normal3, normal4)
|
||||
);
|
||||
|
||||
return normal_border;
|
||||
}
|
||||
|
||||
void
|
||||
main()
|
||||
{
|
||||
gl_FragColor = mix(texture2D(colormap, coord), line_color, border_factor(coord));
|
||||
}
|
||||
|
||||
;
|
||||
|
||||
: (line-art-step1-program) ( -- step1 )
|
||||
line-art-step1-vertex-shader-source line-art-step1-fragment-shader-source
|
||||
<simple-gl-program> ;
|
||||
: (line-art-step2-program) ( -- step2 )
|
||||
line-art-step2-vertex-shader-source line-art-step2-fragment-shader-source
|
||||
<simple-gl-program> ;
|
||||
|
||||
: (line-art-framebuffer-texture) ( dim iformat xformat -- texture )
|
||||
swapd >r >r >r
|
||||
GL_TEXTURE0 glActiveTexture
|
||||
gen-texture GL_TEXTURE_2D over glBindTexture
|
||||
GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri
|
||||
GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri
|
||||
GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri
|
||||
GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri
|
||||
GL_TEXTURE_2D 0 r> r> first2 0 r> GL_UNSIGNED_BYTE f glTexImage2D ;
|
||||
|
||||
: (line-art-color-texture) ( dim -- texture )
|
||||
GL_RGBA16F_ARB GL_RGBA (line-art-framebuffer-texture) ;
|
||||
|
||||
: (line-art-normal-texture) ( dim -- texture )
|
||||
GL_RGBA16F_ARB GL_RGBA (line-art-framebuffer-texture) ;
|
||||
|
||||
: (line-art-depth-texture) ( dim -- texture )
|
||||
GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT (line-art-framebuffer-texture) ;
|
||||
|
||||
: (attach-framebuffer-texture) ( texture attachment -- )
|
||||
swap >r >r GL_FRAMEBUFFER_EXT r> GL_TEXTURE_2D r> 0 glFramebufferTexture2DEXT gl-error ;
|
||||
|
||||
: (line-art-framebuffer) ( color-texture normal-texture depth-texture -- framebuffer )
|
||||
3array gen-framebuffer dup [
|
||||
swap GL_COLOR_ATTACHMENT0_EXT
|
||||
GL_COLOR_ATTACHMENT1_EXT
|
||||
GL_DEPTH_ATTACHMENT_EXT 3array [ (attach-framebuffer-texture) ] 2each
|
||||
check-framebuffer
|
||||
] with-framebuffer ;
|
||||
|
||||
: line-art-remake-framebuffer-if-needed ( gadget -- )
|
||||
dup { rect-dim rect-dim line-art-gadget-framebuffer-dim } get-slots = [ 2drop ] [
|
||||
swap >r
|
||||
dup (line-art-color-texture) gl-error
|
||||
swap dup (line-art-normal-texture) gl-error
|
||||
swap dup (line-art-depth-texture) gl-error
|
||||
swap >r
|
||||
[ (line-art-framebuffer) ] 3keep
|
||||
r> r> { set-line-art-gadget-framebuffer
|
||||
set-line-art-gadget-color-texture
|
||||
set-line-art-gadget-normal-texture
|
||||
set-line-art-gadget-depth-texture
|
||||
set-line-art-gadget-framebuffer-dim } set-slots
|
||||
] if ;
|
||||
|
||||
M: line-art-gadget graft* ( gadget -- )
|
||||
"2.0" { "GL_ARB_draw_buffers" "GL_ARB_shader_objects" "GL_ARB_multitexture" }
|
||||
require-gl-version-or-extensions
|
||||
{ "GL_EXT_framebuffer_object" } require-gl-extensions
|
||||
GL_CULL_FACE glEnable
|
||||
GL_DEPTH_TEST glEnable
|
||||
(line-art-step1-program) over set-line-art-gadget-step1-program
|
||||
(line-art-step2-program) swap set-line-art-gadget-step2-program ;
|
||||
|
||||
M: line-art-gadget ungraft* ( gadget -- )
|
||||
dup line-art-gadget-framebuffer [
|
||||
{ [ line-art-gadget-step1-program delete-gl-program ]
|
||||
[ line-art-gadget-step2-program delete-gl-program ]
|
||||
[ line-art-gadget-framebuffer delete-framebuffer ]
|
||||
[ line-art-gadget-color-texture delete-texture ]
|
||||
[ line-art-gadget-normal-texture delete-texture ]
|
||||
[ line-art-gadget-depth-texture delete-texture ]
|
||||
[ f swap set-line-art-gadget-framebuffer-dim ]
|
||||
[ f swap set-line-art-gadget-framebuffer ] } call-with
|
||||
] [ drop ] if ;
|
||||
|
||||
: line-art-draw-setup ( gadget -- gadget )
|
||||
0.0 0.0 0.0 1.0 glClearColor
|
||||
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
|
||||
dup demo-gadget-set-matrices
|
||||
dup line-art-remake-framebuffer-if-needed
|
||||
gl-error ;
|
||||
|
||||
: line-art-clear-framebuffer ( -- )
|
||||
GL_COLOR_ATTACHMENT0_EXT glDrawBuffer
|
||||
0.2 0.2 0.2 1.0 glClearColor
|
||||
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
|
||||
GL_COLOR_ATTACHMENT1_EXT glDrawBuffer
|
||||
0.0 0.0 0.0 0.0 glClearColor
|
||||
GL_COLOR_BUFFER_BIT glClear ;
|
||||
|
||||
M: line-art-gadget draw-gadget* ( gadget -- )
|
||||
line-art-draw-setup
|
||||
dup line-art-gadget-framebuffer [
|
||||
line-art-clear-framebuffer
|
||||
{ GL_COLOR_ATTACHMENT0_EXT GL_COLOR_ATTACHMENT1_EXT } set-draw-buffers
|
||||
dup line-art-gadget-step1-program dup [
|
||||
"color" glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f
|
||||
0.0 -0.12 0.0 glTranslatef
|
||||
dup line-art-gadget-model first3 draw-bunny
|
||||
] with-gl-program
|
||||
] with-framebuffer
|
||||
init-matrices
|
||||
dup line-art-gadget-color-texture GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit
|
||||
dup line-art-gadget-normal-texture GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit
|
||||
dup line-art-gadget-depth-texture GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit
|
||||
line-art-gadget-step2-program dup [
|
||||
{ [ "colormap" glGetUniformLocation 0 glUniform1i ]
|
||||
[ "normalmap" glGetUniformLocation 1 glUniform1i ]
|
||||
[ "depthmap" glGetUniformLocation 2 glUniform1i ]
|
||||
[ "line_color" glGetUniformLocation 0.2 0.0 0.0 1.0 glUniform4f ] } call-with
|
||||
{ -1.0 -1.0 } { 1.0 1.0 } rect-vertices
|
||||
] with-gl-program ;
|
||||
|
||||
: line-art-window ( -- )
|
||||
[ <line-art-gadget> "Line Art" open-window ] with-ui ;
|
||||
|
||||
MAIN: line-art-window
|
||||
|
|
@ -0,0 +1 @@
|
|||
Stanford Bunny rendered with cartoon-style lines instead of shading
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
demos
|
||||
opengl
|
||||
glsl
|
||||
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
||||
|
|
@ -0,0 +1,74 @@
|
|||
USING: arrays combinators.lib kernel math math.functions math.vectors namespaces
|
||||
opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render ;
|
||||
IN: opengl-demo-support
|
||||
|
||||
: NEAR-PLANE 1.0 64.0 / ; inline
|
||||
: FAR-PLANE 4.0 ; inline
|
||||
: FOV 2.0 sqrt 1+ ; inline
|
||||
: MOUSE-MOTION-SCALE 0.5 ; inline
|
||||
: MOUSE-DISTANCE-SCALE 1.0 64.0 / ; inline
|
||||
: KEY-ROTATE-STEP 1.0 ; inline
|
||||
: KEY-DISTANCE-STEP 1.0 64.0 / ; inline
|
||||
: DIMS { 640 480 } ; inline
|
||||
|
||||
: FOV-RATIO ( -- fov ) DIMS dup first2 min v/n ;
|
||||
|
||||
SYMBOL: last-drag-loc
|
||||
|
||||
TUPLE: demo-gadget yaw pitch distance ;
|
||||
|
||||
: <demo-gadget> ( yaw pitch distance -- gadget )
|
||||
demo-gadget construct-gadget
|
||||
[ { set-demo-gadget-yaw set-demo-gadget-pitch set-demo-gadget-distance } set-slots ] keep ;
|
||||
|
||||
: yaw-demo-gadget ( yaw gadget -- )
|
||||
[ [ demo-gadget-yaw + ] keep set-demo-gadget-yaw ] keep relayout-1 ;
|
||||
|
||||
: pitch-demo-gadget ( pitch gadget -- )
|
||||
[ [ demo-gadget-pitch + ] keep set-demo-gadget-pitch ] keep relayout-1 ;
|
||||
|
||||
: zoom-demo-gadget ( distance gadget -- )
|
||||
[ [ demo-gadget-distance + ] keep set-demo-gadget-distance ] keep relayout-1 ;
|
||||
|
||||
M: demo-gadget pref-dim* ( gadget -- dim )
|
||||
drop DIMS ;
|
||||
|
||||
: -+ ( x -- -x x )
|
||||
dup neg swap ;
|
||||
|
||||
: demo-gadget-frustum ( -- -x x -y y near far )
|
||||
FOV-RATIO NEAR-PLANE FOV / v*n
|
||||
first2 [ -+ ] 2apply NEAR-PLANE FAR-PLANE ;
|
||||
|
||||
: demo-gadget-set-matrices ( gadget -- )
|
||||
GL_PROJECTION glMatrixMode
|
||||
glLoadIdentity
|
||||
demo-gadget-frustum glFrustum
|
||||
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
|
||||
GL_MODELVIEW glMatrixMode
|
||||
glLoadIdentity
|
||||
{ [ >r 0.0 0.0 r> demo-gadget-distance neg glTranslatef ]
|
||||
[ demo-gadget-pitch 1.0 0.0 0.0 glRotatef ]
|
||||
[ demo-gadget-yaw 0.0 1.0 0.0 glRotatef ] } call-with ;
|
||||
|
||||
: reset-last-drag-rel ( -- )
|
||||
{ 0 0 } last-drag-loc set ;
|
||||
: last-drag-rel ( -- rel )
|
||||
drag-loc [ last-drag-loc get v- ] keep last-drag-loc set ;
|
||||
|
||||
: drag-yaw-pitch ( -- yaw pitch )
|
||||
last-drag-rel MOUSE-MOTION-SCALE v*n first2 ;
|
||||
|
||||
demo-gadget H{
|
||||
{ T{ key-down f f "LEFT" } [ KEY-ROTATE-STEP neg swap yaw-demo-gadget ] }
|
||||
{ T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP swap yaw-demo-gadget ] }
|
||||
{ T{ key-down f f "DOWN" } [ KEY-ROTATE-STEP neg swap pitch-demo-gadget ] }
|
||||
{ T{ key-down f f "UP" } [ KEY-ROTATE-STEP swap pitch-demo-gadget ] }
|
||||
{ T{ key-down f f "=" } [ KEY-DISTANCE-STEP neg swap zoom-demo-gadget ] }
|
||||
{ T{ key-down f f "-" } [ KEY-DISTANCE-STEP swap zoom-demo-gadget ] }
|
||||
|
||||
{ T{ button-down f f 1 } [ drop reset-last-drag-rel ] }
|
||||
{ T{ drag f 1 } [ drag-yaw-pitch rot [ pitch-demo-gadget ] keep yaw-demo-gadget ] }
|
||||
{ T{ mouse-scroll } [ scroll-direction get second MOUSE-DISTANCE-SCALE * swap zoom-demo-gadget ] }
|
||||
} set-gestures
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
Common support for OpenGL demos
|
||||
|
|
@ -0,0 +1 @@
|
|||
opengl
|
||||
|
|
@ -37,6 +37,10 @@ HELP: gl-rect
|
|||
{ $values { "loc" "a pair of integers" } { "ext" "a pair of integers" } }
|
||||
{ $description "Draws the outline of a rectangle with top-left corner " { $snippet "loc" } " and bottom-right corner " { $snippet "ext" } "." } ;
|
||||
|
||||
HELP: rect-vertices
|
||||
{ $values { "lower-left" "A pair of numbers indicating the lower-left coordinates of the rectangle." } { "upper-right" "The upper-right coordinates of the rectangle." } }
|
||||
{ $description "Emits" { $link glVertex2d } " calls outlining the axis-aligned rectangle from " { $snippet "lower-left" } " to " { $snippet "upper-right" } " on the z=0 plane in counterclockwise order." } ;
|
||||
|
||||
HELP: gl-fill-poly
|
||||
{ $values { "points" "a sequence of pairs of integers" } }
|
||||
{ $description "Draws a filled polygon." } ;
|
||||
|
|
@ -53,6 +57,58 @@ HELP: gen-texture
|
|||
{ $values { "id" integer } }
|
||||
{ $description "Wrapper for " { $link glGenTextures } " to handle the common case of generating a single texture ID." } ;
|
||||
|
||||
HELP: gen-framebuffer
|
||||
{ $values { "id" integer } }
|
||||
{ $description "Wrapper for " { $link glGenFramebuffersEXT } " to handle the common case of generating a single framebuffer ID." } ;
|
||||
|
||||
HELP: gen-renderbuffer
|
||||
{ $values { "id" integer } }
|
||||
{ $description "Wrapper for " { $link glGenRenderbuffersEXT } " to handle the common case of generating a single render buffer ID." } ;
|
||||
|
||||
HELP: gen-buffer
|
||||
{ $values { "id" integer } }
|
||||
{ $description "Wrapper for " { $link glGenBuffers } " to handle the common case of generating a single buffer ID." } ;
|
||||
|
||||
HELP: delete-texture
|
||||
{ $values { "id" integer } }
|
||||
{ $description "Wrapper for " { $link glDeleteTextures } " to handle the common case of deleting a single texture ID." } ;
|
||||
|
||||
HELP: delete-framebuffer
|
||||
{ $values { "id" integer } }
|
||||
{ $description "Wrapper for " { $link glDeleteFramebuffersEXT } " to handle the common case of deleting a single framebuffer ID." } ;
|
||||
|
||||
HELP: delete-renderbuffer
|
||||
{ $values { "id" integer } }
|
||||
{ $description "Wrapper for " { $link glDeleteRenderbuffersEXT } " to handle the common case of deleting a single render buffer ID." } ;
|
||||
|
||||
HELP: delete-buffer
|
||||
{ $values { "id" integer } }
|
||||
{ $description "Wrapper for " { $link glDeleteBuffers } " to handle the common case of deleting a single buffer ID." } ;
|
||||
|
||||
{ gen-texture delete-texture } related-words
|
||||
{ gen-framebuffer delete-framebuffer } related-words
|
||||
{ gen-renderbuffer delete-renderbuffer } related-words
|
||||
{ gen-buffer delete-buffer } related-words
|
||||
|
||||
HELP: framebuffer-incomplete?
|
||||
{ $values { "status/f" "The framebuffer error code, or " { $snippet "f" } " if the framebuffer is render-complete." } }
|
||||
{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " to see if it is incomplete, i.e., it is not ready to be rendered to." } ;
|
||||
|
||||
HELP: check-framebuffer
|
||||
{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " with " { $link framebuffer-incomplete? } ", and throws a descriptive error if the framebuffer is incomplete." } ;
|
||||
|
||||
HELP: with-framebuffer
|
||||
{ $values { "id" "The id of a framebuffer object." } { "quot" "a quotation" } }
|
||||
{ $description "Binds framebuffer " { $snippet "id" } " in the dynamic extent of " { $snippet "quot" } ", restoring the window framebuffer when finished." } ;
|
||||
|
||||
HELP: bind-texture-unit
|
||||
{ $values { "id" "The id of a texture object." } { "target" "The texture target (e.g., " { $snippet "GL_TEXTURE_2D" } ")" } { "unit" "The texture unit to bind (e.g., " { $snippet "GL_TEXTURE0" } ")" } }
|
||||
{ $description "Binds texture " { $snippet "id" } " to texture target " { $snippet "target" } " of texture unit " { $snippet "unit" } ". Equivalent to " { $snippet "unit glActiveTexture target id glBindTexture" } "." } ;
|
||||
|
||||
HELP: set-draw-buffers
|
||||
{ $values { "buffers" "A sequence of buffer words (e.g. " { $snippet "GL_BACK" } ", " { $snippet "GL_COLOR_ATTACHMENT0_EXT" } ")"} }
|
||||
{ $description "Wrapper for " { $link glDrawBuffers } ". Sets up the buffers named in the sequence for simultaneous drawing." } ;
|
||||
|
||||
HELP: do-attribs
|
||||
{ $values { "bits" integer } { "quot" quotation } }
|
||||
{ $description "Wraps a quotation in " { $link glPushAttrib } "/" { $link glPopAttrib } " calls." } ;
|
||||
|
|
@ -148,11 +204,11 @@ HELP: gl-shader-info-log
|
|||
HELP: gl-program
|
||||
{ $class-description { $snippet "gl-program" } " is a predicate class comprising values returned by OpenGL to represent proram objects. The following words are provided for creating and manipulating these objects:"
|
||||
{ $list
|
||||
{ { $link <gl-program> } " - Link a set of shaders into a GLSL program" }
|
||||
{ { $link <gl-program> } ", " { $link <simple-gl-program> } " - Link a set of shaders into a GLSL program" }
|
||||
{ { $link gl-program-ok? } " - Check whether a program object linked successfully" }
|
||||
{ { $link check-gl-program } " - Throw an error unless a program object linked successfully" }
|
||||
{ { $link gl-program-info-log } " - Retrieve the info log of messages generated by the GLSL linker" }
|
||||
{ { $link gl-program-shaders } " - Retrieve the set of shader objects composing the GLSL linker" }
|
||||
{ { $link gl-program-shaders } " - Retrieve the set of shader objects composing the GLSL program" }
|
||||
{ { $link delete-gl-program } " - Invalidate a program object and all its attached shaders" }
|
||||
{ { $link with-gl-program } " - Use a program object" }
|
||||
}
|
||||
|
|
@ -162,6 +218,12 @@ HELP: <gl-program>
|
|||
{ $values { "shaders" "A sequence of " { $link gl-shader } " objects." } }
|
||||
{ $description "Creates a new GLSL program object, attaches all the shader objects in the " { $snippet "shaders" } " sequence, and attempts to link them. The returned object can be checked for validity by " { $link check-gl-program } " or " { $link gl-program-ok? } ". Errors and warnings generated by the GLSL linker will be collected in the info log, available from " { $link gl-program-info-log } ".\n\nWhen the program object and its attached shaders are no longer needed, it should be deleted using " { $link delete-gl-program } "." } ;
|
||||
|
||||
HELP: <simple-gl-program>
|
||||
{ $values { "vertex-shader-source" "A string containing GLSL vertex shader source" } { "fragment-shader-source" "A string containing GLSL fragment shader source" } }
|
||||
{ $description "Wrapper for " { $link <gl-program> } " for the simple case of compiling a single vertex shader and fragment shader and linking them into a GLSL program. Throws an exception if compiling or linking fails." } ;
|
||||
|
||||
{ <gl-program> <simple-gl-program> } related-words
|
||||
|
||||
HELP: gl-program-ok?
|
||||
{ $values { "program" "A " { $link gl-program } " object" } }
|
||||
{ $description "Returns a boolean value indicating whether the given program object linked successfully. Link errors and warnings are available in the program's info log, which can be gotten using " { $link gl-program-info-log } "." } ;
|
||||
|
|
@ -180,21 +242,80 @@ HELP: delete-gl-program
|
|||
|
||||
HELP: with-gl-program
|
||||
{ $values { "program" "A " { $link gl-program } " object" } { "quot" "A quotation" } }
|
||||
{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in " { $snippet "quot" } ". The fixed-function pipeline is restored at the end of " { $snippet "quot" } "." } ;
|
||||
{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in the dynamic extent of " { $snippet "quot" } ". The fixed-function pipeline is restored at the end of " { $snippet "quot" } "." } ;
|
||||
|
||||
HELP: gl-version
|
||||
{ $values { "version" "The version string from the OpenGL implementation" } }
|
||||
{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ;
|
||||
|
||||
HELP: gl-vendor-version
|
||||
{ $values { "version" "The vendor-specific version information from the OpenGL implementation" } }
|
||||
{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ;
|
||||
|
||||
HELP: has-gl-version?
|
||||
{ $values { "version" "A version string" } { "?" "A boolean value" } }
|
||||
{ $description "Compares the version string returned by " { $link gl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ;
|
||||
|
||||
HELP: require-gl-version
|
||||
{ $values { "version" "A version string" } }
|
||||
{ $description "Throws an exception if " { $link has-gl-version? } " returns false for " { $snippet "version" } "." } ;
|
||||
|
||||
HELP: glsl-version
|
||||
{ $values { "version" "The GLSL version string from the OpenGL implementation" } }
|
||||
{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ;
|
||||
|
||||
HELP: glsl-vendor-version
|
||||
{ $values { "version" "The vendor-specific GLSL version information from the OpenGL implementation" } }
|
||||
{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ;
|
||||
|
||||
HELP: has-glsl-version?
|
||||
{ $values { "version" "A version string" } { "?" "A boolean value" } }
|
||||
{ $description "Compares the version string returned by " { $link glsl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ;
|
||||
|
||||
HELP: require-glsl-version
|
||||
{ $values { "version" "A version string" } }
|
||||
{ $description "Throws an exception if " { $link has-glsl-version? } " returns false for " { $snippet "version" } "." } ;
|
||||
|
||||
HELP: gl-extensions
|
||||
{ $values { "seq" "A sequence of strings naming the implementation-supported OpenGL extensions" } }
|
||||
{ $description "Wrapper for " { $snippet "GL_EXTENSIONS glGetString" } " that returns a sequence of extension names supported by the OpenGL implementation." } ;
|
||||
|
||||
HELP: has-gl-extensions?
|
||||
{ $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } }
|
||||
{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } "." } ;
|
||||
|
||||
HELP: require-gl-extensions
|
||||
{ $values { "extensions" "A sequence of extension name strings" } }
|
||||
{ $description "Throws an exception if " { $link has-gl-extensions? } " returns false for " { $snippet "extensions" } "." } ;
|
||||
|
||||
HELP: require-gl-version-or-extensions
|
||||
{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } }
|
||||
{ $description "Throws an exception if neither " { $link has-gl-version? } " nor " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version, or a set of equivalent extensions." } ;
|
||||
|
||||
{ require-gl-version require-glsl-version require-gl-extensions require-gl-version-or-extensions has-gl-version? has-glsl-version? has-gl-extensions? gl-version glsl-version gl-extensions } related-words
|
||||
|
||||
ARTICLE: "gl-utilities" "OpenGL utility words"
|
||||
"In addition to the full OpenGL API, the " { $vocab-link "opengl" } " vocabulary includes some utility words to give OpenGL a more Factor-like feel."
|
||||
$nl
|
||||
"Checking implementation capabilities:"
|
||||
{ $subsection require-gl-version }
|
||||
{ $subsection require-gl-extensions }
|
||||
{ $subsection require-glsl-version }
|
||||
{ $subsection require-gl-version-or-extensions }
|
||||
"Wrappers:"
|
||||
{ $subsection gl-color }
|
||||
{ $subsection gl-vertex }
|
||||
{ $subsection gl-translate }
|
||||
{ $subsection gen-texture }
|
||||
{ $subsection bind-texture-unit }
|
||||
"Combinators:"
|
||||
{ $subsection do-state }
|
||||
{ $subsection do-enabled }
|
||||
{ $subsection do-attribs }
|
||||
{ $subsection do-matrix }
|
||||
{ $subsection with-translation }
|
||||
{ $subsection with-framebuffer }
|
||||
{ $subsection with-gl-program }
|
||||
{ $subsection make-dlist }
|
||||
"Rendering geometric shapes:"
|
||||
{ $subsection gl-line }
|
||||
|
|
|
|||
|
|
@ -2,9 +2,9 @@
|
|||
! Portions copyright (C) 2007 Eduardo Cavazos.
|
||||
! Portions copyright (C) 2008 Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types byte-arrays kernel libc math
|
||||
namespaces sequences math.vectors math.constants math.functions
|
||||
opengl.gl opengl.glu combinators arrays ;
|
||||
USING: alien alien.c-types continuations kernel libc math macros namespaces
|
||||
math.vectors math.constants math.functions math.parser opengl.gl opengl.glu
|
||||
combinators arrays sequences splitting words ;
|
||||
IN: opengl
|
||||
|
||||
: coordinates [ first2 ] 2apply ;
|
||||
|
|
@ -94,8 +94,63 @@ IN: opengl
|
|||
] 2each 2drop
|
||||
] do-state ;
|
||||
|
||||
: (gen-gl-object) ( quot -- id )
|
||||
>r 1 0 <uint> r> keep *uint ; inline
|
||||
: gen-texture ( -- id )
|
||||
1 0 <uint> [ glGenTextures ] keep *uint ;
|
||||
[ glGenTextures ] (gen-gl-object) ;
|
||||
: gen-framebuffer ( -- id )
|
||||
[ glGenFramebuffersEXT ] (gen-gl-object) ;
|
||||
: gen-renderbuffer ( -- id )
|
||||
[ glGenRenderbuffersEXT ] (gen-gl-object) ;
|
||||
: gen-buffer ( -- id )
|
||||
[ glGenBuffers ] (gen-gl-object) ;
|
||||
|
||||
: (delete-gl-object) ( id quot -- )
|
||||
>r 1 swap <uint> r> call ; inline
|
||||
: delete-texture ( id -- )
|
||||
[ glDeleteTextures ] (delete-gl-object) ;
|
||||
: delete-framebuffer ( id -- )
|
||||
[ glDeleteFramebuffersEXT ] (delete-gl-object) ;
|
||||
: delete-renderbuffer ( id -- )
|
||||
[ glDeleteRenderbuffersEXT ] (delete-gl-object) ;
|
||||
: delete-buffer ( id -- )
|
||||
[ glDeleteBuffers ] (delete-gl-object) ;
|
||||
|
||||
: framebuffer-incomplete? ( -- status/f )
|
||||
GL_FRAMEBUFFER_EXT glCheckFramebufferStatusEXT
|
||||
dup GL_FRAMEBUFFER_COMPLETE_EXT = f rot ? ;
|
||||
|
||||
: framebuffer-error ( status -- * )
|
||||
{ { GL_FRAMEBUFFER_COMPLETE_EXT [ "framebuffer complete" ] }
|
||||
{ GL_FRAMEBUFFER_UNSUPPORTED_EXT [ "framebuffer configuration unsupported" ] }
|
||||
{ GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT_EXT [ "framebuffer incomplete (incomplete attachment)" ] }
|
||||
{ GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT_EXT [ "framebuffer incomplete (missing attachment)" ] }
|
||||
{ GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT [ "framebuffer incomplete (dimension mismatch)" ] }
|
||||
{ GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT [ "framebuffer incomplete (format mismatch)" ] }
|
||||
{ GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT [ "framebuffer incomplete (draw buffer(s) have no attachment)" ] }
|
||||
{ GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT [ "framebuffer incomplete (read buffer has no attachment)" ] }
|
||||
[ drop gl-error "unknown framebuffer error" ] } case throw ;
|
||||
|
||||
: check-framebuffer ( -- )
|
||||
framebuffer-incomplete? [ framebuffer-error ] when* ;
|
||||
|
||||
: with-framebuffer ( id quot -- )
|
||||
GL_FRAMEBUFFER_EXT rot glBindFramebufferEXT
|
||||
[ call ]
|
||||
[ GL_FRAMEBUFFER_EXT 0 glBindFramebufferEXT ] [ ] cleanup ; inline
|
||||
|
||||
: bind-texture-unit ( id target unit -- )
|
||||
glActiveTexture swap glBindTexture gl-error ;
|
||||
|
||||
: framebuffer-attachment ( attachment -- id )
|
||||
GL_FRAMEBUFFER_EXT swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT
|
||||
0 <uint> [ glGetFramebufferAttachmentParameterivEXT ] keep *uint ;
|
||||
|
||||
: (set-draw-buffers) ( buffers -- )
|
||||
dup length swap >c-uint-array glDrawBuffers ;
|
||||
|
||||
MACRO: set-draw-buffers ( buffers -- )
|
||||
[ dup word? [ execute ] [ ] if ] map [ (set-draw-buffers) ] curry ;
|
||||
|
||||
: do-attribs ( bits quot -- )
|
||||
swap glPushAttrib call glPopAttrib ; inline
|
||||
|
|
@ -155,6 +210,14 @@ TUPLE: sprite loc dim dim2 dlist texture ;
|
|||
swap sprite-loc v- gl-translate
|
||||
GL_TEXTURE_2D 0 glBindTexture ;
|
||||
|
||||
: rect-vertices ( lower-left upper-right -- )
|
||||
GL_QUADS [
|
||||
over first2 glVertex2d
|
||||
dup first pick second glVertex2d
|
||||
dup first2 glVertex2d
|
||||
swap first swap second glVertex2d
|
||||
] do-state ;
|
||||
|
||||
: make-sprite-dlist ( sprite -- id )
|
||||
GL_MODELVIEW [
|
||||
GL_COMPILE [ draw-sprite ] make-dlist
|
||||
|
|
@ -168,7 +231,7 @@ TUPLE: sprite loc dim dim2 dlist texture ;
|
|||
|
||||
: free-sprite ( sprite -- )
|
||||
dup sprite-dlist delete-dlist
|
||||
sprite-texture <uint> 1 swap glDeleteTextures ;
|
||||
sprite-texture delete-texture ;
|
||||
|
||||
: free-sprites ( sprites -- ) [ [ free-sprite ] when* ] each ;
|
||||
|
||||
|
|
@ -294,6 +357,70 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
|
|||
] each delete-gl-program-only ;
|
||||
|
||||
: with-gl-program ( program quot -- )
|
||||
swap glUseProgram call 0 glUseProgram ; inline
|
||||
swap glUseProgram [ call ] [ 0 glUseProgram ] [ ] cleanup ; inline
|
||||
|
||||
PREDICATE: integer gl-program (gl-program?) ;
|
||||
|
||||
: <simple-gl-program> ( vertex-shader-source fragment-shader-source -- program )
|
||||
>r <vertex-shader> check-gl-shader
|
||||
r> <fragment-shader> check-gl-shader
|
||||
2array <gl-program> check-gl-program ;
|
||||
|
||||
: (require-gl) ( thing require-quot make-error-quot -- )
|
||||
>r dupd call
|
||||
[ r> 2drop ]
|
||||
[ r> " " make throw ]
|
||||
if ; inline
|
||||
|
||||
: gl-extensions ( -- seq )
|
||||
GL_EXTENSIONS glGetString " " split ;
|
||||
: has-gl-extensions? ( extensions -- ? )
|
||||
gl-extensions subseq? ;
|
||||
: (make-gl-extensions-error) ( required-extensions -- )
|
||||
gl-extensions swap seq-diff
|
||||
"Required OpenGL extensions not supported:\n" %
|
||||
[ " " % % "\n" % ] each ;
|
||||
: require-gl-extensions ( extensions -- )
|
||||
[ has-gl-extensions? ]
|
||||
[ (make-gl-extensions-error) ]
|
||||
(require-gl) ;
|
||||
|
||||
: version-seq ( version-string -- version-seq )
|
||||
"." split [ string>number ] map ;
|
||||
|
||||
: version<=> ( version1 version2 -- n )
|
||||
swap version-seq swap version-seq <=> ;
|
||||
|
||||
: (gl-version) ( -- version vendor )
|
||||
GL_VERSION glGetString " " split1 ;
|
||||
: gl-version ( -- version )
|
||||
(gl-version) drop ;
|
||||
: gl-vendor-version ( -- version )
|
||||
(gl-version) nip ;
|
||||
: has-gl-version? ( version -- ? )
|
||||
gl-version version<=> 0 <= ;
|
||||
: (make-gl-version-error) ( required-version -- )
|
||||
"Required OpenGL version " % % " not supported (" % gl-version % " available)" % ;
|
||||
: require-gl-version ( version -- )
|
||||
[ has-gl-version? ]
|
||||
[ (make-gl-version-error) ]
|
||||
(require-gl) ;
|
||||
|
||||
: (glsl-version) ( -- version vendor )
|
||||
GL_SHADING_LANGUAGE_VERSION glGetString " " split1 ;
|
||||
: glsl-version ( -- version )
|
||||
(glsl-version) drop ;
|
||||
: glsl-vendor-version ( -- version )
|
||||
(glsl-version) nip ;
|
||||
: has-glsl-version? ( version -- ? )
|
||||
glsl-version version<=> 0 <= ;
|
||||
: require-glsl-version ( version -- )
|
||||
[ has-glsl-version? ]
|
||||
[ "Required GLSL version " % % " not supported (" % glsl-version % " available)" % ]
|
||||
(require-gl) ;
|
||||
|
||||
: require-gl-version-or-extensions ( version extensions -- )
|
||||
2array [ first2 has-gl-extensions? swap has-gl-version? or ]
|
||||
[ dup first (make-gl-version-error) "\n" %
|
||||
second (make-gl-extensions-error) "\n" % ]
|
||||
(require-gl) ;
|
||||
|
|
|
|||
|
|
@ -120,12 +120,12 @@ SYMBOL: ui-hook
|
|||
[ dup update-hand draw-world ] each ;
|
||||
|
||||
: notify ( gadget -- )
|
||||
dup gadget-graft-state {
|
||||
{ { f t } [ dup activate-control dup graft* ] }
|
||||
{ { t f } [ dup activate-control dup ungraft* ] }
|
||||
} case
|
||||
dup gadget-graft-state first { f f } { t t } ?
|
||||
swap set-gadget-graft-state ;
|
||||
dup gadget-graft-state [ dup {
|
||||
{ { f t } [ over activate-control over graft* ] }
|
||||
{ { t f } [ over activate-control over ungraft* ] }
|
||||
} case ]
|
||||
[ first { f f } { t t } ?
|
||||
swap set-gadget-graft-state ] [ ] cleanup ;
|
||||
|
||||
: notify-queued ( -- )
|
||||
graft-queue [ notify ] dlist-slurp ;
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
|
|||
|
||||
doc = STDIN.read
|
||||
word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
|
||||
factor_run(%Q(#{doc_using_statements(doc)} USE: help\n \\ #{word} help))</string>
|
||||
factor_run(%Q(#{doc_using_statements(doc)} USE: ui.tools.workspace\n \\ #{word} help-window))</string>
|
||||
<key>fallbackInput</key>
|
||||
<string>word</string>
|
||||
<key>input</key>
|
||||
|
|
|
|||
|
|
@ -139,7 +139,7 @@
|
|||
</dict>
|
||||
<dict>
|
||||
<key>match</key>
|
||||
<string>(^|(?<=\s))(drop|2drop|3drop|keep|2keep|3keep|nip|2nip|dup|2dup|3dup|dupd|over|pick|tuck|swap|rot|-rot|slip|2swap|swapd|>r|r>)(\s|$)</string>
|
||||
<string>(^|(?<=\s))(drop|2drop|3drop|keep|2keep|3keep|nip|2nip|dup|2dup|3dup|dupd|over|pick|tuck|swap|rot|-rot|roll|-roll|slip|2swap|swapd|>r|r>)(\s|$)</string>
|
||||
<key>name</key>
|
||||
<string>keyword.control.stack.factor</string>
|
||||
</dict>
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ void early_init(void)
|
|||
|
||||
const char *vm_executable_path(void)
|
||||
{
|
||||
return [[[NSBundle mainBundle] executablePath] cString];
|
||||
return [[[NSBundle mainBundle] executablePath] UTF8String];
|
||||
}
|
||||
|
||||
const char *default_image_path(void)
|
||||
|
|
@ -55,7 +55,7 @@ const char *default_image_path(void)
|
|||
else
|
||||
returnVal = [path stringByAppendingPathComponent:image];
|
||||
|
||||
return [returnVal cString];
|
||||
return [returnVal UTF8String];
|
||||
}
|
||||
|
||||
void init_signals(void)
|
||||
|
|
|
|||
Loading…
Reference in New Issue