doodle as eTcl plugin
Richard Suchenwirth 2006-02-10 - Just for the fun, during a lengthy build, I contributed yet another plugin for Sepp for eTcl on PocketPC (but runnable anywhere): a little doodler, where you can select color and linewidth. Maybe I'll need it for a quick sketch (or a bored kid) sometimes...
proc doodle {} {
set w .canvas
if ![winfo exists $w] {
toplevel $w
wm geometry $w 240x268
wm title $w Canvas
pack [canvas $w.c -bg white] -fill both -expand 1
doodle'bind $w.c
interp alias {} c {} $w.c
palette $w.c
set ::color black; set ::width 1
}
wm deiconify $w; focus -force $w
}
proc palette w {
set x 5; set y 5
foreach color {black blue cyan green yellow orange red magenta} {
$w create oval $x $y [expr $x+12] [expr $y+12] -fill $color -tag pal
incr x 14
}
incr y 7
$w bind pal <1> {palette'color %W}
foreach width {1 2 3 4 5 6 7 8} {
$w create line $x $y [expr $x+10] $y -width $width -tag width
incr x 12
}
$w bind width <1> {palette'width %W}
incr x 5
$w create text $x $y -text C -tag clear
$w bind clear <1> {%W delete line}
}
proc palette'color w {
$w itemconfig pal -width 1
$w itemconfig current -width 3
set ::color [$w itemcget current -fill]
}
proc palette'width w {
$w itemconfig width -fill black
$w itemconfig current -fill red
set ::width [$w itemcget current -width]
}
proc doodle'bind w {
bind $w <1> [list doodle'start %W %x %y]
bind $w <B1-Motion> {doodle'move %W %x %y}
}
proc doodle'start {w x y} {
if {$y<20} return ;# don't write on the palette
set ::_id [$w create line $x $y $x $y \
-fill $::color -width $::width -tag line]
}
proc doodle'move {w x y} {
if {$y<20} return ;# don't write on the palette
$w coords $::_id [concat [$w coords $::_id] $x $y]
}#-- Self-test when sourced alone:
if {[file tail [info script]] eq [file tail $argv0]} {
wm withdraw .; doodle
}