# planes3d.tcl --
# 
# Part of: Useless Widgets Package
# Contents: shows how to move a orthogonal planes
# Date: Tue Nov 16, 2004
# 
# Abstract
# 
#        The purpose of this script is to test the perspective
#        projection.
#
#        This script 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]
     grid [button [set b $f.exit] -command main_exit]
     focus $b
     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 moving -type homogeneous \
         -dynamic [uwp_hoco_transform_get_parameter_names homogeneous]
 
     uwp_hoco_instance_declare perspective -type perspective \
         -dynamic [uwp_hoco_transform_get_parameter_names perspective]
     
     option add *perspective.Scale.from                0.1
     option add *perspective.Scale.to                100
     option add *perspective.Scale.resolution        0.1
     widget_build_all
     
     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}}
 
     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_planes
     widget_canvas_configure_tags
}
#page
## ------------------------------------------------------------
## Work space 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 perspective] \
         [widget_build_scale_frame $right_frame world] \
         [widget_build_scale_frame $right_frame moving]
}
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} {Canvas_Frame -fill "\#d0d0d0"}
     } { eval widget_canvas_tag_config $arglist }
}
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_setup_options {} {
     option add *toptitle "Moving planes"
     widget_option_scale_rotation \
         moving.theta moving.phi moving.psi \
         world.theta world.phi world.psi
     widget_option_scale_translation moving.x moving.y moving.z
     widget_option_scale_from_to perspective.d 100 10000
     foreach {name text} { World "World Frame" Moving "Moving"
         Perspective "Perspective" } {
         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_planes {} uwp_wireframe_draw_workspace \
     Planes { moving world perspective canvas }
 
#page
## ------------------------------------------------------------
## Let's go.
## ------------------------------------------------------------
 
main
 
### end of file
# Local Variables:
# mode: tcl
# End: