diff --git a/core/alien/c-types/c-types-docs.factor b/core/alien/c-types/c-types-docs.factor
index f6418295f7..f4aa297a3a 100755
--- a/core/alien/c-types/c-types-docs.factor
+++ b/core/alien/c-types/c-types-docs.factor
@@ -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." }
diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor
index 88df823e5b..1f0f6b121e 100755
--- a/core/alien/c-types/c-types.factor
+++ b/core/alien/c-types/c-types.factor
@@ -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 ]
diff --git a/core/float-arrays/float-arrays-docs.factor b/core/float-arrays/float-arrays-docs.factor
index 70bbfe296f..cb36aade6b 100644
--- a/core/float-arrays/float-arrays-docs.factor
+++ b/core/float-arrays/float-arrays-docs.factor
@@ -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
diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor
index 849f88023f..182f04a367 100755
--- a/extra/assocs/lib/lib.factor
+++ b/extra/assocs/lib/lib.factor
@@ -1,9 +1,6 @@
-USING: assocs kernel vectors sequences ;
+USING: assocs kernel vectors sequences namespaces ;
IN: assocs.lib
-: insert-at ( value key assoc -- )
- [ ?push ] change-at ;
-
: >set ( seq -- hash )
[ dup ] H{ } map>assoc ;
@@ -19,5 +16,19 @@ IN: assocs.lib
: at-default ( key assoc -- value/key )
dupd at [ nip ] when* ;
-: at-peek ( key assoc -- value ? )
- at* dup >r [ peek ] when r> ;
+: insert-at ( value key assoc -- )
+ [ ?push ] change-at ;
+
+: peek-at* ( key assoc -- obj ? )
+ at* dup [ >r peek r> ] when ;
+
+: peek-at ( key assoc -- obj )
+ peek-at* drop ;
+
+: >multi-assoc ( assoc -- new-assoc )
+ [ 1vector ] assoc-map ;
+
+: multi-assoc-each ( assoc quot -- )
+ [ with each ] curry assoc-each ; inline
+
+: insert ( value variable -- ) namespace insert-at ;
diff --git a/extra/automata/automata.factor b/extra/automata/automata.factor
index 732033fb75..cd799d477e 100644
--- a/extra/automata/automata.factor
+++ b/extra/automata/automata.factor
@@ -1,6 +1,6 @@
USING: kernel math math.parser random arrays hashtables assocs sequences
- vars strings.lib ;
+ vars ;
IN: automata
@@ -108,4 +108,4 @@ last-line> height> [ drop step-capped-line dup ] map >bitmap >last-line ;
! : start-loop ( -- ) t >loop-flag [ loop ] in-thread ;
-! : stop-loop ( -- ) f >loop-flag ;
\ No newline at end of file
+! : stop-loop ( -- ) f >loop-flag ;
diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor
index 550eb50e0a..38f8e32fb6 100755
--- a/extra/bunny/bunny.factor
+++ b/extra/bunny/bunny.factor
@@ -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
diff --git a/extra/bunny/cel-shaded/cel-shaded.factor b/extra/bunny/cel-shaded/cel-shaded.factor
new file mode 100644
index 0000000000..fc42ca971e
--- /dev/null
+++ b/extra/bunny/cel-shaded/cel-shaded.factor
@@ -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 ;
+
diff --git a/extra/bunny/fixed-pipeline/fixed-pipeline.factor b/extra/bunny/fixed-pipeline/fixed-pipeline.factor
new file mode 100644
index 0000000000..f3fb68e515
--- /dev/null
+++ b/extra/bunny/fixed-pipeline/fixed-pipeline.factor
@@ -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 ;
+
diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor
new file mode 100644
index 0000000000..e3df6bb26c
--- /dev/null
+++ b/extra/bunny/model/model.factor
@@ -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 ;
diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor
new file mode 100644
index 0000000000..9de341561c
--- /dev/null
+++ b/extra/bunny/outlined/outlined.factor
@@ -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 ;
diff --git a/extra/cel-shading/cel-shading.factor b/extra/cel-shading/cel-shading.factor
deleted file mode 100644
index 64d23275e9..0000000000
--- a/extra/cel-shading/cel-shading.factor
+++ /dev/null
@@ -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
diff --git a/extra/cocoa/views/views.factor b/extra/cocoa/views/views.factor
index cc948df55f..7b8de9067c 100644
--- a/extra/cocoa/views/views.factor
+++ b/extra/cocoa/views/views.factor
@@ -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:
diff --git a/extra/db/db.factor b/extra/db/db.factor
new file mode 100644
index 0000000000..b765924cd6
--- /dev/null
+++ b/extra/db/db.factor
@@ -0,0 +1,104 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs classes continuations kernel math
+namespaces sequences sequences.lib tuples words ;
+IN: db
+
+TUPLE: db handle ;
+C: <db> db ( handle -- obj )
+
+! HOOK: db-create db ( str -- )
+! HOOK: db-drop db ( str -- )
+GENERIC: db-open ( db -- )
+GENERIC: db-close ( db -- )
+
+TUPLE: statement sql params handle bound? ;
+
+TUPLE: simple-statement ;
+TUPLE: prepared-statement ;
+
+HOOK: <simple-statement> db ( str -- statement )
+HOOK: <prepared-statement> db ( str -- statement )
+
+GENERIC: prepare-statement ( statement -- )
+GENERIC: bind-statement* ( obj statement -- )
+GENERIC: rebind-statement ( obj statement -- )
+
+GENERIC: execute-statement ( statement -- )
+
+: bind-statement ( obj statement -- )
+ 2dup dup statement-bound? [
+ rebind-statement
+ ] [
+ bind-statement*
+ ] if
+ tuck set-statement-params
+ t swap set-statement-bound? ;
+
+TUPLE: result-set sql params handle n max ;
+
+GENERIC: query-results ( query -- result-set )
+
+GENERIC: #rows ( result-set -- n )
+GENERIC: #columns ( result-set -- n )
+GENERIC# row-column 1 ( result-set n -- obj )
+GENERIC: advance-row ( result-set -- ? )
+
+: init-result-set ( result-set -- )
+ dup #rows over set-result-set-max
+ -1 swap set-result-set-n ;
+
+: <result-set> ( query handle tuple -- result-set )
+ >r >r { statement-sql statement-params } get-slots r>
+ {
+ set-result-set-sql
+ set-result-set-params
+ set-result-set-handle
+ } result-set construct r> construct-delegate ;
+
+: sql-row ( result-set -- seq )
+ dup #columns [ row-column ] with map ;
+
+: query-each ( statement quot -- )
+ over advance-row [
+ 2drop
+ ] [
+ [ call ] 2keep query-each
+ ] if ; inline
+
+: query-map ( statement quot -- seq )
+ accumulator >r query-each r> { } like ; inline
+
+: with-db ( db quot -- )
+ [
+ over db-open
+ [ db swap with-variable ] curry with-disposal
+ ] with-scope ;
+
+: do-query ( query -- result-set )
+ query-results [ [ sql-row ] query-map ] with-disposal ;
+
+: do-bound-query ( obj query -- rows )
+ [ bind-statement ] keep do-query ;
+
+: do-bound-command ( obj query -- )
+ [ bind-statement ] keep execute-statement ;
+
+: sql-query ( sql -- rows )
+ <simple-statement> [ do-query ] with-disposal ;
+
+: sql-command ( sql -- )
+ <simple-statement> [ execute-statement ] with-disposal ;
+
+SYMBOL: in-transaction
+HOOK: begin-transaction db ( -- )
+HOOK: commit-transaction db ( -- )
+HOOK: rollback-transaction db ( -- )
+
+: in-transaction? ( -- ? ) in-transaction get ;
+
+: with-transaction ( quot -- )
+ t in-transaction [
+ begin-transaction
+ [ ] [ rollback-transaction ] cleanup commit-transaction
+ ] with-variable ;
diff --git a/extra/postgresql/authors.txt b/extra/db/postgresql/authors.txt
similarity index 100%
rename from extra/postgresql/authors.txt
rename to extra/db/postgresql/authors.txt
diff --git a/extra/postgresql/libpq/libpq.factor b/extra/db/postgresql/ffi/ffi.factor
similarity index 56%
rename from extra/postgresql/libpq/libpq.factor
rename to extra/db/postgresql/ffi/ffi.factor
index faeb3f9aa4..dbaa70c625 100644
--- a/extra/postgresql/libpq/libpq.factor
+++ b/extra/db/postgresql/ffi/ffi.factor
@@ -1,12 +1,10 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-
! adapted from libpq-fe.h version 7.4.7
-! tested on debian linux with postgresql 7.4.7
-! Updated to 8.1
+! tested on debian linux with postgresql 8.1
USING: alien alien.syntax combinators system ;
-IN: postgresql.libpq
+IN: db.postgresql.ffi
<<
"postgresql" {
@@ -17,45 +15,44 @@ IN: postgresql.libpq
>>
! ConnSatusType
-: CONNECTION_OK HEX: 0 ; inline
-: CONNECTION_BAD HEX: 1 ; inline
-: CONNECTION_STARTED HEX: 2 ; inline
-: CONNECTION_MADE HEX: 3 ; inline
-: CONNECTION_AWAITING_RESPONSE HEX: 4 ; inline
-: CONNECTION_AUTH_OK HEX: 5 ; inline
-: CONNECTION_SETENV HEX: 6 ; inline
-: CONNECTION_SSL_STARTUP HEX: 7 ; inline
-: CONNECTION_NEEDED HEX: 8 ; inline
+: CONNECTION_OK HEX: 0 ; inline
+: CONNECTION_BAD HEX: 1 ; inline
+: CONNECTION_STARTED HEX: 2 ; inline
+: CONNECTION_MADE HEX: 3 ; inline
+: CONNECTION_AWAITING_RESPONSE HEX: 4 ; inline
+: CONNECTION_AUTH_OK HEX: 5 ; inline
+: CONNECTION_SETENV HEX: 6 ; inline
+: CONNECTION_SSL_STARTUP HEX: 7 ; inline
+: CONNECTION_NEEDED HEX: 8 ; inline
! PostgresPollingStatusType
-: PGRES_POLLING_FAILED HEX: 0 ; inline
-: PGRES_POLLING_READING HEX: 1 ; inline
-: PGRES_POLLING_WRITING HEX: 2 ; inline
-: PGRES_POLLING_OK HEX: 3 ; inline
-: PGRES_POLLING_ACTIVE HEX: 4 ; inline
+: PGRES_POLLING_FAILED HEX: 0 ; inline
+: PGRES_POLLING_READING HEX: 1 ; inline
+: PGRES_POLLING_WRITING HEX: 2 ; inline
+: PGRES_POLLING_OK HEX: 3 ; inline
+: PGRES_POLLING_ACTIVE HEX: 4 ; inline
! ExecStatusType;
-: PGRES_EMPTY_QUERY HEX: 0 ; inline
-: PGRES_COMMAND_OK HEX: 1 ; inline
-: PGRES_TUPLES_OK HEX: 2 ; inline
-: PGRES_COPY_OUT HEX: 3 ; inline
-: PGRES_COPY_IN HEX: 4 ; inline
-: PGRES_BAD_RESPONSE HEX: 5 ; inline
-: PGRES_NONFATAL_ERROR HEX: 6 ; inline
-: PGRES_FATAL_ERROR HEX: 7 ; inline
+: PGRES_EMPTY_QUERY HEX: 0 ; inline
+: PGRES_COMMAND_OK HEX: 1 ; inline
+: PGRES_TUPLES_OK HEX: 2 ; inline
+: PGRES_COPY_OUT HEX: 3 ; inline
+: PGRES_COPY_IN HEX: 4 ; inline
+: PGRES_BAD_RESPONSE HEX: 5 ; inline
+: PGRES_NONFATAL_ERROR HEX: 6 ; inline
+: PGRES_FATAL_ERROR HEX: 7 ; inline
! PGTransactionStatusType;
-: PQTRANS_IDLE HEX: 0 ; inline
-: PQTRANS_ACTIVE HEX: 1 ; inline
-: PQTRANS_INTRANS HEX: 2 ; inline
-: PQTRANS_INERROR HEX: 3 ; inline
-: PQTRANS_UNKNOWN HEX: 4 ; inline
+: PQTRANS_IDLE HEX: 0 ; inline
+: PQTRANS_ACTIVE HEX: 1 ; inline
+: PQTRANS_INTRANS HEX: 2 ; inline
+: PQTRANS_INERROR HEX: 3 ; inline
+: PQTRANS_UNKNOWN HEX: 4 ; inline
! PGVerbosity;
-: PQERRORS_TERSE HEX: 0 ; inline
-: PQERRORS_DEFAULT HEX: 1 ; inline
-: PQERRORS_VERBOSE HEX: 2 ; inline
-
+: PQERRORS_TERSE HEX: 0 ; inline
+: PQERRORS_DEFAULT HEX: 1 ; inline
+: PQERRORS_VERBOSE HEX: 2 ; inline
TYPEDEF: int size_t
TYPEDEF: int ConnStatusType
@@ -81,7 +78,6 @@ LIBRARY: postgresql
! Exported functions of libpq
-! === in fe-connect.c ===
! make a new client connection to the backend
! Asynchronous (non-blocking)
@@ -91,12 +87,12 @@ FUNCTION: PostgresPollingStatusType PQconnectPoll ( PGconn* conn ) ;
! Synchronous (blocking)
FUNCTION: PGconn* PQconnectdb ( char* conninfo ) ;
FUNCTION: PGconn* PQsetdbLogin ( char* pghost, char* pgport,
- char* pgoptions, char* pgtty,
- char* dbName,
- char* login, char* pwd ) ;
+ char* pgoptions, char* pgtty,
+ char* dbName,
+ char* login, char* pwd ) ;
: PQsetdb ( M_PGHOST M_PGPORT M_PGOPT M_PGTTY M_DBNAME -- PGconn* )
- f f PQsetdbLogin ;
+ f f PQsetdbLogin ;
! close the current connection and free the PGconn data structure
FUNCTION: void PQfinish ( PGconn* conn ) ;
@@ -112,7 +108,7 @@ FUNCTION: void PQconninfoFree ( PQconninfoOption* connOptions ) ;
! parameters
!
! Asynchronous (non-blocking)
-FUNCTION: int PQresetStart ( PGconn* conn ) ;
+FUNCTION: int PQresetStart ( PGconn* conn ) ;
FUNCTION: PostgresPollingStatusType PQresetPoll ( PGconn* conn ) ;
! Synchronous (blocking)
@@ -125,7 +121,7 @@ FUNCTION: PGcancel* PQgetCancel ( PGconn* conn ) ;
FUNCTION: void PQfreeCancel ( PGcancel* cancel ) ;
! issue a cancel request
-FUNCTION: int PQrequestCancel ( PGconn* conn ) ;
+FUNCTION: int PQrequestCancel ( PGconn* conn ) ;
! Accessor functions for PGconn objects
FUNCTION: char* PQdb ( PGconn* conn ) ;
@@ -138,14 +134,14 @@ FUNCTION: char* PQoptions ( PGconn* conn ) ;
FUNCTION: ConnStatusType PQstatus ( PGconn* conn ) ;
FUNCTION: PGTransactionStatusType PQtransactionStatus ( PGconn* conn ) ;
FUNCTION: char* PQparameterStatus ( PGconn* conn,
- char* paramName ) ;
-FUNCTION: int PQprotocolVersion ( PGconn* conn ) ;
-FUNCTION: int PQServerVersion ( PGconn* conn ) ;
+ char* paramName ) ;
+FUNCTION: int PQprotocolVersion ( PGconn* conn ) ;
+! FUNCTION: int PQServerVersion ( PGconn* conn ) ;
FUNCTION: char* PQerrorMessage ( PGconn* conn ) ;
-FUNCTION: int PQsocket ( PGconn* conn ) ;
-FUNCTION: int PQbackendPID ( PGconn* conn ) ;
-FUNCTION: int PQclientEncoding ( PGconn* conn ) ;
-FUNCTION: int PQsetClientEncoding ( PGconn* conn, char* encoding ) ;
+FUNCTION: int PQsocket ( PGconn* conn ) ;
+FUNCTION: int PQbackendPID ( PGconn* conn ) ;
+FUNCTION: int PQclientEncoding ( PGconn* conn ) ;
+FUNCTION: int PQsetClientEncoding ( PGconn* conn, char* encoding ) ;
! May not be compiled into libpq
! Get the SSL structure associated with a connection
@@ -156,7 +152,7 @@ FUNCTION: void PQinitSSL ( int do_init ) ;
! Set verbosity for PQerrorMessage and PQresultErrorMessage
FUNCTION: PGVerbosity PQsetErrorVerbosity ( PGconn* conn,
- PGVerbosity verbosity ) ;
+ PGVerbosity verbosity ) ;
! Enable/disable tracing
FUNCTION: void PQtrace ( PGconn* conn, FILE* debug_port ) ;
@@ -171,11 +167,11 @@ FUNCTION: void PQuntrace ( PGconn* conn ) ;
! Override default notice handling routines
! FUNCTION: PQnoticeReceiver PQsetNoticeReceiver ( PGconn* conn,
- ! PQnoticeReceiver proc,
- ! void* arg ) ;
+ ! PQnoticeReceiver proc,
+ ! void* arg ) ;
! FUNCTION: PQnoticeProcessor PQsetNoticeProcessor ( PGconn* conn,
- ! PQnoticeProcessor proc,
- ! void* arg ) ;
+ ! PQnoticeProcessor proc,
+ ! void* arg ) ;
! END BROKEN
! === in fe-exec.c ===
@@ -183,83 +179,83 @@ FUNCTION: void PQuntrace ( PGconn* conn ) ;
! Simple synchronous query
FUNCTION: PGresult* PQexec ( PGconn* conn, char* query ) ;
FUNCTION: PGresult* PQexecParams ( PGconn* conn,
- char* command,
- int nParams,
- Oid* paramTypes,
- char** paramValues,
- int* paramLengths,
- int* paramFormats,
- int resultFormat ) ;
+ char* command,
+ int nParams,
+ Oid* paramTypes,
+ char** paramValues,
+ int* paramLengths,
+ int* paramFormats,
+ int resultFormat ) ;
FUNCTION: PGresult* PQprepare ( PGconn* conn, char* stmtName,
char* query, int nParams,
Oid* paramTypes ) ;
FUNCTION: PGresult* PQexecPrepared ( PGconn* conn,
- char* stmtName,
- int nParams,
- char** paramValues,
- int* paramLengths,
- int* paramFormats,
- int resultFormat ) ;
+ char* stmtName,
+ int nParams,
+ char** paramValues,
+ int* paramLengths,
+ int* paramFormats,
+ int resultFormat ) ;
! Interface for multiple-result or asynchronous queries
FUNCTION: int PQsendQuery ( PGconn* conn, char* query ) ;
FUNCTION: int PQsendQueryParams ( PGconn* conn,
- char* command,
- int nParams,
- Oid* paramTypes,
- char** paramValues,
- int* paramLengths,
- int* paramFormats,
- int resultFormat ) ;
+ char* command,
+ int nParams,
+ Oid* paramTypes,
+ char** paramValues,
+ int* paramLengths,
+ int* paramFormats,
+ int resultFormat ) ;
FUNCTION: PGresult* PQsendPrepare ( PGconn* conn, char* stmtName,
char* query, int nParams,
Oid* paramTypes ) ;
FUNCTION: int PQsendQueryPrepared ( PGconn* conn,
- char* stmtName,
- int nParams,
- char** paramValues,
- int *paramLengths,
- int *paramFormats,
- int resultFormat ) ;
+ char* stmtName,
+ int nParams,
+ char** paramValues,
+ int *paramLengths,
+ int *paramFormats,
+ int resultFormat ) ;
FUNCTION: PGresult* PQgetResult ( PGconn* conn ) ;
! Routines for managing an asynchronous query
-FUNCTION: int PQisBusy ( PGconn* conn ) ;
-FUNCTION: int PQconsumeInput ( PGconn* conn ) ;
+FUNCTION: int PQisBusy ( PGconn* conn ) ;
+FUNCTION: int PQconsumeInput ( PGconn* conn ) ;
! LISTEN/NOTIFY support
FUNCTION: PGnotify* PQnotifies ( PGconn* conn ) ;
! Routines for copy in/out
-FUNCTION: int PQputCopyData ( PGconn* conn, char* buffer, int nbytes ) ;
-FUNCTION: int PQputCopyEnd ( PGconn* conn, char* errormsg ) ;
-FUNCTION: int PQgetCopyData ( PGconn* conn, char** buffer, int async ) ;
+FUNCTION: int PQputCopyData ( PGconn* conn, char* buffer, int nbytes ) ;
+FUNCTION: int PQputCopyEnd ( PGconn* conn, char* errormsg ) ;
+FUNCTION: int PQgetCopyData ( PGconn* conn, char** buffer, int async ) ;
! Deprecated routines for copy in/out
-FUNCTION: int PQgetline ( PGconn* conn, char* string, int length ) ;
-FUNCTION: int PQputline ( PGconn* conn, char* string ) ;
-FUNCTION: int PQgetlineAsync ( PGconn* conn, char* buffer, int bufsize ) ;
-FUNCTION: int PQputnbytes ( PGconn* conn, char* buffer, int nbytes ) ;
-FUNCTION: int PQendcopy ( PGconn* conn ) ;
+FUNCTION: int PQgetline ( PGconn* conn, char* string, int length ) ;
+FUNCTION: int PQputline ( PGconn* conn, char* string ) ;
+FUNCTION: int PQgetlineAsync ( PGconn* conn, char* buffer, int bufsize ) ;
+FUNCTION: int PQputnbytes ( PGconn* conn, char* buffer, int nbytes ) ;
+FUNCTION: int PQendcopy ( PGconn* conn ) ;
! Set blocking/nonblocking connection to the backend
-FUNCTION: int PQsetnonblocking ( PGconn* conn, int arg ) ;
-FUNCTION: int PQisnonblocking ( PGconn* conn ) ;
+FUNCTION: int PQsetnonblocking ( PGconn* conn, int arg ) ;
+FUNCTION: int PQisnonblocking ( PGconn* conn ) ;
! Force the write buffer to be written (or at least try)
-FUNCTION: int PQflush ( PGconn* conn ) ;
+FUNCTION: int PQflush ( PGconn* conn ) ;
!
! * "Fast path" interface --- not really recommended for application
! * use
!
FUNCTION: PGresult* PQfn ( PGconn* conn,
- int fnid,
- int* result_buf,
- int* result_len,
- int result_is_int,
- PQArgBlock* args,
- int nargs ) ;
+ int fnid,
+ int* result_buf,
+ int* result_len,
+ int result_is_int,
+ PQArgBlock* args,
+ int nargs ) ;
! Accessor functions for PGresult objects
FUNCTION: ExecStatusType PQresultStatus ( PGresult* res ) ;
@@ -313,7 +309,7 @@ FUNCTION: uchar* PQunescapeBytea ( uchar* strtext,
! These forms are deprecated!
FUNCTION: size_t PQescapeString ( void* to, char* from, size_t length ) ;
FUNCTION: uchar* PQescapeBytea ( uchar* bintext, size_t binlen,
- size_t* bytealen ) ;
+ size_t* bytealen ) ;
! === in fe-print.c ===
@@ -332,30 +328,28 @@ FUNCTION: void PQprintTuples ( PGresult* res,
int printAttName,
int terseOutput,
int width ) ;
-
! === in fe-lobj.c ===
! Large-object access routines
-FUNCTION: int lo_open ( PGconn* conn, Oid lobjId, int mode ) ;
-FUNCTION: int lo_close ( PGconn* conn, int fd ) ;
-FUNCTION: int lo_read ( PGconn* conn, int fd, char* buf, size_t len ) ;
-FUNCTION: int lo_write ( PGconn* conn, int fd, char* buf, size_t len ) ;
-FUNCTION: int lo_lseek ( PGconn* conn, int fd, int offset, int whence ) ;
-FUNCTION: Oid lo_creat ( PGconn* conn, int mode ) ;
-! FUNCTION: Oid lo_creat ( PGconn* conn, Oid lobjId ) ;
-FUNCTION: int lo_tell ( PGconn* conn, int fd ) ;
-FUNCTION: int lo_unlink ( PGconn* conn, Oid lobjId ) ;
-FUNCTION: Oid lo_import ( PGconn* conn, char* filename ) ;
-FUNCTION: int lo_export ( PGconn* conn, Oid lobjId, char* filename ) ;
+FUNCTION: int lo_open ( PGconn* conn, Oid lobjId, int mode ) ;
+FUNCTION: int lo_close ( PGconn* conn, int fd ) ;
+FUNCTION: int lo_read ( PGconn* conn, int fd, char* buf, size_t len ) ;
+FUNCTION: int lo_write ( PGconn* conn, int fd, char* buf, size_t len ) ;
+FUNCTION: int lo_lseek ( PGconn* conn, int fd, int offset, int whence ) ;
+FUNCTION: Oid lo_creat ( PGconn* conn, int mode ) ;
+! FUNCTION: Oid lo_creat ( PGconn* conn, Oid lobjId ) ;
+FUNCTION: int lo_tell ( PGconn* conn, int fd ) ;
+FUNCTION: int lo_unlink ( PGconn* conn, Oid lobjId ) ;
+FUNCTION: Oid lo_import ( PGconn* conn, char* filename ) ;
+FUNCTION: int lo_export ( PGconn* conn, Oid lobjId, char* filename ) ;
! === in fe-misc.c ===
! Determine length of multibyte encoded char at *s
-FUNCTION: int PQmblen ( uchar* s, int encoding ) ;
+FUNCTION: int PQmblen ( uchar* s, int encoding ) ;
! Determine display length of multibyte encoded char at *s
-FUNCTION: int PQdsplen ( uchar* s, int encoding ) ;
+FUNCTION: int PQdsplen ( uchar* s, int encoding ) ;
! Get encoding id from environment variable PGCLIENTENCODING
-FUNCTION: int PQenv2encoding ( ) ;
-
+FUNCTION: int PQenv2encoding ( ) ;
diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor
new file mode 100644
index 0000000000..a940a42ae4
--- /dev/null
+++ b/extra/db/postgresql/lib/lib.factor
@@ -0,0 +1,44 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays continuations db io kernel math namespaces
+quotations sequences db.postgresql.ffi alien alien.c-types ;
+IN: db.postgresql.lib
+
+: postgresql-result-error-message ( res -- str/f )
+ dup zero? [
+ drop f
+ ] [
+ PQresultErrorMessage [ CHAR: \n = ] right-trim
+ ] if ;
+
+: postgres-result-error ( res -- )
+ postgresql-result-error-message [ throw ] when* ;
+
+: postgresql-error-message ( -- str )
+ db get db-handle PQerrorMessage [ CHAR: \n = ] right-trim ;
+
+: postgresql-error ( res -- res )
+ dup [ postgresql-error-message throw ] unless ;
+
+: postgresql-result-ok? ( n -- ? )
+ PQresultStatus
+ PGRES_COMMAND_OK PGRES_TUPLES_OK 2array member? ;
+
+: connect-postgres ( host port pgopts pgtty db user pass -- conn )
+ PQsetdbLogin
+ dup PQstatus zero? [ postgresql-error-message throw ] unless ;
+
+: do-postgresql-statement ( statement -- res )
+ db get db-handle swap statement-sql PQexec dup postgresql-result-ok? [
+ dup postgresql-result-error-message swap PQclear throw
+ ] unless ;
+
+: do-postgresql-bound-statement ( statement -- res )
+ >r db get db-handle r>
+ [ statement-sql ] keep
+ [ statement-params length f ] keep
+ statement-params [ malloc-char-string ] map >c-void*-array
+ f f 0 PQexecParams
+ dup postgresql-result-ok? [
+ dup postgresql-result-error-message swap PQclear throw
+ ] unless ;
diff --git a/extra/db/postgresql/postgresql-tests.factor b/extra/db/postgresql/postgresql-tests.factor
new file mode 100644
index 0000000000..c5a5155d12
--- /dev/null
+++ b/extra/db/postgresql/postgresql-tests.factor
@@ -0,0 +1,110 @@
+! You will need to run 'createdb factor-test' to create the database.
+! Set username and password in the 'connect' word.
+
+USING: kernel db.postgresql alien continuations io prettyprint
+sequences namespaces tools.test db ;
+IN: temporary
+
+IN: scratchpad
+: test-db ( -- postgresql-db )
+ "localhost" "postgres" "" "factor-test" <postgresql-db> ;
+IN: temporary
+
+[ ] [ test-db [ ] with-db ] unit-test
+
+[ ] [
+ test-db [
+ [ "drop table person;" sql-command ] catch drop
+ "create table person (name varchar(30), country varchar(30));"
+ sql-command
+
+ "insert into person values('John', 'America');" sql-command
+ "insert into person values('Jane', 'New Zealand');" sql-command
+ ] with-db
+] unit-test
+
+[
+ {
+ { "John" "America" }
+ { "Jane" "New Zealand" }
+ }
+] [
+ test-db [
+ "select * from person" sql-query
+ ] with-db
+] unit-test
+
+[
+ { { "John" "America" } }
+] [
+ test-db [
+ "select * from person where name = $1 and country = $2"
+ <simple-statement> [
+ { "Jane" "New Zealand" }
+ over do-bound-query
+
+ { { "Jane" "New Zealand" } } =
+ [ "test fails" throw ] unless
+
+ { "John" "America" }
+ swap do-bound-query
+ ] with-disposal
+ ] with-db
+] unit-test
+
+[
+ {
+ { "John" "America" }
+ { "Jane" "New Zealand" }
+ }
+] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
+
+[
+] [
+ test-db [
+ "insert into person(name, country) values('Jimmy', 'Canada')"
+ sql-command
+ ] with-db
+] unit-test
+
+[
+ {
+ { "John" "America" }
+ { "Jane" "New Zealand" }
+ { "Jimmy" "Canada" }
+ }
+] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
+
+[
+ test-db [
+ [
+ "insert into person(name, country) values('Jose', 'Mexico')" sql-command
+ "insert into person(name, country) values('Jose', 'Mexico')" sql-command
+ "oops" throw
+ ] with-transaction
+ ] with-db
+] unit-test-fails
+
+[ 3 ] [
+ test-db [
+ "select * from person" sql-query length
+ ] with-db
+] unit-test
+
+[
+] [
+ test-db [
+ [
+ "insert into person(name, country) values('Jose', 'Mexico')"
+ sql-command
+ "insert into person(name, country) values('Jose', 'Mexico')"
+ sql-command
+ ] with-transaction
+ ] with-db
+] unit-test
+
+[ 5 ] [
+ test-db [
+ "select * from person" sql-query length
+ ] with-db
+] unit-test
diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor
new file mode 100644
index 0000000000..df778cc80d
--- /dev/null
+++ b/extra/db/postgresql/postgresql.factor
@@ -0,0 +1,105 @@
+! Copyright (C) 2007, 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs alien alien.syntax continuations io
+kernel math namespaces prettyprint quotations
+sequences debugger db db.postgresql.lib db.postgresql.ffi ;
+IN: db.postgresql
+
+TUPLE: postgresql-db host port pgopts pgtty db user pass ;
+TUPLE: postgresql-statement ;
+TUPLE: postgresql-result-set ;
+: <postgresql-statement> ( statement -- postgresql-statement )
+ postgresql-statement construct-delegate ;
+
+: <postgresql-db> ( host user pass db -- obj )
+ {
+ set-postgresql-db-host
+ set-postgresql-db-user
+ set-postgresql-db-pass
+ set-postgresql-db-db
+ } postgresql-db construct ;
+
+M: postgresql-db db-open ( db -- )
+ dup {
+ postgresql-db-host
+ postgresql-db-port
+ postgresql-db-pgopts
+ postgresql-db-pgtty
+ postgresql-db-db
+ postgresql-db-user
+ postgresql-db-pass
+ } get-slots connect-postgres <db> swap set-delegate ;
+
+M: postgresql-db dispose ( db -- )
+ db-handle PQfinish ;
+
+: with-postgresql ( host ust pass db quot -- )
+ >r <postgresql-db> r> with-disposal ;
+
+M: postgresql-statement bind-statement* ( seq statement -- )
+ set-statement-params ;
+
+M: postgresql-statement rebind-statement ( seq statement -- )
+ bind-statement* ;
+
+M: postgresql-result-set #rows ( result-set -- n )
+ result-set-handle PQntuples ;
+
+M: postgresql-result-set #columns ( result-set -- n )
+ result-set-handle PQnfields ;
+
+M: postgresql-result-set row-column ( result-set n -- obj )
+ >r dup result-set-handle swap result-set-n r> PQgetvalue ;
+
+M: postgresql-statement execute-statement ( statement -- )
+ query-results dispose ;
+
+: increment-n ( result-set -- n )
+ dup result-set-n 1+ dup rot set-result-set-n ;
+
+M: postgresql-statement query-results ( query -- result-set )
+ dup statement-params [
+ over [ bind-statement ] keep
+ do-postgresql-bound-statement
+ ] [
+ dup do-postgresql-statement
+ ] if*
+ postgresql-result-set <result-set>
+ dup init-result-set ;
+
+M: postgresql-result-set advance-row ( result-set -- ? )
+ dup increment-n swap result-set-max >= ;
+
+M: postgresql-statement dispose ( query -- )
+ dup statement-handle PQclear
+ f swap set-statement-handle ;
+
+M: postgresql-result-set dispose ( result-set -- )
+ dup result-set-handle PQclear
+ 0 0 f roll {
+ set-result-set-n set-result-set-max set-result-set-handle
+ } set-slots ;
+
+M: postgresql-statement prepare-statement ( statement -- )
+ [
+ >r db get db-handle "" r>
+ dup statement-sql swap statement-params
+ length f PQprepare postgresql-error
+ ] keep set-statement-handle ;
+
+M: postgresql-db <simple-statement> ( sql -- statement )
+ { set-statement-sql } statement construct
+ <postgresql-statement> ;
+
+M: postgresql-db <prepared-statement> ( sql -- statement )
+ { set-statement-sql } statement construct
+ <postgresql-statement> ;
+
+M: postgresql-db begin-transaction ( -- )
+ "BEGIN" sql-command ;
+
+M: postgresql-db commit-transaction ( -- )
+ "COMMIT" sql-command ;
+
+M: postgresql-db rollback-transaction ( -- )
+ "ROLLBACK" sql-command ;
diff --git a/extra/db/sqlite/authors.txt b/extra/db/sqlite/authors.txt
new file mode 100644
index 0000000000..26093b451b
--- /dev/null
+++ b/extra/db/sqlite/authors.txt
@@ -0,0 +1,2 @@
+Chris Double
+Doug Coleman
diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor
new file mode 100644
index 0000000000..609c597b35
--- /dev/null
+++ b/extra/db/sqlite/ffi/ffi.factor
@@ -0,0 +1,130 @@
+! Copyright (C) 2005 Chris Double, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+!
+! An interface to the sqlite database. Tested against sqlite v3.1.3.
+
+! Not all functions have been wrapped yet. Only those directly involving
+! executing SQL calls and obtaining results.
+
+USING: alien compiler kernel math namespaces sequences strings alien.syntax
+ system combinators ;
+IN: db.sqlite.ffi
+
+<<
+ "sqlite" {
+ { [ winnt? ] [ "sqlite3.dll" ] }
+ { [ macosx? ] [ "/usr/lib/libsqlite3.dylib" ] }
+ { [ unix? ] [ "libsqlite3.so" ] }
+ } cond "cdecl" add-library >>
+
+! Return values from sqlite functions
+: SQLITE_OK 0 ; inline ! Successful result
+: SQLITE_ERROR 1 ; inline ! SQL error or missing database
+: SQLITE_INTERNAL 2 ; inline ! An internal logic error in SQLite
+: SQLITE_PERM 3 ; inline ! Access permission denied
+: SQLITE_ABORT 4 ; inline ! Callback routine requested an abort
+: SQLITE_BUSY 5 ; inline ! The database file is locked
+: SQLITE_LOCKED 6 ; inline ! A table in the database is locked
+: SQLITE_NOMEM 7 ; inline ! A malloc() failed
+: SQLITE_READONLY 8 ; inline ! Attempt to write a readonly database
+: SQLITE_INTERRUPT 9 ; inline ! Operation terminated by sqlite_interrupt()
+: SQLITE_IOERR 10 ; inline ! Some kind of disk I/O error occurred
+: SQLITE_CORRUPT 11 ; inline ! The database disk image is malformed
+: SQLITE_NOTFOUND 12 ; inline ! (Internal Only) Table or record not found
+: SQLITE_FULL 13 ; inline ! Insertion failed because database is full
+: SQLITE_CANTOPEN 14 ; inline ! Unable to open the database file
+: SQLITE_PROTOCOL 15 ; inline ! Database lock protocol error
+: SQLITE_EMPTY 16 ; inline ! (Internal Only) Database table is empty
+: SQLITE_SCHEMA 17 ; inline ! The database schema changed
+: SQLITE_TOOBIG 18 ; inline ! Too much data for one row of a table
+: SQLITE_CONSTRAINT 19 ; inline ! Abort due to contraint violation
+: SQLITE_MISMATCH 20 ; inline ! Data type mismatch
+: SQLITE_MISUSE 21 ; inline ! Library used incorrectly
+: SQLITE_NOLFS 22 ; inline ! Uses OS features not supported on host
+: SQLITE_AUTH 23 ; inline ! Authorization denied
+: SQLITE_FORMAT 24 ; inline ! Auxiliary database format error
+: SQLITE_RANGE 25 ; inline ! 2nd parameter to sqlite3_bind out of range
+: SQLITE_NOTADB 26 ; inline ! File opened that is not a database file
+
+: sqlite-error-messages ( -- seq ) {
+ "Successful result"
+ "SQL error or missing database"
+ "An internal logic error in SQLite"
+ "Access permission denied"
+ "Callback routine requested an abort"
+ "The database file is locked"
+ "A table in the database is locked"
+ "A malloc() failed"
+ "Attempt to write a readonly database"
+ "Operation terminated by sqlite_interrupt()"
+ "Some kind of disk I/O error occurred"
+ "The database disk image is malformed"
+ "(Internal Only) Table or record not found"
+ "Insertion failed because database is full"
+ "Unable to open the database file"
+ "Database lock protocol error"
+ "(Internal Only) Database table is empty"
+ "The database schema changed"
+ "Too much data for one row of a table"
+ "Abort due to contraint violation"
+ "Data type mismatch"
+ "Library used incorrectly"
+ "Uses OS features not supported on host"
+ "Authorization denied"
+ "Auxiliary database format error"
+ "2nd parameter to sqlite3_bind out of range"
+ "File opened that is not a database file"
+} ;
+
+: SQLITE_ROW 100 ; inline ! sqlite_step() has another row ready
+: SQLITE_DONE 101 ; inline ! sqlite_step() has finished executing
+
+! Return values from the sqlite3_column_type function
+: SQLITE_INTEGER 1 ; inline
+: SQLITE_FLOAT 2 ; inline
+: SQLITE_TEXT 3 ; inline
+: SQLITE_BLOB 4 ; inline
+: SQLITE_NULL 5 ; inline
+
+! Values for the 'destructor' parameter of the 'bind' routines.
+: SQLITE_STATIC 0 ; inline
+: SQLITE_TRANSIENT -1 ; inline
+
+: SQLITE_OPEN_READONLY HEX: 00000001 ; inline
+: SQLITE_OPEN_READWRITE HEX: 00000002 ; inline
+: SQLITE_OPEN_CREATE HEX: 00000004 ; inline
+: SQLITE_OPEN_DELETEONCLOSE HEX: 00000008 ; inline
+: SQLITE_OPEN_EXCLUSIVE HEX: 00000010 ; inline
+: SQLITE_OPEN_MAIN_DB HEX: 00000100 ; inline
+: SQLITE_OPEN_TEMP_DB HEX: 00000200 ; inline
+: SQLITE_OPEN_TRANSIENT_DB HEX: 00000400 ; inline
+: SQLITE_OPEN_MAIN_JOURNAL HEX: 00000800 ; inline
+: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000 ; inline
+: SQLITE_OPEN_SUBJOURNAL HEX: 00002000 ; inline
+: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000 ; inline
+
+
+TYPEDEF: void sqlite3
+TYPEDEF: void sqlite3_stmt
+
+LIBRARY: sqlite
+FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ;
+FUNCTION: int sqlite3_close ( sqlite3* pDb ) ;
+FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
+FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ;
+FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
+FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ;
+FUNCTION: int sqlite3_last_insert_rowid ( sqlite3* pStmt ) ;
+FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ;
+FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ;
+FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ;
+FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ;
+FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ;
+FUNCTION: int sqlite3_column_count ( sqlite3_stmt* pStmt ) ;
+FUNCTION: void* sqlite3_column_blob ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: int sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ;
diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor
new file mode 100644
index 0000000000..e5f8425d92
--- /dev/null
+++ b/extra/db/sqlite/lib/lib.factor
@@ -0,0 +1,85 @@
+! Copyright (C) 2008 Chris Double, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types assocs kernel math math.parser sequences
+db.sqlite.ffi ;
+IN: db.sqlite.lib
+
+TUPLE: sqlite-error n message ;
+
+: sqlite-check-result ( result -- )
+ dup SQLITE_OK = [
+ drop
+ ] [
+ dup sqlite-error-messages nth
+ sqlite-error construct-boa throw
+ ] if ;
+
+: sqlite-open ( filename -- db )
+ "void*" <c-object>
+ [ sqlite3_open sqlite-check-result ] keep *void* ;
+
+: sqlite-close ( db -- )
+ sqlite3_close sqlite-check-result ;
+
+: sqlite-last-insert-rowid ( db -- rowid )
+ sqlite3_last_insert_rowid ;
+
+: sqlite-prepare ( db sql -- statement )
+ #! TODO: Support multiple statements in the SQL string.
+ dup length "void*" <c-object> "void*" <c-object>
+ [ sqlite3_prepare sqlite-check-result ] 2keep
+ drop *void* ;
+
+: sqlite-bind-text ( statement index text -- )
+ dup number? [ number>string ] when
+ dup length SQLITE_TRANSIENT sqlite3_bind_text sqlite-check-result ;
+
+: sqlite-bind-parameter-index ( statement name -- index )
+ sqlite3_bind_parameter_index ;
+
+: sqlite-bind-text-by-name ( statement name text -- )
+ >r dupd sqlite-bind-parameter-index r> sqlite-bind-text ;
+
+: sqlite-bind-assoc ( statement assoc -- )
+ swap [
+ -rot sqlite-bind-text-by-name
+ ] curry assoc-each ;
+
+: sqlite-finalize ( statement -- )
+ sqlite3_finalize sqlite-check-result ;
+
+: sqlite-reset ( statement -- )
+ sqlite3_reset sqlite-check-result ;
+
+: sqlite-#columns ( query -- int )
+ sqlite3_column_count ;
+
+: sqlite-column ( statement index -- string )
+ sqlite3_column_text ;
+
+: sqlite-row ( statement -- seq )
+ dup sqlite-#columns [ sqlite-column ] with map ;
+
+! 2dup sqlite3_column_type .
+! SQLITE_INTEGER 1
+! SQLITE_FLOAT 2
+! SQLITE_TEXT 3
+! SQLITE_BLOB 4
+! SQLITE_NULL 5
+
+: step-complete? ( step-result -- bool )
+ dup SQLITE_ROW = [
+ drop f
+ ] [
+ dup SQLITE_DONE = [ drop t ] [ sqlite-check-result t ] if
+ ] if ;
+
+: sqlite-step ( prepared -- )
+ dup sqlite3_step step-complete? [
+ drop
+ ] [
+ sqlite-step
+ ] if ;
+
+: sqlite-next ( prepared -- ? )
+ sqlite3_step step-complete? ;
diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor
new file mode 100644
index 0000000000..f64b8d1104
--- /dev/null
+++ b/extra/db/sqlite/sqlite-tests.factor
@@ -0,0 +1,110 @@
+USING: io io.files io.launcher kernel namespaces
+prettyprint tools.test db.sqlite db db.sql sequences
+continuations ;
+IN: temporary
+
+! "sqlite3 -init test.txt test.db"
+
+IN: scratchpad
+: test.db "extra/db/sqlite/test.db" resource-path ;
+
+IN: temporary
+: (create-db) ( -- str )
+ [
+ "sqlite3 -init " %
+ test.db %
+ " " %
+ test.db %
+ ] "" make ;
+
+: create-db ( -- ) (create-db) run-process drop ;
+
+[ ] [ test.db delete-file ] unit-test
+
+[ ] [ create-db ] unit-test
+
+[
+ {
+ { "John" "America" }
+ { "Jane" "New Zealand" }
+ }
+] [
+ test.db [
+ "select * from person" sql-query
+ ] with-sqlite
+] unit-test
+
+[
+ { { "John" "America" } }
+] [
+ test.db [
+ "select * from person where name = :name and country = :country"
+ <simple-statement> [
+ { { ":name" "Jane" } { ":country" "New Zealand" } }
+ over do-bound-query
+
+ { { "Jane" "New Zealand" } } =
+ [ "test fails" throw ] unless
+
+ { { ":name" "John" } { ":country" "America" } }
+ swap do-bound-query
+ ] with-disposal
+ ] with-sqlite
+] unit-test
+
+[
+ {
+ { "1" "John" "America" }
+ { "2" "Jane" "New Zealand" }
+ }
+] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test
+
+[
+] [
+ test.db [
+ "insert into person(name, country) values('Jimmy', 'Canada')"
+ sql-command
+ ] with-sqlite
+] unit-test
+
+[
+ {
+ { "1" "John" "America" }
+ { "2" "Jane" "New Zealand" }
+ { "3" "Jimmy" "Canada" }
+ }
+] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test
+
+[
+ test.db [
+ [
+ "insert into person(name, country) values('Jose', 'Mexico')" sql-command
+ "insert into person(name, country) values('Jose', 'Mexico')" sql-command
+ "oops" throw
+ ] with-transaction
+ ] with-sqlite
+] unit-test-fails
+
+[ 3 ] [
+ test.db [
+ "select * from person" sql-query length
+ ] with-sqlite
+] unit-test
+
+[
+] [
+ test.db [
+ [
+ "insert into person(name, country) values('Jose', 'Mexico')"
+ sql-command
+ "insert into person(name, country) values('Jose', 'Mexico')"
+ sql-command
+ ] with-transaction
+ ] with-sqlite
+] unit-test
+
+[ 5 ] [
+ test.db [
+ "select * from person" sql-query length
+ ] with-sqlite
+] unit-test
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
new file mode 100644
index 0000000000..49462dcc50
--- /dev/null
+++ b/extra/db/sqlite/sqlite.factor
@@ -0,0 +1,74 @@
+! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien arrays assocs classes compiler db db.sql
+hashtables io.files kernel math math.parser namespaces
+prettyprint sequences strings tuples alien.c-types
+continuations db.sqlite.lib db.sqlite.ffi ;
+IN: db.sqlite
+
+TUPLE: sqlite-db path ;
+C: <sqlite-db> sqlite-db
+
+M: sqlite-db db-open ( db -- )
+ dup sqlite-db-path sqlite-open <db>
+ swap set-delegate ;
+
+M: sqlite-db dispose ( obj -- )
+ dup db-handle sqlite-close
+ f over set-db-handle
+ f swap set-delegate ;
+
+: with-sqlite ( path quot -- )
+ >r <sqlite-db> r> with-db ; inline
+
+TUPLE: sqlite-statement ;
+C: <sqlite-statement> sqlite-statement
+
+TUPLE: sqlite-result-set ;
+: <sqlite-result-set> ( query -- sqlite-result-set )
+ dup statement-handle sqlite-result-set <result-set> ;
+
+M: sqlite-db <simple-statement> ( str -- obj )
+ <prepared-statement> ;
+
+M: sqlite-db <prepared-statement> ( str -- obj )
+ db get db-handle over sqlite-prepare
+ { set-statement-sql set-statement-handle } statement construct
+ <sqlite-statement> [ set-delegate ] keep ;
+
+M: sqlite-statement dispose ( statement -- )
+ statement-handle sqlite-finalize ;
+
+M: sqlite-result-set dispose ( result-set -- )
+ f swap set-result-set-handle ;
+
+M: sqlite-statement bind-statement* ( assoc statement -- )
+ statement-handle swap sqlite-bind-assoc ;
+
+M: sqlite-statement rebind-statement ( assoc statement -- )
+ dup statement-handle sqlite-reset
+ statement-handle swap sqlite-bind-assoc ;
+
+M: sqlite-statement execute-statement ( statement -- )
+ statement-handle sqlite-next drop ;
+
+M: sqlite-result-set #columns ( result-set -- n )
+ result-set-handle sqlite-#columns ;
+
+M: sqlite-result-set row-column ( result-set n -- obj )
+ >r result-set-handle r> sqlite-column ;
+
+M: sqlite-result-set advance-row ( result-set -- handle ? )
+ result-set-handle sqlite-next ;
+
+M: sqlite-statement query-results ( query -- result-set )
+ dup statement-handle sqlite-result-set <result-set> ;
+
+M: sqlite-db begin-transaction ( -- )
+ "BEGIN" sql-command ;
+
+M: sqlite-db commit-transaction ( -- )
+ "COMMIT" sql-command ;
+
+M: sqlite-db rollback-transaction ( -- )
+ "ROLLBACK" sql-command ;
diff --git a/extra/db/sqlite/test.txt b/extra/db/sqlite/test.txt
new file mode 100644
index 0000000000..e4487d30f9
--- /dev/null
+++ b/extra/db/sqlite/test.txt
@@ -0,0 +1,3 @@
+create table person (name varchar(30), country varchar(30));
+insert into person values('John', 'America');
+insert into person values('Jane', 'New Zealand');
diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor
index dde2c7d205..8e6d8257a4 100755
--- a/extra/http/client/client.factor
+++ b/extra/http/client/client.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs http kernel math math.parser namespaces sequences
io io.sockets io.streams.string io.files strings splitting
-continuations ;
+continuations assocs.lib ;
IN: http.client
: parse-host ( url -- host port )
@@ -44,7 +44,7 @@ DEFER: http-get-stream
#! Should this support Location: headers that are
#! relative URLs?
pick 100 /i 3 = [
- dispose "Location" swap at nip http-get-stream
+ dispose "location" swap peek-at nip http-get-stream
] when ;
: http-get-stream ( url -- code headers stream )
diff --git a/extra/http/http.factor b/extra/http/http.factor
index 1bd9e18d98..755f36a538 100755
--- a/extra/http/http.factor
+++ b/extra/http/http.factor
@@ -1,11 +1,12 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables io kernel math namespaces math.parser assocs
-sequences strings splitting ascii io.utf8 ;
+sequences strings splitting ascii io.utf8 assocs.lib
+namespaces unicode.case ;
IN: http
: header-line ( line -- )
- ": " split1 dup [ swap set ] [ 2drop ] if ;
+ ": " split1 dup [ swap >lower insert ] [ 2drop ] if ;
: (read-header) ( -- )
readln dup
@@ -71,4 +72,3 @@ IN: http
hash>query %
] if
] "" make ;
-
diff --git a/extra/http/server/responders/responders.factor b/extra/http/server/responders/responders.factor
index 8dcaa7223d..70503236f6 100644
--- a/extra/http/server/responders/responders.factor
+++ b/extra/http/server/responders/responders.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs hashtables html html.elements splitting
http io kernel math math.parser namespaces parser sequences
-strings io.server ;
+strings io.server vectors assocs.lib ;
IN: http.server.responders
@@ -10,8 +10,11 @@ IN: http.server.responders
SYMBOL: vhosts
SYMBOL: responders
+: >header ( value key -- multi-hash )
+ H{ } clone [ insert-at ] keep ;
+
: print-header ( alist -- )
- [ swap write ": " write print ] assoc-each nl ;
+ [ swap write ": " write print ] multi-assoc-each nl ;
: response ( msg -- ) "HTTP/1.0 " write print ;
@@ -20,7 +23,7 @@ SYMBOL: responders
: error-head ( error -- )
dup log-error response
- H{ { "Content-Type" "text/html" } } print-header nl ;
+ H{ { "Content-Type" V{ "text/html" } } } print-header nl ;
: httpd-error ( error -- )
#! This must be run from handle-request
@@ -36,7 +39,7 @@ SYMBOL: responders
: serving-content ( mime -- )
"200 Document follows" response
- "Content-Type" associate print-header ;
+ "Content-Type" >header print-header ;
: serving-html "text/html" serving-content ;
@@ -46,7 +49,7 @@ SYMBOL: responders
: serving-text "text/plain" serving-content ;
: redirect ( to response -- )
- response "Location" associate print-header ;
+ response "Location" >header print-header ;
: permanent-redirect ( to -- )
"301 Moved Permanently" redirect ;
@@ -84,14 +87,14 @@ SYMBOL: max-post-request
: log-headers ( hash -- )
[
drop {
- "User-Agent"
- "Referer"
- "X-Forwarded-For"
- "Host"
+ "user-agent"
+ "referer"
+ "x-forwarded-for"
+ "host"
} member?
] assoc-subset [
": " swap 3append log-message
- ] assoc-each ;
+ ] multi-assoc-each ;
: prepare-url ( url -- url )
#! This is executed in the with-request namespace.
@@ -122,7 +125,8 @@ SYMBOL: max-post-request
: query-param ( key -- value ) "query" get at ;
-: header-param ( key -- value ) "header" get at ;
+: header-param ( key -- value )
+ "header" get peek-at ;
: host ( -- string )
#! The host the current responder was called from.
@@ -130,7 +134,7 @@ SYMBOL: max-post-request
: add-responder ( responder -- )
#! Add a responder object to the list.
- "responder" over at responders get set-at ;
+ "responder" over at responders get set-at ;
: make-responder ( quot -- )
#! quot has stack effect ( url -- )
diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor
index 030583dbe8..b44ac80159 100755
--- a/extra/io/unix/launcher/launcher.factor
+++ b/extra/io/unix/launcher/launcher.factor
@@ -57,8 +57,8 @@ MEMO: 'arguments' ( -- parser )
: setup-redirection ( -- )
+stdin+ get read-flags 0 redirect
+stdout+ get write-flags 1 redirect
- +stderr+ get dup +stdout+ get eq?
- [ 1 2 dup2 ] [ write-flags 2 redirect ] if ;
+ +stderr+ get dup +stdout+ eq?
+ [ drop 1 2 dup2 io-error ] [ write-flags 2 redirect ] if ;
: spawn-process ( -- )
[
diff --git a/extra/line-art/line-art.factor b/extra/line-art/line-art.factor
deleted file mode 100644
index 1a0ae6993f..0000000000
--- a/extra/line-art/line-art.factor
+++ /dev/null
@@ -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
diff --git a/extra/opengl-demo-support/authors.txt b/extra/opengl/demo-support/authors.txt
similarity index 100%
rename from extra/opengl-demo-support/authors.txt
rename to extra/opengl/demo-support/authors.txt
diff --git a/extra/opengl-demo-support/opengl-demo-support.factor b/extra/opengl/demo-support/demo-support.factor
similarity index 99%
rename from extra/opengl-demo-support/opengl-demo-support.factor
rename to extra/opengl/demo-support/demo-support.factor
index ecc6458d41..59b7a3bcc3 100644
--- a/extra/opengl-demo-support/opengl-demo-support.factor
+++ b/extra/opengl/demo-support/demo-support.factor
@@ -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
diff --git a/extra/opengl-demo-support/summary.txt b/extra/opengl/demo-support/summary.txt
similarity index 100%
rename from extra/opengl-demo-support/summary.txt
rename to extra/opengl/demo-support/summary.txt
diff --git a/extra/opengl-demo-support/tags.txt b/extra/opengl/demo-support/tags.txt
similarity index 100%
rename from extra/opengl-demo-support/tags.txt
rename to extra/opengl/demo-support/tags.txt
diff --git a/extra/opengl/opengl-docs.factor b/extra/opengl/opengl-docs.factor
index cc8221baa1..cb0c9e884f 100644
--- a/extra/opengl/opengl-docs.factor
+++ b/extra/opengl/opengl-docs.factor
@@ -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."
diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor
index 22bf657637..071f85fe12 100755
--- a/extra/opengl/opengl.factor
+++ b/extra/opengl/opengl.factor
@@ -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) ;
diff --git a/extra/postgresql/postgresql-tests.factor b/extra/postgresql/postgresql-tests.factor
deleted file mode 100644
index c725882b67..0000000000
--- a/extra/postgresql/postgresql-tests.factor
+++ /dev/null
@@ -1,42 +0,0 @@
-! You will need to run 'createdb factor-test' to create the database.
-! Set username and password in the 'connect' word.
-
-IN: postgresql-test
-USING: kernel postgresql alien continuations io prettyprint
-sequences namespaces ;
-
-
-: test-connection ( host port pgopts pgtty db user pass -- bool )
- [ [ ] with-postgres ] catch "Error connecting!" "Connected!" ? print ;
-
-! just a basic demo
-
-"localhost" "" "" "" "test" "postgres" "" [
- "drop table animal" do-command
-
- "create table animal (id serial not null primary key, species varchar(256), name varchar(256), age integer)" do-command
- "insert into animal (species, name, age) values ('lion', 'Mufasa', 5)"
- do-command
-
- "select * from animal where name = 'Mufasa'" [ ] do-query
- "select * from animal where name = 'Mufasa'"
- [
- result>seq length 1 = [ "...there can only be one Mufasa..." throw ] unless
- ] do-query
-
- "insert into animal (species, name, age) values ('lion', 'Simba', 1)"
- do-command
-
- "select * from animal"
- [
- "Animal table:" print
- result>seq print-table
- ] do-query
-
- ! intentional errors
- ! [ "select asdf from animal"
- ! [ ] do-query ] catch [ "caught: " write print ] when*
- ! "select asdf from animal" [ ] do-query
- ! "aofijweafew" do-command
-] with-postgres
-
diff --git a/extra/postgresql/postgresql.factor b/extra/postgresql/postgresql.factor
deleted file mode 100644
index 9d85b6a77e..0000000000
--- a/extra/postgresql/postgresql.factor
+++ /dev/null
@@ -1,61 +0,0 @@
-! Copyright (C) 2007 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-
-! adapted from libpq-fe.h version 7.4.7
-! tested on debian linux with postgresql 7.4.7
-
-USING: arrays alien alien.syntax continuations io
-kernel math namespaces postgresql.libpq prettyprint
-quotations sequences debugger ;
-IN: postgresql
-
-SYMBOL: db
-SYMBOL: query-res
-
-: connect-postgres ( host port pgopts pgtty db user pass -- conn )
- PQsetdbLogin
- dup PQstatus zero? [ "couldn't connect to database" throw ] unless ;
-
-: with-postgres ( host port pgopts pgtty db user pass quot -- )
- [ >r connect-postgres db set r>
- [ db get PQfinish ] [ ] cleanup ] with-scope ; inline
-
-: postgres-error ( ret -- ret )
- dup zero? [ PQresultErrorMessage throw ] when ;
-
-: (do-query) ( PGconn query -- PGresult* )
- ! For queries that do not return rows, PQexec() returns PGRES_COMMAND_OK
- ! For queries that return rows, PQexec() returns PGRES_TUPLES_OK
- PQexec
- dup PQresultStatus PGRES_COMMAND_OK =
- over PQresultStatus PGRES_TUPLES_OK =
- or [
- [ PQresultErrorMessage CHAR: \n swap remove ] keep PQclear throw
- ] unless ;
-
-: (do-command) ( PGconn query -- PGresult* )
- [ (do-query) ] catch
- [
- swap
- "non-fatal error: " print
- "\tQuery: " write "'" write write "'" print
- "\t" write print
- ] when* drop ;
-
-: do-command ( str -- )
- 1quotation \ (do-command) add db get swap call ;
-
-: prepare ( str quot word -- conn quot )
- rot 1quotation swap append swap append db get swap ;
-
-: do-query ( str quot -- )
- [ (do-query) query-res set ] prepare catch
- [ rethrow ] [ query-res get PQclear ] if* ;
-
-: result>seq ( -- seq )
- query-res get [ PQnfields ] keep PQntuples
- [ swap [ query-res get -rot PQgetvalue ] with map ] with map ;
-
-: print-table ( seq -- )
- [ [ write bl ] each "\n" write ] each ;
-
diff --git a/extra/project-euler/032/032.factor b/extra/project-euler/032/032.factor
index d10326a076..2baa6f8714 100644
--- a/extra/project-euler/032/032.factor
+++ b/extra/project-euler/032/032.factor
@@ -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 ;
diff --git a/extra/project-euler/037/037.factor b/extra/project-euler/037/037.factor
new file mode 100644
index 0000000000..f2d5d17c4d
--- /dev/null
+++ b/extra/project-euler/037/037.factor
@@ -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
diff --git a/extra/project-euler/038/038.factor b/extra/project-euler/038/038.factor
new file mode 100644
index 0000000000..cbe6f2363c
--- /dev/null
+++ b/extra/project-euler/038/038.factor
@@ -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
diff --git a/extra/project-euler/039/039.factor b/extra/project-euler/039/039.factor
new file mode 100644
index 0000000000..67578dc5f2
--- /dev/null
+++ b/extra/project-euler/039/039.factor
@@ -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
diff --git a/extra/project-euler/040/040.factor b/extra/project-euler/040/040.factor
new file mode 100644
index 0000000000..8984559265
--- /dev/null
+++ b/extra/project-euler/040/040.factor
@@ -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
diff --git a/extra/project-euler/075/075.factor b/extra/project-euler/075/075.factor
new file mode 100644
index 0000000000..8399235c0d
--- /dev/null
+++ b/extra/project-euler/075/075.factor
@@ -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
diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor
index 2e718ab5a2..50adbe4953 100644
--- a/extra/project-euler/common/common.factor
+++ b/extra/project-euler/common/common.factor
@@ -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 ;
+
diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor
index feef9dbfa8..eb9d7d1300 100644
--- a/extra/project-euler/project-euler.factor
+++ b/extra/project-euler/project-euler.factor
@@ -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
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index 65b0d1beb0..d89c5eec89 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -141,6 +141,9 @@ PRIVATE>
: ?third ( seq -- third/f ) 2 swap ?nth ; inline
: ?fourth ( seq -- fourth/f ) 3 swap ?nth ; inline
+: accumulator ( quot -- quot vec )
+ V{ } clone [ [ push ] curry compose ] keep ;
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! List the positions of obj in seq
diff --git a/extra/unicode/case/case.factor b/extra/unicode/case/case.factor
index ee9e2a0381..8129ec17f8 100755
--- a/extra/unicode/case/case.factor
+++ b/extra/unicode/case/case.factor
@@ -1,6 +1,6 @@
USING: kernel unicode.data sequences sequences.next namespaces
assocs.lib unicode.normalize math unicode.categories combinators
-assocs ;
+assocs strings splitting ;
IN: unicode.case
: ch>lower ( ch -- lower ) simple-lower at-default ;
diff --git a/misc/Factor.tmbundle/Support/lib/tm_factor.rb b/misc/Factor.tmbundle/Support/lib/tm_factor.rb
index 54272e5e36..2775a12ae9 100644
--- a/misc/Factor.tmbundle/Support/lib/tm_factor.rb
+++ b/misc/Factor.tmbundle/Support/lib/tm_factor.rb
@@ -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
diff --git a/misc/factor.sh b/misc/factor.sh
index 39a15f93dc..032b0b3184 100755
--- a/misc/factor.sh
+++ b/misc/factor.sh
@@ -289,7 +289,7 @@ install_libraries() {
}
usage() {
- echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap"
+ echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap|wget-bootstrap"
}
case "$1" in
@@ -299,5 +299,6 @@ case "$1" in
quick-update) update; refresh_image ;;
update) update; update_bootstrap ;;
bootstrap) get_config_info; bootstrap ;;
+ wget-bootstrap) get_config_info; delete_boot_images; get_boot_image; bootstrap ;;
*) usage ;;
esac