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

load greyscale png images, refactor some code

db4
Doug Coleman 2009-10-08 18:18:33 -05:00
parent 7403bcef0c
commit 77f968fad6
1 changed files with 61 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -58,7 +58,7 @@ ERROR: bad-checksum ;
4 read = [ bad-checksum ] unless 4 read = [ bad-checksum ] unless
4 cut-slice 4 cut-slice
[ ascii decode >>type ] [ B{ } like >>data ] bi* [ ascii decode >>type ] [ B{ } like >>data ] bi*
[ over chunks>> push ] [ over chunks>> push ]
[ type>> ] bi "IEND" = [ type>> ] bi "IEND" =
[ read-png-chunks ] unless ; [ read-png-chunks ] unless ;
@ -84,11 +84,13 @@ ERROR: unknown-color-type n ;
ERROR: unimplemented-color-type image ; ERROR: unimplemented-color-type image ;
: inflate-data ( loading-png -- bytes ) : inflate-data ( loading-png -- bytes )
find-compressed-bytes zlib-inflate ; find-compressed-bytes zlib-inflate ;
: png-components-per-pixel ( loading-png -- n ) : png-components-per-pixel ( loading-png -- n )
color-type>> { color-type>> {
{ greyscale [ 1 ] }
{ truecolor [ 3 ] } { truecolor [ 3 ] }
{ greyscale-alpha [ 2 ] }
{ truecolor-alpha [ 4 ] } { truecolor-alpha [ 4 ] }
[ unknown-color-type ] [ unknown-color-type ]
} case ; inline } case ; inline
@ -98,8 +100,8 @@ ERROR: unimplemented-color-type image ;
[ [ png-components-per-pixel ] [ bit-depth>> ] bi * ] [ [ png-components-per-pixel ] [ bit-depth>> ] bi * ]
[ width>> ] bi * 1 + ; [ width>> ] bi * 1 + ;
:: paeth ( a b c -- p ) :: paeth ( a b c -- p )
a b + c - { a b c } [ [ - abs ] keep 2array ] with map a b + c - { a b c } [ [ - abs ] keep 2array ] with map
sort-keys first second ; sort-keys first second ;
:: png-unfilter-line ( width prev curr filter -- curr' ) :: png-unfilter-line ( width prev curr filter -- curr' )
@ -114,7 +116,7 @@ ERROR: unimplemented-color-type image ;
{ filter-up [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] } { filter-up [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
{ filter-average [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] } { filter-average [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
{ filter-paeth [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] } { filter-paeth [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
} case } case
curr width tail ; curr width tail ;
:: reverse-png-filter ( lines n -- byte-array ) :: reverse-png-filter ( lines n -- byte-array )
@ -135,12 +137,12 @@ ERROR: unimplemented-interlace ;
{ interlace-none [ ] } { interlace-none [ ] }
{ interlace-adam7 [ unimplemented-interlace ] } { interlace-adam7 [ unimplemented-interlace ] }
[ unimplemented-interlace ] [ unimplemented-interlace ]
} case bs:<lsb0-bit-reader> ; } case bs:<msb0-bit-reader> ;
: uncompress-bytes ( loading-png -- bitstream ) : uncompress-bytes ( loading-png -- bitstream )
[ inflate-data ] [ interlace-method>> ] bi reverse-interlace ; [ inflate-data ] [ interlace-method>> ] bi reverse-interlace ;
:: png-image-bytes ( loading-png -- byte-array ) :: raw-bytes ( loading-png -- array )
loading-png uncompress-bytes :> bs loading-png uncompress-bytes :> bs
loading-png width>> :> width loading-png width>> :> width
loading-png height>> :> height loading-png height>> :> height
@ -165,33 +167,41 @@ ERROR: unknown-component-type n ;
: png-component ( loading-png -- obj ) : png-component ( loading-png -- obj )
bit-depth>> { bit-depth>> {
{ 1 [ ubyte-components ] }
{ 2 [ ubyte-components ] }
{ 4 [ ubyte-components ] }
{ 8 [ ubyte-components ] } { 8 [ ubyte-components ] }
{ 16 [ ushort-components ] } { 16 [ ushort-components ] }
[ unknown-component-type ] [ unknown-component-type ]
} case ; } case ;
: loading-png>image ( loading-png -- image ) : scale-factor ( n -- n' )
[ image new ] dip { {
[ png-image-bytes >>bitmap ] { 1 [ 255 ] }
[ [ width>> ] [ height>> ] bi 2array >>dim ] { 2 [ 127 ] }
[ png-component >>component-type ] { 4 [ 17 ] }
} cleave ; { 8 [ 1 ] }
} case ;
: decode-greyscale ( loading-png -- image ) : scale-greyscale ( byte-array loading-png -- byte-array' )
unimplemented-color-type ; [ bit-depth>> ] [ color-type>> ] bi {
{ greyscale [
: decode-truecolor ( loading-png -- image ) dup 16 = [
loading-png>image RGB >>component-order ; drop
] [
: decode-indexed-color ( loading-png -- image ) scale-factor '[ _ * ] B{ } map-as
unimplemented-color-type ; ] if
] }
: decode-greyscale-alpha ( loading-png -- image ) { greyscale-alpha [
unimplemented-color-type ; [ 8 group ] dip '[
[ [ 0 5 ] dip <slice> [ _ * ] change-each ] keep
: decode-truecolor-alpha ( loading-png -- image ) ] map B{ } concat-as
loading-png>image RGBA >>component-order ; ] }
} case ;
: decode-greyscale ( loading-png -- byte-array )
[ raw-bytes ] keep scale-greyscale ;
ERROR: invalid-color-type/bit-depth loading-png ; ERROR: invalid-color-type/bit-depth loading-png ;
: validate-bit-depth ( loading-png seq -- loading-png ) : validate-bit-depth ( loading-png seq -- loading-png )
@ -213,16 +223,33 @@ ERROR: invalid-color-type/bit-depth loading-png ;
: validate-truecolor-alpha ( loading-png -- loading-png ) : validate-truecolor-alpha ( loading-png -- loading-png )
{ 8 16 } validate-bit-depth ; { 8 16 } validate-bit-depth ;
: png>image ( loading-png -- image ) : loading-png>bitmap ( loading-png -- bytes component-order )
dup color-type>> { dup color-type>> {
{ greyscale [ validate-greyscale decode-greyscale ] } { greyscale [
{ truecolor [ validate-truecolor decode-truecolor ] } validate-greyscale decode-greyscale L
{ indexed-color [ validate-indexed-color decode-indexed-color ] } ] }
{ greyscale-alpha [ validate-greyscale-alpha decode-greyscale-alpha ] } { truecolor [
{ truecolor-alpha [ validate-truecolor-alpha decode-truecolor-alpha ] } validate-truecolor raw-bytes RGB
] }
{ indexed-color [
validate-indexed-color unimplemented-color-type
] }
{ greyscale-alpha [
validate-greyscale-alpha decode-greyscale LA
] }
{ truecolor-alpha [
validate-truecolor-alpha raw-bytes RGBA
] }
[ unknown-color-type ] [ unknown-color-type ]
} case ; } case ;
: loading-png>image ( loading-png -- image )
[ image new ] dip {
[ loading-png>bitmap [ >>bitmap ] [ >>component-order ] bi* ]
[ [ width>> ] [ height>> ] bi 2array >>dim ]
[ png-component >>component-type ]
} cleave ;
: load-png ( stream -- loading-png ) : load-png ( stream -- loading-png )
[ [
<loading-png> <loading-png>
@ -232,4 +259,4 @@ ERROR: invalid-color-type/bit-depth loading-png ;
] with-input-stream ; ] with-input-stream ;
M: png-image stream>image M: png-image stream>image
drop load-png png>image ; drop load-png loading-png>image ;