Updated 2012-01-04 17:12:26 by AK

Reads TGA images into an easily manipulable format. Requires fishpool.easyOps 0.1, which can be found at http://www.fishpool.com/~setok/proj/easyOpers.tcl.

The idea would be to collect a whole series of these under the same namespace for managing different image formats.
    namespace import ::easyOps::*

    # Reads image from file 'filePath', interprets it as a TGA image and
    # returns it as a list that can be used with Tk photos:
    # A list of lists. Each list is one row of the image and contains
    # pixels in the following format #RRGGBB, with R, G and B being HEX
    # values for red, green and blue, respectively.

    proc readData {filePath} {
        set imageFile [open [lindex $filePath 0] r]
        fconfigure $imageFile -translation binary -encoding binary
        set fileData [read $imageFile]
        close $imageFile

        array set header [getHeader $fileData]
        array set imageSpec [getImgSpec $fileData]

        # Pixels
        # :NOTE: We assume colour map is 0 for now (just deal with
        # truecolour).
        # Naughty naughty.

        set pixels [string range $fileData [+ 18 $header(idLength)] \
                        [+ 18 $header(idLength) \
                             [* $imageSpec(width) \
                                  $imageSpec(height) \
                                  [/ $imageSpec(pixDepth) 8]] -1]]

        # Check order to process pixels in. We always build the list from top
        # to bottom, left to right.

        if {$imageSpec(rightLeft)} {
            # Image should be draw from right to left
            set startX $imageSpec(width)
            set endX -1
            set incrX -1
        } else {
            set startX 0
            set endX [- $imageSpec(width) 1]
            set incrX 1
        }

        if {$imageSpec(topDown)} {
            # Image should be drawn from top to bottom
            set startY 0
            set endY $imageSpec(height)
            set incrY 1
        } else {
            set startY [- $imageSpec(height) 1]
            set endY -1
            set incrY -1
        }

        set imageDat [list]
        for {set y $startY} {$y != $endY} {incr y $incrY} {
            set row [list]
            for {set x $startX} {$x != $endX} {incr x $incrX} {
                set idx [* [+ [* $y $imageSpec(width)] $x] 3]
                set rgbString [string range $pixels $idx [+ $idx 2]]
                binary scan $rgbString "ccc" b g r
                set r [& $r 0xFF]
                set g [& $g 0xFF]
                set b [& $b 0xFF]
                lappend row "#[format "%02x%02x%02x" $r $g $b]"
            }
            lappend imageDat $row
        }

        return $imageDat
    }

    ## Get image specification.
    ##
    ## 'imgData' contains the full TGA data, including headers.
    ##
    ## Returns key-value list with the following fields: xOrigin, yOrigin
    ## width, height, pixDepth, alpha, rightLeft, topDown.
    ##   xOrigin, yOrigin  Abolute co-ordinates for lower left corner.
    ##   width, height   Hm.. obvious.
    ##   pixDepth  Amount of bits per pixel.
    ##   attrBits   Number of attribute bits per pixel (f.ex. alpha).
    ##   rightLeft   If true, to be drawn from right to left.
    ##   topDown   If true, to be drawn from top to bottom.

    proc getImgSpec {imgData} {
        binary scan $imgData "@8 sssscc" imageSpec(xOrigin) \
            imageSpec(yOrigin) imageSpec(width) imageSpec(height) \
            imageSpec(pixDepth) \
            imageDesc

        set imageSpec(attrBits) [& $imageDesc 0x7]
        set imageSpec(rightLeft) [>> [& $imageDesc 0x8] 3]
        set imageSpec(topDown) [>> [& $imageDesc 0x16] 4]

        return [array get imageSpec]
    }

    ## Get image header.
    ##
    ## 'imgData' contains the full TGA data, including headers.
    ##
    ## Returns key-value list with fields: idLength, colourMap, imageData,
    ## [compression, colourModel].
    ##    idLength   Length in bytes of ID field.
    ##    colourMap  If true, image uses a colour map.
    ##    imageData  If true, header contained image data.
    ##    compression  Compression model, either RLE or none.
    ##    colourModel  Model of colour. Either "mapped", "true-colour" or
    ##                 "black-and-white"
    ## 'compression' and 'colourModel' are only set if 'imageData' is true.

    proc getHeader {imgData} {
        set hdrData [string range $imgData 0 18]
        binary scan $hdrData "ccc" header(idLength) header(colourMap) \
            imageType

        if {$imageType == 0} {
            # No image data present.

            set header(imageData) false
            return
        } else {
            set header(imageData) true
        }

        if {$imageType >= 1 && $imageType <= 3} {
            # No imagecompression
            set header(compression) none
        } else {
            set header(compression) RLE
        }

        switch -- $imageType {
            1 -
            9 {
                set header(colourModel) mapped
            }
            2 -
            10 {
                set header(colourModel) true-colour
            }
            3 -
            11 {
                set header(colourModel) black-and-white
            }
        }

        return [array get header]
    }
 }