package require Img

 proc main argv {
     global g
     set g(mode) ""
     trace add variable g(mode) write {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 $argv