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

refactoring bitmap to bitmap.loading and bitmap.saving vocabs

db4
Doug Coleman 2009-06-06 21:10:40 -04:00
parent ce37c8e082
commit 44850e6533
3 changed files with 225 additions and 141 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2,34 +2,23 @@
! 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
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 ;
images.bitmap.loading images.loader io io.binary
io.encodings.8-bit io.encodings.binary io.encodings.string
io.files io.streams.limited kernel locals macros math
math.bitwise math.functions namespaces sequences
specialized-arrays.uint specialized-arrays.ushort strings
summary ;
QUALIFIED-WITH: bitstreams b
IN: images.bitmap
: read2 ( -- n ) 2 read le> ;
: read4 ( -- n ) 4 read le> ;
: write2 ( n -- ) 2 >le write ;
: write4 ( n -- ) 4 >le write ;
SINGLETON: bitmap-image
"bmp" bitmap-image register-image-class
TUPLE: loading-bitmap
magic size reserved1 reserved2 offset header-length width
height planes bit-count compression size-image
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 ;
! endpoints-triple is ciexyzX/Y/Z, 3x fixed-point-2.30 aka 3x uint
: write2 ( n -- ) 2 >le write ;
: write4 ( n -- ) 4 >le write ;
<PRIVATE
: os2-color-lookup ( loading-bitmap -- seq )
@ -48,7 +37,7 @@ color-palette color-index bitfields ;
'[ _ nth ] map concat ;
: color-lookup ( loading-bitmap -- seq )
dup header-length>> {
dup file-header>> header-length>> {
{ 12 [ os2-color-lookup ] }
{ 64 [ os2v2-color-lookup ] }
{ 40 [ v3-color-lookup ] }
@ -66,7 +55,7 @@ ERROR: bmp-not-supported n ;
] { } map-as B{ } concat-as ;
: bitmap>bytes ( loading-bitmap -- byte-array )
dup bit-count>>
dup header>> bit-count>>
{
{ 32 [ color-index>> ] }
{ 24 [ color-index>> ] }
@ -82,13 +71,13 @@ ERROR: bmp-not-supported n ;
color-index>>
] }
{ 8 [ color-lookup ] }
{ 4 [ [ 4 b:byte-array-n>seq ] change-color-index color-lookup ] }
{ 4 [ B [ 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>> {
dup header>> bit-count>> {
{ 16 [ dup color-palette>> 4 group [ le> ] map ] }
{ 32 [ { HEX: ff0000 HEX: ff00 HEX: ff } ] }
} case reverse >>bitfields ;
@ -100,7 +89,7 @@ M: unsupported-bitfield-widths summary
: uncompress-bitfield-widths ( loading-bitmap -- loading-bitmap' )
set-bitfield-widths
dup bit-count>> {
dup header>> bit-count>> {
{ 16 [
dup bitfields>> '[
byte-array>ushort-array _ uncompress-bitfield
@ -116,8 +105,16 @@ M: unsupported-bitfield-widths summary
ERROR: unsupported-bitmap-compression compression ;
: uncompress-bitmap ( loading-bitmap -- loading-bitmap' )
dup compression>> {
GENERIC: uncompress-bitmap* ( loading-bitmap header -- loading-bitmap )
: uncompress-bitmap ( loading-bitmap -- loading-bitmap )
dup header>> uncompress-bitmap* ;
M: os2-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
drop ;
M: v-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
compression>> {
{ f [ ] }
{ 0 [ ] }
{ 1 [ [ run-length-uncompress ] change-color-index ] }
@ -134,73 +131,11 @@ ERROR: unsupported-bitmap-compression compression ;
uncompress-bitmap
bitmap>bytes ;
: parse-file-header ( loading-bitmap -- loading-bitmap )
2 read latin1 decode >>magic
read4 >>size
read2 >>reserved1
read2 >>reserved2
read4 >>offset ;
: read-v3-header ( loading-bitmap -- loading-bitmap )
read4 >>width
read4 32 >signed >>height
read2 >>planes
read2 >>bit-count
read4 >>compression
read4 >>size-image
read4 >>x-pels
read4 >>y-pels
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 )
file-header>>
[ offset>> 14 - ] [ header-length>> ] bi - ;
: color-index-length ( loading-bitmap -- n )
: color-index-length ( header -- n )
{
[ width>> ]
[ planes>> * ]
@ -208,57 +143,8 @@ ERROR: unknown-bitmap-header n ;
[ height>> abs * ]
} cleave ;
: image-size ( loading-bitmap -- n )
[ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ;
: parse-bitmap ( loading-bitmap -- loading-bitmap )
dup color-palette-length read >>color-palette
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 stream-throws <limited-file-reader> [
loading-bitmap new
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 [ BGR ] }
{ 24 [ BGR ] }
{ 16 [ BGR ] }
{ 8 [ BGR ] }
{ 4 [ BGR ] }
{ 1 [ BGR ] }
[ unknown-component-order ]
} case ;
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 < not >>upside-down? ]
[ compression>> 3 = [ t >>upside-down? ] when ]
[ bitmap>component-order >>component-order ]
} cleave ;
PRIVATE>
: bitmap>color-index ( bitmap -- byte-array )
@ -301,7 +187,7 @@ PRIVATE>
! compression
[ drop 0 write4 ]
! size-image
! image-size
[ bitmap>color-index length write4 ]
! x-pels

1
basis/images/bitmap/loading/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

197
basis/images/bitmap/loading/loading.factor Normal file
View File

@ -0,0 +1,197 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators images images.bitmap
images.bitmap.private io io.binary io.encodings.8-bit
io.encodings.binary io.encodings.string io.streams.limited
kernel math math.bitwise ;
IN: images.bitmap.loading
! http://www.fileformat.info/format/bmp/egff.htm
ERROR: unknown-component-order bitmap ;
ERROR: unknown-bitmap-header n ;
: read2 ( -- n ) 2 read le> ;
: read4 ( -- n ) 4 read le> ;
TUPLE: loading-bitmap
file-header header
color-palette color-index bitfields ;
TUPLE: file-header
magic size reserved1 reserved2 offset header-length ;
TUPLE: v3-header
width height planes bit-count
compression image-size x-resolution y-resolution
colors-used colors-important ;
TUPLE: v4-header < v3-header
red-mask green-mask blue-mask alpha-mask
cs-type end-points
gamma-red gamma-green gamma-blue ;
TUPLE: v5-header < v4-header
intent profile-data profile-size reserved3 ;
TUPLE: os2v1-header width height planes bit-count ;
TUPLE: os2v2-header < os2v1-header
compression image-size x-resolution y-resolution
colors-used colors-important units reserved
recording rendering size1 size2 color-encoding identifier ;
UNION: v-header v3-header v4-header v5-header ;
UNION: os2-header os2v1-header os2v2-header ;
: parse-file-header ( -- file-header )
\ file-header new
2 read latin1 decode >>magic
read4 >>size
read2 >>reserved1
read2 >>reserved2
read4 >>offset
read4 >>header-length ;
: read-v3-header-data ( header -- header )
read4 >>width
read4 32 >signed >>height
read2 >>planes
read2 >>bit-count
read4 >>compression
read4 >>image-size
read4 >>x-resolution
read4 >>y-resolution
read4 >>colors-used
read4 >>colors-important ;
: read-v3-header ( -- header )
\ v3-header new
read-v3-header-data ;
: read-v4-header-data ( header -- 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-v4-header ( -- v4-header )
\ v4-header new
read-v3-header-data
read-v4-header-data ;
: read-v5-header-data ( v5-header -- v5-header )
read4 >>intent
read4 >>profile-data
read4 >>profile-size
read4 >>reserved3 ;
: read-v5-header ( -- loading-bitmap )
\ v5-header new
read-v3-header-data
read-v4-header-data
read-v5-header-data ;
: read-os2v1-header ( -- os2v1-header )
\ os2v1-header new
read2 >>width
read2 16 >signed >>height
read2 >>planes
read2 >>bit-count ;
: read-os2v2-header-data ( os2v2-header -- os2v2-header )
read4 >>width
read4 32 >signed >>height
read2 >>planes
read2 >>bit-count
read4 >>compression
read4 >>image-size
read4 >>x-resolution
read4 >>y-resolution
read4 >>colors-used
read4 >>colors-important
read2 >>units
read2 >>reserved
read2 >>recording
read2 >>rendering
read4 >>size1
read4 >>size2
read4 >>color-encoding
4 read >>identifier ;
: read-os2v2-header ( -- os2v2-header )
\ os2v2-header new
read-os2v2-header-data ;
: parse-header ( n -- header )
{
{ 12 [ read-os2v1-header ] }
{ 64 [ read-os2v2-header ] }
{ 40 [ read-v3-header ] }
{ 108 [ read-v4-header ] }
{ 124 [ read-v5-header ] }
[ unknown-bitmap-header ]
} case ;
: parse-color-palette ( loading-bitmap -- loading-bitmap )
dup color-palette-length read >>color-palette ;
GENERIC: parse-color-data* ( loading-bitmap header -- loading-bitmap )
: parse-color-data ( loading-bitmap -- loading-bitmap )
dup header>> parse-color-data* ;
M: os2v1-header parse-color-data* ( loading-bitmap header -- loading-bitmap )
color-index-length read >>color-index ;
M: object parse-color-data* ( loading-bitmap header -- loading-bitmap )
dup image-size>> [
nip
] [
color-index-length
] if* read >>color-index ;
: bitmap>component-order ( loading-bitmap -- object )
header>> bit-count>> {
{ 32 [ BGR ] }
{ 24 [ BGR ] }
{ 16 [ BGR ] }
{ 8 [ BGR ] }
{ 4 [ BGR ] }
{ 1 [ BGR ] }
[ unknown-component-order ]
} case ;
ERROR: unsupported-bitmap-file magic ;
: load-bitmap ( path -- loading-bitmap )
binary stream-throws <limited-file-reader> [
\ loading-bitmap new
parse-file-header [ >>file-header ] [ ] bi magic>> {
{ "BM" [
dup file-header>> header-length>> parse-header >>header
parse-color-palette
parse-color-data
] }
! { "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 ;
M: bitmap-image load-image* ( path bitmap-image -- bitmap )
drop load-bitmap
[ image new ] dip
{
[ loading-bitmap>bytes >>bitmap ]
[ header>> [ width>> ] [ height>> abs ] bi 2array >>dim ]
[ header>> height>> 0 < not >>upside-down? ]
[ bitmap>component-order >>component-order ]
} cleave ;