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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2008-02-03 15:59:02 -06:00
parent bae79b80e3 f4244e7caf
commit 0a0b4b76f2
32 changed files with 1013 additions and 507 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
core/alien/c-types/c-types-docs.factor
View File

@ -34,6 +34,10 @@ HELP: stack-size
{ $description "Outputs the number of bytes to reserve on the C stack by a value of this C type. In most cases this is equal to " { $link heap-size } ", except on some platforms where C structs are passed by invisible reference, in which case a C struct type only uses as much space as a pointer on the C stack." } { $description "Outputs the number of bytes to reserve on the C stack by a value of this C type. In most cases this is equal to " { $link heap-size } ", except on some platforms where C structs are passed by invisible reference, in which case a C struct type only uses as much space as a pointer on the C stack." }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ; { $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: byte-length
{ $values { "seq" "A byte array or float array" } { "n" "a non-negative integer" } }
{ $contract "Outputs the size of the byte array or float array data in bytes as presented to the C library interface." } ;
HELP: c-getter HELP: c-getter
{ $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( c-ptr n -- obj )" } } } { $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( c-ptr n -- obj )" } } }
{ $description "Outputs a quotation which reads values of this C type from a C structure." } { $description "Outputs a quotation which reads values of this C type from a C structure." }

8
core/alien/c-types/c-types.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2004, 2007 Slava Pestov. ! Copyright (C) 2004, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays arrays generator.registers assocs USING: byte-arrays float-arrays arrays generator.registers assocs
kernel kernel.private libc math namespaces parser sequences kernel kernel.private libc math namespaces parser sequences
strings words assocs splitting math.parser cpu.architecture strings words assocs splitting math.parser cpu.architecture
alien alien.accessors quotations system compiler.units ; alien alien.accessors quotations system compiler.units ;
@ -107,6 +107,12 @@ M: string stack-size c-type stack-size ;
M: c-type stack-size c-type-size ; M: c-type stack-size c-type-size ;
GENERIC: byte-length ( seq -- n ) flushable
M: float-array byte-length length "double" heap-size * ;
M: byte-array byte-length length ;
: c-getter ( name -- quot ) : c-getter ( name -- quot )
c-type c-type-getter [ c-type c-type-getter [
[ "Cannot read struct fields with type" throw ] [ "Cannot read struct fields with type" throw ]

2
core/float-arrays/float-arrays-docs.factor
View File

@ -32,7 +32,7 @@ HELP: <float-array> ( n initial -- float-array )
HELP: >float-array HELP: >float-array
{ $values { "seq" "a sequence" } { "float-array" float-array } } { $values { "seq" "a sequence" } { "float-array" float-array } }
{ $description "Outputs a freshly-allocated float array whose elements have the same boolean values as a given sequence." } { $description "Outputs a freshly-allocated float array whose elements have the same floating-point values as a given sequence." }
{ $errors "Throws an error if the sequence contains elements other than real numbers." } ; { $errors "Throws an error if the sequence contains elements other than real numbers." } ;
HELP: 1float-array HELP: 1float-array

149
extra/bunny/bunny.factor
View File

@ -1,112 +1,69 @@
! From http://www.ffconsultancy.com/ocaml/bunny/index.html
USING: alien alien.c-types arrays sequences math USING: alien alien.c-types arrays sequences math
math.vectors math.matrices math.parser io io.files kernel opengl math.vectors math.matrices math.parser io io.files kernel opengl
opengl.gl opengl.glu shuffle http.client vectors timers opengl.gl opengl.glu shuffle http.client vectors timers
namespaces ui.gadgets ui.gadgets.canvas ui.render ui splitting namespaces ui.gadgets ui.gadgets.canvas ui.render ui splitting
combinators tools.time system combinators.lib ; combinators tools.time system combinators.lib combinators.cleave
float-arrays continuations opengl.demo-support multiline
ui.gestures
bunny.fixed-pipeline bunny.cel-shaded bunny.outlined bunny.model ;
IN: bunny IN: bunny
: numbers ( str -- seq ) TUPLE: bunny-gadget model geom draw-seq draw-n ;
" " split [ string>number ] map [ ] subset ;
: (parse-model) ( vs is -- vs is ) : <bunny-gadget> ( -- bunny-gadget )
readln [ 0.0 0.0 0.375 <demo-gadget>
numbers { maybe-download read-model {
{ [ dup length 5 = ] [ 3 head pick push ] } set-delegate
{ [ dup first 3 = ] [ 1 tail over push ] } set-bunny-gadget-model
{ [ t ] [ drop ] } } bunny-gadget construct ;
} cond (parse-model)
] when* ;
: parse-model ( stream -- vs is ) : bunny-gadget-draw ( gadget -- draw )
[ { bunny-gadget-draw-n bunny-gadget-draw-seq }
100000 <vector> 100000 <vector> (parse-model) get-slots nth ;
] with-stream
[
over length # " vertices, " %
dup length # " triangles" %
] "" make print ;
: n ( vs triple -- n ) : bunny-gadget-next-draw ( gadget -- )
swap [ nth ] curry map dup { bunny-gadget-draw-seq bunny-gadget-draw-n }
dup third over first v- >r dup second swap first v- r> cross get-slots
vneg normalize ; 1+ swap length mod
swap [ set-bunny-gadget-draw-n ] keep relayout-1 ;
: normal ( ns vs triple -- ) M: bunny-gadget graft* ( gadget -- )
[ n ] keep [ rot [ v+ ] change-nth ] each-with2 ;
: normals ( vs is -- ns )
over length { 0.0 0.0 0.0 } <array> -rot
[ >r 2dup r> normal ] each drop
[ normalize ] map ;
: read-model ( stream -- model )
"Reading model" print flush [
<file-reader> parse-model [ normals ] 2keep 3array
] time ;
: model-path "bun_zipper.ply" ;
: model-url "http://factorcode.org/bun_zipper.ply" ;
: maybe-download ( -- path )
model-path resource-path dup exists? [
"Downloading bunny from " write
model-url dup print flush
over download-to
] unless ;
: draw-triangle ( ns vs triple -- )
[ dup roll nth gl-normal swap nth gl-vertex ] each-with2 ;
: draw-bunny ( ns vs is -- )
GL_TRIANGLES [ [ draw-triangle ] each-with2 ] do-state ;
TUPLE: bunny-gadget model ;
: <bunny-gadget> ( model -- gadget )
<canvas>
{ set-bunny-gadget-model set-delegate }
bunny-gadget construct ;
M: bunny-gadget graft* 10 10 add-timer ;
M: bunny-gadget ungraft* dup delegate ungraft* remove-timer ;
M: bunny-gadget tick relayout-1 ;
: aspect ( gadget -- x ) rect-dim first2 /f ;
M: bunny-gadget draw-gadget*
GL_DEPTH_TEST glEnable GL_DEPTH_TEST glEnable
GL_SCISSOR_TEST glDisable dup bunny-gadget-model <bunny-geom>
1.0 glClearDepth over {
0.0 0.0 0.0 1.0 glClearColor [ <bunny-fixed-pipeline> ]
GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear [ <bunny-cel-shaded> ]
GL_PROJECTION glMatrixMode [ <bunny-outlined> ]
glLoadIdentity } map-call-with [ ] subset
45.0 over aspect 0.1 1.0 gluPerspective 0
0.0 0.12 -0.25 0.0 0.1 0.0 0.0 1.0 0.0 gluLookAt roll {
GL_MODELVIEW glMatrixMode set-bunny-gadget-geom
glLoadIdentity set-bunny-gadget-draw-seq
GL_LEQUAL glDepthFunc set-bunny-gadget-draw-n
GL_LIGHTING glEnable } set-slots ;
GL_LIGHT0 glEnable
GL_COLOR_MATERIAL glEnable
GL_LIGHT0 GL_POSITION { 1.0 -1.0 1.0 1.0 } >c-float-array glLightfv
millis 24000 mod 0.015 * 0.0 1.0 0.0 glRotated
GL_FRONT_AND_BACK GL_SHININESS 100.0 glMaterialf
GL_FRONT_AND_BACK GL_SPECULAR glColorMaterial
GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE glColorMaterial
0.6 0.5 0.5 1.0 glColor4d
[ bunny-gadget-model first3 draw-bunny ] draw-canvas ;
M: bunny-gadget pref-dim* drop { 400 300 } ; M: bunny-gadget ungraft* ( gadget -- )
{ bunny-gadget-geom bunny-gadget-draw-seq } get-slots
[ [ dispose ] when* ] each
[ dispose ] when* ;
M: bunny-gadget draw-gadget* ( gadget -- )
0.15 0.15 0.15 1.0 glClearColor
GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear
dup demo-gadget-set-matrices
GL_MODELVIEW glMatrixMode
0.0 -0.12 0.0 glTranslatef
{ bunny-gadget-geom bunny-gadget-draw } get-slots
draw-bunny ;
M: bunny-gadget pref-dim* ( gadget -- dim )
drop { 640 480 } ;
bunny-gadget H{
{ T{ key-down f f "TAB" } [ bunny-gadget-next-draw ] }
} set-gestures
: bunny-window ( -- ) : bunny-window ( -- )
[ [ <bunny-gadget> "Bunny" open-window ] with-ui ;
maybe-download read-model <bunny-gadget>
"Bunny" open-window
] with-ui ;
MAIN: bunny-window MAIN: bunny-window

92
extra/bunny/cel-shaded/cel-shaded.factor Normal file
View File

@ -0,0 +1,92 @@
USING: arrays bunny.model combinators.lib continuations
kernel multiline opengl opengl.gl sequences ;
IN: bunny.cel-shaded
STRING: vertex-shader-source
varying vec3 position, normal, viewer;
void
main()
{
gl_Position = ftransform();
position = gl_Vertex.xyz;
normal = gl_Normal;
viewer = vec3(0, 0, 1) * gl_NormalMatrix;
}
;
STRING: cel-shaded-fragment-shader-lib-source
varying vec3 position, normal, viewer;
uniform vec3 light_direction;
uniform vec4 color;
uniform vec4 ambient, diffuse;
uniform float shininess;
float
modulate(vec3 direction, vec3 normal)
{
return dot(direction, normal) * 0.5 + 0.5;
}
float
cel(float m)
{
return smoothstep(0.25, 0.255, m) * 0.4 + smoothstep(0.695, 0.70, m) * 0.5;
}
vec4
cel_light()
{
vec3 direction = normalize(light_direction - position);
vec3 reflection = reflect(direction, normal);
vec4 ad = (ambient + diffuse * vec4(vec3(cel(modulate(direction, normal))), 1));
float s = cel(pow(max(dot(-reflection, viewer), 0.0), shininess));
return ad * color + vec4(vec3(s), 0);
}
;
STRING: cel-shaded-fragment-shader-main-source
vec4 cel_light();
void
main()
{
gl_FragColor = cel_light();
}
;
TUPLE: bunny-cel-shaded program ;
: cel-shading-supported? ( -- ? )
"2.0" { "GL_ARB_shader_objects" }
has-gl-version-or-extensions? ;
: <bunny-cel-shaded> ( gadget -- draw )
drop
cel-shading-supported? [
vertex-shader-source <vertex-shader> check-gl-shader
cel-shaded-fragment-shader-lib-source <fragment-shader> check-gl-shader
cel-shaded-fragment-shader-main-source <fragment-shader> check-gl-shader
3array <gl-program> check-gl-program
{ set-bunny-cel-shaded-program } bunny-cel-shaded construct
] [ f ] if ;
: (draw-cel-shaded-bunny) ( geom program -- )
{
{ "light_direction" [ 1.0 -1.0 1.0 glUniform3f ] }
{ "color" [ 0.6 0.5 0.5 1.0 glUniform4f ] }
{ "ambient" [ 0.2 0.2 0.2 0.2 glUniform4f ] }
{ "diffuse" [ 0.8 0.8 0.8 0.8 glUniform4f ] }
{ "shininess" [ 100.0 glUniform1f ] }
} [ bunny-geom ] with-gl-program ;
M: bunny-cel-shaded draw-bunny
bunny-cel-shaded-program (draw-cel-shaded-bunny) ;
M: bunny-cel-shaded dispose
bunny-cel-shaded-program delete-gl-program ;

25
extra/bunny/fixed-pipeline/fixed-pipeline.factor Normal file
View File

@ -0,0 +1,25 @@
USING: alien.c-types continuations kernel
opengl opengl.gl bunny.model ;
IN: bunny.fixed-pipeline
TUPLE: bunny-fixed-pipeline ;
: <bunny-fixed-pipeline> ( gadget -- draw )
drop
{ } bunny-fixed-pipeline construct ;
M: bunny-fixed-pipeline draw-bunny
drop
GL_LIGHTING glEnable
GL_LIGHT0 glEnable
GL_COLOR_MATERIAL glEnable
GL_LIGHT0 GL_POSITION { 1.0 -1.0 1.0 1.0 } >c-float-array glLightfv
GL_FRONT_AND_BACK GL_SHININESS 100.0 glMaterialf
GL_FRONT_AND_BACK GL_SPECULAR glColorMaterial
GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE glColorMaterial
0.6 0.5 0.5 1.0 glColor4f
bunny-geom ;
M: bunny-fixed-pipeline dispose
drop ;

113
extra/bunny/model/model.factor Normal file
View File

@ -0,0 +1,113 @@
USING: alien alien.c-types arrays sequences math
math.vectors math.matrices math.parser io io.files kernel opengl
opengl.gl opengl.glu shuffle http.client vectors splitting
tools.time system combinators combinators.lib combinators.cleave
float-arrays continuations namespaces ;
IN: bunny.model
: numbers ( str -- seq )
" " split [ string>number ] map [ ] subset ;
: (parse-model) ( vs is -- vs is )
readln [
numbers {
{ [ dup length 5 = ] [ 3 head pick push ] }
{ [ dup first 3 = ] [ 1 tail over push ] }
{ [ t ] [ drop ] }
} cond (parse-model)
] when* ;
: parse-model ( stream -- vs is )
[
100000 <vector> 100000 <vector> (parse-model)
] with-stream
[
over length # " vertices, " %
dup length # " triangles" %
] "" make print ;
: n ( vs triple -- n )
swap [ nth ] curry map
dup third over first v- >r dup second swap first v- r> cross
vneg normalize ;
: normal ( ns vs triple -- )
[ n ] keep [ rot [ v+ ] change-nth ] each-with2 ;
: normals ( vs is -- ns )
over length { 0.0 0.0 0.0 } <array> -rot
[ >r 2dup r> normal ] each drop
[ normalize ] map ;
: read-model ( stream -- model )
"Reading model" print flush [
<file-reader> parse-model [ normals ] 2keep 3array
] time ;
: model-path "bun_zipper.ply" ;
: model-url "http://factorcode.org/bun_zipper.ply" ;
: maybe-download ( -- path )
model-path resource-path dup exists? [
"Downloading bunny from " write
model-url dup print flush
over download-to
] unless ;
: (draw-triangle) ( ns vs triple -- )
[ dup roll nth gl-normal swap nth gl-vertex ] each-with2 ;
: draw-triangles ( ns vs is -- )
GL_TRIANGLES [ [ (draw-triangle) ] each-with2 ] do-state ;
TUPLE: bunny-dlist list ;
TUPLE: bunny-buffers array element-array nv ni ;
: <bunny-dlist> ( model -- geom )
GL_COMPILE [ first3 draw-triangles ] make-dlist
bunny-dlist construct-boa ;
: <bunny-buffers> ( model -- geom )
[
[ first concat ] [ second concat ] bi
append >float-array
GL_ARRAY_BUFFER swap GL_STATIC_DRAW <gl-buffer>
] [
third concat >c-uint-array
GL_ELEMENT_ARRAY_BUFFER swap GL_STATIC_DRAW <gl-buffer>
]
[ first length 3 * ] [ third length 3 * ] tetra
bunny-buffers construct-boa ;
GENERIC: bunny-geom ( geom -- )
GENERIC: draw-bunny ( geom draw -- )
M: bunny-dlist bunny-geom
bunny-dlist-list glCallList ;
M: bunny-buffers bunny-geom
dup {
bunny-buffers-array
bunny-buffers-element-array
} get-slots [
GL_VERTEX_ARRAY GL_NORMAL_ARRAY 2array [
GL_DOUBLE 0 0 buffer-offset glNormalPointer
dup bunny-buffers-nv "double" heap-size * buffer-offset
3 GL_DOUBLE 0 roll glVertexPointer
bunny-buffers-ni
GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements
] all-enabled-client-state
] with-array-element-buffers ;
M: bunny-dlist dispose
bunny-dlist-list delete-dlist ;
M: bunny-buffers dispose
{ bunny-buffers-array bunny-buffers-element-array } get-slots
delete-gl-buffer delete-gl-buffer ;
: <bunny-geom> ( model -- geom )
"1.5" { "GL_ARB_vertex_buffer_object" }
has-gl-version-or-extensions?
[ <bunny-buffers> ] [ <bunny-dlist> ] if ;

239
extra/bunny/outlined/outlined.factor Normal file
View File

@ -0,0 +1,239 @@
USING: arrays bunny.model bunny.cel-shaded
combinators.lib continuations kernel math multiline
opengl opengl.gl sequences ui.gadgets ;
IN: bunny.outlined
STRING: outlined-pass1-fragment-shader-main-source
varying vec3 normal;
vec4 cel_light();
void
main()
{
gl_FragData[0] = cel_light();
gl_FragData[1] = vec4(normal, 1);
}
;
STRING: outlined-pass2-vertex-shader-source
varying vec2 coord;
void
main()
{
gl_Position = ftransform();
coord = (gl_Vertex * vec4(0.5) + vec4(0.5)).xy;
}
;
STRING: outlined-pass2-fragment-shader-source
uniform sampler2D colormap, normalmap, depthmap;
uniform vec4 line_color;
varying vec2 coord;
const float DEPTH_RATIO_THRESHOLD = 1.001, SAMPLE_SPREAD = 1.0/512.0;
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);
vec3 normal1 = normal_sample(coord1),
normal2 = normal_sample(coord2),
normal3 = normal_sample(coord3),
normal4 = normal_sample(coord4);
if (dot(normal1, normal1) < 0.5
&& dot(normal2, normal2) < 0.5
&& dot(normal3, normal3) < 0.5
&& dot(normal4, normal4) < 0.5) {
return 0.0;
} else {
vec4 depths = vec4(depth_sample(coord1),
depth_sample(coord2),
depth_sample(coord3),
depth_sample(coord4));
vec3 ratios1 = depths.xxx/depths.yzw, ratios2 = depths.yyz/depths.zww;
if (are_depths_border(ratios1) || are_depths_border(ratios2)) {
return 1.0;
} else {
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));
}
;
TUPLE: bunny-outlined
gadget
pass1-program pass2-program
color-texture normal-texture depth-texture
framebuffer framebuffer-dim ;
: outlining-supported? ( -- ? )
"2.0" {
"GL_ARB_shading_objects"
"GL_ARB_draw_buffers"
"GL_ARB_multitexture"
} has-gl-version-or-extensions? {
"GL_EXT_framebuffer_object"
"GL_ARB_texture_float"
} has-gl-extensions? and ;
: pass1-program ( -- program )
vertex-shader-source <vertex-shader> check-gl-shader
cel-shaded-fragment-shader-lib-source <fragment-shader> check-gl-shader
outlined-pass1-fragment-shader-main-source <fragment-shader> check-gl-shader
3array <gl-program> check-gl-program ;
: pass2-program ( -- program )
outlined-pass2-vertex-shader-source
outlined-pass2-fragment-shader-source <simple-gl-program> ;
: <bunny-outlined> ( gadget -- draw )
outlining-supported? [
pass1-program pass2-program {
set-bunny-outlined-gadget
set-bunny-outlined-pass1-program
set-bunny-outlined-pass2-program
} bunny-outlined construct
] [ drop f ] if ;
: (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 ;
: (attach-framebuffer-texture) ( texture attachment -- )
swap >r >r
GL_FRAMEBUFFER_EXT r> GL_TEXTURE_2D r> 0 glFramebufferTexture2DEXT
gl-error ;
: (make-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 ;
: dispose-framebuffer ( draw -- )
dup bunny-outlined-framebuffer-dim [
{
[ bunny-outlined-framebuffer [ delete-framebuffer ] when* ]
[ bunny-outlined-color-texture [ delete-texture ] when* ]
[ bunny-outlined-normal-texture [ delete-texture ] when* ]
[ bunny-outlined-depth-texture [ delete-texture ] when* ]
[ f swap set-bunny-outlined-framebuffer-dim ]
} call-with
] [ drop ] if ;
: remake-framebuffer-if-needed ( draw -- )
dup bunny-outlined-gadget rect-dim
over bunny-outlined-framebuffer-dim
over =
[ 2drop ]
[
swap dup dispose-framebuffer >r
dup GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
swap dup GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
swap dup GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT (framebuffer-texture)
swap >r
[ (make-framebuffer) ] 3keep
r> r> {
set-bunny-outlined-framebuffer
set-bunny-outlined-color-texture
set-bunny-outlined-normal-texture
set-bunny-outlined-depth-texture
set-bunny-outlined-framebuffer-dim
} set-slots
] if ;
: clear-framebuffer ( -- )
GL_COLOR_ATTACHMENT0_EXT glDrawBuffer
0.15 0.15 0.15 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 ;
: (pass1) ( geom draw -- )
dup bunny-outlined-framebuffer [
clear-framebuffer
{ GL_COLOR_ATTACHMENT0_EXT GL_COLOR_ATTACHMENT1_EXT } set-draw-buffers
bunny-outlined-pass1-program (draw-cel-shaded-bunny)
] with-framebuffer ;
: (pass2) ( draw -- )
init-matrices
dup bunny-outlined-color-texture GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit
dup bunny-outlined-normal-texture GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit
dup bunny-outlined-depth-texture GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit
bunny-outlined-pass2-program {
{ "colormap" [ 0 glUniform1i ] }
{ "normalmap" [ 1 glUniform1i ] }
{ "depthmap" [ 2 glUniform1i ] }
{ "line_color" [ 0.1 0.0 0.1 1.0 glUniform4f ] }
} [ { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ] with-gl-program ;
M: bunny-outlined draw-bunny
dup remake-framebuffer-if-needed
[ (pass1) ] keep (pass2) ;
M: bunny-outlined dispose
{
[ bunny-outlined-pass1-program [ delete-gl-program ] when* ]
[ bunny-outlined-pass2-program [ delete-gl-program ] when* ]
[ dispose-framebuffer ]
} call-with ;

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

@ -1,89 +0,0 @@
USING: arrays bunny combinators.lib io io.files kernel
math math.functions multiline continuations debugger
opengl opengl.gl opengl-demo-support
sequences ui ui.gadgets ui.render ;
IN: cel-shading
TUPLE: cel-shading-gadget model program ;
: <cel-shading-gadget> ( -- cel-shading-gadget )
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;
void
main()
{
gl_Position = ftransform();
position = gl_Vertex.xyz;
normal = gl_Normal;
}
;
STRING: cel-shading-fragment-shader-source
varying vec3 position, normal;
uniform vec3 light_direction;
uniform vec4 color;
uniform vec4 ambient, diffuse;
float
smooth_modulate(vec3 direction, vec3 normal)
{
return clamp(dot(direction, normal), 0.0, 1.0);
}
float
modulate(vec3 direction, vec3 normal)
{
float m = smooth_modulate(direction, normal);
return smoothstep(0.0, 0.01, m) * 0.4 + smoothstep(0.49, 0.5, m) * 0.5;
}
void
main()
{
vec3 direction = normalize(light_direction - position);
gl_FragColor = ambient + diffuse * color * vec4(vec3(modulate(direction, normal)), 1);
}
;
: cel-shading-program ( -- 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
cel-shading-program swap set-cel-shading-gadget-program ] [ ] [ :c ] cleanup ;
M: cel-shading-gadget ungraft* ( gadget -- )
cel-shading-gadget-program [ delete-gl-program ] when* ;
: cel-shading-draw-setup ( gadget -- gadget )
[ 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 [
cel-shading-draw-setup
0.0 -0.12 0.0 glTranslatef
cel-shading-gadget-model first3 draw-bunny
] with-gl-program ;
: cel-shading-window ( -- )
[ <cel-shading-gadget> "Cel Shading" open-window ] with-ui ;
MAIN: cel-shading-window

15
extra/cocoa/views/views.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2006, 2007 Slava Pestov ! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types arrays kernel math namespaces cocoa USING: alien.c-types arrays kernel math namespaces cocoa
cocoa.messages cocoa.classes cocoa.types sequences ; cocoa.messages cocoa.classes cocoa.types sequences
continuations ;
IN: cocoa.views IN: cocoa.views
: NSOpenGLPFAAllRenderers 1 ; : NSOpenGLPFAAllRenderers 1 ;
@ -35,11 +36,23 @@ IN: cocoa.views
: NSOpenGLPFAPixelBuffer 90 ; : NSOpenGLPFAPixelBuffer 90 ;
: NSOpenGLPFAVirtualScreenCount 128 ; : NSOpenGLPFAVirtualScreenCount 128 ;
<PRIVATE
SYMBOL: +software-renderer+
PRIVATE>
: with-software-renderer ( quot -- )
t +software-renderer+ set
[ f +software-renderer+ set ]
[ ] cleanup ; inline
: <PixelFormat> ( -- pixelfmt ) : <PixelFormat> ( -- pixelfmt )
NSOpenGLPixelFormat -> alloc [ NSOpenGLPixelFormat -> alloc [
NSOpenGLPFAWindow , NSOpenGLPFAWindow ,
NSOpenGLPFADoubleBuffer , NSOpenGLPFADoubleBuffer ,
NSOpenGLPFADepthSize , 16 , NSOpenGLPFADepthSize , 16 ,
+software-renderer+ get [ NSOpenGLPFARobust , ] when
0 , 0 ,
] { } make >c-int-array ] { } make >c-int-array
-> initWithAttributes: -> initWithAttributes:

4
extra/io/unix/launcher/launcher.factor
View File

@ -57,8 +57,8 @@ MEMO: 'arguments' ( -- parser )
: setup-redirection ( -- ) : setup-redirection ( -- )
+stdin+ get read-flags 0 redirect +stdin+ get read-flags 0 redirect
+stdout+ get write-flags 1 redirect +stdout+ get write-flags 1 redirect
+stderr+ get dup +stdout+ get eq? +stderr+ get dup +stdout+ eq?
[ 1 2 dup2 ] [ write-flags 2 redirect ] if ; [ drop 1 2 dup2 io-error ] [ write-flags 2 redirect ] if ;
: spawn-process ( -- ) : spawn-process ( -- )
[ [

255
extra/line-art/line-art.factor
View File

@ -1,255 +0,0 @@
USING: arrays bunny combinators.lib continuations io io.files kernel
math math.functions math.vectors multiline
namespaces debugger
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"
"GL_ARB_texture_float" }
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
] [ ] [ :c ] cleanup ;
M: line-art-gadget ungraft* ( gadget -- )
dup line-art-gadget-framebuffer [
{ [ line-art-gadget-step1-program [ delete-gl-program ] when* ]
[ line-art-gadget-step2-program [ delete-gl-program ] when* ]
[ line-art-gadget-framebuffer [ delete-framebuffer ] when* ]
[ line-art-gadget-color-texture [ delete-texture ] when* ]
[ line-art-gadget-normal-texture [ delete-texture ] when* ]
[ line-art-gadget-depth-texture [ delete-texture ] when* ]
[ 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
extra/opengl-demo-support/authors.txt → extra/opengl/demo-support/authors.txt
View File

2
extra/opengl-demo-support/opengl-demo-support.factor → extra/opengl/demo-support/demo-support.factor
View File

@ -1,6 +1,6 @@
USING: arrays combinators.lib kernel math math.functions math.vectors namespaces USING: arrays combinators.lib kernel math math.functions math.vectors namespaces
opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render ; opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render ;
IN: opengl-demo-support IN: opengl.demo-support
: NEAR-PLANE 1.0 64.0 / ; inline : NEAR-PLANE 1.0 64.0 / ; inline
: FAR-PLANE 4.0 ; inline : FAR-PLANE 4.0 ; inline

0
extra/opengl-demo-support/summary.txt → extra/opengl/demo-support/summary.txt
View File

0
extra/opengl-demo-support/tags.txt → extra/opengl/demo-support/tags.txt
View File

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

@ -1,5 +1,5 @@
USING: help.markup help.syntax io kernel math quotations USING: help.markup help.syntax io kernel math quotations
opengl.gl ; opengl.gl multiline assocs ;
IN: opengl IN: opengl
HELP: gl-color HELP: gl-color
@ -65,7 +65,7 @@ HELP: gen-renderbuffer
{ $values { "id" integer } } { $values { "id" integer } }
{ $description "Wrapper for " { $link glGenRenderbuffersEXT } " to handle the common case of generating a single render buffer ID." } ; { $description "Wrapper for " { $link glGenRenderbuffersEXT } " to handle the common case of generating a single render buffer ID." } ;
HELP: gen-buffer HELP: gen-gl-buffer
{ $values { "id" integer } } { $values { "id" integer } }
{ $description "Wrapper for " { $link glGenBuffers } " to handle the common case of generating a single buffer ID." } ; { $description "Wrapper for " { $link glGenBuffers } " to handle the common case of generating a single buffer ID." } ;
@ -81,14 +81,14 @@ HELP: delete-renderbuffer
{ $values { "id" integer } } { $values { "id" integer } }
{ $description "Wrapper for " { $link glDeleteRenderbuffersEXT } " to handle the common case of deleting a single render buffer ID." } ; { $description "Wrapper for " { $link glDeleteRenderbuffersEXT } " to handle the common case of deleting a single render buffer ID." } ;
HELP: delete-buffer HELP: delete-gl-buffer
{ $values { "id" integer } } { $values { "id" integer } }
{ $description "Wrapper for " { $link glDeleteBuffers } " to handle the common case of deleting a single buffer ID." } ; { $description "Wrapper for " { $link glDeleteBuffers } " to handle the common case of deleting a single buffer ID." } ;
{ gen-texture delete-texture } related-words { gen-texture delete-texture } related-words
{ gen-framebuffer delete-framebuffer } related-words { gen-framebuffer delete-framebuffer } related-words
{ gen-renderbuffer delete-renderbuffer } related-words { gen-renderbuffer delete-renderbuffer } related-words
{ gen-buffer delete-buffer } related-words { gen-gl-buffer delete-gl-buffer } related-words
HELP: framebuffer-incomplete? HELP: framebuffer-incomplete?
{ $values { "status/f" "The framebuffer error code, or " { $snippet "f" } " if the framebuffer is render-complete." } } { $values { "status/f" "The framebuffer error code, or " { $snippet "f" } " if the framebuffer is render-complete." } }
@ -241,8 +241,19 @@ HELP: delete-gl-program
{ $description "Deletes the program object, invalidating it and releasing any resources allocated for it by the OpenGL implementation. Any attached " { $link gl-shader } "s are also deleted.\n\nIf the shader objects should be preserved, they should each be detached using " { $link detach-gl-program-shader } ". The program object can then be destroyed alone using " { $link delete-gl-program-only } "." } ; { $description "Deletes the program object, invalidating it and releasing any resources allocated for it by the OpenGL implementation. Any attached " { $link gl-shader } "s are also deleted.\n\nIf the shader objects should be preserved, they should each be detached using " { $link detach-gl-program-shader } ". The program object can then be destroyed alone using " { $link delete-gl-program-only } "." } ;
HELP: with-gl-program HELP: with-gl-program
{ $values { "program" "A " { $link gl-program } " object" } { "quot" "A quotation" } } { $values { "program" "A " { $link gl-program } " object" } { "uniforms" "An " { $link assoc } " between uniform parameter names and quotations with effect " { $snippet "( uniform-location -- )" } } { "quot" "A quotation" } }
{ $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" } "." } ; { $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" } ". Before calling " { $snippet "quot" } ", calls " { $link glGetUniformLocation } " on each key of " { $snippet "uniforms" } " to get the address of the uniform parameter, which is then placed on top of the stack for the associated quotation.\n\nExample:" }
{ $code <"
! From bunny.cel-shaded
: (draw-cel-shaded-bunny) ( geom program -- )
{
{ "light_direction" [ 1.0 -1.0 1.0 glUniform3f ] }
{ "color" [ 0.6 0.5 0.5 1.0 glUniform4f ] }
{ "ambient" [ 0.2 0.2 0.2 0.2 glUniform4f ] }
{ "diffuse" [ 0.8 0.8 0.8 0.8 glUniform4f ] }
{ "shininess" [ 100.0 glUniform1f ] }
} [ bunny-geom ] with-gl-program ;
"> } ;
HELP: gl-version HELP: gl-version
{ $values { "version" "The version string from the OpenGL implementation" } } { $values { "version" "The version string from the OpenGL implementation" } }
@ -284,15 +295,19 @@ HELP: has-gl-extensions?
{ $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } } { $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 } "." } ; { $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } "." } ;
HELP: has-gl-version-or-extensions?
{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } }
{ $description "Returns true if either " { $link has-gl-version? } " or " { $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." } ;
HELP: require-gl-extensions HELP: require-gl-extensions
{ $values { "extensions" "A sequence of extension name strings" } } { $values { "extensions" "A sequence of extension name strings" } }
{ $description "Throws an exception if " { $link has-gl-extensions? } " returns false for " { $snippet "extensions" } "." } ; { $description "Throws an exception if " { $link has-gl-extensions? } " returns false for " { $snippet "extensions" } "." } ;
HELP: require-gl-version-or-extensions HELP: require-gl-version-or-extensions
{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } } { $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." } ; { $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 { require-gl-version require-glsl-version require-gl-extensions require-gl-version-or-extensions has-gl-version? has-glsl-version? has-gl-extensions? has-gl-version-or-extensions? gl-version glsl-version gl-extensions } related-words
ARTICLE: "gl-utilities" "OpenGL utility 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." "In addition to the full OpenGL API, the " { $vocab-link "opengl" } " vocabulary includes some utility words to give OpenGL a more Factor-like feel."

76
extra/opengl/opengl.factor
View File

@ -5,7 +5,7 @@
USING: alien alien.c-types continuations kernel libc math macros USING: alien alien.c-types continuations kernel libc math macros
namespaces math.vectors math.constants math.functions namespaces math.vectors math.constants math.functions
math.parser opengl.gl opengl.glu combinators arrays sequences math.parser opengl.gl opengl.glu combinators arrays sequences
splitting words byte-arrays assocs ; splitting words byte-arrays assocs combinators.lib ;
IN: opengl IN: opengl
: coordinates [ first2 ] 2apply ; : coordinates [ first2 ] 2apply ;
@ -30,6 +30,13 @@ IN: opengl
: do-enabled ( what quot -- ) : do-enabled ( what quot -- )
over glEnable dip glDisable ; inline over glEnable dip glDisable ; inline
: do-enabled-client-state ( what quot -- )
over glEnableClientState dip glDisableClientState ; inline
: all-enabled ( seq quot -- )
over [ glEnable ] each dip [ glDisable ] each ; inline
: all-enabled-client-state ( seq quot -- )
over [ glEnableClientState ] each dip [ glDisableClientState ] each ; inline
: do-matrix ( mode quot -- ) : do-matrix ( mode quot -- )
swap [ glMatrixMode glPushMatrix call ] keep swap [ glMatrixMode glPushMatrix call ] keep
@ -103,7 +110,7 @@ IN: opengl
[ glGenFramebuffersEXT ] (gen-gl-object) ; [ glGenFramebuffersEXT ] (gen-gl-object) ;
: gen-renderbuffer ( -- id ) : gen-renderbuffer ( -- id )
[ glGenRenderbuffersEXT ] (gen-gl-object) ; [ glGenRenderbuffersEXT ] (gen-gl-object) ;
: gen-buffer ( -- id ) : gen-gl-buffer ( -- id )
[ glGenBuffers ] (gen-gl-object) ; [ glGenBuffers ] (gen-gl-object) ;
: (delete-gl-object) ( id quot -- ) : (delete-gl-object) ( id quot -- )
@ -114,9 +121,26 @@ IN: opengl
[ glDeleteFramebuffersEXT ] (delete-gl-object) ; [ glDeleteFramebuffersEXT ] (delete-gl-object) ;
: delete-renderbuffer ( id -- ) : delete-renderbuffer ( id -- )
[ glDeleteRenderbuffersEXT ] (delete-gl-object) ; [ glDeleteRenderbuffersEXT ] (delete-gl-object) ;
: delete-buffer ( id -- ) : delete-gl-buffer ( id -- )
[ glDeleteBuffers ] (delete-gl-object) ; [ glDeleteBuffers ] (delete-gl-object) ;
: with-gl-buffer ( binding id quot -- )
-rot dupd glBindBuffer
[ slip ] [ 0 glBindBuffer ] [ ] cleanup ; inline
: with-array-element-buffers ( array-buffer element-buffer quot -- )
-rot GL_ELEMENT_ARRAY_BUFFER swap [
swap GL_ARRAY_BUFFER -rot with-gl-buffer
] with-gl-buffer ; inline
: <gl-buffer> ( target data hint -- id )
pick gen-gl-buffer [ [
>r dup byte-length swap r> glBufferData
] with-gl-buffer ] keep ;
: buffer-offset ( int -- alien )
<alien> ; inline
: framebuffer-incomplete? ( -- status/f ) : framebuffer-incomplete? ( -- status/f )
GL_FRAMEBUFFER_EXT glCheckFramebufferStatusEXT GL_FRAMEBUFFER_EXT glCheckFramebufferStatusEXT
dup GL_FRAMEBUFFER_COMPLETE_EXT = f rot ? ; dup GL_FRAMEBUFFER_COMPLETE_EXT = f rot ? ;
@ -256,7 +280,7 @@ TUPLE: sprite loc dim dim2 dlist texture ;
: c-true? ( int -- ? ) zero? not ; inline : c-true? ( int -- ? ) zero? not ; inline
: with-gl-shader-source-ptr ( string quot -- ) : with-gl-shader-source-ptr ( string quot -- )
swap >byte-array malloc-byte-array [ swap string>char-alien malloc-byte-array [
<void*> swap call <void*> swap call
] keep free ; inline ] keep free ; inline
@ -295,9 +319,8 @@ TUPLE: sprite loc dim dim2 dlist texture ;
GL_INFO_LOG_LENGTH gl-shader-get-int ; inline GL_INFO_LOG_LENGTH gl-shader-get-int ; inline
: gl-shader-info-log ( shader -- log ) : gl-shader-info-log ( shader -- log )
dup gl-shader-info-log-length dup gl-shader-info-log-length dup [
dup [ [ 0 <int> swap glGetShaderInfoLog ] keep
0 <int> over glGetShaderInfoLog
alien>char-string alien>char-string
] with-malloc ; ] with-malloc ;
@ -331,9 +354,10 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
GL_INFO_LOG_LENGTH gl-program-get-int ; inline GL_INFO_LOG_LENGTH gl-program-get-int ; inline
: gl-program-info-log ( program -- log ) : gl-program-info-log ( program -- log )
dup gl-program-info-log-length dup gl-program-info-log-length dup [
dup [ [ 0 <int> swap glGetProgramInfoLog ] keep [ 0 <int> swap glGetProgramInfoLog ] keep
alien>char-string ] with-malloc ; alien>char-string
] with-malloc ;
: check-gl-program ( program -- program* ) : check-gl-program ( program -- program* )
dup gl-program-ok? [ dup gl-program-info-log throw ] unless ; dup gl-program-ok? [ dup gl-program-info-log throw ] unless ;
@ -343,7 +367,8 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
: gl-program-shaders ( program -- shaders ) : gl-program-shaders ( program -- shaders )
dup gl-program-shaders-length [ dup gl-program-shaders-length [
dup "GLuint" <c-array> 0 <int> over glGetAttachedShaders dup "GLuint" <c-array>
[ 0 <int> swap glGetAttachedShaders ] keep
] keep c-uint-array> ; ] keep c-uint-array> ;
: delete-gl-program-only ( program -- ) : delete-gl-program-only ( program -- )
@ -357,9 +382,23 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
2dup detach-gl-program-shader delete-gl-shader 2dup detach-gl-program-shader delete-gl-shader
] each delete-gl-program-only ; ] each delete-gl-program-only ;
: with-gl-program ( program quot -- ) : (with-gl-program) ( program quot -- )
swap glUseProgram [ 0 glUseProgram ] [ ] cleanup ; inline swap glUseProgram [ 0 glUseProgram ] [ ] cleanup ; inline
: (with-gl-program-uniforms) ( uniforms -- quot )
[ [ swap , \ glGetUniformLocation , % ] [ ] make ]
{ } assoc>map ;
: (make-with-gl-program) ( uniforms quot -- q )
[
\ dup ,
[ swap (with-gl-program-uniforms) , \ call-with , % ]
[ ] make ,
\ (with-gl-program) ,
] [ ] make ;
MACRO: with-gl-program ( uniforms quot -- )
(make-with-gl-program) ;
PREDICATE: integer gl-program (gl-program?) ; PREDICATE: integer gl-program (gl-program?) ;
: <simple-gl-program> ( vertex-shader-source fragment-shader-source -- program ) : <simple-gl-program> ( vertex-shader-source fragment-shader-source -- program )
@ -376,7 +415,7 @@ PREDICATE: integer gl-program (gl-program?) ;
: gl-extensions ( -- seq ) : gl-extensions ( -- seq )
GL_EXTENSIONS glGetString " " split ; GL_EXTENSIONS glGetString " " split ;
: has-gl-extensions? ( extensions -- ? ) : has-gl-extensions? ( extensions -- ? )
gl-extensions subseq? ; gl-extensions swap [ over member? ] all? nip ;
: (make-gl-extensions-error) ( required-extensions -- ) : (make-gl-extensions-error) ( required-extensions -- )
gl-extensions swap seq-diff gl-extensions swap seq-diff
"Required OpenGL extensions not supported:\n" % "Required OpenGL extensions not supported:\n" %
@ -420,8 +459,11 @@ PREDICATE: integer gl-program (gl-program?) ;
[ "Required GLSL version " % % " not supported (" % glsl-version % " available)" % ] [ "Required GLSL version " % % " not supported (" % glsl-version % " available)" % ]
(require-gl) ; (require-gl) ;
: has-gl-version-or-extensions? ( version extensions -- ? )
has-gl-extensions? swap has-gl-version? or ;
: require-gl-version-or-extensions ( version extensions -- ) : require-gl-version-or-extensions ( version extensions -- )
2array [ first2 has-gl-extensions? swap has-gl-version? or ] 2array [ first2 has-gl-version-or-extensions? ] [
[ dup first (make-gl-version-error) "\n" % dup first (make-gl-version-error) "\n" %
second (make-gl-extensions-error) "\n" % ] second (make-gl-extensions-error) "\n" %
(require-gl) ; ] (require-gl) ;

26
extra/partial-apply/partial-apply.factor Normal file
View File

@ -0,0 +1,26 @@
USING: kernel sequences quotations math parser
shuffle combinators.cleave combinators.lib sequences.lib ;
IN: partial-apply
! Basic conceptual implementation. Todo: get it to compile.
: apply-n ( obj quot i -- quot ) 1+ [ -nrot ] curry swap compose curry ;
SYMBOL: _
SYMBOL: ~
: blank-positions ( quot -- seq )
[ length 2 - ] [ _ indices ] bi [ - ] map-with ;
: partial-apply ( pattern -- quot )
[ blank-positions length nrev ]
[ peek 1quotation ]
[ blank-positions ]
tri
[ apply-n ] each ;
: $[ \ ] [ >quotation ] parse-literal \ partial-apply parsed ; parsing

5
extra/project-euler/032/032.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2008 Aaron Schaefer. ! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib hashtables kernel math math.combinatorics math.parser USING: combinators.lib hashtables kernel math math.combinatorics math.parser
math.ranges project-euler.common sequences sorting ; math.ranges project-euler.common sequences ;
IN: project-euler.032 IN: project-euler.032
! http://projecteuler.net/index.php?section=problems&id=32 ! http://projecteuler.net/index.php?section=problems&id=32
@ -63,9 +63,6 @@ PRIVATE>
: source-032a ( -- seq ) : source-032a ( -- seq )
50 [1,b] 2000 [1,b] cartesian-product ; 50 [1,b] 2000 [1,b] cartesian-product ;
: pandigital? ( n -- ? )
number>string natural-sort "123456789" = ;
! multiplicand/multiplier/product ! multiplicand/multiplier/product
: mmp ( pair -- n ) : mmp ( pair -- n )
first2 2dup * [ number>string ] 3apply 3append 10 string>integer ; first2 2dup * [ number>string ] 3apply 3append 10 string>integer ;

52
extra/project-euler/037/037.factor Normal file
View File

@ -0,0 +1,52 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.parser math.primes sequences ;
IN: project-euler.037
! http://projecteuler.net/index.php?section=problems&id=37
! DESCRIPTION
! -----------
! The number 3797 has an interesting property. Being prime itself, it is
! possible to continuously remove digits from left to right, and remain prime
! at each stage: 3797, 797, 97, and 7. Similarly we can work from right to
! left: 3797, 379, 37, and 3.
! Find the sum of the only eleven primes that are both truncatable from left to
! right and right to left.
! NOTE: 2, 3, 5, and 7 are not considered to be truncatable primes.
! SOLUTION
! --------
<PRIVATE
: r-trunc? ( n -- ? )
10 /i dup 0 > [
dup prime? [ r-trunc? ] [ drop f ] if
] [
drop t
] if ;
: reverse-digits ( n -- m )
number>string reverse 10 string>integer ;
: l-trunc? ( n -- ? )
reverse-digits 10 /i reverse-digits dup 0 > [
dup prime? [ l-trunc? ] [ drop f ] if
] [
drop t
] if ;
PRIVATE>
: euler037 ( -- answer )
23 1000000 primes-between [ r-trunc? ] subset [ l-trunc? ] subset sum ;
! [ euler037 ] 100 ave-time
! 768 ms run / 9 ms GC ave time - 100 trials
MAIN: euler037

55
extra/project-euler/038/038.factor Normal file
View File

@ -0,0 +1,55 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.parser math.ranges project-euler.common sequences ;
IN: project-euler.038
! http://projecteuler.net/index.php?section=problems&id=38
! DESCRIPTION
! -----------
! Take the number 192 and multiply it by each of 1, 2, and 3:
! 192 × 1 = 192
! 192 × 2 = 384
! 192 × 3 = 576
! By concatenating each product we get the 1 to 9 pandigital, 192384576. We
! will call 192384576 the concatenated product of 192 and (1,2,3)
! The same can be achieved by starting with 9 and multiplying by 1, 2, 3, 4,
! and 5, giving the pandigital, 918273645, which is the concatenated product of
! 9 and (1,2,3,4,5).
! What is the largest 1 to 9 pandigital 9-digit number that can be formed as
! the concatenated product of an integer with (1,2, ... , n) where n > 1?
! SOLUTION
! --------
! Only need to search 4-digit numbers starting with 9 since a 2-digit number
! starting with 9 would produce 8 or 11 digits, and a 3-digit number starting
! with 9 would produce 7 or 11 digits.
<PRIVATE
: (concat-product) ( accum n multiplier -- m )
pick length 8 > [
2drop 10 swap digits>integer
] [
[ * number>digits over push-all ] 2keep 1+ (concat-product)
] if ;
: concat-product ( n -- m )
V{ } clone swap 1 (concat-product) ;
PRIVATE>
: euler038 ( -- answer )
9123 9876 [a,b] [ concat-product ] map [ pandigital? ] subset supremum ;
! [ euler038 ] 100 ave-time
! 37 ms run / 1 ms GC ave time - 100 trials
MAIN: euler038

65
extra/project-euler/039/039.factor Normal file
View File

@ -0,0 +1,65 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators.lib kernel math math.ranges namespaces
project-euler.common sequences ;
IN: project-euler.039
! http://projecteuler.net/index.php?section=problems&id=39
! DESCRIPTION
! -----------
! If p is the perimeter of a right angle triangle with integral length sides,
! {a,b,c}, there are exactly three solutions for p = 120.
! {20,48,52}, {24,45,51}, {30,40,50}
! For which value of p < 1000, is the number of solutions maximised?
! SOLUTION
! --------
! Algorithm adapted from http://mathworld.wolfram.com/PythagoreanTriple.html
! Identical implementation as problem #75
! Basically, this makes an array of 1000 zeros, recursively creates primitive
! triples using the three transforms and then increments the array at index
! [a+b+c] by one for each triple's sum AND its multiples under 1000 (to account
! for non-primitive triples). The answer is just the index that has the highest
! number.
SYMBOL: p-count
<PRIVATE
: max-p ( -- n )
p-count get length ;
: adjust-p-count ( n -- )
max-p 1- over <range> p-count get
[ [ 1+ ] change-nth ] curry each ;
: (count-perimeters) ( seq -- )
dup sum max-p < [
dup sum adjust-p-count
[ u-transform ] keep [ a-transform ] keep d-transform
[ (count-perimeters) ] 3apply
] [
drop
] if ;
: count-perimeters ( n -- )
0 <array> p-count set { 3 4 5 } (count-perimeters) ;
PRIVATE>
: euler039 ( -- answer )
[
1000 count-perimeters p-count get [ supremum ] keep index
] with-scope ;
! [ euler039 ] 100 ave-time
! 2 ms run / 0 ms GC ave time - 100 trials
MAIN: euler039

51
extra/project-euler/040/040.factor Normal file
View File

@ -0,0 +1,51 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.parser sequences strings ;
IN: project-euler.040
! http://projecteuler.net/index.php?section=problems&id=40
! DESCRIPTION
! -----------
! An irrational decimal fraction is created by concatenating the positive
! integers:
! 0.123456789101112131415161718192021...
! It can be seen that the 12th digit of the fractional part is 1.
! If dn represents the nth digit of the fractional part, find the value of the
! following expression.
! d1 × d10 × d100 × d1000 × d10000 × d100000 × d1000000
! SOLUTION
! --------
<PRIVATE
: (concat-upto) ( n limit str -- str )
2dup length > [
pick number>string over push-all rot 1+ -rot (concat-upto)
] [
2nip
] if ;
: concat-upto ( n -- str )
SBUF" " clone 1 -rot (concat-upto) ;
: nth-integer ( n str -- m )
[ 1- ] dip nth 1string 10 string>integer ;
PRIVATE>
: euler040 ( -- answer )
1000000 concat-upto { 1 10 100 1000 10000 100000 1000000 }
[ swap nth-integer ] with map product ;
! [ euler040 ] 100 ave-time
! 1002 ms run / 43 ms GC ave time - 100 trials
MAIN: euler040

78
extra/project-euler/075/075.factor Normal file
View File

@ -0,0 +1,78 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators.lib kernel math math.ranges namespaces
project-euler.common sequences ;
IN: project-euler.075
! http://projecteuler.net/index.php?section=problems&id=75
! DESCRIPTION
! -----------
! It turns out that 12 cm is the smallest length of wire can be bent to form a
! right angle triangle in exactly one way, but there are many more examples.
! 12 cm: (3,4,5)
! 24 cm: (6,8,10)
! 30 cm: (5,12,13)
! 36 cm: (9,12,15)
! 40 cm: (8,15,17)
! 48 cm: (12,16,20)
! In contrast, some lengths of wire, like 20 cm, cannot be bent to form a right
! angle triangle, and other lengths allow more than one solution to be found;
! for example, using 120 cm it is possible to form exactly three different
! right angle triangles.
! 120 cm: (30,40,50), (20,48,52), (24,45,51)
! Given that L is the length of the wire, for how many values of L ≤ 1,000,000
! can exactly one right angle triangle be formed?
! SOLUTION
! --------
! Algorithm adapted from http://mathworld.wolfram.com/PythagoreanTriple.html
! Identical implementation as problem #39
! Basically, this makes an array of 1000000 zeros, recursively creates
! primitive triples using the three transforms and then increments the array at
! index [a+b+c] by one for each triple's sum AND its multiples under 1000000
! (to account for non-primitive triples). The answer is just the total number
! of indexes that are equal to one.
SYMBOL: p-count
<PRIVATE
: max-p ( -- n )
p-count get length ;
: adjust-p-count ( n -- )
max-p 1- over <range> p-count get
[ [ 1+ ] change-nth ] curry each ;
: (count-perimeters) ( seq -- )
dup sum max-p < [
dup sum adjust-p-count
[ u-transform ] keep [ a-transform ] keep d-transform
[ (count-perimeters) ] 3apply
] [
drop
] if ;
: count-perimeters ( n -- )
0 <array> p-count set { 3 4 5 } (count-perimeters) ;
PRIVATE>
: euler075 ( -- answer )
[
1000000 count-perimeters p-count get [ 1 = ] count
] with-scope ;
! [ euler075 ] 100 ave-time
! 1873 ms run / 123 ms GC ave time - 100 trials
MAIN: euler075

20
extra/project-euler/common/common.factor
View File

@ -1,5 +1,6 @@
USING: arrays combinators.lib kernel math math.functions math.miller-rabin USING: arrays combinators.lib kernel math math.functions math.miller-rabin
math.parser math.primes.factors math.ranges namespaces sequences ; math.matrices math.parser math.primes.factors math.ranges namespaces
sequences sorting ;
IN: project-euler.common IN: project-euler.common
! A collection of words used by more than one Project Euler solution ! A collection of words used by more than one Project Euler solution
@ -12,9 +13,11 @@ IN: project-euler.common
! log10 - #25, #134 ! log10 - #25, #134
! max-path - #18, #67 ! max-path - #18, #67
! number>digits - #16, #20, #30, #34 ! number>digits - #16, #20, #30, #34
! pandigital? - #32, #38
! propagate-all - #18, #67 ! propagate-all - #18, #67
! sum-proper-divisors - #21 ! sum-proper-divisors - #21
! tau* - #12 ! tau* - #12
! [uad]-transform - #39, #75
: nth-pair ( n seq -- nth next ) : nth-pair ( n seq -- nth next )
@ -44,6 +47,9 @@ IN: project-euler.common
dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if
] { } make sum ; ] { } make sum ;
: transform ( triple matrix -- new-triple )
[ 1array ] dip m. first ;
PRIVATE> PRIVATE>
: cartesian-product ( seq1 seq2 -- seq1xseq2 ) : cartesian-product ( seq1 seq2 -- seq1xseq2 )
@ -67,6 +73,9 @@ PRIVATE>
: number>digits ( n -- seq ) : number>digits ( n -- seq )
number>string string>digits ; number>string string>digits ;
: pandigital? ( n -- ? )
number>string natural-sort "123456789" = ;
! Not strictly needed, but it is nice to be able to dump the triangle after the ! Not strictly needed, but it is nice to be able to dump the triangle after the
! propagation ! propagation
: propagate-all ( triangle -- newtriangle ) : propagate-all ( triangle -- newtriangle )
@ -97,3 +106,12 @@ PRIVATE>
dup sqrt >fixnum [1,b] [ dup sqrt >fixnum [1,b] [
dupd mod zero? [ [ 2 + ] dip ] when dupd mod zero? [ [ 2 + ] dip ] when
] each drop * ; ] each drop * ;
! These transforms are for generating primitive Pythagorean triples
: u-transform ( triple -- new-triple )
{ { 1 2 2 } { -2 -1 -2 } { 2 2 3 } } transform ;
: a-transform ( triple -- new-triple )
{ { 1 2 2 } { 2 1 2 } { 2 2 3 } } transform ;
: d-transform ( triple -- new-triple )
{ { -1 -2 -2 } { 2 1 2 } { 2 2 3 } } transform ;

9
extra/project-euler/project-euler.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu. ! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: definitions io io.files kernel math.parser sequences vocabs USING: definitions io io.files kernel math math.parser project-euler.ave-time
vocabs.loader project-euler.ave-time project-euler.common math sequences vocabs vocabs.loader
project-euler.001 project-euler.002 project-euler.003 project-euler.004 project-euler.001 project-euler.002 project-euler.003 project-euler.004
project-euler.005 project-euler.006 project-euler.007 project-euler.008 project-euler.005 project-euler.006 project-euler.007 project-euler.008
project-euler.009 project-euler.010 project-euler.011 project-euler.012 project-euler.009 project-euler.010 project-euler.011 project-euler.012
@ -11,8 +11,9 @@ USING: definitions io io.files kernel math.parser sequences vocabs
project-euler.025 project-euler.026 project-euler.027 project-euler.028 project-euler.025 project-euler.026 project-euler.027 project-euler.028
project-euler.029 project-euler.030 project-euler.031 project-euler.032 project-euler.029 project-euler.030 project-euler.031 project-euler.032
project-euler.033 project-euler.034 project-euler.035 project-euler.036 project-euler.033 project-euler.034 project-euler.035 project-euler.036
project-euler.067 project-euler.134 project-euler.169 project-euler.173 project-euler.037 project-euler.038 project-euler.039 project-euler.040
project-euler.175 ; project-euler.067 project-euler.075 project-euler.134 project-euler.169
project-euler.173 project-euler.175 ;
IN: project-euler IN: project-euler
<PRIVATE <PRIVATE

10
extra/sequences/lib/lib.factor
View File

@ -140,3 +140,13 @@ PRIVATE>
: ?second ( seq -- second/f ) 1 swap ?nth ; inline : ?second ( seq -- second/f ) 1 swap ?nth ; inline
: ?third ( seq -- third/f ) 2 swap ?nth ; inline : ?third ( seq -- third/f ) 2 swap ?nth ; inline
: ?fourth ( seq -- fourth/f ) 3 swap ?nth ; inline : ?fourth ( seq -- fourth/f ) 3 swap ?nth ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! List the positions of obj in seq
: indices ( seq obj -- seq )
>r dup length swap r>
[ = [ ] [ drop f ] if ] curry
2map
[ ] subset ;

5
extra/shuffle/shuffle.factor
View File

@ -30,3 +30,8 @@ MACRO: ntuck ( n -- ) 2 + [ dup , -nrot ] bake ;
: 4drop ( a b c d -- ) 3drop drop ; inline : 4drop ( a b c d -- ) 3drop drop ; inline
: tuckd ( x y z -- z x y z ) 2 ntuck ; inline : tuckd ( x y z -- z x y z ) 2 ntuck ; inline
MACRO: nrev ( n -- quot )
[ 1+ ] map
reverse
[ [ -nrot ] curry ] map concat ;

16
extra/x11/windows/windows.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov ! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types hashtables kernel math math.vectors USING: alien alien.c-types hashtables kernel math math.vectors math.bitfields
namespaces sequences x11.xlib x11.constants x11.glx ; namespaces sequences x11.xlib x11.constants x11.glx ;
IN: x11.windows IN: x11.windows
@ -12,7 +12,6 @@ IN: x11.windows
XCreateColormap ; XCreateColormap ;
: event-mask ( -- n ) : event-mask ( -- n )
<<<<<<< HEAD:extra/x11/windows/windows.factor
{ {
ExposureMask ExposureMask
StructureNotifyMask StructureNotifyMask
@ -26,19 +25,6 @@ IN: x11.windows
LeaveWindowMask LeaveWindowMask
PropertyChangeMask PropertyChangeMask
} flags ; } flags ;
=======
ExposureMask
StructureNotifyMask bitor
KeyPressMask bitor
KeyReleaseMask bitor
ButtonPressMask bitor
ButtonReleaseMask bitor
PointerMotionMask bitor
FocusChangeMask bitor
EnterWindowMask bitor
LeaveWindowMask bitor
PropertyChangeMask bitor ;
>>>>>>> a05c18152b59073c49aa313ba685516310ec74a8:extra/x11/windows/windows.factor
: window-attributes ( visinfo -- attributes ) : window-attributes ( visinfo -- attributes )
"XSetWindowAttributes" <c-object> "XSetWindowAttributes" <c-object>

22
extra/x11/xlib/xlib.factor
View File

@ -12,7 +12,7 @@
! and note the section. ! and note the section.
USING: kernel arrays alien alien.c-types alien.syntax USING: kernel arrays alien alien.c-types alien.syntax
math words sequences namespaces continuations ; math math.bitfields words sequences namespaces continuations ;
IN: x11.xlib IN: x11.xlib
LIBRARY: xlib LIBRARY: xlib
@ -1078,16 +1078,16 @@ FUNCTION: Status XWithdrawWindow (
! 17.1.7 - Setting and Reading the WM_NORMAL_HINTS Property ! 17.1.7 - Setting and Reading the WM_NORMAL_HINTS Property
: USPosition 1 0 shift ; inline : USPosition 1 0 shift ; inline
: USSize 1 1 shift ; inline : USSize 1 1 shift ; inline
: PPosition 1 2 shift ; inline : PPosition 1 2 shift ; inline
: PSize 1 3 shift ; inline : PSize 1 3 shift ; inline
: PMinSize 1 4 shift ; inline : PMinSize 1 4 shift ; inline
: PMaxSize 1 5 shift ; inline : PMaxSize 1 5 shift ; inline
: PResizeInc 1 6 shift ; inline : PResizeInc 1 6 shift ; inline
: PAspect 1 7 shift ; inline : PAspect 1 7 shift ; inline
: PBaseSize 1 8 shift ; inline : PBaseSize 1 8 shift ; inline
: PWinGravity 1 9 shift ; inline : PWinGravity 1 9 shift ; inline
: PAllHints : PAllHints
{ PPosition PSize PMinSize PMaxSize PResizeInc PAspect } flags ; foldable { PPosition PSize PMinSize PMaxSize PResizeInc PAspect } flags ; foldable

2
misc/Factor.tmbundle/Support/lib/tm_factor.rb
View File

@ -33,6 +33,6 @@ def doc_using_statements(document)
end end
def line_current_word(line, point) def line_current_word(line, point)
left = line.rindex(/\s|^/, point - 1) + 1; right = line.index(/\s|$/, point) - 1 left = line.rindex(/\s/, point - 1) || 0; right = line.index(/\s/, point) || line.length
line[left..right] line[left..right]
end end