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