----
[http://web.tiscali.it/marcomaggi/images/canvas_polygon_buttons.png]
Image link appears broken on July 8, 2012.
----
[MM] Strange thing: if I move the pointer just above the text on a button and
click the event is delivered (I have verified that uwp_cb_action_press is
invoked) but then nothing happens: the button is not pressed. There is a small
rectangle area just above the text item that shows this behaviour: if I move
the pointer a few pixel above or below everything works. I was not able to
reproduce the behaviour with a script that just displayes a canvas with a
polygon and a word of text in it, so the bug must be in my code.
----
[IDG] For me, there is a small dead area on all sides of the text.
I wonder if this is associated with enter/leave events as you move between
the text and the button. You bind to the containing frame ... are all events
guaranteed to arrive in the correct order?
----
[MM] If someone is able to suggest a way to draw an outer polygon to mimic
the highlight border when the focus in in, let me know thank you.
----
[SeS] (11th July, 2012) Nice set of custom canvas buttons, indeed I do observe the same dead area around the text, additionally when user presses the button and at the same time moves into the dead area, it will generate the 'release' event and thus will activate the unpress procedure of the button, even if user is still pressing on the same button. To overcome this situation, we may add the following to the existing set of bindings:
======
  $c bind Clickable <B1-Motion>       [list uwp_cb_event_press   $widget]
======
But the dead area problem remains persistently...

One other thing, when copy/pasting this complete code into [tG²] I had to add the command 'update' right after 'wm geometry . +100+100' inside procedure 'main' in order to see the buttons. No idea why...
----
[SeS] (12th of July, 2012)

Found some more time to fix the dead area problem...
<<discussion>>proposal for fixing dead area problem:
======
# canvas_polygon_button.tcl --
 # 
 # Part of: Useless Widgets Packages
 # Contents: test canvas buttons
 # Date: Wed Dec 22, 2004
 # Credits: Gerard Sookahet has put the superformula on the TCL'ers Wiki
 # 
 # Abstract
 # 
 #        It should support all the common button operations:
 #
 #        * when the pointer enters the button is hilighted;
 #        * when the button is clicked it is pressed;
 #        * when the pointer leaves the button is de-hilighted
 #          and raised (if pressed);
 #        * when the button is unclicked the button is raised
 #          (if pressed) and the command invoked (if the button
 #          is pressed);
 #        * if focus comes in the text is underlined;
 #        * if the focus goes out the text is deunderlined;
 #        * if the "Return" key is pressed while the focus is in
 #          the button is pressed and then depressed after 100 ms,
 #          and the command invoked.
 # 
 # Copyright (c) 2004 Marco Maggi
 # 
 # The author  hereby grant permission to use,  copy, modify, distribute,
 # and  license this  software  and its  documentation  for any  purpose,
 # provided that  existing copyright notices  are retained in  all copies
 # and that  this notice  is included verbatim  in any  distributions. No
 # written agreement, license, or royalty  fee is required for any of the
 # authorized uses.  Modifications to this software may be copyrighted by
 # their authors and need not  follow the licensing terms described here,
 # provided that the new terms are clearly indicated on the first page of
 # each file where they apply.
 # 
 # IN NO  EVENT SHALL THE AUTHOR  OR DISTRIBUTORS BE LIABLE  TO ANY PARTY
 # FOR  DIRECT, INDIRECT, SPECIAL,  INCIDENTAL, OR  CONSEQUENTIAL DAMAGES
 # ARISING OUT  OF THE  USE OF THIS  SOFTWARE, ITS DOCUMENTATION,  OR ANY
 # DERIVATIVES  THEREOF, EVEN  IF THE  AUTHOR  HAVE BEEN  ADVISED OF  THE
 # POSSIBILITY OF SUCH DAMAGE.
 # 
 # THE  AUTHOR  AND DISTRIBUTORS  SPECIFICALLY  DISCLAIM ANY  WARRANTIES,
 # INCLUDING,   BUT   NOT  LIMITED   TO,   THE   IMPLIED  WARRANTIES   OF
 # MERCHANTABILITY,    FITNESS   FOR    A    PARTICULAR   PURPOSE,    AND
 # NON-INFRINGEMENT.  THIS  SOFTWARE IS PROVIDED  ON AN "AS  IS" BASIS,
 # AND  THE  AUTHOR  AND  DISTRIBUTORS  HAVE  NO  OBLIGATION  TO  PROVIDE
 # MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
 # 
 # Bugfix proposals by Sedat Serper:
 #  11th of July 2012
 #    - moving over text while pressing button behaves as intended
 #  12th of July 2012
 #    - the dead area problem is fixed
 #  Observed additionally:
 #    - even when user looses focus while pressing button, it will not 
 #      restore the button to normal view, until user releases the button
 #  Note:
 #   All additions/corrections by this author is identied with the #SeS  
 #   string in the code
 #
 
 #page
 ## ------------------------------------------------------------
 ## Setup.
 ## ------------------------------------------------------------
 
 package require Tcl 8.4
 package require Tk  8.4
 
 #page
 ## ------------------------------------------------------------
 ## Widget options.
 ## ------------------------------------------------------------
 
 option add *borderWidth                  1
 
 option add *Cb.relief                    flat
 option add *Cb.canvas.relief             flat
 
 option add *Cb.borderWidth               2
 option add *Cb*highlightThickness        0
 # this is the default light gray
 option add *Cb.background                "\#d9d9d9"
 option add *Cb.bbground                  "\#d9d9d9"
 # bisque see the "colors" man page or "/usr/X11R6/lib/X11/rgb.txt"
 option add *Cb.activebbground            bisque
 option add *Cb.foreground                black
 option add *Cb.pressedbordercolor        {dark gray}
 option add *Cb.width                     100
 option add *Cb.height                    100
 option add *Cb.takeFocus                 1
 
 option add *Cb.text                      Text
 option add *Cb.font                      {-weight bold -family Helvetica -size 12}
 
 #page
 ## ------------------------------------------------------------
 ## Main.
 ## ------------------------------------------------------------
 
 proc main {} {
     global        exit_trigger
 
     wm title . "Testing canvas buttons"
     wm geometry . 600x600+100+100
     #SeS : tG2 requires this for some odd reason...
     update
     
     set counter 0
     
     set col -1
     foreach {name num fraction} {
         a 3 -4  b 4 8  c 6 1  d 12 1  e 50 1
     } {
         uwp_cb_build .$name [polygon_regular_coords $num 0.8 $fraction] \
             button_command
         grid .$name -row 0 -column [incr col]
     }
     set col -1
     foreach {name num} {
         m 3  n 4  o 6  p 12  q 20
     } {
         uwp_cb_build .$name [polygon_star_coords $num] button_command
         grid .$name -row 1 -column [incr col]
     }
     set col -1
     # parms: a b m n1 n2 n3
     foreach {name parms} {
         r {0.7   0.9   6.0   1.0   2.0   1.4}
         s {0.9   0.7  12.0   1.5   2.0   7.5}
         t {0.9   0.7  10.0   0.9   1.7   1.1}
     } {
         uwp_cb_build .$name [eval superformula $parms] button_command
         grid .$name -row 2 -column [incr col]
     }
 
     grid \
         [label .l -text 0 -width 5 -background \#ffffff] \
         [button .quit -text Exit -command main_exit]
     focus .quit
     bind .quit <Return> main_exit
     
     interp alias {} main_exit {} set exit_trigger 1
     vwait exit_trigger
     #SeS : tG2 has renamed the 'exit' command to 'tcl_exit' for exit handling...
     #exit
     destroy .
 }
 proc button_command {} { .l configure -text [expr {[.l cget -text]+1}] }
 #page
 proc polygon_regular_coords { num radius {fraction 1.0} } {
     for {set i 0} {$i < $num} {incr i} {
         set angle [expr {6.28318530718/double($fraction)+
                          (6.28318530718*double($i)/double($num))}]
         lappend coords \
             [expr {double($radius)*cos($angle)}] \
             [expr {double($radius)*sin($angle)}]
     }
     return $coords
 }
 proc polygon_star_coords { num } {
     set fraction [expr {double($num)*2.0}]
     foreach {x1 y1} [polygon_regular_coords $num 0.9] \
         {x2 y2} [polygon_regular_coords $num 0.6 $fraction] {
             lappend result $x1 $y1 $x2 $y2
     }
     return $result
 }
 proc superformula { a b m n1 n2 n3 } {
     set num 50
     for {set i 0} {$i < $num} {incr i} {
         set theta [expr {double($i)*6.28318530718/double($num)}]
         set rho \
             [expr { pow(pow(abs(cos(0.25*double($m)*double($theta))/double($a)),
                             double($n2))+
                         pow(abs(sin(0.25*double($m)*double($theta))/double($b)),
                             double($n2)), (-1/double($n1))) }]
         lappend result [expr {$rho*cos($theta)}] [expr {$rho*sin($theta)}]
     }
     return $result
 }
 #page
 proc uwp_op_array { widget varName } {
     uplevel [list array set $varName { a b }]
     uplevel [list trace add variable $varName read  [list uwp_op_get $widget]]
     uplevel [list trace add variable $varName write [list uwp_op_set $widget]]
 }
 proc uwp_op_get { widget name1 name2 op } {
     upvar        $name1 options
     set options($name2) [option get $widget $name2 {}]
 }
 proc uwp_op_set { widget name1 name2 op } {
     upvar        $name1 options
     option add *[string trimleft $widget .].$name2 $options($name2)
 }
 #page
 proc uwp_cb_build { widget coords {command {}} } {
     global        uwp_data
     uwp_op_array $widget options
     
     frame $widget -class Cb
     canvas [set c $widget.canvas] -background $options(background) \
         -width $options(width) -height $options(height)
     grid $c
     
     set width  [$c cget -width]
     set height [$c cget -height]
     
     foreach {x y} $coords {
         lappend border_coords \
             [expr {int((double($x)+1.0)*double($width)*0.5)}] \
             [expr {int((double($y)+1.0)*double($height)*0.5)}]
     }
     array set uwp_data \
         [list $widget:border_coords $border_coords $widget:pressed no]
     
     $c create polygon $border_coords -tags {Clickable Button} \
         -fill $options(bbground)
     $c create text [expr {int($width/2)}] [expr {int($height/2)}] \
         -text $options(text) -font $options(font) \
         -fill $options(foreground) -tags {Clickable Text}
     uwp_p_cb_draw_released_border $widget
     
     bind $widget <Destroy>  [list uwp_p_cb_destroy $widget]
     bind $widget <FocusIn>  [list uwp_cb_event_focus yes $widget]
     bind $widget <FocusOut> [list uwp_cb_event_focus no $widget]
     bind $widget <Return>   [list uwp_cb_event_return $widget]
     $c bind Clickable <ButtonRelease-1> [list uwp_cb_event_release $widget]
     $c bind Clickable <ButtonPress-1>   [list uwp_cb_event_press   $widget]
     $c bind Clickable <Enter>           [list uwp_cb_event_enter   $widget]
     $c bind Clickable <Leave>           [list uwp_cb_event_leave   $widget]

     #SeS
     $c bind Clickable <B1-Motion>       [list uwp_cb_event_press   $widget]
     
     uwp_cb_command $widget $command
     return $widget
 }
 proc uwp_p_cb_destroy { widget } {
     global        uwp_data
     array unset uwp_data $widget:*
 }
 #page
 proc uwp_p_cb_draw_border { pressed widget } {
     global        uwp_data
     uwp_op_array $widget options
     
     set coords $uwp_data($widget:border_coords)
     set coords1 [concat [lrange $coords 2 end] [lrange $coords 0 1]]
     
     foreach {x1 y1} $coords {x2 y2} $coords1 {
         set d [expr {(-double($y2-$y1)+double($x2-$x1))/
                      sqrt(pow(double($y2-$y1),2.0)+pow(double($x2-$x1),2.0))}]
         set level [expr {180+int(50.0*$d)}]
         if { $pressed } {
             if { $level < 200 } { set color $options(background)
             } else { set color $options(pressedbordercolor) }
         } else {
             set color [format "\#%x%x%x" $level $level $level]            
         }
         $widget.canvas create line $x1 $y1 $x2 $y2 \
             -fill $color -tags Border -width $options(borderWidth)
     }
 }
 interp alias {} uwp_p_cb_draw_pressed_border  {} uwp_p_cb_draw_border yes
 interp alias {} uwp_p_cb_draw_released_border {} uwp_p_cb_draw_border no
 proc deg2rad { angle } { expr {double($angle)*57.2957795131} }
 #page
 proc uwp_cb_command { widget {command {}} } {
     global        uwp_data
     set uwp_data($widget:command) $command
 }
 proc uwp_cb_invoke { widget } {
     upvar        \#0 uwp_data($widget:command) cmd
     upvar        \#0 uwp_data($widget:focus) focus
     if { [string length $cmd] && $focus } { uplevel \#0 $cmd }
 }
 proc uwp_cb_event_press { widget } {
     uwp_cb_action_press $widget
 }
 proc uwp_cb_event_release { widget } {
     #SeS
     upvar        \#0 uwp_data($widget:pressed) pressed
     upvar        \#0 uwp_data($widget:focus) focus
     if { $pressed && $focus} { after 0 [list uwp_cb_invoke $widget] }
     uwp_cb_action_release $widget
 }
 proc uwp_cb_event_enter { widget } {
    #SeS
    upvar        \#0 uwp_data($widget:pressed) pressed
    if { ! $pressed } {uwp_cb_action_state_active $widget}
    set ::uwp_data($widget:focus) 1
 }
 proc uwp_cb_event_leave { widget } {
    #SeS
    upvar        \#0 uwp_data($widget:pressed) pressed
    upvar        \#0 uwp_data($widget:focus) focus
    if { !$pressed && $focus } {
      uwp_cb_action_state_normal $widget
      uwp_cb_action_release $widget
      set ::uwp_data($widget:focus) 0
    }
 }
 proc uwp_cb_event_focus { mode widget } {
     $widget.canvas itemconfigure Text \
         -font [concat [$widget.canvas itemcget Text -font] [list -underline $mode]]
 }
 proc uwp_cb_event_return { widget } {
     uwp_cb_event_press $widget
     after 100 [list uwp_cb_event_release $widget]
 }
 #page
 proc uwp_cb_action_state_active { widget } {
     uwp_op_array $widget options
     $widget.canvas itemconfigure Button -fill $options(activebbground)
 }
 proc uwp_cb_action_state_normal { widget } {
     uwp_op_array $widget options
     $widget.canvas itemconfigure Button -fill $options(bbground)
 }
 proc uwp_cb_action_press { widget } {
     upvar        \#0 uwp_data($widget:pressed) pressed
     if { ! $pressed } {
         uwp_p_cb_draw_pressed_border $widget
         $widget.canvas move Text 2 2
         set pressed yes
     }
 }
 proc uwp_cb_action_release { widget } {
     upvar        \#0 uwp_data($widget:pressed) pressed
     if { $pressed } {
         uwp_p_cb_draw_released_border $widget
         $widget.canvas move Text -2 -2
         set pressed no
     }
 }
 #page
 ## ------------------------------------------------------------
 ## Let's go.
 ## ------------------------------------------------------------
 main
 
 ### end of file
 # Local Variables:
 # mode: tcl
 # End:
======
<<discussion>>

----

Orginal code:
======

 # canvas_polygon_button.tcl --
 # 
 # Part of: Useless Widgets Packages
 # Contents: test canvas buttons
 # Date: Wed Dec 22, 2004
 # Credits: Gerard Sookahet has put the superformula on the TCL'ers Wiki
 # 
 # Abstract
 # 
 #        It should support all the common button operations:
 #
 #        * when the pointer enters the button is hilighted;
 #        * when the button is clicked it is pressed;
 #        * when the pointer leaves the button is de-hilighted
 #          and raised (if pressed);
 #        * when the button is unclicked the button is raised
 #          (if pressed) and the command invoked (if the button
 #          is pressed);
 #        * if focus comes in the text is underlined;
 #        * if the focus goes out the text is deunderlined;
 #        * if the "Return" key is pressed while the focus is in
 #          the button is pressed and then depressed after 100 ms,
 #          and the command invoked.
 # 
 # Copyright (c) 2004 Marco Maggi
 # 
 # The author  hereby grant permission to use,  copy, modify, distribute,
 # and  license this  software  and its  documentation  for any  purpose,
 # provided that  existing copyright notices  are retained in  all copies
 # and that  this notice  is included verbatim  in any  distributions. No
 # written agreement, license, or royalty  fee is required for any of the
 # authorized uses.  Modifications to this software may be copyrighted by
 # their authors and need not  follow the licensing terms described here,
 # provided that the new terms are clearly indicated on the first page of
 # each file where they apply.
 # 
 # IN NO  EVENT SHALL THE AUTHOR  OR DISTRIBUTORS BE LIABLE  TO ANY PARTY
 # FOR  DIRECT, INDIRECT, SPECIAL,  INCIDENTAL, OR  CONSEQUENTIAL DAMAGES
 # ARISING OUT  OF THE  USE OF THIS  SOFTWARE, ITS DOCUMENTATION,  OR ANY
 # DERIVATIVES  THEREOF, EVEN  IF THE  AUTHOR  HAVE BEEN  ADVISED OF  THE
 # POSSIBILITY OF SUCH DAMAGE.
 # 
 # THE  AUTHOR  AND DISTRIBUTORS  SPECIFICALLY  DISCLAIM ANY  WARRANTIES,
 # INCLUDING,   BUT   NOT  LIMITED   TO,   THE   IMPLIED  WARRANTIES   OF
 # MERCHANTABILITY,    FITNESS   FOR    A    PARTICULAR   PURPOSE,    AND
 # NON-INFRINGEMENT.  THIS  SOFTWARE IS PROVIDED  ON AN "AS  IS" BASIS,
 # AND  THE  AUTHOR  AND  DISTRIBUTORS  HAVE  NO  OBLIGATION  TO  PROVIDE
 # MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
 # 
 #
 
 #page
 ## ------------------------------------------------------------
 ## Setup.
 ## ------------------------------------------------------------
 
 package require Tcl 8.4
 package require Tk  8.4
 
 #page
 ## ------------------------------------------------------------
 ## Widget options.
 ## ------------------------------------------------------------
 
 option add *borderWidth                        1
 
 option add *Cb.relief                        flat
 option add *Cb.canvas.relief                flat
 
 option add *Cb.borderWidth                2
 option add *Cb*highlightThickness        0
 # this is the default light gray
 option add *Cb.background                "\#d9d9d9"
 option add *Cb.bbground                        "\#d9d9d9"
 # bisque see the "colors" man page or "/usr/X11R6/lib/X11/rgb.txt"
 option add *Cb.activebbground                bisque
 option add *Cb.foreground                black
 option add *Cb.pressedbordercolor        {dark gray}
 option add *Cb.width                        100
 option add *Cb.height                        100
 option add *Cb.takeFocus                1
 
 option add *Cb.text                        Text
 option add *Cb.font                        {-weight bold -family Helvetica -size 12}
 
 #page
 ## ------------------------------------------------------------
 ## Main.
 ## ------------------------------------------------------------
 
 proc main {} {
     global        exit_trigger
 
     wm title . "Testing canvas buttons"
     wm geometry . +100+100
     
     set counter 0
     
     set col -1
     foreach {name num fraction} {
         a 3 -4  b 4 8  c 6 1  d 12 1  e 50 1
     } {
         uwp_cb_build .$name [polygon_regular_coords $num 0.8 $fraction] \
             button_command
         grid .$name -row 0 -column [incr col]
     }
     set col -1
     foreach {name num} {
         m 3  n 4  o 6  p 12  q 20
     } {
         uwp_cb_build .$name [polygon_star_coords $num] button_command
         grid .$name -row 1 -column [incr col]
     }
     set col -1
     # parms: a b m n1 n2 n3
     foreach {name parms} {
         r {0.7   0.9   6.0   1.0   2.0   1.4}
         s {0.9   0.7  12.0   1.5   2.0   7.5}
         t {0.9   0.7  10.0   0.9   1.7   1.1}
     } {
         uwp_cb_build .$name [eval superformula $parms] button_command
         grid .$name -row 2 -column [incr col]
     }
 
     grid \
         [label .l -text 0 -width 5 -background \#ffffff] \
         [button .quit -text Exit -command main_exit]
     focus .quit
     bind .quit <Return> main_exit
     
     interp alias {} main_exit {} set exit_trigger 1
     vwait exit_trigger
     exit
 }
 proc button_command {} { .l configure -text [expr {[.l cget -text]+1}] }
 #page
 proc polygon_regular_coords { num radius {fraction 1.0} } {
     for {set i 0} {$i < $num} {incr i} {
         set angle [expr {6.28318530718/double($fraction)+
                          (6.28318530718*double($i)/double($num))}]
         lappend coords \
             [expr {double($radius)*cos($angle)}] \
             [expr {double($radius)*sin($angle)}]
     }
     return $coords
 }
 proc polygon_star_coords { num } {
     set fraction [expr {double($num)*2.0}]
     foreach {x1 y1} [polygon_regular_coords $num 0.9] \
         {x2 y2} [polygon_regular_coords $num 0.6 $fraction] {
             lappend result $x1 $y1 $x2 $y2
     }
     return $result
 }
 proc superformula { a b m n1 n2 n3 } {
     set num 50
     for {set i 0} {$i < $num} {incr i} {
         set theta [expr {double($i)*6.28318530718/double($num)}]
         set rho \
             [expr { pow(pow(abs(cos(0.25*double($m)*double($theta))/double($a)),
                             double($n2))+
                         pow(abs(sin(0.25*double($m)*double($theta))/double($b)),
                             double($n2)), (-1/double($n1))) }]
         lappend result [expr {$rho*cos($theta)}] [expr {$rho*sin($theta)}]
     }
     return $result
 }
 #page
 proc uwp_op_array { widget varName } {
     uplevel [list array set $varName { a b }]
     uplevel [list trace add variable $varName read  [list uwp_op_get $widget]]
     uplevel [list trace add variable $varName write [list uwp_op_set $widget]]
 }
 proc uwp_op_get { widget name1 name2 op } {
     upvar        $name1 options
     set options($name2) [option get $widget $name2 {}]
 }
 proc uwp_op_set { widget name1 name2 op } {
     upvar        $name1 options
     option add *[string trimleft $widget .].$name2 $options($name2)
 }
 #page
 proc uwp_cb_build { widget coords {command {}} } {
     global        uwp_data
     uwp_op_array $widget options
     
     frame $widget -class Cb
     canvas [set c $widget.canvas] -background $options(background) \
         -width $options(width) -height $options(height)
     grid $c
     
     set width  [$c cget -width]
     set height [$c cget -height]
     
     foreach {x y} $coords {
         lappend border_coords \
             [expr {int((double($x)+1.0)*double($width)*0.5)}] \
             [expr {int((double($y)+1.0)*double($height)*0.5)}]
     }
     array set uwp_data \
         [list $widget:border_coords $border_coords $widget:pressed no]
     
     $c create polygon $border_coords -tags {Clickable Button} \
         -fill $options(bbground)
     $c create text [expr {int($width/2)}] [expr {int($height/2)}] \
         -text $options(text) -font $options(font) \
         -fill $options(foreground) -tags {Clickable Text}
     uwp_p_cb_draw_released_border $widget
     
     bind $widget <Destroy>  [list uwp_p_cb_destroy $widget]
     bind $widget <FocusIn>  [list uwp_cb_event_focus yes $widget]
     bind $widget <FocusOut> [list uwp_cb_event_focus no $widget]
     bind $widget <Return>   [list uwp_cb_event_return $widget]
     $c bind Clickable <ButtonRelease-1> [list uwp_cb_event_release $widget]
     $c bind Clickable <ButtonPress-1>   [list uwp_cb_event_press   $widget]
     $c bind Clickable <Enter>           [list uwp_cb_event_enter   $widget]
     $c bind Clickable <Leave>           [list uwp_cb_event_leave   $widget]
     
     uwp_cb_command $widget $command
     return $widget
 }
 proc uwp_p_cb_destroy { widget } {
     global        uwp_data
     array unset uwp_data $widget:*
 }
 #page
 proc uwp_p_cb_draw_border { pressed widget } {
     global        uwp_data
     uwp_op_array $widget options
     
     set coords $uwp_data($widget:border_coords)
     set coords1 [concat [lrange $coords 2 end] [lrange $coords 0 1]]
     
     foreach {x1 y1} $coords {x2 y2} $coords1 {
         set d [expr {(-double($y2-$y1)+double($x2-$x1))/
                      sqrt(pow(double($y2-$y1),2.0)+pow(double($x2-$x1),2.0))}]
         set level [expr {180+int(50.0*$d)}]
         if { $pressed } {
             if { $level < 200 } { set color $options(background)
             } else { set color $options(pressedbordercolor) }
         } else {
             set color [format "\#%x%x%x" $level $level $level]            
         }
         $widget.canvas create line $x1 $y1 $x2 $y2 \
             -fill $color -tags Border -width $options(borderWidth)
     }
 }
 interp alias {} uwp_p_cb_draw_pressed_border  {} uwp_p_cb_draw_border yes
 interp alias {} uwp_p_cb_draw_released_border {} uwp_p_cb_draw_border no
 proc deg2rad { angle } { expr {double($angle)*57.2957795131} }
 #page
 proc uwp_cb_command { widget {command {}} } {
     global        uwp_data
     set uwp_data($widget:command) $command
 }
 proc uwp_cb_invoke { widget } {
     upvar        \#0 uwp_data($widget:command) cmd
     if { [string length $cmd] } { uplevel \#0 $cmd }
 }
 proc uwp_cb_event_press { widget } {
     uwp_cb_action_press $widget
 }
 proc uwp_cb_event_release { widget } {
     upvar        \#0 uwp_data($widget:pressed) pressed
     if { $pressed } { after 0 [list uwp_cb_invoke $widget] }
     uwp_cb_action_release $widget
 }
 proc uwp_cb_event_enter { widget } {
     uwp_cb_action_state_active $widget
 }
 proc uwp_cb_event_leave { widget } {
     uwp_cb_action_state_normal $widget
     uwp_cb_action_release $widget
 }
 proc uwp_cb_event_focus { mode widget } {
     $widget.canvas itemconfigure Text \
         -font [concat [$widget.canvas itemcget Text -font] [list -underline $mode]]
 }
 proc uwp_cb_event_return { widget } {
     uwp_cb_event_press $widget
     after 100 [list uwp_cb_event_release $widget]
 }
 #page
 proc uwp_cb_action_state_active { widget } {
     uwp_op_array $widget options
     $widget.canvas itemconfigure Button -fill $options(activebbground)
 }
 proc uwp_cb_action_state_normal { widget } {
     uwp_op_array $widget options
     $widget.canvas itemconfigure Button -fill $options(bbground)
 }
 proc uwp_cb_action_press { widget } {
     upvar        \#0 uwp_data($widget:pressed) pressed
     if { ! $pressed } {
         uwp_p_cb_draw_pressed_border $widget
         $widget.canvas move Text 2 2
         set pressed yes
     }
 }
 proc uwp_cb_action_release { widget } {
     upvar        \#0 uwp_data($widget:pressed) pressed
     if { $pressed } {
         uwp_p_cb_draw_released_border $widget
         $widget.canvas move Text -2 -2
         set pressed no
     }
 }
 #page
 ## ------------------------------------------------------------
 ## Let's go.
 ## ------------------------------------------------------------
 
 main
 
 ### end of file
 # Local Variables:
 # mode: tcl
 # End:
======


<<categories>> Graphics | Broken Links