imEdit
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.
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