# hoco.tcl --
 # 
 # Part of: Useless Widgets Package
 # Contents: homogeneous coordinates procedures
 # Date: Wed Nov 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
 ## ------------------------------------------------------------
 ## Math procedures.
 ## ------------------------------------------------------------
 
 proc uwp_math_deg2rad { angle } {expr {double($angle)*0.0174532925199}}
 proc uwp_math_rad2deg { angle } {expr {double($angle)*57.2957795131}}
 proc uwp_math_sin_cos { angle nickname } {
     uplevel [list set cos_$nickname [expr {cos(double($angle))}]]
     uplevel [list set sin_$nickname [expr {sin(double($angle))}]]
 }
 proc uwp_math_evallist { expr_list } {
     foreach expr $expr_list { lappend matrix [uplevel [list expr $expr]] }
     return $matrix
 }
 interp alias {} uwp_math_fundamental_rotation_around_z {} \
     uwp_math_fundamental_rotation t \
     {{$cos_t} {-$sin_t} 0 0  {$sin_t} {$cos_t} 0 0 0 0 1 0  0 0 0 1}
 interp alias {} uwp_math_fundamental_rotation_around_x {} \
     uwp_math_fundamental_rotation p \
     {1 0 0 0  0 {$cos_p} {-$sin_p} 0  0 {$sin_p} {$cos_p} 0 0 0 0 1}
 interp alias {} uwp_math_fundamental_rotation_around_y {} \
     uwp_math_fundamental_rotation f \
     {{$cos_f} 0 {$sin_f} 0  0 1 0 0  {-$sin_f} 0 {$cos_f} 0 0 0 0 1}
 proc uwp_math_fundamental_rotation { alias expression angle } {
     uwp_math_sin_cos $angle $alias
     uwp_math_evallist $expression
 }
 proc uwp_math_fundamental_translation {x y z} {list 1 0 0 $x 0 1 0 $y 0 0 1 $z 0 0 0 1}
 # 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 uwp_math_transformation { transform_list coords } {
     set matrix_elms {a11 a12 a13 a14  a21 a22 a23 a24  a31 a32 a33 a34  a41 a42 a43 a44}
     foreach transform $transform_list {
 	foreach {premultiplication matrix} $transform {
 	    foreach $matrix_elms $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 {
 	if { $o != 1.0 } {
 	    set x [expr {$x/$o}]
 	    set y [expr {$y/$o}]
 	}
 	lappend result $x $y
     }
     return $result
 }
 #page
 ## ------------------------------------------------------------
 ## Token management.
 ## ------------------------------------------------------------
 
 set uwp_counter 0
 array set uwp_token_map {}
 proc uwp_token_get { ns key id } { uwp_token_access $ns $id; return $data($key) }
 proc uwp_token_declare { ns id } {
     upvar	\#0 uwp_token_map map uwp_counter counter
     set map($ns:$id) uwp__[incr counter]
 }
 proc uwp_token_forget { ns id } {
     upvar	\#0 uwp_token_map map
     unset -nocomplain $map($ns:$id)
     unset -nocomplain map($ns:$id)
 }
 proc uwp_token_access { ns id } {
     upvar	\#0 uwp_token_map map
     uplevel [list upvar \#0 $map($ns:$id) data]
 }
 proc uwp_token_aliases { prefix namespace } {
     foreach c {declare forget access get} {
 	interp alias {} $prefix$c {} uwp_token_$c $namespace
     }
 }
 #page
 ## ------------------------------------------------------------
 ## Transform variables and declarations.
 ## ------------------------------------------------------------
 
 uwp_token_aliases uwp_hoco_transform_token_ hoco_tran
 
 # Transform type attributes:
 # -names	= the list of parameter names
 # -deg2rad	= a list of boolean declaring if the parameter requires
 #                 conversion from degrees to radians
 # -defaults	= the list of default values for the parameters
 # -transform	= the name of the procedure that converts the parameters
 #		  into the transformation
 proc uwp_hoco_transform_declare { id args } {
     uwp_hoco_transform_token_declare $id
     uwp_hoco_transform_token_access $id
     array set data $args
 }
 interp alias {} uwp_hoco_transform_forget {} uwp_hoco_transform_token_forget
 proc uwp_hoco_transform_compute { id parameters } {
     uwp_hoco_transform_token_access $id
     foreach name $data(-names) deg2rad $data(-deg2rad) value $parameters \
 	{ lappend values [expr {($deg2rad)? [uwp_math_deg2rad $value] : $value}] }
     $data(-transform) $data(-names) $values
 }
 proc uwp_hoco_transform_get_parameter_name_index { id parm_name } {
     uwp_hoco_transform_token_access $id
     lsearch $data(-names) $parm_name
 }
 interp alias {} uwp_hoco_transform_get_parameter_defaults \
     {} uwp_hoco_transform_token_get -defaults
 interp alias {} uwp_hoco_transform_get_parameter_names \
     {} uwp_hoco_transform_token_get -names
 #page
 ## ------------------------------------------------------------
 ## Default transformation matrix procedures.
 ## ------------------------------------------------------------
 
 proc uwp_hoco_canvas_parameters_to_transform { names values } {
     foreach $names $values {}
     uwp_math_sin_cos $theta t
     list [list yes [uwp_math_evallist \
 	{{$cos_t} {-$sin_t} 0 {$x} {-$sin_t} {-$cos_t} 0 {$y} 0 0 1 0 0 0 0 1}]]
 }
 proc uwp_hoco_homogeneous_parameters_to_transform { names values } {
     foreach $names $values {}
     foreach { axis angleName mode } { z theta yes y phi yes x psi no } {
 	lappend result [list $mode \
 	    [uwp_math_fundamental_rotation_around_$axis [set $angleName]]]
     }
     lappend result [list yes [uwp_math_fundamental_translation $x $y $z]]
 }
 proc uwp_hoco_workspace_parameters_to_transform { names values } {
     foreach $names $values {}
     foreach { axis angleName mode } { y phi yes x psi no } {
 	lappend result [list $mode \
 	    [uwp_math_fundamental_rotation_around_$axis [set $angleName]]]
     }
     return $result
 }
 proc uwp_hoco_dh_parameters_to_transform { names values } {
     foreach $names $values {}
     uwp_math_sin_cos $theta t
     uwp_math_sin_cos $alpha a
     list [list yes [uwp_math_evallist {
 	{$cos_t}  {-($cos_a*$sin_t)}  {$sin_a*$sin_t}     {double($a)*$cos_t}
 	{$sin_t}  {$cos_a*$cos_t}     {-($sin_a*$cos_t)}  {double($a)*$sin_t}
 	0         {$sin_a}            {$cos_a}            {double($d)}
 	0 0 0 1}]]
 }
 proc uwp_hoco_perspective_parameters_to_transform { names values } {
     foreach $names $values {}
     list [list yes [uwp_math_evallist {
 	1 0 0 0
 	0 1 0 0
 	0 0 1 0
 	0 0 {-1.0/double($d)} 1
     }]]
 }
 #page
 ## ------------------------------------------------------------
 ## Default transform types.
 ## ------------------------------------------------------------
 
 uwp_hoco_transform_declare canvas \
     -names { theta x y } -deg2rad { yes no no } -defaults { 0.0 300.0 300.0 } \
     -transform uwp_hoco_canvas_parameters_to_transform
 
 uwp_hoco_transform_declare homogeneous \
     -names { theta psi phi x y z } -deg2rad { yes yes yes no no no } \
     -defaults { 0.0 0.0 0.0  0.0 0.0 0.0 } \
     -transform uwp_hoco_homogeneous_parameters_to_transform
 
 uwp_hoco_transform_declare workspace \
     -names { psi phi } -deg2rad { yes yes } -defaults { 0.0 0.0 } \
     -transform uwp_hoco_workspace_parameters_to_transform
 
 uwp_hoco_transform_declare dh \
     -names { d theta a alpha } -deg2rad { no yes no yes } \
     -defaults { 0.0 0.0 0.0 0.0 } \
     -transform uwp_hoco_dh_parameters_to_transform    
 
 uwp_hoco_transform_declare perspective \
     -names { d } -deg2rad { no } \
     -defaults { 1700 } \
     -transform uwp_hoco_perspective_parameters_to_transform    
 
 #page
 ## ------------------------------------------------------------
 ## Transform instances procedures.
 ## ------------------------------------------------------------
 
 uwp_token_aliases uwp_hoco_instance_token_ hoco_inst
 
 # Transform instance attributes:
 # -type		= the name of a transform type
 # -parameters	= a list holding the current values of the parameters
 # -transform	= the transformation
 # -dynamic	= the list of parameters that are modifiable in this
 #		  transform instance, it must be a sub-set of the
 #		  transform type parameters or the empty string
 proc uwp_hoco_instance_declare { id args } {
     uwp_hoco_instance_token_declare $id
     uwp_hoco_instance_token_access $id
     array set data $args
     if { ! [info exists data(-parameters)] } {
 	set data(-parameters) \
 	    [uwp_hoco_transform_get_parameter_defaults $data(-type)]
     }
     uwp_hoco_instance_update_transform $id
 }
 interp alias {} uwp_hoco_instance_forget {} uwp_hoco_instance_token_forget
 proc uwp_hoco_instance_update_transform { id } {
     uwp_hoco_instance_token_access $id
     set data(transform) \
 	[uwp_hoco_transform_compute $data(-type) $data(-parameters)]
 }
 proc uwp_hoco_instance_update_parameter { id parm_name parm_value } {
     uwp_hoco_instance_token_access $id
     set idx [uwp_hoco_transform_get_parameter_name_index $data(-type) $parm_name]
     lset data(-parameters) $idx $parm_value
     uwp_hoco_instance_update_transform $id
 }
 proc uwp_hoco_instance_get_transform { transform_names } {
     foreach id $transform_names \
 	{ uwp_hoco_instance_token_access $id; lappend result $data(transform) }
     return [join $result]
 }
 proc uwp_hoco_instance_get_all_parameter_names { id } {
     uwp_hoco_instance_token_access $id
     uwp_hoco_transform_get_parameter_names $data(-type)
 }
 proc uwp_hoco_instance_get_dynamic_parameter_names { id } {
     uwp_hoco_instance_token_access $id
     return $data(-dynamic)
 }
 proc uwp_hoco_instance_get_parameter_value { id parm_name } {
     uwp_hoco_instance_token_access $id
     set idx [uwp_hoco_transform_get_parameter_name_index $data(-type) $parm_name]
     lindex $data(-parameters) $idx
 }
 #page
 ## ------------------------------------------------------------
 ## Default transform instances.
 ## ------------------------------------------------------------
 
 uwp_hoco_instance_declare canvas -type canvas -dynamic {}
 uwp_hoco_instance_declare world  -type homogeneous -dynamic { theta phi psi }
 
 #page
 ## ------------------------------------------------------------
 ## Basic graphical elements.
 ## ------------------------------------------------------------
 
 # Prototype of drawing procedure:
 #
 #	proc widget_canvas_draw { command coords {main_tag {}} {tags {}} }
 #
 # command	= what to draw (line, polygon, ...)
 # coords	= the list of homogeneous coordinates of the points
 # main_tag	= the main tag of the object: the one used to delete it
 # tags		= optional list of tags
 
 proc uwp_wireframe_draw_reference_frame { frame_tag transforms element } {
     set axis_template {{-1 0 0 1  1 0 0 1} {0 -1 0 1  0 1 0 1} {0 0 -1 1  0 0 1 1}}
     foreach coords $axis_template axis_tag { xaxis yaxis zaxis } {
 	widget_canvas_draw line \
 	    [uwp_math_transformation \
 		 [concat [list $element] \
 		      [uwp_hoco_instance_get_transform $transforms]] \
 		 $coords] ${frame_tag}_$axis_tag \
 	    [list $frame_tag reference_frame_$axis_tag reference_frame]
     }
 }
 proc uwp_wireframe_draw_prism { prism_tag transforms element {tags {}} } {
     foreach {face coords} {
 	A {-1 -1 -1 1	1 -1 -1 1	1 1 -1 1	-1 1 -1 1	-1 -1 -1 1}
  	B {-1 -1 1 1	1 -1 1 1	1 1 1 1		-1 1 1 1	-1 -1 1 1}
 	C {-1 -1 -1 1	-1 -1 1 1	-1 1 1 1	-1 1 -1 1	-1 -1 -1 1}
 	D {1 -1 -1 1	1 -1 1 1	1 1 1 1		1 1 -1 1	1 -1 -1 1}
     } {
 	widget_canvas_draw line [uwp_math_transformation \
 	     [concat [list $element] [uwp_hoco_instance_get_transform $transforms]] \
 		$coords] ${prism_tag}_$face $tags
     }
 }
 #page
 proc uwp_wireframe_draw_workspace { item_tag transforms } {
     uwp_wireframe_draw_plane ${item_tag}_XY $transforms { 0 4 5   1 5 4 } \
 	[list workspace_XY_plane $item_tag]
     uwp_wireframe_draw_plane ${item_tag}_YZ $transforms { 1 5 6   2 6 5 } \
 	[list workspace_YZ_plane $item_tag]
     uwp_wireframe_draw_plane ${item_tag}_ZX $transforms { 2 6 0   4 0 6 } \
 	[list workspace_ZX_plane $item_tag]
 }
 proc uwp_wireframe_draw_plane { main_tag transforms indices {tags {}} } {
     set delta 30.0
     set num 11
     set max [expr {$delta*double($num-1)}]
     set coords { 0 0 0 1  0 0 0 1}
     set counter 0
     foreach { a b c } $indices {
 	set vector $coords
 	set plane_tag ${main_tag}_[incr counter]
 	for {set x 0.0} {$x <= $max} {set x [expr {$x+$delta}]} {
 	    lset vector $a $x
 	    lset vector $b $x
 	    lset vector $c $max
 	    widget_canvas_draw line \
 		[uwp_math_transformation \
 		     [uwp_hoco_instance_get_transform $transforms] $vector] \
 		${plane_tag}_$x [concat [list $main_tag] $tags]
 	}
     }
 }
 #page
 proc uwp_wireframe_regular_polygon { number_of_points } {
     set angle [expr {[uwp_math_deg2rad 360.0]/double($number_of_points)}]
     lappend coords 1 0 0 1
     for {set i 1} {$i < $number_of_points} {incr i} {
 	lappend coords \
 	    [expr {cos(double($angle)*double($i))}] \
 	    [expr {sin(double($angle)*double($i))}] 0 1
     }
     lappend coords 1 0 0 1
 }
 proc uwp_wireframe_draw_path { coords transforms element tag {tags {}} } {
     widget_canvas_draw line \
 	[uwp_math_transformation \
 	     [concat [list $element] \
 		  [uwp_hoco_instance_get_transform $transforms]] \
 	     $coords] $tag $tags
 }
 
 ### end of file
 # Local Variables:
 # mode: tcl
 # End:

----
See also: [Playing with planes in 3D] which uses this code.
----
[[
[Category Package] |
[Category GUI]
]]