# denavit-hartenberg.tcl --
#
# Part of: Useless Widgets Package
# Contents: shows how to move a frame along Denavit-Hartenberg coords
# Date: Tue Nov 2, 2004
#
# Abstract
#
# This script shows the meaning of Denavit-Hartenberg coordinates
# transforms. It makes use of the "hoco.tcl" package, which
# you can find on the TCL'ers Wiki also. You have to place the
# "hoco.tcl" file in the same directory of this file.
#
# 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
set pathname [file dirname $argv]
source [file join $pathname hoco.tcl]
#page
## ------------------------------------------------------------
## TK options.
## ------------------------------------------------------------
option add *topgeometry +20+20
option add *borderWidth 1
option add *Labelframe.borderWidth 2
option add *command_buttons.exit.text "Exit"
foreach { option value } {
background \#f8f8f8 width 600 height 600 relief sunken borderwidth 2
x_axis_color red y_axis_color blue z_axis_color green
} { option add *Drawing.Canvas.$option $value }
proc widget_option_scale_from_to { master from to } {
option add *${master}.to $to
option add *${master}.from $from
}
proc widget_option_scale_rotation { args } {
foreach w $args { widget_option_scale_from_to $w 180.0 -180.0 }
}
proc widget_option_scale_translation { args } {
foreach w $args { widget_option_scale_from_to $w 300.0 -300.0 }
}
#page
## ------------------------------------------------------------
## Widget procedures.
## ------------------------------------------------------------
proc widget_grid_frames { args } { foreach w $args { grid $w -sticky news } }
proc widget_configure_toplevel {} {
wm geometry . [option get . topgeometry {}]
wm title . [option get . toptitle {}]
foreach event { <Return> <Escape> } { bind . $event main_exit }
}
proc widget_build_canvas { master } {
global widget_canvas
set f [frame $master.drawing -class Drawing]
grid [set widget_canvas [canvas $f.canvas]] -sticky news
return $f
}
proc widget_build_command_buttons { master } {
set f [frame $master.command_buttons]
focus [grid [button $f.exit -command main_exit]]
return $f
}
proc widget_build_scale_frame { master coord_spec } {
set f [labelframe $master.$coord_spec -class [string totitle $coord_spec]]
set column_index 0
foreach name [uwp_hoco_instance_get_dynamic_parameter_names $coord_spec] {
label [set label_widget $f.lab_$name] -text [string totitle $name]
scale [set scale_widget $f.$name]
$scale_widget set \
[uwp_hoco_instance_get_parameter_value $coord_spec $name]
$scale_widget configure -command \
[list widget_update_parameter_from_scale $coord_spec $name]
grid $label_widget -column $column_index -row 0 -sticky news
grid $scale_widget -column $column_index -row 1 -sticky news
incr column_index
}
return $f
}
proc widget_update_parameter_from_scale { coord_spec param_name param_value } {
uwp_hoco_instance_update_parameter $coord_spec $param_name $param_value
after 0 widget_put_drawing_on_canvas
}
proc widget_canvas_draw { command coords {main_tag {}} {tags {}} } {
global widget_canvas
if { [string length $main_tag] } { $widget_canvas delete $main_tag }
$widget_canvas create $command $coords -tags [lappend tags $main_tag]
}
proc widget_canvas_query_option { option } {
global widget_canvas
option get $widget_canvas $option {}
}
proc widget_canvas_tag_config { tag args } {
global widget_canvas
eval { $widget_canvas itemconfigure $tag } $args
}
#page
## ------------------------------------------------------------
## Main procedures.
## ------------------------------------------------------------
proc main {} {
global exit_trigger
uwp_hoco_instance_declare dh -type dh \
-dynamic [uwp_hoco_transform_get_parameter_names dh]
widget_build_all
interp alias {} draw_canvas_frame {} \
uwp_wireframe_draw_reference_frame Canvas_Frame \
{canvas} {yes {200 0 0 1 0 200 0 1 0 0 0 1 0 0 0 1}}
interp alias {} draw_world_frame {} \
uwp_wireframe_draw_reference_frame World_Frame \
{ world canvas } {yes {50 0 0 0 0 50 0 0 0 0 50 0 0 0 0 1}}
interp alias {} draw_dh_frame {} \
uwp_wireframe_draw_reference_frame Dh_Frame \
{ dh world canvas } {yes {100 0 0 1 0 100 0 1 0 0 100 1 0 0 0 1}}
draw_canvas_frame
widget_put_drawing_on_canvas
interp alias {} main_exit {} uplevel \#0 {set exit_trigger 1}
vwait exit_trigger
exit
}
proc widget_put_drawing_on_canvas {} {
draw_world_frame
draw_dh_frame
draw_prism
widget_canvas_configure_tags
}
#page
## ------------------------------------------------------------
## Denavit-Hartenberg proof widgets.
## ------------------------------------------------------------
proc widget_build_all {} {
widget_setup_options
widget_configure_toplevel
grid columnconfigure . 0 -weight 1
grid rowconfigure . 0 -weight 1
grid [widget_build_canvas .] [frame [set right_frame .right]] -sticky news
widget_grid_frames \
[widget_build_command_buttons $right_frame] \
[widget_build_color_explanation $right_frame] \
[widget_build_scale_frame $right_frame world] \
[widget_build_scale_frame $right_frame dh]
}
proc widget_build_color_explanation { master } {
set f [labelframe $master.explain_colors -class Explain_colors]
set column_index 0
foreach axis { x y z } {
grid [label $f.${axis}axis] -row 1 -column [incr column_index]
}
return $f
}
proc widget_canvas_configure_tags {} {
foreach axis {x y z} {
widget_canvas_tag_config reference_frame_${axis}axis \
-fill [widget_canvas_query_option ${axis}_axis_color] }
foreach arglist {
{reference_frame -arrow last} {World_Frame -dash ,}
{Canvas_Frame -fill "\#d0d0d0"}
} { eval widget_canvas_tag_config $arglist }
}
proc widget_setup_options {} {
option add *toptitle "Playing with Denavit and Hartenberg"
widget_option_scale_rotation \
dh.theta dh.alpha world.theta world.phi world.psi
widget_option_scale_translation dh.d dh.a
foreach {name text} {
World "World Frame" Dh "Denavit-Hartenberg" Explain_colors "Axis colors"
} {
option add *$name.text $text
option add *$name.borderWidth 2
}
foreach { ax color } { x red y blue z green } {
set axis [format "%saxis" $ax]
option add *Explain_colors.$axis.text \
[format "%saxis" [string toupper $ax]]
option add *Explain_colors.$axis.foreground $color
}
}
#page
## ------------------------------------------------------------
## Graphical elements.
## ------------------------------------------------------------
interp alias {} draw_prism {} uwp_wireframe_draw_prism \
Prism {dh world canvas} {yes {50 0 0 0 0 50 0 0 0 0 50 0 0 0 0 1}}
#page
## ------------------------------------------------------------
## Let's go.
## ------------------------------------------------------------
main
### end of file
# Local Variables:
# mode: tcl
# End:The Denavit-Hartenberg representation is a standard identification in robotics of joints and orthonormal (x, y, z) coordinate systems, one particularly useful for describing the space of all controlled motions.
See also hoco an homogeneous coordinates package.