Exactly what it says on the tin. The procedure below will take a nested list of pixels in hex notation and format the list into a valid XPM pixmap. This pixmap can be saved to disk as a regular text file and displayed using the Img extension's pixmap type. Neither Tk nor Img is required to use the formatter.
Also included is a procedure to convert a Tk photo image to pixmap data. Tk is required to use this procedure, although Img is not as long as you are using a format supported by vanilla Tk. Transparency is supported, so if your source photo has transparency, so will the resulting pixmap.
Return data from both procedures is a string containing the pixmap. This can be saved in a variable and written to disk or loaded into a Tk (Img) image with:
set pixmapname [image create pixmap -data $returndata]
and updated with:
$pixmapname configure -data $newdata
Some sample data has been supplied to demonstrate the formatting needed for the nested list used as input.
##=========================================
## photo2xpm
##
## Convert Tk photo image to XPM data.
## Transparency is supported and handled
## automatically.
##
## Uses the image handle as the XPM name.
##
##=========================================
## Arguments:
## tki - Tk photo image handle
##=========================================
proc photo2xpm {tki} {
if {![string match *$tki* [image names]] || ![string match [image type $tki] "photo"]} {
error "Valid Tk photo image handle required." ; return 1
}
set idata {}
set w [image width $tki] ; set h [image height $tki]
for { set y 0 } { $y < $h } { incr y } {
set bline {}
for { set x 0 } { $x < $w} { incr x } {
if {[$tki transparency get $x $y]} {
lappend bline "#00NONE"
} else {
lappend bline [format "#%02x%02x%02x" {*}[$tki get $x $y]]
}
}
lappend idata $bline
}
return [xpm.data $tki $idata]
}
##=========================================
## xpm.data
##
## Format a nested list of pixels into
## valid XPM data. Data can be loaded into
## a Tk image of type 'pixmap' using the
## Img extension or saved to disk.
##
## The data supplied to the argument 'pixels'
## should be formated as a list of lists, with
## each sublist representing a row of pixels
## in the image. Rows must be of the same
## length or the data may be corrupted.
##
## Colors are specified in 8-bit hex. For
## transparent pixels, the color code
## "#00NONE" should be used.
##
## A few checks are done to ensure that
## the proc has been given valid data.
## These are not exhaustive and errors still
## may occur if bad data is supplied.
##
## A substitution formula based on the total
## number of unique colors is used to
## designate character codes. This helps keep
## file size as small as possible while still
## allowing for the full 8-bit range to be
## expressed.
##
## Output has been tested and works with the
## Img 'pixmap' type and with Gimp, including
## transparency.
##
##=========================================
## Arguments:
## name - name for XPM data object
## pixels - nested list of pixels
##=========================================
proc xpm.data {name pixels} {
set data "/* XPM */"
append data \n "static char *const " $name \[\] " = " \{ \n \"
set test [lindex [lindex $pixels 0] 0]
if {[string length $test] ne 7 || ![string equal [string index $test 0] \#]} {
error "8-bit hex color codes required." ; return 1
}
set colors {}
foreach row $pixels {
foreach pixel $row {
if {![string equal $pixel "#00NONE"]}
{lappend colors $pixel}
}
}
set colors [lsort -unique $colors]
set h [llength $pixels]
set w [llength [lindex $pixels 0]]
set count [llength $colors]
set fmt "%0" ; append fmt [string length $count] "s"
append data "$w $h [expr {$count + 1}] [string length $count]" \" "," \n
set trans [string map {0 a 1 b 2 c 3 d 4 e 5 f 6 g 7 h 8 i 9 j} 0]
append data \" "$trans c None " \" "," \n
set idx 1
foreach color $colors {
set tag [string map {0 a 1 b 2 c 3 d 4 e 5 f 6 g 7 h 8 i 9 j} [format $fmt $idx]]
append data \" $tag " c " $color \" "," \n
set lookup($color) $tag
incr idx
}
foreach row $pixels {
append data \"
foreach pixel $row {
if {[string equal $pixel "#00NONE"]} {
append data $trans
} else {
append data $lookup($pixel)
}
}
append data \" "," \n
}
append data \}\;
return $data
}
#### Test data
proc testdata {} {
set data {}
lappend data [list #FFFFFF #000000 #FFFFFF #000000]
lappend data [list #000000 #FFFFFF #000000 #FFFFFF]
lappend data [list #FFFFFF #000000 #FFFFFF #000000]
lappend data [list #FFFFFF #00NONE #00NONE #000000]
lappend data [list #FFFFFF #00NONE #00NONE #000000]
lappend data [list #000000 #FFFFFF #000000 #FFFFFF]
lappend data [list #FFFFFF #000000 #FFFFFF #000000]
lappend data [list #FFFFFF #000000 #FFFFFF #000000]
return $data
}