#
 # pure-tcl .bmp file read/write package.
 #
 # v0.1  (2007-05-15)  this code reads and writes 2-color, 16-color,
 # 256-color, and 16.7-million-color non-compressed .bmp files.
 #
 # v0.2  (2007-07-01)  fixed a typo and bug
 #
 # 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 $fixed_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]
----
See also [BMP].

See also [BMP Dump].

----

[male] - 2007-05-16:

Can anybody explain or introduce perhabs the common BMP RLE compression?

The background - I already have used a self-written BMP package, but the images I could create (even with this [pure-tcl BMP reader/writer]) are relative big. And I really would like to reduce the size of those BMP files.

Best regards,

Martin

[Duoas] Hmm, I didn't notice that this doesn't do RLE.

Google is your best friend here. Using it, I found this site which deals only with MS BMP RLE [http://www.multimedia.cx/msrle.txt]. Microsoft BMP format is rather obnoxious in unintuitive places, but if you sick with 4- or 8-bits per pixel you can compress it rather easily. If your source images cannot be compressed into a 256-color or less colormapped image, then you cannot RLE-compress them, alas.

I don't have an algorithm handy for you, but you should be able to write one in one sitting easily enough. Just remember to keep in mind the EOL markers and DWORD padding BMPs require.

Hope this helps.

[[edit]] Say, if you are using Tk, you might as well check out the [Img] package. It does BMP also...

[male]: I already took a look at some Google'd pages, but found had some problems to readopt those algorithms in tcl. But ... one problem is, that we have mostly screen shots to be saved. And most screens have today more than 256 colors, so that a RLE compression is not applyable -right? That's what you written above, and what I missed completely! Thanks!

About using the binary Img package - we have a kind of policy, that does not allow the usage of binary packages in our application. We had in former times e.g. the libTiff library and had many problems compiling and linking it on the many supported platforms. So I wrote a most simple, non-compressing Tiff writer, first for understanding and testing in tcl, than for gaining speed in C++. The same I did for other image formats and for non-compressed AVIs - just to support even AVI creation on non-MS platforms without using 3rd party binary libraries.

Another problem is, that our application works with Open GL and has no Tk, but a Motif or a MFC GUI. But ok, I'm leaving the path while "talking".

Do you know any other BMP compression method, than RLE? I will Google a bit, too.

Thanks and best regards,

Martin

[Duoas] OpenGL Screenshots, eh? Must the output be in BMP? If not you can try something like TGA, which can do TrueColor RLE compression. BMP does not support any other kind of compression. 

Your other option would be to do some kind of color reduction. In most cases you can get a pretty good sample...