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

Merge git://factorcode.org/git/factor 

Conflicts:

	extra/sequences/lib/lib.factor
db4
Doug Coleman 2008-02-03 16:06:36 -06:00
parent bb1e06dd8d 793c3ceb1f
commit 5459105264
47 changed files with 1099 additions and 548 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." }
{ $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
{ $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." }

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

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

2
core/definitions/definitions-tests.factor
View File

@ -11,7 +11,7 @@ SYMBOL: generic-1
[
generic-1 T{ combination-1 } define-generic
[ ] <method> object \ generic-1 define-method
[ ] object \ generic-1 define-method
] with-compilation-unit
[ ] [

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

@ -32,7 +32,7 @@ HELP: <float-array> ( n initial -- float-array )
HELP: >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." } ;
HELP: 1float-array

4
core/generic/generic-docs.factor
View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax generic.math generic.standard
words classes definitions kernel alien combinators sequences
math ;
math quotations ;
IN: generic
ARTICLE: "method-order" "Method precedence"
@ -154,7 +154,7 @@ HELP: with-methods
$low-level-note ;
HELP: define-method
{ $values { "method" "an instance of " { $link method } } { "class" class } { "generic" generic } }
{ $values { "method" quotation } { "class" class } { "generic" generic } }
{ $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ;
HELP: implementors

14
core/generic/generic.factor
View File

@ -39,11 +39,6 @@ TUPLE: method loc def ;
: <method> ( def -- method )
{ set-method-def } \ method construct ;
M: f method-def ;
M: f method-loc ;
M: quotation method-def ;
M: quotation method-loc drop f ;
: method ( class generic -- method/f )
"methods" word-prop at ;
@ -55,7 +50,7 @@ PREDICATE: pair method-spec
: sort-methods ( assoc -- newassoc )
[ keys sort-classes ] keep
[ dupd at method-def 2array ] curry map ;
[ dupd at method-def ] curry { } map>assoc ;
: methods ( word -- assoc )
"methods" word-prop sort-methods ;
@ -72,18 +67,19 @@ TUPLE: check-method class generic ;
inline
: define-method ( method class generic -- )
>r bootstrap-word r> check-method
>r >r <method> r> bootstrap-word r> check-method
[ set-at ] with-methods ;
! Definition protocol
M: method-spec where
dup first2 method method-loc [ ] [ second where ] ?if ;
dup first2 method [ method-loc ] [ second where ] ?if ;
M: method-spec set-where first2 method set-method-loc ;
M: method-spec definer drop \ M: \ ; ;
M: method-spec definition first2 method method-def ;
M: method-spec definition
first2 method dup [ method-def ] when ;
: forget-method ( class generic -- )
check-method [ delete-at ] with-methods ;

4
core/generic/math/math.factor Normal file → Executable file
View File

@ -39,8 +39,8 @@ TUPLE: no-math-method left right generic ;
\ no-math-method construct-boa throw ;
: applicable-method ( generic class -- quot )
over method method-def
[ ] [ [ no-math-method ] curry [ ] like ] ?if ;
over method
[ method-def ] [ [ no-math-method ] curry [ ] like ] ?if ;
: object-method ( generic -- quot )
object bootstrap-word applicable-method ;

2
core/slots/slots.factor
View File

@ -10,7 +10,7 @@ TUPLE: slot-spec type name offset reader writer ;
C: <slot-spec> slot-spec
: define-typecheck ( class generic quot -- )
<method> over define-simple-generic -rot define-method ;
over define-simple-generic -rot define-method ;
: define-slot-word ( class slot word quot -- )
rot >fixnum add* define-typecheck ;

2
core/syntax/syntax.factor
View File

@ -126,7 +126,7 @@ IN: bootstrap.syntax
f set-word
location >r
scan-word bootstrap-word scan-word
[ parse-definition <method> -rot define-method ] 2keep
[ parse-definition -rot define-method ] 2keep
2array r> remember-definition
] define-syntax

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
math.vectors math.matrices math.parser io io.files kernel opengl
opengl.gl opengl.glu shuffle http.client vectors timers
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
: numbers ( str -- seq )
" " split [ string>number ] map [ ] subset ;
TUPLE: bunny-gadget model geom draw-seq draw-n ;
: (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* ;
: <bunny-gadget> ( -- bunny-gadget )
0.0 0.0 0.375 <demo-gadget>
maybe-download read-model {
set-delegate
set-bunny-gadget-model
} bunny-gadget construct ;
: parse-model ( stream -- vs is )
[
100000 <vector> 100000 <vector> (parse-model)
] with-stream
[
over length # " vertices, " %
dup length # " triangles" %
] "" make print ;
: bunny-gadget-draw ( gadget -- draw )
{ bunny-gadget-draw-n bunny-gadget-draw-seq }
get-slots nth ;
: n ( vs triple -- n )
swap [ nth ] curry map
dup third over first v- >r dup second swap first v- r> cross
vneg normalize ;
: bunny-gadget-next-draw ( gadget -- )
dup { bunny-gadget-draw-seq bunny-gadget-draw-n }
get-slots
1+ swap length mod
swap [ set-bunny-gadget-draw-n ] keep relayout-1 ;
: 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-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*
M: bunny-gadget graft* ( gadget -- )
GL_DEPTH_TEST glEnable
GL_SCISSOR_TEST glDisable
1.0 glClearDepth
0.0 0.0 0.0 1.0 glClearColor
GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear
GL_PROJECTION glMatrixMode
glLoadIdentity
45.0 over aspect 0.1 1.0 gluPerspective
0.0 0.12 -0.25 0.0 0.1 0.0 0.0 1.0 0.0 gluLookAt
GL_MODELVIEW glMatrixMode
glLoadIdentity
GL_LEQUAL glDepthFunc
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
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 ;
dup bunny-gadget-model <bunny-geom>
over {
[ <bunny-fixed-pipeline> ]
[ <bunny-cel-shaded> ]
[ <bunny-outlined> ]
} map-call-with [ ] subset
0
roll {
set-bunny-gadget-geom
set-bunny-gadget-draw-seq
set-bunny-gadget-draw-n
} set-slots ;
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 ( -- )
[
maybe-download read-model <bunny-gadget>
"Bunny" open-window
] with-ui ;
[ <bunny-gadget> "Bunny" open-window ] with-ui ;
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
! See http://factorcode.org/license.txt for BSD license.
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
: NSOpenGLPFAAllRenderers 1 ;
@ -35,11 +36,23 @@ IN: cocoa.views
: NSOpenGLPFAPixelBuffer 90 ;
: NSOpenGLPFAVirtualScreenCount 128 ;
<PRIVATE
SYMBOL: +software-renderer+
PRIVATE>
: with-software-renderer ( quot -- )
t +software-renderer+ set
[ f +software-renderer+ set ]
[ ] cleanup ; inline
: <PixelFormat> ( -- pixelfmt )
NSOpenGLPixelFormat -> alloc [
NSOpenGLPFAWindow ,
NSOpenGLPFADoubleBuffer ,
NSOpenGLPFADepthSize , 16 ,
+software-renderer+ get [ NSOpenGLPFARobust , ] when
0 ,
] { } make >c-int-array
-> initWithAttributes:

11
extra/io/launcher/launcher-docs.factor
View File

@ -116,6 +116,15 @@ HELP: run-detached
"The output value can be passed to " { $link wait-for-process } " to get an exit code."
} ;
HELP: kill-process
{ $values { "process" process } }
{ $description "Kills a running process. Does nothing if the process has already exited." } ;
HELP: kill-process*
{ $values { "handle" "a process handle" } }
{ $contract "Kills a running process." }
{ $notes "User code should call " { $link kill-process } " intead." } ;
HELP: process
{ $class-description "A class representing an active or finished process."
$nl
@ -166,6 +175,8 @@ $nl
"The following words are used to launch processes:"
{ $subsection run-process }
{ $subsection run-detached }
"Stopping processes:"
{ $subsection kill-process }
"Redirecting standard input and output to a pipe:"
{ $subsection <process-stream> }
{ $subsection with-process-stream }

5
extra/io/launcher/launcher.factor
View File

@ -84,6 +84,11 @@ HOOK: run-process* io-backend ( desc -- handle )
: run-detached ( desc -- process )
>descriptor H{ { +detached+ t } } union run-process ;
HOOK: kill-process* io-backend ( handle -- )
: kill-process ( process -- )
process-handle [ kill-process* ] when* ;
HOOK: process-stream* io-backend ( desc -- stream process )
TUPLE: process-stream process ;

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

@ -57,7 +57,8 @@ MEMO: 'arguments' ( -- parser )
: setup-redirection ( -- )
+stdin+ get read-flags 0 redirect
+stdout+ get write-flags 1 redirect
+stderr+ get write-flags 2 redirect ;
+stderr+ get dup +stdout+ eq?
[ drop 1 2 dup2 io-error ] [ write-flags 2 redirect ] if ;
: spawn-process ( -- )
[
@ -74,6 +75,9 @@ M: unix-io run-process* ( desc -- pid )
[ spawn-process ] [ ] with-fork <process>
] with-descriptor ;
M: unix-io kill-process* ( pid -- )
SIGTERM kill io-error ;
: open-pipe ( -- pair )
2 "int" <c-array> dup pipe zero?
[ 2 c-int-array> ] [ drop f ] if ;

15
extra/io/unix/linux/linux.factor
View File

@ -21,8 +21,11 @@ TUPLE: linux-monitor path wd callback ;
TUPLE: inotify watches ;
: wd>path ( wd -- path )
inotify get-global inotify-watches at linux-monitor-path ;
: watches ( -- assoc ) inotify get-global inotify-watches ;
: wd>monitor ( wd -- monitor ) watches at ;
: wd>path ( wd -- path ) wd>monitor linux-monitor-path ;
: <inotify> ( -- port )
H{ } clone
@ -31,8 +34,6 @@ TUPLE: inotify watches ;
: inotify-fd inotify get-global port-handle ;
: watches inotify get-global inotify-watches ;
: (add-watch) ( path mask -- wd )
inotify-fd -rot inotify_add_watch dup io-error ;
@ -105,9 +106,13 @@ M: linux-monitor dispose ( monitor -- )
inotify-event-len "inotify-event" heap-size +
swap >r + r> ;
: wd>queue ( wd -- queue )
inotify-event-wd wd>monitor monitor-queue ;
: parse-file-notifications ( i buffer -- )
2dup events-exhausted? [ 2drop ] [
2dup inotify-event@ parse-file-notify changed-file
2dup inotify-event@ dup inotify-event-wd wd>queue
[ parse-file-notify changed-file ] bind
next-event parse-file-notifications
] if ;

21
extra/io/windows/launcher/launcher.factor
View File

@ -48,10 +48,10 @@ TUPLE: CreateProcess-args
} get-slots CreateProcess win32-error=0/f ;
: escape-argument ( str -- newstr )
[ [ dup CHAR: " = [ CHAR: \\ , ] when , ] each ] "" make ;
CHAR: \s over member? [ "\"" swap "\"" 3append ] when ;
: join-arguments ( args -- cmd-line )
" " join ;
[ escape-argument ] map " " join ;
: app-name/cmd-line ( -- app-name cmd-line )
+command+ get [
@ -118,11 +118,22 @@ TUPLE: CreateProcess-args
: inherited-stderr ( args -- handle )
drop STD_ERROR_HANDLE GetStdHandle ;
: duplicate-handle ( handle -- handle )
GetCurrentProcess
swap
GetCurrentProcess
f <void*> [
0
TRUE
DUPLICATE_SAME_ACCESS
DuplicateHandle win32-error=0/f
] keep *void* ;
: redirect-stderr ( args -- handle )
+stderr+ get
dup +stdout+ eq? [
drop
CreateProcess-args-lpStartupInfo
CreateProcess-args-lpStartupInfo duplicate-handle
STARTUPINFO-hStdOutput
] [
GENERIC_WRITE CREATE_ALWAYS redirect
@ -162,6 +173,10 @@ M: windows-io run-process* ( desc -- handle )
] with-descriptor
] with-destructors ;
M: windows-io kill-process* ( handle -- )
PROCESS_INFORMATION-hProcess
255 TerminateProcess win32-error=0/f ;
: dispose-process ( process-information -- )
#! From MSDN: "Handles in PROCESS_INFORMATION must be closed
#! with CloseHandle when they are no longer needed."

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
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
: 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
opengl.gl ;
opengl.gl multiline assocs ;
IN: opengl
HELP: gl-color
@ -65,7 +65,7 @@ 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
HELP: gen-gl-buffer
{ $values { "id" integer } }
{ $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 } }
{ $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 } }
{ $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
{ gen-gl-buffer delete-gl-buffer } related-words
HELP: framebuffer-incomplete?
{ $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 } "." } ;
HELP: with-gl-program
{ $values { "program" "A " { $link gl-program } " object" } { "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" } "." } ;
{ $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" } ". 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
{ $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" } }
{ $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
{ $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." } ;
{ $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"
"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
namespaces math.vectors math.constants math.functions
math.parser opengl.gl opengl.glu combinators arrays sequences
splitting words byte-arrays assocs ;
splitting words byte-arrays assocs combinators.lib ;
IN: opengl
: coordinates [ first2 ] 2apply ;
@ -30,6 +30,13 @@ IN: opengl
: do-enabled ( what quot -- )
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 -- )
swap [ glMatrixMode glPushMatrix call ] keep
@ -103,7 +110,7 @@ IN: opengl
[ glGenFramebuffersEXT ] (gen-gl-object) ;
: gen-renderbuffer ( -- id )
[ glGenRenderbuffersEXT ] (gen-gl-object) ;
: gen-buffer ( -- id )
: gen-gl-buffer ( -- id )
[ glGenBuffers ] (gen-gl-object) ;
: (delete-gl-object) ( id quot -- )
@ -114,9 +121,26 @@ IN: opengl
[ glDeleteFramebuffersEXT ] (delete-gl-object) ;
: delete-renderbuffer ( id -- )
[ glDeleteRenderbuffersEXT ] (delete-gl-object) ;
: delete-buffer ( id -- )
: delete-gl-buffer ( id -- )
[ 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 )
GL_FRAMEBUFFER_EXT glCheckFramebufferStatusEXT
dup GL_FRAMEBUFFER_COMPLETE_EXT = f rot ? ;
@ -256,7 +280,7 @@ TUPLE: sprite loc dim dim2 dlist texture ;
: c-true? ( int -- ? ) zero? not ; inline
: with-gl-shader-source-ptr ( string quot -- )
swap >byte-array malloc-byte-array [
swap string>char-alien malloc-byte-array [
<void*> swap call
] keep free ; inline
@ -295,9 +319,8 @@ TUPLE: sprite loc dim dim2 dlist texture ;
GL_INFO_LOG_LENGTH gl-shader-get-int ; inline
: gl-shader-info-log ( shader -- log )
dup gl-shader-info-log-length
dup [
0 <int> over glGetShaderInfoLog
dup gl-shader-info-log-length dup [
[ 0 <int> swap glGetShaderInfoLog ] keep
alien>char-string
] with-malloc ;
@ -331,9 +354,10 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
GL_INFO_LOG_LENGTH gl-program-get-int ; inline
: gl-program-info-log ( program -- log )
dup gl-program-info-log-length
dup [ [ 0 <int> swap glGetProgramInfoLog ] keep
alien>char-string ] with-malloc ;
dup gl-program-info-log-length dup [
[ 0 <int> swap glGetProgramInfoLog ] keep
alien>char-string
] with-malloc ;
: check-gl-program ( program -- program* )
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 )
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> ;
: delete-gl-program-only ( program -- )
@ -357,9 +382,23 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
2dup detach-gl-program-shader delete-gl-shader
] each delete-gl-program-only ;
: with-gl-program ( program quot -- )
: (with-gl-program) ( program quot -- )
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?) ;
: <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 glGetString " " split ;
: has-gl-extensions? ( extensions -- ? )
gl-extensions subseq? ;
gl-extensions swap [ over member? ] all? nip ;
: (make-gl-extensions-error) ( required-extensions -- )
gl-extensions swap seq-diff
"Required OpenGL extensions not supported:\n" %
@ -420,8 +459,11 @@ PREDICATE: integer gl-program (gl-program?) ;
[ "Required GLSL version " % % " not supported (" % glsl-version % " available)" % ]
(require-gl) ;
: has-gl-version-or-extensions? ( version extensions -- ? )
has-gl-extensions? swap has-gl-version? or ;
: 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) ;
2array [ first2 has-gl-version-or-extensions? ] [
dup first (make-gl-version-error) "\n" %
second (make-gl-extensions-error) "\n" %
] (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.
! See http://factorcode.org/license.txt for BSD license.
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
! http://projecteuler.net/index.php?section=problems&id=32
@ -63,9 +63,6 @@ PRIVATE>
: source-032a ( -- seq )
50 [1,b] 2000 [1,b] cartesian-product ;
: pandigital? ( n -- ? )
number>string natural-sort "123456789" = ;
! multiplicand/multiplier/product
: mmp ( pair -- n )
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
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
! A collection of words used by more than one Project Euler solution
@ -12,9 +13,11 @@ IN: project-euler.common
! log10 - #25, #134
! max-path - #18, #67
! number>digits - #16, #20, #30, #34
! pandigital? - #32, #38
! propagate-all - #18, #67
! sum-proper-divisors - #21
! tau* - #12
! [uad]-transform - #39, #75
: nth-pair ( n seq -- nth next )
@ -44,6 +47,9 @@ IN: project-euler.common
dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if
] { } make sum ;
: transform ( triple matrix -- new-triple )
[ 1array ] dip m. first ;
PRIVATE>
: cartesian-product ( seq1 seq2 -- seq1xseq2 )
@ -67,6 +73,9 @@ PRIVATE>
: number>digits ( n -- seq )
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
! propagation
: propagate-all ( triangle -- newtriangle )
@ -97,3 +106,12 @@ PRIVATE>
dup sqrt >fixnum [1,b] [
dupd mod zero? [ [ 2 + ] dip ] when
] 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.
! See http://factorcode.org/license.txt for BSD license.
USING: definitions io io.files kernel math.parser sequences vocabs
vocabs.loader project-euler.ave-time project-euler.common math
USING: definitions io io.files kernel math math.parser project-euler.ave-time
sequences vocabs vocabs.loader
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.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.029 project-euler.030 project-euler.031 project-euler.032
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.175 ;
project-euler.037 project-euler.038 project-euler.039 project-euler.040
project-euler.067 project-euler.075 project-euler.134 project-euler.169
project-euler.173 project-euler.175 ;
IN: project-euler
<PRIVATE

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

@ -143,3 +143,13 @@ PRIVATE>
: accumulator ( quot -- quot vec )
V{ } clone [ [ push ] curry compose ] keep ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 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
: tuckd ( x y z -- z x y z ) 2 ntuck ; inline
MACRO: nrev ( n -- quot )
[ 1+ ] map
reverse
[ [ -nrot ] curry ] map concat ;

7
extra/unix/unix.factor
View File

@ -168,9 +168,10 @@ FUNCTION: time_t time ( time_t* t ) ;
FUNCTION: int unlink ( char* path ) ;
FUNCTION: int utimes ( char* path, timeval[2] times ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! wait and waitpid
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: SIGKILL 9 ; inline
: SIGTERM 15 ; inline
FUNCTION: int kill ( pid_t pid, int sig ) ;
! Flags for waitpid

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

@ -707,7 +707,19 @@ FUNCTION: BOOL DeleteFileW ( LPCTSTR lpFileName ) ;
! FUNCTION: DosPathToSessionPathA
! FUNCTION: DosPathToSessionPathW
! FUNCTION: DuplicateConsoleHandle
! FUNCTION: DuplicateHandle
FUNCTION: BOOL DuplicateHandle (
HANDLE hSourceProcessHandle,
HANDLE hSourceHandle,
HANDLE hTargetProcessHandle,
LPHANDLE lpTargetHandle,
DWORD dwDesiredAccess,
BOOL bInheritHandle,
DWORD dwOptions ) ;
: DUPLICATE_CLOSE_SOURCE 1 ;
: DUPLICATE_SAME_ACCESS 2 ;
! FUNCTION: EncodePointer
! FUNCTION: EncodeSystemPointer
! FUNCTION: EndUpdateResourceA
@ -1453,7 +1465,7 @@ FUNCTION: DWORD SleepEx ( DWORD dwMilliSeconds, BOOL bAlertable ) ;
FUNCTION: BOOL SystemTimeToFileTime ( SYSTEMTIME* lpSystemTime, LPFILETIME lpFileTime ) ;
! FUNCTION: SystemTimeToTzSpecificLocalTime
! FUNCTION: TerminateJobObject
! FUNCTION: TerminateProcess
FUNCTION: BOOL TerminateProcess ( HANDLE hProcess, DWORD uExit ) ;
! FUNCTION: TerminateThread
! FUNCTION: TermsrvAppInstallMode
! FUNCTION: Thread32First

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

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
! 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 ;
IN: x11.windows
@ -12,7 +12,6 @@ IN: x11.windows
XCreateColormap ;
: event-mask ( -- n )
<<<<<<< HEAD:extra/x11/windows/windows.factor
{
ExposureMask
StructureNotifyMask
@ -26,19 +25,6 @@ IN: x11.windows
LeaveWindowMask
PropertyChangeMask
} 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 )
"XSetWindowAttributes" <c-object>

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

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

3
vm/os-genunix.c Normal file → Executable file
View File

@ -21,7 +21,8 @@ const char *default_image_path(void)
if(!path)
return "factor.image";
char *new_path = safe_realloc(path,PATH_MAX + strlen(SUFFIX) + 1);
char *new_path = safe_malloc(PATH_MAX + strlen(SUFFIX) + 1);
memcpy(new_path,path,strlen(path) + 1);
strcat(new_path,SUFFIX);
return new_path;
}

7
vm/utilities.c Normal file → Executable file
View File

@ -8,13 +8,6 @@ void *safe_malloc(size_t size)
return ptr;
}
void *safe_realloc(const void *ptr, size_t size)
{
void *new_ptr = realloc((void *)ptr,size);
if(!new_ptr) fatal_error("Out of memory in safe_realloc", 0);
return new_ptr;
}
F_CHAR *safe_strdup(const F_CHAR *str)
{
F_CHAR *ptr = STRDUP(str);

1
vm/utilities.h Normal file → Executable file
View File

@ -1,3 +1,2 @@
void *safe_malloc(size_t size);
void *safe_realloc(const void *ptr, size_t size);
F_CHAR *safe_strdup(const F_CHAR *str);