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: