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]
}
}