From d56acaab86caf7a45ecdf48163863dd9cc58e08d Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 29 Jan 2008 20:50:15 -0800
Subject: [PATCH 01/25] Fix broken opengl shader words

---
 extra/opengl/opengl.factor | 17 +++++++++--------
 1 file changed, 9 insertions(+), 8 deletions(-)

diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor
index 4ea91b867b..2c1d4de75c 100755
--- a/extra/opengl/opengl.factor
+++ b/extra/opengl/opengl.factor
@@ -255,7 +255,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
 
@@ -294,9 +294,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 ;
 
@@ -330,9 +329,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 ;
@@ -342,7 +342,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 -- )

From 6394eb70bf82005eff70258aa91f133eea7ef10c Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Wed, 30 Jan 2008 00:50:18 -0500
Subject: [PATCH 02/25] Solution to Project Euler problem 37

---
 extra/project-euler/037/037.factor       | 52 ++++++++++++++++++++++++
 extra/project-euler/project-euler.factor |  4 +-
 2 files changed, 54 insertions(+), 2 deletions(-)
 create mode 100644 extra/project-euler/037/037.factor

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/project-euler.factor b/extra/project-euler/project-euler.factor
index feef9dbfa8..fbb62961a9 100644
--- a/extra/project-euler/project-euler.factor
+++ b/extra/project-euler/project-euler.factor
@@ -11,8 +11,8 @@ 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.067 project-euler.134 project-euler.169
+    project-euler.173 project-euler.175 ;
 IN: project-euler
 
 <PRIVATE

From ae31bc65d25c5a7b662b41c68aed42bda5e1f830 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 29 Jan 2008 22:01:06 -0800
Subject: [PATCH 03/25] Add with-software-renderer combinator to cocoa.views .
 Hack up shader code in line-art to make it display properly with the Apple
 software OpenGL implementation

---
 extra/cocoa/views/views.factor | 15 ++++++++-
 extra/line-art/line-art.factor | 56 +++++++++++++++++-----------------
 2 files changed, 42 insertions(+), 29 deletions(-)

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/line-art/line-art.factor b/extra/line-art/line-art.factor
index 1a0ae6993f..9856921a51 100644
--- a/extra/line-art/line-art.factor
+++ b/extra/line-art/line-art.factor
@@ -57,13 +57,7 @@ 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;
-}
+const float DEPTH_RATIO_THRESHOLD = 1.001, SAMPLE_SPREAD = 1.0/512.0;
 
 float
 depth_sample(vec2 c)
@@ -97,33 +91,39 @@ border_factor(vec2 c)
          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);
+
+    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));
     
-    float normal_border = 1.0 - min6(
-        dot(normal1, normal2),
-        dot(normal1, normal3),
-        dot(normal1, normal4),
-        dot(normal2, normal3),
-        dot(normal2, normal4),
-        dot(normal3, normal4)
-    );
+        vec3 ratios1 = depths.xxx/depths.yzw, ratios2 = depths.yyz/depths.zww;
     
-    return normal_border;
+        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

From 7666949e13397dda79dda6ddb6d68d976119ca98 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Thu, 31 Jan 2008 20:22:19 -0800
Subject: [PATCH 04/25] byte-length generic word for determining alien buffer
 sizes of byte-arrays and float-arrays

---
 core/alien/alien-docs.factor               | 4 ++++
 core/alien/alien.factor                    | 2 ++
 core/byte-arrays/byte-arrays.factor        | 3 +++
 core/float-arrays/float-arrays-docs.factor | 2 +-
 core/float-arrays/float-arrays.factor      | 3 ++-
 5 files changed, 12 insertions(+), 2 deletions(-)

diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor
index 8fee0e8c3e..8ae89ed5b1 100755
--- a/core/alien/alien-docs.factor
+++ b/core/alien/alien-docs.factor
@@ -34,6 +34,10 @@ HELP: <alien>
 { $description "Creates an alien object, wrapping a raw memory address." }
 { $notes "Alien objects are invalidated between image saves and loads." } ;
 
+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-ptr
 { $class-description "Class of objects consisting of aliens, byte arrays and " { $link f } ". These objects can convert to pointer C types, which are all aliases of " { $snippet "void*" } "." } ;
 
diff --git a/core/alien/alien.factor b/core/alien/alien.factor
index 1c8163e2fa..4b899a15e4 100755
--- a/core/alien/alien.factor
+++ b/core/alien/alien.factor
@@ -28,6 +28,8 @@ PREDICATE: alien pinned-alien
 UNION: pinned-c-ptr
     pinned-alien POSTPONE: f ;
 
+GENERIC: byte-length ( seq -- n ) flushable
+
 M: f expired? drop t ;
 
 : <alien> ( address -- alien )
diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor
index f82569c270..d65f243d71 100755
--- a/core/byte-arrays/byte-arrays.factor
+++ b/core/byte-arrays/byte-arrays.factor
@@ -15,6 +15,9 @@ M: byte-array new drop <byte-array> ;
 M: byte-array equal?
     over byte-array? [ sequence= ] [ 2drop f ] if ;
 
+M: byte-array byte-length
+    length ;
+
 INSTANCE: byte-array sequence
 INSTANCE: byte-array simple-c-ptr
 INSTANCE: byte-array c-ptr
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/core/float-arrays/float-arrays.factor b/core/float-arrays/float-arrays.factor
index ba0b2bb61d..42a2db7cd8 100755
--- a/core/float-arrays/float-arrays.factor
+++ b/core/float-arrays/float-arrays.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel kernel.private alien sequences
+USING: kernel kernel.private alien alien.c-types sequences
 sequences.private math math.private ;
 IN: float-arrays
 
@@ -12,6 +12,7 @@ PRIVATE>
 
 M: float-array clone (clone) ;
 M: float-array length array-capacity ;
+M: float-array byte-length array-capacity "float" heap-size * ;
 
 M: float-array nth-unsafe
     float-array@ alien-double ;

From f3b9e889ff6a41ec68937ab294f1b94b12012270 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Thu, 31 Jan 2008 20:24:08 -0800
Subject: [PATCH 05/25] Start work on making bunny demos use vertex buffers to
 draw

---
 extra/bunny/bunny.factor             | 13 ++++++-
 extra/cel-shading/cel-shading.factor | 54 ++++++++++++++++++++--------
 extra/line-art/line-art.factor       |  5 ++-
 extra/opengl/opengl-docs.factor      |  6 ++--
 extra/opengl/opengl.factor           | 28 +++++++++++++--
 5 files changed, 83 insertions(+), 23 deletions(-)

diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor
index 3042b87ad6..73a3efc742 100644
--- a/extra/bunny/bunny.factor
+++ b/extra/bunny/bunny.factor
@@ -3,7 +3,8 @@ 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 ;
 IN: bunny
 
 : numbers ( str -- seq )
@@ -45,6 +46,16 @@ IN: bunny
         <file-reader> parse-model [ normals ] 2keep 3array
     ] time ;
 
+: make-vertex-buffers ( model -- array element-array )
+    [
+        [ 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>
+    ] bi ;
+
 : model-path "bun_zipper.ply" ;
 
 : model-url "http://factorcode.org/bun_zipper.ply" ;
diff --git a/extra/cel-shading/cel-shading.factor b/extra/cel-shading/cel-shading.factor
index 64d23275e9..992fd9655d 100644
--- a/extra/cel-shading/cel-shading.factor
+++ b/extra/cel-shading/cel-shading.factor
@@ -4,12 +4,14 @@ USING: arrays bunny combinators.lib io io.files kernel
        sequences ui ui.gadgets ui.render ;
 IN: cel-shading
 
-TUPLE: cel-shading-gadget model program ;
+TUPLE: cel-shading-gadget model program vertices elements ;
 
 : <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 ;
+    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;
@@ -53,34 +55,58 @@ main()
 
 ;
 
-: cel-shading-program ( -- program )
+: make-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
+    "2.0" {
+        "GL_ARB_shader_objects"
+        "GL_ARB_vertex_buffer_object"
+    } 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 ;
+    dup cel-shading-gadget-model make-vertex-buffers
+    make-cel-shading-program roll {
+        set-cel-shading-gadget-vertices
+        set-cel-shading-gadget-elements
+        set-cel-shading-gadget-program
+    } set-slots ;
 
 M: cel-shading-gadget ungraft* ( gadget -- )
-    cel-shading-gadget-program [ delete-gl-program ] when* ;
+    {
+        [ cel-shading-gadget-program [ delete-gl-program ] when* ] 
+        [ cel-shading-gadget-elements [ delete-gl-buffer ] when* ]
+        [ cel-shading-gadget-vertices [ delete-gl-buffer ] when* ]
+    } call-with ;
 
 : 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 ;
+    [ 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
+        dup {
+            cel-shading-gadget-vertices
+            cel-shading-gadget-elements
+        } get-slots [
+            GL_VERTEX_ARRAY GL_NORMAL_ARRAY 2array [
+                GL_FLOAT 0 0 buffer-offset glNormalPointer
+                cel-shading-gadget-model dup
+                first length 3 * 4 * buffer-offset
+                3 GL_FLOAT 0 roll glVertexPointer
+                third length 3 *
+                GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements
+            ] all-enabled-client-state
+        ] with-array-element-buffers
     ] with-gl-program ;
 
 : cel-shading-window ( -- )
diff --git a/extra/line-art/line-art.factor b/extra/line-art/line-art.factor
index 9856921a51..d78ea8a4ee 100644
--- a/extra/line-art/line-art.factor
+++ b/extra/line-art/line-art.factor
@@ -187,7 +187,7 @@ main()
     ] if ;
     
 M: line-art-gadget graft* ( gadget -- )
-    [ "2.0" { "GL_ARB_draw_buffers"
+    "2.0" { "GL_ARB_draw_buffers"
             "GL_ARB_shader_objects"
             "GL_ARB_multitexture"
             "GL_ARB_texture_float" }
@@ -196,8 +196,7 @@ M: line-art-gadget graft* ( gadget -- )
     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 ;
+    (line-art-step2-program) swap set-line-art-gadget-step2-program ;
 
 M: line-art-gadget ungraft* ( gadget -- )
     dup line-art-gadget-framebuffer [
diff --git a/extra/opengl/opengl-docs.factor b/extra/opengl/opengl-docs.factor
index cc8221baa1..63875e91a8 100644
--- a/extra/opengl/opengl-docs.factor
+++ b/extra/opengl/opengl-docs.factor
@@ -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." } }
diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor
index 2c1d4de75c..a6aecf1b77 100755
--- a/extra/opengl/opengl.factor
+++ b/extra/opengl/opengl.factor
@@ -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 ? ;

From e37f2101c6d355e437d4ca9654e59f6354473748 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Fri, 1 Feb 2008 14:45:29 -0500
Subject: [PATCH 06/25] Solution to Project Euler problem 38

---
 extra/project-euler/032/032.factor       |  5 +--
 extra/project-euler/038/038.factor       | 55 ++++++++++++++++++++++++
 extra/project-euler/common/common.factor |  6 ++-
 extra/project-euler/project-euler.factor |  4 +-
 4 files changed, 63 insertions(+), 7 deletions(-)
 create mode 100644 extra/project-euler/038/038.factor

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/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/common/common.factor b/extra/project-euler/common/common.factor
index 2e718ab5a2..609492c724 100644
--- a/extra/project-euler/common/common.factor
+++ b/extra/project-euler/common/common.factor
@@ -1,5 +1,5 @@
 USING: arrays combinators.lib kernel math math.functions math.miller-rabin
-    math.parser math.primes.factors math.ranges namespaces sequences ;
+    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,6 +12,7 @@ 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
@@ -67,6 +68,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 )
diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor
index fbb62961a9..0037e4462f 100644
--- a/extra/project-euler/project-euler.factor
+++ b/extra/project-euler/project-euler.factor
@@ -11,8 +11,8 @@ 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.037 project-euler.067 project-euler.134 project-euler.169
-    project-euler.173 project-euler.175 ;
+    project-euler.037 project-euler.038 project-euler.067 project-euler.134
+    project-euler.169 project-euler.173 project-euler.175 ;
 IN: project-euler
 
 <PRIVATE

From 6f2b91d4a4a9acdd83161a0d1ae884b423c59ae4 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Fri, 1 Feb 2008 18:10:32 -0800
Subject: [PATCH 07/25] Move byte-length generic and methods into alien.c-types

---
 core/alien/alien-docs.factor           | 4 ----
 core/alien/alien.factor                | 2 --
 core/alien/c-types/c-types-docs.factor | 4 ++++
 core/alien/c-types/c-types.factor      | 8 +++++++-
 core/byte-arrays/byte-arrays.factor    | 2 --
 core/float-arrays/float-arrays.factor  | 3 +--
 6 files changed, 12 insertions(+), 11 deletions(-)

diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor
index 8ae89ed5b1..8fee0e8c3e 100755
--- a/core/alien/alien-docs.factor
+++ b/core/alien/alien-docs.factor
@@ -34,10 +34,6 @@ HELP: <alien>
 { $description "Creates an alien object, wrapping a raw memory address." }
 { $notes "Alien objects are invalidated between image saves and loads." } ;
 
-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-ptr
 { $class-description "Class of objects consisting of aliens, byte arrays and " { $link f } ". These objects can convert to pointer C types, which are all aliases of " { $snippet "void*" } "." } ;
 
diff --git a/core/alien/alien.factor b/core/alien/alien.factor
index 4b899a15e4..1c8163e2fa 100755
--- a/core/alien/alien.factor
+++ b/core/alien/alien.factor
@@ -28,8 +28,6 @@ PREDICATE: alien pinned-alien
 UNION: pinned-c-ptr
     pinned-alien POSTPONE: f ;
 
-GENERIC: byte-length ( seq -- n ) flushable
-
 M: f expired? drop t ;
 
 : <alien> ( address -- alien )
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 1ecfa37ee6..47f9fd0326 100755
--- a/core/alien/c-types/c-types.factor
+++ b/core/alien/c-types/c-types.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2004, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: byte-arrays arrays generator.registers assocs
+USING: byte-arrays float-arrays arrays generator.registers assocs
 kernel kernel.private libc math namespaces parser sequences
 strings words assocs splitting math.parser cpu.architecture
 alien quotations system compiler.units ;
@@ -107,6 +107,12 @@ M: string stack-size c-type stack-size ;
 
 M: c-type stack-size c-type-size ;
 
+GENERIC: byte-length ( seq -- n ) flushable
+
+M: float-array byte-length length "float" heap-size * ;
+
+M: byte-array byte-length length ;
+
 : c-getter ( name -- quot )
     c-type c-type-getter [
         [ "Cannot read struct fields with type" throw ]
diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor
index 295c6c4384..401b151ad0 100755
--- a/core/byte-arrays/byte-arrays.factor
+++ b/core/byte-arrays/byte-arrays.factor
@@ -15,8 +15,6 @@ M: byte-array new drop <byte-array> ;
 M: byte-array equal?
     over byte-array? [ sequence= ] [ 2drop f ] if ;
 
-M: byte-array byte-length
-    length ;
 M: byte-array resize
     resize-byte-array ;
 
diff --git a/core/float-arrays/float-arrays.factor b/core/float-arrays/float-arrays.factor
index 948e41ef7a..445edd550a 100755
--- a/core/float-arrays/float-arrays.factor
+++ b/core/float-arrays/float-arrays.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel kernel.private alien alien.c-types sequences
+USING: kernel kernel.private alien sequences
 sequences.private math math.private ;
 IN: float-arrays
 
@@ -12,7 +12,6 @@ PRIVATE>
 
 M: float-array clone (clone) ;
 M: float-array length array-capacity ;
-M: float-array byte-length array-capacity "float" heap-size * ;
 
 M: float-array nth-unsafe
     float-array@ alien-double ;

From a0dad18f4f96ffc0a93a07f90a7c42453c5e6ebb Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Sat, 2 Feb 2008 13:37:53 -0500
Subject: [PATCH 08/25] Solution to Project Euler problem 39

---
 extra/project-euler/039/039.factor       | 76 ++++++++++++++++++++++++
 extra/project-euler/project-euler.factor |  8 +--
 2 files changed, 80 insertions(+), 4 deletions(-)
 create mode 100644 extra/project-euler/039/039.factor

diff --git a/extra/project-euler/039/039.factor b/extra/project-euler/039/039.factor
new file mode 100644
index 0000000000..4df7ba610a
--- /dev/null
+++ b/extra/project-euler/039/039.factor
@@ -0,0 +1,76 @@
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays combinators.lib kernel math math.matrices math.ranges namespaces
+    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
+
+! 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 ;
+
+: transform ( triple matrix -- new-triple )
+    [ 1array ] dip m. first ;
+
+: 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 ;
+
+: (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/project-euler.factor b/extra/project-euler/project-euler.factor
index 0037e4462f..86dff7a192 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,8 @@ 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.037 project-euler.038 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.067
+    project-euler.134 project-euler.169 project-euler.173 project-euler.175 ;
 IN: project-euler
 
 <PRIVATE

From 9667afcb816c042e4c396a0b048cbebdbd9b75f0 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 2 Feb 2008 13:14:22 -0800
Subject: [PATCH 09/25] cel-shading, line-art, and bunny touch their magic
 rings together and become Super Bunny Demo

---
 core/alien/c-types/c-types.factor             |   2 +-
 extra/bunny/bunny.factor                      | 158 ++++-------
 extra/cel-shading/cel-shading.factor          | 115 --------
 extra/line-art/line-art.factor                | 254 ------------------
 .../demo-support}/authors.txt                 |   0
 .../demo-support/demo-support.factor}         |   2 +-
 .../demo-support}/summary.txt                 |   0
 .../demo-support}/tags.txt                    |   0
 extra/opengl/opengl.factor                    |  11 +-
 9 files changed, 63 insertions(+), 479 deletions(-)
 delete mode 100644 extra/cel-shading/cel-shading.factor
 delete mode 100644 extra/line-art/line-art.factor
 rename extra/{opengl-demo-support => opengl/demo-support}/authors.txt (100%)
 rename extra/{opengl-demo-support/opengl-demo-support.factor => opengl/demo-support/demo-support.factor} (99%)
 rename extra/{opengl-demo-support => opengl/demo-support}/summary.txt (100%)
 rename extra/{opengl-demo-support => opengl/demo-support}/tags.txt (100%)

diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor
index d260eb9b8f..8ab703eb7e 100755
--- a/core/alien/c-types/c-types.factor
+++ b/core/alien/c-types/c-types.factor
@@ -109,7 +109,7 @@ M: c-type stack-size c-type-size ;
 
 GENERIC: byte-length ( seq -- n ) flushable
 
-M: float-array byte-length length "float" heap-size * ;
+M: float-array byte-length length "double" heap-size * ;
 
 M: byte-array byte-length length ;
 
diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor
index 479d9cb39b..efebefcef3 100755
--- a/extra/bunny/bunny.factor
+++ b/extra/bunny/bunny.factor
@@ -1,123 +1,73 @@
-! 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.cleave
-float-arrays ;
+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 ;
+<PRIVATE
 
-: (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* ;
+PRIVATE>
 
-: parse-model ( stream -- vs is )
-    [
-        100000 <vector> 100000 <vector> (parse-model)
-    ] with-stream
-    [
-        over length # " vertices, " %
-        dup length # " triangles" %
-    ] "" make print ;
+TUPLE: bunny-gadget model geom draw-seq draw-n ;
 
-: 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> ( -- bunny-gadget )
+    0.0 0.0 0.375 <demo-gadget>
+    maybe-download read-model {
+        set-delegate
+        set-bunny-gadget-model
+    } bunny-gadget construct ;
 
-: normal ( ns vs triple -- )
-    [ n ] keep [ rot [ v+ ] change-nth ] each-with2 ;
+: bunny-gadget-draw ( gadget -- draw )
+    { bunny-gadget-draw-n bunny-gadget-draw-seq }
+    get-slots nth ;
 
-: normals ( vs is -- ns )
-    over length { 0.0 0.0 0.0 } <array> -rot
-    [ >r 2dup r> normal ] each drop
-    [ normalize ] map ;
+: 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 ;
 
-: read-model ( stream -- model )
-    "Reading model" print flush [
-        <file-reader> parse-model [ normals ] 2keep 3array
-    ] time ;
-
-: make-vertex-buffers ( model -- array element-array )
-    [
-        [ 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>
-    ] bi ;
-
-: 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/cel-shading/cel-shading.factor b/extra/cel-shading/cel-shading.factor
deleted file mode 100644
index 992fd9655d..0000000000
--- a/extra/cel-shading/cel-shading.factor
+++ /dev/null
@@ -1,115 +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 vertices elements ;
-
-: <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); 
-}
-
-;
-
-: make-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"
-        "GL_ARB_vertex_buffer_object"
-    } require-gl-version-or-extensions
-    0.0 0.0 0.0 1.0 glClearColor
-    GL_CULL_FACE glEnable
-    GL_DEPTH_TEST glEnable
-    dup cel-shading-gadget-model make-vertex-buffers
-    make-cel-shading-program roll {
-        set-cel-shading-gadget-vertices
-        set-cel-shading-gadget-elements
-        set-cel-shading-gadget-program
-    } set-slots ;
-
-M: cel-shading-gadget ungraft* ( gadget -- )
-    {
-        [ cel-shading-gadget-program [ delete-gl-program ] when* ] 
-        [ cel-shading-gadget-elements [ delete-gl-buffer ] when* ]
-        [ cel-shading-gadget-vertices [ delete-gl-buffer ] when* ]
-    } call-with ;
-
-: 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
-        dup {
-            cel-shading-gadget-vertices
-            cel-shading-gadget-elements
-        } get-slots [
-            GL_VERTEX_ARRAY GL_NORMAL_ARRAY 2array [
-                GL_FLOAT 0 0 buffer-offset glNormalPointer
-                cel-shading-gadget-model dup
-                first length 3 * 4 * buffer-offset
-                3 GL_FLOAT 0 roll glVertexPointer
-                third length 3 *
-                GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements
-            ] all-enabled-client-state
-        ] with-array-element-buffers
-    ] with-gl-program ;
-
-: cel-shading-window ( -- )
-    [ <cel-shading-gadget> "Cel Shading" open-window ] with-ui ;
-    
-MAIN: cel-shading-window
diff --git a/extra/line-art/line-art.factor b/extra/line-art/line-art.factor
deleted file mode 100644
index d78ea8a4ee..0000000000
--- a/extra/line-art/line-art.factor
+++ /dev/null
@@ -1,254 +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, 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));
-}
-
-;
-
-: (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 ;
-
-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.factor b/extra/opengl/opengl.factor
index a6aecf1b77..9b26662cef 100755
--- a/extra/opengl/opengl.factor
+++ b/extra/opengl/opengl.factor
@@ -444,8 +444,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) ;

From 8b207d1f48891d201387da7930419e9287745308 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Sat, 2 Feb 2008 17:22:20 -0500
Subject: [PATCH 10/25] Solution to Project Euler problem 75

---
 extra/project-euler/039/039.factor       | 17 +-----
 extra/project-euler/075/075.factor       | 78 ++++++++++++++++++++++++
 extra/project-euler/common/common.factor | 16 ++++-
 extra/project-euler/project-euler.factor |  3 +-
 4 files changed, 98 insertions(+), 16 deletions(-)
 create mode 100644 extra/project-euler/075/075.factor

diff --git a/extra/project-euler/039/039.factor b/extra/project-euler/039/039.factor
index 4df7ba610a..67578dc5f2 100644
--- a/extra/project-euler/039/039.factor
+++ b/extra/project-euler/039/039.factor
@@ -1,7 +1,7 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators.lib kernel math math.matrices math.ranges namespaces
-    sequences ;
+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
@@ -21,6 +21,7 @@ IN: project-euler.039
 ! --------
 
 ! 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
@@ -39,18 +40,6 @@ SYMBOL: p-count
     max-p 1- over <range> p-count get
     [ [ 1+ ] change-nth ] curry each ;
 
-: transform ( triple matrix -- new-triple )
-    [ 1array ] dip m. first ;
-
-: 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 ;
-
 : (count-perimeters) ( seq -- )
     dup sum max-p < [
         dup sum adjust-p-count
diff --git a/extra/project-euler/075/075.factor b/extra/project-euler/075/075.factor
new file mode 100644
index 0000000000..f8ee9d50db
--- /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 number of
+! indexes that equal 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 609492c724..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 sorting ;
+    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
@@ -16,6 +17,7 @@ IN: project-euler.common
 ! propagate-all - #18, #67
 ! sum-proper-divisors - #21
 ! tau* - #12
+! [uad]-transform - #39, #75
 
 
 : nth-pair ( n seq -- nth next )
@@ -45,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 )
@@ -101,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 86dff7a192..f5766536ef 100644
--- a/extra/project-euler/project-euler.factor
+++ b/extra/project-euler/project-euler.factor
@@ -12,7 +12,8 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time
     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.037 project-euler.038 project-euler.039 project-euler.067
-    project-euler.134 project-euler.169 project-euler.173 project-euler.175 ;
+    project-euler.075 project-euler.134 project-euler.169 project-euler.173
+    project-euler.175 ;
 IN: project-euler
 
 <PRIVATE

From ae51681750da901134dfc6fc0de3ad948fc22999 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 2 Feb 2008 14:24:03 -0800
Subject: [PATCH 11/25] Fix has-gl-extensions? when requested extensions are
 not contiguous in the gl-extensions string

---
 extra/opengl/opengl.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor
index e000a3103e..d26c2c7685 100755
--- a/extra/opengl/opengl.factor
+++ b/extra/opengl/opengl.factor
@@ -401,7 +401,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" %

From 7da1da5fff0e539fefd5772b891977f283639d65 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 2 Feb 2008 15:33:05 -0800
Subject: [PATCH 12/25] Modularize the new bunny demo, and adjust the bikeshed
 parameters a bit

---
 extra/bunny/cel-shaded/cel-shaded.factor      |  95 +++++++
 .../fixed-pipeline/fixed-pipeline.factor      |  25 ++
 extra/bunny/model/model.factor                | 114 +++++++++
 extra/bunny/outlined/outlined.factor          | 235 ++++++++++++++++++
 4 files changed, 469 insertions(+)
 create mode 100644 extra/bunny/cel-shaded/cel-shaded.factor
 create mode 100644 extra/bunny/fixed-pipeline/fixed-pipeline.factor
 create mode 100644 extra/bunny/model/model.factor
 create mode 100644 extra/bunny/outlined/outlined.factor

diff --git a/extra/bunny/cel-shaded/cel-shaded.factor b/extra/bunny/cel-shaded/cel-shaded.factor
new file mode 100644
index 0000000000..eb0924f50e
--- /dev/null
+++ b/extra/bunny/cel-shaded/cel-shaded.factor
@@ -0,0 +1,95 @@
+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 -- )
+    dup [
+        {
+            [ "light_direction" glGetUniformLocation 1.0 -1.0 1.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 ]
+            [ "shininess" glGetUniformLocation 100.0 glUniform1f ]
+        } call-with
+        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..a19adcb782
--- /dev/null
+++ b/extra/bunny/model/model.factor
@@ -0,0 +1,114 @@
+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..021ac6b4d8
--- /dev/null
+++ b/extra/bunny/outlined/outlined.factor
@@ -0,0 +1,235 @@
+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 ;
+
+: remake-framebuffer-if-needed ( draw -- )
+    dup bunny-outlined-gadget rect-dim
+    over bunny-outlined-framebuffer-dim
+    over =
+    [ 2drop ]
+    [
+        swap >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 dup [
+        {
+            [ "colormap"  glGetUniformLocation 0 glUniform1i ]
+            [ "normalmap" glGetUniformLocation 1 glUniform1i ]
+            [ "depthmap"  glGetUniformLocation 2 glUniform1i ]
+            [ "line_color" glGetUniformLocation 0.1 0.0 0.1 1.0 glUniform4f ]
+        } call-with
+        { -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* ]
+        [ 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 ;

From 557bde6206e5243140307bff964a0b73e204d139 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Sat, 2 Feb 2008 18:53:32 -0500
Subject: [PATCH 13/25] Solution to Project Euler problem 40

---
 extra/project-euler/040/040.factor       | 51 ++++++++++++++++++++++++
 extra/project-euler/075/075.factor       |  4 +-
 extra/project-euler/project-euler.factor |  6 +--
 3 files changed, 56 insertions(+), 5 deletions(-)
 create mode 100644 extra/project-euler/040/040.factor

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
index f8ee9d50db..8399235c0d 100644
--- a/extra/project-euler/075/075.factor
+++ b/extra/project-euler/075/075.factor
@@ -39,8 +39,8 @@ IN: project-euler.075
 ! 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 number of
-! indexes that equal one.
+! (to account for non-primitive triples). The answer is just the total number
+! of indexes that are equal to one.
 
 SYMBOL: p-count
 
diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor
index f5766536ef..eb9d7d1300 100644
--- a/extra/project-euler/project-euler.factor
+++ b/extra/project-euler/project-euler.factor
@@ -11,9 +11,9 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time
     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.037 project-euler.038 project-euler.039 project-euler.067
-    project-euler.075 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

From 4e4e4ee157fce3dc3daa8e6a4861897065cad78b Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 2 Feb 2008 18:15:22 -0800
Subject: [PATCH 14/25] Make setting up shader uniform parameters nicer from
 with-gl-program

---
 extra/bunny/bunny.factor                 |  4 ---
 extra/bunny/cel-shaded/cel-shaded.factor | 17 +++++-------
 extra/bunny/outlined/outlined.factor     | 34 +++++++++++++-----------
 extra/opengl/opengl-docs.factor          | 25 +++++++++++++----
 extra/opengl/opengl.factor               | 18 +++++++++++--
 5 files changed, 62 insertions(+), 36 deletions(-)

diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor
index efebefcef3..38f8e32fb6 100755
--- a/extra/bunny/bunny.factor
+++ b/extra/bunny/bunny.factor
@@ -8,10 +8,6 @@ ui.gestures
 bunny.fixed-pipeline bunny.cel-shaded bunny.outlined bunny.model ;
 IN: bunny
 
-<PRIVATE
-
-PRIVATE>
-
 TUPLE: bunny-gadget model geom draw-seq draw-n ;
 
 : <bunny-gadget> ( -- bunny-gadget )
diff --git a/extra/bunny/cel-shaded/cel-shaded.factor b/extra/bunny/cel-shaded/cel-shaded.factor
index eb0924f50e..fc42ca971e 100644
--- a/extra/bunny/cel-shaded/cel-shaded.factor
+++ b/extra/bunny/cel-shaded/cel-shaded.factor
@@ -76,16 +76,13 @@ TUPLE: bunny-cel-shaded program ;
     ] [ f ] if ;
 
 : (draw-cel-shaded-bunny) ( geom program -- )
-    dup [
-        {
-            [ "light_direction" glGetUniformLocation 1.0 -1.0 1.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 ]
-            [ "shininess" glGetUniformLocation 100.0 glUniform1f ]
-        } call-with
-        bunny-geom
-    ] with-gl-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) ;
diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor
index 021ac6b4d8..9de341561c 100644
--- a/extra/bunny/outlined/outlined.factor
+++ b/extra/bunny/outlined/outlined.factor
@@ -168,13 +168,24 @@ TUPLE: bunny-outlined
         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 >r
+        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)
@@ -209,15 +220,12 @@ TUPLE: bunny-outlined
     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 dup [
-        {
-            [ "colormap"  glGetUniformLocation 0 glUniform1i ]
-            [ "normalmap" glGetUniformLocation 1 glUniform1i ]
-            [ "depthmap"  glGetUniformLocation 2 glUniform1i ]
-            [ "line_color" glGetUniformLocation 0.1 0.0 0.1 1.0 glUniform4f ]
-        } call-with
-        { -1.0 -1.0 } { 1.0 1.0 } rect-vertices
-    ] with-gl-program ;
+    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
@@ -227,9 +235,5 @@ M: bunny-outlined dispose
     {
         [ bunny-outlined-pass1-program [ delete-gl-program ] when* ]
         [ bunny-outlined-pass2-program [ delete-gl-program ] when* ]
-        [ 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 ]
+        [ dispose-framebuffer ]
     } call-with ;
diff --git a/extra/opengl/opengl-docs.factor b/extra/opengl/opengl-docs.factor
index 63875e91a8..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
@@ -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 d26c2c7685..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 ;
@@ -382,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 )

From 303cb0edc2efaedfab5d8e38cf7ab18a5a975d65 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 3 Feb 2008 03:48:08 -0600
Subject: [PATCH 15/25] Fix missing math.bitfields

---
 extra/x11/windows/windows.factor | 16 +---------------
 extra/x11/xlib/xlib.factor       | 22 +++++++++++-----------
 2 files changed, 12 insertions(+), 26 deletions(-)

diff --git a/extra/x11/windows/windows.factor b/extra/x11/windows/windows.factor
index b3220d44bd..f9158c2956 100755
--- a/extra/x11/windows/windows.factor
+++ b/extra/x11/windows/windows.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types hashtables kernel math math.vectors
+USING: alien alien.c-types hashtables kernel math math.vectors math.bitfields
 namespaces sequences x11.xlib x11.constants x11.glx ;
 IN: x11.windows
 
@@ -12,7 +12,6 @@ IN: x11.windows
     XCreateColormap ;
 
 : event-mask ( -- n )
-<<<<<<< HEAD:extra/x11/windows/windows.factor
     {
         ExposureMask
         StructureNotifyMask
@@ -26,19 +25,6 @@ IN: x11.windows
         LeaveWindowMask
         PropertyChangeMask
     } flags ;
-=======
-    ExposureMask
-    StructureNotifyMask bitor
-    KeyPressMask bitor
-    KeyReleaseMask bitor
-    ButtonPressMask     bitor
-    ButtonReleaseMask bitor
-    PointerMotionMask bitor
-    FocusChangeMask bitor
-    EnterWindowMask bitor
-    LeaveWindowMask bitor
-    PropertyChangeMask bitor ;
->>>>>>> a05c18152b59073c49aa313ba685516310ec74a8:extra/x11/windows/windows.factor
 
 : window-attributes ( visinfo -- attributes )
     "XSetWindowAttributes" <c-object>
diff --git a/extra/x11/xlib/xlib.factor b/extra/x11/xlib/xlib.factor
index 230b24c6d0..70006c9f64 100755
--- a/extra/x11/xlib/xlib.factor
+++ b/extra/x11/xlib/xlib.factor
@@ -12,7 +12,7 @@
 ! and note the section.
 
 USING: kernel arrays alien alien.c-types alien.syntax
-math words sequences namespaces continuations ;
+math math.bitfields words sequences namespaces continuations ;
 IN: x11.xlib
 
 LIBRARY: xlib
@@ -1078,16 +1078,16 @@ FUNCTION: Status XWithdrawWindow (
 
 ! 17.1.7 - Setting and Reading the WM_NORMAL_HINTS Property
 
-: USPosition	1 0 shift ; inline
-: USSize	1 1 shift ; inline
-: PPosition	1 2 shift ; inline
-: PSize		1 3 shift ; inline
-: PMinSize	1 4 shift ; inline
-: PMaxSize	1 5 shift ; inline
-: PResizeInc	1 6 shift ; inline
-: PAspect	1 7 shift ; inline
-: PBaseSize	1 8 shift ; inline
-: PWinGravity	1 9 shift ; inline
+: USPosition    1 0 shift ; inline
+: USSize        1 1 shift ; inline
+: PPosition     1 2 shift ; inline
+: PSize         1 3 shift ; inline
+: PMinSize      1 4 shift ; inline
+: PMaxSize      1 5 shift ; inline
+: PResizeInc    1 6 shift ; inline
+: PAspect       1 7 shift ; inline
+: PBaseSize     1 8 shift ; inline
+: PWinGravity   1 9 shift ; inline
 : PAllHints 
     { PPosition PSize PMinSize PMaxSize PResizeInc PAspect } flags ; foldable
 

From 7a5d48cadb7c67c0859cd71879a68b7c58e355c7 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 3 Feb 2008 03:48:29 -0600
Subject: [PATCH 16/25] shuffle: add nrev

---
 extra/shuffle/shuffle.factor | 5 +++++
 1 file changed, 5 insertions(+)

diff --git a/extra/shuffle/shuffle.factor b/extra/shuffle/shuffle.factor
index f9f8b030a8..f139a4864e 100644
--- a/extra/shuffle/shuffle.factor
+++ b/extra/shuffle/shuffle.factor
@@ -30,3 +30,8 @@ MACRO: ntuck ( n -- ) 2 + [ dup , -nrot ] bake ;
 : 4drop ( a b c d -- ) 3drop drop ; inline
 
 : tuckd ( x y z -- z x y z ) 2 ntuck ; inline
+
+MACRO: nrev ( n -- quot )
+  [ 1+ ] map
+  reverse
+  [ [ -nrot ] curry ] map concat ;

From 8cfc644893a61e4cd807da2dea6a6019f7c175de Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 3 Feb 2008 03:48:58 -0600
Subject: [PATCH 17/25] sequences.lib: indices

---
 extra/sequences/lib/lib.factor | 10 ++++++++++
 1 file changed, 10 insertions(+)

diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index d784726754..65b0d1beb0 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -140,3 +140,13 @@ PRIVATE>
 : ?second ( seq -- second/f ) 1 swap ?nth ; inline
 : ?third ( seq -- third/f ) 2 swap ?nth ; inline
 : ?fourth ( seq -- fourth/f ) 3 swap ?nth ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! List the positions of obj in seq
+
+: indices ( seq obj -- seq )
+  >r dup length swap r>
+  [ = [ ] [ drop f ] if ] curry
+  2map
+  [ ] subset ;

From 1de4896c248f6f95767c4d75df3bd7ffc3130c32 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 3 Feb 2008 03:49:19 -0600
Subject: [PATCH 18/25] Add partial-apply

---
 extra/partial-apply/partial-apply.factor | 26 ++++++++++++++++++++++++
 1 file changed, 26 insertions(+)
 create mode 100644 extra/partial-apply/partial-apply.factor

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

From c60338df7e82a1ac8ae1df3f7fd35470a48cdc86 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 3 Feb 2008 10:24:28 -0800
Subject: [PATCH 19/25] Fix bug in TextMate bundle when using the see or help
 commands on the first word on a line

---
 extra/bunny/model/model.factor                | 1 -
 misc/Factor.tmbundle/Support/lib/tm_factor.rb | 2 +-
 2 files changed, 1 insertion(+), 2 deletions(-)

diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor
index a19adcb782..e3df6bb26c 100644
--- a/extra/bunny/model/model.factor
+++ b/extra/bunny/model/model.factor
@@ -111,4 +111,3 @@ M: bunny-buffers dispose
     "1.5" { "GL_ARB_vertex_buffer_object" }
     has-gl-version-or-extensions?
     [ <bunny-buffers> ] [ <bunny-dlist> ] if ;
-
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

From 1dbd54293c7775ebf866c9d415603b8d15a17eaf Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 3 Feb 2008 14:19:07 -0600
Subject: [PATCH 20/25] Clean up generic words a little bit

---
 core/definitions/definitions-tests.factor |  2 +-
 core/generic/generic-docs.factor          |  4 ++--
 core/generic/generic.factor               | 14 +++++---------
 core/generic/math/math.factor             |  4 ++--
 core/slots/slots.factor                   |  2 +-
 core/syntax/syntax.factor                 |  2 +-
 6 files changed, 12 insertions(+), 16 deletions(-)
 mode change 100644 => 100755 core/generic/math/math.factor

diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor
index 13172c0ada..a4cb4de902 100755
--- a/core/definitions/definitions-tests.factor
+++ b/core/definitions/definitions-tests.factor
@@ -11,7 +11,7 @@ SYMBOL: generic-1
 [
     generic-1 T{ combination-1 } define-generic
 
-    [ ] <method> object \ generic-1 define-method
+    [ ] object \ generic-1 define-method
 ] with-compilation-unit
 
 [ ] [
diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor
index 9dfc40a869..f1cdae1c91 100755
--- a/core/generic/generic-docs.factor
+++ b/core/generic/generic-docs.factor
@@ -1,6 +1,6 @@
 USING: help.markup help.syntax generic.math generic.standard
 words classes definitions kernel alien combinators sequences 
-math ;
+math quotations ;
 IN: generic
 
 ARTICLE: "method-order" "Method precedence"
@@ -154,7 +154,7 @@ HELP: with-methods
 $low-level-note ;
 
 HELP: define-method
-{ $values { "method" "an instance of " { $link method } } { "class" class } { "generic" generic } }
+{ $values { "method" quotation } { "class" class } { "generic" generic } }
 { $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ;
 
 HELP: implementors
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index bde5fd31af..c75dd41d74 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -39,11 +39,6 @@ TUPLE: method loc def ;
 : <method> ( def -- method )
     { set-method-def } \ method construct ;
 
-M: f method-def ;
-M: f method-loc ;
-M: quotation method-def ;
-M: quotation method-loc drop f ;
-
 : method ( class generic -- method/f )
     "methods" word-prop at ;
 
@@ -55,7 +50,7 @@ PREDICATE: pair method-spec
 
 : sort-methods ( assoc -- newassoc )
     [ keys sort-classes ] keep
-    [ dupd at method-def 2array ] curry map ;
+    [ dupd at method-def ] curry { } map>assoc ;
 
 : methods ( word -- assoc )
     "methods" word-prop sort-methods ;
@@ -72,18 +67,19 @@ TUPLE: check-method class generic ;
     inline
 
 : define-method ( method class generic -- )
-    >r bootstrap-word r> check-method
+    >r >r <method> r> bootstrap-word r> check-method
     [ set-at ] with-methods ;
 
 ! Definition protocol
 M: method-spec where
-    dup first2 method method-loc [ ] [ second where ] ?if ;
+    dup first2 method [ method-loc ] [ second where ] ?if ;
 
 M: method-spec set-where first2 method set-method-loc ;
 
 M: method-spec definer drop \ M: \ ; ;
 
-M: method-spec definition first2 method method-def ;
+M: method-spec definition
+    first2 method dup [ method-def ] when ;
 
 : forget-method ( class generic -- )
     check-method [ delete-at ] with-methods ;
diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
old mode 100644
new mode 100755
index 912ece3a30..d5079c5dfb
--- a/core/generic/math/math.factor
+++ b/core/generic/math/math.factor
@@ -39,8 +39,8 @@ TUPLE: no-math-method left right generic ;
     \ no-math-method construct-boa throw ;
 
 : applicable-method ( generic class -- quot )
-    over method method-def
-    [ ] [ [ no-math-method ] curry [ ] like ] ?if ;
+    over method
+    [ method-def ] [ [ no-math-method ] curry [ ] like ] ?if ;
 
 : object-method ( generic -- quot )
     object bootstrap-word applicable-method ;
diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index cd523b05c1..40f0dd3da1 100755
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@@ -10,7 +10,7 @@ TUPLE: slot-spec type name offset reader writer ;
 C: <slot-spec> slot-spec
 
 : define-typecheck ( class generic quot -- )
-    <method> over define-simple-generic -rot define-method ;
+    over define-simple-generic -rot define-method ;
 
 : define-slot-word ( class slot word quot -- )
     rot >fixnum add* define-typecheck ;
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 006f1a225f..67799b92ea 100755
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -126,7 +126,7 @@ IN: bootstrap.syntax
         f set-word
         location >r
         scan-word bootstrap-word scan-word
-        [ parse-definition <method> -rot define-method ] 2keep
+        [ parse-definition -rot define-method ] 2keep
         2array r> remember-definition
     ] define-syntax
 

From d92361286da46186e4dd961dd03dde288e0b38c0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 3 Feb 2008 14:23:14 -0600
Subject: [PATCH 21/25] Add kill-process and flesh out inotify

---
 extra/io/launcher/launcher-docs.factor    | 11 +++++++++++
 extra/io/launcher/launcher.factor         |  5 +++++
 extra/io/unix/launcher/launcher.factor    |  6 +++++-
 extra/io/unix/linux/linux.factor          | 15 ++++++++++-----
 extra/io/windows/launcher/launcher.factor |  8 ++++++--
 extra/unix/unix.factor                    |  7 ++++---
 extra/windows/kernel32/kernel32.factor    |  2 +-
 7 files changed, 42 insertions(+), 12 deletions(-)

diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor
index 072cfcf959..c30516a83f 100755
--- a/extra/io/launcher/launcher-docs.factor
+++ b/extra/io/launcher/launcher-docs.factor
@@ -116,6 +116,15 @@ HELP: run-detached
     "The output value can be passed to " { $link wait-for-process } " to get an exit code."
 } ;
 
+HELP: kill-process
+{ $values { "process" process } }
+{ $description "Kills a running process. Does nothing if the process has already exited." } ;
+
+HELP: kill-process*
+{ $values { "handle" "a process handle" } }
+{ $contract "Kills a running process." }
+{ $notes "User code should call " { $link kill-process } " intead." } ;
+
 HELP: process
 { $class-description "A class representing an active or finished process."
 $nl
@@ -166,6 +175,8 @@ $nl
 "The following words are used to launch processes:"
 { $subsection run-process }
 { $subsection run-detached }
+"Stopping processes:"
+{ $subsection kill-process }
 "Redirecting standard input and output to a pipe:"
 { $subsection <process-stream> }
 { $subsection with-process-stream }
diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor
index 9fb24fb51a..09a77fe985 100755
--- a/extra/io/launcher/launcher.factor
+++ b/extra/io/launcher/launcher.factor
@@ -84,6 +84,11 @@ HOOK: run-process* io-backend ( desc -- handle )
 : run-detached ( desc -- process )
     >descriptor H{ { +detached+ t } } union run-process ;
 
+HOOK: kill-process* io-backend ( handle -- )
+
+: kill-process ( process -- )
+    process-handle [ kill-process* ] when* ;
+
 HOOK: process-stream* io-backend ( desc -- stream process )
 
 TUPLE: process-stream process ;
diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor
index 0135b55a7e..030583dbe8 100755
--- a/extra/io/unix/launcher/launcher.factor
+++ b/extra/io/unix/launcher/launcher.factor
@@ -57,7 +57,8 @@ MEMO: 'arguments' ( -- parser )
 : setup-redirection ( -- )
     +stdin+ get read-flags 0 redirect
     +stdout+ get write-flags 1 redirect
-    +stderr+ get write-flags 2 redirect ;
+    +stderr+ get dup +stdout+ get eq?
+    [ 1 2 dup2 ] [ write-flags 2 redirect ] if ;
 
 : spawn-process ( -- )
     [
@@ -74,6 +75,9 @@ M: unix-io run-process* ( desc -- pid )
         [ spawn-process ] [ ] with-fork <process>
     ] with-descriptor ;
 
+M: unix-io kill-process* ( pid -- )
+    SIGTERM kill io-error ;
+
 : open-pipe ( -- pair )
     2 "int" <c-array> dup pipe zero?
     [ 2 c-int-array> ] [ drop f ] if ;
diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor
index 01d6159e45..9751cefe91 100755
--- a/extra/io/unix/linux/linux.factor
+++ b/extra/io/unix/linux/linux.factor
@@ -21,8 +21,11 @@ TUPLE: linux-monitor path wd callback ;
 
 TUPLE: inotify watches ;
 
-: wd>path ( wd -- path )
-    inotify get-global inotify-watches at linux-monitor-path ;
+: watches ( -- assoc ) inotify get-global inotify-watches ;
+
+: wd>monitor ( wd -- monitor ) watches at ;
+
+: wd>path ( wd -- path ) wd>monitor linux-monitor-path ;
 
 : <inotify> ( -- port )
     H{ } clone
@@ -31,8 +34,6 @@ TUPLE: inotify watches ;
 
 : inotify-fd inotify get-global port-handle ;
 
-: watches inotify get-global inotify-watches ;
-
 : (add-watch) ( path mask -- wd )
     inotify-fd -rot inotify_add_watch dup io-error ;
 
@@ -105,9 +106,13 @@ M: linux-monitor dispose ( monitor -- )
     inotify-event-len "inotify-event" heap-size +
     swap >r + r> ;
 
+: wd>queue ( wd -- queue )
+    inotify-event-wd wd>monitor monitor-queue ;
+
 : parse-file-notifications ( i buffer -- )
     2dup events-exhausted? [ 2drop ] [
-        2dup inotify-event@ parse-file-notify changed-file
+        2dup inotify-event@ dup inotify-event-wd wd>queue
+        [ parse-file-notify changed-file ] bind
         next-event parse-file-notifications
     ] if ;
 
diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor
index ec53d9152c..ad84be0825 100755
--- a/extra/io/windows/launcher/launcher.factor
+++ b/extra/io/windows/launcher/launcher.factor
@@ -48,10 +48,10 @@ TUPLE: CreateProcess-args
     } get-slots CreateProcess win32-error=0/f ;
 
 : escape-argument ( str -- newstr )
-    [ [ dup CHAR: " = [ CHAR: \\ , ] when , ] each ] "" make ;
+    CHAR: \s over member? [ "\"" swap "\"" 3append ] when ;
 
 : join-arguments ( args -- cmd-line )
-    " " join ;
+    [ escape-argument ] map " " join ;
 
 : app-name/cmd-line ( -- app-name cmd-line )
     +command+ get [
@@ -162,6 +162,10 @@ M: windows-io run-process* ( desc -- handle )
         ] with-descriptor
     ] with-destructors ;
 
+M: windows-io kill-process* ( handle -- )
+    PROCESS_INFORMATION-hProcess
+    255 TerminateProcess win32-error=0/f ;
+
 : dispose-process ( process-information -- )
     #! From MSDN: "Handles in PROCESS_INFORMATION must be closed
     #! with CloseHandle when they are no longer needed."
diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor
index f5c484568e..bcfbb3a214 100755
--- a/extra/unix/unix.factor
+++ b/extra/unix/unix.factor
@@ -168,9 +168,10 @@ FUNCTION: time_t time ( time_t* t ) ;
 FUNCTION: int unlink ( char* path ) ;
 FUNCTION: int utimes ( char* path, timeval[2] times ) ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! wait and waitpid
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: SIGKILL 9 ; inline
+: SIGTERM 15 ; inline
+
+FUNCTION: int kill ( pid_t pid, int sig ) ;
 
 ! Flags for waitpid
 
diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor
index 77c7666bfd..b0c2d85598 100755
--- a/extra/windows/kernel32/kernel32.factor
+++ b/extra/windows/kernel32/kernel32.factor
@@ -1453,7 +1453,7 @@ FUNCTION: DWORD SleepEx ( DWORD dwMilliSeconds, BOOL bAlertable ) ;
 FUNCTION: BOOL SystemTimeToFileTime ( SYSTEMTIME* lpSystemTime, LPFILETIME lpFileTime ) ;
 ! FUNCTION: SystemTimeToTzSpecificLocalTime
 ! FUNCTION: TerminateJobObject
-! FUNCTION: TerminateProcess
+FUNCTION: BOOL TerminateProcess ( HANDLE hProcess, DWORD uExit ) ;
 ! FUNCTION: TerminateThread
 ! FUNCTION: TermsrvAppInstallMode
 ! FUNCTION: Thread32First

From 9d0d371efc1159aa26f5350a305108968aad4a87 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 3 Feb 2008 14:47:44 -0600
Subject: [PATCH 22/25] Minor fix for Windows +stderr+ = +stdout+

---
 extra/io/windows/launcher/launcher.factor | 13 ++++++++++++-
 extra/windows/kernel32/kernel32.factor    | 14 +++++++++++++-
 2 files changed, 25 insertions(+), 2 deletions(-)

diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor
index ad84be0825..3d0c2feac1 100755
--- a/extra/io/windows/launcher/launcher.factor
+++ b/extra/io/windows/launcher/launcher.factor
@@ -118,11 +118,22 @@ TUPLE: CreateProcess-args
 : inherited-stderr ( args -- handle )
     drop STD_ERROR_HANDLE GetStdHandle ;
 
+: duplicate-handle ( handle -- handle )
+    GetCurrentProcess
+    swap
+    GetCurrentProcess
+    f <void*> [
+        0
+        TRUE
+        DUPLICATE_SAME_ACCESS
+        DuplicateHandle win32-error=0/f
+    ] keep *void* ;
+
 : redirect-stderr ( args -- handle )
     +stderr+ get
     dup +stdout+ eq? [
         drop
-        CreateProcess-args-lpStartupInfo
+        CreateProcess-args-lpStartupInfo duplicate-handle
         STARTUPINFO-hStdOutput
     ] [
         GENERIC_WRITE CREATE_ALWAYS redirect
diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor
index b0c2d85598..45bd6bfae9 100755
--- a/extra/windows/kernel32/kernel32.factor
+++ b/extra/windows/kernel32/kernel32.factor
@@ -707,7 +707,19 @@ FUNCTION: BOOL DeleteFileW ( LPCTSTR lpFileName ) ;
 ! FUNCTION: DosPathToSessionPathA
 ! FUNCTION: DosPathToSessionPathW
 ! FUNCTION: DuplicateConsoleHandle
-! FUNCTION: DuplicateHandle
+
+FUNCTION: BOOL DuplicateHandle (
+    HANDLE hSourceProcessHandle,
+    HANDLE hSourceHandle,
+    HANDLE hTargetProcessHandle,
+    LPHANDLE lpTargetHandle,
+    DWORD dwDesiredAccess,
+    BOOL bInheritHandle,
+    DWORD dwOptions ) ;
+
+: DUPLICATE_CLOSE_SOURCE 1 ;
+: DUPLICATE_SAME_ACCESS 2 ;
+
 ! FUNCTION: EncodePointer
 ! FUNCTION: EncodeSystemPointer
 ! FUNCTION: EndUpdateResourceA

From 62bbb0597ee1f9fd621f5eb6b34aa7af4f60e67c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 3 Feb 2008 14:51:35 -0600
Subject: [PATCH 23/25] Fix dodgy memory management

---
 vm/os-genunix.c | 3 ++-
 vm/utilities.c  | 7 -------
 vm/utilities.h  | 1 -
 3 files changed, 2 insertions(+), 9 deletions(-)
 mode change 100644 => 100755 vm/os-genunix.c
 mode change 100644 => 100755 vm/utilities.c
 mode change 100644 => 100755 vm/utilities.h

diff --git a/vm/os-genunix.c b/vm/os-genunix.c
old mode 100644
new mode 100755
index 92598eec41..a0bd3e05ae
--- a/vm/os-genunix.c
+++ b/vm/os-genunix.c
@@ -21,7 +21,8 @@ const char *default_image_path(void)
 	if(!path)
 		return "factor.image";
 
-	char *new_path = safe_realloc(path,PATH_MAX + strlen(SUFFIX) + 1);
+	char *new_path = safe_malloc(PATH_MAX + strlen(SUFFIX) + 1);
+	memcpy(new_path,path,strlen(path) + 1);
 	strcat(new_path,SUFFIX); 
 	return new_path;
 }
diff --git a/vm/utilities.c b/vm/utilities.c
old mode 100644
new mode 100755
index 60a4ecb268..ebc8e87977
--- a/vm/utilities.c
+++ b/vm/utilities.c
@@ -8,13 +8,6 @@ void *safe_malloc(size_t size)
 	return ptr;
 }
 
-void *safe_realloc(const void *ptr, size_t size)
-{
-	void *new_ptr = realloc((void *)ptr,size);
-	if(!new_ptr) fatal_error("Out of memory in safe_realloc", 0);
-	return new_ptr;
-}
-
 F_CHAR *safe_strdup(const F_CHAR *str)
 {
 	F_CHAR *ptr = STRDUP(str);
diff --git a/vm/utilities.h b/vm/utilities.h
old mode 100644
new mode 100755
index 483e395345..89a8ba57a3
--- a/vm/utilities.h
+++ b/vm/utilities.h
@@ -1,3 +1,2 @@
 void *safe_malloc(size_t size);
-void *safe_realloc(const void *ptr, size_t size);
 F_CHAR *safe_strdup(const F_CHAR *str);

From f4244e7cafacdd82972419226b33c67535c4a7f5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.local>
Date: Sun, 3 Feb 2008 15:55:59 -0600
Subject: [PATCH 24/25] Fix Unix launcher

---
 extra/io/unix/launcher/launcher.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

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 ( -- )
     [

From 793c3ceb1f627d578fa510f272786cb3e10cc70f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.local>
Date: Sun, 3 Feb 2008 16:06:57 -0600
Subject: [PATCH 25/25] byte-length for bit-arrays

---
 core/alien/c-types/c-types.factor | 15 +++++++++------
 1 file changed, 9 insertions(+), 6 deletions(-)

diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor
index 8ab703eb7e..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 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 ;
+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
@@ -109,10 +110,12 @@ M: c-type stack-size c-type-size ;
 
 GENERIC: byte-length ( seq -- n ) flushable
 
-M: float-array byte-length length "double" heap-size * ;
+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 ]