A tiny drawing program

Richard Suchenwirth 2005-01-01 - As this New Year's Day project, here's a tiny drawing program on a canvas. Radio buttons on top allow choice of draw mode and fill color. In "Move" mode, you can of course move items around. Right-click on an item to delete it.

A radio is an obvious "megawidget" to hold a row of radiobuttons. This simple one allows text or color mode:

 proc radio {w var values {col 0}} {
    frame $w
    set type [expr {$col? "-background" : "-text"}]
    foreach value $values {
        radiobutton $w.v$value $type $value -variable $var -value $value \
            -indicatoron 0
        if $col {$w.v$value config -selectcolor $value -borderwidth 3}
    }
    eval pack [winfo children $w] -side left
    set ::$var [lindex $values 0]
    set w
 }

Depending on draw mode, the mouse events "Down" and "Motion" have different handlers, which are dispatched by names that look like array elements. So for a mode X, we need a pair of procs, down(X) and move(X). Values used between calls are kept in global variables.

First, the handlers for free-hand line drawing:

 proc down(Draw) {w x y} {
    set ::ID [$w create line $x $y $x $y -fill $::Fill]
 }
 proc move(Draw) {w x y} {
    $w coords $::ID [concat [$w coords $::ID] $x $y]
 }
#-- Movement of an item
 proc down(Move) {w x y} {
    set ::ID [$w find withtag current]
    set ::X $x; set ::Y $y
 }
 proc move(Move) {w x y} {
    $w move $::ID [expr {$x-$::X}] [expr {$y-$::Y}]
    set ::X $x; set ::Y $y
 }
#-- Clone an existing item
 proc serializeCanvasItem {c item} {
    set data [concat [$c type $item] [$c coords $item]]
    foreach opt [$c itemconfigure $item] {
        # Include any configuration that deviates from the default
        if {[lindex $opt end] != [lindex $opt end-1]} {
            lappend data [lindex $opt 0] [lindex $opt end]
            }
        }
    return $data
    }
 proc down(Clone) {w x y} {
    set current [$w find withtag current]
    if {[string length $current] > 0} {
        set itemData [serializeCanvasItem $w [$w find withtag current]]
        set ::ID [eval $w create $itemData]
        set ::X $x; set ::Y $y
    }
 }
 interp alias {} move(Clone) {} move(Move)
#-- Drawing a rectangle
 proc down(Rect) {w x y} {
    set ::ID [$w create rect $x $y $x $y -fill $::Fill]
 }
 proc move(Rect) {w x y} {
    $w coords $::ID [lreplace [$w coords $::ID] 2 3 $x $y]
 }
#-- Drawing an oval (or circle, if you're careful)
 proc down(Oval) {w x y} {
    set ::ID [$w create oval $x $y $x $y -fill $::Fill]
 }
 proc move(Oval) {w x y} {
    $w coords $::ID [lreplace [$w coords $::ID] 2 3 $x $y]
 }

Polygons are drawn by clicking the corners. When a corner is close enough to the first one, the polygon is closed and drawn.

 proc down(Poly) {w x y} {
    if [info exists ::Poly] {
        set coords [$w coords $::Poly]
        foreach {x0 y0} $coords break
        if {hypot($y-$y0,$x-$x0)<10} {
            $w delete $::Poly
            $w create poly [lrange $coords 2 end] -fill $::Fill
            unset ::Poly
        } else {
            $w coords $::Poly [concat $coords $x $y]
        }
    } else {
        set ::Poly [$w create line $x $y $x $y -fill $::Fill]
    }
 }
 proc move(Poly) {w x y} {#nothing}

#-- With little more coding, the '''Fill''' mode allows changing an item's fill color:
 proc down(Fill) {w x y} {$w itemconfig current -fill $::Fill}
 proc move(Fill) {w x y} {}

#-- Building the UI
 set modes {Draw Move Clone Fill Rect Oval Poly}
 set colors {
    black white magenta brown red orange yellow green green3 green4
    cyan blue blue4 purple
 }
 grid [radio .1 Mode $modes] [radio .2 Fill $colors 1] -sticky nw
 grid [canvas .c -relief raised -borderwidth 1] - -sticky news
 grid rowconfig . 0 -weight 0
 grid rowconfig . 1 -weight 1

#-- The current mode is retrieved at runtime from the global ''Mode'' variable:
 bind .c <1>         {down($Mode) %W %x %y}
 bind .c <B1-Motion> {move($Mode) %W %x %y}
 bind .c <3>         {%W delete current}

For saving the current image, you need the Img extension, so just omit the following binding if you don't have Img:

 bind . <F1> {
    package require Img
    set img [image create photo -data .c]
    set name [tk_getSaveFile -filetypes {{GIFF .gif} {"All files" *}}\
        -defaultextension .gif]
    if {$name ne ""} {$img write $name; wm title . $name}
 }
#-- This is an always useful helper in development:
 bind . <Escape> {exec wish $argv0 &; exit}

Brian Theado 20Feb2005 - Nice! I like how simple this is. I noticed when closing polygons that I ended up with one less side than I expected. I changed end-2 to end in down(Poly) to fix that. I also added a Clone mode where you drag on an existing item to create a duplicate.