if 0 {[Richard Suchenwirth] 2003-07-03 - This little thing, runnable on [PocketPC] and elsewhere, lets you load a small [photo] [image] from file. You see it both in original size and zoomed on a [canvas]. 
The "palette" at top right lets you choose a color, which is applied to pixel blocks that you tap upon on the canvas, and immediately in the small image too. You get undo functionality by pixels, or if you save the file often, and click File/Revert to reload the last saved state.

[http://mini.net/files/imedit.jpg]
}
----
 set about "imEdit
   R.Suchenwirth 2003
   Powered by Tcl/Tk!

   A little pixel editor for photo images. 
   Reads and writes small GIF files.
   Transparency is not seen, but preserved :(
   "
 package require Tk
 proc main {} {
    global g
    set g(filename) ""
    . config -menu [menu .m]
    m+ File Open.. {openFile .c}
    m+ File Revert {openFile .c $g(filename)}
    m+ File ---
    m+ File Save {saveFile $g(filename)}
    m+ File "Save as.." saveFile
    m+ File ---
    m+ File Restart {exec wish $argv0 &; exit}
    m+ File Exit    exit
    m+ Edit Undo {undo .c}
    m+ Edit New.. {new .c}
    m+ Help About {tk_messageBox -message $about}
    frame .f
    set g(image) [image create photo]
    set g(label) [label .f.i -image $g(image) -width 20 -height 20 -relief sunken]
    palette .f.p g(color)
    eval pack [winfo childr .f] -side left
    pack .f [canvas .c] -fill x
 }
if 0 {This wrapper factors out the verbosity of menu specifications:}
 proc m+ {title label {cmd ""}} {
    set m .m.m$title
    if ![winfo exists $m] {
       .m add cascade -label $title \
          -menu [menu $m -tearoff 0]
    }
    if [regexp ^-+$ $label] {
       $m add separator
    } else {
       $m add command -label $label -command $cmd
    }
 }
# File I/O, with selectors if needed:
 proc openFile {w {fn ""}} {
    global g
    if {$fn==""} {
       set fn [tk_getOpenFile -filetypes {{GIF .gif} {All *}}]
    }
    if {$fn==""} return
    $g(image) read $fn -shrink
    set g(filename) $fn
    imageEdit $w $g(image)
 }
 proc saveFile {{fn ""}} {
    if {$fn==""} {
       set fn [tk_getSaveFile -filetypes {{GIF .gif} {All *}}]
    }
    if {$fn==""} return
    $::g(image) write $fn -format GIF
 }
 proc new w {
    global g
    set g(new) 0
    set g(white) 0
    wm title [toplevel .t] "Size"
    label .t.w -text Width:
    entry .t.x -textvar g(w) -width 3
    grid .t.w .t.x -sticky ew
    label .t.h -text Height:
    entry .t.y -textvar g(h) -width 3
    grid .t.h .t.y -sticky ew
    checkbutton .t.white -text white -variable g(white)
    grid .t.white
    button .t.ok -text OK -command {incr g(new); destroy .t}\
       -default active
    bind .t <Return> {.t.ok invoke}
    button .t.c -text Cancel -command {destroy .t}
    grid .t.ok .t.c -sticky ew
    focus .t.x
    grab  .t
    tkwait window .t
    if $g(new) {
      image create photo t -width $g(w) -height $g(h)
      if $g(white) {
         t put #fff -to 0 0 $g(w)  $g(h)
      }
      $g(image) copy t -shrink
      image delete t
      set g(filename) ""
      imageEdit $w $g(image)
    }
 }
#----------------- The color chooser:
 proc palette {w varName} {
     canvas $w -height 20
     $w create rect 5 5 15 15 -tag select
     set x0 20; set x1 30
     set y0 2; set y1 10
     foreach color {
        black brown purple red pink
        orange yellow lightgreen green
        lightblue blue grey white
     } {
        $w create rect $x0 $y0 $x1 $y1 \
           -fill $color -tag choice
        incr x0 12; incr x1 12
        if {$x0>200} {
           incr y0 10; incr y1 10
           set x0 20; set x1 28
        }
     }
     $w bind select <1> "selectColor %W $varName new"
     $w bind choice <1> "selectColor %W $varName"
     set ::$varName {}
     set w
 }
 proc selectColor {w varName {c ""}} {
    if {$c==""} {
       set id [$w find withtag current]
       set col [$w itemcget $id -fill]
    } else {
       # tk_chooseColor not supported..
       package require BWidget
       set col [SelectColor .x]
    }
    $w itemconfig select -fill $col
    set ::$varName $col
 }
if 0 {The heart of the matter: this determines a suitable scale factor, and renders the big pixels. As this is quite slow, I added an [update] after every row:}
 proc imageEdit {w img} {
    set imw [image width $img]
    set imh [image height $img]
    wm title . "[file tail $::g(filename)] $imw*$imh"
    $::g(label) config -width $imw -height $imh
    set cw [winfo width $w]
    set ch [winfo height $w]
    set xfac [expr $cw/$imw]
    set yfac [expr $ch/$imh]
    set fac [max [min $xfac $yfac] 2]
    $w delete all
    set y0 0; set y1 [expr {$fac-1}]
    for {set i 0} {$i<$imh} {incr i} {
       set x0 0; set x1 [expr {$fac-1}]
       for {set j 0} {$j<$imw} {incr j} {
         set color [rgb [$img get $j $i]]
         $w create rect $x0 $y0 $x1 $y1 -fill $color -outline $color -tag "px $j,$i"
         incr x0 $fac; incr x1 $fac
      }
      incr y0 $fac; incr y1 $fac
      update idletasks ;# show rows
    }
    $w bind px <1> {repaint %W}
    set ::g(undo) {}
 }
 proc repaint w {
    global g
    set id [$w find withtag current]
    set col [$w itemcget $id -fill]
    foreach tag [$w gettags $id] {
       if [regexp (.+),(.+) $tag -> x y] break
    }
    lappend g(undo) [list $x $y $col]
    $w itemconfig $id -fill $g(color) -outline $g(color)
    $g(image) put $g(color) -to $x $y
 }
 proc undo {w} {
    global g
    if ![llength $g(undo)] return
    foreach {x y col} [pop g(undo)] break
    $w itemconfig $x,$y -fill $col -outline $col
    $g(image) put $col -to $x $y
 }
#--------------- Some little utilities:
 proc K {a b} {set a}
 proc min {a b} {expr $a<$b? $a:$b}
 proc max {a b} {expr $a>$b? $a:$b}
 proc pop varName {
    upvar 1 $varName v
    K [lindex $v end] [set v [lrange $v 0 end-1]]
 }
 proc rgb color {
    foreach {r g b} $color break
    format #%02x%02x%02x $r $g $b
 }

 main
 wm geometry . 235x280+0+0 ;#iPaq
----

[Category Graphics] - [Category File]