----
[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.
----
[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:
======


<<categories>> Graphics