Summary edit
The program below has been developed further by Tom Turkey
.From its homepage at sf.net, version 13.4.22.12, 2013-04-22:tk-number (or tk#) is a spreadsheet that uses names rather than numbers for the rows and columns. Any tcl expression and even user written procedures can be used in any cell.
Cells can be conditionally highlighted in color, font, relief and several other ways.
Code edit
# tk#.tcl --
#
# A simple spreadsheet especially designed to show off the
# properties of tcl/tk.
#
# Copyright (c) 1997 GPL / Martin Vermeer & The tk# Team
# mv@fgi.fi
#
# Click "About" for info on copying and lack of guarantees :-)
#
#Versions:
# MV 06-Sep-97 Base version
# MV 08-Sep-97 Changes mainly in ReDisplay to improve performance
# MV 10-Sep-97 Changes due to remarks by Bruce Gingery:
# Quit panel added "cancel"
# Colour choice cancel error fixed
# Current cell uses textbg as fg for clarity
# Clear added to Format menu
# Selected link paint in on-line manual
# Manual language improvement + Quickstart addition
# MV 11-Sep-97 Fixed watch cursor bug in rename row/col
# Fixed multi-word left align format bug
# Corrected manual explanation of [Sum ...] etc. functions
# Added tagging of selected rows/columns
# MV 12-Sep-97 Added select match string construction for aggregates
# Fixed watch cursor bug Select Box
# Fixed current cell hilite bug Recalc-Sel
# MV 14-Sep-97 Added functions AboveCell...RightCell; Today, USAtoday.
# Removed set "Modified" flag if cell content unchanged.
# Template variable $i packed in parentheses to prevent
# match between, e.g., "Row1" and "Row10".
# Added REPOSITORIES for function and other definitions,
# as suggested by Bruce Gingery to support extensibility.
# MV 15-Sep-97 Called clock control buttons Start and Stop.
# Multiple cmd line load filenames implemented
# Export comma separated table added; removal of separator
# from field values.
# Create directory tl# in user root for repository files.
# MV 16-Sep-97 Fixed bug in NewNameError: used "string first" function.
# Bug in FormattedCell: test existence v-element
# MV 17-Sep-97 Final bug fixes. Redefine $initdir as [pwd] if dir
# nonexistent (other machine/user).
# Default ext .tl# for load repository.
#
proc wm args { }
# init --
#
# proc to initialize a number of things needed to be able to display
# an empty worksheet, and continue working.
#
proc init {argc argv} {
global thisformula r c rows cols headrows sidecols f v cw rowsel colsel
global autocalc modified filename exportname inspoint colours initdir
global reload tr tc defmov winsize env tcl_precisiona reps
set tcl_precision 17
set autocalc 1
# to detect multiple (overlaying) loads:
set reload 0
TemplateDefault
set rows {}
set cols {}
set sidecols {title}
set headrows {title}
set r title
set c title
foreach x {title} {set cw($x) 12; set cs($x) 0}
foreach x {title} {set rs($x) 0}
set thisformula ""
set f(title,title) ""
set rowsel {}; set colsel {}
set inspoint {^$}
# Create a dedicated data directory.
if ![file exists "$env(HOME)/tk#"] {
if [catch {exec mkdir "$env(HOME)/tk#"} result] {
puts $result
}
}
# Create a directory for user function repositories.
if ![file exists "$env(HOME)/tl#"] {
if [catch {exec mkdir "$env(HOME)/tl#"} result] {
puts $result
}
}
ColourDefault
set filename "datafile.tk#"
set exportname "datafile.dat"
set initdir [pwd]
set defmov "-"
set winsize "550x355+0+200"
set reps {}
Getrc
return
}
# ColourDefault --
#
# Set the colours to acceptable default values.
# Will be overridden by any loaded files.
#
proc ColourDefault {} {
global colours
# set up colours:
# textfg textbg for text in panels
# textcur current cell bg
# selcolour selected rows/cols
# inscolour insert col/row position
# timecolor timer (clock) cell
# iconcolour tk# icon colour
# mancolour used for titles in manual
set colourlist {textfg black textbg white \
textcur blue selcolour yellow \
inscolour red timecolour green \
iconcolour blue mancolour blue }
foreach {x y} $colourlist {
# if ![info exists colours($x)] {set colours($x) $y}
set colours($x) $y
}
return
}
# TemplateDefault --
#
# Reset "template" to empty string and "spawn" to 1.
#
proc TemplateDefault {} {
global template spawn
set spawn 1
set template ""
}
# InitIndexRow --
#
# Initialize table rs of row starting indices. Return no. of rows.
#
# Arguments:
# prows Row name list to be processed in this call.
# Either $rows or $headrows.
#
proc InitIndexRow {prows} {
global rs
set bgn 0
foreach r $prows {
array set rs "$r $bgn"
incr bgn
}
return $bgn
}
# InitIndexCol --
#
# Initialize tables cs of col starting indices and cw of col widths.
# Return total no. of character positions in a row.
#
# Arguments:
# pcols Col name list to be processed in this call.
# Either $cols or $sidecols.
#
proc InitIndexCol {pcols} {
global cs cw
set bgn 0
foreach c $pcols {
set cs($c) $bgn
incr bgn $cw($c)
}
return $bgn
}
# InitIndex --
#
# Init the row and col start and width tables for all panels.
#
proc InitIndex {} {
global rows cols headrows sidecols
global cw cs rs rowsel colsel f
InitIndexRow $headrows
InitIndexRow $rows
InitIndexCol $sidecols
InitIndexCol $cols
}
# PanelsState --
#
# Set state to "normal" or "disabled"
# to make spreadsheet panels uneditable.
#
proc PanelsState {state} {
global frq
foreach panel {corner side head main} {
$frq.$panel config -state $state
}
}
# PutIcon --
#
# Place an icon on the corner panel for About and Manual
#
# Arguments:
# w Intended width of panels "corner" and "side"
#
proc PutIcon {w} {
global colours frq
$frq.corner config -width $w -height 3
$frq.head config -height 3
$frq.side config -width $w
$frq.corner delete 1.0 end
# Construct the "tk#" icon from textual elements:
$frq.corner tag configure tktag -font "*-times-bold-i-normal-*-24*" \
-foreground $colours(mancolour) \
-background $colours(textbg) -justify center
$frq.corner tag configure hashtag -font "*-bold-o-normal-*-34*" \
-offset -15 -foreground $colours(iconcolour) \
-background $colours(textbg) -just center
$frq.corner insert end "tk" tktag
$frq.corner insert end "#\n" hashtag
$frq.head delete 1.0 end
$frq.head tag configure centered -justify center
$frq.head insert end {#### (tk-number) ####} {mancolour centered}
$frq.head insert end {
A spreadsheet with a difference!
Copyright (c) 1997 GPL / Martin Vermeer & The tk# Team.} centered
return
}
# About --
#
# Put the "About..." information into the spreadsheet.
#
proc About {} {
global frq
PanelsState normal
PutIcon 11
$frq.side delete 1.0 end
$frq.main delete 1.0 end
$frq.main tag configure centered -justify center
$frq.main insert end {
No promises, no lies; may be freely copied and
improved in agreement with the spirit of the
Gnu Public License, the text of which is
fro forma included by this reference.
} centered
PanelsState disabled
}
# HandleButton1 --
#
# Show the chapter heading for this link;
# highlight chosen link in index panel
#
proc HandleButton1 {tagname} {
global frq colours
# Only way to get rid of old highlights: Redraw it all :-(
Manual
$frq.main see $tagname.first
$frq.side tag configure $tagname -background $colours(mancolour) \
-foreground $colours(textbg)
return
}
# PutManChapter --
#
# Put a single manual chapter, with title, properly tagged, into
# both the side panel (titles only) and the main panel (titles + text).
#
# Arguments:
# tagno Tag label, only used internally to connect panels "side" and
# "main".
# text The name of the chapter = link title appearing in "side".
# chapter The plain text of the chapter (or part of it).
#
proc PutManChapter {tagno text chapter} {
global frq colours
# creates a button in the "side" panel, carrying a keyword
# which is searched for (command!) in the "main" panel if pressed.
$frq.side tag configure t$tagno -foreground $colours(mancolour) \
-background $colours(textbg) -underline true
$frq.main tag configure t$tagno -background $colours(mancolour) \
-foreground $colours(textbg) -justify center
# intelligent TOC: clicking mouse scrolls text to visibility.
$frq.side tag bind t$tagno <Button-1> [list HandleButton1 t$tagno]
$frq.side insert end $text\n t$tagno
$frq.main insert end $text t$tagno
$frq.main insert end $chapter\n
return
}
# PutTaggedText --
#
# Put an amount of text with a tag connected to it into main panel.
#
# Arguments:
# t Tag to be used.
# text Text in "main" panel to apply it to.
#
proc PutTaggedText {t text} {
.w.fr.frq.main insert end $text $t
return
}
# PutText --
#
# Put an amount of text as such to the main panel.
#
# Argument:
# text The text to put into "main" panel.
#
proc PutText {text} {.w.fr.frq.main insert end $text}
# Manual --
#
# Put the on-line manual text to the main panel screen.
#
proc Manual {} {
global frq
PanelsState normal
PutIcon 20
$frq.side delete 1.0 end
$frq.main delete 1.0 end
$frq.main configure -wrap word
# Define the formatting tags we may want to use:
$frq.main tag config tabindent -lmargin2 150
$frq.main tag configure centered -justify center
$frq.main insert end {
TK# ON-LINE MANUAL
==================
} centered
PutManChapter 1 Introduction {
tk# is a simple but intelligent spreadsheet written in tcl/tk.
The graphic abilities of tk are used to provide a grid of four\
interconnected, scrolling panels containing cells with formulas\
and data values associated with them:
<------------->
+-------------+-------------+
! corner ! head !
^ +-------------+-------------+
! ! side ! main !
v +-------------+-------------+
The top and left panels ("head" and "side"), which are narrow\
and scroll only in one\
direction, contain the names of the rows/columns.
Additionally, they may contain user defined things such as row and column\
sums, so-called "aggregates", which then also remain always visible even\
when navigating through the (large) main panel.
The scrollable main panel, on the other hand, contains the bulk\
of the data. Its scrolling behaviour helps when entering large\
amounts of data.
Because of performance reasons, you should not make the main panel larger\
than, say, 100 x 100 cells; you do wiser to split your application into\
smaller parts handled separately, save selections from them, and load these\
together. Be aware that tk# allows saving of the selection (with row/column\
titles) as well as multiple loading of data files with overlaying, cf. below.
One thing that makes tk# special is that IT DO NOT USE NUMBERS but names\
to refer to rows and columns. Also selection of ranges is based\
on names and regular expression matching, as is the evaluation of\
formulas over cell ranges (summation etc.) which is an important\
part of real life spreadsheet usage (think of bookkeeping!).
QUICKSTART:
Start up tk# without a filename, and give the following commands in\
succession:
Edit/Row Spawn
Spawn Factor: 10
Template: R$i
Edit/Col Spawn
Spawn Factor: 10
Template: C$i
This will set up a 10 x 10 spreadsheet blank to get you started.\
Just enter values, strings and expressions (see below) into the\
Formula: -box, when it has the focus (ESC toggles). Pressing\
ENTER will put them into the sheet.
}
PutManChapter 2 Functions {
Within expressions, you can use the full math facility,\
including the function library, provided with tcl; see the\
tcl manual. Also all the common operators are provided.
Formulas should be tcl expressions: one round of variable and command\
substitution is done. Please note that numerical expressions must be\
enclosed in
[expr ... ]
in order to be evaluated. The ellipsis represents your expression, e.g.
[expr sqrt(2)]
to get the square root of 2. This enclosing is achieved by pressing\
control-E in the Formula: entry box. Alternatively, use the Format menu\
item.
Strings, bot numeric and non-numeric, are copied straight over to\
the corresponding cell value. This is useful for text and\
direct data entries.
There is a set of SPECIAL or AGGREGATE FUNCTIONS implemented in tk# for\
summation and the like.
NOTE. In these summation functions, always summation over the CURRENT\
column (c) or row (r) is implied. The second argument is a MATCH STRING,\
which is matched against either row or column NAMES. This is a non-trivial
thing, quite different from traditional spreadsheets, and should be well\
understood. }
PutTaggedText {tabindent} {
[Sum c June] sums elements in THIS column and in ALL rows\
containing the string "June" in their names.
[Sum r Sales] row sum over all cols with "Sales" in name
[Av c June] average
[Cnt r Rent] no of cols named Rent-something
[wSum c June wtscol] column sum of June rows weighted\
by entries in the column "wtscol".
This one can be generalized by defining,\
in the column "wtscol" (e.g. the neighbouring column), the variable\
$wtscol by the statement "set wtscol $r".
After that, writing
[wSum c June $wtscol] will give the same sum as above. However,\
now RENAMING the weights column to something else will not break the sum!
[wAv c June $wtsrow] weighted average.
[Ssq r Gas] sum of squares
[wSsq r Gas $wtscol] same, weighted
[RMS c June] root-mean-square
[wRMS c June $wtscol] weighted
[Sd r Rent] standard deviation
[wSd r Rent] weighted
}
PutText {
These last functions are not very well tested yet.
NOTE the use of square brackets forcing, what is called\
"command substitution" i.e. execution of the procedure enclosed.
Example of use:
title csums ! -spalte1 -spalte2 -spalte3
rsums ! [Sum c sei] [Sum c sei] [Sum c sei]
--------------------+------------------------------------
seile1- [Sum r spa] ! 12 18 222
seile2- [Sum r spa] ! 15 3 17
seile3- [Sum r spa] ! 7 8 10
Upon recalc you should see the sums appear. The argument "sei" inside\
the [ ] causes a match with the row names containing this substring, in this\
case all three of them.
NOTE NOTE NOTE (you MUST UNDERSTAND this!):
As you see from the example, when summing through a ROW (i.e. [Sum r ...]\
you should give a match string for COLUMN headers ("spa").\
And vice versa!
NOTE also that it pays off to choose row and column names judiciously,\
so you can use them easily in this way!
NOTE a facility that makes selecting rows/columns for summation easier,\
is the TAGGING/UNTAGGING FACILITY. These are found in the Row/Col Rename\
subwindows. Use them by using the match string argument "#$" in your\
summation command, e.g.
[Sum c #$]
}
PutManChapter 3 "Selecting Cells" {
First you select the cells to edit by putting an "anchor" using\
mouse button 1 (the left one). This selects this one\
cell, making it the CURRENT CELL). The anchor will be top left of\
the selected range.
Mouse-3 (the right one) then marks the end (bottom right) of a selected range,\
both in columns and in rows. The range is painted on the screen,\
but ONLY in the row and column headers (this is for efficiency reasons\
with large spreadsheets).
Alternatively, you can use the Select Match -item from the Select\
menu, to give two "match strings" to select row and column names\
with. NOTE that a select range defined in this way may be non-contiguous.
The matching procedure used is regular expression matching (REGEXP,\
see tcp manual).
A third alternative is to directly enter a non-contiguous set of\
row or column names in listboxes, accessible through the\
Select/Row Select Box or Select/Col Select Box menu items.\
Also a thus selected range may be non-contiguous (but will of course\
always be an intersection of a row and a column selection, cf. below).
NOTE (technical remark) that a selected range is ALWAYS the intersection\
of a row selection and a column selection. Inside the software, they\
are represented by the lists $rowsel and $colsel.
}
PutManChapter 4 "Editing Cells" {
Once you have made your selection, you can just start editing it\
in the Formula: -box. (this will contain the formula of the\
current cell as a starting point).
NOTE that pressing the left mouse button above, already moved focus\
to the Formula: -box. This is the quickest way for editing only\
one cell.
You can also select ONE CELL by using the keyboard only: use the\
arrow keys to go to the cell, then press ENTER to get it into the\
"Formula:" -box.
If you press ESC, you will be given an empty box. In fact, you can toggle\
between NAV and EDIT modes by just prssing enter. The focus will change\
correspondingly between the spreadsheet panels and the "Formula:" edit\
window.
EXPERIMENT!
}
PutManChapter 5 "Formula Entry" {
When you are finished editing, ENTER moves your formula (expression)\
into the spreadsheet; ESC cancels your expression.
If a select RANGE is active (not just one cell) your entry will\
be moved into every cell in the range. You can include counters\
$i, $j (row, column within select area starting from 0) or row,\
column names ($r, $c) to make the entries different. You can\
use this to fill in a large number of cells at once and\
corresponds a little bit with "relative cell numbering" in\
other spreadsheets.
}
PutManChapter 6 "Formula Formatting" {
When focus is on the Formula: -box, you can give commands to format\
or unformat the entry in the box. The commands are all given in the\
Format menu, and have control key shortcuts.
}
PutTaggedText tabindent {
Fixed real ^F requires a Format entry in the entrybox right,
Floating real ^G e.g. 12.6
Integer ^N requires format e.g. 8
Left align ^L
Currency ^C two digits fixed point.
Make expression ^E enclose in [expr ...]
Remove expr the reverse
Remove format removes the [format ...] strings added by the\
above formatting commands.
Replace by value IRREVERSIBLE!
}
PutText {
What these menu commands do, as do the equivalent control sequences, is\
placing a
[format "%{fmt}f" ...]
thing around the expression to be formatted.\
This operation is reversible, as the menu shows. The value "fmt" is taken\
from the "Format:" box and is of form
12.6
for real values, and
12
for integers. Just like in FORTRAN (a stone age programming language that\
some of you might remember) or in tcl!
Furthermore, you can change the display column width by directly\
editing the "Colwidth:" entry box top right, and pressing ENTER.
}
PutManChapter 7 "The Insert Mark" {
The insert mark is set on either the row or column header (the\
first row or column containing their names) by clicking the\
middle mouse button (Mouse-2) on it.
Alternatively, Select/Insert Point gives you a listbox to choose from.
Conventionally, if the insert point is lacking, it is assumed\
AFTER the LAST row/column. Otherwise all insertions take place\
before the marked row or column, moving the ones beyond aside to\
make room.
}
PutManChapter 8 "Moving Things" {
The Edit menu provides for a number of things to do with rows,\
columns, groups of these and selected areas.}
PutTaggedText tabindent {
Spawn: Take a group of rows/cols (the selection)\
and copy it to the place indicated by the\
insert marker.\
This command asks for a TEMPLATE to\
generate the new row/col names. This\
template may contain the counter $i starting from 0.
}
PutText {
Example:
Spawn counter 3
Template Row[expr $i + 1]
will insert three new rows under the names Row1, Row2, Row3.
}
PutTaggedText tabindent {
Kill: Delete one or more rows/columns.\
The selection (row or col) is deleted.
Move: Move selection or rows/cols into the\
insert point location.
Rename: As the name indicates. Takes a row/col\
template which may contain the counter $i.
}
PutText {
A special case of rename is TAGGING: this\
adds the suffix "#" (hash), which can be subsequently used in operations\
involving row or column name string matching. Such operations are\
especially the row/col summation ("aggregate") operations discussed earlier.
In spawning and renaming, a new name is not accepted and the operation\
cancelled if the name is a substring of an already existing name,\
or an already existing name is a substring of the new name.\
This would namely interfere with the use of the "insert select match"\
feature in aggregate operations.
}
PutManChapter 9 "Special user functions" {
You can put a CLOCK ticking in a cell. Mainly for keeping\
hour sheets at the job. Moving to another cell and actuating\
will stop and "value-ize" the current cell, and start the\
new one ticking.
The format of the clock value, which becomes visible if you do\
a ReCalc or StopClock operation, is taken (1) from the Format:\
-box, and this being empty, taken to be ColWidth.2.
If you try to quit with the clock still running, it will be stopped\
and the file marked modified. Quit will refuse until you have\
saved the file.
}
PutTaggedText tabindent {
CellAbove, CellBelow, CellLeft and CellRight: \
produce as function values (i.e. [CellAbove] etc...) the data values in these\
neighbour cells. Useful for e.g. displaying a cumulative sum.
Now, Today, USAtoday: \
produces the current date and time, or current date only, or date in USA\
style format.
}
PutManChapter 10 Extensibility {
tk# is EXTENSIBLE: You can enter procedure definitions as\
formulas into cells by just writing them into the formula box,\
and after recalculation they will be available for use.
This is the extensibility intended for OLEO, here implemented\
by the code bootstrap property (similar to LISP) of tcl.
Another product attempting at similar extensibility is SIAG\
(Scheme In A Grid) based on another LISP dialect.
Contrary to those attempts, tk# is not only extensible, it also\
borrows its special character from the programming & extension\
language used, tcl/tk. This may take a little getting used to; but\
once you have, you will discover for yourself that you can do things\
with tk# that you wouldn't even have thought of with a traditional\
spreadsheet!
}
PutManChapter 11 "Loading and Saving" {
tk# saves the data file "intelligently" as a tcl/tk file to be sourced.\
This applies for a complete as well as a partial (select range) save.
Multiple loads on top of each other are supported;\
then an intelligent merge takes place, keeping the union of\
row/column names in memory. }
PutTaggedText tabindent {
Save: to same file
Save As: to another file. Prompts for filename.
Save Select same, but only select range (plus row, col titles)\
is saved.
Import: Still insufficiently tested. Works only with\
sheets exported WITH headers, using tab as separators.
Export: Supports output of ASCII tables with\
various field (cell) separators:\
tab, blank, newline, LaTeX-style.
Supports output of full sheet,\
selection, selection plus row and column headers.
Quit: Terminate tk#, but save/query if modified.
}
PutText {
The tk# icon doubles as an indicator for "Modified" (i.e. red if modified,\
green if not) and as a button for saving.
A special word should be said about the REPOSITORY of function, binding\
and widget definitions. It is possible to write a file containing such\
definitions, which is then automatically loaded whenever an application\
data file is loaded. These function etc. definitions then exist for the user,\
but are NOT bound to any cell and also are NOT re-installed every time\
the sheet is re-calculated.
The way to associate a function repository with a data file is the following:\
}
PutTaggedText tabindent {
1. Load the data file (default extension .tk#) using\
the "File/Load" menu command;
2. Load the repository file using the\
"File/Load Repository" menu command;
3. Save the data file.
}
PutText {
Now, when re-loading this file, you can use the menu command\
"File/Show Repositories" to display the associated repository file(s) in\
the window title row.
The actual WRITING of repository files presupposes fluency in tcl/tk and a\
sound understanding of the internal workings of tk#. It is not for beginners.
}
PutManChapter 12 Variables {
The following variables are available for inclusion in formulas:}
PutTaggedText tabindent {
$r $c row, col number
$i,$j numerical row/col counter used in\
Spawn statements and in multiple\
cell editing. Counts from 0 upward.
$v($r,c$) cell values.
NOTE: You should NOT refer to cell values using\
literal row/column names directly. If you\
rename a row or column, any reference to\
it will break.
Rather, put a statement
[set usecol $c]
in the column you intend to use,\
and refer to $usecol after that.
}
PutManChapter 13 "File Names" {
Internally, the program tk# uses three filenames:}
PutTaggedText tabindent {
$filename The current filename used when saving;\
this should always be displayed in the window header.
$lfl The Last File Loaded.
$lfs The Last File Saved.
}
PutText {
The filenames $lfl and $lfs are displayed in the File menu and can be\
loaded by clicking upon. Note that these two filenames are always\
different.
The file names $filename, $lfl and $lfs are NOT saved to the data file.\
It is however possible to put them MANUALLY there. This is a trick,\
which may be used e.g. to load a template file and then save the data\
to a file, the name of which is generated according to some rule\
specified by you. E.g. if you put in the data (template) file the\
command
set filename "$env(HOME)/tk#/[Now].tk#"
the template file will be loaded, but $filename set to a date and time\
string, which will become the name of the next saved data file!\
The procedures "Now", "Today" and "USAtoday"are defined in tk#.\
You can define your own, either in tk# or in your source-able data file\
(repository file).
An advanced trick, to be used with considerable care...
}
PutManChapter 14 "Limitations" {
Many. Not optimized for performance (would the 8.0 compiler help?)
The code and its comments should be improved and extended and made to\
conform to Ray Johnson's Tcl Style Guide, so also others can participate\
in development (MV :-)).
}
PutManChapter 15 "Finally..." {
tk# is distributed under the name tknum, to cater for the needs of\
Netscape and (possibly) other mail/ftp agents. You should rename it on\
your disk to "tk#", if your OS will allow it :-), which is its proper\
name.
Happy tcl/tk-ing! Martin Vermeer mv@fgi.fi
}
PanelsState disabled
focus $frq.side
}
#################################
##
## High level procedures operating on rows or columns:
##
# Iter --
#
# General service routine for iterative user functions (sum, average, etc.)
# globalize anything that might be used in $start, $step and $final:
#
# Arguments:
#
# startScript script to be executed once when starting
# stepScript script to be executed iteratively
# finalScript script to be executed once when finishing
# match match string for row/cols to be included in iteration
# rr1 first row/col list
# rr2 second row/col list
# rr r for row-wise, c for col-wise
#
# Returns:
# error messages in return values.
#
proc Iter {startScript stepScript finalScript match rr1 rr2 rr} {
global r c v
# ALWAYS output something after a trapped error, NEVER leave catch dangling!
if [catch {eval $startScript} result] {return "?ERR 1 $result"}
if {$rr == "r"} {
set oldr $r ; # save...
foreach r [concat $rr1 $rr2] {
if {[regexp $match $r]} {
if [catch {eval $stepScript} result] {return "?ERR 8 $result"}
}
}
set r $oldr ; # ...restore
} else {
set oldc $c
foreach c [concat $rr1 $rr2] {
if {[regexp $match $c]} {
if [catch {eval $stepScript} result] {return "?ERR 9 $result"}
}
set c $oldc
}
}
if [catch {eval $finalScript} result] {return "?ERR 2 $result"}
return $s ; # This is the $s defined in SumAv!
}
# Citer --
#
# Wrapper proc for iteration through a column (i.e. over rows).
#
# Arguments:
# startScript stepScript finalScript See header of proc Iter.
# match Matching string for selecting
# rownames of cells to include.
#
proc Citer {startScript stepScript finalScript match} {
global headrows rows
return [Iter $startScript $stepScript $finalScript $match $headrows $rows r]
}
# Riter --
#
# Wrapper proc for iteration through a row (i.e. over columns).
#
# startScript stepScript finalScript See header of proc Iter.
# match Matching string for selecting
# colnames of cells to include.
#
proc Riter {startScript stepScript finalScript match} {
global sidecols cols
return [Iter $startScript $stepScript $finalScript $match $sidecols $cols c]
}
# -MakeIterCmd --
#
# Switching routine to direct general specific iteration routines
# to either Citer or Riter, dpending on $rc flag.
#
# Argument:
# rc r means: call Riter, c means: call Citer.
#
proc MakeIterCmd {rc} {
if {$rc == "c"} {
return "Citer"
} elseif {$rc == "r"} {
return "Riter"
} else {error "bad row/col flag: $rc"}
}
# SumAv --
#
# Generalized routine used by all the others for aggregate operations.
#
# Arguments:
# rc r (row) or c (col)
# match match string with row or col names to select elements to be
# aggregated
# sa s (sum) or a (average). Flag for post-division by sum of
# weights
# wn w (use weights) or n (do not)
# wt name of row/col providing weights
# pwr "power" parameter: 1 for ordinary sum/average, 2 for sum of
# squares
#
# Results:
# Function value.
# Error messages go to spreadsheet cell or are "puts" in background
# window (warnings).
#
proc SumAv {rc match sa wn {wt 0} {pwr 1}} {
# Process the Sum/Average flag:
if {$sa == "a"} {
set final {
if [catch {set s [expr $s / $w]} result] {set s "?ERR 3 $result"}
}
} elseif {$sa == "s"} {set final {}} else {error "bad sum/av flag: $sa"}
# Process the Weighted/Nonweighted flag:
if {$wn == "w"} {
if {$rc == "r"} {
set stepwt {
if [set ww 0; catch {scan $v($wt,$c) "%f" ww} result] {
puts "?ERR 6 $result"
}
set w [expr $w + $ww]
}
} else {
set stepwt {
if [set ww 0; catch {scan $v($r,$wt) "%f" ww} result] {
puts "?ERR 7 $result"
}
set w [expr $w + $ww]
}
}
} elseif {$wn == "n"} {
set stepwt {set ww 1; incr w}
} else {error "bad weighting flag: $wn"}
# Initialize the (possible) weights column:
set initwt "set wt $wt"
# Initialize the "step" code:
switch -- $pwr {
1 {set stepdo { ; set s [expr $s + $ww * $vv] }}
2 {set stepdo { ; set s [expr $s + $ww * $vv * $vv] }}
}
# Next, either Citer or Riter is executed:
set s [[MakeIterCmd $rc] [concat {
# start
set s 0
set w 0
set ww 1 ;
} $initwt] [concat {
# step
# if you can't find a float, put zero:
if [catch {set vv 0; scan $v($r,$c) "%f" vv} result] {
# puts "?WRN 1 $result"
} ;
} $stepwt $stepdo] $final $match]
# Return as function value of SumAv:
return $s
}
proc Sum {rc match} {
return [SumAv $rc $match s n]
}
proc Av {rc match} {
return [SumAv $rc $match a n]
}
proc Cnt {rc match} {
return [[MakeIterCmd $rc] {set s 0} {incr s} {return $s} $match]
}
# Weighted sum
proc wSum {rc match wt} {
return [SumAv $rc $match s w $wt]
}
# Weighted average
proc wAv {rc match wt} {
return [SumAv $rc $match a w $wt]
}
# Sum of squares
proc Ssq {rc match} {
return [SumAv $rc $match s n 0 2]
}
# Weighted sum of squares
proc wSsq {rc match wt} {
return [SumAv $rc $match s w $wt 2]
}
# Average of squares
proc MS {rc match} {
return [SumAv $rc $match a n 0 2]
}
# Root Mean Square
proc RMS {rc match} {
return [expr sqrt([MS $rc $match])]
}
# Weighted average of squares:
proc wMS {rc match wt} {
return [SumAv $rc $match a w $wt 2]
}
# Root of Weighted average of squares:
proc wRMS {rc match wt} {
return [expr sqrt([wMS $rc $match $wt])]
}
# Standard deviation:
proc Sd {rc match} {
set av [Av $rc $match]
return [expr sqrt([MS $rc $match] - $av * $av)]
}
proc wSd {rc match wt} {
set wav [wAv $rc $match $wt]
return [expr sqrt([wMS $rc $match $wt] - $wav * $wav)]
}
# Colour --
#
# Colour choice interaction wrapper routine.
# Typically the arg and function value are elements
# of the "Colours" array.
#
# Argument:
# colour present value of colour.
# colourname name of this colour
#
# Result:
# New colour value in function value.
proc Colour {colour colourname} {
set colour2 [tk_chooseColor -initialcolor $colour \
-title "tk# colour choice: $colourname"]
if {$colour2 != ""} {
return $colour2
} else {
return $colour
}
}
# Load --
#
# Loads by "sourcing" a tk# data file, generated by "Save".
# All vars that one wants to make available to the program should be
# included in the "globals" list.
#
# Arguments:
# sw Flag indicating if 1 that filename should be entered manually.
# If 0, last filename is used.
#
proc Load {sw} {
# These are all variables that, if loaded, will be globally available:
global rows cols headrows sidecols f cw r c tr tc
global colours initdir reload lfl lfs
global rowsel colsel inspoint filename winsize
global recalc defmov exp env reps
# for use in tl# files:
global b tools e ew ef
.w config -cursor watch
if {$sw == 2} {
set typelist {
{"tl# files" {".tl#"}}
{"All files" {*}}
}
} else {
set typelist {
{"tk# files" {".tk#"}}
{"All files" {*}}
}
}
if {$sw > 0} {
# Perhaps we changed machine/userid :-)
if ![file isdirectory $initdir] {set initdir [pwd]}
set fn [tk_getOpenFile -defaultextension ".tk#" -initialdir $initdir \
-filetypes $typelist -initialfile $filename -title "tk# file load"]
} else {set fn $filename}
if {$fn != ""} {
if {$sw < 2} {set filename $fn}
wm title .w "Load: $fn"
# Last file loaded:
if {$filename != $lfs} {set lfl $filename}
# copy row/col lists over:
foreach x {rows cols headrows sidecols} {set ${x}2 [subst \$$x]}
source $fn
# merge row/col lists, merging common names (overwrite!):
foreach x {rows cols headrows sidecols} {
foreach y [subst \$$x] {
if {([lsearch [subst \$${x}2] $y] == -1)} {
lappend ${x}2 $y
}
}
set $x [subst \$${x}2]
}
# Last colour merged in has it!
ColoursSet
ReCalc
if $reload Modified else {set reload 1}
if {$sw == 2} {
# Add to lib stack if called with $sw == 2:
lappend reps $fn
} else {
# Source the library stack:
if [info exists reps] {
foreach x $reps {source $x}
}
wm geometry .w $winsize
}
wm title .w "File: $filename"
}
.w config -cursor {}
}
# ClipRC --
#
# Return only those rows/cols in $rr which are in the selection $rs.
#
# Arguments:
# rr row/col name list, e.g. $rows or $sidecols.
# rs row/col selection list, i.e. $rowsel or $colsel
#
# Result:
# Function value containing list of elements of $rr also in $rs.
#
proc ClipRC {rr rs} {
set cc {}
foreach x $rr {
if {!([lsearch $rs $x] == -1)} {lappend cc $x}
}
return $cc
}
# Save --
#
# Saves the spreadsheet and its state vars to a data file in "sourceable"
# format. The globals list should contain everything that one wants
# saved.
#
# Arguments:
# sw2 Switch flagging manual entry of filename (> 0) or not ( = 0).
# If =2, then save only selection.
#
proc Save {sw2} {
# These are all variables that will be saved:
global rows cols headrows sidecols r c tr tc
global colours initdir lfs lfl winsize
global rowsel colsel inspoint f cw filename
global recalc defmov exp reps
set winsize [wm geometry .w]
# Condition necessary so Save does not break in destroyed window:
if [winfo exists .w] {.w config -cursor watch}
set typelist {
{"tk# files" {".tk#"}}
{"All files" {*}}
}
if {$sw2 > 0} {
if ![file isdirectory $initdir] {set initdir [pwd]}
set fnx [tk_getSaveFile -defaultextension ".tk#" -initialdir $initdir \
-initialfile $filename -filetypes $typelist \
-title "tk# file save"]
} else {set fnx $filename}
if {$fnx != ""} {
set filename $fnx
if {$filename != $lfl} {set lfs $filename ;# last file saved}
if {$sw2 == 2} {
# save the selection only, i.e. restrict the $row and $col lists
# only to include the selection (+title):
set sidecols [concat title [ClipRC $sidecols $colsel]]
set cols [ClipRC $cols $colsel]
set headrows [concat title [ClipRC $headrows $rowsel]]
set rows [ClipRC $rows $rowsel]
}
# not saved:
unset typelist sw2
if [winfo exists .w] {wm title .w "Save: $filename"}
set FileId [open $filename w]
# Put aside into local vars, prevent saving of originals:
foreach {lfs2 lfl2 fnx} [list $lfs $lfl $filename] {break}
# Prevent from being saved, as their unintended loading is wrong:
unset filename lfl lfs ; # prevent saving
# First simple variables...
foreach x [info vars *] {
if ![array exists $x] {
# A variable may be unset, but still exist:
if [info exists $x] {
puts $FileId [list set $x [subst \$$x] ]
}
}
}
# ...then arrays cw and f:
foreach y [concat $sidecols $cols] {
puts $FileId [list array set cw [array get cw $y]]
}
foreach x [concat $headrows $rows] {
foreach y [concat $sidecols $cols] {
puts $FileId [list array set f [array get f $x,$y]]
}
}
# ... and colours:
foreach x [array names colours] {
puts $FileId [list array set colours [array get colours $x]]
}
close $FileId
# Restore:
foreach {lfs lfl filename} [list $lfs2 $lfl2 $fnx] {break}
UnModified
if [winfo exists .w] {wm title .w "File: $filename"}
}
if [winfo exists .w] {.w config -cursor {}}
}
# Get the "rc" file from user home
proc Getrc {} {
global lfl lfs env
set fn "$env(HOME)/.tk#rc"
if [file exists $fn] {
set FileId [open $fn r]
# lfl: Last File Loaded
gets $FileId lfl
# lfs: Last File Saved
gets $FileId lfs
close $FileId
} else {
set lfl ""
set lfs ""
}
}
# Write back rc file to user home:
proc Exit {} {
global lfl lfs env
set FileId [open "$env(HOME)/.tk#rc" w]
puts $FileId $lfl
puts $FileId $lfs
close $FileId
exit
}
# QuitWarn --
#
# Quit with warning to save file
#
# Result:
# Yes: Save if modified, stop clock(s) and exit
# No: Do not save; exit
# Cancel: Do not even exit. Return to spreadsheet
#
proc QuitWarn {} {
global modified filename tr
# Has file been modified?
if $modified {set choice \
[tk_messageBox -type yesnocancel -icon question \
-message "Save File $filename" -default yes]
if {$choice == "yes"} {
# If clock running, stop it
if [info exists tr] StopClock
Save 0
Exit
}
if {$choice == "no"} Exit
} else Exit
}
proc ConvSep {separ} {
switch -- $separ {
"Tab" {set sep "\t"}
"Comma" {set sep ","}
"Newline" {set sep "\n"}
"Blank" {set sep " "}
"None" {set sep ""}
"LaTeX" {set sep " & "}
}
return $sep
}
# Export --
#
# Export routine, allowing simple data tables with tab, space, comma
# or newline separators to be written, or LaTeX format table.
#
proc Export {} {
global initdir exp exportname
global v headrows rows sidecols cols cw rowsel colsel
.w config -cursor watch
set sep [ConvSep $exp(separ)]
switch -- $exp(howmuch) {
"All" {
set prows [concat $headrows $rows]
set pcols [concat $sidecols $cols]
}
"Selection" {
set prows $rowsel
if {([lsearch $rowsel title] == -1) && $exp(titlerow)} {
set prows [concat title $rowsel]
}
set pcols $colsel
if {([lsearch $colsel title] == -1) && $exp(titlecol)} {
set pcols [concat title $colsel]
}
}
}
set typelist {
{"tk# files" {".tk#"}}
{"All files" {*}}
}
if ![file isdirectory $initdir] {set initdir [pwd]}
set exportname [tk_getSaveFile -defaultextension ".dat" -initialdir $initdir \
-initialfile $exportname -filetypes $typelist -title "tk# file export"]
if {$exportname != ""} {
set FileId [open $exportname w]
switch -- $exp(separ) {
LaTeX {
puts -nonewline $FileId "\\begin\{tabular\}\{|"
foreach y $pcols {puts -nonewline $FileId " r |"}
puts $FileId "\}"
foreach x $prows {
puts $FileId {\hline}
foreach y $pcols {
if {[lsearch $pcols $y] > 0} {
puts -nonewline $FileId $sep
}
if ![info exists v($x,$y)] {set v($x,$y) "?UNDEF"}
puts -nonewline $FileId \
[string trim [FormattedCell $x $y $cw($y)]]
}
puts $FileId "\\\\"
}
puts $FileId {\hline}
puts $FileId "\\end\{tabular\}"
}
default {
foreach x $prows {
foreach y $pcols {
if {[lsearch $pcols $y] > 0} {
puts -nonewline $FileId $sep
}
# Remove separator char from string:
regsub $sep [FormattedCell $x $y $cw($y)] "_" z
puts -nonewline $FileId $z
}
puts $FileId ""
}
}
}
close $FileId
}
.w config -cursor {}
}
# Avoid the generation of empty elements due to multiple separator chars
proc BetterSplit {line ch} {
regsub "$ch$ch" $line "$ch" line
regsub "$ch$ch" $line "$ch" line
regsub "$ch$ch" $line "$ch" line
return [split $line "$ch"]
}
# Import --
#
# Counterpart of Export.
# Currently only tab-separated tables WITH headers can be imported.
#
proc Import {} {
global initdir exportname exp
global f headrows rows sidecols cols cw
#
.w config -cursor watch
set sep [ConvSep $exp(separ)]
set typelist {
{"tk# files" {".tk#"}}
{"All files" {*}}
}
if ![file isdirectory $initdir] {set initdir [pwd]}
set exportname [tk_getOpenFile -defaultextension ".dat" -initialdir $initdir \
-initialfile $exportname -filetypes $typelist -title "tk# file import"]
if {$exportname != ""} {
set FileId [open $exportname r]
# needs work...
set prows {}; set pcols {}
# title row:
gets $FileId line
set x [BetterSplit $line $sep]
# Remove leading "-" from column names in title row:
foreach y $x {set pcols [concat $pcols [string trim $y " -"]]}
while {![eof $FileId]} {
gets $FileId line
# works with tab:
set linelist [BetterSplit $line $sep]
# Get row name, removing trailing "-":
set rr [string trim [lindex $linelist 0] " -"]
set prows [concat $prows $rr]
# element-in-row counter:
set iz 0
foreach z [lrange $linelist 1 end] {
incr iz
set cc [lindex $pcols $iz]
# keep track of widest cell in column:
if [info exists cw($cc)] {
set sl [string length $z]
if {$sl > $cw($cc)} {
set cw($cc) $sl
}
} else {set cw($cc) 12}
set f($rr,$cc) $z
}
}
close $FileId
# Add the missing rows/cols
foreach x $prows {
if {([lsearch $headrows $x] == -1) && ([lsearch $rows $x] == -1)} {
set rows [concat $rows $x]
}
}
foreach x $pcols {
if {([lsearch $sidecols $x] == -1) && ([lsearch $cols $x] == -1)} {
set cols [concat $cols $x]
}
}
}
.w config -cursor {}
ReCalc
ReDisplay
}
# RecalcCell --
#
# Recalculate a single cell value.
# Put ?UNDEF for undefined formulas.
# Use uplevel to globalize any var definitions put by the user
# into $f, so they will be available in other cells too
#
proc ReCalcCell {} {
global rows cols cw r c
global v f
if ![info exists f($r,$c)] {set f($r,$c) "?UNDEF"}
uplevel #0 {
set w $cw($c)
if [catch {set v($r,$c) [subst $f($r,$c)]} result] {
set v($r,$c) "?ERR 4 $result"
}
}
}
# GetFormula --
#
# After entry of a formula into the entrybox, evaluation and
# writing back of value result into spreadsheet.
#
proc GetFormula {} {
global r c f autocalc rowsel colsel thisformula frq
#
# "thisformula" is the current content of the Formula: box.
#
# Temporary save of $r, $c, to allow their use in loops
# (and availability of loop-$r and loop-$c to user):
#
set oldr $r; set oldc $c
foreach r $rowsel {
foreach c $colsel {
if {$f($r,$c) != $thisformula} {
regsub "<F>" $thisformula $f($r,$c) f($r,$c)
# Mark modified only if actual formula change:
Modified
}
}
}
set r $oldr; set c $oldc
# Only update the selected cells if autocalc off:
# (Remember ReCalc does a ReDisplay)
if {$autocalc} {ReCalc} else {ReCalc 1}
PaintSelect
# Prepare for arrow keys use:
NavFocus
}
# PanelRow --
#
# Returns the row list identity ($rows or $headrows) belonging to this
# spreadsheet panel.
#
proc PanelRow {panel} {
global rows headrows
if {($panel == "main") || ($panel == "side")} {
return $rows
} else {
return $headrows
}
}
# PanelCol --
#
# Returns the col list identity ($cols or $sidecols) belonging to this
# spreadsheet panel.
#
proc PanelCol {panel} {
global cols sidecols
if {($panel == "main") || ($panel == "head")} {
return $cols
} else {
return $sidecols
}
}
proc SetUpForEdit {} {
global c r rowsel colsel frq
if {($c != "title")} {set colsel $c}
if {($r != "title")} {set rowsel $r}
PaintSelect
# Set up for data/formula entry:
EditFocus
}
proc SetUpEntry {} {
global r c thisformula f cw cwidth
# Make width entry box current:
set cwidth $cw($c)
if ![info exists f($r,$c)] {set f($r,$c) "?UNDEF"}
# Get current cell formula for editing:
set thisformula $f($r,$c)
SetUpForEdit
}
# GetMouse1 --
#
# Callback routine for mouse button 1 (data entry) in panels:
#
proc GetMouse1 {panel} {
global r c rowsel colsel thisformula f cw cwidth
UnPaintCurrentCell
# Get the proper name of row/column list for this panel:
set prows [PanelRow $panel]
set pcols [PanelCol $panel]
foreach {r c} [GetCell $panel $prows $pcols] {break}
SetUpEntry
}
# GetMouse2 --
#
# Handle mouse button 2 clicks: Mark insert point.
#
# Note: There is an overloading of this mouse button. It is also used
# to drag the panels. I don't know if this is OK or not (mv).
#
proc GetMouse2 {panel} {
global rows cols headrows sidecols inspoint
# remove previous insert marks in row or col headers:
PaintCell "" "" "" noinsert
set prows [PanelRow $panel]
set pcols [PanelCol $panel]
foreach {x y} [GetCell $panel $prows $pcols] {break}
if {($x == "title") || ($y == "title")} {
PaintCell $panel $x $y insert
if {$x != "title"} {
set inspoint $x
} elseif {$y != "title"} {
set inspoint $y
} else {set inspoint "title" }
} else {set inspoint {^$} }
}
# GetMouse3 --
#
# Handle mouse button 3 clicks: Selection bottom right corner.
#
proc GetMouse3 {panel} {
global r c rowsel colsel
global rows cols headrows sidecols
set prows [PanelRow $panel]
set pcols [PanelCol $panel]
foreach {rr cc} [GetCell $panel $prows $pcols] {break}
set allrows [concat $headrows $rows]
set i [lsearch $allrows $r]
# do not include "title" in selection:
if {($r == "title")} {incr i}
set j [lsearch $allrows $rr]
if {($r != "title")} {set rowsel [lrange $allrows $i $j]}
set allcols [concat $sidecols $cols]
set i [lsearch $allcols $c]
if {($c == "title")} {incr i}
set j [lsearch $allcols $cc]
if {($c != "title")} {set colsel [lrange $allcols $i $j]}
PaintSelect
return
}
# GetCell --
#
# Get cell address (row, col names as function value list)
# from mouse click.
#
# Arguments:
# rect current panel of spreadsheet
# prows current row list
# pcols current column list
#
proc GetCell {rect prows pcols} {
global cw cs f frq
# row address:
set rn -1
while {[$frq.$rect compare current >= "1.0 + $rn lines"]} {
incr rn
}
incr rn -1
set r [lindex $prows $rn]
if {$r == ""} {set r title} ;# play safe
# col address (if possible):
for {set jj 0} {$jj < [llength $pcols]} {incr jj} {
set cc [lindex $pcols $jj]
if {[$frq.$rect compare \
"current linestart + $cs($cc) chars" <= current]} {
set c $cc
}
}
if {(![info exists c]) || (![info exists r])} {set r title; set c title}
# Make a list containing two names, a row name and a column name, to return.
return [list $r $c]
}
# RowColPanel --
#
# Get panel identity as a name string, given $r and $c.
#
proc RowColPanel {r c} {
global headrows sidecols
if {[lsearch $headrows $r] > -1} {
return [expr {([lsearch $sidecols $c] > -1) ? "corner" : "head" }]
} else {
return [expr {([lsearch $sidecols $c] > -1) ? "side" : "main" }]
}
}
# PaintSelect --
#
# Paint the selected rows/cols in the titles, and some more (clock cell,
# current cell).
#
proc PaintSelect {} {
global rows cols headrows sidecols r c tr tc rowsel colsel
PaintCell "" "" "" notitle
# add "title" tag only to the selected cells' rows/cols:"
foreach x $rowsel {
PaintCell [RowColPanel $x title] $x title title
}
foreach y $colsel {
PaintCell [RowColPanel title $y] title $y title
}
# tag the clock cell:
PaintCell "" "" "" notime
if [info exists tr] {
PaintCell [RowColPanel $tr $tc] $tr $tc time
}
# tag the current cell:
PaintCurrentCell
}
# FormattedCell --
#
# Returns the string $v($rr,$cc) clipped to column width.
# Handles undefined v element (may happen!)
#
proc FormattedCell {rr cc w} {
global v
# Prevent crash
if ![info exists v($rr,$cc)] {set v($rr,$cc) "?UNDEF"}
return [format "%${w}s" [string range "$v($rr,$cc)" 0 [expr $w - 1]]]
}
# Redisplay a single cell in the right attributes
#
# Arguments:
# none.
# globals $r $c used as display location.
#
proc ReDisplayCell {} {
global cw v r c frq
set w $cw($c)
set panel [RowColPanel $r $c]
set x [FormattedCell $r $c $w]
foreach {cb ce} [GetCellEnds $r $c] {break}
PanelsState normal
if {[$frq.$panel compare $ce < end]} {$frq.$panel delete $cb $ce}
if {($r == "title") || ($c == "title")} {
$frq.$panel insert $cb $x underline
} else {
$frq.$panel insert $cb $x
}
PanelsState disabled
return
}
# GetCellEnds --
#
# Return begin- and endpoints (character positions in row)
# of a cell in its text widget (panel).
#
# Arguments:
# r, c row, col names
#
proc GetCellEnds {r c} {
global rs cs cw headrows rows sidecols cols
if ![info exists rs($r)] {
InitIndexRow $headrows
InitIndexRow $rows
}
if ![info exists cs($c)] {
InitIndexCol $sidecols
InitIndexCol $cols
}
if [info exists rs($r)] {
set linebgn $rs($r)
incr linebgn
set cellbgn $cs($c)
set cellsize $cw($c)
return [list "$linebgn.$cellbgn" "$linebgn.$cellbgn + $cellsize chars"]
} else {
return {1.0 1.0}
}
}
# PaintCell --
#
# Put proper attributes on a single cell
#
# Arguments:
# thispanel panel to add attributes (tags) to
# r c row and col number (LOCAL VARS!)
# switch specifies kind of tag to use.
#
proc PaintCell {thispanel r c switch } {
global cw cs rs frq
foreach {cb ce} [GetCellEnds $r $c] {break}
PanelsState normal
foreach panel {main head side corner} {
switch -- $switch {
noinsert {$frq.$panel tag remove instag 1.0 end}
nocurrent {$frq.$panel tag remove current 1.0 end}
notime {$frq.$panel tag remove time 1.0 end}
notitle {$frq.$panel tag remove title 1.0 end}
nocurtitle {$frq.$panel tag remove curtitle 1.0 end}
default {}
}
}
switch -- $switch {
title {$frq.$thispanel tag add title $cb $ce}
insert {$frq.$thispanel tag add instag $cb $ce}
curtitle {
$frq.$thispanel tag add curtitle $cb $ce
$frq.$thispanel see curtitle.last
$frq.$thispanel see curtitle.first
}
time {$frq.$thispanel tag add time $cb $ce}
current {
$frq.$thispanel tag add current $cb $ce
$frq.$thispanel see current.last
$frq.$thispanel see current.first
}
}
PanelsState disabled
return
}
proc ClearAll {} {
global frq
PanelsState normal
foreach panel {main side head corner} {$frq.$panel delete 1.0 end}
PanelsState disabled
return
}
# ReCalc --
#
# Recalc everything (sw = 0) or selection (sw = 1)
#
proc ReCalc {{sw 0}} {
global f v rows cols headrows sidecols r c frq rowsel colsel
.w config -cursor watch
$frq.flag configure -text "Calc..."
update idletasks
if {$sw == 0} {
set prows [ConcatNoTitle $rows $headrows]
set pcols [ConcatNoTitle $cols $sidecols]
} else {
set prows $rowsel
set pcols $colsel
}
InitIndex
# r and c must be global :-( for cell evaluation in #0 scope;
# however r and c must be available at eval time for each cell
# within the two loops.
set oldr $r ; set oldc $c
foreach r $prows {
foreach c $pcols {
ReCalcCell
}
}
$frq.flag configure -text "Display..."
update idletasks
if {$sw == 0} {
# restore
set r $oldr ; set c $oldc
ReDisplay
} else {
foreach r $prows {
foreach c $pcols {
ReDisplayCell
}
}
set r $oldr ; set c $oldc
PaintSelect;
}
.w config -cursor {}
NavFocus
return
}
# ReDisplay --
#
# Redisplay the whole assembly of four data panels.
# The three "title panels" are scaled to contain the text.
# Necessary attributes (tags) are added to the appropriate cells.
# Also newline characters (\n) added at the right places.
# For rows and columns, their names are used instead of
# evaluated formulas.
#
proc ReDisplay {} {
global f v cw rows cols headrows sidecols rowsel colsel inspoint frq
InitIndex
set ht [InitIndexRow $headrows]
set wd [InitIndexCol $sidecols]
$frq.head config -height $ht
$frq.side config -width $wd
$frq.corner config -width $wd -height $ht
$frq.main config -wrap none
ClearAll
set prows [concat $headrows $rows]
set pcols [concat $sidecols $cols]
foreach r $prows {set v($r,title) $r-}
foreach c $pcols {set v(title,$c) -$c}
set v(title,title) "title"
PanelsState normal
foreach r $prows {
update idletasks
set panel [RowColPanel $r [lindex $sidecols 0]]
foreach c $sidecols {
set x [FormattedCell $r $c $cw($c)]
if {($r == "title") || ($c == "title")} {
$frq.$panel insert end $x underline
} else {
$frq.$panel insert end $x
}
}
set panel [RowColPanel $r [lindex $cols 0]]
if {($r == "title")} {
foreach c $cols {
set x [FormattedCell $r $c $cw($c)]
$frq.$panel insert end $x underline
}
} else {
# inline format cmd, not FormattedCell call, for speed
foreach c $cols {
if ![info exists v($r,$c)] {set v($r,$c) "?UNDEF"}
$frq.$panel insert end [format "%$cw($c)s" \
[string range "$v($r,$c)" 0 [expr $cw($c) - 1]]]
}
}
set rn [lsearch $headrows $r]
if {($rn > -1)} {
incr rn
foreach panel {head corner} {
if {$rn < [llength $headrows]} {
$frq.$panel insert "$rn.end" "\n"
}
}
} else {
set rn [lsearch $rows $r]
incr rn
foreach panel {side main} {
if {$rn < [llength $rows]} {
$frq.$panel insert "$rn.end" "\n"
}
}
}
}
update idletasks
PaintSelect
if {[info exists inspoint]} {
# re-paint the inspoint title cell!
if {([lsearch $prows $inspoint] > -1)} {
set panel [RowColPanel $inspoint title]
PaintCell $panel $inspoint title insert
} elseif {([lsearch $pcols $inspoint] > -1)} {
set panel [RowColPanel title $inspoint]
PaintCell $panel title $inspoint insert
}
}
PanelsState disabled
return
}
# ColWidth --
#
# Get column width value from entry box
#
proc ColWidth {} {
global cw c rows headrows cols sidecols
# Use scan to guarantee integer return:
set cwidth 12
scan [.w.fr.box1.ew get] "%d" cwidth
if {($cwidth == 0)} {set cwidth 12}
set cw($c) $cwidth
ReDisplay
return
}
#
# Service routines for joint scrolling of all panels & scrollbars.
# Do not touch unless you know your way around.
#
proc HorizScroll {args} {
global frq
eval [concat $frq.main xview $args]
eval [concat $frq.head xview $args]
return
}
proc VertScroll {args} {
global frq
eval [concat $frq.main yview $args]
eval [concat $frq.side yview $args]
return
}
proc BindDragto { x y args } {foreach w $args {$w scan dragto $x $y}}
proc BindMark { x y args } {foreach w $args {$w scan mark $x $y}}
# ColoursSet --
#
# Make all colours valid on panels and tags after modification
# through menu.
#
proc ColoursSet {} {
global colours frq
foreach panel {main side head corner} {
$frq.$panel config \
-foreground $colours(textfg) -background $colours(textbg)
}
TagsConfig
return
}
# Wrapper routine for colour editing
proc ColourReconfig {colour} {
global colours
set colours($colour) [Colour $colours($colour) $colour]
ColoursSet
return
}
# FillListBox --
#
# obtain rowsel/colsel and put into listbox
#
proc FillListBox {rclist pselName} {
upvar $pselName psel
.sel.f0.lb delete 0 end
foreach x $rclist {
.sel.f0.lb insert end $x
}
foreach x $rclist {
set i [lsearch $rclist $x]
if {[lsearch $psel $x] > -1} {
.sel.f0.lb selection set $i
}
}
return
}
# PaintInsAll --
#
# Tag the insert pointer where-ever it is
#
proc PaintInsAll {} {
global headrows rows sidecols cols inspoint
PaintCell "" "" "" noinsert
if [info exists inspoint] {
PaintInsert $headrows corner 1
PaintInsert $rows side 1
PaintInsert $sidecols corner 0
PaintInsert $cols head 0
}
return
}
# PaintInsert --
#
# Tag the insert pointer if in current panel
# sw indicates row or column pointer
# For usage see proc PaintInsAll
#
proc PaintInsert {rr panel sw} {
global inspoint
if {([lsearch $rr $inspoint] > -1)} {
if $sw {
PaintCell $panel $inspoint title insert
} else {
PaintCell $panel title $inspoint insert
}
}
return
}
# ProcListBox
#
# Obtain cursor selection, put into rowsel/colsel/inspoint, and exit
#
# Arguments:
# rclist list of row/column names
# rc flag for row select, col select, or insert point choose.
#
proc ProcListBox {rclist rc} {
global rowsel colsel inspoint
#global headrows rows sidecols cols
set ii [.sel.f0.lb curselection]
set locpsel {}; foreach i $ii {lappend locpsel [lindex $rclist $i]}
switch -- $rc {
"r" {set rowsel $locpsel}
"c" {set colsel $locpsel}
"i" {set inspoint [lindex $locpsel 0]}
}
.sel.f0.lb selection clear 0 end
wm withdraw .sel
PaintSelect
PaintInsAll
return
}
# GetSel --
#
# Get selection (rows, columns) by string matching with row/col names
#
# Arguments:
# rowselect match string for row names
# colselect match string for column names
#
proc GetSel {rowselect colselect} {
global rowsel colsel rows headrows cols sidecols
set rowsel {}
foreach r [concat $rows $headrows] {
if {[regexp $rowselect $r]} {
if {$r != "title"} {
lappend rowsel $r
}
}
}
set colsel {}
foreach c [concat $cols $sidecols] {
if {[regexp $colselect $c]} {
if {$c != "title"} {
lappend colsel $c
}
}
}
PaintSelect
.w config -cursor {}
wm withdraw .selm
return
}
# SelectEdit --
#
# Listbox user interface handling routine
#
proc SelectEdit {rclist rc title mode selName} {
upvar $selName sel
.w config -cursor watch
set doScript [list ProcListBox $rclist $rc]
if [winfo exists .sel] {
wm deiconify .sel
wm title .sel $title
raise .sel
.sel.f0.lb config -selectmode $mode
FillListBox $rclist sel
set doScript [list ProcListBox $rclist $rc]
.sel.f1.do config -command $doScript
.w config -cursor {}
return
}
toplevel .sel
wm title .sel $title
CenterWin .sel .w
foreach x {0 1} {frame .sel.f$x}
listbox .sel.f0.lb -selectmode $mode \
-yscrollcommand {.sel.f0.sb set} -width 30
scrollbar .sel.f0.sb -command {.sel.f0.lb yview}
FillListBox $rclist sel
button .sel.f1.do -text OK -command $doScript
bind .sel <Key-Return> $doScript
button .sel.f1.cancel -text cancel -command {wm withdraw .sel}
bind .sel <Key-Escape> {wm withdraw .sel}
pack .sel.f0.lb -fill both -expand true -side left
pack .sel.f0.sb -fill both -expand false -side right
pack .sel.f1.do -side left
pack .sel.f1.cancel -side right
grid columnconfigure .sel 0 -weight 1
grid rowconfigure .sel 0 -weight 1
foreach x {0 1} {grid .sel.f$x -in .sel -row $x -sticky news}
raise .sel
PaintSelect
.w config -cursor {}
return
}
# SelectMatch --
#
# Selection by string matching user interface handling routine
#
proc SelectMatch {} {
global colours rowsel colsel headrows rows sidecols cols
.w config -cursor watch
if [winfo exists .selm] {
wm deiconify .selm;
raise .selm; return
}
toplevel .selm
wm title .selm "Row/Col Select by Match"
CenterWin .selm .w
foreach x {1 2 3} {frame .selm.f$x}
foreach {x y} {1 Row 2 Col} {
label .selm.f$x.l$x -text "$y Select String:" -width 18 -anchor e
entry .selm.f$x.e$x -textvariable ${y}SelString \
-background $colours(textbg)
}
button .selm.f3.do -text OK -command {GetSel $RowSelString $ColSelString}
bind .selm <Key-Return> {GetSel $RowSelString $ColSelString}
button .selm.f3.cancel -text cancel -command [list DoNothing .selm]
bind .selm <Key-Escape> [list DoNothing .selm]
foreach x {1 2} {
pack .selm.f$x.l$x -side left
pack .selm.f$x.e$x -side left -fill x -expand true
}
pack .selm.f3.do -side left
pack .selm.f3.cancel -side right
foreach x {1 2 3} {grid .selm.f$x -in .selm -row $x -sticky ew}
raise .selm
return
}
# Service routine for the editing of formatting commands
proc ComposeCmd {fmt} {
global thisformula
set thisformula $fmt
}
# RCSpawn --
#
# Service routine for row/column spawning.
#
# Arguments:
# rr1 row/col list 1
# rr2 row/col list 2
# switch r for rows, c for columns
#
proc RCSpawn {rr1Name rr2Name switch} {
global r c inspoint rows headrows cols sidecols f v cw
global template spawn
upvar $rr1Name rr1
upvar $rr2Name rr2
for {set in 0} {$in < $spawn} {incr in} {
set i "($in)"
# template may contain $i!
set t [subst $template]
if ![NewNameError [concat $rr1 $rr2] $t] {
set ii [lsearch $rr1 $inspoint]
if {$ii > -1} {
# insert AFTER first element:
set rr1 [concat [lrange $rr1 0 [Pred $ii]] $t \
[lrange $rr1 [This $ii] end]]
} else {
set ii [lsearch $rr2 $inspoint]
if {$ii > -1} {
# insert BEFORE 1st el:
set rr2 [concat [lrange $rr2 0 [expr $ii - 1]] $t \
[lrange $rr2 $ii end]]
} else {
set rr2 [concat $rr2 $t]
}
}
# copy over f,v,cw values:
if {$switch == "r"} {
foreach y [concat $sidecols $cols] {
if [info exists f($r,$y)] {set f($t,$y) $f($r,$y)}
if [info exists v($r,$y)] {set v($t,$y) $v($r,$y)}
}
} else {
foreach x [concat $headrows $rows] {
if [info exists f($x,$c)] {set f($x,$t) $f($x,$c)}
if [info exists v($x,$c)] {set v($x,$t) $v($x,$c)}
set cw($t) $cw($c)
}
}
}
}
Modified
TemplateDefault
.w config -cursor {}
return
}
proc RowSpawn {win} {
global rows headrows inspoint template spawn autocalc
RCSpawn headrows rows r
if $autocalc ReCalc else ReDisplay
wm withdraw $win
return
}
proc ColSpawn {win} {
global cols sidecols inspoint template spawn autocalc
RCSpawn sidecols cols c
if $autocalc ReCalc else Redisplay
wm withdraw $win
return
}
proc ReplaceElement {rr r newr} {
set ii [lsearch $rr $r]
if {($ii > -1)} {
return [lreplace $rr $ii $ii $newr]
} else {
return $rr
}
}
# NewNameError --
#
# Report error in rename row/col, such as empty template or
# attempt at using already existing name
#
# Arguments:
# rr List of existing row or col names
# newr The new name template proposed
#
# Results:
# Error code 1 in case of error
#
proc NewNameError {rr newr} {
global template
# Empty template:
if {$newr == ""} {
return 1
}
# Contains blanks:
if {[string first " " $newr] > -1} {return 1}
# Contains/is contained in already:
foreach x $rr {
if {([string first $newr $x] > -1) || ([string first $x $newr] > -1)} {
return 1
}
}
return 0
}
# RowRename --
#
# Rename selected rows. If given name (acc. to template)
# already exists, don't do it.
#
# Argument:
# win The auxiliare window containing the dialogue.
#
proc RowRename {win} {
global rows headrows sidecols cols r f v rs rowsel colsel
set oldr $r
set in 0
foreach r $rowsel {
if {$r != "title"} {
incr in
set i "($in)"
set template [subst [$win.f0.e get]]
if ![NewNameError [concat $headrows $rows] $template] {
set headrows [ReplaceElement $headrows $r $template]
set rows [ReplaceElement $rows $r $template]
set rowsel [ReplaceElement $rowsel $r $template]
foreach c [concat $sidecols $cols] {
if [info exists f($r,$c)] {
set f($template,$c) $f($r,$c)
unset f($r,$c)
}
if [info exists v($r,$c)] {
set v($template,$c) $v($r,$c)
unset v($r,$c)
}
}
set v($template,title) ${template}-
if [info exists rs($r)] {
set rs($template) $rs($r); unset rs($r)
} else {puts "RowRename: rs($r) not exist bug"}
if {$r == $oldr} {set oldr $template}
}
}
}
set r $oldr
ReDisplay
wm withdraw $win
.w config -cursor {}
Modified
return
}
# ColRename --
#
# Rename selected cols. If given name (acc. to template)
# already exists, don't do it.
#
# Argument:
# win The auxiliare window containing the dialogue.
#
proc ColRename {win} {
global cols sidecols rows headrows c f v cs cw colsel rowsel
set oldc $c
set in 0
foreach c $colsel {
if {$c != "title"} {
incr in
set i "($in)"
set template [subst [$win.f0.e get]]
if ![NewNameError [concat $sidecols $cols] $template] {
set sidecols [ReplaceElement $sidecols $c $template]
set cols [ReplaceElement $cols $c $template]
set colsel [ReplaceElement $colsel $c $template]
foreach r [concat $headrows $rows] {
if [info exists f($r,$c)] {
set f($r,$template) $f($r,$c)
unset f($r,$c)
}
if [info exists v($r,$c)] {
set v($r,$template) $v($r,$c)
unset v($r,$c)
}
}
set v(title,$template) -${template}
if [info exists cs($c)] {
set cs($template) $cs($c); unset cs($c)
} else {puts "ColRename: cs($c) not exist bug"}
if [info exists cw($c)] {
set cw($template) $cw($c); unset cw($c)
} else {puts "ColRename: cw($c) not exist bug"}
if {($c == $oldc)} {set oldc $template}
}
}
}
set c $oldc
ReDisplay
wm withdraw $win
.w config -cursor {}
Modified
return
}
# SplitSel
#
# Split rr1, rr2 into "selected" (s) and "rest" (x1, x2)
#
# Arguments:
# rr1, rr2 row/col name lists
# rs row/col selection list
# s output selected names
# x1,x2 output rest
#
proc SplitSel {rr1 rr2 rs} {
set s {}; set x1 {}; set x2 {}
foreach y $rr1 {
if {([lsearch $rs $y] == -1)} {lappend x1 $y} else {lappend s $y}
}
foreach y $rr2 {
if {([lsearch $rs $y] == -1)} {lappend x2 $y} else {lappend s $y}
}
return [list $x1 $x2 $s]
}
# CellAbove ... CellRight --
#
# Procedures referring to the value in the neighbouring cell
#
proc CellAbove {} {
global headrows rows r c v
set itemlist [concat $headrows $rows]
set x [lindex $itemlist [Pred [lsearch $itemlist $r] ] ]
return $v($x,$c)
}
proc CellBelow {} {
global headrows rows r c v
set itemlist [concat $headrows $rows]
set x [lindex $itemlist \
[Succ [lsearch $itemlist $r] [llength $itemlist] ] ]
return $v($x,$c)
}
proc CellLeft {} {
global sidecols cols r c v
set itemlist [concat $sidecols $cols]
set x [lindex $itemlist [Pred [lsearch $itemlist $c] ] ]
return $v($r,$x)
}
proc CellRight {} {
global sidecols cols r c v
set itemlist [concat $sidecols $cols]
set x [lindex $itemlist \
[Succ [lsearch $itemlist $c] [llength $itemlist] ] ]
return $v($r,$x)
}
#
# Functions Pred (predecessor), This, and Succ (successor), supporting
# moves to neighbouring cells.
#
proc Pred {i} {
set i [expr ($i - 1)]
if {$i < 0} {set i 0}
return $i
}
proc This {i} {
if {$i < 1} {set i 1}
return $i
}
proc Succ {i max} {
incr i
if {$i >= $max} {set i 0}
return $i
}
# Service routine for row/col move.
proc RCMove {rr1 rr2 rs} {
global inspoint
foreach {x1 x2 s} [SplitSel $rr1 $rr2 $rs] {break}
# ii is Insert Index
set ii [lsearch $x1 $inspoint]
if {$ii > -1} {
return [list \
[concat [lrange $x1 0 [Pred $ii]] $s [lrange $x1 [This $ii] end]] \
$x2]
} else {
set ii [lsearch $x2 $inspoint]
if {$ii > -1} {
return [list $x1 \
[concat [lrange $x2 0 [Pred $ii]] $s [lrange $x2 [This $ii] end]]]
} else {return [list $x1 [concat $x2 $s]]}
}
Modified
}
proc RowMove {} {
global headrows rows rowsel
foreach {headrows rows} [RCMove $headrows $rows $rowsel] {break}
ReDisplay
}
proc ColMove {} {
global sidecols cols colsel
foreach {sidecols cols} [RCMove $sidecols $cols $colsel] {break}
ReDisplay
}
# Service routine for row/column kill.
proc RCKill {rrName rs} {
upvar $rrName rr
set x {}
foreach y $rr {if {([lsearch $rs $y] == -1)} {lappend x $y}}
set rr $x
Modified
}
proc RowKill {} {
global r rowsel rows headrows autocalc
RCKill headrows $rowsel
RCKill rows $rowsel
set rowsel {}
set r title ;# safe
if $autocalc ReCalc ReDisplay
}
proc ColKill {} {
global c colsel cols sidecols autocalc
RCKill sidecols $colsel
RCKill cols $colsel
set colsel {}
set c title
if $autocalc ReCalc ReDisplay
}
#
# Executed when regretting a subwindow operation (pressing Cancel)
#
proc DoNothing {win} {
wm withdraw $win
.w config -cursor {}
}
#
# Window user interface for row/col spawn data input.
#
proc RCspawnWindow {title spawnCmd win} {
global template spawn colours
.w config -cursor watch
if [winfo exists $win] { wm deiconify $win; raise $win; return }
toplevel $win
wm title $win $title
CenterWin $win .w
wm resizable $win true false
frame $win.f1
frame $win.f2
frame $win.f3
label $win.f1.l1 -text "Spawn Factor:" -width 15 -anchor e
entry $win.f1.e1 -textvariable spawn -width 5 -background $colours(textbg)
label $win.f2.lfac -text "Template:" -width 15 -anchor e
entry $win.f2.efac -textvariable template -background $colours(textbg)
set com1 [list $spawnCmd $win]
set com2 [list DoNothing $win]
button $win.f3.ok -text OK -command $com1
bind $win <Key-Return> $com1
label $win.f3.info -text {-$i-} -justify center
button $win.f3.close -text Cancel -command $com2
bind $win <Key-Escape> $com2
pack $win.f1.l1 -side left
pack $win.f1.e1 -side left
pack $win.f2.lfac -side left
pack $win.f2.efac -fill x -expand true -side left
pack $win.f3.ok -side left
pack $win.f3.info -fill x -expand true -side left
pack $win.f3.close -side right
grid columnconf $win 0 -weight 1
grid $win.f1 -in $win -column 0 -row 0 -sticky ew
grid $win.f2 -in $win -column 0 -row 1 -sticky ew
grid $win.f3 -in $win -column 0 -row 2 -sticky ew
raise $win
return
}
# RCrenameWindow --
#
# User interface service routine for inputting a string,
# typically a template string for row/col rename.
#
# Arguments:
# title To appear in window title.
# labeltext To appear as label by the entry box.
# cmd Callback cmd to be associated with OK.
# win identifier of new toplevel window to be opened/used.
# rc r for row rename, c for col rename
#
proc RCrenameWindow {title labeltext renameCmd win rc} {
global colours
if [winfo exists $win] { wm deiconify $win; raise $win; return }
.w config -cursor watch
toplevel $win
wm title $win $title
CenterWin $win .w
wm resizable $win true false
frame $win.f0
frame $win.f1
label $win.f0.l -text $labeltext -anchor e
entry $win.f0.e -textvariable template -background $colours(textbg)
set doScript [list $renameCmd $win]
set cancelScript [list DoNothing $win]
button $win.f1.tag -text "Tag" -command "set template \\\$$rc#"
button $win.f1.untag -text "Untag" -command \
"set template {\[string trimright \$$rc \"#\"\]}"
button $win.f1.do -text "OK" -command $doScript
bind $win <Key-Return> $doScript
button $win.f1.close -text "Cancel" -command $cancelScript
bind $win <Key-Escape> $cancelScript
label $win.f1.info -text {-$i-} -justify center
pack $win.f0.l -side left
pack $win.f0.e -fill x -expand true -side left
pack $win.f1.do $win.f1.tag $win.f1.untag -side left
pack $win.f1.info -fill x -expand true -side left
pack $win.f1.close -side right
grid columnconf $win 0 -weight 1
grid $win.f0 -in $win -sticky ew
grid $win.f1 -in $win -sticky ew
raise $win
return
}
# Now, Today, USAtoday --
#
# Return current time, formatted, for use in clock applications and
# user file name generation.
#
proc Now {} {
set x [clock format [clock seconds]]
regsub -all { } $x {=} x
return $x
}
proc Today {} {
return [clock format [clock seconds] -format {%d-%h-%Y}]
}
proc USAtoday {} {
return [clock format [clock seconds] -format {%Y/%h/%d}]
}
# StartClock, StopClock --
#
# Routines to put a running clock (hours) into a cell, and to stop it.
# (this could be generalized by using time formatting; reminder mv)
#
proc StartClock {} {
global r c tr tc f thisformula rows cw frq sidecols cols v
if [info exists tr] {StopClock}
# Make room for date strings:
set cw(title) 36
lappend rows [Now]
# last (new) row:
set r [lindex $rows [expr ([llength $rows] - 1)]]
set fmt [.w.fr.box1.ef get]
if {$fmt == ""} {set fmt {$cw($c).2}}
set thisformula "\[format \"%${fmt}f\" \
\[expr (\[clock seconds\] - [clock seconds]) / 3600.0 \]\]"
foreach x [concat $sidecols $cols] {set f($r,$x) "-"; set v($r,$x) "-"}
set f($r,$c) $thisformula
set v($r,$c) CLOCK
set tr $r; set tc $c
ReDisplay
Modified
}
proc StopClock {} {
global r c f v thisformula tr tc
# Make sure that CLOCK cell is stopped:
set oldr $r; set oldc $c
set r $tr; set c $tc
ReCalcCell
if [info exists v($r,$c)] {
set thisformula [string trim $v($r,$c)]
} else {set thisformula "?UNDEF"}
set f($r,$c) $thisformula
Modified
ReDisplayCell
PaintCell "" "" "" notime
if [info exists tr] {unset tr}
if [info exists tc] {unset tc}
set r $oldr; set c $oldc
}
# ComposeFixed ... ComposeCurr, AddExpr, LeftAlign
#
# The formatted string composition routines, used in the
# Formula box when editing.
#
proc ComposeFixed {} {
global ef e
ComposeCmd "\[format \"%[$ef get]f\" [$e get]\]"
}
proc ComposeFloat {} {
global ef e
ComposeCmd "\[format \"%[$ef get]g\" [$e get]\]"
}
proc ComposeInt {} {
global ef e
ComposeCmd "\[format \"%[$ef get]d\" \[scan [$e get] \"%d\" x; set x\]\]"
}
proc ComposeCurr {} {
global w e
ComposeCmd "\[format \"%$\{w\}.2f\" [$e get]\]"
}
proc AddExpr {} {
global e
ComposeCmd "\[expr [$e get]\]"
}
proc LeftAlign {} {
global w e
if [regexp "\[ \t\]" [$e get]] {
# "Embrace" if multiword:
ComposeCmd "\[format \"%-$\{w\}s\" \{[$e get]\}\]"
} else {
ComposeCmd "\[format \"%-$\{w\}s\" [$e get]\]"
}
}
# CenterWin --
#
# Centers a window (win) in its parent (otherwin).
# Improved version of one found in Midnight Commander.
#
proc CenterWin {win otherwin} {
wm withdraw $win
foreach {c r} {x height y width} {set cen$c [winfo req$r $win]}
set geo [split [wm geometry $otherwin] +x]
foreach {p n} {pdx 0 pdy 1 px 2 py 3} {set $p [lindex $geo $n]}
foreach c {x y} {set $c [expr \$p$c+((\$pd$c-\$cen$c)/2)]}
wm geometry $win +$x+$y
wm deiconify $win
}
# TagsConfig --
#
# (re-)Configure the colour tags used in spreadsheet panels
#
proc TagsConfig {} {
global frq colours
foreach panel {main side head corner} {
$frq.$panel tag config title -background $colours(selcolour)
$frq.$panel tag config time -foreground $colours(timecolour)
$frq.$panel tag config instag -foreground $colours(inscolour)
$frq.$panel tag config current -background $colours(textcur)\
-foreground $colours(textbg)
# "blank" tag:
$frq.$panel tag config curtitle
$frq.$panel tag config mancolour -background $colours(mancolour)
}
return
}
# KeyRight ... KeyDown --
#
# One cell cursor motion routines.
#
proc KeyRight {} {
global sidecols cols c
KeyForward [concat $sidecols $cols] $c "c"
return
}
proc KeyLeft {} {
global sidecols cols c
KeyBackward [concat $sidecols $cols] $c "c"
return
}
proc KeyUp {} {
global headrows rows r
KeyBackward [concat $headrows $rows] $r "r"
return
}
proc KeyDown {} {
global headrows rows r
KeyForward [concat $headrows $rows] $r "r"
return
}
# UnPaintCurrentCell --
#
# Remove "current cell" painting from WHOLE spreadsheet
#
proc UnPaintCurrentCell {} {
global headrows rows sidecols cols
PaintCell "" "" "" nocurrent
PaintCell "" "" "" nocurtitle
return
}
# PaintCurrentCell --
#
# Paint the current cell with coloured tag "current", and tag
# (for "see" operation, scrolling) associated row/col title cells
#
proc PaintCurrentCell {} {
global r c
PaintCell [RowColPanel $r $c] $r $c current
PaintCell [RowColPanel title $c] title $c curtitle
PaintCell [RowColPanel $r title] $r title curtitle
return
}
proc KeyForward {itemlist item rc} {
global r c
UnPaintCurrentCell
set x [lindex $itemlist [Succ [lsearch $itemlist $item] [llength $itemlist] ] ]
if {$rc == "r"} {set r $x} {set c $x}
PaintCurrentCell
}
proc KeyBackward {itemlist item rc} {
global r c
UnPaintCurrentCell
set x [lindex $itemlist [Pred [lsearch $itemlist $item] ] ]
if {$rc == "r"} {set r $x} {set c $x}
PaintCurrentCell
}
# Put an info label stating default dir of motion, autocalc:
#
proc PutInfo {} {
global defmov autocalc fr tools
if $autocalc {set au "Auto"} else {set au "-"}
switch -- $defmov {
{-} {}
{Left} KeyLeft
{Right} KeyRight
{Up} KeyUp
{Down} KeyDown
}
$tools.flag configure -text "$defmov $au"
}
#
# Keep track of focus status:
#
proc NavFocus {} {
global frq colours
focus $frq
$frq.flag configure -text "NAV" -foreground $colours(mancolour)
.w config -cursor {}
return
}
proc EditFocus {} {
global frq colours
focus .w.fr.box1.e
$frq.flag configure -text "EDIT" -foreground $colours(mancolour)
return
}
#
# Keep track of modification status and display logo:
#
proc Modified {} {
global modified frq
MakeLogo red
set modified 1
set reload 1
}
proc UnModified {} {
global modified frq
MakeLogo #00b000
set modified 0
}
# MakeLogo --
#
# Draw the tk# logo in green or red (indicating "modified").
#
# Argument:
# colour either green or red
#
proc MakeLogo {colour} {
global colours
return [if [info exists logo] {image delete logo}
image create bitmap logo -foreground $colour -data {
#define tk_pic2_width 30
#define tk_pic2_height 27
static unsigned char tk_pic2_bits[] = {
0x00, 0x00, 0x00, 0x00, 0x10, 0x02, 0x00, 0x00, 0x10, 0x02, 0x00, 0x00,
0x18, 0x03, 0x00, 0x00, 0x08, 0x11, 0x00, 0x00, 0xbe, 0x1d, 0x00, 0x00,
0x88, 0x05, 0x00, 0x00, 0x8c, 0xe3, 0x0c, 0x03, 0x84, 0xe2, 0x0c, 0x03,
0xc6, 0x06, 0x0c, 0x03, 0x42, 0x0c, 0x8e, 0x03, 0x7e, 0x08, 0x86, 0x01,
0x00, 0x00, 0x86, 0x01, 0x00, 0xe0, 0xff, 0x0f, 0x00, 0xe0, 0xff, 0x0f,
0x00, 0x00, 0xc3, 0x00, 0x00, 0x00, 0xc3, 0x00, 0x00, 0x80, 0x61, 0x00,
0x00, 0x80, 0x61, 0x00, 0x00, 0xf8, 0xff, 0x03, 0x00, 0xf8, 0xff, 0x03,
0x00, 0xc0, 0x30, 0x00, 0x00, 0xc0, 0x30, 0x00, 0x00, 0xe0, 0x38, 0x00,
0x00, 0x60, 0x18, 0x00, 0x00, 0x60, 0x18, 0x00, 0x00, 0x00, 0x00, 0x00};
}]
}
# Service routine for inserting math functions in Formula box:
proc InsertFunction {be en} {
global e
if [$e selection present] {
$e insert sel.first $be
$e insert sel.last $en
$e selection from [expr [$e index sel.first] - [string length $be]]
$e selection to [expr [$e index sel.last] + [string length $en]]
} else {
$e insert insert $be
$e insert insert $en
$e icursor [expr [$e index insert] - [string length $en]]
}
}
# ConcatNoTitle --
#
# Concatenate two lists of row/col names, but leave "title" out
#
proc ConcatNoTitle {rr1 rr2} {
set s {}
set rr [concat $rr1 $rr2]
foreach x $rr {
if {$x != "title"} {lappend s $x}
}
return $s
}
# BuildMenu --
#
# Construct the pulldown menu of tk#.
#
proc BuildMenu {} {
global fr b exp lfl lfs defmov e reps
set b [frame $fr.box0 -relief raised -borderwidth 2]
menubutton $b.file -text File -menu $b.file.menu -underline 0
set m [menu $b.file.menu -tearoff 0]
$m add command -label Load -command {Load 1}
$m add command -label Save -command {Save 0} -accel "^S"
$m add command -label "Save As..." -command {Save 1}
$m add command -label "Save Select" -command {Save 2}
$m add separator
$m add command -label "Load Repository" -command {Load 2}
$m add command -label "Show Repositories" -command {
wm title .w "Rep: $reps"
}
$m add separator
$m add cascade -label "Export Set-Up" -menu $m.sub0
set m2 [menu $m.sub0 -tearoff 1]
$m2 add radio -label "All" -variable exp(howmuch)
$m2 add radio -label "Selection" -variable exp(howmuch)
set exp(howmuch) "All"
$m2 add separator
$m2 add check -label "Title Row" -variable exp(titlerow)
$m2 add check -label "Title Col" -variable exp(titlecol)
set exp(titlerow) 0; set exp(titlecol) 0
$m2 add separator
$m2 add radio -label "Tab" -variable exp(separ)
$m2 add radio -label "Comma" -variable exp(separ)
$m2 add radio -label "Blank" -variable exp(separ)
$m2 add radio -label "Newline" -variable exp(separ)
$m2 add radio -label "None" -variable exp(separ)
$m2 add radio -label "LaTeX" -variable exp(separ)
set exp(separ) "Tab"
$m add command -label "Export" -command Export
$m add command -label "Import" -command Import
$m add separator
$m add command -label Quit -command QuitWarn -accelerator "^Q"
$m add separator
# quotes to force eval here:
$m add command -label "$lfl" -command "set filename $lfl ; Load 0"
$m add command -label "$lfs" -command "set filename $lfs ; Load 0"
menubutton $b.editrc -text Edit -menu .w.fr.box0.editrc.menu -underline 0
set m [menu $b.editrc.menu -tearoff 0]
$m add command -label "Row Spawn" -command {
RCspawnWindow "Row Spawn" RowSpawn ".rs"
}
$m add command -label "Row Rename" -command {
RCrenameWindow "Row Rename" "New Name Template:" RowRename\
.rren r
}
$m add command -label "Row Move" -command RowMove
$m add command -label "Row Kill" -command RowKill
$m add separator
$m add command -label "Col Spawn" -command {
RCspawnWindow "Col Spawn" ColSpawn ".cs"
}
$m add command -label "Col Rename" -command {
RCrenameWindow "Column Rename" "New Name Template:" ColRename\
.cren c
}
$m add command -label "Col Move" -command ColMove
$m add command -label "Col Kill" -command ColKill
menubutton $b.sel -text Select -menu $b.sel.menu -underline 0
set m [menu $b.sel.menu -tearoff 1]
$m add command -label "Row Select Box" -command {
SelectEdit [ConcatNoTitle $rows $headrows] r \
"Row Select by Listbox" multiple rowsel
}
$m add command -label "Col Select Box" -command {
SelectEdit [ConcatNoTitle $cols $sidecols] c \
"Col Select by Listbox" multiple colsel
}
$m add command -label "Select Match" -command SelectMatch
$m add separator
$m add command -label "Select All" -command {
set rowsel [ConcatNoTitle $headrows $rows]
set colsel [ConcatNoTitle $sidecols $cols]
PaintSelect
}
$m add separator
$m add command -label "Insert Mark" -command {
SelectEdit [concat $headrows $rows $sidecols $cols] i \
"Set Insert Mark" single inspoint
}
$m add separator
# Here a match string for the selected set of rows/cols is inserted
# (Thanks Bruce Gingery for the idea):
$m add command -label "Row Matchmaker" -command {
$e insert insert [join $rowsel |]
# necessary :-(
set rowsel $r
}
$m add command -label "Col Matchmaker" -command {
$e insert insert [join $colsel |]
set colsel $c
}
menubutton $b.format -text Format -menu $b.format.menu
set m [menu $b.format.menu -tearoff 1]
$m add command -label "Fixed Real" -acc "^F" -command ComposeFixed
$m add command -label "Floating Real" -acc "^G" -command ComposeFloat
$m add command -label "Integer" -acc "^N" -command ComposeInt
$m add command -label "Currency" -acc "^C" -command ComposeCurr
$m add command -label "Left-Align" -acc "^L" -command LeftAlign
$m add separator
$m add command -label {Add [expr...]} -acc "^E" -command AddExpr
$m add command -label {Remove [expr...]} -command {
if [regexp {^\[expr (.*)\]$} [$e get] dummy y] {ComposeCmd $y}
}
$m add command -label {Remove [format...]} -command {
if [regexp {^\[format +"[^"]*" +(.*)\] *$} \
[$e get] dummy y] {
ComposeCmd $y
}
# Remove excess curlies if necessary (for leftalign multiword):
if [regexp {\{(.*)\}} [$e get] dummy y] {
ComposeCmd $y
}
# remove scan if necessary (for compose integer):
if [regexp {^\[scan +(.+)"[^"]*" +.+\] *$} [$e get] dummy y] {
ComposeCmd $y
}
}
$m add separator
$m add command -label "Replace by Value" \
-command {set thisformula [subst [$e get]]}
$m add separator
$m add command -label "Clear" -command {set thisformula ""}
menubutton $b.calc -text Options -menu $b.calc.menu -underline 0
set m [menu $b.calc.menu -tearoff 0]
$m add check -label AutoCalc -variable autocalc -command PutInfo
$m add command -label ReCalc -command ReCalc
$m add command -label "ReCalc Sel" -command {ReCalc 1}
$m add command -label "ReDisplay" -command ReDisplay
$m add separator
foreach x {- Left Right Up Down} {
$m add radio -label $x -var defmov -command PutInfo
}
set defmov "-"
menubutton $b.math -text Math -menu $b.math.menu -underline 0
set m [menu $b.math.menu -tearoff 0]
$m add cascade -label "Functions 1" -menu $m.sub1
set m2 [menu $m.sub1 -tearoff 1]
foreach x {acos cos sinh asin cosh log sqrt atan exp log10 tan tanh sin} {
$m2 add command -label $x -command [list InsertFunction "$x\(" ")"]
}
$m add cascade -label "Functions 2" -menu $m.sub2
set m2 [menu $m.sub2 -tearoff 1]
foreach x {floor ceil abs double int round hypot atan2 pow fmod} {
$m2 add command -label $x -command [list InsertFunction "$x\(" ")"]
}
$m add cascade -label "Row Aggregate" -menu $m.sub3
set m2 [menu $m.sub3 -tearoff 1]
foreach x {Sum Av Cnt wSum wAv Ssq sSsq RMS wRMS Sd wSd} {
$m2 add command -label "$x" \
-command [list InsertFunction "\[$x r " "\]"]
}
$m add cascade -label "Col Aggregate" -menu $m.sub4
set m2 [menu $m.sub4 -tearoff 1]
foreach x {Sum Av Cnt wSum wAv Ssq sSsq RMS wRMS Sd wSd} {
$m2 add command -label "$x" \
-command [list InsertFunction "\[$x c " "\]"]
}
menubutton $b.clock -text Clock -menu $b.clock.menu -underline 0
set m [menu $b.clock.menu -tearoff 0]
$m add command -label "(Re-)Start" -command StartClock
$m add command -label "Stop" -command StopClock
menubutton $b.colour -text Colour -menu $b.colour.menu
set m [menu $b.colour.menu -tearoff 1]
$m add command -lab "Foreground" -command {ColourReconfig textfg}
$m add command -lab "Background" -command {ColourReconfig textbg}
$m add command -lab "Current Cell" -command {ColourReconfig textcur}
$m add command -lab "Insert Point" -command {ColourReconfig inscolour}
$m add command -lab "Selection" -command {ColourReconfig selcolour}
$m add command -lab "Clock Cell" -command {ColourReconfig timecolour}
$m add separator
$m add command -lab "tk# icon" -command {ColourReconfig iconcolour}
$m add command -lab "man titles" -command {ColourReconfig mancolour}
$m add separator
$m add command -lab "Default" -command {
ColourDefault
ColoursSet
}
menubutton $b.help -text Help -menu $fr.box0.help.menu -underline 0
set m [menu $b.help.menu -tearoff 0]
$m add command -label "Manual" -command Manual
$m add command -label "About..." -command About
}
# ShowWindow --
#
# Construct and display rest of the GUI of tk#.
#
proc ShowWindow {} {
global thisformula cwidth titlerow titlecol
global colours winsize
global filename autocalc inspoint headrows rows sidecols cols
# Symbolic widget names:
# b menubutton row
# e Formula: entrybox
# ef Format: entrybox
# ew Colwidth: entrybox
# fr frame around everything
# frq frame around spreadsheet panels
# tools tool button bar.
global b e ef ew fr frq tools
if {[winfo exists .w]} { wm deiconify .w; return }
#
# Widgets definition:
#
frame .w ; pack .w
wm geometry .w $winsize
wm minsize .w 1 1
wm resizable .w 1 1
wm title .w "tk# -- a spreadsheet with a difference"
bind .w <Destroy> {if {"%W" == ".w"} {QuitWarn}}
bind .w <Control-s> {Save 0}
bind .w <Control-q> QuitWarn
set fr [frame .w.fr -borderwidth 0 -height 45 -width 50]
set frq [frame $fr.frq -highlightcolor black -highlightthickness 2 \
-borderwidth 0]
set logo [MakeLogo #00b000]
button $frq.logo -padx 0 -pady 0 -image logo \
-relief raised -borderwidth 2 -command {Save 0}
label $frq.flag -anchor w -pady 0
bind $frq.flag <Button> NavFocus
NavFocus
set tools [frame $fr.tools -borderwidth 0]
# toolbar:
button $tools.quit -pady 0 -text Quit -command QuitWarn
button $tools.save -pady 0 -text Save -command {Save 0}
button $tools.calc -pady 0 -text Calc -command ReCalc
button $tools.view -pady 0 -text View -command {ReDisplay; PutInfo}
button $tools.start -pady 0 -text Start -command StartClock
button $tools.stop -pady 0 -text Stop -command StopClock
label $tools.flag -pady 0 -width 20 -foreground $colours(mancolour)
PutInfo
# The two scrollbars:
scrollbar $frq.hscroll -borderwidth 1 -comm {HorizScroll} -orient horiz
scrollbar $frq.vscroll -borderwidth 1 -comm {VertScroll} -orient vert
# The four main spreadsheet panels:
text $frq.main -wrap none -font fixed -background $colours(textbg) \
-foreground $colours(textfg)\
-xscrollcommand {.w.fr.frq.hscroll set} \
-yscrollcommand {.w.fr.frq.vscroll set}
text $frq.head -wrap none -background $colours(textbg) \
-foreground $colours(textfg)\
-font fixed -height 3 -xscrollcommand {.w.fr.frq.hscroll set}
text $frq.side -wrap none -background $colours(textbg) \
-foreground $colours(textfg)\
-font fixed -width 20 -yscrollcommand {.w.fr.frq.vscroll set}
text $frq.corner -width 20 -height 3 -font fixed -wrap none\
-background $colours(textbg) -foreground $colours(textfg)
BuildMenu
frame $fr.box1
label $fr.box1.l -text "Formula:" -width 8 -anchor e
set e [entry $fr.box1.e -textvariable thisformula \
-background $colours(textbg)]
bind $e <Key-Return> {GetFormula}
bind $e <Key-Escape> {NavFocus}
bind $e <Key-Down> {NavFocus; KeyDown}
bind $e <Key-Up> {NavFocus; KeyUp }
bind $e <Button> {EditFocus}
# Keybindings for entry formatting:
bind $e <Control-f> {ComposeFixed}
bind $e <Control-g> {ComposeFloat}
bind $e <Control-n> {ComposeInt}
bind $e <Control-c> {ComposeCurr}
bind $e <Control-e> {AddExpr}
bind $e <Control-l> {LeftAlign}
label $fr.box1.lw -text "Colwidth:" -width 8 -anchor e
set ew [entry $fr.box1.ew -textvariable cwidth \
-background $colours(textbg) -width 4]
bind $ew <Key-Return> {ColWidth}
bind $ew <Key-Escape> {NavFocus}
bind $ew <Button> {EditFocus}
label $fr.box1.lf -text "Format:" -width 7 -anchor e
set ef [entry $fr.box1.ef -textvariable fmtitem \
-background $colours(textbg) -width 4]
bind $ef <Button> {EditFocus}
bind $ef <Key-Escape> {NavFocus}
foreach panel {main head side corner} {
$frq.$panel config -cursor arrow
bind $frq.$panel <Button-1> [list GetMouse1 $panel]
bind $frq.$panel <Button-3> [list GetMouse3 $panel]
}
# bind the middle mouse button dragging function:
foreach panel {main head side corner} {
bind $frq.$panel <B2-Motion>\
[list BindDragto %x %y $frq.main $frq.head $frq.side $frq.corner]
bind $frq.$panel <Button-2> {
[list BindMark %x %y $frq.main $frq.head $frq.side $frq.corner]
}
}
foreach panel {main head side corner} {
bind $frq.$panel <Button-2> [list GetMouse2 $panel]
}
# The arrow keys:
bind $frq <Key-Right> KeyRight
bind $frq <Key-Left> KeyLeft
bind $frq <Key-Down> KeyDown
bind $frq <Key-Up> KeyUp
bind $frq <Control-Key-Right> {$frq.main xview scroll 1 pages}
bind $frq <Control-Key-Left> {$frq.main xview scroll -1 pages}
bind $frq <Control-Key-Down> {$frq.main yview scroll 1 pages}
bind $frq <Control-Key-Up> {$frq.main yview scroll -1 pages}
bind $frq <Key-Return> {SetUpEntry}
bind $frq <Key-Escape> {SetUpForEdit}
foreach panel {side head corner} {
$frq.$panel tag config underline -background #d9d9d9 \
-relief raised -borderwidth 2
}
TagsConfig
#
# Geometry definition:
#
grid columnconf .w 0 -weight 1
grid rowconf .w 0 -weight 1
grid $fr -in .w -column 0 -row 0 -sticky news
grid columnconf $fr 0 -weight 1
grid rowconf $fr 3 -weight 1
pack $b.file $b.editrc $b.format $b.sel \
$b.calc $b.math $b.colour $b.clock -side left
pack $b.help -side right
pack $fr.box1.l -side left
pack $fr.box1.e -side left -fill x -expand true
pack $fr.box1.ew $fr.box1.lw $fr.box1.ef $fr.box1.lf -side right
grid $b -sticky ew
grid $fr.box1 -sticky ew
grid $tools -sticky ew
pack $tools.quit -side right
pack $tools.save $tools.flag $tools.calc \
$tools.view $tools.start $tools.stop -side left
grid $frq -in $fr -sticky news
grid columnconf $frq 2 -weight 1
grid rowconf $frq 2 -weight 1
grid $frq.logo $frq.flag $frq.hscroll -sticky new
grid ^ $frq.corner $frq.head -sticky news
grid $frq.vscroll $frq.side $frq.main -sticky news
focus $frq
UnModified
}
init $argc $argv
ShowWindow
# command line filename(s):
foreach filename $argv {
Load 0
}
ReCalc
