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/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 8bf8d59944..151c12132b 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -2,14 +2,14 @@ ! 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 ; @@ -17,62 +17,130 @@ IN: images.bitmap TUPLE: bitmap-image < image ; -! Used to construct the final bitmap-image - 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 +152,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,53 +210,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>> [ + read >>color-index + ] [ + 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 ) +: loading-bitmap>image ( image loading-bitmap -- bitmap-image ) { [ 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 ; + swap load-bitmap loading-bitmap>image ; "bmp" bitmap-image register-image-class @@ -165,6 +278,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/png/png.factor b/basis/images/png/png.factor index d4b284142f..b8a9a1d569 100755 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -104,8 +104,7 @@ 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 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/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. ;