strToPic

MG Sep 3rd 2005 - This is a small script which encodes strings as PNG images. (It uses PNG because GIF and JPEG both garbled the string when it was decoded, I guess b/c of lack of colors or something.) It's very barely tested, on Tcl/Tk 8.4.9 with Img 1.3. It's very simple to use:

  strToPic $text

will encode the text, and save it as a PNG image (you'll be prompted to give a file name). Then you can use

  picToStr ?$file?

to decode a file (if no file is given, you'll be prompted to give one). This decodes the contents of the file, and prints the string it represents to stdout.

It works by simply converting each character to a numerical value, with

  scan $char %c

and using that as a color value (where three characters make up a pixel; the first is the red value, the second the green, the third the blue). If there aren't enough characters, it will pad the end of the string with randomly generated ones until there are (and will strip them off again automatically when you decode). This means that if you use any character outside the range of 0-255, the script will break. Not exactly graceful. If someone has a good way to change/fix that, feel free to do so :) - RS: By converting the text to explicit utf-8, you are guaranteed to have all bytes in 0..255.

The images created are always square - again, if it lacks the number of characters for that, it will pad the string until there are enough.

Here's an example of the output - this image is the first two paragraphs of Harry Potter and the Half-Blood Prince, as that happened to the be first "real" text file I could find for testing.

And here's the code to produce it (and decode it back):

package require Img
 
proc randChar {} {

  return [format %c [expr {int(rand()*77)+45}]];

};# randChar

proc charToColComp {char} {

  return [expr {255*[scan $char %c]}];

};# charToColComp

proc strToPic {string} {

  set len [string length $string]
  set string "${len}:$string"
  while { [expr {[string length $string] % 3}] != "0" } {
          append string [randChar]
        }
  while { [expr {floor(sqrt(([string length $string]/3)))}] != [expr {ceil(sqrt(([string length $string]/3)))}] } {
          append string [randChar][randChar][randChar]
        }
  set len [string length $string]
  set pixels [expr {$len/3}]
  set size   [expr {int(sqrt($pixels))}]
  set image [image create photo -width $size -height $size]
  set x 0
  set y 0
  foreach {r g b} [split $string ""] {
           set col [format "#%04x%04x%04x" [charToColComp $r] [charToColComp $g] [charToColComp $b]]
           $image put $col -to $x $y
           incr x
           if { $x == $size } {
                set x 0
                incr y
              }
          }
  set path [tk_getSaveFile -filetypes {{{PNG Files} {*.png}} {{All Files} {*.*}}} -defaultextension .png]
  if { $path != "" } {
       $image write $path -format png
       tk_messageBox -message "Image created."
     }

  image delete $image

};# strToPic

proc picToStr {{pic ""}} {

  if { $pic == "" } {
       set pic [tk_getOpenFile  -filetypes {{{PNG Files} {*.png}} {{All Files} {*.*}}}]
       if { $pic == "" } {return}
     }

  set string ""

  set image [image create photo -file $pic]
  for {set y 0} "\$y < [image height $image]" {incr y} {
       for {set x 0} "\$x < [image width $image]" {incr x} {
            scan [$image get $x $y] "%d %d %d" r g b
            set r [format %c [incr r]]
            set g [format %c [incr g]]
            set b [format %c [incr b]]
            append string "$r$g$b"
           }
      }

  image delete $image

  set colon  [string first : $string]
  set size   [string range $string 0 [incr colon -1]]
  set string [string range $string   [incr colon 2] end]
  set string [string range $string 0 [incr size -1]]
  puts "\n\nDone! Image file [file tail $pic] says:"
  puts $string

};# picToStr
            
catch {console show}  ;# for us poor Windows users
picToStr

strToPic

See also