Updated 2004-11-27 08:40:40

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