# $Id: pltools.tcl,v 1.13 1994/07/01 20:39:57 mjl Exp $
# $Log: pltools.tcl,v $
# Revision 1.13  1994/07/01  20:39:57  mjl
# Added proc plstdwin to handle "standard" initialization code.
#
# Revision 1.12  1994/04/25  18:58:48  mjl
# Added the simple class system by Sam Shen for support of the palette
# manipulators.  Will probably rewrite in itcl at some point.

#----------------------------------------------------------------------------
# PLPLOT TK/TCL graphics renderer support procs
# Maurice LeBrun
# 1-Jul-1993
# IFS, University of Texas at Austin
#
# Includes code borrowed from the TCL/TK widget demo.
#----------------------------------------------------------------------------

#----------------------------------------------------------------------------
# plstdwin
#
# Does "standard" startup for a plframe-containing main window.
# Use it or roll your own, but note: this may change in future versions.
#----------------------------------------------------------------------------

proc plstdwin {w} {
    global plstdwin_skip_startup

# Only do global initialization once.

    if { ! [info exists plstdwin_skip_startup]} {

# Set up configuration options.
# The first is to hold default values of everything, the second is for
# user customization.  See pldefaults.tcl for more info.

	pldefaults
	plconfig

# I refuse to allow exec's since there's no need for them now.
# Open's have to remain, however, to read/write palette info.

	rename exec {}

	set plstdwin_skip_startup 1
    }

# Set min/max window sizes.

    set root_width  [winfo vrootwidth .] 
    set root_height [winfo vrootheight .]

    wm minsize $w 300 240
    wm maxsize $w [expr "$root_width/64*63"] [expr "$root_height/64*62"]

# Set window geometry defaults.  Depart from square slightly to account
# for menu bar.

    global geometry
    if { ! [ info exists geometry ] } then {
	set width  [expr "$root_width / 16 * 10"]
	set height [expr "$root_height / 16 * 11"]
	set geometry ${width}x${height}
    }
    wm geometry $w $geometry
}

#----------------------------------------------------------------------------
# null_command
#
# Invokes a dialog explaining that the real binding isn't written yet.
#----------------------------------------------------------------------------

proc null_command {cmd_name} {
    set dialog_args "-text {Command \"$cmd_name\" not yet implemented.} \
		     -aspect 500 -justify left"
    mkDialog .null $dialog_args {OK {}}
    tkwait visibility .null
    grab .null
    tkwait window .null
}

#----------------------------------------------------------------------------
# bogue_out
#
# Invokes a dialog explaining that the user bogued out (messed up, blew
# it, puked on the system console, etc).
#----------------------------------------------------------------------------

proc bogue_out {msg} {
    set dialog_args "-text \"$msg\" -aspect 800 -justify left"
    mkDialog .bogus $dialog_args {OK {}}
    tkwait visibility .bogus
    grab .bogus
    focus .bogus
    tkwait window .bogus
}

#----------------------------------------------------------------------------
# dpos w
#
# Position a dialog box at a reasonable place on the screen.
#----------------------------------------------------------------------------

proc dpos w {
    set offx [expr "[winfo rootx .]+100"]
    set offy [expr "[winfo rooty .]+100"]
    wm geometry $w +$offx+$offy
}

#----------------------------------------------------------------------------
# normal_text_setup
#
# Sets up text widgets the way I like them.
#----------------------------------------------------------------------------

proc normal_text_setup {w {width 60} {height 30}} {
    global dialog_font dialog_bold_font

    button $w.ok -text OK -command "destroy $w"
    text $w.t -relief raised -bd 2 -yscrollcommand "$w.s set" -setgrid true \
	    -width $width -height $height
    scrollbar $w.s -relief flat -command "text_scroll $w.t"
    pack append $w $w.ok {bottom fillx} $w.s {right filly} $w.t {expand fill}
    focus $w.t

# Set up display styles

    $w.t tag configure normal -font $dialog_font
    $w.t tag configure bold -font $dialog_bold_font

    if {[tk colormodel $w] == "color"} {
	$w.t tag configure color1 -background #eed5b7
	$w.t tag configure color2 -foreground red
	$w.t tag configure raised -background #eed5b7 -relief raised \
		-borderwidth 1
	$w.t tag configure sunken -background #eed5b7 -relief sunken \
		-borderwidth 1
    } else {
	$w.t tag configure color1 -background black -foreground white
	$w.t tag configure color2 -background black -foreground white
	$w.t tag configure raised -background white -relief raised \
		-borderwidth 1
	$w.t tag configure sunken -background white -relief sunken \
		-borderwidth 1
    }
    $w.t tag configure bgstipple -background black -borderwidth 0 \
	    -bgstipple gray25
    $w.t tag configure fgstipple -fgstipple gray50
    $w.t tag configure underline -underline on

# Set up bindings to be as useful as possible.

    bind $w <Any-Enter> "focus $w.t"

    bind $w.t <Return>	  "destroy $w"

    bind $w.t <Down>	  "text_scroll_by_line $w.t + 1"
    bind $w.t <Up>	  "text_scroll_by_line $w.t - 1"

    bind $w.t <Next>	  "text_scroll_by_page $w.t + 1"
    bind $w.t <space>	  "text_scroll_by_page $w.t + 1"

    bind $w.t <Prior>	  "text_scroll_by_page $w.t - 1"
    bind $w.t <BackSpace> "text_scroll_by_page $w.t - 1"
    bind $w.t <Delete>	  "text_scroll_by_page $w.t - 1"
}

#----------------------------------------------------------------------------
# text_scroll
#
# Scrolls text widget vertically, updating various things
#----------------------------------------------------------------------------

proc text_scroll {w line} {
    $w yview $line
    $w mark set insert [$w index @0,0]
}

#----------------------------------------------------------------------------
# text_scroll_by_line
#
# Scrolls text widget vertically by the given number of lines.
#----------------------------------------------------------------------------

proc text_scroll_by_line {w sign delta} {
    text_scroll $w [$w index "@0,0 $sign $delta lines"]
}

#----------------------------------------------------------------------------
# text_scroll_by_page
#
# Scrolls text widget vertically by the given number of pages (almost).
#----------------------------------------------------------------------------

proc text_scroll_by_page {w sign delta} {
    set height [lindex [$w config -height] 4]
    set delta [expr $delta*($height-2)]
    text_scroll $w [$w index "@0,0 $sign $delta lines"]
}

#----------------------------------------------------------------------------
# The procedure below inserts text into a given text widget and
# applies one or more tags to that text.  The arguments are:
#
# w		Window in which to insert
# text		Text to insert (it's inserted at the "insert" mark)
# args		One or more tags to apply to text.  If this is empty
#		then all tags are removed from the text.
#----------------------------------------------------------------------------

proc insertWithTags {w text args} {
    set start [$w index insert]
    $w insert insert $text
    foreach tag [$w tag names $start] {
	$w tag remove $tag $start insert
    }
    foreach i $args {
	$w tag add $i $start insert
    }
}

#----------------------------------------------------------------------------
# Numeric utility procs:
#
#    min	returns minimum argument
#    max	returns maximum argument
#
# Taken from utils.tcl by Tom Phelps (phelps@cs.Berkeley.EDU)
#----------------------------------------------------------------------------

proc min {args} {
   set x [lindex $args 0]
   foreach i $args {
      if {$i<$x} {set x $i}
   }
   return $x
}

proc max {args} {
   set x [lindex $args 0]
   foreach i $args {
      if {$i>$x} {set x $i}
   }
   return $x
}

#----------------------------------------------------------------------------
# getItem
#
# Asks user to input something, returning the result.
# Selecting "Cancel" returns the empty string.
#----------------------------------------------------------------------------

proc getItem {item} {
    global dialog_font dialog_bold_font
    global itemval

    set w .entry
    set itemval ""

    catch {destroy $w}
    toplevel $w
    dpos $w
    wm title $w "Entry"
    wm iconname $w "Entry"
    message $w.msg -font $dialog_font -aspect 800 -text $item

    frame $w.frame -borderwidth 10
    pack append $w.frame \
	[entry $w.frame.e1 -relief sunken] {top pady 10 fillx} 

    button $w.ok -text OK -command \
	"set itemval \[$w.frame.e1 get\]; destroy $w"
    button $w.cancel -text Cancel -command "destroy $w"

    bind $w.frame.e1 <Return> \
	"set itemval \[$w.frame.e1 get\]; destroy $w"

    pack append $w $w.msg {top fill} $w.frame {top expand fill} \
	$w.ok {left expand fill} $w.cancel {left expand fill}

    tkwait visibility $w
    grab $w
    focus $w.frame.e1
    tkwait window $w
    return $itemval
}

#----------------------------------------------------------------------------
# confirm
#
# Sure about that, buddy?
#----------------------------------------------------------------------------

proc confirm {msg} {
    global confirm_flag
    set dialog_args "-text {$msg} \
		     -aspect 500 -justify left"
    mkDialog .confirm $dialog_args \
	"OK {set confirm_flag 1}" "Cancel {set confirm_flag 0}"
    tkwait visibility .confirm
    grab .confirm
    focus .confirm
    tkwait window .confirm
    return $confirm_flag
}

#----------------------------------------------------------------------------
# mkDialog w msgArgs list list ...
#
# Create a dialog box with a message and any number of buttons at
# the bottom.
#
# Arguments:
#    w -	Name to use for new top-level window.
#    msgArgs -	List of arguments to use when creating the message of the
#		dialog box (e.g. text, justifcation, etc.)
#    list -	A two-element list that describes one of the buttons that
#		will appear at the bottom of the dialog.  The first element
#		gives the text to be displayed in the button and the second
#		gives the command to be invoked when the button is invoked.
#----------------------------------------------------------------------------

proc mkDialog {w msgArgs args} {
    catch {destroy $w}
    toplevel $w -class Dialog
    dpos $w
    wm title $w "Dialog box"
    wm iconname $w "Dialog"

    # Create two frames in the main window. The top frame will hold the
    # message and the bottom one will hold the buttons.  Arrange them
    # one above the other, with any extra vertical space split between
    # them.

    frame $w.top -relief raised -border 1
    frame $w.bot -relief raised -border 1
    pack append $w $w.top {top fill expand} $w.bot {top fill expand}
    
    # Create the message widget and arrange for it to be centered in the
    # top frame.
    
    eval message $w.top.msg -justify center $msgArgs
    pack append $w.top $w.top.msg {top expand padx 10 pady 10}
    
    # Create as many buttons as needed and arrange them from left to right
    # in the bottom frame.  Embed the left button in an additional sunken
    # frame to indicate that it is the default button, and arrange for that
    # button to be invoked as the default action for clicks and returns in
    # the dialog.

    if {[llength $args] > 0} {
	set arg [lindex $args 0]
	frame $w.bot.0 -relief sunken -border 1
	pack append $w.bot $w.bot.0 {left expand padx 20 pady 20}
	button $w.bot.0.button -text [lindex $arg 0] \
		-command "[lindex $arg 1]; destroy $w"
	pack append $w.bot.0 $w.bot.0.button {expand padx 12 pady 12}
	bind $w <Return> "[lindex $arg 1]; destroy $w"
	focus $w

	set i 1
	foreach arg [lrange $args 1 end] {
	    button $w.bot.$i -text [lindex $arg 0] \
		    -command "[lindex $arg 1]; destroy $w"
	    pack append $w.bot $w.bot.$i {left expand padx 20}
	    set i [expr $i+1]
	}
    }
    bind $w <Any-Enter> [list focus $w]
    focus $w
}

#----------------------------------------------------------------------------
# Form2d
#
# Create a top-level window that displays a bunch of entries used for
# entering window coordinates.
#
# Arguments:
#    w		Name of top level window
#    desc	Short description of coordinates to be entered.
#
# Global variables referenced:
#    fv00	fn00
#    fv01	fn01
#    fv10	fn10
#    fv11	fn11
#
# The global variables are modified by the entry widgets and may be
# overwritten at any time so the caller must wait for the dialog to be
# destroyed and then use them immediately.  
#----------------------------------------------------------------------------

proc Form2d {w desc} {
    global dialog_font dialog_bold_font
    global tabList
    global fv00 fv01 fv10 fv11
    global fn00 fn01 fn10 fn11

    catch {destroy $w}
    toplevel $w
    dpos $w

    wm title $w "Entry window"
    wm iconname $w "Entry"

    message $w.msg \
	-font $dialog_font \
	-aspect 700 \
	-text "$desc  Click \"OK\" button when finished."

    pack append $w \
	$w.msg {top fill}

    set rows {0 1}
    set cols {0 1}
    set tabList ""

    foreach i $rows {
	frame $w.$i

	foreach j $cols {
            set name [set fn$i$j]
            set value [set fv$i$j]
	    frame $w.$i.$j -bd 1m

	    entry $w.$i.$j.entry -relief sunken -width 10
	    $w.$i.$j.entry insert 0 $value
	    bind $w.$i.$j.entry <Tab> "Form2d_tab \$tabList"
	    bind $w.$i.$j.entry <Return> "Form2d_destroy $w"
            set tabList [concat $tabList $w.$i.$j.entry]

	    label $w.$i.$j.label -width 10
	    $w.$i.$j.label config -text "$name:"

	    pack append $w.$i.$j \
		$w.$i.$j.entry right \
		$w.$i.$j.label left

	    pack append $w.$i \
		$w.$i.$j {left fillx}
	}

	pack append $w \
	    $w.$i {top fillx} 
    }

    button $w.ok -text OK -command "Form2d_destroy $w"
    pack append $w \
	$w.ok {bottom fill}

    tkwait visibility $w
    grab $w
    focus $w.0.0.entry
}

# This procedure is invoked when the top level entry dialog is destroyed.
# It updates the global vars used to communicate the entry values then
# destroys the window.

proc Form2d_destroy {w} {
    global fv00 fv01 fv10 fv11

    set fv00 [$w.0.0.entry get]
    set fv01 [$w.0.1.entry get]
    set fv10 [$w.1.0.entry get]
    set fv11 [$w.1.1.entry get]

    destroy $w
}

# The procedure below is invoked in response to tabs in the entry
# windows.  It moves the focus to the next window in the tab list.
# Arguments:
#
# list -	Ordered list of windows to receive focus

proc Form2d_tab {list} {
    set i [lsearch $list [focus]]
    if {$i < 0} {
	set i 0
    } else {
	incr i
	if {$i >= [llength $list]} {
	    set i 0
	}
    }
    focus [lindex $list $i]
}

#----------------------------------------------------------------------------
# evalCmd w
#
# Create a top-level window containing a text widget that allows you
# to enter a TCL command and have it executed.
#
# Arguments:
#    w -	Name to use for new top-level window.
#----------------------------------------------------------------------------

proc evalCmd {{w .eval}} {
    catch {destroy $w}
    toplevel $w -geometry 400x300
    dpos $w
    wm title $w "Interpret command"
    wm iconname $w "Interpret"

    frame $w.cmd
    label $w.cmd.label -text "Command:" -width 13 -anchor w
    entry $w.cmd.entry -width 40 -relief sunken -bd 2 -textvariable command
    button $w.cmd.button -text "Execute" \
	    -command "eval \$command"
    pack append $w.cmd $w.cmd.label left $w.cmd.entry left \
	    $w.cmd.button {left pady 10 padx 20}
    bind $w.cmd.entry <Return> "eval \$command"

    text $w.t -relief raised -bd 2 -setgrid true
    $w.t insert 0.0 {\
Type TCL command to be executed in the window above, then type <Return>
or click on "Execute".  
}
    $w.t mark set insert 0.0
    bind $w <Any-Enter> "focus $w.cmd.entry"

    button $w.ok -text OK -command "destroy $w"

    pack append $w $w.cmd {top fill} \
	    $w.ok {bottom fillx} $w.t {expand fill}
}

#------------------------------------------------------------------------------
#
# A simple class system in Tcl.
#
# From the pixmap editor by Sam Shen (sls@aero.org)
#
#------------------------------------------------------------------------------

set object_counter 0
proc class {class_name spec} {
    global class_methods
    set members ""
    for {set i 0} {$i < [llength $spec]} {incr i} {
	case [lindex $spec $i] {
	    method {
		set method_body [concat global \$this ";" in \$this]
		lappend method_body [lindex $spec [expr {$i+3}]]
		set ag [linsert [lindex $spec [expr {$i+2}]] 0 this]
		proc $class_name:[lindex $spec [expr {$i+1}]] \
		    $ag $method_body
		lappend class_methods($class_name) [lindex $spec [expr {$i+1}]]
		incr i 3
	    }
	    member {
		lappend members [list [lindex $spec [expr {$i+1}]] \
				 [lindex $spec [expr {$i+2}]]]
		incr i 2
	    }
	    "#|" {
		incr i
		while {[lindex $spec $i] != "#|"} {
		    incr i
		}
	    }
	    default {
		error [format {unknown keyword "%s" in class declaration} \
		       [lindex $spec $i]]
	    }
	}
    }
    if {$members != ""} {
	set ctor_body [format {
	    upvar #0 $_this this
	    foreach member {%s} {
		set this([lindex $member 0]) [lindex $member 1]
	    }
	} $members]
	proc $class_name:Construct _this $ctor_body
    }
    set body [format {
	global object_counter
	set objects ""
	for {set i 0} {$i < $count} {incr i} {
	    set var O_[incr object_counter]
	    upvar #0 $var object
	    lappend objects $var
	    set object(class) %s
	    if %d {
		uplevel "%s:Construct $var"
	    }
	}
	return $objects
    } $class_name [expr {$members != ""}] $class_name]
    proc $class_name {{count 1}} $body
}

set in_counter 0
set in_sti 0
proc push_scope {on} {
    global in_sti in_st
    set in_st([incr in_sti]) $on
}
proc in_scope? {on} {
    global in_sti in_st
    expr {$in_sti > 0 && $in_st($in_sti) == $on}
}
proc pop_scope {} {
    global in_sti in_st
    unset in_st($in_sti)
    incr in_sti -1
}

proc in {_object expr} {
    upvar #0 $_object object
    global in_counter errorInfo class_methods
    set cleanup ""
    if ![in_scope? $_object] {
	push_scope $_object
	set switched_scope 1
	set ctr [incr in_counter]
	set cleanup "pop_scope; "
	set class $object(class)
	foreach method $class_methods($class) {
	    if {[info procs $method] != ""} {
		set oldproc $method[set ctr]
		rename $method $oldproc
		append cleanup "rename $method {}; rename $oldproc $method; "
	    } else {
		append cleanup "rename $method {}; "
	    }
	    set method_body [format {
		uplevel [format "%s %s %%s" $args]
	    } $class:$method $_object]
	    proc $method args $method_body
	}
    }
    if {[set retval [catch {uplevel $expr} result]] == 1} {
	set savedInfo $errorInfo
    }
    eval $cleanup
    if {$retval == 1} {
	error $result $savedInfo
    }
    return $result
}

proc getmember var {
    upvar [uplevel "set this"] o
    set o($var)
}

proc setmember {var val} {
    set cmd [format {set [set this](%s)} $var]
    lappend cmd $val
    return [uplevel $cmd]
}

proc appendmember {var val} {
    set cmd [format {append [set this](%s)} $var]
    lappend cmd $val
    uplevel $cmd
}

proc membername {var} {
    set o [uplevel {set this}]
    return [format %s(%s) $o $var]
}

proc lappendmember {var val} {
    set cmd [format {lappend [set this](%s)} $var]
    lappend cmd $val
    uplevel $cmd
}

proc delete object {
    uplevel "unset $object"
}

#------------------------------------------------------------------------------
# Proc to set up debug bindings.
#------------------------------------------------------------------------------

proc dbug_bind {w} {

bind $w <Any-ButtonPress>	{puts stderr "Widget event: ButtonPress"}
bind $w <Any-ButtonRelease>	{puts stderr "Widget event: ButtonRelease"}
bind $w <Any-Circulate>		{puts stderr "Widget event: Circulate"}
bind $w <Any-CirculateRequest>	{puts stderr "Widget event: CirculateRequest"}
bind $w <Any-Colormap>		{puts stderr "Widget event: Colormap"}
bind $w <Any-Configure>		{puts stderr "Widget event: Configure"}
bind $w <Any-ConfigureRequest>	{puts stderr "Widget event: ConfigureRequest"}
bind $w <Any-Destroy>		{puts stderr "Widget event: Destroy"}
bind $w <Any-Enter>		{puts stderr "Widget event: Enter"}
bind $w <Any-Expose> 		{puts stderr "Widget event: Expose"}
bind $w <Any-FocusIn>		{puts stderr "Widget event: FocusIn"}
bind $w <Any-FocusOut>		{puts stderr "Widget event: FocusOut"}
bind $w <Any-Gravity>		{puts stderr "Widget event: Gravity"}
bind $w <Any-Keymap>		{puts stderr "Widget event: Keymap"}
bind $w <Any-KeyPress>		{puts stderr "Widget event: KeyPress"}
bind $w <Any-KeyRelease>	{puts stderr "Widget event: KeyRelease"}
bind $w <Any-Leave>		{puts stderr "Widget event: Leave"}
bind $w <Any-Map>		{puts stderr "Widget event: Map"}
bind $w <Any-MapRequest>	{puts stderr "Widget event: MapRequest"}
#bind $w <Any-Motion>		{puts stderr "Widget event: Motion"}
bind $w <Any-Property>		{puts stderr "Widget event: Property"}
bind $w <Any-Reparent>		{puts stderr "Widget event: Reparent"}
bind $w <Any-ResizeRequest>	{puts stderr "Widget event: ResizeRequest"}
bind $w <Any-Unmap>		{puts stderr "Widget event: Unmap"}
bind $w <Any-Visibility>	{puts stderr "Widget event: Visibility"}

}
