Version 5 of XPM to photo image

Updated 2004-08-06 05:23:09

if 0 { Richard Suchenwirth - XPM (X Pixmap) is a text file format in X11 to specify color images like icons with one or more characters per pixel, which are resolved in a color map at beginning of file. Here's some old code of mine which scans an XPM file into a photo image - might need some tuning before it joins the strimj - string image routines family, but as it was requested on c.l.t., here you go... }

 proc image:fromXpm {fn} {
    set f [open $fn r]
    set stage 0; # 0:dimensions 1:colors 2:data
    set ncol 0; set y 0
    set bg white ;# or whatever
    while {![eof $f]} {
        gets $f line
        if {[regexp {\"([^\"]+)\"} $line -> cont]} {
            switch $stage {
                0 {
                    lspread $cont to w h ncols nbytes
                    set im [image create photo]
                    $im put #FFF -to 0 0 $w $h
                    incr stage; continue
                } 1 {
                    set c [string range $cont 0 [expr $nbytes-1]]
                    regexp "\[ \t\]c (.+)" $cont -> col
                    if {[regexp {[Nn]one} $col]} {set col $bg}
                    if [catch {winfo rgb . $col}] {
                        set col [lindex $col 0]
                    }
                    set color($c) $col
                    incr ncol
                    if {$ncol>=$ncols} {incr stage}
                    continue
                } 2 {
                    set t {}
                    foreach i [string:split $cont $nbytes] {
                        lappend t $color($i)
                    }
                    catch {
                        $im put [list $t] -to 0 $y [expr $w] [expr $y+1]
                    }
                    incr y
                }
            }
        }
    }
    close $f
    return $im
 } 
 # The following should rather be called "string:stride"... it breaks a string into substrings of length n
 proc string:split {s n} {
    if {$n==1} {
        return [split $s ""]
    } elseif {$n==2} {
        set t {}
        foreach {i j} [split $s ""] {lappend t $i$j}
        return $t
    } else {error "string:split -- bad splitter $n (must be 1 or 2)"}
 }
 # needed above ...
 proc lspread {list "to" args} {
    foreach a $args v $list {
        upvar [lindex $a 0] var ;# name maybe in list with default
        if {$v==""} {set var [lindex $a 1]} else {set var $v}
    }
 }

return ;# if 0 :)

See Also: Tk_Xpm, XPM.


Arts and crafts of Tcl-Tk programming - Category Graphics