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

basis/help/tips/tips-docs.factor

@@ -18,6 +18,13 @@ TIP: "You can write graphical applications using the " { $link "ui" } "." ;
 
 TIP: "Power tools: " { $links see edit help about apropos time infer. } ;
 
+TIP: "Tips of the day implement the " { $link "definition-protocol" } " and new tips of the day can be defined using the " { $link POSTPONE: TIP: } " parsing word." ;
+
+HELP: TIP:
+{ $syntax "TIP: content ;" }
+{ $values { "content" "a markup element" } }
+{ $description "Defines a new tip of the day." } ;
+  
 ARTICLE: "all-tips-of-the-day" "All tips of the day"
 { $tips-of-the-day } ;
 

basis/help/tips/tips.factor

@@ -1,14 +1,28 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: parser arrays namespaces sequences random help.markup kernel io
+USING: parser arrays namespaces sequences random help.markup help.stylesheet
-io.styles colors.constants ;
+kernel io io.styles colors.constants definitions accessors ;
 IN: help.tips
 
 SYMBOL: tips
 
 tips [ V{ } clone ] initialize
 
-SYNTAX: TIP: parse-definition >array tips get push ;
+TUPLE: tip < identity-tuple content loc ;
+
+M: tip forget* tips get delq ;
+
+M: tip where loc>> ;
+
+M: tip set-where (>>loc) ;
+
+: <tip> ( content -- tip ) f tip boa ;
+
+: add-tip ( tip -- ) tips get push ;
+
+SYNTAX: TIP:
+    parse-definition >array <tip>
+    [ save-location ] [ add-tip ] bi ;
 
 : a-tip ( -- tip ) tips get random ;
 
@@ -20,13 +34,20 @@ H{
     { wrap-margin 500 }
 } tip-of-the-day-style set-global
 
+: $tip-title ( tip -- )
+    [
+        heading-style get [
+            [ "Tip of the day" ] dip write-object
+        ] with-style
+    ] ($block) ;
+
 : $tip-of-the-day ( element -- )
     drop
     [
         tip-of-the-day-style get
         [
             last-element off
-            "Tip of the day" $heading a-tip print-element nl
+            a-tip [ $tip-title ] [ content>> print-element nl ] bi
             "— " print-element "all-tips-of-the-day" ($link)
         ]
         with-nesting
@@ -35,4 +56,6 @@ H{
 : tip-of-the-day. ( -- ) { $tip-of-the-day } print-content nl ;
 
 : $tips-of-the-day ( element -- )
-    drop tips get [ nl nl ] [ print-element ] interleave ;
+    drop tips get [ nl nl ] [ content>> print-element ] interleave ;
+
+INSTANCE: tip definition

basis/help/topics/topics.factor

@@ -7,8 +7,12 @@ IN: help.topics
 
 TUPLE: link name ;
 
+INSTANCE: link definition
+
 MIXIN: topic
+
 INSTANCE: link topic
+
 INSTANCE: word topic
 
 GENERIC: >link ( obj -- obj )

basis/hints/hints.factor

@@ -34,16 +34,18 @@ M: object specializer-declaration class ;
         [ specializer-declaration ] map '[ _ declare ] pick append
     ] { } map>assoc ;
 
+: specialize-quot ( quot specializer -- quot' )
+    specializer-cases alist>quot ;
+
 : method-declaration ( method -- quot )
     [ "method-generic" word-prop dispatch# object <array> ]
     [ "method-class" word-prop ]
     bi prefix ;
 
 : specialize-method ( quot method -- quot' )
-    method-declaration '[ _ declare ] prepend ;
+    [ method-declaration '[ _ declare ] prepend ]
-
+    [ "method-generic" word-prop "specializer" word-prop ] bi
-: specialize-quot ( quot specializer -- quot' )
+    [ specialize-quot ] when* ;
-    specializer-cases alist>quot ;
 
 : standard-method? ( method -- ? )
     dup method-body? [
@@ -52,9 +54,11 @@ M: object specializer-declaration class ;
 
 : specialized-def ( word -- quot )
     [ def>> ] keep
-    [ dup standard-method? [ specialize-method ] [ drop ] if ]
+    dup generic? [ drop ] [
-    [ "specializer" word-prop [ specialize-quot ] when* ]
+        [ dup standard-method? [ specialize-method ] [ drop ] if ]
-    bi ;
+        [ "specializer" word-prop [ specialize-quot ] when* ]
+        bi
+    ] if ;
 
 : specialized-length ( specializer -- n )
     dup [ array? ] all? [ first ] when length ;

basis/images/images.factor

@@ -1,16 +1,14 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors grouping sequences combinators
+USING: combinators kernel ;
-math specialized-arrays.direct.uint byte-arrays fry
-specialized-arrays.direct.ushort specialized-arrays.uint
-specialized-arrays.ushort specialized-arrays.float ;
 IN: images
 
-SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
+SINGLETONS: L BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
 R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
 
 : bytes-per-pixel ( component-order -- n )
     {
+        { L [ 1 ] }
         { BGR [ 3 ] }
         { RGB [ 3 ] }
         { BGRA [ 4 ] }
@@ -32,70 +30,3 @@ TUPLE: image dim component-order upside-down? bitmap ;
 : <image> ( -- image ) image new ; inline
 
 GENERIC: load-image* ( path tuple -- image )
-
-: add-dummy-alpha ( seq -- seq' )
-    3 <groups> [ 255 suffix ] map concat ;
-
-: normalize-floats ( byte-array -- byte-array )
-    byte-array>float-array [ 255.0 * >integer ] B{ } map-as ;
-
-GENERIC: normalize-component-order* ( image component-order -- image )
-
-: normalize-component-order ( image -- image )
-    dup component-order>> '[ _ normalize-component-order* ] change-bitmap ;
-
-M: RGBA normalize-component-order* drop ;
-
-M: R32G32B32A32 normalize-component-order*
-    drop normalize-floats ;
-
-M: R32G32B32 normalize-component-order*
-    drop normalize-floats add-dummy-alpha ;
-
-: RGB16>8 ( bitmap -- bitmap' )
-    byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline
-
-M: R16G16B16A16 normalize-component-order*
-    drop RGB16>8 ;
-
-M: R16G16B16 normalize-component-order*
-    drop RGB16>8 add-dummy-alpha ;
-
-: BGR>RGB ( bitmap -- pixels )
-    3 <sliced-groups> [ <reversed> ] map B{ } join ; inline
-
-: BGRA>RGBA ( bitmap -- pixels )
-    4 <sliced-groups>
-    [ unclip-last-slice [ <reversed> ] dip suffix ] map concat ; inline
-
-M: BGRA normalize-component-order*
-    drop BGRA>RGBA ;
-
-M: RGB normalize-component-order*
-    drop add-dummy-alpha ;
-
-M: BGR normalize-component-order*
-    drop BGR>RGB add-dummy-alpha ;
-
-: ARGB>RGBA ( bitmap -- bitmap' )
-    4 <groups> [ unclip suffix ] map B{ } join ; inline
-
-M: ARGB normalize-component-order*
-    drop ARGB>RGBA ;
-
-M: ABGR normalize-component-order*
-    drop ARGB>RGBA BGRA>RGBA ;
-
-: normalize-scan-line-order ( image -- image )
-    dup upside-down?>> [
-        dup dim>> first 4 * '[
-            _ <groups> reverse concat
-        ] change-bitmap
-        f >>upside-down?
-    ] when ;
-
-: normalize-image ( image -- image )
-    [ >byte-array ] change-bitmap
-    normalize-component-order
-    normalize-scan-line-order
-    RGBA >>component-order ;

basis/images/loader/loader.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: constructors kernel splitting unicode.case combinators
-accessors images.bitmap images.tiff images io.backend
+accessors images.bitmap images.tiff images images.normalization
 io.pathnames ;
 IN: images.loader
 

basis/images/normalization/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/images/normalization/normalization.factor

@@ -0,0 +1,78 @@
+! Copyright (C) 2009 Doug Coleman
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors grouping sequences combinators
+math specialized-arrays.direct.uint byte-arrays fry
+specialized-arrays.direct.ushort specialized-arrays.uint
+specialized-arrays.ushort specialized-arrays.float images ;
+IN: images.normalization
+
+<PRIVATE
+
+: add-dummy-alpha ( seq -- seq' )
+    3 <groups> [ 255 suffix ] map concat ;
+
+: normalize-floats ( byte-array -- byte-array )
+    byte-array>float-array [ 255.0 * >integer ] B{ } map-as ;
+
+GENERIC: normalize-component-order* ( image component-order -- image )
+
+: normalize-component-order ( image -- image )
+    dup component-order>> '[ _ normalize-component-order* ] change-bitmap ;
+
+M: RGBA normalize-component-order* drop ;
+
+M: R32G32B32A32 normalize-component-order*
+    drop normalize-floats ;
+
+M: R32G32B32 normalize-component-order*
+    drop normalize-floats add-dummy-alpha ;
+
+: RGB16>8 ( bitmap -- bitmap' )
+    byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline
+
+M: R16G16B16A16 normalize-component-order*
+    drop RGB16>8 ;
+
+M: R16G16B16 normalize-component-order*
+    drop RGB16>8 add-dummy-alpha ;
+
+: BGR>RGB ( bitmap -- pixels )
+    3 <sliced-groups> [ <reversed> ] map B{ } join ; inline
+
+: BGRA>RGBA ( bitmap -- pixels )
+    4 <sliced-groups>
+    [ unclip-last-slice [ <reversed> ] dip suffix ] map concat ; inline
+
+M: BGRA normalize-component-order*
+    drop BGRA>RGBA ;
+
+M: RGB normalize-component-order*
+    drop add-dummy-alpha ;
+
+M: BGR normalize-component-order*
+    drop BGR>RGB add-dummy-alpha ;
+
+: ARGB>RGBA ( bitmap -- bitmap' )
+    4 <groups> [ unclip suffix ] map B{ } join ; inline
+
+M: ARGB normalize-component-order*
+    drop ARGB>RGBA ;
+
+M: ABGR normalize-component-order*
+    drop ARGB>RGBA BGRA>RGBA ;
+
+: normalize-scan-line-order ( image -- image )
+    dup upside-down?>> [
+        dup dim>> first 4 * '[
+            _ <groups> reverse concat
+        ] change-bitmap
+        f >>upside-down?
+    ] when ;
+
+PRIVATE>
+
+: normalize-image ( image -- image )
+    [ >byte-array ] change-bitmap
+    normalize-component-order
+    normalize-scan-line-order
+    RGBA >>component-order ;

basis/images/tesselation/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/images/tesselation/tesselation-tests.factor

@@ -0,0 +1,46 @@
+USING: images accessors kernel tools.test literals math.ranges
+byte-arrays ;
+IN: images.tesselation
+
+! Check an invariant we depend on
+[ t ] [
+    <image> B{ 1 2 3 } >>bitmap dup clone [ bitmap>> ] bi@ eq?
+] unit-test
+
+[
+    {
+        {
+            T{ image f { 2 2 } L f B{ 1 2 5 6 } }
+            T{ image f { 2 2 } L f B{ 3 4 7 8 } }
+        }
+        {
+            T{ image f { 2 2 } L f B{ 9 10 13 14 } }
+            T{ image f { 2 2 } L f B{ 11 12 15 16 } }
+        }
+    }
+] [
+    <image>
+        1 16 [a,b] >byte-array >>bitmap
+        { 4 4 } >>dim
+        L >>component-order
+    { 2 2 } tesselate
+] unit-test
+
+[
+    {
+        {
+            T{ image f { 2 2 } L f B{ 1 2 4 5 } }
+            T{ image f { 1 2 } L f B{ 3 6 } }
+        }
+        {
+            T{ image f { 2 1 } L f B{ 7 8 } }
+            T{ image f { 1 1 } L f B{ 9 } }
+        }
+    }
+] [
+    <image>
+        1 9 [a,b] >byte-array >>bitmap
+        { 3 3 } >>dim
+        L >>component-order
+    { 2 2 } tesselate
+] unit-test

basis/images/tesselation/tesselation.factor

@@ -0,0 +1,35 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences kernel math grouping fry columns locals accessors
+images math math.vectors arrays ;
+IN: images.tesselation
+
+: group-rows ( bitmap bitmap-dim -- rows )
+    first <sliced-groups> ; inline
+
+: tesselate-rows ( bitmap-rows tess-dim -- bitmaps )
+    second <sliced-groups> ; inline
+
+: tesselate-columns ( bitmap-rows tess-dim -- bitmaps )
+    first '[ _ <sliced-groups> ] map flip ; inline
+
+: tesselate-bitmap ( bitmap bitmap-dim tess-dim -- bitmap-grid )
+    [ group-rows ] dip
+    [ tesselate-rows ] keep
+    '[ _ tesselate-columns ] map ;
+
+: tile-width ( tile-bitmap original-image -- width )
+    [ first length ] [ component-order>> bytes-per-pixel ] bi* /i ;
+
+: <tile-image> ( tile-bitmap original-image -- tile-image )
+    clone
+        swap
+        [ concat >>bitmap ]
+        [ [ over tile-width ] [ length ] bi 2array >>dim ] bi ;
+
+:: tesselate ( image tess-dim -- image-grid )
+    image component-order>> bytes-per-pixel :> bpp
+    image dim>> { bpp 1 } v* :> image-dim'
+    tess-dim { bpp 1 } v* :> tess-dim'
+    image bitmap>> image-dim' tess-dim' tesselate-bitmap
+    [ [ image <tile-image> ] map ] map ;

basis/io/streams/byte-array/byte-array-tests.factor

@@ -1,5 +1,5 @@
 USING: tools.test io.streams.byte-array io.encodings.binary
-io.encodings.utf8 io kernel arrays strings ;
+io.encodings.utf8 io kernel arrays strings namespaces ;
 
 [ B{ 1 2 3 } ] [ binary [ { 1 2 3 } write ] with-byte-writer ] unit-test
 [ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test
@@ -7,3 +7,23 @@ io.encodings.utf8 io kernel arrays strings ;
 [ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
 [ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } utf8 [ write ] with-byte-writer ] unit-test
 [ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> contents dup >array swap string? ] unit-test
+
+[ B{ 121 120 } 0 ] [
+    B{ 0 121 120 0 0 0 0 0 0 } binary
+    [ 1 read drop "\0" read-until ] with-byte-reader
+] unit-test
+
+[ 1 1 4 11 f ] [
+    B{ 1 2 3 4 5 6 7 8 9 10 11 12 } binary
+    [
+        read1
+        0 seek-absolute input-stream get stream-seek
+        read1
+        2 seek-relative input-stream get stream-seek
+        read1
+        -2 seek-end input-stream get stream-seek
+        read1
+        0 seek-end input-stream get stream-seek
+        read1
+    ] with-byte-reader
+] unit-test

basis/io/streams/byte-array/byte-array.factor

@@ -28,7 +28,7 @@ M: byte-reader stream-seek ( n seek-type stream -- )
     swap {
         { seek-absolute [ (>>i) ] }
         { seek-relative [ [ + ] change-i drop ] }
-        { seek-end [ dup underlying>> length >>i [ + ] change-i drop ] }
+        { seek-end [ [ underlying>> length + ] keep (>>i) ] }
         [ bad-seek-type ]
     } case ;
 

basis/math/bitwise/bitwise.factor

@@ -37,7 +37,7 @@ IN: math.bitwise
 
 ! flags
 MACRO: flags ( values -- )
-    [ 0 ] [ [ dup word? [ execute ] when bitor ] curry compose ] reduce ;
+    [ 0 ] [ [ ?execute bitor ] curry compose ] reduce ;
 
 ! bitfield
 <PRIVATE

basis/opengl/opengl-docs.factor

@@ -23,11 +23,11 @@ HELP: gl-line
 { $description "Draws a line between two points." } ;
 
 HELP: gl-fill-rect
-{ $values { "dim" "a pair of integers" } }
+{ $values { "loc" "a pair of integers" } { "dim" "a pair of integers" } }
 { $description "Draws a filled rectangle with the top-left corner at the origin and the given dimensions." } ;
 
 HELP: gl-rect
-{ $values { "dim" "a pair of integers" } }
+{ $values { "loc" "a pair of integers" } { "dim" "a pair of integers" } }
 { $description "Draws the outline of a rectangle with the top-left corner at the origin and the given dimensions." } ;
 
 HELP: gen-gl-buffer

basis/opengl/opengl.factor

@@ -3,8 +3,8 @@
 ! Portions copyright (C) 2008 Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types continuations kernel libc math macros
-namespaces math.vectors math.parser opengl.gl opengl.glu
+namespaces math.vectors math.parser opengl.gl opengl.glu combinators
-combinators arrays sequences splitting words byte-arrays assocs
+combinators.smart arrays sequences splitting words byte-arrays assocs
 colors colors.constants accessors generalizations locals fry
 specialized-arrays.float specialized-arrays.uint ;
 IN: opengl
@@ -28,7 +28,7 @@ IN: opengl
     over glEnableClientState dip glDisableClientState ; inline
 
 : words>values ( word/value-seq -- value-seq )
-    [ dup word? [ execute ] when ] map ;
+    [ ?execute ] map ;
 
 : (all-enabled) ( seq quot -- )
     over [ glEnable ] each dip [ glDisable ] each ; inline
@@ -67,42 +67,46 @@ MACRO: all-enabled-client-state ( seq quot -- )
 : gl-line ( a b -- )
     line-vertices GL_LINES 0 2 glDrawArrays ;
 
-: (rect-vertices) ( dim -- vertices )
+:: (rect-vertices) ( loc dim -- vertices )
     #! We use GL_LINE_STRIP with a duplicated first vertex
     #! instead of GL_LINE_LOOP to work around a bug in Apple's
     #! X3100 driver.
-    {
+    loc first2 :> y :> x
-        [ drop 0.5 0.5 ]
+    dim first2 :> h :> w
-        [ first 0.3 - 0.5 ]
+    [
-        [ [ first 0.3 - ] [ second 0.3 - ] bi ]
+        x 0.5 +     y 0.5 +
-        [ second 0.3 - 0.5 swap ]
+        x w + 0.3 - y 0.5 +
-        [ drop 0.5 0.5 ]
+        x w + 0.3 - y h + 0.3 -
-    } cleave 10 float-array{ } nsequence ;
+        x           y h + 0.3 -
+        x 0.5 +     y 0.5 +
+    ] float-array{ } output>sequence ;
 
-: rect-vertices ( dim -- )
+: rect-vertices ( loc dim -- )
     (rect-vertices) gl-vertex-pointer ;
 
 : (gl-rect) ( -- )
     GL_LINE_STRIP 0 5 glDrawArrays ;
 
-: gl-rect ( dim -- )
+: gl-rect ( loc dim -- )
     rect-vertices (gl-rect) ;
 
-: (fill-rect-vertices) ( dim -- vertices )
+:: (fill-rect-vertices) ( loc dim -- vertices )
-    {
+    loc first2 :> y :> x
-        [ drop 0 0 ]
+    dim first2 :> h :> w
-        [ first 0 ]
+    [
-        [ first2 ]
+        x      y
-        [ second 0 swap ]
+        x w +  y
-    } cleave 8 float-array{ } nsequence ;
+        x w +  y h +
+        x      y h +
+    ] float-array{ } output>sequence ;
 
-: fill-rect-vertices ( dim -- )
+: fill-rect-vertices ( loc dim -- )
     (fill-rect-vertices) gl-vertex-pointer ;
 
 : (gl-fill-rect) ( -- )
     GL_QUADS 0 4 glDrawArrays ;
 
-: gl-fill-rect ( dim -- )
+: gl-fill-rect ( loc dim -- )
     fill-rect-vertices (gl-fill-rect) ;
 
 : do-attribs ( bits quot -- )

basis/opengl/textures/textures-tests.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: tools.test opengl.textures opengl.textures.private
-images kernel namespaces ;
+opengl.textures.private images kernel namespaces accessors
+sequences ;
 IN: opengl.textures.tests
 
 [ ] [
@@ -53,3 +54,16 @@ IN: opengl.textures.tests
        { bitmap B{ } }
     } power-of-2-image
 ] unit-test
+
+[
+    {
+        { { 0 0 } { 10 0 } }
+        { { 0 20 } { 10 20 } }
+    }
+] [
+    {
+        { { 10 20 } { 30 20 } }
+        { { 10 30 } { 30 300 } }
+    }
+    [ [ image new swap >>dim ] map ] map image-locs
+] unit-test

basis/opengl/textures/textures.factor

@@ -1,16 +1,15 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs cache colors.constants destructors fry kernel
-opengl opengl.gl combinators images grouping specialized-arrays.float
+opengl opengl.gl combinators images images.tesselation grouping
-locals sequences math math.vectors generalizations ;
+specialized-arrays.float locals sequences math math.vectors
+math.matrices generalizations fry columns ;
 IN: opengl.textures
 
 : gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ;
 
 : delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ;
 
-TUPLE: texture loc dim texture-coords texture display-list disposed ;
-
 GENERIC: component-order>format ( component-order -- format type )
 
 M: RGB component-order>format drop GL_RGB GL_UNSIGNED_BYTE ;
@@ -19,8 +18,14 @@ M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ;
 M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ;
 M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
 
+GENERIC: draw-texture ( texture -- )
+
+GENERIC: draw-scaled-texture ( dim texture -- )
+
 <PRIVATE
 
+TUPLE: single-texture loc dim texture-coords texture display-list disposed ;
+
 : repeat-last ( seq n -- seq' )
     over peek pad-tail concat ;
 
@@ -69,20 +74,27 @@ M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
     GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT glTexParameteri
     GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT glTexParameteri ;
 
-: draw-textured-rect ( dim texture -- )
+: with-texturing ( quot -- )
     GL_TEXTURE_2D [
         GL_TEXTURE_BIT [
             GL_TEXTURE_COORD_ARRAY [
                 COLOR: white gl-color
-                dup loc>> [
+                call
-                    [ [ GL_TEXTURE_2D ] dip texture>> glBindTexture ]
-                    [ init-texture texture-coords>> gl-texture-coord-pointer ] bi
-                    fill-rect-vertices (gl-fill-rect)
-                    GL_TEXTURE_2D 0 glBindTexture
-                ] with-translation
             ] do-enabled-client-state
         ] do-attribs
-    ] do-enabled ;
+    ] do-enabled ; inline
+
+: (draw-textured-rect) ( dim texture -- )
+    [ loc>> ]
+    [ [ GL_TEXTURE_2D ] dip texture>> glBindTexture ]
+    [ init-texture texture-coords>> gl-texture-coord-pointer ] tri
+    swap gl-fill-rect ;
+
+: draw-textured-rect ( dim texture -- )
+    [
+        (draw-textured-rect)
+        GL_TEXTURE_2D 0 glBindTexture
+    ] with-texturing ;
 
 : texture-coords ( dim -- coords )
     [ dup next-power-of-2 /f ] map
@@ -92,10 +104,8 @@ M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
 : make-texture-display-list ( texture -- dlist )
     GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ;
 
-PRIVATE>
+: <single-texture> ( image loc -- texture )
-
+   single-texture new swap >>loc
-: <texture> ( image loc -- texture )
-    texture new swap >>loc
     swap
     [ dim>> >>dim ] keep
     [ dim>> product 0 = ] keep '[
@@ -105,12 +115,59 @@ PRIVATE>
         dup make-texture-display-list >>display-list
     ] unless ;
 
-M: texture dispose*
+M: single-texture dispose*
     [ texture>> [ delete-texture ] when* ]
     [ display-list>> [ delete-dlist ] when* ] bi ;
 
-: draw-texture ( texture -- )
+M: single-texture draw-texture display-list>> [ glCallList ] when* ;
-    display-list>> [ glCallList ] when* ;
 
-: draw-scaled-texture ( dim texture -- )
+M: single-texture draw-scaled-texture
     dup texture>> [ draw-textured-rect ] [ 2drop ] if ;
+
+TUPLE: multi-texture grid display-list loc disposed ;
+
+: image-locs ( image-grid -- loc-grid )
+    [ first [ dim>> first ] map ] [ 0 <column> [ dim>> second ] map ] bi
+    [ 0 [ + ] accumulate nip ] bi@
+    cross-zip flip ;
+
+: <texture-grid> ( image-grid loc -- grid )
+    [ dup image-locs ] dip
+    '[ [ _ v+ <single-texture> |dispose ] 2map ] 2map ;
+
+: draw-textured-grid ( grid -- )
+    [ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ;
+
+: make-textured-grid-display-list ( grid -- dlist )
+    GL_COMPILE [
+        [
+            [
+                [
+                    [ dim>> ] keep (draw-textured-rect)
+                ] each
+            ] each
+            GL_TEXTURE_2D 0 glBindTexture
+        ] with-texturing
+    ] make-dlist ;
+
+: <multi-texture> ( image-grid loc -- multi-texture )
+    [
+        [
+            <texture-grid> dup
+            make-textured-grid-display-list
+        ] keep
+        f multi-texture boa
+    ] with-destructors ;
+
+M: multi-texture draw-texture display-list>> [ glCallList ] when* ;
+
+M: multi-texture dispose* grid>> [ [ dispose ] each ] each ;
+
+CONSTANT: max-texture-size { 256 256 }
+
+PRIVATE>
+
+: <texture> ( image loc -- texture )
+    over dim>> max-texture-size [ <= ] 2all?
+    [ <single-texture> ]
+    [ [ max-texture-size tesselate ] dip <multi-texture> ] if ;

basis/roman/roman-docs.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel math ;
+USING: help.markup help.syntax kernel math strings ;
 IN: roman
 
 HELP: >roman
@@ -39,7 +39,7 @@ HELP: roman>
 { >roman >ROMAN roman> } related-words
 
 HELP: roman+
-{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
+{ $values { "string" string } { "string" string } { "string" string } }
 { $description "Adds two Roman numerals." }
 { $examples 
     { $example "USING: io roman ;"
@@ -49,7 +49,7 @@ HELP: roman+
 } ;
 
 HELP: roman-
-{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
+{ $values { "string" string } { "string" string } { "string" string } }
 { $description "Subtracts two Roman numerals." }
 { $examples 
     { $example "USING: io roman ;"
@@ -61,7 +61,7 @@ HELP: roman-
 { roman+ roman- } related-words
 
 HELP: roman*
-{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
+{ $values { "string" string } { "string" string } { "string" string } }
 { $description "Multiplies two Roman numerals." }
 { $examples 
     { $example "USING: io roman ;"
@@ -71,7 +71,7 @@ HELP: roman*
 } ;
 
 HELP: roman/i
-{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
+{ $values { "string" string } { "string" string } { "string" string } }
 { $description "Computes the integer division of two Roman numerals." }
 { $examples 
     { $example "USING: io roman ;"
@@ -81,7 +81,7 @@ HELP: roman/i
 } ;
 
 HELP: roman/mod
-{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } { "str4" "a string" } }
+{ $values { "string" string } { "string" string } { "string" string } { "string" string } }
 { $description "Computes the quotient and remainder of two Roman numerals." }
 { $examples 
     { $example "USING: kernel io roman ;"

basis/roman/roman-tests.factor

@@ -38,3 +38,9 @@ USING: arrays kernel math roman roman.private sequences tools.test ;
 [ "iii" "iii"  roman- ] must-fail
 
 [ 30 ] [ ROMAN: xxx ] unit-test
+
+[ roman+ ] must-infer
+[ roman- ] must-infer
+[ roman* ] must-infer
+[ roman/i ] must-infer
+[ roman/mod ] must-infer

basis/roman/roman.factor

@@ -1,29 +1,33 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs kernel math math.order math.vectors
+USING: accessors arrays assocs fry generalizations grouping
-namespaces make quotations sequences splitting.monotonic
+kernel lexer macros make math math.order math.vectors
-sequences.private strings unicode.case lexer parser
+namespaces parser quotations sequences sequences.private
-grouping ;
+splitting.monotonic stack-checker strings unicode.case
+words effects ;
 IN: roman
 
 <PRIVATE
 
-: roman-digits ( -- seq )
+CONSTANT: roman-digits
-    { "m" "cm" "d" "cd" "c" "xc" "l" "xl" "x" "ix" "v" "iv" "i" } ;
+    { "m" "cm" "d" "cd" "c" "xc" "l" "xl" "x" "ix" "v" "iv" "i" }
 
-: roman-values ( -- seq )
+CONSTANT: roman-values
-    { 1000 900 500 400 100 90 50 40 10 9 5 4 1 } ;
+    { 1000 900 500 400 100 90 50 40 10 9 5 4 1 }
 
 ERROR: roman-range-error n ;
 
 : roman-range-check ( n -- )
     dup 1 3999 between? [ drop ] [ roman-range-error ] if ;
 
+: roman-digit-index ( ch -- n )
+    1string roman-digits index ; inline
+
 : roman<= ( ch1 ch2 -- ? )
-    [ 1string roman-digits index ] bi@ >= ;
+    [ roman-digit-index ] bi@ >= ;
 
 : roman>n ( ch -- n )
-    1string roman-digits index roman-values nth ;
+    roman-digit-index roman-values nth ;
 
 : (>roman) ( n -- )
     roman-values roman-digits [
@@ -31,47 +35,39 @@ ERROR: roman-range-error n ;
     ] 2each drop ;
 
 : (roman>) ( seq -- n )
-    [ [ roman>n ] map ] [ all-eq? ] bi [
+    [ [ roman>n ] map ] [ all-eq? ] bi
-        sum
+    [ sum ] [ first2 swap - ] if ;
-    ] [
-        first2 swap -
-    ] if ;
 
 PRIVATE>
 
 : >roman ( n -- str )
-    dup roman-range-check
+    dup roman-range-check [ (>roman) ] "" make ;
-    [ (>roman) ] "" make ;
 
 : >ROMAN ( n -- str ) >roman >upper ;
 
 : roman> ( str -- n )
-    >lower [ roman<= ] monotonic-split
+    >lower [ roman<= ] monotonic-split [ (roman>) ] sigma ;
-    [ (roman>) ] sigma ;
 
 <PRIVATE
 
-: 2roman> ( str1 str2 -- m n )
+MACRO: binary-roman-op ( quot -- quot' )
-    [ roman> ] bi@ ;
+    dup infer [ in>> swap ] [ out>> ] bi
-
+    '[ [ roman> ] _ napply @ [ >roman ] _ napply ] ;
-: binary-roman-op ( str1 str2 quot -- str3 )
-    [ 2roman> ] dip call >roman ; inline
 
 PRIVATE>
 
-: roman+ ( str1 str2 -- str3 )
+<<
-    [ + ] binary-roman-op ;
+SYNTAX: ROMAN-OP:
+    scan-word [ name>> "roman" prepend create-in ] keep
+    1quotation '[ _ binary-roman-op ]
+    dup infer [ in>> ] [ out>> ] bi
+    [ "string" <repetition> ] bi@ <effect> define-declared ;
+>>
 
-: roman- ( str1 str2 -- str3 )
+ROMAN-OP: +
-    [ - ] binary-roman-op ;
+ROMAN-OP: -
-
+ROMAN-OP: *
-: roman* ( str1 str2 -- str3 )
+ROMAN-OP: /i
-    [ * ] binary-roman-op ;
+ROMAN-OP: /mod
-
-: roman/i ( str1 str2 -- str3 )
-    [ /i ] binary-roman-op ;
-
-: roman/mod ( str1 str2 -- str3 str4 )
-    [ /mod ] binary-roman-op [ >roman ] dip ;
 
 SYNTAX: ROMAN: scan roman> parsed ;

basis/specialized-vectors/specialized-vectors-tests.factor

@@ -1,5 +1,9 @@
 IN: specialized-vectors.tests
-USING: specialized-vectors.double tools.test kernel sequences ;
+USING: specialized-arrays.float
+specialized-vectors.float
+specialized-vectors.double
+tools.test kernel sequences ;
 
 [ 3 ] [ double-vector{ 1 2 } 3 over push length ] unit-test
 
+[ t ] [ 10 float-array{ } new-resizable float-vector? ] unit-test

basis/stack-checker/transforms/transforms.factor

@@ -154,6 +154,15 @@ CONSTANT: bit-member-max 256
     dup sequence? [ memq-quot ] [ drop f ] if
 ] 1 define-transform
 
+! Index search
+\ index [
+    dup sequence? [
+        dup length 4 >= [
+            dup length zip >hashtable '[ _ at ]
+        ] [ drop f ] if
+    ] [ drop f ] if
+] 1 define-transform
+
 ! Shuffling
 : nths-quot ( indices -- quot )
     [ [ '[ _ swap nth ] ] map ] [ length ] bi

basis/tools/scaffold/scaffold-docs.factor

@@ -26,7 +26,7 @@ HELP: scaffold-undocumented
 HELP: scaffold-vocab
 { $values
      { "vocab-root" "a vocabulary root string" } { "string" string } }
-{ $description "Creates a directory in the given root for a new vocabulary and adds a main .factor file, a tests file, and an authors.txt file." } ;
+{ $description "Creates a directory in the given root for a new vocabulary and adds a main .factor file and an authors.txt file." } ;
 
 HELP: scaffold-emacs
 { $description "Touches the .emacs file in your home directory and provides a clickable link to open it in an editor." } ;

basis/ui/gadgets/debug/debug.factor

@@ -58,7 +58,7 @@ M: metrics-paint draw-boundary
     COLOR: red gl-color
     [ dim>> ] [ >label< line-metrics ] bi
     [ [ first ] [ ascent>> ] bi* [ nip 0 swap 2array ] [ 2array ] 2bi gl-line ]
-    [ drop gl-rect ]
+    [ drop { 0 0 } swap gl-rect ]
     2bi ;
 
 : <metrics-gadget> ( text font -- gadget )

basis/ui/gadgets/editors/editors.factor

@@ -172,11 +172,10 @@ TUPLE: selected-line start end first? last? ;
 
 :: draw-selection ( line pair editor -- )
     pair [ editor font>> line offset>x ] map :> pair
-    pair first 0 2array [
+    editor selection-color>> gl-color
-        editor selection-color>> gl-color
+    pair first 0 2array
-        pair second pair first - round 1 max
+    pair second pair first - round 1 max editor line-height 2array
-        editor line-height 2array gl-fill-rect
+    gl-fill-rect ;
-    ] with-translation ;
 
 : draw-unselected-line ( line editor -- )
     font>> swap draw-text ;

basis/ui/gadgets/grids/grids-tests.factor

@@ -3,9 +3,6 @@ namespaces math.rectangles accessors ui.gadgets.grids.private
 ui.gadgets.debug sequences ;
 IN: ui.gadgets.grids.tests
 
-[ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ]
-[ { 1 2 } { "a" "b" } cross-zip ] unit-test
-
 [ { 0 0 } ] [ { } <grid> pref-dim ] unit-test
 
 : 100x100 ( -- gadget ) <gadget> { 100 100 } >>dim ;

basis/ui/gadgets/grids/grids.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.order namespaces make sequences words io
+USING: arrays kernel math math.order math.matrices namespaces make sequences words io
 math.vectors ui.gadgets ui.baseline-alignment columns accessors strings.tables
 math.rectangles fry ;
 IN: ui.gadgets.grids
@@ -33,9 +33,6 @@ PRIVATE>
 
 <PRIVATE
 
-: cross-zip ( seq1 seq2 -- seq1xseq2 )
-    [ [ 2array ] with map ] curry map ;
-
 TUPLE: cell pref-dim baseline cap-height ;
 
 : <cell> ( gadget -- cell )
@@ -116,7 +113,7 @@ M: grid layout* [ grid>> ] [ <grid-layout> ] bi grid-layout ;
 
 M: grid children-on ( rect gadget -- seq )
     dup children>> empty? [ 2drop f ] [
-        { 0 1 } swap grid>>
+        [ { 0 1 } ] dip grid>>
         [ 0 <column> fast-children-on ] keep
         <slice> concat
     ] if ;

basis/ui/gadgets/panes/panes.factor

@@ -79,9 +79,7 @@ GENERIC: draw-selection ( loc obj -- )
 
 M: gadget draw-selection ( loc gadget -- )
     swap offset-rect [
-        dup loc>> [
+        rect-bounds gl-fill-rect
-            dim>> gl-fill-rect
-        ] with-translation
     ] if-fits ;
 
 M: node draw-selection ( loc node -- )

basis/ui/gadgets/tables/tables.factor

@@ -121,16 +121,15 @@ M: table layout*
     [ [ line-height ] dip * 0 swap 2array ]
     [ drop [ dim>> first ] [ line-height ] bi 2array ] 2bi <rect> ;
 
-: highlight-row ( table row color quot -- )
+: row-bounds ( table row -- loc dim )
-    [ [ row-rect rect-bounds ] dip gl-color ] dip
+    row-rect rect-bounds ; inline
-    '[ _ @ ] with-translation ; inline
 
 : draw-selected-row ( table -- )
     {
         { [ dup selected-index>> not ] [ drop ] }
         [
-            [ ] [ selected-index>> ] [ selection-color>> ] tri
+            [ ] [ selected-index>> ] [ selection-color>> gl-color ] tri
-            [ gl-fill-rect ] highlight-row
+            row-bounds gl-fill-rect
         ]
     } cond ;
 
@@ -139,14 +138,15 @@ M: table layout*
         { [ dup focused?>> not ] [ drop ] }
         { [ dup selected-index>> not ] [ drop ] }
         [
-            [ ] [ selected-index>> ] [ focus-border-color>> ] tri
+            [ ] [ selected-index>> ] [ focus-border-color>> gl-color ] tri
-            [ gl-rect ] highlight-row
+            row-bounds gl-rect
         ]
     } cond ;
 
 : draw-moused-row ( table -- )
     dup mouse-index>> dup [
-        over mouse-color>> [ gl-rect ] highlight-row
+        over mouse-color>> gl-color
+        row-bounds gl-rect
     ] [ 2drop ] if ;
 
 : column-line-offsets ( table -- xs )
@@ -279,7 +279,7 @@ PRIVATE>
 
 : row-action ( table -- )
     dup selected-row
-    [ swap [ action>> call ] [ dup hook>> call ] bi ]
+    [ swap [ action>> call( value -- ) ] [ dup hook>> call( table -- ) ] bi ]
     [ 2drop ]
     if ;
 

basis/ui/pens/solid/solid.factor

@@ -9,8 +9,8 @@ TUPLE: solid < caching-pen color interior-vertices boundary-vertices ;
 
 M: solid recompute-pen
     swap dim>>
-    [ (fill-rect-vertices) >>interior-vertices ]
+    [ [ { 0 0 } ] dip (fill-rect-vertices) >>interior-vertices ]
-    [ (rect-vertices) >>boundary-vertices ]
+    [ [ { 0 0 } ] dip (rect-vertices) >>boundary-vertices ]
     bi drop ;
 
 <PRIVATE

basis/ui/render/render.factor

@@ -38,7 +38,7 @@ SYMBOL: viewport-translation
     ! white gl-clear is broken w.r.t window resizing
     ! Linux/PPC Radeon 9200
     COLOR: white gl-color
-    clip get dim>> gl-fill-rect ;
+    { 0 0 } clip get dim>> gl-fill-rect ;
 
 GENERIC: draw-gadget* ( gadget -- )
 

basis/ui/tools/operations/operations.factor

@@ -81,8 +81,6 @@ IN: ui.tools.operations
     { +listener+ t }
 } define-operation
 
-UNION: definition word method-spec link vocab vocab-link ;
-
 [ definition? ] \ edit H{
     { +keyboard+ T{ key-down f { C+ } "e" } }
     { +listener+ t }

basis/unicode/breaks/breaks.factor

@@ -60,7 +60,7 @@ SYMBOL: table
 : finish-table ( -- table )
     table get [ [ 1 = ] map ] map ;
 
-: eval-seq ( seq -- seq ) [ dup word? [ execute ] when ] map ;
+: eval-seq ( seq -- seq ) [ ?execute ] map ;
 
 : (set-table) ( class1 class2 val -- )
     [ table get nth ] dip '[ _ or ] change-nth ;

core/definitions/definitions.factor

@@ -3,6 +3,8 @@
 USING: kernel sequences namespaces assocs graphs math math.order ;
 IN: definitions
 
+MIXIN: definition
+
 ERROR: no-compilation-unit definition ;
 
 SYMBOLS: inlined-dependency flushed-dependency called-dependency ;

core/generic/generic.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors words kernel sequences namespaces make assocs
 hashtables definitions kernel.private classes classes.private
@@ -27,6 +27,8 @@ M: generic definition drop f ;
 PREDICATE: method-spec < pair
     first2 generic? swap class? and ;
 
+INSTANCE: method-spec definition
+
 : order ( generic -- seq )
     "methods" word-prop keys sort-classes ;
 

core/io/streams/sequence/sequence.factor

@@ -15,11 +15,10 @@ SLOT: i
     [ 1+ ] change-i drop ; inline
 
 : sequence-read1 ( stream -- elt/f )
-    [ >sequence-stream< ?nth ]
+    [ >sequence-stream< ?nth ] [ next ] bi ; inline
-    [ next ] bi ; inline
 
 : add-length ( n stream -- i+n )
-    [ i>> + ] [ underlying>> length ] bi min  ; inline
+    [ i>> + ] [ underlying>> length ] bi min ; inline
 
 : (sequence-read) ( n stream -- seq/f )
     [ add-length ] keep
@@ -32,8 +31,8 @@ SLOT: i
     [ (sequence-read) ] [ 2drop f ] if ; inline
 
 : find-sep ( seps stream -- sep/f n )
-    swap [ >sequence-stream< ] dip
+    swap [ >sequence-stream< swap tail-slice ] dip
-    [ memq? ] curry find-from swap ; inline
+    [ memq? ] curry find swap ; inline
 
 : sequence-read-until ( separators stream -- seq sep/f )
     [ find-sep ] keep

core/kernel/kernel.factor

@@ -23,6 +23,10 @@ GENERIC: call ( callable -- )
 
 GENERIC: execute ( word -- )
 
+GENERIC: ?execute ( word -- value )
+
+M: object ?execute ;
+
 DEFER: if
 
 : ? ( ? true false -- true/false )

core/syntax/syntax-docs.factor

@@ -566,8 +566,8 @@ HELP: GENERIC#
 { $description "Defines a new generic word which dispatches on the " { $snippet "n" } "th most element from the top of the stack in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." }
 { $notes
     "The following two definitions are equivalent:"
-    { $code "GENERIC: foo" }
+    { $code "GENERIC: foo ( obj -- )" }
-    { $code "GENERIC# foo 0" }
+    { $code "GENERIC# foo 0 ( obj -- )" }
 } ;
 
 HELP: MATH:

core/vocabs/vocabs.factor

@@ -109,3 +109,5 @@ SYMBOL: load-vocab-hook ! ( name -- vocab )
 
 PREDICATE: runnable-vocab < vocab
     vocab-main >boolean ;
+
+INSTANCE: vocab-spec definition

core/words/words.factor

@@ -12,6 +12,8 @@ IN: words
 
 M: word execute (execute) ;
 
+M: word ?execute execute( -- value ) ;
+
 M: word <=>
     [ [ name>> ] [ vocabulary>> ] bi 2array ] compare ;
 
@@ -260,3 +262,5 @@ M: word hashcode*
 M: word literalize <wrapper> ;
 
 : xref-words ( -- ) all-words [ xref ] each ;
+
+INSTANCE: word definition

extra/cap/cap.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2008 Doug Coleman, Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays byte-arrays kernel math namespaces
-opengl.gl sequences math.vectors ui images images.viewer
+opengl.gl sequences math.vectors ui images images.normalization
-models ui.gadgets.worlds ui.gadgets fry alien.syntax ;
+images.viewer models ui.gadgets.worlds ui.gadgets fry alien.syntax ;
 IN: cap
 
 : screenshot-array ( world -- byte-array )

extra/game-input/game-input-tests.factor

@@ -1,8 +1,12 @@
 IN: game-input.tests
-USING: game-input tools.test kernel system threads ;
+USING: ui game-input tools.test kernel system threads
+combinators.short-circuit calendar ;
 
-os windows? os macosx? or [
+{
+    [ os windows? ui-running? and ]
+    [ os macosx? ]
+} 0|| [
     [ ] [ open-game-input ] unit-test
-    [ ] [ yield ] unit-test
+    [ ] [ 1 seconds sleep ] unit-test
     [ ] [ close-game-input ] unit-test
 ] when

extra/math/matrices/matrices-tests.factor

@@ -104,3 +104,6 @@ USING: math.matrices math.vectors tools.test math ;
 [ { 0 1 0 } ] [ { 0 0 1 } { 1 0 0 } cross ] unit-test
 
 [ { 1 0 0 } ] [ { 1 1 0 } { 1 0 0 } proj ] unit-test
+
+[ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ]
+[ { 1 2 } { "a" "b" } cross-zip ] unit-test

extra/math/matrices/matrices.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel math math.order math.vectors sequences ;
 IN: math.matrices
@@ -57,3 +57,6 @@ PRIVATE>
 
 : norm-gram-schmidt ( seq -- orthonormal )
     gram-schmidt [ normalize ] map ;
+
+: cross-zip ( seq1 seq2 -- seq1xseq2 )
+    [ [ 2array ] with map ] curry map ;

extra/tetris/gl/gl.factor

@@ -8,7 +8,7 @@ IN: tetris.gl
 #! OpenGL rendering for tetris
 
 : draw-block ( block -- )
-    [ { 1 1 } gl-fill-rect ] with-translation ;
+    { 1 1 } gl-fill-rect ;
 
 : draw-piece-blocks ( piece -- )
     piece-blocks [ draw-block ] each ;

extra/ui/gadgets/lists/lists.factor

@@ -57,9 +57,7 @@ M: list draw-gadget*
     origin get [
         dup color>> gl-color
         selected-rect [
-            dup loc>> [
+            rect-bounds gl-fill-rect
-                dim>> gl-fill-rect
-            ] with-translation
         ] when*
     ] with-translation ;