Playing with bar charts

# bar3d.tcl --

 # 
 # Part of: Useless Widgets Package
 # Contents: shows how to move a bar chart
 # Date: Fri Nov 19, 2004
 # 
 # Abstract
 # 
 #        This script is just a proof.
 # 
 # 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
 ## ------------------------------------------------------------
 ## Global variables.
 ## ------------------------------------------------------------

 # theta -> counterclockwise rotation of the frame center,
 #           origin is the horizontal axis left->right
 # x        -> horizontal coordinate of the frame center
 # y        -> vertical of the frame center
 #
 # (0,0)     --> TK x coordinate
 #        -------------------------------    -
 #  TK   |               ^ /             |   : y parameter
 #  y    |               |/ \theta param |   :
 # coord |          -----+----->         |   -
 #     | |               |               |
 #     v |               |               |
 #        -------------------------------
 #
 #       |...............| x parameter
 #
 set canvas_coord_names        {theta x y}
 set canvas_parameters        {0 350 350}
 set canvas_matrix        {1 0 0 0  0 1 0 0  0 0 1 0  0 0 0 1}

 # theta        -> rotation around the world's Z axis
 # psi        -> rotation around the world's X axis
 # phi        -> rotation around the world's Y axis
 set world_coord_names        { psi phi }
 set world_parameters        { -32.0 -16.0 }
 set world_frame                {}
 set world_matrix        {1 0 0 0  0 1 0 0  0 0 1 0  0 0 0 1}

 set pi                        3.14159265359
 set pi_over_180                [expr {$pi/180.0}]
 set 180_over_pi                [expr {180.0/$pi}]

 # World scale widgets variables.
 array set WorldParametersForScaleWidgets {}

 # Bar values.
 proc random {} { expr {int(rand()*200)+30} }
 set bar_tags { First_Bar Second_Bar Third_Bar Fourth_Bar Fifth_Bar }
 foreach tag $bar_tags {
     set values {}
     for {set i 0} {$i < 5} {incr i} {
         lappend values [random]
     }
     lappend default_bars $tag $values
 }
 set bars $default_bars

 # Widget bar related variables.
 set SelectedBarButtonVariable {}
 array set BarDataForScaleWidgets {}

 #page
 ## ------------------------------------------------------------
 ## TK options.
 ## ------------------------------------------------------------

 option add *borderWidth 1
 option add *Labelframe.borderWidth 2

 foreach { option value } {
     background \#f8f8f8 width 700 height 600 relief sunken borderwidth 2
 } {
     option add *c.$option $value
 }

 option add *frame.lab_theta.text        "rot(Z)"
 option add *frame.lab_psi.text                "rot(X)"
 option add *frame.lab_phi.text                "rot(Y)"
 option add *frame.lab_x.text                "X"
 option add *frame.lab_y.text                "Y"
 option add *frame.lab_z.text                "Z"

 option add *lab_theta.text                "theta"
 option add *lab_psi.text                "psi"
 option add *lab_phi.text                "phi"

 option add *world.phi.to                -90.0
 option add *world.phi.from                0.0
 option add *world.psi.to                -90.0
 option add *world.psi.from                0.0

 option add *Bar.Scale.height                10
 option add *bars*to                        30
 option add *bars*from                        280

 #page
 ## ------------------------------------------------------------
 ## Widgets.
 ## ------------------------------------------------------------

 proc widget_build {} {
     wm geometry . +20+20
     wm title . "Playing with bar charts"
     bind . <Return> {set exit_trigger 1}
     bind . <Escape> {set exit_trigger 1}

     set master [frame .scales]
     set command_buttons                [widget_build_command_buttons $master]
     set world_frame                [widget_build_world_scales $master]
     set bar_stuff_frame                [widget_build_bar_stuff $master]

     grid [canvas .c] $master

     grid $command_buttons        -sticky news
     grid $world_frame                -sticky news
     grid $bar_stuff_frame        -sticky news
     grid $world_frame                -sticky news
     grid columnconfigure . 0 -weight 1
     grid rowconfigure         . 0 -weight 1
     focus $master.exit
 }
 proc widget_build_command_buttons { master } {
     set frame [frame $master.command_buttons]
     button $master.exit -text Exit -command {set exit_trigger 1}
     grid $master.exit
     return $frame
 }
 proc widget_build_world_scales { master } {
     global        WorldParametersForScaleWidgets world_coord_names

     set frame [labelframe $master.world -text "World Frame"]
     set column_index 0
     foreach coord $world_coord_names {
         set labw $frame.lab_$coord
         set scaw $frame.$coord
         label $labw
         scale $scaw -command "update_world_matrix $coord"
         $scaw set $WorldParametersForScaleWidgets($coord)
         $scaw configure -variable WorldParametersForScaleWidgets($coord)
         grid $labw -column $column_index -row 0 -sticky news
         grid $scaw -column $column_index -row 1 -sticky news
         incr column_index
     }
     return $frame
 }
 proc widget_build_bar_stuff { master } {

     set b [frame $master.bars]
     set radio                [widget_build_bar_selection_buttons $b]
     set bar_frames        [widget_build_bar_frame $b]

     grid $radio -sticky news
     foreach w $bar_frames { grid $w -row 1 -column 0 -sticky news }    
     return $b
 }
 proc widget_build_bar_selection_buttons { master } {
     global        bar_tags SelectedBarButtonVariable

     set SelectedBarButtonVariable [lindex $bar_tags 0]
     set frame [labelframe $master.radio -text "Select Bar"]
     foreach tag $bar_tags {
         set w $frame.[string tolower $tag]
         radiobutton $w -text $tag \
             -variable SelectedBarButtonVariable -value $tag \
             -command "raise $master.[string tolower $tag]"
         grid $w -sticky w
     }    
     return $frame
 }
 proc widget_make_bar_scale_variable_name { tag bar_index } {
     global         BarDataForScaleWidgets
     return BarDataForScaleWidgets($tag:$bar_index)
 }
 proc widget_build_bar_frame { master } {
     global         bar_tags

     set bar_frames {}
     foreach tag $bar_tags {
         set f $master.[string tolower $tag]
         lappend bar_frames [labelframe $f -text $tag -class Bar]
         set scale_widget_list {}
         foreach bar_index { 1 2 3 4 5 } {
             set widget $f.$bar_index
             set scale_var_name \
                 [widget_make_bar_scale_variable_name $tag $bar_index]

             lappend scale_widget_list [scale $widget]
             $widget set [uplevel \#0 set $scale_var_name]
             $widget configure \
                 -variable $scale_var_name \
                 -command [list update_bar_value $tag $bar_index]
         }
         eval { grid } $scale_widget_list { -sticky news }
     }
     raise [lindex $bar_frames 0]
     return $bar_frames
 }
 proc widget_canvas_configure_tags {} {
     # Axis settings are overridden by frame settings.
     foreach {tag color} {xaxis red yaxis blue zaxis green} {
         .c itemconfigure $tag -fill $color
     }
     .c itemconfigure World_Frame -dash ,
     .c itemconfigure Canvas_Frame -fill black
     .c itemconfigure Bar -outline black
     foreach {tag color} {
         First_Bar                red
         Second_Bar                green
         Third_Bar                blue
         Fourth_Bar                yellow
         Fifth_Bar                gray
     } {
         .c itemconfigure $tag -fill $color
     }
 }
 #page
 proc widget_initialise_world_scales { parameters } {
     global        world_coord_names WorldParametersForScaleWidgets

     foreach name $world_coord_names value $parameters {
         set WorldParametersForScaleWidgets($name) $value
     }
 }
 proc widget_initialise_bar_scales { bars } {
     foreach {tag values} $bars {
         set bar_index 0
         foreach v $values {
             set varName [widget_make_bar_scale_variable_name $tag [incr bar_index]]
             upvar        \#0 $varName var
             set var $v
         }
     }
 }
 #page
 proc math_deg2rad { angle } {
     global        pi_over_180
     expr {double($angle)*$pi_over_180}
 }
 proc math_rad2deg { angle } {
     global        180_over_pi
     expr {double($angle)*$180_over_pi}
 }
 proc math_sin_cos { angle nickname } {
     upvar        cos_$nickname cos_t sin_$nickname sin_t
     set cos_t [expr {cos(double($angle))}]
     set sin_t [expr {sin(double($angle))}]
 }
 proc math_matrix_mul { a b } {
     foreach {
         a11 a12 a13 a14  a21 a22 a23 a24  a31 a32 a33 a34  a41 a42 a43 a44
     } $a {}
     foreach {
         b11 b12 b13 b14  b21 b22 b23 b24  b31 b32 b33 b34  b41 b42 b43 b44
     } $b {}

     set expr {double([set c$i$j])+double([set a$i$k])*double([set b$k$j])}

     for {set i 1} {$i < 5} {incr i} {
         for {set j 1} {$j < 5} {incr j} {
             set c$i$j 0.0
             for {set k 1} {$k < 5} {incr k} { set c$i$j [expr $expr] }
         }
     }

     list \
         $c11 $c12 $c13 $c14  $c21 $c22 $c23 $c24 \
         $c31 $c32 $c33 $c34  $c41 $c42 $c43 $c44
 }
 proc math_eval_list_of_expressions { expr_list args } {
     set matrix {}
     foreach expr $expr_list { lappend matrix [uplevel expr $expr] }
     eval { lappend matrix } $args
 }
 #page
 proc math_fundamental_rotation_around_z { theta } {
     math_sin_cos $theta t
     math_eval_list_of_expressions {
         {$cos_t} {-$sin_t} 0 0
         {$sin_t} {$cos_t} 0 0
     }  0 0 1 0  0 0 0 1
 }
 proc math_fundamental_rotation_around_x { psi } {
     math_sin_cos $psi p
     math_eval_list_of_expressions {
         1 0 0 0
         0 {$cos_p} {-$sin_p} 0
         0 {$sin_p} {$cos_p} 0
     }  0 0 0 1
 }
 proc math_fundamental_rotation_around_y { phi } {
     math_sin_cos $phi f
     math_eval_list_of_expressions {
         {$cos_f} 0 {$sin_f} 0
         0 1 0 0
         {-$sin_f} 0 {$cos_f} 0
     }  0 0 0 1
 }
 proc math_fundamental_translation { x y z } {
     list 1 0 0 $x  0 1 0 $y  0 0 1 $z  0 0 0 1
 }
 proc transform_names_to_transform { transform_names } {
     foreach T $transform_names { eval {lappend transform} [uplevel \#0 set $T] }
     return $transform
 }
 #page
 # The "transform_list" argument is a list of the form:
 #
 # {
 #   { premultiplication_boolean { a11 a12 a13 ... a44 }
 #   { premultiplication_boolean { b11 b12 b13 ... b44 }
 #   { premultiplication_boolean { c11 c12 c13 ... c44 }
 #   ...
 # }
 #
 # matrices are applied in the same order in which the appear in the
 # list.
 proc math_transformation { transform_list coords } {
     foreach transform $transform_list {
         foreach {premultiplication matrix} $transform {
             foreach {
                 a11 a12 a13 a14  a21 a22 a23 a24  a31 a32 a33 a34  a41 a42 a43 a44
             } $matrix {}
             set result {}
             foreach {x y z other} $coords {
                 if { $premultiplication } {
                     lappend result \
                         [expr {double($x)*double($a11)+double($y)*double($a12)+
                                double($z)*double($a13)+double($other)*double($a14)}] \
                         [expr {double($x)*double($a21)+double($y)*double($a22)+
                                double($z)*double($a23)+double($other)*double($a24)}] \
                         [expr {double($x)*double($a31)+double($y)*double($a32)+
                                double($z)*double($a33)+double($other)*double($a34)}] \
                         [expr {double($x)*double($a41)+double($y)*double($a42)+
                                double($z)*double($a43)+double($other)*double($a44)}]
                 } else {
                     lappend result \
                         [expr {double($x)*double($a11)+double($y)*double($a21)+
                                double($z)*double($a31)+double($other)*double($a41)}] \
                         [expr {double($x)*double($a12)+double($y)*double($a22)+
                                double($z)*double($a32)+double($other)*double($a42)}] \
                         [expr {double($x)*double($a13)+double($y)*double($a23)+
                                double($z)*double($a33)+double($other)*double($a43)}] \
                         [expr {double($x)*double($a14)+double($y)*double($a24)+
                                double($z)*double($a34)+double($other)*double($a44)}]
                 }
             }
             set coords $result
         }
     }
     set result {}
     foreach { x y z o } $coords { lappend result $x $y }
     return $result
 }
 #page
 proc canvas_parameters_to_transformation_matrix { parameters } {
     global        canvas_coord_names
     foreach $canvas_coord_names $parameters {}
     math_sin_cos $theta t
     list [list yes [math_eval_list_of_expressions {
         {$cos_t} {-$sin_t} 0 {$x}
         {-$sin_t} {-$cos_t} 0 {$y}
     }  0 0 1 0  0 0 0 1]]
 }
 proc world_parameters_to_transformation_matrix { parameters } {
     global        world_coord_names
     foreach $world_coord_names $parameters {}
     foreach { axis angleName mode } { y phi yes x psi no } {
         lappend result \
             [list $mode [math_fundamental_rotation_around_$axis [set $angleName]]]
     }
     return $result
 }
 #page
 proc update_world_matrix { name value } {
     global        world_coord_names
     upvar        \#0 world_parameters parameters world_matrix matrix

     set index [lsearch $world_coord_names $name]
     lset parameters $index [math_deg2rad $value]
     set matrix [world_parameters_to_transformation_matrix $parameters]
     after 0 update_drawing
 }
 proc update_bar_value { tag bar value } {
     global        bars

     set idx [lsearch $bars $tag]
     lset bars [incr idx] [incr bar -1] $value
     after 0 update_drawing
 }
 #page
 ## ------------------------------------------------------------
 ## Draw frames.
 ## ------------------------------------------------------------

 interp alias {} draw_canvas_frame {} draw_frame Canvas_Frame \
     {canvas_matrix} \
     { -100 0 0 1  100 0 0 1 } \
     { 0 -100 0 1  0 100 0 1 } \
     { 0 0 0 1     0 0 0 1 }
 interp alias {} draw_world_frame {} draw_frame World_Frame \
     {world_matrix canvas_matrix} \
     { 0 0 0 1   100 0 0 1 } \
     { 0 0 0 1   0 100 0 1 } \
     { 0 0 0 1   0 0 100 1 }
 proc draw_frame { tag transform_names xaxis yaxis zaxis } {
     set transform [transform_names_to_transform $transform_names]

     .c delete $tag
     foreach varname { xaxis yaxis zaxis } {
         set id [.c create line [math_transformation $transform [set $varname]]]
         .c addtag $tag withtag $id
         .c addtag Frame withtag $id
         .c addtag $varname withtag $id
     }
 }
 proc update_drawing {} {
 #    draw_world_frame
     draw_plane_xy
     draw_plane_yz
     draw_plane_zx
     draw_bars
     widget_canvas_configure_tags
 }
 #page
 proc list_set { lst args } {
     foreach {index value} $args { lset lst $index $value }
     return $lst
 }
 interp alias {} draw_plane_xy {} draw_plane_compute { 0 4 5   1 5 4 } XY_plane
 interp alias {} draw_plane_yz {} draw_plane_compute { 1 5 6   2 6 5 } YZ_plane
 interp alias {} draw_plane_zx {} draw_plane_compute { 2 6 0   4 0 6 } ZX_plane
 proc draw_plane_compute { indices tag } {
     set delta 30.0
     set num 11
     set max [expr {$delta*double($num-1)}]
     set coords { 0 0 0 1  0 0 0 1}
     foreach { a b c } $indices {
         for {set x 0.0} {$x <= $max} {set x [expr {$x+$delta}]} {
             lappend axis [list_set $coords $a $x $b $x $c $max]
         }
     }
     draw_plane $tag {world_matrix canvas_matrix} $axis
 }
 proc draw_plane { tag transform_names axis_list } {
     set transform [transform_names_to_transform $transform_names]

     .c delete $tag
     foreach axis $axis_list {
         set id [.c create line [math_transformation $transform $axis]]
         .c addtag $tag withtag $id
         .c addtag Plane withtag $id
     }
 }
 #page
 proc draw_bars {} {
     global        bars
     set base        30
     set delta        30
     set y 0

     foreach { tag values } $bars {
         set tags {}
         set xlst {}
         for {set i 0} {$i < [llength $values]} {incr i} {
             lappend xlst [expr {(double($delta)+double($base))*double($i)}]
             lappend tags [format "%s_%s" $tag $i]
         }
         foreach val $values x $xlst bartag $tags {
             draw_bar $tag $bartag $x $y $base $val
         }
         set y [expr {double($y)+double($delta)+double($base)}]
     }
 }
 proc draw_bar { tag bartag x y base height } {
     set transform [transform_names_to_transform {world_matrix canvas_matrix}]

     .c delete $bartag
     set x1 [expr {$x+$base}]
     set y1 [expr {$y+$base}]
     #   (0,0)
     #     -----------> Xworld
     #    | ---->Xbar
     #    ||
     #    ||
     #    |vYbar
     #    v
     #   Zworld
     foreach coords [list \
                         [list \
                              $x  $height $y  1  $x1 $height $y  1 \
                              $x1 $height $y1 1  $x  $height $y1 1] \
                         [list \
                              $x1 0.0 $y 1       $x1 0.0 $y1  1 \
                              $x1 $height $y1 1  $x1 $height $y 1] \
                         [list \
                              $x  0.0 $y1 1  $x1 0.0 $y1  1 \
                              $x1 $height $y1 1  $x  $height $y1 1]] {
         set id [.c create polygon \
                     [math_transformation $transform $coords]]
         .c addtag Bar withtag $id
         .c addtag $tag withtag $id
         .c addtag $bartag withtag $id
     }
 }
 #page
 ## ------------------------------------------------------------
 ## Do stuff.
 ## ------------------------------------------------------------

 proc main {} {
     global        exit_trigger \
         canvas_parameters world_parameters canvas_matrix default_bars

     widget_initialise_bar_scales $default_bars
     widget_initialise_world_scales $world_parameters

     widget_build
     set canvas_matrix \
         [canvas_parameters_to_transformation_matrix $canvas_parameters]
 #    draw_canvas_frame

     vwait exit_trigger
     exit
 }
 #page
 ## ------------------------------------------------------------
 ## Let's go.
 ## ------------------------------------------------------------

 main

 ### end of file
 # Local Variables:
 # mode: tcl
 # End: