source: trunk/gui/apps/nanovis-test @ 855

#!/bin/sh
# ----------------------------------------------------------------------
#  TEST PROGRAM for nanoVIS
#
#  This program is a test harness for the nanoVIS visualization
#  engine.  It allows you to monitor the commands being sent back
#  and forth between a standard Rappture application and the nanoVIS
#  server.  You can also send your own commands to the server, to
#  debug new features.
#
# ======================================================================
#  AUTHOR:  Michael McLennan, Purdue University
#  Copyright (c) 2004-2007  Purdue Research Foundation
#
#  See the file "license.terms" for information on usage and
#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# ======================================================================
#\
exec wish "$0" $*
# ----------------------------------------------------------------------
# wish executes everything from here on...

lappend auto_path /usr/local/rappture/lib /usr/local/rappture/lib/vtk /usr/local/rappture/lib/vtk/tcl

package require Itcl
package require Rappture
package require RapptureGUI

option add *comm.font -*-courier-medium-r-normal-*-*-120-*
option add *Menu.tearOff off

option add *Tooltip.background white
option add *Editor.background white
option add *Gauge.textBackground white
option add *TemperatureGauge.textBackground white
option add *Switch.textBackground white
option add *Progress.barColor #ffffcc
option add *Balloon.titleBackground #6666cc
option add *Balloon.titleForeground white
option add *Balloon*Label.font -*-helvetica-medium-r-normal-*-*-120-*
option add *Balloon*Radiobutton.font -*-helvetica-medium-r-normal-*-*-120-*
option add *Balloon*Checkbutton.font -*-helvetica-medium-r-normal-*-*-120-*
option add *ResultSet.controlbarBackground #6666cc
option add *ResultSet.controlbarForeground white
option add *ResultSet.activeControlBackground #ccccff
option add *ResultSet.activeControlForeground black
option add *Radiodial.length 3i
option add *BugReport*banner*foreground white
option add *BugReport*banner*background #a9a9a9
option add *BugReport*banner*highlightBackground #a9a9a9
option add *BugReport*banner*font -*-helvetica-bold-r-normal-*-*-180-*

# fix the "grab" command to support a stack of grab windows
#Rappture::grab::init

# ----------------------------------------------------------------------
# LOAD RESOURCE SETTINGS
#
# Try to load the $SESSIONDIR/resources file, which contains
# middleware settings, such as the application name and the
# filexfer settings.
# ----------------------------------------------------------------------
Rappture::resources::load

# ----------------------------------------------------------------------
# Fake data object for sending DX data...
# ----------------------------------------------------------------------
itcl::class DxData {
    constructor {args} {
        set _data [Rappture::encoding::encode -as zb64 [lindex $args 0]]
    }

    public method components {args} {
        if {[llength $args] == 0} {
            return "one"
        }
        return ""
    }
    public method values {args} {
        return $_data
    }
    public method hints {args} {
        return ""
    }

    private variable _data ""
}

# ----------------------------------------------------------------------
# USAGE: send_file
#
# Prompts the user for a text file, and then sends the text within
# that file along to the rendering widget.
# ----------------------------------------------------------------------
proc send_file {} {
    global widgets

    set file [tk_getOpenFile -title "Open Command File"]
    if {"" != $file && [catch {
            set fid [open $file r]
            fconfigure $fid -translation binary
            set info [read $fid]
            close $fid
          }] == 0} {
        set obj [DxData #auto $info]
        $widgets(nanovis) add $obj
    }
}

# ----------------------------------------------------------------------
# USAGE: send_command
#
# Invoked automatically whenever the user enters a command and
# presses <Return>.  Sends the command along to the rendering
# widget.
# ----------------------------------------------------------------------
proc send_command {} {
    global widgets
    global last_command

    set cmd [$widgets(command) get]
    
    # Karl
    if {[string length $cmd] > 0} {
        set last_command $cmd
    } else {
        set cmd $last_command
    }

    
    namespace eval Rappture::NanovisViewer [list $widgets(nanovis) _send_text $cmd]
    $widgets(command) delete 0 end
}

# ----------------------------------------------------------------------
# USAGE: reset
#
# Used internally to reset the connection to the rendering server.
# Discards all data and resets the widget connection to the server.
# ----------------------------------------------------------------------
proc reset {} {
    global widgets
    $widgets(nanovis) delete
    $widgets(nanovis) disconnect
    $widgets(comm) configure -state normal
    $widgets(comm) delete 1.0 end
    $widgets(comm) configure -state disabled
}

# ----------------------------------------------------------------------
# USAGE: show_comm <channel> <data>
#
# Invoked automatically whenever there is communication between
# the rendering widget and the server.  Eavesdrops on the communication
# and posts the commands in a text viewer.
# ----------------------------------------------------------------------
proc show_comm {channel {data ""}} {
    global widgets

    $widgets(comm) configure -state normal
    switch -- $channel {
        closed {
            $widgets(comm) insert end "--CLOSED--\n" error
        }
        <<line {
            $widgets(comm) insert end $data incoming "\n" incoming
            images_refresh
        }
        >>line {
            $widgets(comm) insert end $data outgoing "\n" outgoing
        }
        error {
            $widgets(comm) insert end $data error "\n" error
        }
        default {
            $widgets(comm) insert end "$data\n"
        }
    }
    $widgets(comm) configure -state disabled
    $widgets(comm) see end
}

# ----------------------------------------------------------------------
# TOPLEVEL FOR IMAGES
# ----------------------------------------------------------------------
# USAGE: images_save
#
# Invoked when the user presses the "Save As..." button on the
# images panel.  Saves the current image in a file, which can be
# examined by some external program.
# ----------------------------------------------------------------------
proc images_save {} {
    global widgets images

    set imh [$widgets(nanovis) get -image $images(which)]

    set file [tk_getSaveFile -title "Save Image File" \
        -defaultextension .jpg -filetypes {{{JPEG files} .jpg} {{All Files} *}}]

    if {"" != $file} {
        set cmds {
            $imh write $file -format jpeg
        }
        if {[catch $cmds err]} {
            tk_messageBox -icon error -message "Oops!  Save failed:\n$err"
        }
    }
}

# ----------------------------------------------------------------------
# USAGE: images_refresh
#
# Invoked automatically whenever there is a change in the 3dview/legend
# controls on the images panel.  Updates the image being shown based
# on the current selection.
# ----------------------------------------------------------------------
proc images_refresh {} {
    global widgets images
    set c $widgets(viewer)

    set w [winfo width $c]
    set h [winfo height $c]

    set imh [$widgets(nanovis) get -image $images(which)]
    set iw [image width $imh]
    set ih [image height $imh]

    $c coords image [expr {$w/2}] [expr {$h/2}]
    $c itemconfigure image -image $imh
    $c coords outline [expr {$w/2-$iw/2}] [expr {$h/2-$ih/2}] \
        [expr {$w/2+$iw/2}] [expr {$h/2+$ih/2}]
}

toplevel .images
wm title .images "nanoVIS: Images"
wm withdraw .images
wm protocol .images WM_DELETE_WINDOW {wm withdraw .images}

frame .images.cntls
pack .images.cntls -side bottom -fill x
button .images.cntls.save -text "Save As..." -command images_save
pack .images.cntls.save -side right -padx 4
radiobutton .images.cntls.3dview -text "3D View" -variable images(which) \
    -value "3dview" -command images_refresh
pack .images.cntls.3dview -side top -anchor w
radiobutton .images.cntls.legend -text "Legend" -variable images(which) \
    -value "legend" -command images_refresh
pack .images.cntls.legend -side top -anchor w
set images(which) "3dview"

canvas .images.viewer -background black -width 500 -height 500
pack .images.viewer -expand yes -fill both
bind .images.viewer <Configure> images_refresh
set widgets(viewer) .images.viewer

$widgets(viewer) create image 0 0 -anchor c \
    -image [image create photo] -tags image
$widgets(viewer) create rectangle 0 0 1 1 -width 2 -outline red -fill "" \
    -tags outline


# ----------------------------------------------------------------------
# MAIN WINDOW
# ----------------------------------------------------------------------
menu .mbar
menu .mbar.file
.mbar.file add command -label "Send file..." -underline 0 -command send_file
.mbar.file add command -label "Reset" -underline 0 -command reset
.mbar.file add separator
.mbar.file add command -label "Exit" -underline 1 -command exit
.mbar add cascade -label "File" -underline 0 -menu .mbar.file

menu .mbar.view
.mbar.view add command -label "Images..." -underline 0 \
    -command {wm deiconify .images}
.mbar add cascade -label "View" -underline 0 -menu .mbar.view

. configure -menu .mbar

Rappture::Panes .main -sashwidth 4 -sashrelief raised -sashpadding 4 \
    -width 6i -height 4i
pack .main -expand yes -fill both

set f [.main pane 0]
Rappture::Field3DResult $f.viewer
pack $f.viewer -expand yes -fill both
set widgets(nanovis) [$f.viewer component renderer]

puts stderr [winfo class $widgets(nanovis)]

$f.viewer component renderer configure \
    -sendcommand show_comm \
    -receivecommand show_comm

set f [.main insert end -fraction 0.5]
frame $f.send
pack $f.send -side bottom -fill x
label $f.send.l -text "Send:"
pack $f.send.l -side left
set widgets(command) [entry $f.send.e]
pack $f.send.e -side left -expand yes -fill x
bind $f.send.e <KeyPress-Return> send_command

scrollbar $f.sb -orient vertical -command "$f.comm yview"
pack $f.sb -side right -fill y
text $f.comm -wrap char -yscrollcommand "$f.sb set"
pack $f.comm -expand yes -fill both
set widgets(comm) $f.comm

$widgets(comm) tag configure error -foreground red \
    -font -*-courier-medium-o-normal-*-*-120-*
$widgets(comm) tag configure incoming -foreground blue