proc readxpm {imgname dataname args} { upvar 1 $dataname data set colcode "c" set makenew 1 foreach {opt val} $args { switch -exact -- $opt { -code {set colcode $val} -new {set makenew $val} default {error "Invalid option. valid options: -code and -new"} } } set state gethdr; set row 0 foreach line [split $data "\n"] { set s [string first "\"" $line] set e [string last "\"" $line] if {$s==-1 || $e==-1 || $s==$e} continue incr s; incr e -1; set line [string range $line $s $e] switch -exact -- $state { gethdr { foreach {w h cols cpp} $line {} if {$makenew} { image create photo $imgname -width $w -height $h $imgname blank } set state getcols } getcols { set colstr [string range $line 0 [expr {$cpp-1}]] set line [string range $line $cpp end] set col {} foreach {code col} $line { if {$code==$colcode} {set colval $col; break} } if {$col=={}} { error "$dataname: colortable has no $colcode-field" } if {[string tolower $col] == "none"} {set col {}} set coltable($colstr) $col incr cols -1; if {$cols==0} {set state getpix} } getpix { set s 0; set e $cpp; incr e -1 set ii -1; set clist {} for {set i 0} {$i < $w} {incr i} { set c $coltable([string range $line $s $e]) incr s $cpp; incr e $cpp if {$c=={}} { if {$ii >=0} { $imgname put [list $clist] -to $ii $row set ii -1; set clist {} } } else { if {$ii < 0} {set ii $i; set clist $c } else {lappend clist $c} } } if {$ii >=0} { $imgname put [list $clist] -to $ii $row set ii -1 } incr row } default {} } } }