steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fix conflict

db4
Slava Pestov 2008-01-27 23:17:48 -06:00
parent b60edc199a 1d7ba3363e
commit 578ee72509
18 changed files with 638 additions and 110 deletions

2
core/kernel/kernel-docs.factor
View File

@ -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

4
core/libc/libc.factor
View File

@ -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

99
extra/cel-shading/cel-shading.factor
View File

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

20
extra/combinators/lib/lib.factor
View File

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

1
extra/line-art/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

251
extra/line-art/line-art.factor Normal file
View File

@ -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

1
extra/line-art/summary.txt Normal file
View File

@ -0,0 +1 @@
Stanford Bunny rendered with cartoon-style lines instead of shading

3
extra/line-art/tags.txt Normal file
View File

@ -0,0 +1,3 @@
demos
opengl
glsl

1
extra/opengl-demo-support/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

74
extra/opengl-demo-support/opengl-demo-support.factor Normal file
View File

@ -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

1
extra/opengl-demo-support/summary.txt Normal file
View File

@ -0,0 +1 @@
Common support for OpenGL demos

1
extra/opengl-demo-support/tags.txt Normal file
View File

@ -0,0 +1 @@
opengl

127
extra/opengl/opengl-docs.factor
View File

@ -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 }

143
extra/opengl/opengl.factor
View File

@ -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
@ -121,7 +176,7 @@ TUPLE: sprite loc dim dim2 dlist texture ;
GL_UNSIGNED_BYTE r> glTexImage2D
] do-attribs
] keep ;
: gen-dlist ( -- id ) 1 glGenLists ;
: make-dlist ( type quot -- id )
@ -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 ;
@ -253,7 +316,7 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
[ dupd glAttachShader ] each
[ glLinkProgram ] keep
gl-error ;
: (gl-program?) ( object -- ? )
dup integer? [ glIsProgram c-true? ] [ drop f ] if ;
@ -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) ;

12
extra/ui/ui.factor
View File

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

2
misc/Factor.tmbundle/Commands/Help for Word.tmCommand
View File

@ -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>

2
misc/Factor.tmbundle/Syntaxes/Factor.tmLanguage
View File

@ -139,7 +139,7 @@
</dict>
<dict>
<key>match</key>
<string>(^|(?&lt;=\s))(drop|2drop|3drop|keep|2keep|3keep|nip|2nip|dup|2dup|3dup|dupd|over|pick|tuck|swap|rot|-rot|slip|2swap|swapd|&gt;r|r&gt;)(\s|$)</string>
<string>(^|(?&lt;=\s))(drop|2drop|3drop|keep|2keep|3keep|nip|2nip|dup|2dup|3dup|dupd|over|pick|tuck|swap|rot|-rot|roll|-roll|slip|2swap|swapd|&gt;r|r&gt;)(\s|$)</string>
<key>name</key>
<string>keyword.control.stack.factor</string>
</dict>

4
vm/os-macosx.m
View File

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