##+##########################################################################
 #
 # bmpDump.tsh -- Dumps out metadata about .BMP files
 # by Keith Vetter, September 2005
 #
 #############################################################################

 set S(rows) 1                                   ;# Count of image rows to show

 proc DoBMP {iname} {
    set ::S(ch) [open $iname r]
    fconfigure $::S(ch) -translation binary
    FileHeader $iname                           ;# Read file header
    ImageHeader                                 ;# Read image header
    DumpImageHeader $iname                      ;# Dump image header info
    ReadPixels                                  ;# Dump pixel info
    Show ""
 }
 proc ReadInt {{size 32}} {                      ;# Reads raw integer from file
    array set BSCAN {32 i 16 s 8 c}
    set data [read $::S(ch) [expr {$size / 8}]]
    binary scan $data $BSCAN($size) val
    return $val
 }
 proc ReadRGBX {} {
    set data [read $::S(ch) 4]
    binary scan $data cccc b g r x
    return [format "%02X%02X%02X" [expr {$r & 0xFF}] [expr {$g & 0xFF}] [expr {$b & 0xFF}]]
 }
 proc FileHeader {fname} {
    set data [read $::S(ch) 2]
    if {$data ne "BM"} { ERROR "Bad file header: signature" }
    set len [ReadInt]
    set len2 [file size $fname]
    if {$len != $len2} { ERROR "Bad file header: file length"}
    set len [ReadInt]
    if {$len != 0} { ERROR "Bad file header: reserved fields"}
    set ::S(offBits) [ReadInt]
 }
 proc ImageHeader {} {
    global I
    array unset I

    set size [ReadInt]
    if {$size == 12} { ERROR "Cannot handle OS/2 bmp files" }

    set I(Width) [ReadInt]
    set I(Height) [ReadInt]
    set I(Planes) [ReadInt 16]
    set I(BitCount) [ReadInt 16]
    set I(Compression) [ReadInt]
    set I(SizeImage) [ReadInt]
    set I(xPelsPerMeter) [ReadInt]
    set I(yPelsPerMeter) [ReadInt]
    set I(ClrUsed) [ReadInt]
    set I(ClrImportant) [ReadInt]

    if {$I(Compression)} { ERROR "Cannot handle compressed images"}
    if {$I(BitCount) <= 8} ReadPalette
 }
 proc ReadPalette {} {
    set cnt [expr {int(pow(2,$::I(BitCount)))}]
    for {set i 0} {$i < $cnt} {incr i} {
        set ii [format "%d" $i]
        set ::I(palette,$ii) [ReadRGBX]
    }
 }
 proc DumpImageHeader {iname} {
    array set ZIP {0 none 1 rle8 2 rle4 3 bitfields}

    Show [file tail $iname]
    Show [string repeat "=" [string length [file tail $iname]]]
    Show [format "  %-17s: %d" "Width" $::I(Width)]
    Show [format "  %-17s: %d" "Height" $::I(Height)]
    Show [format "  %-17s: %d" "Planes" $::I(Planes)]
    Show [format "  %-17s: %d" "Bits/pixel" $::I(BitCount)]
    Show [format "  %-17s: %s" "Compression" $ZIP($::I(Compression))]
    Show [format "  %-17s: %d" "Image Size" $::I(SizeImage)]
    Show [format "  %-17s: %dx%d" "Pixels/meter" $::I(xPelsPerMeter) $::I(yPelsPerMeter)]
    Show [format "  %-17s: %d" "Colors Used" $::I(ClrUsed)]
    Show [format "  %-17s: %d %s" "Essential Colors" $::I(ClrImportant) \
              [expr {$::I(ClrImportant) > 0 ? "" : "(all)"}]]
    Show [format "  %-17s: %s" "Palette" [DumpPalette]]
    Show [format "  %-17s: %s" "Image" ""]
 }
 proc DumpPalette {} {
    if {$::I(BitCount) > 8} { return "none"}

    if {$::I(BitCount) == 1} {
        return [format "0: %s  1: %s" $::I(palette,0) $::I(palette,1)]
    }

    set result "\n"
    set cnt [expr {int(pow(2,$::I(BitCount)))}]
    set cols 6
    for {set i 0} {$i < $cnt} {incr i} {
        append result [format "  %3d: %s" $i $::I(palette,$i)]
        if {($i % $cols) == $cols-1} { append result "\n"}
    }
    return $result
 }

 proc ReadPixels {} {
    seek $::S(ch) $::S(offBits)
    set func "ReadPixels$::I(BitCount)"
    if {[info commands $func] eq {}} {
        ERROR "Cannot read pixels for bitCount $::I(BitCount)" 0
        return
    }
    $func
 }
 proc ReadPixels1 {} {
    set bytes [expr {($::I(Width)+7)/8}]
    set bpr [expr {(((($::I(Width)+7)/8)+3)/4)*4}]
    for {set row 0} {$row < $::I(Height)} {incr row} {
        if {$row >= $::S(rows)} break
        set data [read $::S(ch) $bpr]
        binary scan $data c$bytes pixels
        set tmp {}
        foreach pixel $pixels {
            for {set shift 7} {$shift >= 0} {incr shift -1} {
                lappend tmp [expr {($pixel >> $shift) & 0x01}]
            }
        }
        set pixels [lrange $tmp 0 [expr {$::I(Width)-1}]]
        ShowRow $row $pixels
    }
 }
 proc ReadPixels4 {} {
    set bytes [expr {($::I(Width)+1)/2}]
    set bpr [expr {(((($::I(Width)+1)/2)+3)/4)*4}]
    for {set row 0} {$row < $::I(Height)} {incr row} {
        if {$row >= $::S(rows)} break
        set data [read $::S(ch) $bpr]
        binary scan $data c$bytes pixels
        set tmp {}
        foreach pixel $pixels {
            lappend tmp [expr {($pixel >> 4) & 0x0F}]
            lappend tmp [expr {$pixel & 0x0F}]
        }
        set pixels [lrange $tmp 0 [expr {$::I(Width)-1}]]
        ShowRow $row $pixels
    }
 }

 proc ReadPixels8 {} {
    set bpr [expr {(($::I(Width)+3)/4)*4}]
    for {set row 0} {$row < $::I(Height)} {incr row} {
        if {$row >= $::S(rows)} break
        set data [read $::S(ch) $bpr]
        binary scan $data c$::I(Width) pixels
        ShowRow $row $pixels
    }
 }
 proc ShowRow {row pixels} {
    ShowNNL [format "   Row %2d: " [expr {$::I(Height)-$row-1}]]
    set w [expr {$::I(BitCount) == 8 ? 3 : 2}]
    foreach pixel $pixels {
        ShowNNL [format " %${w}d" [expr {$pixel & 0xFF}]]
    }
    Show ""
 }
 proc ReadPixels24 {} {
    set bpr [expr {4 * (($::I(Width) * 3 + 3) / 4)}]
    for {set row 0} {$row < $::I(Height)} {incr row} {
        if {$row >= $::S(rows)} break
        set data [read $::S(ch) $bpr]
        DisplayRow $row $data
    }
 }
 proc DisplayRow {row data} {
    ShowNNL "  Row [expr {$::I(Height)-$row-1}]:"

    binary scan $data c* bgr
    set bgr [lrange $bgr 0 [expr {([llength $bgr] / 3)*3-1}]] ; list
    set last {}
    set cnt 0
    foreach {b g r} $bgr {
        set pixel [list $r $g $b]
        if {$pixel eq $last} {
            if {$cnt == 0} {ShowNNL "*"}
            incr cnt
        } else {
            set rgb [format "%02X%02X%02X" [expr {$r & 0xFF}] [expr {$g & 0xFF}] [expr {$b & 0xFF}]]
            ShowNNL " $rgb"
            set last $pixel
            set cnt 0
        }
    }
    Show ""
 }
 proc Show {line} { ShowNNL "$line\n" }
 proc ShowNNL {line} {
    if {[info exists ::tk_version] && [winfo exists .t]} {
        .t insert end $line
        .t see end
    } else {
        puts -nonewline $line
    }
 }
 proc ERROR {emsg {die 1}} {
    if {[info exists ::tk_version]} {
        tk_messageBox -icon error -message $emsg
    } else {
        puts stderr $emsg
    }
    if {$die} exit
 }
 ################################################################
 ################################################################

 if {[info exists ::tk_version]} {
    wm title . "BMP Dump"
    bind all <Key-F2> [list console show]
    pack [text .t -wrap word] -fill both -expand 1
 }

 if {$argv eq {}} {
    catch {wm withdraw .}
    ERROR "usage: bmpdmp <bmp files>"
 }
 foreach arg $argv {
    regsub -all {\\} $arg {/} arg
    set files [glob -nocomplain $arg]
    if {$files eq {}} { set files $arg }
    foreach iname $files {
        DoBMP $iname
    }
 }