package req Tk
proc strimj2xbm strimj {
set width [string length [lindex $strimj 0]]
set height [llength $strimj]
set bytes {}
foreach line [string map {. 0} $strimj] {
regsub -all {[^0]} $line 1 line ;# black pixel
foreach bin [split [binary format b* $line] ""] {
lappend bytes [scan $bin %c]
}
}
set res "#define i_width $width\n#define i_height $height\n"
append res "static char i_bits\[\] = {\n[join $bytes ,]\n}"
}
proc strimj2image {strimj {fg black}} {
image create bitmap -data [strimj2xbm $strimj] -foreground $fg
}#-- Just for the fun of it, here's also the inverse operation: proc xbm2strimj xbm {
regexp {width +(\d+).+\{(.+)\}} $xbm -> width data
set res ""
set line ""
foreach byte [string map {, " "} $data] {
if {[string length $line] > $width-7} {
append res [string range $line 0 [expr {$width-1}]]\n
set line ""
}
binary scan [format %c $byte] b* bits
append line $bits
}
if {$line ne ""} {
append res [string range $line 0 [expr {$width-1}]]\n
}
string map {0 . 1 @} $res
}#-- .. and a tiny alternative to make photo images (with another use case for K): proc strimj2photo {strimj {fg #000000} {bg #FFFFFF}} {
set data {}
foreach line $strimj {
lappend data [lrange [string map [list @ "$fg " . "$bg "] $line] 0 end]
}
K [set im [image create photo]] [$im put $data -to 0 0]
}
proc K {a b} {set a}#--------------------------- Usage demo, and test: set test {
@@......
@@@@....
@@@@@@..
@@@@@@@@
@@@@@@..
@@@@....
@@......
}
set pause {
@@@..@@@
@@@..@@@
@@@..@@@
@@@..@@@
@@@..@@@
@@@..@@@
@@@..@@@
}
pack [button .1 -image [strimj2image $test red]] \
[button .2 -image [strimj2photo $pause]] -padx 5 -pady 5 -side leftSee Arts and crafts of Tcl-Tk programming
