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 ;#iPaqCategory Graphics - Category File
