source: trunk/gui/apps/geoviewer-test @ 4147

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

set installdir [file root $argv0]
set libdir [file join $installdir "lib"]

lappend auto_path $libdir

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

# ----------------------------------------------------------------------
# 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 Earth File as Map"]
    if {"" != $file && [catch {
            set fid [open $file r]
            fconfigure $fid -translation binary -encoding binary
            set info [read $fid]
            close $fid
          }] == 0} {
        set len [string length $info]
        $widgets(command) insert 0 "map load data follows $len\n$info"
        send_command
    }
}

# ----------------------------------------------------------------------
# USAGE: load_script
#
# Prompts the user for a text file, and then sends the text within
# that file along to the rendering widget.
# ----------------------------------------------------------------------
proc load_script {} {
    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} {

        $widgets(command) insert 0 $info
        send_command
    }
}

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

    if {[string length $cmd] > 0} {
        set last_command $cmd
    } else {
        set cmd $last_command
    }
    namespace eval Rappture::GeoViewer [list $widgets(geoviewer) SendCmd $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(geoviewer) delete
    $widgets(geoviewer) 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(geoviewer) 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 view/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(geoviewer) 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 "Geoviewer: 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.view -text "3D View" -variable images(which) \
    -value "view" -command images_refresh
pack .images.cntls.view -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) "view"

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 Earth File..." -underline 0 -command send_file
.mbar.file add command -label "Load script..." -underline 0 -command load_script
.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]
set servers [Rappture::VisViewer::GetServerList "geovis"]
Rappture::GeoViewer $f.viewer $servers
pack $f.viewer -expand yes -fill both
set widgets(geoviewer) $f.viewer

$f.viewer 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