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 TEXT 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...
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:
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: