# 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: