diff --git a/Factor.app/Contents/Frameworks/libfreetype.6.dylib b/Factor.app/Contents/Frameworks/libfreetype.6.dylib deleted file mode 100755 index 381e74bf18..0000000000 Binary files a/Factor.app/Contents/Frameworks/libfreetype.6.dylib and /dev/null differ diff --git a/basis/help/tips/tips-docs.factor b/basis/help/tips/tips-docs.factor index 8d732c5568..750eff7a52 100644 --- a/basis/help/tips/tips-docs.factor +++ b/basis/help/tips/tips-docs.factor @@ -17,7 +17,14 @@ TIP: "You can write documentation for your own code using the " { $link "help" } 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 } ; diff --git a/basis/help/tips/tips.factor b/basis/help/tips/tips.factor index 8d173ce533..4685b6c517 100644 --- a/basis/help/tips/tips.factor +++ b/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 -io.styles colors.constants ; +USING: parser arrays namespaces sequences random help.markup help.stylesheet +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) ; + +: ( content -- tip ) f tip boa ; + +: add-tip ( tip -- ) tips get push ; + +SYNTAX: TIP: + parse-definition >array + [ 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 ; \ No newline at end of file + drop tips get [ nl nl ] [ content>> print-element ] interleave ; + +INSTANCE: tip definition \ No newline at end of file diff --git a/basis/help/topics/topics.factor b/basis/help/topics/topics.factor index 864b030126..a251849e8f 100644 --- a/basis/help/topics/topics.factor +++ b/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 ) diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index 52684e55f5..597367c353 100644 --- a/basis/hints/hints.factor +++ b/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 ] [ "method-class" word-prop ] bi prefix ; : specialize-method ( quot method -- quot' ) - method-declaration '[ _ declare ] prepend ; - -: specialize-quot ( quot specializer -- quot' ) - specializer-cases alist>quot ; + [ method-declaration '[ _ declare ] prepend ] + [ "method-generic" word-prop "specializer" word-prop ] bi + [ specialize-quot ] when* ; : 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 ] - [ "specializer" word-prop [ specialize-quot ] when* ] - bi ; + dup generic? [ drop ] [ + [ dup standard-method? [ specialize-method ] [ drop ] if ] + [ "specializer" word-prop [ specialize-quot ] when* ] + bi + ] if ; : specialized-length ( specializer -- n ) dup [ array? ] all? [ first ] when length ; diff --git a/basis/images/images.factor b/basis/images/images.factor index a426c33ddc..08fbdd4e7e 100644 --- a/basis/images/images.factor +++ b/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 -math specialized-arrays.direct.uint byte-arrays fry -specialized-arrays.direct.ushort specialized-arrays.uint -specialized-arrays.ushort specialized-arrays.float ; +USING: combinators kernel ; 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 ] } @@ -31,71 +29,4 @@ TUPLE: image dim component-order upside-down? bitmap ; : ( -- image ) image new ; inline -GENERIC: load-image* ( path tuple -- image ) - -: add-dummy-alpha ( seq -- seq' ) - 3 [ 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 [ ] map B{ } join ; inline - -: BGRA>RGBA ( bitmap -- pixels ) - 4 - [ unclip-last-slice [ ] 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 [ 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 * '[ - _ 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 ; +GENERIC: load-image* ( path tuple -- image ) \ No newline at end of file diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor index 6f2ae47c61..b8bafc021f 100644 --- a/basis/images/loader/loader.factor +++ b/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 diff --git a/basis/images/normalization/authors.txt b/basis/images/normalization/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/images/normalization/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/images/normalization/normalization.factor b/basis/images/normalization/normalization.factor new file mode 100644 index 0000000000..bcdf841b42 --- /dev/null +++ b/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 + + [ 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 [ ] map B{ } join ; inline + +: BGRA>RGBA ( bitmap -- pixels ) + 4 + [ unclip-last-slice [ ] 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 [ 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 * '[ + _ 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 ; diff --git a/basis/images/tesselation/authors.txt b/basis/images/tesselation/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/images/tesselation/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/images/tesselation/tesselation-tests.factor b/basis/images/tesselation/tesselation-tests.factor new file mode 100644 index 0000000000..2ac8e37ae7 --- /dev/null +++ b/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 ] [ + 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 } } + } + } +] [ + + 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 } } + } + } +] [ + + 1 9 [a,b] >byte-array >>bitmap + { 3 3 } >>dim + L >>component-order + { 2 2 } tesselate +] unit-test \ No newline at end of file diff --git a/basis/images/tesselation/tesselation.factor b/basis/images/tesselation/tesselation.factor new file mode 100644 index 0000000000..694041a28d --- /dev/null +++ b/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 ; inline + +: tesselate-rows ( bitmap-rows tess-dim -- bitmaps ) + second ; inline + +: tesselate-columns ( bitmap-rows tess-dim -- bitmaps ) + first '[ _ ] 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-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 ] map ] map ; \ No newline at end of file diff --git a/basis/io/streams/byte-array/byte-array-tests.factor b/basis/io/streams/byte-array/byte-array-tests.factor index 77a9126740..44290bfb47 100644 --- a/basis/io/streams/byte-array/byte-array-tests.factor +++ b/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 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 \ No newline at end of file diff --git a/basis/io/streams/byte-array/byte-array.factor b/basis/io/streams/byte-array/byte-array.factor index 25d879a534..2ffb9b9a63 100644 --- a/basis/io/streams/byte-array/byte-array.factor +++ b/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 ; diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index 4f639c02a7..3148567bc0 100755 --- a/basis/math/bitwise/bitwise.factor +++ b/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 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. - { - [ drop 0.5 0.5 ] - [ first 0.3 - 0.5 ] - [ [ first 0.3 - ] [ second 0.3 - ] bi ] - [ second 0.3 - 0.5 swap ] - [ drop 0.5 0.5 ] - } cleave 10 float-array{ } nsequence ; + loc first2 :> y :> x + dim first2 :> h :> w + [ + x 0.5 + y 0.5 + + x w + 0.3 - y 0.5 + + x w + 0.3 - y h + 0.3 - + 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 ) - { - [ drop 0 0 ] - [ first 0 ] - [ first2 ] - [ second 0 swap ] - } cleave 8 float-array{ } nsequence ; +:: (fill-rect-vertices) ( loc dim -- vertices ) + loc first2 :> y :> x + dim first2 :> h :> w + [ + x y + x w + y + 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 -- ) diff --git a/basis/opengl/textures/textures-tests.factor b/basis/opengl/textures/textures-tests.factor index 7141caa67d..163871028d 100644 --- a/basis/opengl/textures/textures-tests.factor +++ b/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 [ ] [ @@ -52,4 +53,17 @@ IN: opengl.textures.tests { component-order R32G32B32 } { 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 \ No newline at end of file diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index 48cdafb837..810aaa2c9c 100644 --- a/basis/opengl/textures/textures.factor +++ b/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 -locals sequences math math.vectors generalizations ; +opengl opengl.gl combinators images images.tesselation grouping +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 -- ) + 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>> [ - [ [ 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 + call ] 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> - -: ( image loc -- texture ) - texture new swap >>loc +: ( image loc -- texture ) + single-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 -- ) - display-list>> [ glCallList ] when* ; +M: single-texture draw-texture display-list>> [ glCallList ] when* ; -: draw-scaled-texture ( dim texture -- ) - dup texture>> [ draw-textured-rect ] [ 2drop ] if ; \ No newline at end of file +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 [ dim>> second ] map ] bi + [ 0 [ + ] accumulate nip ] bi@ + cross-zip flip ; + +: ( image-grid loc -- grid ) + [ dup image-locs ] dip + '[ [ _ v+ |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 ; + +: ( image-grid loc -- multi-texture ) + [ + [ + 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> + +: ( image loc -- texture ) + over dim>> max-texture-size [ <= ] 2all? + [ ] + [ [ max-texture-size tesselate ] dip ] if ; \ No newline at end of file diff --git a/basis/roman/roman-docs.factor b/basis/roman/roman-docs.factor index 4a8197f064..bef0ab90fc 100644 --- a/basis/roman/roman-docs.factor +++ b/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 ;" diff --git a/basis/roman/roman-tests.factor b/basis/roman/roman-tests.factor index 82084e0b1f..a510514e23 100644 --- a/basis/roman/roman-tests.factor +++ b/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 diff --git a/basis/roman/roman.factor b/basis/roman/roman.factor index 71343b723d..66fb3b302a 100644 --- a/basis/roman/roman.factor +++ b/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 -namespaces make quotations sequences splitting.monotonic -sequences.private strings unicode.case lexer parser -grouping ; +USING: accessors arrays assocs fry generalizations grouping +kernel lexer macros make math math.order math.vectors +namespaces parser quotations sequences sequences.private +splitting.monotonic stack-checker strings unicode.case +words effects ; IN: roman = ; + [ 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 [ - sum - ] [ - first2 swap - - ] if ; + [ [ roman>n ] map ] [ all-eq? ] bi + [ sum ] [ first2 swap - ] if ; PRIVATE> : >roman ( n -- str ) - dup roman-range-check - [ (>roman) ] "" make ; + dup roman-range-check [ (>roman) ] "" make ; : >ROMAN ( n -- str ) >roman >upper ; : roman> ( str -- n ) - >lower [ roman<= ] monotonic-split - [ (roman>) ] sigma ; + >lower [ roman<= ] monotonic-split [ (roman>) ] sigma ; ( str1 str2 -- m n ) - [ roman> ] bi@ ; - -: binary-roman-op ( str1 str2 quot -- str3 ) - [ 2roman> ] dip call >roman ; inline +MACRO: binary-roman-op ( quot -- quot' ) + dup infer [ in>> swap ] [ out>> ] bi + '[ [ roman> ] _ napply @ [ >roman ] _ napply ] ; 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" ] bi@ define-declared ; +>> -: roman- ( str1 str2 -- str3 ) - [ - ] binary-roman-op ; - -: roman* ( str1 str2 -- str3 ) - [ * ] binary-roman-op ; - -: roman/i ( str1 str2 -- str3 ) - [ /i ] binary-roman-op ; - -: roman/mod ( str1 str2 -- str3 str4 ) - [ /mod ] binary-roman-op [ >roman ] dip ; +ROMAN-OP: + +ROMAN-OP: - +ROMAN-OP: * +ROMAN-OP: /i +ROMAN-OP: /mod SYNTAX: ROMAN: scan roman> parsed ; diff --git a/basis/specialized-vectors/specialized-vectors-tests.factor b/basis/specialized-vectors/specialized-vectors-tests.factor index df077ce189..82def17e44 100644 --- a/basis/specialized-vectors/specialized-vectors-tests.factor +++ b/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 \ No newline at end of file diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index dd36c5a82b..c2b348f5f1 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/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 diff --git a/basis/tools/scaffold/scaffold-docs.factor b/basis/tools/scaffold/scaffold-docs.factor index 4d1240ad38..621933bfa8 100644 --- a/basis/tools/scaffold/scaffold-docs.factor +++ b/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." } ; diff --git a/basis/ui/gadgets/debug/debug.factor b/basis/ui/gadgets/debug/debug.factor index f8d496c1fc..786a97f689 100644 --- a/basis/ui/gadgets/debug/debug.factor +++ b/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 ; : ( text font -- gadget ) diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index 55622503b6..f5b7f63d22 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/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 - pair second pair first - round 1 max - editor line-height 2array gl-fill-rect - ] with-translation ; + editor selection-color>> gl-color + pair first 0 2array + pair second pair first - round 1 max editor line-height 2array + gl-fill-rect ; : draw-unselected-line ( line editor -- ) font>> swap draw-text ; diff --git a/basis/ui/gadgets/grids/grids-tests.factor b/basis/ui/gadgets/grids/grids-tests.factor index fb92cd2ac6..b83f1a7003 100644 --- a/basis/ui/gadgets/grids/grids-tests.factor +++ b/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 } ] [ { } pref-dim ] unit-test : 100x100 ( -- gadget ) { 100 100 } >>dim ; diff --git a/basis/ui/gadgets/grids/grids.factor b/basis/ui/gadgets/grids/grids.factor index 4ab080464b..ddcfa1465d 100644 --- a/basis/ui/gadgets/grids/grids.factor +++ b/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> ( gadget -- cell ) @@ -116,7 +113,7 @@ M: grid layout* [ grid>> ] [ ] bi grid-layout ; M: grid children-on ( rect gadget -- seq ) dup children>> empty? [ 2drop f ] [ - { 0 1 } swap grid>> + [ { 0 1 } ] dip grid>> [ 0 fast-children-on ] keep concat ] if ; diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor index 44da013f2c..a6bd5c4e29 100644 --- a/basis/ui/gadgets/panes/panes.factor +++ b/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>> [ - dim>> gl-fill-rect - ] with-translation + rect-bounds gl-fill-rect ] if-fits ; M: node draw-selection ( loc node -- ) diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor index 7b1befc539..f2ed5b10e0 100644 --- a/basis/ui/gadgets/tables/tables.factor +++ b/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 ; -: highlight-row ( table row color quot -- ) - [ [ row-rect rect-bounds ] dip gl-color ] dip - '[ _ @ ] with-translation ; inline +: row-bounds ( table row -- loc dim ) + row-rect rect-bounds ; inline : draw-selected-row ( table -- ) { { [ dup selected-index>> not ] [ drop ] } [ - [ ] [ selected-index>> ] [ selection-color>> ] tri - [ gl-fill-rect ] highlight-row + [ ] [ selected-index>> ] [ selection-color>> gl-color ] tri + 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 - [ gl-rect ] highlight-row + [ ] [ selected-index>> ] [ focus-border-color>> gl-color ] tri + 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 ; diff --git a/basis/ui/pens/solid/solid.factor b/basis/ui/pens/solid/solid.factor index 950035e773..fe44a8f341 100644 --- a/basis/ui/pens/solid/solid.factor +++ b/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 ] - [ (rect-vertices) >>boundary-vertices ] + [ [ { 0 0 } ] dip (fill-rect-vertices) >>interior-vertices ] + [ [ { 0 0 } ] dip (rect-vertices) >>boundary-vertices ] bi drop ; > gl-fill-rect ; + { 0 0 } clip get dim>> gl-fill-rect ; GENERIC: draw-gadget* ( gadget -- ) diff --git a/basis/ui/tools/operations/operations.factor b/basis/ui/tools/operations/operations.factor index 28781e24bb..c6371ac8aa 100644 --- a/basis/ui/tools/operations/operations.factor +++ b/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 } diff --git a/basis/unicode/breaks/breaks.factor b/basis/unicode/breaks/breaks.factor index 22d6cddfb9..12314505d9 100644 --- a/basis/unicode/breaks/breaks.factor +++ b/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 ; diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 434b133b3f..c95c5816ac 100644 --- a/core/definitions/definitions.factor +++ b/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 ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 8380a41207..c22641d439 100644 --- a/core/generic/generic.factor +++ b/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 ; diff --git a/core/io/streams/sequence/sequence.factor b/core/io/streams/sequence/sequence.factor index f455512ed3..0f922a37cc 100644 --- a/core/io/streams/sequence/sequence.factor +++ b/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 ] - [ next ] bi ; inline + [ >sequence-stream< ?nth ] [ 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 - [ memq? ] curry find-from swap ; inline + swap [ >sequence-stream< swap tail-slice ] dip + [ memq? ] curry find swap ; inline : sequence-read-until ( separators stream -- seq sep/f ) [ find-sep ] keep diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 56f19595cb..baccf56059 100644 --- a/core/kernel/kernel.factor +++ b/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 ) diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 6a7e8116cd..e8f699748f 100644 --- a/core/syntax/syntax-docs.factor +++ b/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 0" } + { $code "GENERIC: foo ( obj -- )" } + { $code "GENERIC# foo 0 ( obj -- )" } } ; HELP: MATH: diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index edac418285..2b978e8666 100644 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -108,4 +108,6 @@ SYMBOL: load-vocab-hook ! ( name -- vocab ) : load-vocab ( name -- vocab ) load-vocab-hook get call( name -- vocab ) ; PREDICATE: runnable-vocab < vocab - vocab-main >boolean ; \ No newline at end of file + vocab-main >boolean ; + +INSTANCE: vocab-spec definition \ No newline at end of file diff --git a/core/words/words.factor b/core/words/words.factor index cfdcd4517f..5b230c1b00 100755 --- a/core/words/words.factor +++ b/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 ; : xref-words ( -- ) all-words [ xref ] each ; + +INSTANCE: word definition \ No newline at end of file diff --git a/extra/cap/cap.factor b/extra/cap/cap.factor index 64696759bb..f43787673a 100644 --- a/extra/cap/cap.factor +++ b/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 -models ui.gadgets.worlds ui.gadgets fry alien.syntax ; +opengl.gl sequences math.vectors ui images images.normalization +images.viewer models ui.gadgets.worlds ui.gadgets fry alien.syntax ; IN: cap : screenshot-array ( world -- byte-array ) diff --git a/extra/game-input/game-input-tests.factor b/extra/game-input/game-input-tests.factor index 69b40dbec7..2bf923c12b 100644 --- a/extra/game-input/game-input-tests.factor +++ b/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 \ No newline at end of file diff --git a/extra/math/matrices/matrices-tests.factor b/extra/math/matrices/matrices-tests.factor index 6f87109ba0..20942356de 100644 --- a/extra/math/matrices/matrices-tests.factor +++ b/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 \ No newline at end of file diff --git a/extra/math/matrices/matrices.factor b/extra/math/matrices/matrices.factor index 0088b17372..7c687d753d 100755 --- a/extra/math/matrices/matrices.factor +++ b/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 ; \ No newline at end of file diff --git a/extra/tetris/gl/gl.factor b/extra/tetris/gl/gl.factor index f8c901ff56..d1f398994e 100644 --- a/extra/tetris/gl/gl.factor +++ b/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 ; diff --git a/extra/ui/gadgets/lists/lists.factor b/extra/ui/gadgets/lists/lists.factor index d7301ca042..aa98793c70 100644 --- a/extra/ui/gadgets/lists/lists.factor +++ b/extra/ui/gadgets/lists/lists.factor @@ -57,9 +57,7 @@ M: list draw-gadget* origin get [ dup color>> gl-color selected-rect [ - dup loc>> [ - dim>> gl-fill-rect - ] with-translation + rect-bounds gl-fill-rect ] when* ] with-translation ;