#
# pure-tcl .bmp file read/write package.
#
# as of 2007-05-15, this code reads and writes 2-color, 16-color,
# 256-color, and 16.7-million-color .bmp files.
#
# written by S. Havelka (on tclchat: hat0)
#
namespace eval ::bmp {
namespace export readfile writefile
set header_def { bfType 2 bfSize 4 bfReserved1 2 bfReserved 2 bfOffBits 4 }
set info_def { biSize 4 biWidth 4 biHeight 4 biPlanes 2 biBitCount 2 biCompression 4 biSizeImage 4 biXPelsPerMeter 4 biYPelsPerMeter 4 biClrUsed 4 biClrImportant 4 }
}
#
# the data returned from this routine is:
# width, height, bits per pixel, a list of rgb quads (zero for true-color images),
# and a list of lists representing the pixel data
#
proc ::bmp::readfile { fname } {
variable header_def
variable info_def
#
# open the file
#
if { [catch {set fh [open $fname r] } err] } {
return -code error "couldn't open $fname for reading"
} else {
proc scan2 { in } { binary scan $in s val; return [expr {$val & 0xFFFF}] }
proc scan4 { in } { binary scan $in i val; return [expr {$val & 0xFFFFFFFF}] }
proc lprepend {var args} { upvar 1 $var v; set v [eval [list linsert $v 0] $args] }
fconfigure $fh -translation binary
#
# first, read in the header
#
foreach {name len} $header_def {
set in [read $fh $len]
set bmp($name) [expr {$len == 2 ? [scan2 $in] : [scan4 $in]}]
}
# is it a .bmp ?
if { $bmp(bfType) != 19778 } {
return -code error "$fname is not a valid bmp"
}
#
# second, read the bitmap info data
#
foreach {name len} $info_def {
set in [read $fh $len]
set bmp($name) [expr {$len == 2 ? [scan2 $in] : [scan4 $in]}]
}
# right now we only take the 'v3' format bmp
if { $bmp(biSize) != 40 } {
return -code error "we can only read v3 bmps at present"
}
#
# if this is a color-mapped image, read the rgbquad array.
# first, determine the # of rgb quads to read!
#
if { $bmp(biClrUsed) } {
set rgb_quads_to_read $bmp(biClrUsed)
} else {
switch $bmp(biBitCount) {
1 { set rgb_quads_to_read 2 }
4 { set rgb_quads_to_read 16 }
8 { set rgb_quads_to_read 256 }
24 { set rgb_quads_to_read 0 }
}
}
# and read in the rgb quads
set rgb_quads {}
for { set i 0 } { $i < $rgb_quads_to_read } { incr i } {
set in [read $fh 4]
binary scan $in cccc b g r x
lappend rgb_quads [list [expr {$r & 0xff}] [expr {$g & 0xff}] [expr {$b & 0xff}]]
}
#
# and now, read in the bitmap data, dword-aligned and in reverse order.
# first, calculate the line width in bytes and pad to dword
#
switch $bmp(biBitCount) {
1 { set line_width [expr {$bmp(biWidth)/8}] }
4 { set line_width [expr {$bmp(biWidth)/2}] }
8 { set line_width $bmp(biWidth) }
24 { set line_width [expr {$bmp(biWidth)*3}] }
}
set padded_line_width [expr {($line_width+3) & ~3}]
# and read in the lines, unpacking if the bitplane is 1 or 4 bpp
set bmp_data {}
for { set i 0 } { $i < $bmp(biHeight) } { incr i } {
set in [read $fh $padded_line_width]
if { $bmp(biBitCount) == 1 } {
binary scan $in b$bmp(biWidth) line
lprepend bmp_data [split $line ""]
} elseif { $bmp(biBitCount) == 4 } {
binary scan $in h$bmp(biWidth) line
set line [split $line ""]
lprepend bmp_data [string map { A 10 B 11 C 12 D 13 E 14 F 15 } $line]
} elseif { $bmp(biBitCount) == 8 } { {
binary scan $in c$line_width line
for { set j 0 } { $j < $line_width } { incr j } { lset line $j [expr {[lindex $line $j] & 0xff}] }
lprepend bmp_data $line
} elseif { $bmp(biBitCount) == 24 } {
binary scan $in c$line_width line
for { set j 0 } { $j < $line_width } { incr j } { lset line $j [expr {[lindex $line $j] & 0xff}] }
# note that bmp data is stored as bgr, not rgb
set fixed_line {}
foreach {b g r} $line {
lappend fixed_line $r $g $b
}
lprepend bmp_data $line
}
}
return [list $bmp(biWidth) $bmp(biHeight) $bmp(biBitCount) $rgb_quads $bmp_data]
}
}
#
# this routine needs:
# a list of rgb_quads, bitmap data, and a filename
# - rgb quads: 0-256. if 1-256, then bitmap data is indexed.
# if 0, then bitmap data is taken as rgb
# - bitmap data: a list of lists, each sublist one line of
# pixel data. either indexed or rgb.
#
proc ::bmp::writefile { rgb_quads bmp_data fname } {
variable header_def
variable info_def
#
# determine the bit depth
#
set qc [llength $rgb_quads]
if { !$qc } {
set bpp 24
} elseif { $qc == 2 } {
set bpp 1
} elseif { 2 < $qc && $qc <= 16 } {
set bpp 4
} elseif { 16 < $qc && $qc <= 256 } {
set bpp 8
} else {
return -code error "too many rgb quads!"
}
#
# verify that rgb data is all properly formed
#
foreach rgb $rgb_quads {
if { [llength $rgb] != 3 } {
return -code error "bad rgb data"
}
}
#
# and verify the bmp data
#
set height [llength $bmp_data]
if { !$height } {
return -code error "no bmp data provided"
}
set width [llength [lindex $bmp_data 0]]
if { $bpp == 24 && $width % 3 } {
return -code error "given bmp data seems to be 24bpp, but is not divisible by 3"
}
for { set i 1 } { $i < $height } { incr i } {
if { [llength [lindex $bmp_data $i]] != $width } {
return -code error "all rows in bmp data must be the same width"
}
}
#
# calculate padded data size
#
switch $bpp {
1 { set byte_width [expr { (($width+7) & ~7) / 8}] }
4 { set byte_width [expr { (($width+1) & ~1) / 2}] }
8 { set byte_width $width }
24 {
set byte_width $width
set width [expr {$width / 3}]
}
}
set pad_width [expr {($byte_width+3) & ~3}]
set bmp_len [expr {$pad_width * $height}]
#
# ok! let's try to get a file handle
#
if { [catch { set fh [open $fname w] } err] } {
return -code error "couldn't open $fname for writing"
} else {
fconfigure $fh -translation binary
#
# ok! write out the header! first, the identifying bytes
#
puts -nonewline $fh [binary format s 19778]
#
# calculate and output the total bmp size
#
set header_len 0
foreach {junk len} $header_def {
set header_len [expr {$header_len + $len}]
}
set info_len 0
foreach {junk len} $info_def {
set info_len [expr {$info_len + $len}]
}
set rgb_len [expr {[llength $rgb_quads] * 4}]
puts -nonewline $fh [binary format i [expr {$header_len + $info_len + $rgb_len + $bmp_len}]]
#
# reserved bytes ..
#
puts -nonewline $fh [binary format s 0]
puts -nonewline $fh [binary format s 0]
#
# offset to bmp data
#
puts -nonewline $fh [binary format i [expr {$header_len + $info_len + $rgb_len}]]
#
# now output the info block (v3-style .bmp)
#
puts -nonewline $fh [binary format i 40]
puts -nonewline $fh [binary format i $width]
puts -nonewline $fh [binary format i $height]
puts -nonewline $fh [binary format s 0]
puts -nonewline $fh [binary format s $bpp]
puts -nonewline $fh [binary format i 0]
puts -nonewline $fh [binary format i 0]
puts -nonewline $fh [binary format i 0]
puts -nonewline $fh [binary format i 0]
puts -nonewline $fh [binary format i [llength $rgb_quads]]
puts -nonewline $fh [binary format i [llength $rgb_quads]]
#
# and now, the rgb quads
#
foreach my $rgb_quads {
foreach {r g b} $my break
puts -nonewline $fh [binary format cccc $b $g $r 0]
}
#
# at last, the bitmap data. note that each bitmap format has enough padding
# added to the line to ensure proper dword-alignment, no matter how much
# pixel data is provided.
#
for { incr height -1 } { $height != -1 } { incr height -1 } {
if { $bpp == 1 } {
puts -nonewline $fh [binary format B[expr {$pad_width*8}] [join [lindex $bmp_data $height] ""][string repeat 0 31]]
} elseif { $bpp == 4 } {
puts -nonewline $fh [binary format H[expr {$pad_width*2}] [join [string map { 10 A 11 B 12 C 13 D 14 E 15 F } [lindex $bmp_data $height]] ""][string repeat 0 7]]
} elseif { $bpp == 8 } {
puts -nonewline $fh [binary format c$pad_width "[lindex $bmp_data $height] 0 0 0"]
} elseif { $bpp == 24 } {
# note that, for some reason, rgb data is stored as bgr ...
set fixed_data {}
foreach {r g b} [lindex $bmp_data $height] {
lappend fixed_data $b $g $r
}
puts -nonewline $fh [binary format c$pad_width "$fixed_data 0 0 0"]
}
}
#
# behold, we're done!
#
close $fh
}
}
package provide bmp [lindex {Revision: 0.1.0} 1]