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