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.FPX However, Img only copies the windows's visible area to the image. If the window is covered, e.g., by another application, the covered parts appear blank. (Observed on Windows.)
AK Note also tklib's diagram package and dia application.
