strimj - string image routines
Richard Suchenwirth 1999-05-03 - "Everything is a string", the old Tcl mantra goes, so what about images? Image data can indeed be specified as strings (in XBM format for bitmaps, GIF/PPM for photos), but those are not exactly nice to look at. Here I explore what can be done with naive string images ("strimjes"), where one character specifies one pixel's color (except for newline, which of course starts a new pixel line), using the string processing typical for Tcl. See also: strimj segmentation - strimj animation - Mongolian in Tcl strimjes - strimj to XBM.
Binary images (bitmaps) use the pixel values "." and "@" which give best contrast on screen and paper. For graylevel images, I'm planning to use 0-9A-V for 32 graded values, giving us a pixel depth of 5 bits. For color images, seven primary colors (r red g green b blue c cyan m magenta y yellow o orange) are predefined, plus white and black from binary, and " " for transparent; but the user may add others or override the default colors by specifying a (partial) private colormap when producing a photo image. This is a simplification from XPM format. For image manipulation, it does not matter much which color characters are used, except that "." should remain white (used in shearing, expanding etc.)
The routines below work best for small images (area below 10000) with simple colormaps (e.g. icons), but then again they offer us features that photo or even more bitmap lack:
- rotation (in 90-degrees increments)
- shearing (slanting)
- concatenating multiple images
- zooming, subsampling, flipping (photo has them too)
... and other manipulations can easily be thought of. The concatenation feature allows a beautifully simple text rendering system, where every single pixel is under Tcl control (as a side effect, you get old- fashioned "banner printing" if you were looking for that). Such strimjes can then be converted to bitmap or photo images for display. See also strimj segmentation - strimj animation.
Fonts can be defined in such a clear manner (see code below) that my 11yo daughter Hanke was able to spot a bug, and rendered into images as simply as
strimj::text Hello
which returns a banner-like human-readable pattern that can be fed into the other routines (or puts [string map {. " "} ...]:
@...@.......@.@...... @...@.......@.@...... @...@..@@@..@.@..@@@. @@@@@.@...@.@.@.@...@ @...@.@@@@@.@.@.@...@ @...@.@.....@.@.@...@ @...@.@...@.@.@.@...@ @...@..@@@..@.@..@@@.
The strimj::char command implements a character finding mechanism that first looks in the specified font, then the default, then all others, and finally substitutes a "?" if no match was possible. The "font database" (just a namespaced array) can be used for organizing other images too - if their names are >1 characters long, you don't risk having them mistaken for characters.
I could keep most of the routines very short - runtime is another issue, better stay with icons and such, but it's amazing how little code can bring great effects. The script below contains a demo which also displays the time needed in seconds. Play, enjoy, improve on it!
Dan Smart With the addition of a pair of strategic [substs] I've added {} and \ to the 5x12 font.
namespace eval strimj {
variable Font
variable defaultColors {
r red g green b blue c cyan m magenta y yellow o orange . white
}
proc bitmap {si args} {eval [list image create bitmap -data [xbm $si]] $args}
proc char {char {font -}} {
#--- retrieve an image from the font database
variable Font
if [info exist Font($font,$char)] {
set res $Font($font,$char)
} else {
set font $Font(default)
if [info exist Font($font,$char)] {
set res $Font($font,$char)
} else {
set choices [array names Font *,$char]
if [llength $choices] {
set res $Font([lindex $choices 0])
} else {set res $Font(unknown)}
}
}
set res
}
proc concat {si1 si2 {pad ""}} {
#--- horizontally join two strimjes
set si [expand $si1 0 [util::max [height $si1] [height $si2]]]
set res {}
foreach line1 [lines $si] line2 [lines $si2] {
lappend res "$line1$pad$line2"
}
join $res \n
}
proc expand {si {w 0} {h 0}} {
#--- turn a strimj to specified dim. and equal-length lines
if {!$w} {set w [width $si]}
if {!$h} {set h [height $si]}
set res {}; set n 0; set filler " "
foreach line [lines $si] {
lappend res [util::pad line $w $filler]
incr n
}
set filline [string repeat $filler $w]
while {$n<$h} {lappend res $filline; incr n}
join $res \n
}
proc flip {si axis} {
switch -- $axis {
x {join [util::lrevert [lines $si]] \n}
y {join [util::map util::revert [lines [expand $si]]] \n}
default {error "bad axis $axis: must be x or y"}
}
}
proc font {font data} {
#--- add one or more images to the font database
variable Font
regsub -all {\\} $data {\\\\} data
foreach {labels si} $data {
foreach label $labels {
set label [subst -nocommands -novariables $label]
set Font($font,$label) ""
}
foreach line [lines $si] {
foreach label $labels pixels $line {
set label [subst -nocommands -novariables $label]
append Font($font,$label) [string map {. " "} $pixels]\n
}
}
}
}
proc height si {llength [lines $si]}
proc lines si {split [string trim $si \n] \n}
proc new {width height {color " "}} {zoom $color $width $height}
proc photo {si {usermap ""}} {
variable defaultColors
array set map [concat $defaultColors $usermap]
set img [image create photo -height [height $si] -width [width $si]]
set y 0
foreach line [lines $si] {
set x 0
foreach char [split $line ""] {
if {$char!=" "} {
if {![info exist map($char)]} {set map($char) black}
$img put $map($char) -to $x $y
}
incr x
}
incr y
}
set img
}
proc rotate {si angle} {
switch -- $angle {
90 {rot90 $si}
180 {flip [flip $si x] y}
270 {rot90 [rotate $si 180]}
default {error "bad angle $angle: must be 90|180|270"}
}
}
proc rot90 si {
set cols [util::range [width $si]]
foreach line [lines [expand $si]] {
foreach col $cols char [split $line ""] {
append $col $char
}
}
join [util::lrevert [util::lget $cols]] \n
}
proc shear {si {gradient 3}} {
set lines [lines $si]
set h [llength $lines]
set bias [expr {$h-($h/$gradient)*$gradient}]
set res {}
set n 0
foreach line $lines {
set dx [expr {($gradient>0?($h-$n-1):$bias-$n)/$gradient}]
append res [string repeat . $dx]$line\n
incr n
}
set res
}
proc subsample {si {xfac 2} {yfac 0}} {
if {!$yfac} {set yfac $xfac}
set ilist [string repeat "i " $yfac]
set res {}
foreach $ilist [lines $si] {
lappend res [subsampleLine $i $xfac]
}
join $res \n
}
proc subsampleLine {string xfac} {
set ilist [string repeat "i " $xfac]
set res ""
foreach $ilist [split $string ""] {append res $i}
set res
}
proc text {string args} {
#--- render a string into a strimj
array set opt [::concat {-font - -pad " "} $args]
set si [char [string index $string 0] $opt(-font)]
foreach c [split [string range $string 1 end] ""] {
set si [concat $si [char $c $opt(-font)] $opt(-pad)]
}
set si
}
proc width si {util::max [util::map "string length" [lines $si]]}
proc xbm si {
set si [string map {" " 0 . 0} [expand $si]]
set lines [lines $si]
set width [string length [lindex $lines 0]]
set height [llength $lines]
set bytes {}
foreach line $lines {
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 zoom {si {xfac 2} {yfac 0}} {
#--- negative zoom factors imply flipping
if {$xfac<0} {
set si [flip $si x]
set xfac [expr {-$xfac}]
}
if {$yfac<0} {
set si [flip $si y]
set yfac [expr {-$yfac}]
}
if {$xfac==1 && $yfac==1} {return $si}
if {!$yfac} {set yfac $xfac}
#--- zoom factors<1 imply subsampling
if {$xfac<1 && $yfac<1} {
set xfac [expr {round(1./$xfac)}]
set yfac [expr {round(1./$yfac)}]
return [subsample $si $xfac $yfac]
}
set res {}
foreach line [lines $si] {
foreach - [util::range $yfac] {
lappend res [util::strmul $line $xfac]
}
}
join $res \n
}
set Font(default) 5x10
font 5x10 {
{{ }} ...
{A B C D E F G H I J K} "
..@.. @@@@ .@@@. @@@ @@@@@ @@@@@ .@@@. @...@ @@@ ....@ @...@
.@.@. @...@ @...@ @..@ @ @ @...@ @...@ .@ ....@ @..@
@...@ @...@ @ @...@ @ @ @ @...@ .@ ....@ @.@
@...@ @@@@. @ @...@ @@@@ @@@@ @..@@ @@@@@ .@ ....@ @@
@@@@@ @...@ @ @...@ @ @ @...@ @...@ .@ ....@ @.@
@...@ @...@ @ @...@ @ @ @...@ @...@ .@ ....@ @..@
@...@ @...@ @...@ @..@ @ @ @...@ @...@ .@ @...@ @...@
@...@ @@@@ .@@@ @@@ @@@@@ @ .@@@ @...@ @@@ .@@@ @....@"
{L M N O P Q R S T U} "
@ @...@ @....@ .@@@. @@@@ .@@@. @@@@ .@@@. @@@@@ @...@
@ @@.@@ @@...@ @...@ @...@ @...@ @...@ @...@ ..@ @...@
@ @.@.@ @@...@ @...@ @...@ @...@ @...@ @ ..@ @...@
@ @.@.@ @.@..@ @...@ @...@ @...@ @...@ .@@. ..@ @...@
@ @...@ @..@.@ @...@ @@@@ @...@ @@@@ ...@ ..@ @...@
@ @...@ @..@@@ @...@ @ @.@.@ @.@ ....@ ..@ @...@
@ @...@ @...@@ @...@ @ @..@ @..@ @...@ ..@ @...@
@@@@@ @...@ @....@ .@@@ @ .@@.@ @...@ .@@@. ..@ .@@@."
{V W X Y Z} "
@...@ @...@ @...@ @...@ @@@@@@
@...@ @...@ @...@ @...@ .....@
@...@ @...@ @...@ .@.@. ....@
@...@ @.@.@ .@.@. .@.@ ...@
.@.@. @.@.@ ..@.. ..@ ..@.
.@.@. @@.@@ .@.@. ..@ .@..
.@.@. @@.@@ @...@ ..@ @...
..@.. @...@ @...@ ..@ @@@@@@"
{0 1 2 3 4 5 6 7 8 9} "
.@@@. ..@.. .@@@. .@@@. .@.@. @@@@@ .@@@. @@@@@ .@@@. .@@@.
@...@ .@@.. @...@ @...@ .@.@. @ @...@ ....@ @...@ @...@
@@..@ @.@.. ....@ ....@ @..@. @ @ ...@ @...@ @...@
@.@.@ ..@.. ...@ ..@@ @..@. @.@@ @@@@ ...@ .@@@. @...@
@..@@ ..@.. ..@ ....@ @@@@@ @@..@ @...@ ..@ @...@ .@@@@
@...@ ..@.. .@ ....@ ...@ ....@ @...@ ..@ @...@ ....@
@...@ ..@.. @. @...@ ...@ @...@ @...@ ..@ @...@ @...@
.@@@. .@@@. @@@@@ .@@@ ...@ .@@@ .@@@. ..@ .@@@. .@@@."
{a b c d e f h i k l m n} "
..... @.... ..... ....@ ..... .@@ @ @ @ @ . .
..... @.... ..... ....@ ..... .@ @ . @ @ . .
.@@@. @.@@ .@@@. .@@.@ .@@@. .@. @.@@ @ @..@ @ @@@.@@. @.@@
....@ @@..@ @...@ @..@@ @...@ @@@ @@..@ @ @.@ @ @..@..@ @@..@
.@@@@ @...@ @ @...@ @@@@@ .@ @...@ @ @@ @ @..@..@ @...@
@...@ @...@ @.... @...@ @.... .@ @...@ @ @.@ @ @..@..@ @...@
@..@@ @...@ @...@ @..@@ @...@ .@ @...@ @ @..@ @ @..@..@ @...@
.@@.@ @@@@. .@@@. .@@.@ .@@@. .@ @...@ @ @...@ @ @..@..@ @...@"
{o r s t u v w x z} "
..... . . .@. . . . . .
..... . . .@. . . . . .
.@@@. @.@@ .@@@. @@@ @...@ @...@ @...@...@ @...@ @@@@@
@...@ @@ @...@ .@. @...@ @...@ @...@...@ .@.@. ...@.
@...@ @ .@@ .@. @...@ .@.@. .@.@.@.@ ..@.. ..@..
@...@ @ ...@. .@. @...@ .@.@. .@.@.@.@ .@.@. .@...
@...@ @ @...@ .@ @..@@ ..@ ..@...@ @...@ @
.@@@. @ .@@@. .@. .@@.@ ..@.. ..@...@ @...@ @@@@@"
{g j p q y} "
. .@ . . .
. .. . . .
.@@.@ .@ @.@@. .@@.@ @...@
@..@@ .@ @@..@ @..@@ @...@
@...@ .@ @...@ @...@ @...@
@...@ .@ @...@ @...@ .@.@.
@..@@ .@ @...@ @...@ .@.@.
.@@.@ .@ @@@@. .@@@@ ..@..
....@ .@ @ ....@ .@...
.@@@ @ @ ....@ @"
"! \" # \$ % ' ( ) + , - . /" "
@ @.@ .@.@. ..@.. .@...@ @ ..@ @ ..... .. ..... . ...@
@ @.@ .@.@. .@@@ @.@..@ @ .@ .@ ..... .. ..... . ...@
@ . @@@@@ @.@.@ .@..@ . @ ..@ ..@.. .. ..... . ..@
@ . .@.@ @.@ ...@ . @ ..@ ..@.. .. ..... . ..@
@ . .@.@. .@@@. ..@.. . @ ..@ @@@@@ .. @@@@@ . .@
@ . @@@@@ ..@.@ .@..@. . @ ..@ ..@.. .. ..... . .@
. . @.@ @.@.@ @..@.@ . .@ .@ ..@.. @@ ..... . @
@ . @.@ @@@ @...@ . ..@ @ ..... @. ..... @ @"
{? \{ \} \\} "
.@@@. ..@@ @@ @
@...@ .@ ..@ @
....@ .@ ..@ .@
...@. @ ...@ .@
..@.. .@ ..@ ..@
..@.. .@ ..@ ..@
..... .@ ..@ ...@
..@.. ..@@ @@ ...@"
}
font cute {
{a b c} {
.. ._ .
.. |.| .
..__._ |.|._ ..___
./._`.| |.´_.\ ./.__\
|.(_|.| |.|_).| |.(__
.\__,_| |_,__/ .\___/
}
}
font demo {
fx "
...@
..@@@
.@@@@@
@@@@@@@
...@
...@
...@
@@@@@@@
.@@@@@
..@@@
...@"
fy "
...@...@
..@@...@@
.@@@...@@@
@@@@@@@@@@@
.@@@...@@@
..@@...@@
...@...@"
rot "
...@
..@@
.@@@
@@@@@@@
.@@@...@
..@@...@
...@...@
.......@"
}
set Font(unknown) $Font(5x10,?)
} ;# end namespace strimj
# utilities of general use, may some day go into their own package
namespace eval util {
proc lget varlist {
#-- turn a list of var.names in caller's scope to their values
set res {}
foreach var $varlist {lappend res [uplevel 1 set $var]}
set res
}
proc lrevert list {
#--- e.g. lrevert {a b c} => c b a
set res {}
for {set i [expr {[llength $list]-1}]} {$i>=0} {incr i -1} {
lappend res [lindex $list $i]
}
set res
}
proc map {func list} {
#--- apply a function to each element of a list
set res {}
foreach i $list {lappend res [eval $func [list $i]]}
set res
}
proc max args {
if {[llength $args]==1} {set args [lindex $args 0]}
lindex [lsort -real -decreasing $args] 0
}
proc pad {_string length filler} {
upvar $_string string
set n [expr {$length-[string length $string]}]
append string [string repeat $filler $n]
}
proc range n {
#--- produce a list from 0 to n-1 (for unrolling for's)
set res {}
for {set i 0} {$i<$n} {incr i} {lappend res $i}
set res
}
proc revert string {join [lrevert [split $string ""]] ""}
proc strmul {string factor} {
#--- multiply a string, e.g. strmul ABC 3 => AAABBBCCC
set res ""
foreach char [split $string ""] {
for {set i 0} {$i<$factor} {incr i} {
append res $char
}
}
set res
}
}
#--- test and demo code...
if {[file tail [info script]]==[file tail $argv0]} {
proc strimj::demo {} {
variable Font
regsub -all {[^ ]+,} [array names Font *,?] "" abc
#set ::demoimg [text [join [lsort $abc] ""]]
set ::demoimg [text "Abc 123" -background white]
trace add variable ::demoimg write {.l config -image [strimj::bitmap $::demoimg] ;#}
label .info -textvar ::info
frame .f
label .f.l -image [photo [zoom ry\ngb 12]]
button .f.fx -image [bitmap [char fx]] -command {
tell [time {set demoimg [strimj::flip $::demoimg x]}]
}
button .f.fy -image [bitmap [char fy]] -command {
tell [time {set demoimg [strimj::flip $::demoimg y]}]
}
button .f.rot -image [bitmap [char rot]] -command {
tell [time {set demoimg [strimj::rot90 $::demoimg]}]
}
button .f.zoom -text "+" -command {
tell [time {set demoimg [strimj::zoom $::demoimg]}]
}
button .f.unzoom -text " - " -command {
tell [time {set demoimg [strimj::subsample $::demoimg]}]
}
button .f.slant -text "/" -command {
tell [time {set demoimg [strimj::shear $::demoimg 3]}]
}
button .f.slant- -text "\\" -command {
tell [time {set demoimg [strimj::shear $::demoimg -3]}]
}
bind .f.unzoom <3> {tell [time {set demoimg $demoimg}]}
eval pack [winfo children .f] -side left -fill both -ipadx 2
label .l -image [bitmap $::demoimg] -bg white
pack .info .f .l
}
proc tell time {
set img $::demoimg
set w [strimj::width $img]
set h [strimj::height $img]
set ::info "$w*$h=[expr {$w*$h}]: [expr {[lindex $time 0]/1000000.}]"
}
strimj::demo
}