steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
John Benediktsson 2009-06-03 21:50:09 -07:00
parent 0c0f796267 a506ddbbfc
commit b1136c77b5
7 changed files with 216 additions and 64 deletions
basis
bitstreams
compression/run-length
images
io/streams/limited
extra/game-loop

6
basis/bitstreams/bitstreams.factor
View File

@ -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 <msb0-bit-reader> '[
drop n _ read
] { } map-as ;

2
basis/compression/run-length/run-length.factor
View File

@ -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 <array> ] map concat ;

228
basis/images/bitmap/bitmap.factor
View File

@ -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
<PRIVATE
: 8bit>buffer ( bitmap -- array )
[ color-palette>> 4 <sliced-groups> [ 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 <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 ;
: reverse-lines ( byte-array width -- byte-array )
<sliced-groups> <reversed> 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 <sliced-groups>
[ 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 <limited-file-reader> [
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 )
<sliced-groups> <reversed> concat ; inline
: save-bitmap ( image path -- )
binary [
B{ CHAR: B CHAR: M } write

3
basis/images/png/png.factor
View File

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

11
basis/io/streams/limited/limited.factor
View File

@ -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 ;
: <limited-file-reader> ( path encoding mode -- stream' )
[
[ <file-reader> ]
[ drop file-info size>> ] 2bi
] dip <limited-stream> ;
GENERIC# limit 2 ( stream limit mode -- stream' )
M: decoder limit ( stream limit mode -- stream' )

21
extra/game-loop/game-loop.factor
View File

@ -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 ;
<PRIVATE
: redraw ( loop -- )
@ -54,7 +64,9 @@ CONSTANT: MAX-FRAMES-TO-SKIP 5
[ drop ] if ;
: 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 )
millis swap benchmark-time>> - ;
@ -91,3 +103,6 @@ PRIVATE>
M: game-loop dispose
stop-loop ;
USING: vocabs vocabs.loader ;
"prettyprint" vocab [ "game-loop.prettyprint" require ] when

9
extra/game-loop/prettyprint/prettyprint.factor Normal file
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. ;