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

db4
John Benediktsson 2009-06-03 21:50:09 -07:00
commit b1136c77b5
7 changed files with 216 additions and 64 deletions

View File

@ -158,3 +158,9 @@ M: msb0-bit-reader peek ( n bs -- bits ) \ be> \ subseq>bits-be (peek) ;
writer bytes>> swap push writer bytes>> swap push
] unless ] unless
writer bytes>> ; writer bytes>> ;
:: byte-array-n>seq ( byte-array n -- seq )
byte-array length 8 * n / iota
byte-array <msb0-bit-reader> '[
drop n _ read
] { } map-as ;

View File

@ -3,5 +3,5 @@
USING: arrays grouping sequences ; USING: arrays grouping sequences ;
IN: compression.run-length IN: compression.run-length
: run-length-uncompress8 ( byte-array -- byte-array' ) : run-length-uncompress ( byte-array -- byte-array' )
2 group [ first2 <array> ] map concat ; 2 group [ first2 <array> ] map concat ;

View File

@ -2,14 +2,14 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types arrays byte-arrays columns USING: accessors alien alien.c-types arrays byte-arrays columns
combinators compression.run-length endian fry grouping images combinators compression.run-length endian fry grouping images
images.loader io io.binary io.encodings.binary io.files kernel images.loader io io.binary io.encodings.binary io.files
locals macros math math.bitwise math.functions namespaces io.streams.limited kernel locals macros math math.bitwise
sequences strings summary ; 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 IN: images.bitmap
: assert-sequence= ( a b -- )
2dup sequence= [ 2drop ] [ assert ] if ;
: read2 ( -- n ) 2 read le> ; : read2 ( -- n ) 2 read le> ;
: read4 ( -- n ) 4 read le> ; : read4 ( -- n ) 4 read le> ;
: write2 ( n -- ) 2 >le write ; : write2 ( n -- ) 2 >le write ;
@ -17,62 +17,130 @@ IN: images.bitmap
TUPLE: bitmap-image < image ; TUPLE: bitmap-image < image ;
! Used to construct the final bitmap-image
TUPLE: loading-bitmap TUPLE: loading-bitmap
size reserved offset header-length width magic size reserved1 reserved2 offset header-length width
height planes bit-count compression size-image height planes bit-count compression size-image
x-pels y-pels color-used color-important color-palette color-index x-pels y-pels color-used color-important
uncompressed-bytes ; 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 ; ! endpoints-triple is ciexyzX/Y/Z, 3x fixed-point-2.30 aka 3x uint
M: bitmap-magic summary
drop "First two bytes of bitmap stream must be 'BM'" ;
<PRIVATE <PRIVATE
: 8bit>buffer ( bitmap -- array ) : os2-color-lookup ( loading-bitmap -- seq )
[ color-palette>> 4 <sliced-groups> [ 3 head-slice ] map ] [ color-index>> >array ]
[ color-index>> >array ] bi [ swap nth ] with map concat ; [ color-palette>> 3 <sliced-groups> ] bi
'[ _ nth ] map concat ;
: os2v2-color-lookup ( loading-bitmap -- seq )
[ color-index>> >array ]
[ color-palette>> 3 <sliced-groups> ] bi
'[ _ nth ] map concat ;
: v3-color-lookup ( loading-bitmap -- seq )
[ color-index>> >array ]
[ color-palette>> 4 <sliced-groups> [ 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 ; ERROR: bmp-not-supported n ;
: reverse-lines ( byte-array width -- byte-array ) : uncompress-bitfield ( seq masks -- bytes' )
<sliced-groups> <reversed> concat ; inline '[
_ [
[ 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>> dup bit-count>>
{ {
{ 32 [ color-index>> ] } { 32 [ color-index>> ] }
{ 24 [ [ color-index>> ] [ width>> 3 * ] bi reverse-lines ] } { 24 [ color-index>> ] }
{ 8 [ [ 8bit>buffer ] [ width>> 3 * ] bi reverse-lines ] } { 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 ] [ bmp-not-supported ]
} case >byte-array ; } 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 ; ERROR: unsupported-bitmap-compression compression ;
: uncompress-bitmap ( loading-bitmap -- loading-bitmap' ) : uncompress-bitmap ( loading-bitmap -- loading-bitmap' )
dup compression>> { dup compression>> {
{ f [ ] }
{ 0 [ ] } { 0 [ ] }
{ 1 [ [ run-length-uncompress8 ] change-color-index ] } { 1 [ [ run-length-uncompress ] change-color-index ] }
{ 2 [ "run-length encoding 4" unsupported-bitmap-compression ] } { 2 [ [ 4 b:byte-array-n>seq run-length-uncompress >byte-array ] change-color-index ] }
{ 3 [ "bitfields" unsupported-bitmap-compression ] } { 3 [ uncompress-bitfield-widths ] }
{ 4 [ "jpeg" unsupported-bitmap-compression ] } { 4 [ "jpeg" unsupported-bitmap-compression ] }
{ 5 [ "png" unsupported-bitmap-compression ] } { 5 [ "png" unsupported-bitmap-compression ] }
} case ; } case ;
: bitmap-padding ( width -- n )
3 * 4 mod 4 swap - 4 mod ; inline
: loading-bitmap>bytes ( loading-bitmap -- byte-array ) : loading-bitmap>bytes ( loading-bitmap -- byte-array )
uncompress-bitmap bitmap>bytes ; uncompress-bitmap
bitmap>bytes ;
: parse-file-header ( loading-bitmap -- loading-bitmap ) : parse-file-header ( loading-bitmap -- loading-bitmap )
2 read "BM" assert-sequence= 2 read latin1 decode >>magic
read4 >>size read4 >>size
read4 >>reserved read2 >>reserved1
read2 >>reserved2
read4 >>offset ; read4 >>offset ;
: parse-bitmap-header ( loading-bitmap -- loading-bitmap ) : read-v3-header ( loading-bitmap -- loading-bitmap )
read4 >>header-length
read4 >>width read4 >>width
read4 32 >signed >>height read4 32 >signed >>height
read2 >>planes read2 >>planes
@ -84,6 +152,50 @@ ERROR: unsupported-bitmap-compression compression ;
read4 >>color-used read4 >>color-used
read4 >>color-important ; 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 ) : color-palette-length ( loading-bitmap -- n )
[ offset>> 14 - ] [ header-length>> ] bi - ; [ offset>> 14 - ] [ header-length>> ] bi - ;
@ -98,53 +210,54 @@ ERROR: unsupported-bitmap-compression compression ;
: image-size ( loading-bitmap -- n ) : image-size ( loading-bitmap -- n )
[ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ; [ [ 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 <sliced-groups>
[ width*3 head-slice ] map concat
] change-color-index
] when ;
: parse-bitmap ( loading-bitmap -- loading-bitmap ) : parse-bitmap ( loading-bitmap -- loading-bitmap )
dup color-palette-length read >>color-palette dup color-palette-length read >>color-palette
dup color-index-length read >>color-index dup size-image>> [
fixup-color-index ; read >>color-index
] [
dup color-index-length read >>color-index
] if* ;
ERROR: unsupported-bitmap-file magic ;
: load-bitmap ( path -- loading-bitmap ) : load-bitmap ( path -- loading-bitmap )
binary [ binary stream-throws <limited-file-reader> [
loading-bitmap new loading-bitmap new
parse-file-header parse-bitmap-header parse-bitmap parse-file-header dup magic>> {
] with-file-reader ; { "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 ; ERROR: unknown-component-order bitmap ;
: bitmap>component-order ( loading-bitmap -- object ) : bitmap>component-order ( loading-bitmap -- object )
bit-count>> { bit-count>> {
{ 32 [ BGRA ] } { 32 [ BGR ] }
{ 24 [ BGR ] } { 24 [ BGR ] }
{ 16 [ BGR ] }
{ 8 [ BGR ] } { 8 [ BGR ] }
{ 4 [ BGR ] }
{ 1 [ BGR ] }
[ unknown-component-order ] [ unknown-component-order ]
} case ; } case ;
: loading-bitmap>bitmap-image ( bitmap-image loading-bitmap -- bitmap-image ) : loading-bitmap>image ( image loading-bitmap -- bitmap-image )
{ {
[ loading-bitmap>bytes >>bitmap ] [ loading-bitmap>bytes >>bitmap ]
[ [ width>> ] [ height>> abs ] bi 2array >>dim ] [ [ 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 ] [ bitmap>component-order >>component-order ]
} cleave ; } cleave ;
M: bitmap-image load-image* ( path loading-bitmap -- bitmap ) 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 "bmp" bitmap-image register-image-class
@ -165,6 +278,9 @@ PRIVATE>
] if ] if
] bi ; ] bi ;
: reverse-lines ( byte-array width -- byte-array )
<sliced-groups> <reversed> concat ; inline
: save-bitmap ( image path -- ) : save-bitmap ( image path -- )
binary [ binary [
B{ CHAR: B CHAR: M } write B{ CHAR: B CHAR: M } write

View File

@ -104,8 +104,7 @@ ERROR: unimplemented-color-type image ;
} case ; } case ;
: load-png ( path -- image ) : load-png ( path -- image )
[ binary <file-reader> ] [ file-info size>> ] bi binary stream-throws <limited-file-reader> [
stream-throws <limited-stream> [
<png-image> <png-image>
read-png-header read-png-header
read-png-chunks read-png-chunks

View File

@ -1,8 +1,9 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2009 Doug Coleman. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math io io.encodings destructors accessors USING: accessors byte-vectors combinators destructors fry io
sequences namespaces byte-vectors fry combinators ; io.encodings io.files io.files.info kernel math namespaces
sequences ;
IN: io.streams.limited IN: io.streams.limited
TUPLE: limited-stream stream count limit mode stack ; TUPLE: limited-stream stream count limit mode stack ;
@ -16,6 +17,12 @@ SINGLETONS: stream-throws stream-eofs ;
swap >>stream swap >>stream
0 >>count ; 0 >>count ;
: <limited-file-reader> ( path encoding mode -- stream' )
[
[ <file-reader> ]
[ drop file-info size>> ] 2bi
] dip <limited-stream> ;
GENERIC# limit 2 ( stream limit mode -- stream' ) GENERIC# limit 2 ( stream limit mode -- stream' )
M: decoder limit ( stream limit mode -- stream' ) M: decoder limit ( stream limit mode -- stream' )

View File

@ -1,5 +1,5 @@
USING: accessors calendar destructors kernel math math.order namespaces USING: accessors calendar continuations destructors kernel math
system threads ; math.order namespaces system threads ui ui.gadgets.worlds ;
IN: game-loop IN: game-loop
TUPLE: game-loop TUPLE: game-loop
@ -27,6 +27,16 @@ SYMBOL: game-loop
CONSTANT: MAX-FRAMES-TO-SKIP 5 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 ;
<PRIVATE <PRIVATE
: redraw ( loop -- ) : redraw ( loop -- )
@ -54,7 +64,9 @@ CONSTANT: MAX-FRAMES-TO-SKIP 5
[ drop ] if ; [ drop ] if ;
: run-loop ( loop -- ) : run-loop ( loop -- )
dup game-loop [ (run-loop) ] with-variable ; dup game-loop
[ [ (run-loop) ] [ game-loop-error ] recover ]
with-variable ;
: benchmark-millis ( loop -- millis ) : benchmark-millis ( loop -- millis )
millis swap benchmark-time>> - ; millis swap benchmark-time>> - ;
@ -91,3 +103,6 @@ PRIVATE>
M: game-loop dispose M: game-loop dispose
stop-loop ; stop-loop ;
USING: vocabs vocabs.loader ;
"prettyprint" vocab [ "game-loop.prettyprint" require ] when

View File

@ -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. ;