package require Img
proc main argv {
global g
set g(mode) ""
trace var g(mode) w {changeMode .c}
pack [radio .r g(mode) {move text line rect oval} -side left] -fill x
pack [canvas .c -bg white] -fill both -expand 1
bind .c <Button-3> {%W delete withtag current}
bind .c <Control-s> {canvas_save %W}
set g(mode) move
bind . <Escape> {exec wish $argv0 &; exit}
}
#-- A collection of radiobuttons:
proc radio {w var values args} {
frame $w
set btns ""
foreach value $values {
lappend btns [radiobutton $w.b$value -indicatoron 0 \
-text $value -var $var -value $value]
}
eval pack $btns $args
set w
}
proc changeMode {w args} {
bind $w <ButtonRelease-1> {}
$w focus ""
switch -- $::g(mode) {
move {canvas_movable $w}
text {Canvas_EditBind $w}
line {canvas_drawable line $w}
rect {canvas_drawable rect $w}
oval {canvas_drawable oval $w}
}
}
proc canvas_save w {
set im [image create photo -format window -data $w]
set filename [tk_getSaveFile -defaultextension .jpg \
-filetypes {{JPEG .jpg} {"All files" *}}]
if {$filename ne ""} {
$im write $filename -format JPEG
}
image delete $im
}
proc canvas_movable w {
bind $w <Button-1> \
{set g(id) [%W find withtag current];
set g(x) [%W canvasx %x];
set g(y) [%W canvasy %y]}
bind $w <B1-Motion> {canvas_move %W [%W canvasx %x] [%W canvasy %y]}
foreach event {<Button-1> <B1-Motion>} {
$w bind text $event {}
}
$w config -cursor {}
}
proc canvas_move {w xn yn} {
global g
$w move $g(id) [expr {$xn-$g(x)}] [expr {$yn-$g(y)}]
set g(x) $xn
set g(y) $yn
}
proc canvas_drawable {type w} {
global g
set g(type) $type
bind $w <Button-1> {
set g(x) [%W canvasx %x]
set g(y) [%W canvasy %y]
set g(id) [%W create $g(type) $g(x) $g(y) $g(x) $g(y)]
}
bind $w <B1-Motion> {canvas_draw %W [%W canvasx %x] [%W canvasy %y]}
if {$type eq "line"} {
bind $w <ButtonRelease-1> {canvas_straighten %W}
}
foreach event {<Button-1> <B1-Motion>} {$w bind text $event {}}
$w config -cursor lr_angle
}
proc canvas_draw {w xn yn} {
global g
set coords [concat [lrange [$w coords $g(id)] 0 1] $xn $yn]
$w coords $g(id) $coords
}
proc canvas_straighten w {
set id [$w find withtag current]
foreach {x0 y0 x1 y1} [$w coords $id] break
if {abs($x0-$x1)<4 && abs($y0-$y1)>10} {set x1 $x0}
if {abs($y0-$y1)<4 && abs($x0-$x1)>10} {set y1 $y0}
$w coords $id $x0 $y0 $x1 $y1
}#-- Code from the Welch book proc Canvas_EditBind { c } {
bind $c <Button-1> {CanvasFocus %W [%W canvasx %x] [%W canvasy %y]}
bind $c <Button-2> {CanvasPaste %W [%W canvasx %x] [%W canvasy %y]}
bind $c <<Cut>> {CanvasTextCopy %W; CanvasDelete %W}
bind $c <<Copy>> {CanvasTextCopy %W}
bind $c <<Paste>> {CanvasPaste %W}
$c bind text <Button-1> {CanvasTextHit %W [%W canvasx %x] [%W canvasy %y]}
$c bind text <B1-Motion> {CanvasTextDrag %W [%W canvasx %x] [%W canvasy %y]}
$c bind text <Delete> {CanvasDelete %W}
$c bind text <Control-d> {CanvasDelChar %W}
$c bind text <BackSpace> {CanvasBackSpace %W}
$c bind text <Control-Delete> {CanvasErase %W}
$c bind text <Return> {CanvasInsert %W \n}
$c bind text <Any-Key> {CanvasInsert %W %A}
$c bind text <Key-Right> {CanvasMoveRight %W}
$c bind text <Key-Left> {CanvasMoveLeft %W}
$c config -cursor xterm
}
proc CanvasFocus {c x y} {
focus $c
set id [$c find overlapping [expr $x-2] [expr $y-2] \
[expr $x+2] [expr $y+2]]
if {($id == {}) || ([$c type $id] != "text")} {
set t [$c create text $x $y -text "" \
-tags text -anchor nw]
$c focus $t
$c select clear
$c icursor $t 0
}
}
proc CanvasTextHit {c x y {select 1}} {
$c focus current
$c icursor current @$x,$y
$c select clear
$c select from current @$x,$y
}
proc CanvasTextDrag {c x y} {
$c select to current @$x,$y
}
proc CanvasDelete {c} {
if {[$c select item] != {}} {
$c dchars [$c select item] sel.first sel.last
} elseif {[$c focus] != {}} {
$c dchars [$c focus] insert
}
}
proc CanvasTextCopy {c} {
if {[$c select item] != {}} {
clipboard clear
set t [$c select item]
set text [$c itemcget $t -text]
set start [$c index $t sel.first]
set end [$c index $t sel.last]
clipboard append [string range $text $start $end]
} elseif {[$c focus] != {}} {
clipboard clear
set t [$c focus]
set text [$c itemcget $t -text]
clipboard append $text
}
}
proc CanvasDelChar {c} {
if {[$c focus] ne {}} {
$c dchars [$c focus] insert
}
}
proc CanvasBackSpace {c} {
if {[$c select item] != {}} {
$c dchars [$c select item] sel.first sel.last
} elseif {[$c focus] != {}} {
set _t [$c focus]
$c icursor $_t [expr {[$c index $_t insert]-1}]
$c dchars $_t insert
}
}
proc CanvasErase {c} {$c delete [$c focus]}
proc CanvasInsert {c char} {$c insert [$c focus] insert $char}
proc CanvasPaste {c {x {}} {y {}}} {
if {[catch {selection get} _s] &&
[catch {selection get -selection CLIPBOARD} _s]} {
return ;# No selection
}
set id [$c focus]
if {[string length $id] == 0 } {
set id [$c find withtag current]
}
if {[string length $id] == 0 } {
# No object under the mouse
if {[string length $x] == 0} {
# Keyboard paste
set x [expr {[winfo pointerx $c] - [winfo rootx $c]}]
set y [expr {[winfo pointery $c] - [winfo rooty $c]}]
}
CanvasFocus $c $x $y
} else {
$c focus $id
}
$c insert [$c focus] insert $_s
}
proc CanvasMoveRight {c} {
$c icursor [$c focus] [expr [$c index current insert]+1]
}
proc CanvasMoveLeft {c} {
$c icursor [$c focus] [expr [$c index current insert]-1]
}
main $argvSee also: A tiny drawing program
Ro 2012-04-08 removed a call to global that wasn't necessary and was breaking on 8.5The saving proc is very instructive because it uses an undocumented ability of Img to save the contents of a window to jpeg.---AK Note also tklib's diagram package and dia application.