Version 7 of Canvas polygon buttons
Updated 2012-07-08 20:28:35 by RLE
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.
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.
# 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: