diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index cb6a753735..4718f137e4 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/basis/bitstreams/bitstreams.factor @@ -158,3 +158,9 @@ M: msb0-bit-reader peek ( n bs -- bits ) \ be> \ subseq>bits-be (peek) ; writer bytes>> swap push ] unless writer bytes>> ; + +:: byte-array-n>seq ( byte-array n -- seq ) + byte-array length 8 * n / iota + byte-array '[ + drop n _ read + ] { } map-as ; diff --git a/basis/compression/run-length/run-length.factor b/basis/compression/run-length/run-length.factor index d281b0718a..6553860546 100644 --- a/basis/compression/run-length/run-length.factor +++ b/basis/compression/run-length/run-length.factor @@ -3,5 +3,5 @@ USING: arrays grouping sequences ; IN: compression.run-length -: run-length-uncompress8 ( byte-array -- byte-array' ) +: run-length-uncompress ( byte-array -- byte-array' ) 2 group [ first2 ] map concat ; diff --git a/basis/constructors/constructors-tests.factor b/basis/constructors/constructors-tests.factor index 367f0ad143..271e173718 100644 --- a/basis/constructors/constructors-tests.factor +++ b/basis/constructors/constructors-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: tools.test constructors calendar kernel accessors -combinators.short-circuit ; +combinators.short-circuit initializers math ; IN: constructors.tests TUPLE: stock-spread stock spread timestamp ; @@ -18,4 +18,42 @@ SYMBOL: AAPL [ spread>> 1234 = ] [ timestamp>> timestamp? ] } 1&& -] unit-test \ No newline at end of file +] unit-test + +TUPLE: ct1 a ; +TUPLE: ct2 < ct1 b ; +TUPLE: ct3 < ct2 c ; +TUPLE: ct4 < ct3 d ; + +CONSTRUCTOR: ct1 ( a -- obj ) + [ 1 + ] change-a ; + +CONSTRUCTOR: ct2 ( a b -- obj ) + initialize-ct1 + [ 1 + ] change-a ; + +CONSTRUCTOR: ct3 ( a b c -- obj ) + initialize-ct1 + [ 1 + ] change-a ; + +CONSTRUCTOR: ct4 ( a b c d -- obj ) + initialize-ct3 + [ 1 + ] change-a ; + +[ 1001 ] [ 1000 a>> ] unit-test +[ 2 ] [ 0 0 a>> ] unit-test +[ 2 ] [ 0 0 0 a>> ] unit-test +[ 3 ] [ 0 0 0 0 a>> ] unit-test + + +TUPLE: rofl a b c ; +CONSTRUCTOR: rofl ( b c a -- obj ) ; + +[ T{ rofl { a 3 } { b 1 } { c 2 } } ] [ 1 2 3 ] unit-test + + +TUPLE: default { a integer initial: 0 } ; + +CONSTRUCTOR: default ( -- obj ) ; + +[ 0 ] [ a>> ] unit-test diff --git a/basis/constructors/constructors.factor b/basis/constructors/constructors.factor index 7a98cd5e0a..e6982e3d98 100644 --- a/basis/constructors/constructors.factor +++ b/basis/constructors/constructors.factor @@ -1,23 +1,54 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: slots kernel sequences fry accessors parser lexer words -effects.parser macros ; +USING: accessors assocs classes.tuple effects.parser fry +generalizations generic.standard kernel lexer locals macros +parser sequences slots vocabs words ; IN: constructors ! An experiment -MACRO: set-slots ( slots -- quot ) - [ setter-word '[ swap _ execute ] ] map [ ] join ; +: initializer-name ( class -- word ) + name>> "initialize-" prepend ; -: construct ( ... class slots -- instance ) - [ new ] dip set-slots ; inline +: lookup-initializer ( class -- word/f ) + initializer-name "initializers" lookup ; -: define-constructor ( name class effect body -- ) - [ [ in>> '[ _ _ construct ] ] dip compose ] [ drop ] 2bi - define-declared ; +: initializer-word ( class -- word ) + initializer-name + "initializers" create-vocab create + [ t "initializer" set-word-prop ] [ ] bi ; + +: define-initializer-generic ( name -- ) + initializer-word (( object -- object )) define-simple-generic ; + +: define-initializer ( class def -- ) + [ drop define-initializer-generic ] + [ [ dup lookup-initializer ] dip H{ } clone define-typecheck ] 2bi ; + +MACRO:: slots>constructor ( class slots -- quot ) + class all-slots [ [ name>> ] [ initial>> ] bi ] { } map>assoc :> params + slots length + params length + '[ + _ narray slots swap zip + params swap assoc-union + values _ firstn class boa + ] ; + +:: define-constructor ( constructor-word class effect def -- ) + constructor-word + class def define-initializer + class effect in>> '[ _ _ slots>constructor ] + class lookup-initializer + '[ @ _ execute( obj -- obj ) ] effect define-declared ; + +: scan-constructor ( -- class word ) + scan-word [ name>> "<" ">" surround create-in ] keep ; SYNTAX: CONSTRUCTOR: - scan-word [ name>> "<" ">" surround create-in ] keep + scan-constructor complete-effect parse-definition - define-constructor ; \ No newline at end of file + define-constructor ; + +"initializers" create-vocab drop diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 8bf8d59944..4f2ad720b6 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -2,77 +2,146 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types arrays byte-arrays columns combinators compression.run-length endian fry grouping images -images.loader io io.binary io.encodings.binary io.files kernel -locals macros math math.bitwise math.functions namespaces -sequences strings summary ; +images.loader io io.binary io.encodings.binary io.files +io.streams.limited kernel locals macros math math.bitwise +math.functions namespaces sequences specialized-arrays.uint +specialized-arrays.ushort strings summary io.encodings.8-bit +io.encodings.string ; +QUALIFIED-WITH: bitstreams b IN: images.bitmap -: assert-sequence= ( a b -- ) - 2dup sequence= [ 2drop ] [ assert ] if ; - : read2 ( -- n ) 2 read le> ; : read4 ( -- n ) 4 read le> ; : write2 ( n -- ) 2 >le write ; : write4 ( n -- ) 4 >le write ; -TUPLE: bitmap-image < image ; - -! Used to construct the final bitmap-image +SINGLETON: bitmap-image +"bmp" bitmap-image register-image-class TUPLE: loading-bitmap -size reserved offset header-length width +magic size reserved1 reserved2 offset header-length width height planes bit-count compression size-image -x-pels y-pels color-used color-important color-palette color-index -uncompressed-bytes ; +x-pels y-pels color-used color-important +red-mask green-mask blue-mask alpha-mask +cs-type end-points +gamma-red gamma-green gamma-blue +intent profile-data profile-size reserved3 +color-palette color-index bitfields ; -ERROR: bitmap-magic magic ; - -M: bitmap-magic summary - drop "First two bytes of bitmap stream must be 'BM'" ; +! endpoints-triple is ciexyzX/Y/Z, 3x fixed-point-2.30 aka 3x uint buffer ( bitmap -- array ) - [ color-palette>> 4 [ 3 head-slice ] map ] - [ color-index>> >array ] bi [ swap nth ] with map concat ; +: os2-color-lookup ( loading-bitmap -- seq ) + [ color-index>> >array ] + [ color-palette>> 3 ] bi + '[ _ nth ] map concat ; + +: os2v2-color-lookup ( loading-bitmap -- seq ) + [ color-index>> >array ] + [ color-palette>> 3 ] bi + '[ _ nth ] map concat ; + +: v3-color-lookup ( loading-bitmap -- seq ) + [ color-index>> >array ] + [ color-palette>> 4 [ 3 head-slice ] map ] bi + '[ _ nth ] map concat ; + +: color-lookup ( loading-bitmap -- seq ) + dup header-length>> { + { 12 [ os2-color-lookup ] } + { 64 [ os2v2-color-lookup ] } + { 40 [ v3-color-lookup ] } + ! { 108 [ v4-color-lookup ] } + ! { 124 [ v5-color-lookup ] } + } case ; ERROR: bmp-not-supported n ; -: reverse-lines ( byte-array width -- byte-array ) - concat ; inline +: uncompress-bitfield ( seq masks -- bytes' ) + '[ + _ [ + [ bitand ] [ bit-count ] [ log2 ] tri - shift + ] with map + ] { } map-as B{ } concat-as ; -: bitmap>bytes ( loading-bitmap -- array ) +: bitmap>bytes ( loading-bitmap -- byte-array ) dup bit-count>> { { 32 [ color-index>> ] } - { 24 [ [ color-index>> ] [ width>> 3 * ] bi reverse-lines ] } - { 8 [ [ 8bit>buffer ] [ width>> 3 * ] bi reverse-lines ] } + { 24 [ color-index>> ] } + { 16 [ + [ + ! byte-array>ushort-array + 2 group [ le> ] map + ! 5 6 5 + ! { HEX: f800 HEX: 7e0 HEX: 1f } uncompress-bitfield + ! 5 5 5 + { HEX: 7c00 HEX: 3e0 HEX: 1f } uncompress-bitfield + ] change-color-index + color-index>> + ] } + { 8 [ color-lookup ] } + { 4 [ [ 4 b:byte-array-n>seq ] change-color-index color-lookup ] } + { 1 [ [ 1 b:byte-array-n>seq ] change-color-index color-lookup ] } [ bmp-not-supported ] } case >byte-array ; +: set-bitfield-widths ( loading-bitmap -- loading-bitmap' ) + dup bit-count>> { + { 16 [ dup color-palette>> 4 group [ le> ] map ] } + { 32 [ { HEX: ff0000 HEX: ff00 HEX: ff } ] } + } case reverse >>bitfields ; + +ERROR: unsupported-bitfield-widths n ; + +M: unsupported-bitfield-widths summary + drop "Bitmaps only support bitfield compression in 16/32bit images" ; + +: uncompress-bitfield-widths ( loading-bitmap -- loading-bitmap' ) + set-bitfield-widths + dup bit-count>> { + { 16 [ + dup bitfields>> '[ + byte-array>ushort-array _ uncompress-bitfield + ] change-color-index + ] } + { 32 [ + dup bitfields>> '[ + byte-array>uint-array _ uncompress-bitfield + ] change-color-index + ] } + [ unsupported-bitfield-widths ] + } case ; + ERROR: unsupported-bitmap-compression compression ; : uncompress-bitmap ( loading-bitmap -- loading-bitmap' ) dup compression>> { + { f [ ] } { 0 [ ] } - { 1 [ [ run-length-uncompress8 ] change-color-index ] } - { 2 [ "run-length encoding 4" unsupported-bitmap-compression ] } - { 3 [ "bitfields" unsupported-bitmap-compression ] } + { 1 [ [ run-length-uncompress ] change-color-index ] } + { 2 [ [ 4 b:byte-array-n>seq run-length-uncompress >byte-array ] change-color-index ] } + { 3 [ uncompress-bitfield-widths ] } { 4 [ "jpeg" unsupported-bitmap-compression ] } { 5 [ "png" unsupported-bitmap-compression ] } } case ; +: bitmap-padding ( width -- n ) + 3 * 4 mod 4 swap - 4 mod ; inline + : loading-bitmap>bytes ( loading-bitmap -- byte-array ) - uncompress-bitmap bitmap>bytes ; + uncompress-bitmap + bitmap>bytes ; : parse-file-header ( loading-bitmap -- loading-bitmap ) - 2 read "BM" assert-sequence= + 2 read latin1 decode >>magic read4 >>size - read4 >>reserved + read2 >>reserved1 + read2 >>reserved2 read4 >>offset ; -: parse-bitmap-header ( loading-bitmap -- loading-bitmap ) - read4 >>header-length +: read-v3-header ( loading-bitmap -- loading-bitmap ) read4 >>width read4 32 >signed >>height read2 >>planes @@ -84,6 +153,50 @@ ERROR: unsupported-bitmap-compression compression ; read4 >>color-used read4 >>color-important ; +: read-v4-header ( loading-bitmap -- loading-bitmap ) + read-v3-header + read4 >>red-mask + read4 >>green-mask + read4 >>blue-mask + read4 >>alpha-mask + read4 >>cs-type + read4 read4 read4 3array >>end-points + read4 >>gamma-red + read4 >>gamma-green + read4 >>gamma-blue ; + +: read-v5-header ( loading-bitmap -- loading-bitmap ) + read-v4-header + read4 >>intent + read4 >>profile-data + read4 >>profile-size + read4 >>reserved3 ; + +: read-os2-header ( loading-bitmap -- loading-bitmap ) + read2 >>width + read2 16 >signed >>height + read2 >>planes + read2 >>bit-count ; + +: read-os2v2-header ( loading-bitmap -- loading-bitmap ) + read4 >>width + read4 32 >signed >>height + read2 >>planes + read2 >>bit-count ; + +ERROR: unknown-bitmap-header n ; + +: parse-bitmap-header ( loading-bitmap -- loading-bitmap ) + read4 [ >>header-length ] keep + { + { 12 [ read-os2-header ] } + { 64 [ read-os2v2-header ] } + { 40 [ read-v3-header ] } + { 108 [ read-v4-header ] } + { 124 [ read-v5-header ] } + [ unknown-bitmap-header ] + } case ; + : color-palette-length ( loading-bitmap -- n ) [ offset>> 14 - ] [ header-length>> ] bi - ; @@ -98,56 +211,54 @@ ERROR: unsupported-bitmap-compression compression ; : image-size ( loading-bitmap -- n ) [ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ; -: bitmap-padding ( width -- n ) - 3 * 4 mod 4 swap - 4 mod ; inline - -:: fixup-color-index ( loading-bitmap -- loading-bitmap ) - loading-bitmap width>> :> width - width 3 * :> width*3 - loading-bitmap width>> bitmap-padding :> padding - loading-bitmap [ color-index>> length ] [ height>> abs ] bi /i :> stride - loading-bitmap - padding 0 > [ - [ - stride - [ width*3 head-slice ] map concat - ] change-color-index - ] when ; - : parse-bitmap ( loading-bitmap -- loading-bitmap ) dup color-palette-length read >>color-palette - dup color-index-length read >>color-index - fixup-color-index ; + dup size-image>> dup 0 > [ + read >>color-index + ] [ + drop dup color-index-length read >>color-index + ] if ; + +ERROR: unsupported-bitmap-file magic ; : load-bitmap ( path -- loading-bitmap ) - binary [ + binary stream-throws [ loading-bitmap new - parse-file-header parse-bitmap-header parse-bitmap - ] with-file-reader ; + parse-file-header dup magic>> { + { "BM" [ parse-bitmap-header parse-bitmap ] } + ! { "BA" [ parse-os2-bitmap-array ] } + ! { "CI" [ parse-os2-color-icon ] } + ! { "CP" [ parse-os2-color-pointer ] } + ! { "IC" [ parse-os2-icon ] } + ! { "PT" [ parse-os2-pointer ] } + [ unsupported-bitmap-file ] + } case + ] with-input-stream ; ERROR: unknown-component-order bitmap ; : bitmap>component-order ( loading-bitmap -- object ) bit-count>> { - { 32 [ BGRA ] } + { 32 [ BGR ] } { 24 [ BGR ] } + { 16 [ BGR ] } { 8 [ BGR ] } + { 4 [ BGR ] } + { 1 [ BGR ] } [ unknown-component-order ] } case ; -: loading-bitmap>bitmap-image ( bitmap-image loading-bitmap -- bitmap-image ) +M: bitmap-image load-image* ( path bitmap-image -- bitmap ) + drop load-bitmap + [ image new ] dip { [ loading-bitmap>bytes >>bitmap ] [ [ width>> ] [ height>> abs ] bi 2array >>dim ] - [ height>> 0 < [ t >>upside-down? ] when ] + [ height>> 0 < not >>upside-down? ] + [ compression>> 3 = [ t >>upside-down? ] when ] [ bitmap>component-order >>component-order ] } cleave ; -M: bitmap-image load-image* ( path loading-bitmap -- bitmap ) - swap load-bitmap loading-bitmap>bitmap-image ; - -"bmp" bitmap-image register-image-class - PRIVATE> : bitmap>color-index ( bitmap -- byte-array ) @@ -165,6 +276,9 @@ PRIVATE> ] if ] bi ; +: reverse-lines ( byte-array width -- byte-array ) + concat ; inline + : save-bitmap ( image path -- ) binary [ B{ CHAR: B CHAR: M } write diff --git a/basis/images/images.factor b/basis/images/images.factor index 62c4f7e2ed..4c76b85459 100755 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -34,14 +34,7 @@ TUPLE: image dim component-order upside-down? bitmap ; : has-alpha? ( image -- ? ) component-order>> alpha-channel? ; -GENERIC: load-image* ( path tuple -- image ) - -: make-image ( bitmap -- image ) - ! bitmap is a sequence of sequences of pixels which are RGBA - - over [ first length ] [ length ] bi 2array >>dim - RGBA >>component-order - swap concat concat B{ } like >>bitmap ; +GENERIC: load-image* ( path class -- image ) ( -- jpeg-image ) jpeg-image get ; +: jpeg> ( -- jpeg-image ) loading-jpeg get ; : apply-diff ( dc color -- dc' ) [ diff>> + dup ] [ (>>diff) ] bi ; @@ -291,9 +293,9 @@ PRIVATE> binary [ parse-marker { SOI } assert= parse-headers - contents + contents ] with-file-reader - dup jpeg-image [ + dup loading-jpeg [ baseline-parse baseline-decompress jpeg> bitmap>> 3 [ color-transform ] change-each @@ -302,5 +304,3 @@ PRIVATE> M: jpeg-image load-image* ( path jpeg-image -- bitmap ) drop load-jpeg ; - -{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor index 19f2fd12c8..51d4e0fadf 100644 --- a/basis/images/loader/loader.factor +++ b/basis/images/loader/loader.factor @@ -7,16 +7,18 @@ IN: images.loader ERROR: unknown-image-extension extension ; lower types get ?at [ unknown-image-extension ] unless ; + PRIVATE> : register-image-class ( extension class -- ) swap types get set-at ; : load-image ( path -- image ) - dup image-class new load-image* ; + dup image-class load-image* ; diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index d4b284142f..fd5e36e212 100755 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -7,12 +7,15 @@ checksums checksums.crc32 compression.inflate grouping byte-arrays images.loader ; IN: images.png -TUPLE: png-image < image chunks +SINGLETON: png-image +"png" png-image register-image-class + +TUPLE: loading-png < image chunks width height bit-depth color-type compression-method filter-method interlace-method uncompressed ; -CONSTRUCTOR: png-image ( -- image ) -V{ } clone >>chunks ; +CONSTRUCTOR: loading-png ( -- image ) + V{ } clone >>chunks ; TUPLE: png-chunk length type data ; @@ -104,9 +107,8 @@ ERROR: unimplemented-color-type image ; } case ; : load-png ( path -- image ) - [ binary ] [ file-info size>> ] bi - stream-throws [ - + binary stream-throws [ + read-png-header read-png-chunks parse-ihdr-chunk @@ -116,5 +118,3 @@ ERROR: unimplemented-color-type image ; M: png-image load-image* drop load-png ; - -"png" png-image register-image-class diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index c98f737b11..876076e9fe 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -9,10 +9,10 @@ strings math.vectors specialized-arrays.float locals images.loader ; IN: images.tiff -TUPLE: tiff-image < image ; +SINGLETON: tiff-image -TUPLE: parsed-tiff endianness the-answer ifd-offset ifds ; -CONSTRUCTOR: parsed-tiff ( -- tiff ) V{ } clone >>ifds ; +TUPLE: loading-tiff endianness the-answer ifd-offset ifds ; +CONSTRUCTOR: loading-tiff ( -- tiff ) V{ } clone >>ifds ; TUPLE: ifd count ifd-entries next processed-tags strips bitmap ; @@ -410,7 +410,7 @@ ERROR: bad-small-ifd-type n ; [ nip unhandled-ifd-entry swap ] } case ; -: process-ifds ( parsed-tiff -- parsed-tiff ) +: process-ifds ( loading-tiff -- loading-tiff ) [ [ dup ifd-entries>> @@ -483,18 +483,6 @@ ERROR: unknown-component-order ifd ; [ unknown-component-order ] } case ; -: normalize-alpha-data ( seq -- byte-array ) - B{ } like dup - byte-array>float-array - 4 - [ - dup fourth dup 0 = [ - 2drop - ] [ - [ 3 head-slice ] dip '[ _ / ] change-each - ] if - ] each ; - : handle-alpha-data ( ifd -- ifd ) dup extra-samples find-tag { { extra-samples-associated-alpha-data [ ] } @@ -508,17 +496,17 @@ ERROR: unknown-component-order ifd ; [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ] [ ifd-component-order f ] [ bitmap>> ] - } cleave tiff-image boa ; + } cleave image boa ; : tiff>image ( image -- image ) ifds>> [ ifd>image ] map first ; -: with-tiff-endianness ( parsed-tiff quot -- ) +: with-tiff-endianness ( loading-tiff quot -- ) [ dup endianness>> ] dip with-endianness ; inline -: load-tiff-ifds ( path -- parsed-tiff ) +: load-tiff-ifds ( path -- loading-tiff ) binary [ - + read-header [ dup ifd-offset>> read-ifds process-ifds @@ -550,10 +538,10 @@ ERROR: unknown-component-order ifd ; drop "no planar configuration" throw ] if ; -: process-tif-ifds ( parsed-tiff -- ) +: process-tif-ifds ( loading-tiff -- ) ifds>> [ process-ifd ] each ; -: load-tiff ( path -- parsed-tiff ) +: load-tiff ( path -- loading-tiff ) [ load-tiff-ifds dup ] keep binary [ [ process-tif-ifds ] with-tiff-endianness diff --git a/basis/io/streams/limited/limited.factor b/basis/io/streams/limited/limited.factor index b1b07a08c0..fd441e4c4d 100755 --- a/basis/io/streams/limited/limited.factor +++ b/basis/io/streams/limited/limited.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math io io.encodings destructors accessors -sequences namespaces byte-vectors fry combinators ; +USING: accessors byte-vectors combinators destructors fry io +io.encodings io.files io.files.info kernel math namespaces +sequences ; IN: io.streams.limited TUPLE: limited-stream stream count limit mode stack ; @@ -16,6 +17,12 @@ SINGLETONS: stream-throws stream-eofs ; swap >>stream 0 >>count ; +: ( path encoding mode -- stream' ) + [ + [ ] + [ drop file-info size>> ] 2bi + ] dip ; + GENERIC# limit 2 ( stream limit mode -- stream' ) M: decoder limit ( stream limit mode -- stream' ) diff --git a/basis/opengl/gl/gl.factor b/basis/opengl/gl/gl.factor index 39a8a2c4fe..be457dcd00 100644 --- a/basis/opengl/gl/gl.factor +++ b/basis/opengl/gl/gl.factor @@ -1872,7 +1872,7 @@ GL-FUNCTION: void glUniform4uivEXT { } ( GLint location, GLsizei count, GLuint* GL-FUNCTION: void glGetUniformuivEXT { } ( GLuint program, GLint location, GLuint* params ) ; GL-FUNCTION: void glBindFragDataLocationEXT { } ( GLuint program, GLuint colorNumber, GLchar* name ) ; -GL-FUNCTION: GLint GetFragDataLocationEXT { } ( GLuint program, GLchar* name ) ; +GL-FUNCTION: GLint glGetFragDataLocationEXT { } ( GLuint program, GLchar* name ) ; CONSTANT: GL_VERTEX_ATTRIB_ARRAY_INTEGER_EXT HEX: 88FD CONSTANT: GL_SAMPLER_1D_ARRAY_EXT HEX: 8DC0 diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 38fb220c69..dfce3d3eee 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -217,4 +217,3 @@ M: world check-world-pixel-format : with-world-pixel-format ( world quot -- ) [ dup dup world-pixel-format-attributes ] dip [ 2dup check-world-pixel-format ] prepose with-disposal ; inline - diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 144530399c..aee19279a4 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -206,8 +206,11 @@ PRIVATE> : open-world-window ( world -- ) dup pref-dim >>dim dup relayout graft ; +: open-window* ( gadget title/attributes -- window ) + ?attributes [ open-world-window ] keep ; + : open-window ( gadget title/attributes -- ) - ?attributes open-world-window ; + open-window* drop ; : set-fullscreen ( gadget ? -- ) [ find-world ] dip (set-fullscreen) ; diff --git a/extra/game-loop/game-loop.factor b/extra/game-loop/game-loop.factor index 8abbe6ba25..982319541b 100644 --- a/extra/game-loop/game-loop.factor +++ b/extra/game-loop/game-loop.factor @@ -1,5 +1,5 @@ -USING: accessors calendar destructors kernel math math.order namespaces -system threads ; +USING: accessors calendar continuations destructors kernel math +math.order namespaces system threads ui ui.gadgets.worlds ; IN: game-loop TUPLE: game-loop @@ -27,6 +27,16 @@ SYMBOL: game-loop CONSTANT: MAX-FRAMES-TO-SKIP 5 +DEFER: stop-loop + +TUPLE: game-loop-error game-loop error ; + +: ?ui-error ( error -- ) + ui-running? [ ui-error ] [ rethrow ] if ; + +: game-loop-error ( game-loop error -- ) + [ drop stop-loop ] [ \ game-loop-error boa ?ui-error ] 2bi ; + > - ; @@ -91,3 +103,6 @@ PRIVATE> M: game-loop dispose stop-loop ; +USING: vocabs vocabs.loader ; + +"prettyprint" vocab [ "game-loop.prettyprint" require ] when diff --git a/extra/game-loop/prettyprint/prettyprint.factor b/extra/game-loop/prettyprint/prettyprint.factor new file mode 100644 index 0000000000..8b20dd4c9d --- /dev/null +++ b/extra/game-loop/prettyprint/prettyprint.factor @@ -0,0 +1,9 @@ +! (c)2009 Joe Groff bsd license +USING: accessors debugger game-loop io ; +IN: game-loop.prettyprint + +M: game-loop-error error. + "An error occurred inside a game loop." print + "The game loop has been stopped to prevent runaway errors." print + "The error was:" print nl + error>> error. ; diff --git a/extra/images/processing/rotation/rotation-tests.factor b/extra/images/processing/rotation/rotation-tests.factor index 493f09b145..9d9e72a205 100755 --- a/extra/images/processing/rotation/rotation-tests.factor +++ b/extra/images/processing/rotation/rotation-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Kobi Lurie, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors fry images.loader images.normalization +USING: accessors fry images.loader images.processing.rotation kernel literals math sequences tools.test images.processing.rotation.private ; IN: images.processing.rotation.tests @@ -24,13 +24,13 @@ IN: images.processing.rotation.tests CONSTANT: pasted-image $[ "vocab:images/processing/rotation/test-bitmaps/PastedImage.bmp" - load-image normalize-image clone-image + load-image clone-image ] CONSTANT: pasted-image90 $[ "vocab:images/processing/rotation/test-bitmaps/PastedImage90.bmp" - load-image normalize-image clone-image + load-image clone-image ] CONSTANT: lake-image @@ -55,7 +55,7 @@ CONSTANT: lake-image "vocab:images/processing/rotation/test-bitmaps/small.bmp" load-image 90 rotate "vocab:images/processing/rotation/test-bitmaps/small-rotated.bmp" - load-image normalize-image = + load-image = ] unit-test [ t ] [ diff --git a/extra/managed-server/chat/chat.factor b/extra/managed-server/chat/chat.factor index 4e841ec95e..f60445c48f 100644 --- a/extra/managed-server/chat/chat.factor +++ b/extra/managed-server/chat/chat.factor @@ -126,7 +126,8 @@ M: chat-server handle-client-disconnect ] "" append-outputs-as send-everyone ; M: chat-server handle-already-logged-in - username username-taken-string send-line ; + username username-taken-string send-line + t client (>>quit?) ; M: chat-server handle-managed-client* readln dup f = [ t client (>>quit?) ] when diff --git a/extra/managed-server/managed-server.factor b/extra/managed-server/managed-server.factor index 4d4a440525..6f9bdf25f1 100644 --- a/extra/managed-server/managed-server.factor +++ b/extra/managed-server/managed-server.factor @@ -11,7 +11,7 @@ TUPLE: managed-server < threaded-server clients ; TUPLE: managed-client input-stream output-stream local-address remote-address -username object quit? ; +username object quit? logged-in? ; HOOK: handle-login threaded-server ( -- username ) HOOK: handle-managed-client* managed-server ( -- ) @@ -62,26 +62,39 @@ PRIVATE> local-address get >>local-address remote-address get >>remote-address ; -: check-logged-in ( username -- username ) - dup clients key? [ handle-already-logged-in ] when ; +: maybe-login-client ( -- ) + username clients key? [ + handle-already-logged-in + ] [ + t client (>>logged-in?) + client username clients set-at + ] if ; -: add-managed-client ( -- ) - client username check-logged-in clients set-at ; +: when-logged-in ( quot -- ) + client logged-in?>> [ call ] [ drop ] if ; inline : delete-managed-client ( -- ) - username server clients>> delete-at ; + [ username server clients>> delete-at ] when-logged-in ; : handle-managed-client ( -- ) handle-login managed-client set - add-managed-client handle-client-join - [ handle-managed-client* client quit?>> not ] loop ; + maybe-login-client [ + handle-client-join + [ handle-managed-client* client quit?>> not ] loop + ] when-logged-in ; + +: cleanup-client ( -- ) + [ + delete-managed-client + handle-client-disconnect + ] when-logged-in ; PRIVATE> M: managed-server handle-client* managed-server set [ handle-managed-client ] - [ delete-managed-client handle-client-disconnect ] + [ cleanup-client ] [ ] cleanup ; : new-managed-server ( port name encoding class -- server ) diff --git a/extra/ui/gadgets/worlds/null/null.factor b/extra/ui/gadgets/worlds/null/null.factor new file mode 100644 index 0000000000..26fc3e8a94 --- /dev/null +++ b/extra/ui/gadgets/worlds/null/null.factor @@ -0,0 +1,27 @@ +USING: accessors kernel ui ui.backend ui.gadgets +ui.gadgets.worlds ui.pixel-formats ; +IN: ui.gadgets.worlds.null + +TUPLE: null-world < world ; +M: null-world begin-world drop ; +M: null-world end-world drop ; +M: null-world draw-world* drop ; +M: null-world resize-world drop ; +M: null-world pref-dim* drop { 512 512 } ; + +: null-window ( title -- world ) + + swap >>title + null-world >>world-class + { + windowed + double-buffered + backing-store + T{ depth-bits f 24 } + } >>pixel-format-attributes + f swap open-window* ; + +: into-window ( world quot -- world ) + [ dup handle>> ] dip with-gl-context ; inline + +