Updated 2017-11-08 18:57:05 by SEH


 # canvas_equaliser.tcl --
 # 
 # Part of: Useless Analog Widgets
 # Contents: canvas equaliser test script
 # Date: Fri Dec 24, 2004
 # 
 # Abstract
 # 
 # 
 # 
 # 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
 ## ------------------------------------------------------------
 ## TK options.
 ## ------------------------------------------------------------
 
 # led numbers and pad options must be tailored to the screen resolution
 # the values below work for 1024x768
 
 option add *borderWidth                                1
 
 option add *Equaliser.relief                        sunken
 option add *Equaliser.borderWidth                1
 option add *Equaliser.highlightTickness                0
 option add *Equaliser.canvas.borderWidth        0
 option add *Equaliser.canvas.highlightTickness        0
 option add *Equaliser.canvas.relief                flat
 
 option add *Equaliser.canvas.background                black
 
 option add *Equaliser.label                        level
 option add *Equaliser.label_font                {-family helvetica -size 10}
 
 option add *Equaliser.channel_number                10
 option add *Equaliser.led_number                15
 
 option add *Equaliser.epadx                        6
 option add *Equaliser.epady                        6
 option add *Equaliser.ipadx                        6
 option add *Equaliser.ipady                        6
 
 option add *Equaliser.box_display                yes
 option add *Equaliser.box_color                        gold
 
 option add *Equaliser.orient                        vertical
 option add *Equaliser.led_width                        8
 option add *Equaliser.led_height                2
 option add *Equaliser.channel_spacing                3
 option add *Equaliser.led_spacing                2
 
 option add *Equaliser.led_red_mark                0.8
 option add *Equaliser.led_green_off_color        darkgreen
 option add *Equaliser.led_green_on_color        green
 option add *Equaliser.led_red_off_color                darkred
 option add *Equaliser.led_red_on_color                red
 
 
 option add *b.led_height                        1
 option add *b.channel_number                        20
 option add *b.label                                {}
 option add *b.led_red_mark                        1.0
 option add *b.led_green_off_color                goldenrod4
 option add *b.led_green_on_color                gold
 option add *b.epadx                                3
 option add *b.epady                                3
 option add *b.ipadx                                3
 option add *b.ipady                                3
 
 option add *d.led_height                        1
 option add *d.channel_number                        20
 option add *d.led_number                        30
 option add *d.label                                {}
 option add *d.led_red_mark                        1.0
 option add *d.led_green_off_color                darkslategray
 option add *d.led_green_on_color                lightgray
 option add *d.epadx                                3
 option add *d.epady                                3
 option add *d.ipadx                                3
 option add *d.ipady                                3
 option add *d.box_color                                lightgray
 
 option add *c.orient                                horizontal
 
 option add *e.label                                channels
 option add *e.led_number                        40
 option add *e.led_height                        2
 option add *e.channel_number                        2
 option add *e.orient                                horizontal
 
 #page
 ## ------------------------------------------------------------
 ## Main.
 ## ------------------------------------------------------------
 
 proc main {} {
     global        exit_trigger
 
     wm title . "Testing canvas equaliser"
     wm geometry . +200+100
     
     grid [frame .f] -sticky news
     
     equaliser .f.a
     equaliser .f.b
     equaliser .f.c
     equaliser .f.d
     grid .f.a .f.b -sticky news -padx 5 -pady 5
     grid .f.c .f.d -sticky news -padx 5
     
     equaliser .e
     grid .e
     grid [button .quit -text Exit -command main_exit]
     focus .quit
     bind .quit <Return> main_exit
     bind . <Escape> main_exit
     
     interp alias {} main_exit {} set exit_trigger 1
     vwait exit_trigger
     exit
 }
 proc equaliser { widget } {
     uwp_equaliser_build $widget
     schedule [list signals $widget [option get $widget channel_number {}]]
 }
 proc schedule { script } {
     after 250 [list schedule $script]
     uplevel \#0 $script
 }
 proc signals { widget number } {
     for {set i 0} {$i < $number} {incr i} { lappend signal [expr {rand()}] }
     uwp_equaliser_update $widget $signal
 }
 #page
 proc uwp_op_array { widget varName } {
     uplevel [subst -nocommands {
         array set $varName {}
         trace add variable $varName read { uwp_op_get $widget }
         trace add variable $varName write { 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_equaliser_build { widget } {
     uwp_op_array $widget options
     
     frame $widget -class Equaliser
     canvas [set c $widget.canvas]
     grid $c -sticky news -padx 0 -pady 0
 
     uwp_p_equaliser_draw_$options(orient) $widget
     return $widget
 }
 #page
 proc uwp_p_equaliser_draw_vertical { widget } {
     uwp_op_array $widget options
     set c $widget.canvas
     
     foreach var {
         epadx epady ipadx ipady
         channel_number led_number channel_spacing led_spacing
         led_width led_height
     } { set $var $options($var) }
     
     set width  [expr {2*$epadx+2*$ipadx+
                       $led_width*$channel_number+
                       $channel_spacing*($channel_number-1)}]
     set height [expr {2*$epadx+2*$ipadx+
                       $led_height*$led_number+
                       $led_spacing*($led_number-1)}]
     
     $c configure -width $width -height $height
     
     if { $options(box_display) } {
          $c create rectangle $epadx $epady \
             [expr {$width-$epadx}] [expr {$height-$epady}] \
             -outline $options(box_color) -tag Box
     }
 
     if { [string length $options(label)] } {
         set x1 [expr {$epadx+$ipadx+1}]
         set y1 $epady
         $c create text $x1 $y1 \
             -anchor w -text $options(label) -fill $options(box_color) \
             -font $options(label_font) -tag Label
         foreach {x1 y1 x2 y2} [$c bbox Label] {}
         $c create polygon $x1 $y1 $x2 $y1 $x2 $y2 $x1 $y2 \
             -fill [option get $c background {}] -tag LabelBack
         $c raise LabelBack Box
         $c raise Label LabelBack
     }
 
     set baseX [expr {$epadx+$ipadx}]
     set baseY [expr {$height-$epady-$ipady}]
 
     for {set channel 0} {$channel < $channel_number} {incr channel} {
         for {set led 0} {$led < $led_number} {incr led} {
             set x1 [expr {$baseX+$channel*($channel_spacing+$led_width)}]
             set y1 [expr {$baseY-$led*($led_spacing+$led_height)}]
             set x2 [expr {$x1+$led_width}]
             set y2 [expr {$y1-$led_height}]
             $c create polygon $x1 $y1 $x2 $y1 $x2 $y2 $x1 $y2 \
                 -tags $channel:$led
         }
     }
 
     uwp_equaliser_update $widget
 }
 #page
 proc uwp_p_equaliser_draw_horizontal { widget } {
     uwp_op_array $widget options
     set c $widget.canvas
     
     foreach var {
         epadx epady ipadx ipady
         channel_number led_number channel_spacing led_spacing
         led_width led_height
     } { set $var $options($var) }
     
     set height [expr {2*$epadx+2*$ipadx+
                       $led_width*$channel_number+
                       $channel_spacing*($channel_number-1)}]
     set width [expr {2*$epadx+2*$ipadx+
                       $led_height*$led_number+
                       $led_spacing*($led_number-1)}]
     
     $c configure -width $width -height $height
     
     if { $options(box_display) } {
          $c create rectangle $epadx $epady \
             [expr {$width-$epadx}] [expr {$height-$epady}] \
             -outline $options(box_color) -tag Box
     }
 
     if { [string length $options(label)] } {
         set x1 [expr {$epadx+$ipadx+1}]
         set y1 $epady
         $c create text $x1 $y1 \
             -anchor w -text $options(label) -fill $options(box_color) \
             -font $options(label_font) -tag Label
         foreach {x1 y1 x2 y2} [$c bbox Label] {}
         $c create polygon $x1 $y1 $x2 $y1 $x2 $y2 $x1 $y2 \
             -fill [option get $c background {}] -tag LabelBack
         $c raise LabelBack Box
         $c raise Label LabelBack
     }
 
     set baseX [expr {$epadx+$ipadx}]
     set baseY [expr {$epady+$ipady}]
 
     for {set channel 0} {$channel < $channel_number} {incr channel} {
         for {set led 0} {$led < $led_number} {incr led} {
             set x1 [expr {$baseX+$led*($led_spacing+$led_height)}]
             set x2 [expr {$x1+$led_height}]
             set y1 [expr {$baseY+$channel*($channel_spacing+$led_width)}]
             set y2 [expr {$y1+$led_width}]
             $c create polygon $x1 $y1 $x2 $y1 $x2 $y2 $x1 $y2 \
                 -tags $channel:$led
         }
     }
 
     uwp_equaliser_update $widget
 }
 #page
 proc uwp_equaliser_update { widget {levels {}} } {
     upvar        \#0 uwp_data data
     uwp_op_array $widget options
     
     foreach var { led_number channel_number led_red_mark } {
         set $var $options($var) }
 
     for {set channel 0} {$channel < $channel_number} {incr channel} {
         set level [if {[llength $levels]} {lindex $levels $channel} {expr 0}]
 
         for {set led 0} {$led < $led_number} {incr led} {
             if { int(double($led_number)*$level) > $led } {
                 set color on
             } else {
                 set color off
             }
             if { double($led)/double($led_number) < $led_red_mark } {
                 set color led_green_${color}_color
             } else {
                 set color led_red_${color}_color
             }
             $widget.canvas itemconfigure $channel:$led -fill $options($color)
         }
     }
 }
 #page
 ## ------------------------------------------------------------
 ## Let's go.
 ## ------------------------------------------------------------
 
 main
 
 ### end of file
 # Local Variables:
 # mode: tcl
 # End: