diff options
Diffstat (limited to 'vendor/x11iraf/guidemo/table.gui')
| -rw-r--r-- | vendor/x11iraf/guidemo/table.gui | 1958 |
1 files changed, 1958 insertions, 0 deletions
diff --git a/vendor/x11iraf/guidemo/table.gui b/vendor/x11iraf/guidemo/table.gui new file mode 100644 index 00000000..68d71df9 --- /dev/null +++ b/vendor/x11iraf/guidemo/table.gui @@ -0,0 +1,1958 @@ +# TABDEMO.GUI -- Test the Table widget. + +reset-server +appInitialize tabdemo Tabdemo { + + *demoObjects:\ + toplevel Layout panel \ + panel Frame panelMenuFrame \ + panelMenuFrame Layout panelMenuBar \ + panelMenuBar Command newCol \ + panelMenuBar Command newRow \ + panelMenuBar Command newTable \ + panelMenuBar Command tclShell \ + panelMenuBar Command quitButton + + + Tabdemo*background: grey + *Tabdemo.geometry: +0+0 + + *Group.shrinkToFit: True + *Command.height: 28 + *Command.shadowWidth: 1 + *Frame.frameWidth: 1 + *Frame.innerOffset: 4 + *Frame.highlightThickness: 0 + *borderWidth: 0 + *Scrollbar2.location: 0 0 17 17 + *Scrollbar.beNiceToColormap: False + + *panel.width: 600 + *panel.height: 350 + *panel.layout: vertical { \ + panelMenuFrame < +inf -inf * > \ + 5 < +inf > horizontal { 5 < +inf > }\ + } + + *panelMenuBar.layout: horizontal { \ + 2 newRow 1 newCol 1 newTable 1 tclShell 2 < +inf > quitButton 2 \ + } + *newCol.label: New Col + *newRow.label: New Row + *newTable.label: New Table + *tclShell.label: TclShell + *quitButton.label: Quit + +} ; createObjects demoObjects + +send quitButton addCallback "send client gkey q ; deactivate unmap" + +# Utility procedure to test True/False strings in resources. +proc true {v} {expr {$v == "true" || $v == "True" || $v == "TRUE"}} + +# Utility functions. +proc min {a b} { expr {($a < $b) ? $a : $b} } +proc max {a b} { expr {($a > $b) ? $a : $b} } + +# Create the Table objects in the OBM. + +set tabnumber 0 ;# initialize table counter + +proc doTable args { + global tabnumber + + set tab [ format "tab%d" $tabnumber ] + set objs [ tableBuildObjects panel $tab ] + +# tableSetOption $tab DefLabels no +# tableSetOption $tab RowLabels no +# tableSetOption $tab ColLabels no +# tableSetOption $tab Tracking no +# tableSetOption $tab RowScroll no +# tableSetOption $tab ColScroll no +# tableSetOption $tab DefaultTranslations no + tableSetOption $tab RowMultiSelect no + tableSetOption $tab ColMultiSelect no +# tableSetOption $tab RowLabelCols 2 +# tableSetOption $tab ColLabelRows 2 + tableSetOption $tab Background bisque3 + + # Now create the new objects. + appExtend $objs + createObjects ${tab}Objects + + # Now construct a layout for the new object. + set new "" + set panStart "vertical \{ panelMenuFrame < +inf -inf * > 5 < -5 >" + for {set i 0} {$i <= $tabnumber} {incr i} { + + # Send the existing table a small height so they'll ajust to + # fit the new table. + if {$i < $tabnumber} { send tab${i}TableFrame set height 10 } + + # Append a layout spec for the table. + set new \ + [format "%s tab%dTableFrame < +inf -inf * +inf -inf > 5 < -5 >" \ + $new $i] + } + set panEnd "\}" + set panelLayout [format "%s %s %s" $panStart $new $panEnd] + + # Send the panel the new layout incorporating the newly created Table. + send panel set layout $panelLayout + + # Now create the table itself, it should appear as if by magic. + tableCreate $tab 12 30 { } + + # Apply some default test callbacks for selection/edit events. + tableAddSelectCallback $tab Row demoSelCB + tableAddSelectCallback $tab Col demoSelCB + tableAddSelectCallback $tab Cell demoSelCB + tableAddUnSelectCallback $tab Row demoUnSelCB + tableAddUnSelectCallback $tab Col demoUnSelCB + tableAddUnSelectCallback $tab Cell demoUnSelCB + tableAddEditCallback $tab demoEditCB + + # Increment the global table counter. + incr tabnumber + +} ; send newTable addCallback doTable + +proc demoSelCB { name row col x y args } { + print "demoSelCB: name=$name r=$row c=$col x=$x y=$y args='$args'" +} + +proc demoUnSelCB { name row col x y args } { + print "demoUnSelCB: name=$name r=$row c=$col x=$x y=$y args='$args'" +} + +proc demoEditCB { name row col str args } { + print "demoEditCB: name=$name row=$row col=$col str='$str' args='$args'" +} + + +################################################################################ + +################################################################################ +# +# TABLE WIDGET PROCEDURES -- This interface provides simple access to a +# named instance of a Table "meta-widget". The "widget" is actually a +# number of widgets (Table, Scrollbars, etc) in a common layout to provide +# row/col headings, scrollable data tables, and callbacks for [gs]etting +# attributes. The meta-widget is created on-the-fly with a given named +# and parent object, it is the callers responsibility to adjust the layout +# of the parent to incorporate the new objects. +# +# The Table widget itself has various quirks and non-standard implem- +# entations so features such as editing cells or access to certain callbacks +# are not fully implemented in the OBM and hidden here. Most of what's +# needed can be handled by these procedures, however these routines may be +# used to manage multiple named tables in a GUI. +# +# +# tableBuildObjects parent tab +# tableSetOption tab option value +# tableAddSelectCallback tab type cbname +# tableAddEditCallback tab cbname +# tableDestroyObjects tab +# +# tableCreate tab nrows ncols data +# tableSetData tab data +# tableSetColumnLabels tab labels +# tableSetRowLabels tab labels +# +# tableSelectRow tab [ rownum | "all" ] +# tableUnSelectRow tab [ rownum | "all" ] +# tableSelectCol tab [ colnum | "all" ] +# tableUnSelectCol tab [ colnum | "all" ] +# tableSelectCell tab x y +# tableUnSelectCell tab x y +# list = tableGetSelected tab type +# +# tableSetRowLabelsAttr tab attr value +# value = tableGetRowLabelsAttr tab attr +# tableSetColLabelsAttr tab attr value +# value = tableGetColLabelsAttr tab attr +# tableSetRowLabelAttr tab row attr value +# value = tableGetRowLabelAttr tab row attr +# tableSetColLabelAttr tab col attr value +# value = tableGetColLabelAttr tab col attr +# +# attr = tableGetCelllAttr tab row col attr +# tableSetCelllAttr tab row col attr value +# value = tableGetRowAttr tab row attr +# tableSetRowAttr tab row attr value +# value = tableGetColAttr tab col attr +# tableSetColAttr tab col attr value +# +# tableDeleteCol tab col +# tableDeleteRow tab row +# tableAddCol tab col width [where] +# tableAddRow tab row [where] +# +# nrows = tableGetNrows tab +# ncols = tableGetNcols tab +# height = tableGetHeight tab +# width = tableGetWidth tab +# +# See obm$widget.c for a complete list of the OBM commands available +# for this widget, and procedure header comments for details about the +# interface here. +# +################################################################################ + +set tabNrows(name) 0 +set tabNcols(name) 0 +set tabData(name) 0 +set tabColLabs(name) 0 +set tabRowHeights(name,j) 0 +set tabColWidths(name,i) 0 + +set tabHeight(name) 0 +set tabWidth(name) 0 +set tabScrollSize(name,type) 0 +set tabScrollPos(name,type) 0 + +# Meta-widget options, should be set before the tableCreate call. +set tabOption(name,RowLabels) yes +set tabOption(name,ColLabels) yes +set tabOption(name,DefLabels) yes +set tabOption(name,Tracking) yes +set tabOption(name,RowScroll) yes +set tabOption(name,ColScroll) yes +set tabOption(name,Editable) yes +set tabOption(name,RowSelect) yes +set tabOption(name,ColSelect) no +set tabOption(name,CellSelect) no +set tabOption(name,DefaultTranslations) yes +set tabOption(name,Background) grey +set tabOption(name,Foreground) black +set tabOption(name,HighlightColor) grey90 +set tabOption(name,RowLabelCols) 1 +set tabOption(name,ColLabelRows) 1 + +# Selection lists. +set tabSelected(name,Row) {} +set tabSelected(name,Col) {} +set tabSelected(name,Cell) {} +set tabSelectionCB(name,Row) {} +set tabSelectionCB(name,Col) {} +set tabSelectionCB(name,Cell) {} +set tabUnSelectionCB(name,Row) {} +set tabUnSelectionCB(name,Col) {} +set tabUnSelectionCB(name,Cell) {} +set tabEditCB(name) {} + + +# TABLEBUILDOBJECTS -- Utility routine to build the object list for the meta- +# widget. +# +# Usage: +# tableBuildObjects <parent> <tab> + +proc tableBuildObjects { parent tab } { + + set objDef { + *TABObjects: \ + PARENT Frame TABTableFrame \ + TABTableFrame Layout TABFrameLayout \ + TABFrameLayout Layout TABTableLayout \ + TABTableLayout Viewport TABTabView \ + TABTabView Table TABTab \ + TABTableLayout Label TABSpacer1 \ + TABTableLayout Viewport TABRowTabView \ + TABRowTabView Table TABRowTab \ + TABTableLayout Viewport TABColTabView \ + TABColTabView Table TABColTab \ + TABFrameLayout Label TABLabel \ + TABFrameLayout Label TABSpacer2 \ + TABFrameLayout Scrollbar TABColScroll \ + TABFrameLayout Scrollbar TABRowScroll \ +\ + toplevel TopLevelShell TABEditShell \ + TABEditShell Layout TABEditLayout \ + TABEditLayout Frame TABEditMenuFrame\ + TABEditMenuFrame Layout TABEditMenuBar \ + TABEditMenuBar Command TABEditApply \ + TABEditMenuBar Command TABEditClear \ + TABEditMenuBar Command TABEditCancel \ + TABEditLayout Frame TABEditFrame \ + TABEditFrame AsciiText TABEditText \ + + + + + ! Global Table widget resources. + *Table.literalWidth: 20 + *Table.rowHeight: 18 + *Table.shadowWidth: 2 + *Table.labelShadowWidth: 1 + *Table.tableMargin: 0 + *Table.columnMargin: 0 + *Table.rowMargin: 0 + *Table.internalHeight: 0 + *Table.internalWidth: 0 + *Table*font: 7x13bold + + *TABTableFrame*Group.shrinkToFit: True + *TABTableFrame*Command.height: 28 + *TABTableFrame*Command.shadowWidth: 1 + *TABTableFrame*Frame.frameWidth: 1 + *TABTableFrame*Frame.innerOffset: 4 + *TABTableFrame*Frame.highlightThickness: 0 + *TABTableFrame*Frame.borderWidth: 0 + *TABTableFrame*Frame.shrinkToFit: True + *TABTableFrame*Table.borderWidth: 1 + *TABTableFrame*Scrollbar.beNiceToColormap: False + + *TABTableFrame.height: 10 + *TABTableFrame.width: 10 + *TABTableFrame*Layout.height: 10 + *TABTableFrame*Layout.width: 10 + *TABTableFrame*Label.height: 12 + *TABTableFrame*Label.label: + *TABTableFrame*Label.font: 6x12 + + *TABFrameLayout.TABTableLayout.height: 10 + *TABFrameLayout.TABTableLayout.width: 10 + *TABFrameLayout.TABTableLayout*Layout.height: 10 + *TABFrameLayout.TABTableLayout*Layout.width: 10 + *TABFrameLayout.TABTableLayout*Viewport.height: 20 + *TABFrameLayout.TABTableLayout*Viewport.width: 20 + *TABFrameLayout.TABTableLayout*Table.height: 20 + *TABFrameLayout.TABTableLayout*Table.width: 20 + + + ! The following resources enable the scrollbars on the Viewport + ! widget but effectively hide them from display. This allows us + ! to control the viewport manually from the Table code, e.g. to + ! scroll both the column headings and data table. + *TABFrameLayout.TABTableLayout*Viewport.allowVert: True + *TABFrameLayout.TABTableLayout*Viewport.allowHoriz: True + *TABFrameLayout.TABTableLayout*Viewport.forceBars: True + *TABFrameLayout.TABTableLayout*Viewport.useBottom: True + *TABFrameLayout.TABTableLayout*Viewport.useRight: True + *TABFrameLayout.TABTableLayout*Viewport.borderWidth: 1 + + *TABTableLayout*TABRowTabView*vertical.thickness: 1 + *TABTableLayout*TABRowTabView*horizontal.thickness: 1 + *TABTableLayout*TABColTabView*vertical.thickness: 1 + *TABTableLayout*TABColTabView*horizontal.thickness: 1 + *TABTableLayout*TABTabView*vertical.thickness: 1 + *TABTableLayout*TABTabView*horizontal.thickness: 1 + + *TABTableFrame.TABFrameLayout.TABRowScroll.thickness: 12 + *TABTableFrame.TABFrameLayout.TABRowScroll.width: 12 + *TABTableFrame.TABFrameLayout.TABRowScroll.height: 12 + *TABTableFrame.TABFrameLayout.TABRowScroll.orientation: Vertical + + *TABTableFrame.TABFrameLayout.TABColScroll.thickness: 12 + *TABTableFrame.TABFrameLayout.TABColScroll.width: 12 + *TABTableFrame.TABFrameLayout.TABColScroll.height: 12 + *TABTableFrame.TABFrameLayout.TABColScroll.orientation: Horizontal + + *TABFrameLayout.layout: horizontal { \ + vertical { \ + 2 < -2 > \ + TABTableLayout < +inf -inf * +inf -inf > \ + 2 < -2 > \ + horizontal { \ + TABLabel 1 < -1 > TABColScroll < +inf -inf * > \ + } \ + } \ + vertical { \ + TABSpacer2 1 < -1 > TABRowScroll < * +inf -inf > 22 < -22 > \ + } \ + } + *TABTableFrame.TABFrameLayout.TABLabel.label: ( 0, 0) + *TABTableFrame.TABFrameLayout.TABLabel.font: 6x12 + *TABTableFrame.TABFrameLayout.TABLabel.width: 80 + *TABTableFrame.TABFrameLayout.TABLabel.height: 12 + *TABTableFrame.TABFrameLayout*TABColScroll.height: 12 + *TABTableFrame.TABFrameLayout.TABSpacer2.height: 27 + *TABTableFrame.TABFrameLayout.TABSpacer2.shadowWidth: 0 + + *TABTableLayout.layout: horizontal { \ + vertical { \ + TABSpacer1 1 < -1 > TABRowTabView < * +inf -inf > \ + } \ + 3 < -3 > \ + vertical { \ + TABColTabView < +inf -inf * > \ + 3 < -3 > \ + TABTabView < +inf -inf * +inf -inf > \ + } \ + 3 < -3 > \ + } + *TABTableLayout.TABSpacer1.height: 27 + *TABTableLayout.TABSpacer1.shadowWidth: 0 + + !---------------------------+ + ! Set the editor resources. | + !---------------------------+ + *TABEditShell.title: Table Value Editor + *TABEditShell.width: 275 + *TABEditShell.height: 80 + *TABEditLayout*borderWidth: 0 + *TABEditLayout.layout: vertical { \ + TABEditFrame < +inf -inf * +inf -inf > \ + -2 \ + TABEditMenuFrame < +inf -inf * > \ + -2 \ + } + + *TABEditMenuBar.layout: horizontal { \ + TABEditApply 5 \ + 10 < +inf -inf > \ + TABEditClear 5 \ + 10 < +inf -inf > \ + TABEditCancel 5 \ + } + *TABEditMenuFrame.height: 80 + *TABEditMenuFrame.outerOffset: 0 + *TABEditMenuFrame.innerOffset: 5 + *TABEditMenuFrame.frameType: chiseled + *TABEditMenuFrame.frameWidth: 2 + *TABEditFrame.frameType: sunken + *TABEditFrame.frameWidth: 2 + *TABEditFrame.outerOffset: 5 + *TABEditText*scrollVertical: never + *TABEditText*scrollHorizontal: whenNeeded + *TABEditText*font: 7x13 + *TABEditText*editType: edit + *TABEditApply.label: Apply + *TABEditApply.width: 150 + *TABEditClear.label: Clear + *TABEditClear.width: 150 + *TABEditCancel.label: Cancel + *TABEditCancel.width: 150 + + } + + regsub -all TAB $objDef $tab tmp1 + regsub -all PARENT $tmp1 $parent objs + set objs [format "{ %s }" $objs] + + return $objs +} + + +# TABLEDESTROYOBJECTS -- Destroy the specified table and all it's objects. +# +# Usage: +# tableDestroyObjects <tab> + +proc tableDestroyObjects { tab } { + destroyObject ${tab}TableFrame +} + + +# TABESETOPTION -- Set an option for the Table meta-widget. +# +# Usage: +# tableSetOption <tab> <option> [yes|no] +# +# where <tab> is the table name given when the meta-widget was created, and +# <option> is one of: +# +# +# Option Name Type Default Description +# ----------- ---- ------- ----------- +# RowLabels bool yes display a row label table +# ColLabels bool yes display a column label table +# DefLabels bool yes do default labels of rows/cols +# Tracking bool yes do coord tracking in data table +# RowScroll bool yes display row scrollbar +# ColScroll bool yes display column scrollbar +# Editable bool yes table is editable +# RowSelect bool yes rows are selectable +# ColSelect bool yes cols are selectable +# CellSelect bool yes cells are selectable +# RowMultiSelect bool yes multiple rows may be selected +# ColMultiSelect bool yes multiple cols may be selected +# CellMultiSelect bool yes multiple cells may be selected +# DefaultTranslations bool yes use default table translations +# Foreground color black meta-widget foreground color +# Background color grey meta-widget background color +# HighlightColor color grey90 selected item highlight color +# RowLabelCols int 1 number of columns in row labels +# ColLabelRows int 1 number of rows in column labels +# + +proc tableSetOption { tab option value } { + global tabOption + set tabOption(${tab},${option}) $value + + # Now handle the special cases where one option may disable some other. +} + + +# TABLEADDSELECTCALLBACK -- Add a user-defined callback to be executed +# when there is a row, column, or cell selection event occurs. +# +# Usage: +# tableAddSelectCallback <tab> <type> <cbname> +# +# where <type> is "Row", "Col", or "Cell" and <cbname> specifies a procedure +# to be called whenever the specified <type> is selected. Procedures are +# called as +# <cbname> name row col x y +# +# where 'name' is the table name, 'row' and 'col' are the coordinates of the +# selection and 'x' and 'y' are the raw event coordinates. Registered proc- +# edures are required to declare all these arguments but do not need to use +# them. + +proc tableAddSelectCallback { tab type cbname } { + global tabSelectionCB + lappend tabSelectionCB(${tab},${type}) $cbname +} + + +# TABLEADDUNSELECTCALLBACK -- Add a user-defined callback to be executed +# when there is a row, column, or cell un-selection event occurs. +# +# Usage: +# tableAddUnSelectCallback <tab> <type> <cbname> +# +# where <type> is "Row", "Col", or "Cell" and <cbname> specifies a procedure +# to be called whenever the specified <type> is selected. Procedures are +# called as +# <cbname> name row col x y state +# +# where 'name' is the table name, 'row' and 'col' are the coordinates of the +# selection and 'x' and 'y' are the raw event coordinates. Registered proc- +# edures are required to declare all these arguments but do not need to use +# them. + +proc tableAddUnSelectCallback { tab type cbname } { + global tabUnSelectionCB + lappend tabUnSelectionCB(${tab},${type}) $cbname +} + + + +# TABLEADDEDITCALLBACK -- Add a user-defined callback to be executed +# when there is an edit event. +# +# Usage: +# tableAddEditCallback <tab> <cbname> +# +# <cbname> specifies a procedure to be called whenever the table editor +# Apply button has been pressed. Procedures are called as +# +# <cbname> name row col new_string +# +# where 'name' is the table name, 'row' and 'col' are the coordinates of the +# edited cell and 'new_string' is the new value inserted in the table. Reg- +# istered procedures are required to declare all these arguments but do not +# need to use them. + +proc tableAddEditCallback { tab cbname } { + global tabEditCB + lappend tabEditCB(${tab}) $cbname +} + + +# TABLECREATE -- Create a named instance of the Table meta-widget. The +# individual objects in the meta-widget are created dynamically and the +# entire thing is created as a child of the named parent object. The +# standard callbacks are assigned and the table is initialized, however +# it is the callers responsibility to adjust the parent's layout to make +# the meta-widget visible and assign any constraint callbacks. +# +# Usage: +# tableCreate <tab> <nrows> <ncols> <data> +# +# The <data> is specified as a Tcl list of the form: +# +# { {r1c1 r1c2 ... r1cN} +# {r2c1 r2c2 ... r2cN} +# : +# {rNc1 rNc2 ... rNcN} } +# +# String values must be quoted, rows/cols will be truncated or cleared if +# the specified table size does not agree with the size of the data table +# being loaded. + +set tabBGWidgets { \ + TABTab TABRowTab TABColTab TABLabel TABColScroll \ + TABRowScroll TABEditApply TABEditClear TABEditCancel \ + TABEditApply TABEditClear TABEditCancel TABEditText \ + TABEditFrame TABEditMenuBar TABEditMenuFrame \ +} +set tabFGWidgets { \ + TABTab TABRowTab TABColTab TABLabel TABColScroll \ + TABRowScroll TABEditApply TABEditClear TABEditCancel \ + TABEditApply TABEditClear TABEditCancel TABEditText \ +} + +proc tableCreate { tab nrows ncols data } { + global tabNrows tabNcols tabRowHeights tabColWidths + global tabHeight tabWidth tabDebug tabOption + global tabEditCB tabSelectionCB tabUnSelectionCB + global tabSelected tabBGWidgets tabFGWidgets + + set err "" + catch { + if { ![info exists tabOption(${tab},RowLabelCols)] } { + set tabOption(${tab},RowLabelCols) $tabOption(name,RowLabelCols) + } + } err + if {$err != ""} { + set tabOption(${tab},RowLabelCols) $tabOption(name,RowLabelCols) + } + set err "" + catch { + if { ![info exists tabOption(${tab},ColLabelRows)] } { + set tabOption(${tab},ColLabelRows) $tabOption(name,ColLabelRows) + } + } err + if {$err != ""} { + set tabOption(${tab},ColLabelRows) $tabOption(name,ColLabelRows) + } + + + set tabNrows(${tab},data) $nrows + set tabNcols(${tab},data) $ncols + set tabNrows(${tab},rows) $nrows + set tabNcols(${tab},rows) $tabOption(${tab},RowLabelCols) + set tabNrows(${tab},cols) $tabOption(${tab},ColLabelRows) + set tabNcols(${tab},cols) $ncols + set tabData($tab) $data + + # Initialize with a default row height. + set rh [send ${tab}Tab get rowHeight] + set tabRowHeights($tab,default) $rh + for {set i 1} {$i <= $nrows} {incr i} { + set tabRowHeights($tab,$i) $rh + } + + # Initialize with a default column width. + set cw [send ${tab}Tab get defaultWidth] + for {set i 1} {$i <= $ncols} {incr i} { + set tabColWidths($tab,$i) $cw + } + + # Initialize the table. + send ${tab}Tab setTable $nrows $ncols $data + + # Initialize the labels. + tableSetDefaultLabels $tab + + # Save the table dimensions. + set tabHeight($tab) [ tableGetHeight $tab ] + set tabWidth($tab) [ tableGetWidth $tab ] + + # Set the default table translations. + tableSetDefaultTranslations $tab + + # Attach the default-callbacks to the new Table. + tableAddCallbacks $tab + + # Set Default Scrollbars for the table. + tableSetDefaultScrollbars $tab yes + + # Default the colors. + set err "" + catch { + if { ![info exists tabOption(${tab},HighlightColor)] != 0 } { + set tabOption(${tab},HighlightColor) $tabOption(name,HighlightColor) + } + } err + if {$err != ""} { + set tabOption(${tab},HighlightColor) $tabOption(name,HighlightColor) + } + set err "" + catch { + if { ![info exists tabOption(${tab},Background)] != 0 } { + set tabOption(${tab},Background) $tabOption(name,Background) + } + } err + if {$err != ""} { + set tabOption(${tab},Background) $tabOption(name,Background) + } + set err "" + catch { + if { ![info exists tabOption(${tab},Foreground)] != 0 } { + set tabOption(${tab},Foreground) $tabOption(name,Foreground) + } + } err + if {$err != ""} { + set tabOption(${tab},Foreground) $tabOption(name,Foreground) + } + + regsub -all TAB $tabBGWidgets $tab bgwidgets + foreach w $bgwidgets { + send $w set background $tabOption(${tab},Background) + } + regsub -all TAB $tabFGWidgets $tab fgwidgets + foreach w $fgwidgets { + send $w set foreground $tabOption(${tab},Foreground) + } + + # Default selections. + set tabSelected(${tab},Row) {} + set tabSelected(${tab},Col) {} + set tabSelected(${tab},Cell) {} + + set tabSelectionCB(${tab},Row) {} + set tabSelectionCB(${tab},Col) {} + set tabSelectionCB(${tab},Cell) {} + set tabUnSelectionCB(${tab},Row) {} + set tabUnSelectionCB(${tab},Col) {} + set tabUnSelectionCB(${tab},Cell) {} + set tabEditCB(${tab}) {} +} + + +# TABLESETDATA -- Set the data elements of a table meta-widget. +# +# Usage: +# tableSetData <tab> <data> +# +# where <tab> is the table name given when the meta-widget was created, and +# <data> is of the form: +# +# { {r1c1 r1c2 ... r1cN} +# {r2c1 r2c2 ... r2cN} +# : +# {rNc1 rNc2 ... rNcN} } + +proc tableSetData { tab data } { + global tabNrows tabNcols + + send ${tab}Tab setTable $tabNrows(${tab},data) $tabNcols(${tab},data) $data + +# send ${tab}Tab setTable \ +# [expr ($tabNrows(${tab},data) + 20)] \ +# [expr ($tabNcols(${tab},data) + 20)] \ +# $data +} + + +# TABLESETSIZE -- Set the size of a table meta-widget. +# +# Usage: +# tableSetSize <tab> <nrows> <ncols> +# + +proc tableSetSize { tab nrows ncols } { + global tabNrows tabNcols tabOption + global tabHeight tabWidth tabRowHeights + + set tabNrows(${tab},data) $nrows + set tabNcols(${tab},data) $ncols + + set tabNrows(${tab},rows) $nrows + set tabNcols(${tab},rows) $tabOption(${tab},RowLabelCols) + set tabNrows(${tab},cols) $tabOption(${tab},ColLabelRows) + set tabNcols(${tab},cols) $ncols + + send ${tab}Tab setTableSize $nrows $ncols + send ${tab}RowTab setTableSize $tabNrows(${tab},rows) $tabNcols(${tab},rows) + send ${tab}ColTab setTableSize $tabNrows(${tab},cols) $tabNcols(${tab},cols) + + set rh [send ${tab}Tab get rowHeight] + set tabRowHeights($tab,default) $rh + for {set i 1} {$i <= $nrows} {incr i} { + set tabRowHeights($tab,$i) $rh + } + + # Save the table dimensions. + set tabHeight($tab) [ tableGetHeight $tab ] + set tabWidth($tab) [ tableGetWidth $tab ] + + #tableSetDefaultScrollbars $tab yes +} + + +# TABLESETCOLUMNLABELS -- Set the column header labels for a table. +# meta-widget. +# +# Usage: +# tableSetColumnLabels <tab> <column_labs> +# +# where <tab> is the table name given when the meta-widget was created, and +# <data> is of the form: +# +# { { r1c1 } { r1c2 } ... { r1cN } } + +proc tableSetColumnLabels { tab col_labs } { + global tabNrows tabNcols + send ${tab}ColTab \ + setTable $tabNrows(${tab},cols) $tabNcols(${tab},cols) $col_labs +} + + +# TABLESETROWLABELS -- Set the row header labels for a table. +# meta-widget. +# +# Usage: +# tableSetColumnLabels <tab> <row_labs> +# +# where <tab> is the table name given when the meta-widget was created, and +# <data> is of the form: +# +# { {r1c1 r1c2 ... r1cN} } + +proc tableSetRowLabels { tab row_labs } { + global tabNrows tabNcols + send ${tab}RowTab \ + setTable $tabNrows(${tab},rows) $tabNcols(${tab},rows) $row_labs +} + + +# TABLESETCOLLABELSATTR -- Set the column header labels for a table +# meta-widget. +# +# Usage: +# tableSetColumnLabels <tab> <attr> <value> [<row>] +# +# where <attr> is one of +# +# background background color +# foreground foreground color +# width column width +# justify label justification + +proc tableSetColLabelsAttr { tab attr value args } { + if {$args != ""} { + send ${tab}ColTab setRowAttr $args $attr $value + } else { + send ${tab}ColTab setRowAttr 1 $attr $value + } +} + + +# TABLESETROWLABELSATTR -- Set the row header labels for a table meta-widget. +# +# Usage: +# tableSetRowLabelsAttr <tab> <attr> <value> [<col>] +# +# where <attr> is one of +# +# background background color +# foreground foreground color +# width column width +# justify label justification + +proc tableSetRowLabelsAttr { tab attr value args } { + if {$args != ""} { + send ${tab}RowTab setColAttr $args $attr $value + } else { + send ${tab}RowTab setColAttr 1 $attr $value + } +} + + +# TABLEGETROWLABELSATTR -- Get the row header labels for a table meta-widget. +# +# Usage: +# value = tableGetRowLabelsAttr <tab> <attr> [<col>] +# +# where <attr> is one of +# +# background background color +# foreground foreground color +# width column width +# justify label justification + +proc tableGetRowLabelsAttr { tab attr args } { + if {$args != ""} { + return [ send ${tab}RowTab getColAttr $args $attr ] + } else { + return [ send ${tab}RowTab getColAttr 1 $attr ] + } +} + + +# TABLEGETCOLLABELSATTR -- Get the column header labels for a table. +# meta-widget. +# +# Usage: +# value = tableGetColLabelsAttr <tab> <attr> [<row>] +# +# where <attr> is one of +# +# background background color +# foreground foreground color +# width column width +# justify label justification + +proc tableGetColLabelsAttr { tab attr args } { + if {$args != ""} { + return [ send ${tab}ColTab getRowAttr $args $attr ] + } else { + return [ send ${tab}ColTab getRowAttr 1 $attr ] + } +} + + +# TABLESETROWLABELATTR -- Set the specified attribute for the row label table. +# +# Usage: +# tableSetRowLabelAttr <tab> <row> <attr> <value> [<row>] +# +# The cell position is given as a 1-indexed array element where the UL +# of the table is cell (1,1). Allowed attributes for a cell include: +# +# label label text (string) +# background background color (string) +# foreground foreground color (string) + +proc tableSetRowLabelAttr { tab row attr value args } { + if {$args != ""} { + send ${tab}RowTab setCellAttr $row $args $attr $value + } else { + send ${tab}RowTab setCellAttr $row 1 $attr $value + } +} + + +# TABLESETCOLLABELATTR -- Get the specified attribute for the col label table. +# +# Usage: +# value = tableSetColLabelAttr <tab> <col> <attr> <value> [<row>] +# +# The cell position is given as a 1-indexed array element where the UL +# of the table is cell (1,1). Allowed attributes for a cell include: +# +# label label text (string) +# background background color (string) +# foreground foreground color (string) + +proc tableSetColLabelAttr { tab col attr value args } { + if {$args != ""} { + send ${tab}ColTab setCellAttr $args $col $attr $value + } else { + send ${tab}ColTab setCellAttr 1 $col $attr $value + } +} + + +# TABLEGETCELLATTR -- Get the specified attribute for the cell. +# +# Usage: +# value = tableGetCellAttr <tab> <row> <col> <attr> +# +# The cell position is given as a 1-indexed array element where the UL +# of the table is cell (1,1). Allowed attributes for a cell include: +# +# label label text (string) +# background background color (string) +# foreground foreground color (string) + +proc tableGetCellAttr { tab row col attr } { + return [ send ${tab}Tab getCellAttr $row $col $attr ] +} + + +# TABLESETCELLATTR -- Set the specified attribute for the cell. +# +# Usage: +# tableSetCellAttr <tab> <row> <col> <attr> <value> +# +# The cell position is given as a 1-indexed array element where the UL +# of the table is cell (1,1). Allowed attributes for a cell include: +# +# label label text (string) +# background background color (string) +# foreground foreground color (string) + +proc tableSetCellAttr { tab row col attr value } { + send ${tab}Tab setCellAttr $row $col $attr $value +} + + +# TABLEGETROWATTR -- Get the specified attribute for the row. +# +# Usage: +# value = tableGetCellAttr <tab> <row> <attr> +# +# The row position is given as a 1-indexed array element where the UL +# of the table is cell (1,1). Allowed attributes for a row include: +# +# background background color +# foreground foreground color + +proc tableGetRowAttr { tab row attr } { + return [ send ${tab}Tab getRowAttr $row $attr ] +} + + +# TABLESETROWATTR -- Set the specified attribute for the row. +# +# Usage: +# tableSetRowAttr <tab> <row> <attr> <value> +# +# The row position is given as a 1-indexed array element where the UL +# of the table is cell (1,1). Allowed attributes for a row include: +# +# background background color +# foreground foreground color + +proc tableSetRowAttr { tab row attr value } { + send ${tab}Tab setRowAttr $row $attr $value +} + + +# TABLEGETCOLATTR -- Get the specified attribute for the column. +# +# Usage: +# value = tableGetColAttr <tab> <col> <attr> +# +# The column position is given as a 1-indexed array element where the UL +# of the table is cell (1,1). Allowed attributes for a column include: +# +# width column width (pixels) +# background background color (string) +# foreground foreground color (string) +# justify text justification (string) + +proc tableGetColAttr { tab col attr } { + return [ send ${tab}Tab getColAttr $col $attr ] +} + + +# TABLESETCOLATTR -- Set the specified attribute for the column. +# +# Usage: +# tableSetColAttr <tab> <col> <attr> <value> +# +# The column position is given as a 1-indexed array element where the UL +# of the table is cell (1,1). Allowed attributes for a column include: +# +# width column width (pixels) +# background background color (string) +# foreground foreground color (string) +# justify text justification (string) + +proc tableSetColAttr { tab col attr value } { + global tabColWidths tabNcols + + send ${tab}Tab setColAttr $col $attr $value + if {$attr == "width"} { + set tabColWidths(${tab},$col) $value + } +} + + +# TABLEDELETECOL -- Delete the specified column from the named table. +# +# Usage: +# tableDeleteCol <tab> <col> + +proc tableDeleteCol { tab col } { + global tabColWidths tabNcols + + send ${tab}Tab deleteCol $col + send ${tab}ColTab deleteCol $col + incr tabNcols(${tab},data) -1 + catch { unset tabColWidths(${tab},$col) } err +} + + +# TABLEDELETEROW -- Delete the specified row from the named table. +# +# Usage: +# tableDeleteRow <tab> <row> + +proc tableDeleteRow { tab row } { + global tabRowHeights tabNrows + + send ${tab}Tab deleteRow $row + send ${tab}RowTab deleteRow $row + incr tabNrows(${tab},data) -1 + catch { unset tabRowHeights(${tab},$row) } err +} + + +# TABLEDADDCOL -- Add a column to the named table at the specified position. +# +# Usage: +# tableAddCol <tab> <col> <width> + +proc tableAddCol { tab col width args} { + global tabColWidths tabNcols + + send ${tab}Tab addCol $col $width $args + send ${tab}ColTab addCol $col $width $args + incr tabNcols(${tab},data) + + set ncols $tabNcols(${tab},data) + if {$col == "first"} { + set colnum 1 + } elseif {$col == "last"} { + set colnum $tabNcols(${tab},data) + } else { + set colnum $col + } + + # Update the column widths. + for {set c $ncols} {$c > $colnum} {incr c -1} { + set tabColWidths(${tab},$c) $tabColWidths(${tab},[expr ($c - 1)]) + } + set tabColWidths(${tab},$colnum) $width +} + + +# TABLEADDROW -- Add a rows to the named table at the specified position. +# +# Usage: +# tableAddRow <tab> <row> + +proc tableAddRow { tab row args } { + global tabRowHeights tabNrows + + send ${tab}Tab addRow $row $args + send ${tab}RowTab addRow $row $args + incr tabNrows(${tab},data) + set tabRowHeights(${tab},$row) $tabRowHeights(${tab},default) +} + + +# TABLEGETNROWS -- Return the number of rows in a named table. +# +# Usage: +# nrows = tableGetNrows <tab> + +proc tableGetNrows { tab } { + global tabNrows + return $tabNrows(${tab},data) +} + + +# TABLEGETNCOLS -- Return the number of columns in a named table. +# +# Usage: +# ncols = tableGetNcols <tab> + +proc tableGetNcols { tab } { + global tabNcols + return $tabNcols(${tab},data) +} + + +# TABLEGETHEIGHT -- Compute the height of the table given varying row heights. +# +# Usage: +# height = tableGetHeight <tab> + +proc tableGetHeight { tab } { + return [ send ${tab}Tab get height ] +} + + +# TABLEGETWIDTH -- Compute the width of the table given varying column widths. +# +# Usage: +# width = tableGetWidth <tab> + +proc tableGetWidth { tab } { + return [ send ${tab}Tab get width ] +} + + +# TABLEGETSELECTED -- Return a list of the selected items. +# +# Usage: list = tableGetSelected tab type +# +# where <type> is 'Row', 'Col', or 'Cell'. + +proc tableGetSelected { tab type } { + global tabSelected + return $tabSelected(${tab},${type}) +} + + + +# TABLESELECTROW -- User-selectable row procedure. Row may be the string +# "all" in which case we select all rows in the table, otherwise may sure +# selection is unique. + +proc tableSelectRow { tab row } { + global tabSelected tabOption tabNrows + + set color $tabOption(${tab},HighlightColor) + if {$row == "all"} { + for {set i 0} {$i < $tabNrows(${tab},data)} {incr i} { + set index [lsearch $tabSelected(${tab},Row) $row ] + if {$index < 0} { + lappend tabSelected(${tab},Row) $i + tableSetRowAttr ${tab} $i background $color + tableSetRowAttr ${tab}Row $i background $color + } + } + } else { + set index [lsearch $tabSelected(${tab},Row) $row ] + if {$index < 0} { + lappend tabSelected(${tab},Row) $row + tableSetRowAttr ${tab} $row background $color + tableSetRowAttr ${tab}Row $row background $color + } + } +} + + +# TABLESELECTCOL -- User-selectable column procedure. Col may be the string +# "all" in which case we select all cols in the table, otherwise may sure +# selection is unique. + +proc tableSelectCol { tab col } { + global tabSelected tabOption tabNcols + + set color $tabOption(${tab},HighlightColor) + if {$col == "all"} { + for {set i 0} {$i < $tabNcols(${tab},data)} {incr i} { + set index [lsearch $tabSelected(${tab},Col) $col ] + if {$index < 0} { + lappend tabSelected(${tab},Col) $i + tableSetColAttr ${tab} $i background $color + tableSetColAttr ${tab}Col $i background $color + } + } + } else { + set index [lsearch $tabSelected(${tab},Col) $col ] + if {$index < 0} { + lappend tabSelected(${tab},Col) $col + tableSetRowAttr ${tab} $col background $color + tableSetRowAttr ${tab}Col $col background $color + } + } +} + + +# TABLESELECTCELL -- User-callable cell selection procedure + +proc tableSelectCell { tab col row } { + global tabSelected tabOption + + set color $tabOption(${tab},HighlightColor) + set index [lsearch $tabSelected(${tab},Col) [list $row $col] ] + if {$index < 0} { + lappend tabSelected(${tab},Cell) [list $row $col] + tableSetCellAttr ${tab} $row $col background $color + } +} + + +# TABLEUNSELECTROW -- Deselect the specified row. + +proc tableUnSelectRow { tab row } { + global tabSelected tabOption tabNrows + + set color $tabOption(${tab},Background) + if {$row == "all"} { + for {set i 0} {$i < $tabNrows(${tab},data)} {incr i} { + set index [lsearch $tabSelected(${tab},Row) $i ] + if {$index >= 0} { + set tabSelected(${tab},Row) \ + [ lreplace $tabSelected(${tab},Row) $index $index ] + tableSetRowAttr ${tab} $i background $color + tableSetRowAttr ${tab}Row $i background $color + } + } + } else { + # Delete it from the list. + set index [lsearch $tabSelected(${tab},Row) $row ] + if {$index >= 0} { + set tabSelected(${tab},Row) \ + [ lreplace $tabSelected(${tab},Row) $index $index ] + tableSetRowAttr ${tab} $row background $color + tableSetRowAttr ${tab}Row $row background $color + } + } +} + + +# TABLEUNSELECTCOL -- Deselect the specified col. + +proc tableUnSelectCol { tab col } { + global tabSelected tabOption tabNrows + + set color $tabOption(${tab},Background) + if {$col == "all"} { + for {set i 0} {$i < $tabNcols(${tab},data)} {incr i} { + set index [lsearch $tabSelected(${tab},Col) $i ] + if {$index >= 0} { + set tabSelected(${tab},Col) \ + [ lreplace $tabSelected(${tab},Col) $index $index ] + tableSetColAttr ${tab} $i background $color + tableSetColAttr ${tab}Col $i background $color + } + } + } else { + # Delete it from the list. + set index [lsearch $tabSelected(${tab},Col) $col ] + if {$index >= 0} { + set tabSelected(${tab},Col) \ + [ lreplace $tabSelected(${tab},Col) $index $index ] + tableSetColAttr ${tab} $col background $color + tableSetColAttr ${tab}Col $col background $color + } + } +} + + +# TABLEUNSELECTCELL -- Deselect the specified cell. + +proc tableUnSelectCell { tab col row } { + global tabSelected tabOption + + set val [list $row $col] + set index [lsearch $tabSelected(${tab},Cell) $val ] + set color $tabOption(${tab},Background) + + # Delete it from the list. + if {$index >= 0} { + set tabSelected(${tab},Cell) \ + [ lreplace $tabSelected(${tab},Cell) $index $index ] + tableSetCellAttr ${tab} $row $col background $color + } +} + + + +#============================================================================== +# TABLEDIT -- Enable the cell editor +#============================================================================== + +set tabEditRow 0 +set tabEditCol 0 +set tabEditValue "" + +set tableEditorUp 0 + +proc tableEdit { name x y } { + global tabEditValue tabEditRow tabEditCol tableEditCB, tableEditorUp + + regsub Tab $name "" tab + + set ry [tablePos2CellY $tab $y] + set rx [tablePos2CellX $tab $x] + + if {$rx < 0 || $ry < 0} \ + return + + set newcell 0 + if {$tabEditRow != $rx || $tabEditCol != $ry} { + set newcell 1 + } + + set tabEditCol [tablePos2CellX $tab $x] + set tabEditRow [tablePos2CellY $tab $y] + set tabEditValue [tableGetCellAttr $tab $tabEditRow $tabEditCol label] + + if {$tableEditorUp == 0 || $newcell == 1} { + send ${tab}EditApply addCallback tableEditApply + send ${tab}EditCancel addCallback tableEditCancel + send ${tab}EditClear addCallback tableEditClear + send ${tab}EditText addCallback tableEditLoad + send ${tab}EditText set string $tabEditValue + send ${tab}EditShell move $x [expr ($y + 50)] + send ${tab}EditShell map + set tableEditorUp 1 + } else { + send ${tab}EditApply deleteCallback tableEditApply + send ${tab}EditCancel deleteCallback tableEditCancel + send ${tab}EditClear deleteCallback tableEditClear + send ${tab}EditText deleteCallback tableEditLoad + send ${tab}EditShell unmap + set tableEditorUp 0 + } +} + +proc tableEditApply { button args } { + global tabEditValue tabEditRow tabEditCol tabEditCB tabEditorUp + regsub EditApply $button "" tab + + set str [send ${tab}EditText get string] + + tableSetCellAttr $tab $tabEditRow $tabEditCol label $str + set tabEditValue $str + + # Now do the user-defined selection callbacks. + if { [llength $tabEditCB(${tab})] > 0} { + foreach cb $tabEditCB(${tab}) {$cb $tab $tabEditRow $tabEditCol "$str"} + } + + # Close the window. + send ${tab}EditApply deleteCallback tableEditApply + send ${tab}EditCancel deleteCallback tableEditCancel + send ${tab}EditClear deleteCallback tableEditClear + send ${tab}EditText deleteCallback tableEditLoad + send ${tab}EditShell unmap + set tableEditorUp 0 +} + +proc tableEditLoad { widget mode pattern args } { + regsub EditText $widget "" tab + tableEditApply ${tab}EditApply +} + +proc tableEditClear { button args } { + global tabEditValue + + regsub EditClear $button "" tab + send ${tab}EditText set string "" +} + +proc tableEditCancel { button args } { + global tableEditValue tableEditorUp + + regsub EditCancel $button "" tab + send ${tab}EditShell unmap + send ${tab}EditApply deleteCallback tableEditApply + send ${tab}EditCancel deleteCallback tableEditCancel + send ${tab}EditClear deleteCallback tableEditClear + send ${tab}EditText deleteCallback tableEditLoad + set tableEditorUp 0 +} + + +############################################################################### +# +# Private Procedures +# +############################################################################### + + +# TABLEADDCALLBACKS -- Add the default widget callbacks. + +proc tableAddCallbacks { tab } { + + # Attach the scrollbars actions. + if {[ tableOption $tab RowScroll] == "yes"} { + send ${tab}RowScroll addCallback tableJumpScroll + } else { + send ${tab}RowScroll "unmap ; set width 0" + } + + if {[ tableOption $tab ColScroll] == "yes"} { + send ${tab}ColScroll addCallback tableJumpScroll + } else { + send ${tab}Label set height 0 + send ${tab}ColScroll "unmap ; set height 0" + } + + if {[tableOption $tab Tracking] == "no"} { + send ${tab}Label set label "" + send ${tab}Label set width 50 + } + + # Setup a resize handler that will adjust the scrollbars/viewports. + send ${tab}TableFrame addEventHandler tableResizeHandler structureNotifyMask +} + + +# TABLERESIZEHANDLER -- Resize callbacks, called as an eventHandler when +# the parent window or the table meta-widget changes size. All we need to +# do here is reset the scrollbars to reflect the new size. + +proc tableResizeHandler { table args } { + regsub TableFrame $table "" tab + #tableSetDefaultScrollbars $tab no + tableSetDefaultScrollbars $tab yes +} + + +# TABLETRACK -- Track the motion in the table. + +proc tableTrack { name x y } { + regsub Tab $name "" tab + if {[ tableOption $tab Tracking] == "no"} { + return + } + + set nr [tableGetNrows $tab] + set nc [tableGetNcols $tab] + set col [tablePos2CellX $tab $x] + set row [tablePos2CellY $tab $y] + if {$col < 0 || $row < 0} { + send ${tab}Label set label " " + } else { + send ${tab}Label set label [ format "(%3d,%3d)" $row $col ] + } +} + + +# TABLESELECT -- Do the default selection callback which applies to rows, +# columns and cells. + +proc tableSelect { name type x y } { + global tabOption tabSelected tabSelectionCB tabUnSelectionCB + + + regsub Row $name "" rc + regsub Col $name "" cc + + if {$type == "Row"} { + if {$rc == $name || [ tableOption $name RowSelect ] == "no"} \ + return + regsub ${type}Tab $name "" tab + set col [tablePos2CellX $tab $x] + set row [tablePos2CellY $tab $y] + set val $row + } elseif {$type == "Col"} { + if {$cc == $name || [ tableOption $name ColSelect ] == "no"} \ + return + regsub ${type}Tab $name "" tab + set col [tablePos2CellX $tab $x] + set row [tablePos2CellY $tab $y] + set val $col + } elseif {$type == "Cell"} { + if {$rc != $name && $cc != $name} \ + return + if {[ tableOption $name CellSelect ] == "no"} \ + return + regsub Tab $name "" tab + set col [tablePos2CellX $tab $x] + set row [tablePos2CellY $tab $y] + set val [list $row $col] + } + + if {$col < 0 || $row < 0} \ + return + + set index [ lsearch $tabSelected(${tab},${type}) $val ] + set color $tabOption(${tab},HighlightColor) + + # If we're doing a radio selection, turn off anything already selected. + + if {[ tableOption $tab ${type}MultiSelect] == "no"} { + if { [llength $tabSelected(${tab},${type})] == 1} { + tableSet${type}Attr ${tab} \ + [lindex $tabSelected(${tab},${type}) 0] \ + background $tabOption(${tab},Background) + tableSet${type}Attr ${tab}${type} \ + [lindex $tabSelected(${tab},${type}) 0] \ + background $tabOption(${tab},Background) + + # Now do the user-defined un-selection callbacks. + if { [llength $tabUnSelectionCB(${tab},${type})] > 0} { + foreach cb $tabUnSelectionCB(${tab},${type}) { + $cb $tab $row $col $x $y 0 + } + } + + set tabSelected(${tab},${type}) [list $val ] + + if {$type == "Row"} { + foreach c $tabSelected(${tab},Col) { + tableSetColAttr ${tab} $c background $color + } + } elseif {$type == "Col"} { + foreach c $tabSelected(${tab},Row) { + tableSetRowAttr ${tab} $c background $color + } + } + } else { + lappend tabSelected(${tab},${type}) $val + } + } else { + if { $index < 0} { + lappend tabSelected(${tab},${type}) $val + } + } + + # If this has already been selected, toggle it. + if { $index >= 0} { + if {$type != "Cell"} { + tableSet${type}Attr ${tab} \ + [lindex $tabSelected(${tab},${type}) $index] \ + background $tabOption(${tab},Background) + tableSet${type}Attr ${tab}${type} \ + [lindex $tabSelected(${tab},${type}) $index] \ + background $tabOption(${tab},Background) + + # Now do the user-defined un-selection callbacks. + if { [llength $tabUnSelectionCB(${tab},${type})] > 0} { + foreach cb $tabUnSelectionCB(${tab},${type}) { + $cb $tab $row $col $x $y 0 + } + } + + } else { + tableSet${type}Attr ${tab} \ + $row $col background $tabOption(${tab},Background) + + # Now do the user-defined selection callbacks. + if { [llength $tabUnSelectionCB(${tab},${type})] > 0} { + foreach cb $tabUnSelectionCB(${tab},${type}) { + $cb $tab $row $col $x $y 0 + } + } + } + + # Delete it from the list + set tabSelected(${tab},${type}) \ + [ lreplace $tabSelected(${tab},${type}) $index $index ] + + # Go back and re-select the row/col intersection but don't + # generate an event for it, purely cosmetic. + if {$type == "Row"} { + foreach c $tabSelected(${tab},Col) { + tableSetColAttr ${tab} $c background $color + } + } elseif {$type == "Col"} { + foreach c $tabSelected(${tab},Row) { + tableSetRowAttr ${tab} $c background $color + } + } + + } else { + + # Highlight the selected item. + if {$type != "Cell"} { + tableSet${type}Attr ${tab} $val background $color + tableSet${type}Attr ${tab}${type} $val background $color + } else { + tableSet${type}Attr ${tab} $row $col background $color + } + + # Now do the user-defined selection callbacks. + if { [llength $tabSelectionCB(${tab},${type})] > 0} { + foreach cb $tabSelectionCB(${tab},${type}) { + $cb $tab $row $col $x $y 1 + } + } + } +} + + +# TABLESETDEFAULTLABELS -- Set the default labels for the table, i.e. letters +# for columns headings and numbers for the row labels. +# +# Usage: +# tableSetDefaultLabels <tab> + +proc tableSetDefaultLabels { tab } { + # Set the default Row labels, i.e numbers + tableSetDefaultRowLabels $tab + + # Now set the default Column Labels, i.e. letters + tableSetDefaultColLabels $tab +} + + +# TABLESETDEFAULTTRANSLATIONS -- Set the default translations for the widget. + +proc tableSetDefaultTranslations { tab } { + + if {[ tableOption $tab DefaultTranslations ] == "no"} { + return + } + + # Set the coord tracking translations. + set trans1 "" + if {[ tableOption $tab Tracking ] == "yes"} { + set trans1 { \ + <Motion>:call(tableTrack,$name,$x,$y) + } + } + + set trans2 "" + if {[ tableOption $tab CellSelect ] == "yes"} { + set trans2 { \ + <Btn1Down>:call(tableSelect,$name,Cell,$x,$y) + } + } + + set trans3 "" + if {[ tableOption $tab Editable ] == "yes"} { + set trans3 { \ + <Btn3Down>:call(tableEdit,$name,$x,$y) + } + } + set trans "$trans1 $trans2 $trans3" + send ${tab}Tab set translations $trans + + + # Set the row-selectable translations. + if {[ tableOption $tab RowSelect ] == "yes"} { + send ${tab}RowTab set translations \ + "<Btn1Down>: call(tableSelect,\$name,Row,\$x,\$y)" + } + + # Set the col-selectable translations. + if {[ tableOption $tab ColSelect ] == "yes"} { + send ${tab}ColTab set translations \ + "<Btn1Down>: call(tableSelect,\$name,Col,\$x,\$y)" + } +} + + +# TABLESETDEFAULTSCROLLBARS -- Set the default scrollbar position and size +# in the meta-widget. + +proc tableSetDefaultScrollbars { tab init } { + global tabHeight tabWidth tabScrollSize tabScrollPos tabDebug + global tabNcols tabNrows tabColWidths + + + set visW [ send ${tab}TabView get width] + set visH [ send ${tab}TabView get height] + set rh [ send ${tab}Tab get rowHeight] + set sw [ send ${tab}Tab get shadowWidth] + set th [expr ($tabNrows(${tab},data) * ($rh + (2 * $sw)) )] + set tw 0 + for {set i 1} {$i <= $tabNcols(${tab},data)} {incr i} { + set w $tabColWidths(${tab},$i) + set tw [ expr ($tw + $w + (2 * $sw)) ] + } + set rowS [max 0.0 [min 1.0 [expr (double($visH)/double($th)) ]]] + set colS [max 0.0 [min 1.0 [expr (double($visW)/double($tw)) ]]] +#print "defScroll: data visW=$visW visH=$visH th=$th tw=$tw" +#print "defScroll: ($tab,$init) rowS = $rowS colS = $colS" + + set tabScrollSize($tab,row) $rowS + set tabScrollSize($tab,col) $colS + set tabScrollPos($tab,row) 0.0 + set tabScrollPos($tab,col) 0.0 + + if {[ tableOption $tab RowScroll] == "yes"} { + send ${tab}RowScroll setScrollbar 0.0 $tabScrollSize($tab,row) + } + if {[ tableOption $tab ColScroll] == "yes"} { + send ${tab}ColScroll setScrollbar 0.0 $tabScrollSize($tab,col) + } + + if {$init == "yes"} { + send ${tab}TabView setLocation 0.0 0.0 + send ${tab}ColTabView setLocation 0.0 0.0 + send ${tab}RowTabView setLocation 0.0 0.0 + } +} + + +# TABLEJUMPSCROLL -- Scroll the specified table. This scrolls both the +# data and row/column label tables. + +proc tableJumpScroll { widget cbtype pos } { + global scrollHeight tabWidth tabHeight tabDebug + global tabScrollSize tabScrollPos tabDebug + + if {$pos < 0.01} { + set pos 0.0 + } + + if { [string match *ColScroll $widget] } { + regsub ColScroll $widget "" tab + set y $tabScrollPos($tab,row) + send ${tab}TabView setLocation $pos $y + send ${tab}ColTabView setLocation $pos 0.0 + set tabScrollPos($tab,col) $pos + + } elseif { [string match *RowScroll $widget] } { + regsub RowScroll $widget "" tab + set x $tabScrollPos($tab,col) + send ${tab}TabView setLocation $x $pos + send ${tab}RowTabView setLocation 0.0 $pos + set tabScrollPos($tab,row) $pos + } +} + + +# TABLEOPTION -- Return any defined table option. + +proc tableOption { tab option } { + global tabOption + + set val yes + catch { + if {[info exists tabOption(${tab},${option}) ]} { + if { $tabOption(${tab},${option}) } { + set val yes + } else { + set val no + } + } + } err + + return $val +} + + +# TABLEPOS2CELLX -- Convert a widget position to a cell column number. + +proc tablePos2CellX { tab x } { + global tabColWidths tabNcols + + set nc [ tableGetNcols $tab ] + set cellX 1 + for {set w 0} {$w < $x && $cellX <= $nc} {incr cellX} { + set w [ expr ($w + $tabColWidths($tab,$cellX) + 3) ] + } + if {$x > $w} { + return -1 + } else { + return [ min [incr cellX -1] $tabNcols(${tab},data) ] + } +} + +# TABLEPOS2CELLY -- Convert a widget position to a cell row number. + +proc tablePos2CellY { tab y } { + global tabRowHeights tabNrows + + set nr [ tableGetNrows $tab ] + set cellY 1 + for {set h 0} {$h < $y && $cellY <= $nr} {incr cellY} { + set h [ expr ($h + $tabRowHeights($tab,$cellY)) + 2 ] + } + if {$y > $h} { + return -1 + } else { + return [ min [incr cellY -1] $tabNrows(${tab},data) ] + } +} + + +# TABLESETDEFAULTROWLABELS -- Utility to set the default row labels. + +proc tableSetDefaultRowLabels { tab args } { + global tabNrows tabOption + + # Set the default Row labels, i.e numbers + set rowlabs {} + for {set i 1} {$i <= $tabNrows(${tab},data)} {incr i} { + if {[ tableOption $tab DefLabels ] == "yes"} { + lappend rowlabs $i + } else { + lappend rowlabs {} + } + } + if {[ tableOption $tab RowLabels ] == "yes"} { + send ${tab}RowTab setTable $tabNrows(${tab},data) \ + $tabOption(${tab},RowLabelCols) $rowlabs + set cw [send ${tab}RowTab get defaultWidth] + send ${tab}RowTabView set width \ + [expr ($tabOption(${tab},RowLabelCols) * $cw)] + } else { + send ${tab}RowTab set width 0 + } +} + + +# TABLESETDEFAULTCOLLABELS -- Utility to set the default columns labels. + +proc tableSetDefaultColLabels { tab args } { + global tabNcols tabOption + + # Now set the default Column Labels, i.e. letters + set collabs "" + set j 65 + for {set i 1} {$i <= $tabNcols(${tab},data)} {incr i} { + if {[ tableOption $tab DefLabels ] == "yes"} { + if {$j > 90} { + set j 97 + set collabs [ format "%s { %c } " $collabs $j ] + } elseif {$j > 122} { + set j 1 + set collabs [ format "%s { %d } " $collabs $j ] + } else { + set collabs [ format "%s { %c } " $collabs $j ] + } + incr j + } else { + lappend collabs {} + } + } + if {[ tableOption $tab ColLabels ] == "yes"} { + send ${tab}ColTab setTable $tabOption(${tab},ColLabelRows) \ + $tabNcols(${tab},data) [ list $collabs ] + send ${tab}ColTabView set height \ + [expr ($tabOption(${tab},ColLabelRows) * 21)] + send ${tab}Spacer1 set height \ + [expr ($tabOption(${tab},ColLabelRows) * 24)] + send ${tab}Spacer2 set height \ + [expr ($tabOption(${tab},ColLabelRows) * 24)] + } else { + send ${tab}ColTab set height 0 + } +} + + +################################################################################ + + +################################################################################ + + + +activate + + +appExtend { + *tclObjects:\ + toplevel TopLevelShell tcl_panel\ + tcl_panel Layout tclLayout\ + tclLayout Group tclCmdGroup\ + tclCmdGroup Layout tclCmd\ + tclCmd Command tclClear\ + tclCmd Command tclExecute\ + tclCmd Command tclDismiss\ + tclLayout Frame tclFrame\ + tclFrame AsciiText tclEntry + + + !-------------------------------- + ! Define a debug Tcl shell. + !-------------------------------- + *tcl_panel.width: 550 + *tcl_panel.height: 180 + *tcl_panel.title: Debug TCL Command Entry + *tclLayout*borderWidth: 0 + *tclLayout*shrinkToFit: True + *tclLayout*Frame.frameType: sunken + *tclLayout*Frame.frameWidth: 2 + *tclLayout.layout: vertical { \ + tclCmdGroup < +inf -inf * > \ + tclFrame < +inf -inf * +inf -inf> \ + } + *tclEntry*foreground: black + *tclEntry*editType: edit + *tclEntry*type: string + *tclEntry*font: 7x13 + *tclEntry*scrollVertical: Always + *tclEntry*scrollHorizontal: whenNeeded + + *tclCmdGroup.label: + *tclCmdGroup.outerOffset: 0 + *tclCmdGroup.innerOffset: 0 + *tclCmd.layout: vertical { \ + 5 \ + horizontal { 5 tclClear 3 tclExecute 10 < +inf -10> tclDismiss 5 } \ + 5 \ + } + *tclClear.label: Clear + *tclExecute.label: Execute + *tclDismiss.label: Dismiss + +} ; createObjects tclObjects + + + +################################################ +# Define some TCL debug procedures. +################################################ + +proc tclCommandClear {widget args} { + send tclEntry set string "" +} ; send tclClear addCallback tclCommandClear + +proc tclCommandExecute {widget args} { + send server [send tclEntry {get string}] +} ; send tclExecute addCallback tclCommandExecute + +proc tclCommand {widget mode command args} { + send server $command +} ; send tclEntry addCallback tclCommand + +proc tclClose {widget args} { + send tcl_panel unmap +} ; send tclDismiss addCallback tclClose + +send tclShell addCallback "send tcl_panel map" + |