utils.tcl

卫星仿真软件 卫星仿真软件 卫星仿真软件

#
######################################################
#
#  SaVi by Robert Thurman ([e-mail]) and
#          Patrick Worfolk ([e-mail]).
#
#  Copyright (c) 1997 by The Geometry Center.
#  This file is part of SaVi.  SaVi is free software;
#  you can redistribute it and/or modify it only under
#  the terms given in the file COPYRIGHT which you should
#  have received along with this file.  SaVi may be
#  obtained from:
#  http://savi.sourceforge.net/
#  http://www.geom.uiuc.edu/locate/SaVi
#
######################################################
#
# utils.tcl
#
#
# Routines for helping to construct tk windows
#
# Construction routines:
#   build_Toplevel
#   build_Title
#   build_StdFrame
#   build_CmdFrame
#   build_Menubar
#   build_Menu
#   build_Buttonbar
#   build_DismissButtonbar
#   build_Optionslist
#   build_HOptionslist
#   build_Filename
#   build_Scrollingtext
#   build_Text
#   build_Dialog
#   build_IPopupMenu
#   build_PopupMenu
#   build_LabelEntryColumns
#   build_Label
#   build_Message
#   build_Radiobutton
#
#
# Other routines:
#   build_Wname
#   update_Popupmenu
#   longest
#   loadfile_into_text

# New routines:
#   string_ends

#
# All these procedures use the global variables COLOR and FONT in
# order to configure them.  In particular, they may reference:
#   COLOR(bg)
#   COLOR(abg)
#   COLOR(entry)
#   FONT(button)
#   FONT(label)
#   TITLE
#
# Other global variables used are:
#   main(title)  - for a string to appear in all titlebars made
#                  with build_Title
#
# $Id: utils.tcl,v 1.12 2005/02/04 17:58:53 lloydwood Exp $

#
# string_ends {filename extension}
#
# returns true if filename ends with extension
#
proc string_ends {filename extension} {
    set file_length [string length "$filename"]
    set ext_length [string length "$extension"]
    set file_end [string range "$filename" \
	       [expr $file_length - $ext_length] $file_length]
    if {[string compare $file_end "$extension"] == 0} {
	return 1
    } else {
	return 0
    }
}

#
# build_Wname
#
# Converts name to a tk window name by placing a '.' at the beginning
#
# Returns: .name
#
proc build_Wname name {
    return .$name
}

#
# build_Toplevel
#
# Builds a new window using name (which must be unique).
# The name is passed to build_Wname to convert it to a Tk window name
#
# Returns: the tk window name
#
proc build_Toplevel {name} {
    global COLOR

    set wname [build_Wname $name]
    if {![winfo exists $wname]} {
	toplevel $wname
    }
    return $wname
}


#
# build_Title
#
# Set the title of a toplevel window with the string "main(title) $title"
#
proc build_Title {name title} {
    global TITLE
    wm title $name "$TITLE: $title"
}

#
# build_StdFrame
#
# Builds a plain frame with specifed name in specified parent
# This widget is not packed.
#
# Returns: the tk frame widget name parent.name
#
proc build_StdFrame {parent name} {
    global COLOR

    set fname $parent.$name
    if {![winfo exists $fname]} {
	frame $fname
    }
    return $fname
}

#
# build_CmdFrame
#
# Builds a raied frame with specifed name in specified parent
# to become an area of a window to put widgets
# This widget is not packed
#
# Returns: the tk frame widget name parent.name
#
proc build_CmdFrame {parent name} {
    global COLOR

    set fname $parent.$name
    if {![winfo exists $fname]} {
	frame $fname -relief raised -bd 1
    }
    return $fname
}


#
# build_Menubar
#
# Usage:
#       build_menubar parent name { helpmenu stuff } { menu stuff } ...
#
# Builds a menubar as specified.  The first menu specification is
# always placed all the way to the right and is expected to be a help menu.
# The others are placed starting at the left.
#
proc build_Menubar {parent name helpmenu args} {
    global COLOR FONT

    # create menubar
    set mbarname [ build_CmdFrame $parent $name ]

    # menubars are not currently rebuilt!
    if [winfo exists $mbarname.b0] {
	puts stderr "build_menubar: NOT rebuilding $mbarname"
	return
    }

    # add help menubutton on right side
    if {[llength $helpmenu] > 1} {
	menubutton $mbarname.help -text [lindex $helpmenu 0] \
	    -menu $mbarname.help.menu -font $FONT(button)
	eval build_Menu $mbarname.help menu [lrange $helpmenu 1 end]
	pack $mbarname.help -side right
    }

    #add other menubuttons on left side
    set i 0 ; set menubuttons {}
    foreach arg $args {
	if {[llength $arg] > 0} {
	    menubutton $mbarname.b$i -text [lindex $arg 0] \
		-menu $mbarname.b$i.menu -font $FONT(button)
	    lappend menubuttons $mbarname.b$i
	    if {[llength $arg] > 1} {
		eval build_Menu $mbarname.b$i menu [lrange $arg 1 end]
	    }
	    incr i
	}
    }
    if {[llength $menubuttons] > 0} {
	eval pack $menubuttons -side left
    }

    # display menubar across the top of the panel
    pack $mbarname -side top -fill x

    return $mbarname
}

#
# build_Menu
#
# Usage:
#	build_Menu parent name {"Load..." load_open} {} {"Exit" tk_exit} ...
#
# Builds a menu with an arbitrary number of entries.
# Empty entries result in menu separators.
#
proc build_Menu {parent name args} {
    global COLOR FONT

    # create menu
    set mname $parent.$name
    menu $mname -font $FONT(label)

    # add commands to menu
    foreach arg $args {
	if {[llength $arg] == 2} {
	    $mname add command -label [lindex $arg 0] -command [lindex $arg 1]
	} else {
	    $mname add separator
	}
    }

    return $mname
}

#
# build_Buttonbar
#
# Usage: build_Buttonbar parent name {"Button1" action} ...
#
proc build_Buttonbar {parent name args} {
    global COLOR FONT

    # create buttonbar
    set bbarname [ build_CmdFrame $parent $name ]

    # add buttons
    set i 0
    foreach arg $args {
	if {[llength $arg] > 1} {
	    if { [winfo exists $bbarname.b$i] == 0} {
		button $bbarname.b$i -font $FONT(button)
		pack $bbarname.b$i -side left -padx 2 -pady 2
	    }
	    set name [lindex $arg 0]
	    if {([string compare $name "Restart"] == 0) ||
	        ([string compare $name "Dismiss"] == 0) ||
		([string compare $name "Dismiss window"] == 0)} {
		pack $bbarname.b$i -side right
	    }
	    $bbarname.b$i configure -text [lindex $arg 0] \
		-command [lindex $arg 1]
	    incr i
	}
	while { [winfo exists $bbarname.b$i] == 1} {
	    destroy $bbarname.b$i
	    incr i
	}
    }

    pack $bbarname -fill x

    return $bbarname
}

#
# build_DismissButtonbar
#
# Builds a button bar with a dismiss button on the right hand side
# and the rest lined up on the left.
#
# Usage: build_DismissButtonbar parent name "dismiss command" \
#            {"Button1" "button1 command"} ...
#
proc build_DismissButtonbar {parent name dismiss args} {
    global COLOR FONT

    # create buttonbar
    set bbarname [ build_CmdFrame $parent $name ]

    # add other buttons
    set i 0
    foreach arg $args {
	if {[llength $arg] > 1} {
	    if { [winfo exists $bbarname.b$i] == 0} {
		button $bbarname.b$i -font $FONT(button)
		pack $bbarname.b$i -side left -padx 2 -pady 2
	    }
	    $bbarname.b$i configure -text [lindex $arg 0] \
		-command [lindex $arg 1]
	    incr i
	}
	while { [winfo exists $bbarname.b$i] == 1} {
	    destroy $bbarname.b$i
	    incr i
	}
    }

    # add dismiss button on right side
    if {[winfo exists $bbarname.dismiss] == 0} {
	button $bbarname.dismiss -font $FONT(button)
	pack $bbarname.dismiss -in $bbarname -side right -anchor e \
	    -padx 2 -pady 2
    }
    $bbarname.dismiss configure -text "Dismiss window" -command $dismiss

    pack $bbarname -side bottom -fill x
}


#
# build_Optionslist
#
# Procedure to make a list of option items
#
# Usage: build_Optionslist parent name \
#            {"Switch 1" switch1} {"Switch 2" switch2} ...
#
# The variables switch1,2 are set to 0 or 1 according to whether
# the switch is set or not.
#
proc build_Optionslist {parent name args} {
    global COLOR FONT

    # create options list
    set olistname [ build_StdFrame $parent $name]

    # add options
    set i 0
    foreach arg $args {
	if {[llength $arg] > 1} {
	    if { [winfo exists $olistname.b$i] == 0} {
		checkbutton $olistname.b$i -anchor w -font $FONT(label)
		pack $olistname.b$i -side top -fill x -padx 0.1c -pady 0.1c
	    }
	    $olistname.b$i configure -text [lindex $arg 0] \
		-variable [lindex $arg 1]
	    incr i
	}
	while {[winfo exists $olistname.b$i] == 1} {
	    destroy $olistname.b$i
	    incr i
	}
    }

    pack $olistname -pady 0.1c -anchor w
}

#
# build_HOptionslist
#
# Procedure to make a horizontal list of option items
#
# Usage: build_Optionslist parent name cmd \
#            {"Switch 1" switch1} {"Switch 2" switch2} ...
#
# The variables switch1,2 are set to 0 or 1 according to whether
# the switch is set or not, and then the cmd is executed.
#
proc build_HOptionslist {parent name cmd args} {
    global COLOR FONT

    # create options list
    set olistname [ build_StdFrame $parent $name]

    # add options
    set i 0
    foreach arg $args {
	if {[llength $arg] > 1} {
	    if { [winfo exists $olistname.b$i] == 0} {
		checkbutton $olistname.b$i -anchor w -font $FONT(label) -command $cmd
		pack $olistname.b$i -side left -padx 0.1c -pady 0.1c
	    }
	    $olistname.b$i configure -text [lindex $arg 0] \
		-variable [lindex $arg 1]
	    incr i
	}
	while {[winfo exists $olistname.b$i] == 1} {
	    destroy $olistname.b$i
	    incr i
	}
    }

    pack $olistname -pady 0.1c -anchor w
}


#
# build_Filename
#
# Builds fields for inputting a directory and filename
#
#
proc build_Filename {owner name file_var dir_var} {
    global COLOR

    build_LabelEntryColumns $owner $name \
	[list text {} { "Directory:" "Filename:" } ] \
	[list lentry {} [list "$dir_var" "$file_var"]]
}

#
# build_Scrollingtext
#
# Builds a widget for text and a scrollbar
#
proc build_Scrollingtext {parent name width height} {
    global COLOR FONT

    # create stext frame