From 2d3cc6aaa4bcc1f5b9409ef60a9f5e4ba47a8110 Mon Sep 17 00:00:00 2001 From: Andreas Kupries Date: Fri, 28 Nov 2003 22:42:03 +0000 Subject: [PATCH 0001/1290] * Reworked the entire build system to use the same framework as tcllib does. IOW tklib now uses a swiss army knife tool (sak.tcl, with all attendant files), and configure/Makefile are based on that. Generation of distributions, and installer now also work in the same way as for tcllib. * Replaced existing nroff documentation with doctools manpages, and wrote doctools manpages for the modules which had none. All (four) modules now have documentation. --- ChangeLog | 12 + INSTALL.txt | 77 ++ Makefile.in | 221 ++--- README | 82 +- all.tcl | 74 +- config/tcl.m4 | 8 +- configure | 133 +-- configure.in | 32 +- install_action.tcl | 96 +++ installed_modules.tcl | 30 + installer.tcl | 486 +++++++++++ main.tcl | 4 + mkIndex.tcl | 33 - mkInstallScripts.tcl | 50 -- modules/autoscroll/autoscroll.man | 4 +- modules/cursor/cursor.man | 44 + modules/cursor/cursor.n | 53 -- modules/datefield/datefield.man | 58 ++ modules/datefield/datefield.n | 61 -- sak.tcl | 1325 +++++++++++++++++++++++++++++ tklib_version.tcl | 2 + 21 files changed, 2347 insertions(+), 538 deletions(-) create mode 100644 INSTALL.txt create mode 100644 install_action.tcl create mode 100755 installed_modules.tcl create mode 100755 installer.tcl create mode 100755 main.tcl delete mode 100644 mkIndex.tcl delete mode 100644 mkInstallScripts.tcl create mode 100644 modules/cursor/cursor.man delete mode 100644 modules/cursor/cursor.n create mode 100644 modules/datefield/datefield.man delete mode 100644 modules/datefield/datefield.n create mode 100755 sak.tcl create mode 100644 tklib_version.tcl diff --git a/ChangeLog b/ChangeLog index 74669d01..fb698cd0 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,15 @@ +2003-11-28 Andreas Kupries + + * Reworked the entire build system to use the same framework as + tcllib does. IOW tklib now uses a swiss army knife tool + (sak.tcl, with all attendant files), and configure/Makefile are + based on that. Generation of distributions, and installer now + also work in the same way as for tcllib. + + * Replaced existing nroff documentation with doctools manpages, + and wrote doctools manpages for the modules which had none. All + (four) modules now have documentation. + 2003-07-21 Aaron Faupell * imported ipentry into tklib diff --git a/INSTALL.txt b/INSTALL.txt new file mode 100644 index 00000000..64788fea --- /dev/null +++ b/INSTALL.txt @@ -0,0 +1,77 @@ +How to install Tklib +===================== + +Introduction +------------ + +The tklib distribution, whether a snapshot directly from CVS, or +officially released, offers a single method for installing tklib, +based on Tcl itself. + +This is based on the assumption that for tklib to be of use Tcl has +to be present, and therefore can be used. + +This single method however can be used in a variety of ways. + +0 For an unwrapped (= directory) distribution or CVS snapshot + + a. either call the application 'installer.tcl' directly, + b or use + + % configure ; make install + + The latter is provided for people which are used to + this method and more comfortable with it. In end this + boils down into a call of 'installer.tcl' too. + +1. A starpack distribution (window-only) is a self-extracting + installer which internally uses the aforementioned installer. + +2. A starkit distribution is very much like a starpack, but + required an external interpreyter to run. This can be any tcl + interpreter which has all the packages to support starkits + (tclvfs, memchan, trf). + +3. A distribution in a tarball has to be unpacked first, then any + of the methods described in (0) can be used. + + +Usage of the installer +---------------------- + +The installer selects automatically either a gui based mode, or a +command line based mode. If the package Tk is present and can be +loaded, then the GUI mode is entered, else the system falls back to +the command line. + +Note that it is possible to specify options on the command line even +if the installer ultimatively selects a gui mode. In that case the +hardwired defaults and the options determine the data presented to the +user for editing. + +Command line help can be asked for by using the option -help when +running the installer (3) or the distribution itself in the case of +(1) or (2). + +The installer will select a number of defaults for the locations of +packages, examples, and documentation, and also the format of the +documentation. The user can overide these defaults in the GUI, or by +specifying additional options. + +The defaults depend on the platform detected (unix/windows) and the +executable used to run the installer. In the case of a starpack +distribution (1) this means that _no defaults_ are possible for the +various locations as the executable is part of the distribution and +has no knowledge of its environment. + +In all other cases the intepreter executable is outside of the +distribution, which means that its location can be used to determine +sensible defaults. + +Notes +----- + +The installer will overwrite an existing installation of tklib 0.2 +without asking back after the initial confirmation is given. And if +the user chooses the same directory as for tklib 0.1, or 0.0, etc. +then the installer will overwrite that too. diff --git a/Makefile.in b/Makefile.in index c1a322ff..11486494 100644 --- a/Makefile.in +++ b/Makefile.in @@ -1,36 +1,18 @@ # Makefile.in -- # -# This file is a Makefile for the tklib standard Tk library. If this +# This file is a Makefile for the tklib standard tcl library. If this # is "Makefile.in" then it is a template for a Makefile; to generate # the actual Makefile, run "./configure", which is a configuration script # generated by the "autoconf" program (constructs like "@foo@" will get # replaced in the actual Makefile. # +# Copyright (c) 1999-2000 Ajuba Solutions +# Copyright (c) 2001 ActiveState Tool Corp. +# # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: Makefile.in,v 1.5 2003/07/28 05:02:53 afaupell Exp $ - -# ModuleName: specify short description of module here -#MODULENAME=moduleDirName - -# ModuleName: specify short description of module here -CURSOR=cursor - -# An enhanced text entry widget for entering dates -DATEFIELD=datefield - -# An entry for ip addresses -IPENTRY=ipentry - -# Automatic scrollbars -AUTOSCROLL=autoscroll - -MODULES= \ - $(CURSOR) \ - $(DATEFIELD) \ - $(IPENTRY) \ - $(AUTOSCROLL) \ +# RCS: @(#) $Id: Makefile.in,v 1.6 2003/11/28 22:42:03 andreas_kupries Exp $ #======================================================================== # Nothing of the variables below this line need to be changed. Please @@ -40,199 +22,94 @@ MODULES= \ SHELL = @SHELL@ -INSTALL_ROOT = - srcdir = @srcdir@ top_srcdir = @top_srcdir@ prefix = @prefix@ exec_prefix = @exec_prefix@ - libdir = @libdir@ mandir = @mandir@ DESTDIR = - pkglibdir = $(libdir)/@PACKAGE@@VERSION@ - top_builddir = . -INSTALL = @INSTALL@ -INSTALL_PROGRAM = @INSTALL_PROGRAM@ -INSTALL_DATA = @INSTALL_DATA@ -INSTALL_SCRIPT = @INSTALL_SCRIPT@ -INSTALL_STRIP_FLAG = -transform = @program_transform_name@ - -NORMAL_INSTALL = : -PRE_INSTALL = : -POST_INSTALL = : -NORMAL_UNINSTALL = : -PRE_UNINSTALL = : -POST_UNINSTALL = : - PACKAGE = @PACKAGE@ VERSION = @VERSION@ CYGPATH = @CYGPATH@ -TCLSH_PROG = @TCLSH_PROG@ -AUTOCONF = autoconf +TCLSH_PROG = @TCLSH_PROG@ -ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 -CONFIGDIR = @CONFIGDIR@ -mkinstalldirs = $(SHELL) $(CONFIGDIR)/mkinstalldirs CONFIG_CLEAN_FILES = #======================================================================== # Start of user-definable TARGETS section #======================================================================== -#======================================================================== -# TEA TARGETS. Please note that the "libraries:" target refers to platform -# independent files, and the "binaries:" target inclues executable programs and -# platform-dependent libraries. Modify these targets so that they install -# the various pieces of your package. The make and install rules -# for the BINARIES that you specified above have already been done. -#======================================================================== +all: +doc: html-doc nroff-doc -all: libraries doc - -#======================================================================== -# The binaries target builds executable programs, Windows .dll's, unix -# shared/static libraries, and any other platform-dependent files. -# The list of targets to build for "binaries:" is specified at the top -# of the Makefile, in the "BINARIES" variable. -#======================================================================== +install: + $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/installer.tcl` \ + -no-examples -no-html \ + -pkg-path $(DESTDIR)$(pkglibdir) \ + -nroff-path $(DESTDIR)$(mandir)/mann \ + -no-wait -no-gui -binaries: +install-libraries: + $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/installer.tcl` \ + -pkg-path $(DESTDIR)$(pkglibdir) \ + -no-examples -no-html -no-nroff \ + -no-wait -no-gui -libraries: - -doc: - -install: all install-libraries install-doc - -install-binaries: - -#======================================================================== -# This rule installs platform-independent files, such as header files. -#======================================================================== - -install-libraries: libraries - $(mkinstalldirs) $(DESTDIR)$(pkglibdir) - @echo "Installing modules in $(DESTDIR)$(pkglibdir)" - @for i in $(MODULES) ; do \ - if test -d $(srcdir)/modules/$$i; then \ - echo "Installing $$i in $(DESTDIR)$(pkglibdir)/$$i" ; \ - $(mkinstalldirs) $(DESTDIR)$(pkglibdir)/$$i ; \ - for j in $(srcdir)/modules/$$i/*.tcl ; do \ - $(INSTALL_DATA) $$j $(DESTDIR)$(pkglibdir)/$$i ; \ - done; \ - fi; \ - done; - $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/mkIndex.tcl` `$(CYGPATH) $(DESTDIR)$(pkglibdir)` tklib $(VERSION) $(MODULES) - -# AK: Mar 26, 2001: Added 'smtp' explicitly to the list of modules (is part of 'mime'). - -#======================================================================== -# Install documentation. Unix manpages should go in the $(mandir) -# directory. -#======================================================================== - -install-doc: doc - $(mkinstalldirs) $(DESTDIR)$(mandir)/mann - -for j in $(MODULES) ; do \ - echo "Installing documentation for $$j" ; \ - for i in $(srcdir)/modules/$$j/*.n ; do \ - $(INSTALL_DATA) $$i $(DESTDIR)$(mandir)/mann ; \ - done; \ - done - -chmod 444 $(DESTDIR)$(mandir)/mann/* - $(INSTALL_DATA) $(srcdir)/man.macros $(DESTDIR)$(mandir) +install-doc: + $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/installer.tcl` \ + -nroff-path $(DESTDIR)$(mandir)/mann \ + -no-examples -no-pkgs -no-html \ + -no-wait -no-gui test: - $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/all.tcl` -modules "$(MODULES)" + $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` test depend: - -# Make a distribution. This includes: -# Code, doc's, and tests for all modules -# Generated installer for Windows (INSTALL.BAT) and UNIX (install.sh) -# This all gets archived together (tklib$(VERSION).zip or -# tklib$(VERSION).tar.gz). dist: - rm -rf $(srcdir)/tklib$(VERSION) tklib$(VERSION).tar.gz tklib$(VERSION).zip - @mkdir $(srcdir)/tklib$(VERSION) - -for j in $(MODULES) ; do \ - mkdir $(srcdir)/tklib$(VERSION)/$$j ; \ - cp $(srcdir)/modules/$$j/*.n $(srcdir)/tklib$(VERSION)/$$j ; \ - cp $(srcdir)/modules/$$j/*.txt $(srcdir)/tklib$(VERSION)/$$j ; \ - cp $(srcdir)/modules/$$j/*.xml $(srcdir)/tklib$(VERSION)/$$j ; \ - cp $(srcdir)/modules/$$j/*.html $(srcdir)/tklib$(VERSION)/$$j ; \ - cp $(srcdir)/modules/$$j/*.tcl $(srcdir)/tklib$(VERSION)/$$j ; \ - cp $(srcdir)/modules/$$j/*.test $(srcdir)/tklib$(VERSION)/$$j ; \ - done - $(TCLSH_PROG) $(srcdir)/mkIndex.tcl $(srcdir)/tklib$(VERSION) tklib $(VERSION) $(MODULES) - $(TCLSH_PROG) $(srcdir)/mkInstallScripts.tcl $(srcdir)/tklib$(VERSION) tklib $(VERSION) $(MODULES) - for j in license.terms README ; do \ - cp $(srcdir)/$$j $(srcdir)/tklib$(VERSION)/$$j ; \ - done - cd $(srcdir) - tar cf tklib$(VERSION).tar tklib$(VERSION) - gzip tklib$(VERSION).tar - zip -r tklib$(VERSION).zip tklib$(VERSION) - rm -rf $(srcdir)/tklib$(VERSION) + $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` gendist -#======================================================================== -# End of user-definable section -#======================================================================== - -#======================================================================== -# Don't modify the file to clean here. Instead, set the "CLEANFILES" -# variable in configure.in -#======================================================================== - -clean: +clean: + rm -rf doc *-doc distclean: clean -rm -f Makefile $(CONFIG_CLEAN_FILES) -rm -f config.cache config.log stamp-h stamp-h[0-9]* -rm -f config.status -#======================================================================== -# Install binary object libraries. On Windows this includes both .dll and -# .lib files. Because the .lib files are not explicitly listed anywhere, -# we need to deduce their existence from the .dll file of the same name. -# Additionally, the .dll files go into the bin directory, but the .lib -# files go into the lib directory. On Unix platforms, all library files -# go into the lib directory. In addition, this will generate the pkgIndex.tcl -# file in the install location (assuming it can find a usable tclsh8.2 shell) -# -# You should not have to modify this target. -#======================================================================== - -install-lib-binaries: installdirs +Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status + cd $(top_builddir) \ + && CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status -#======================================================================== -# Install binary executables (e.g. .exe files) -# -# You should not have to modify this target. -#======================================================================== +uninstall-binaries: -install-bin-binaries: installdirs -.SUFFIXES: .c .o .obj +html-doc: + $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` html +nroff-doc: + $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` nroff +tmml-doc: + $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` tmml +wiki-doc: + $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` wiki +latex-doc: + $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` ps +list-doc: + $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` list -Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status - cd $(top_builddir) \ - && CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status +check: + $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` validate -uninstall-binaries: +sak-help: + $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` help -installdirs: - $(mkinstalldirs) $(DESTDIR)$(pkglibdir) -.PHONY: all binaries clean depend distclean doc install installdirs \ -libraries test +.PHONY: all binaries clean depend distclean doc install installdirs libraries test # Tell versions [3.59,3.63) of GNU make to not export all variables. # Otherwise a system limit (for SysV at least) may be exceeded. diff --git a/README b/README index d06f62c3..c2b06465 100644 --- a/README +++ b/README @@ -1,10 +1,19 @@ -RCS: @(#) $Id: README,v 1.2 2001/11/08 19:14:22 hobbs Exp $ +RCS: @(#) $Id: README,v 1.3 2003/11/28 22:42:03 andreas_kupries Exp $ Welcome to the tklib, the Tk Standard Library. This package is intended to be a collection of Tcl packages that provide utility functions useful to a large collection of Tcl programmers. -The structure of the tklib source heirarchy is: +The home web site for this code is http://tcllib.sourceforge.net/ . +At this web site, you will find mailing lists, web forums, databases +for bug reports and feature requests, the CVS repository (browsable on +the web, or read-only accessible via CVS ), and more. + +Please note that tklib depends on tcllib, the Tcl Standard Library. +This is true for both installation and runtime. + + +The structure of the tklib source hierarchy is: tklib +- modules @@ -13,9 +22,9 @@ tklib +- ... -The install heirarchy is: +The install hierarchy is: -.../lib/tklib +.../lib/tklib +- +- +- ... @@ -25,31 +34,59 @@ will be added to tklib: * the module must be a proper Tcl package * the module must use a namespace for its commands and variables -* the name of the package must be the same as the name of the namespace +* the name of the package must be the same as the name of the + namespace * the module must reside in a subdirectory of the modules directory in - the source heirarchy, and that subdirectory must have the same name - as the package and namespace. A module may opt to have multiple - similar packages (ie: clock), in which case the module name must not - match the packages therein. + the source hierarchy, and that subdirectory must have the same name + as the package and namespace * the module must be released under the BSD License, the terms of which can be found in the toplevel tklib source directory in the file license.terms -* the module should have both documentation (in XML, man, or HTML - form) and a test suite (in the form of a group of *.test files in - the module directory). It is very hard for users to make use of - modules when neither are present. Even a stub doc that states the - available commands is useful. +* the module should have both documentation ([*]) and a test suite + (in the form of a group of *.test files in the module directory). + + [*] Possible forms: doctools, TMML/XML, nroff (man), or HTML. + The first format is the most prefered as it can be processed with + tools provided by tcllib (See module doctools there). The first + two are prefered in general as they are semantic markup and thus + easier to convert into other formats. + +* the module must have either documentation or a test suite. It can + not have neither. * the module should adhere to Tcl coding standards -When adding a module to tklib, be sure to add it to the Makefile.in -so it will be installed. Add a line like: +When adding a module to tklib, be sure to add it to the files listed below. + +* installed_modules.tcl -MYNEWMODULE=mynewmodule + contains a table listing all modules to be installed, modules + excluded, and names the actions to be taken during installation + of each module. Add a line to this table naming your module and + its actions. -to the list of modules at the top of the Makefile.in, and then add -$(MYNEWMODULE) to the definition of the MODULES variable. This will -allow users to choose which modules to install by commenting or -uncommenting lines in the Makefile. + Three actions have to be specified, for the package itself, its + documentation, and the examples demonstrating it. + + The _null action can be used everywhere and signals that there is + nothing to do. Although it is possible to use it for the package + action it does make no sense there, as that means that no package + code is installed. + + Other package actions are _tcl, _tci, and _text. The first causes + the installer to copy all .tcl files from the source directory for + the module into the appropriate module directory. _tci does all that + and also expects a tclIndex file to copy. _tex is like _tcl, however + it also copies all .tex files found in the source directory for the + module. + + There is currently only one true documentation action. This action + is _doc. It converts all documentation in doctools format into the + format chosen by the user for installation and copies the result + into the appropriate directory. + + There is currently one true action for examples, _exa. It copies all + files in the source directory for examples into the directory chosen + by the user as destination for examples. Each module source directory should have no subdirectories (other than the CVS directory), and should contain the following files: @@ -57,8 +94,7 @@ the CVS directory), and should contain the following files: * source code *.tcl * package index pkgIndex.tcl * tests *.test -* documentation *.n, *.xml +* documentation *.man, *.n, *.xml If you do not follow this directory structure, the tklib Makefile will fail to locate the files from the new module. - diff --git a/all.tcl b/all.tcl index 0c7f0f2c..e8bf7766 100644 --- a/all.tcl +++ b/all.tcl @@ -1,24 +1,25 @@ # all.tcl -- # # This file contains a top-level script to run all of the Tcl -# tests. Execute it by invoking "source all.test" when running tcltest -# in this directory. +# tests. Execute it by invoking "tclsh all.test" in this directory. +# +# To test a subset of the modules, invoke it by 'tclsh all.test -modules ""' # # Copyright (c) 1998-2000 by Ajuba Solutions. # All rights reserved. # -# RCS: @(#) $Id: all.tcl,v 1.1.1.1 2001/11/07 20:51:21 hobbs Exp $ +# RCS: @(#) $Id: all.tcl,v 1.2 2003/11/28 22:42:03 andreas_kupries Exp $ set old_auto_path $auto_path if {[lsearch [namespace children] ::tcltest] == -1} { namespace eval ::tcltest {} - proc ::tcltest::processCmdLineArgsFlagsHook {} { + proc ::tcltest::processCmdLineArgsAddFlagsHook {} { return [list -modules] } proc ::tcltest::processCmdLineArgsHook {argv} { array set foo $argv - set ::modules $foo(-modules) + catch {set ::modules $foo(-modules)} } proc ::tcltest::cleanupTestsHook {{c {}}} { if { [string equal $c ""] } { @@ -41,7 +42,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { set res "" } set res - }] + }] ; # {} if { ![string equal $f ""] } { lappend ::tcltest::failFiles $f } @@ -74,11 +75,19 @@ if {[lsearch [namespace children] ::tcltest] == -1} { } set ::tcltest::testSingleFile false -set ::tcltest::testsDirectory [file dir [info script]] +set ::tcltest::testsDirectory [file dirname [info script]] set root $::tcltest::testsDirectory # We need to ensure that the testsDirectory is absolute -::tcltest::normalizePath ::tcltest::testsDirectory +if {[catch {::tcltest::normalizePath ::tcltest::testsDirectory}]} { + # The version of tcltest we have here does not support + # 'normalizePath', so we have to do this on our own. + + set oldpwd [pwd] + catch {cd $::tcltest::testsDirectory} + set ::tcltest::testsDirectory [pwd] + cd $oldpwd +} puts stdout "tcllib tests" puts stdout "Tests running in working dir: $::tcltest::testsDirectory" @@ -104,6 +113,18 @@ set auto_path $old_auto_path set auto_path [linsert $auto_path 0 [file join $root modules]] set old_apath $auto_path +## +## Take default action if the modules are not specified +## + +if {![info exists modules]} then { + foreach module [glob [file join $root modules]/*/*.test] { + set tmp([lindex [file split $module] end-1]) 1 + } + set modules [array names tmp] + unset tmp +} + foreach module $modules { set ::tcltest::testsDirectory [file join $root modules $module] @@ -121,13 +142,46 @@ foreach module $modules { interp alias $c pSet {} set # import the auto_path from the parent interp, so "package require" works $c eval { + set ::argv0 [pSet ::argv0] set ::tcllibModule [pSet module] set auto_path [pSet auto_path] + + # The next command allows the execution of 'tk' constrained + # tests, if Tk is present (for example when this code is run + # run by 'wish'). + catch {package require Tk} + package require tcltest namespace import ::tcltest::* set ::tcltest::testSingleFile false set ::tcltest::testsDirectory [pSet ::tcltest::testsDirectory] #set ::tcltest::verbose ps + + # Add a function to construct a proper error message for + # 'wrong#args' situations. The format of the messages changed + # for 8.4 + + proc ::tcltest::getErrorMessage {functionName argList missingIndex} { + # if oldstyle errors: + if { [info tclversion] < 8.4 } { + set msg "no value given for parameter " + append msg "\"[lindex $argList $missingIndex]\" to " + append msg "\"$functionName\"" + } else { + set msg "wrong # args: should be \"$functionName $argList\"" + } + return $msg + } + + proc ::tcltest::tooManyMessage {functionName argList} { + # if oldstyle errors: + if { [info tclversion] < 8.4 } { + set msg "called \"$functionName\" with too many arguments" + } else { + set msg "wrong # args: should be \"$functionName $argList\"" + } + return $msg + } } interp alias $c ::tcltest::cleanupTestsHook {} \ ::tcltest::cleanupTestsHook $c @@ -137,7 +191,7 @@ foreach module $modules { puts stdout [string map [list "$root/" ""] $file] $c eval { if {[catch {source [pSet file]} msg]} { - puts stdout $msg + puts stdout $errorInfo } } } @@ -148,5 +202,5 @@ foreach module $modules { # cleanup puts stdout "\nTests ended at [eval $timeCmd]" ::tcltest::cleanupTests 1 +# FRINK: nocheck return - diff --git a/config/tcl.m4 b/config/tcl.m4 index 873335d3..f6df490e 100644 --- a/config/tcl.m4 +++ b/config/tcl.m4 @@ -1928,13 +1928,13 @@ AC_DEFUN(SC_MAKE_LIB, [ case "`uname -s`" in *win32* | *WIN32* | *CYGWIN_NT* |*CYGWIN_98*|*CYGWIN_95*) if test "${CC-cc}" = "cl"; then - MAKE_STATIC_LIB="\${STLIB_LD} -out:\[$]@ \$(\[$]@_OBJECTS) " - MAKE_SHARED_LIB="\${SHLIB_LD} \${SHLIB_LDFLAGS} \${SHLIB_LD_LIBS} \$(LDFLAGS) -out:\[$]@ \$(\[$]@_OBJECTS) " + MAKE_STATIC_LIB="\${STLIB_LD} -out:\[$]@ \$(${PACKAGE}_LIB_OBJECTS) " + MAKE_SHARED_LIB="\${SHLIB_LD} \${SHLIB_LDFLAGS} \${SHLIB_LD_LIBS} \$(LDFLAGS) -out:\[$]@ \$(${PACKAGE}_LIB_OBJECTS) " fi ;; *) - MAKE_STATIC_LIB="\${STLIB_LD} \[$]@ \$(\[$]@_OBJECTS)" - MAKE_SHARED_LIB="\${SHLIB_LD} -o \[$]@ \$(\[$]@_OBJECTS) \${SHLIB_LDFLAGS} \${SHLIB_LD_LIBS}" + MAKE_STATIC_LIB="\${STLIB_LD} \[$]@ \$(${PACKAGE}_LIB_OBJECTS)" + MAKE_SHARED_LIB="\${SHLIB_LD} -o \[$]@ \$(${PACKAGE}_LIB_OBJECTS) \${SHLIB_LDFLAGS} \${SHLIB_LD_LIBS}" ;; esac diff --git a/configure b/configure index 28bbab23..52a9ec01 100755 --- a/configure +++ b/configure @@ -522,40 +522,6 @@ fi -ac_aux_dir= -for ac_dir in config $srcdir/config; do - if test -f $ac_dir/install-sh; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install-sh -c" - break - elif test -f $ac_dir/install.sh; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install.sh -c" - break - fi -done -if test -z "$ac_aux_dir"; then - { echo "configure: error: can not find install-sh or install.sh in config $srcdir/config" 1>&2; exit 1; } -fi -ac_config_guess=$ac_aux_dir/config.guess -ac_config_sub=$ac_aux_dir/config.sub -ac_configure=$ac_aux_dir/configure # This should be Cygnus configure. - -CONFIGDIR=${srcdir}/config - - -PACKAGE=tklib - -MAJOR_VERSION=0 -MINOR_VERSION=1 -PATCHLEVEL="" - -VERSION=${MAJOR_VERSION}.${MINOR_VERSION}${PATCHLEVEL} -NODOT_VERSION=${MAJOR_VERSION}${MINOR_VERSION} - - - - case "`uname -s`" in *win32* | *WIN32* | *CYGWIN_NT* | *CYGWIN_98* | *CYGWIN_95*) CYGPATH="cygpath -w" @@ -566,73 +532,9 @@ case "`uname -s`" in esac -# Find a good install program. We prefer a C program (faster), -# so one script is as good as another. But avoid the broken or -# incompatible versions: -# SysV /etc/install, /usr/sbin/install -# SunOS /usr/etc/install -# IRIX /sbin/install -# AIX /bin/install -# AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag -# AFS /usr/afsws/bin/install, which mishandles nonexistent args -# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" -# ./install, which can be erroneously created by make from ./install.sh. -echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6 -echo "configure:582: checking for a BSD compatible install" >&5 -if test -z "$INSTALL"; then -if eval "test \"`echo '$''{'ac_cv_path_install'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - IFS="${IFS= }"; ac_save_IFS="$IFS"; IFS=":" - for ac_dir in $PATH; do - # Account for people who put trailing slashes in PATH elements. - case "$ac_dir/" in - /|./|.//|/etc/*|/usr/sbin/*|/usr/etc/*|/sbin/*|/usr/afsws/bin/*|/usr/ucb/*) ;; - *) - # OSF1 and SCO ODT 3.0 have their own names for install. - # Don't use installbsd from OSF since it installs stuff as root - # by default. - for ac_prog in ginstall scoinst install; do - if test -f $ac_dir/$ac_prog; then - if test $ac_prog = install && - grep dspmsg $ac_dir/$ac_prog >/dev/null 2>&1; then - # AIX install. It has an incompatible calling convention. - : - else - ac_cv_path_install="$ac_dir/$ac_prog -c" - break 2 - fi - fi - done - ;; - esac - done - IFS="$ac_save_IFS" - -fi - if test "${ac_cv_path_install+set}" = set; then - INSTALL="$ac_cv_path_install" - else - # As a last resort, use the slow shell script. We don't cache a - # path for INSTALL within a source directory, because that will - # break other packages using the cache if that directory is - # removed, or if the path is relative. - INSTALL="$ac_install_sh" - fi -fi -echo "$ac_t""$INSTALL" 1>&6 - -# Use test -z because SunOS4 sh mishandles braces in ${var-val}. -# It thinks the first close brace ends the variable substitution. -test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' - -test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}' - -test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' - echo $ac_n "checking executable extension based on host type""... $ac_c" 1>&6 -echo "configure:636: checking executable extension based on host type" >&5 +echo "configure:538: checking executable extension based on host type" >&5 case "`uname -s`" in *win32* | *WIN32* | *CYGWIN_NT* |*CYGWIN_98*|*CYGWIN_95*) @@ -648,7 +550,7 @@ echo "configure:636: checking executable extension based on host type" >&5 echo $ac_n "checking for tclsh""... $ac_c" 1>&6 -echo "configure:652: checking for tclsh" >&5 +echo "configure:554: checking for tclsh" >&5 if eval "test \"`echo '$''{'ac_cv_path_tclsh'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 @@ -680,7 +582,7 @@ fi echo $ac_n "checking for wish""... $ac_c" 1>&6 -echo "configure:684: checking for wish" >&5 +echo "configure:586: checking for wish" >&5 if eval "test \"`echo '$''{'ac_cv_path_wish'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 @@ -711,6 +613,21 @@ fi +# ### ######### ########################### + +PACKAGE=`$TCLSH_PROG ${srcdir}/sak.tcl name` +MAJOR_VERSION=`$TCLSH_PROG ${srcdir}/sak.tcl major` +MINOR_VERSION=`$TCLSH_PROG ${srcdir}/sak.tcl minor` +PATCHLEVEL="" + +VERSION=${MAJOR_VERSION}.${MINOR_VERSION}${PATCHLEVEL} +NODOT_VERSION=${MAJOR_VERSION}${MINOR_VERSION} + + + + +# ### ######### ########################### + trap '' 1 2 15 cat > confcache <<\EOF # This file is a shell script that caches the results of configure @@ -822,7 +739,6 @@ do done ac_given_srcdir=$srcdir -ac_given_INSTALL="$INSTALL" trap 'rm -fr `echo "Makefile" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15 EOF @@ -856,16 +772,12 @@ s%@includedir@%$includedir%g s%@oldincludedir@%$oldincludedir%g s%@infodir@%$infodir%g s%@mandir@%$mandir%g -s%@CONFIGDIR@%$CONFIGDIR%g -s%@PACKAGE@%$PACKAGE%g -s%@VERSION@%$VERSION%g s%@CYGPATH@%$CYGPATH%g -s%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g -s%@INSTALL_SCRIPT@%$INSTALL_SCRIPT%g -s%@INSTALL_DATA@%$INSTALL_DATA%g s%@EXEEXT@%$EXEEXT%g s%@TCLSH_PROG@%$TCLSH_PROG%g s%@WISH_PROG@%$WISH_PROG%g +s%@PACKAGE@%$PACKAGE%g +s%@VERSION@%$VERSION%g CEOF EOF @@ -942,10 +854,6 @@ for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then top_srcdir="$ac_dots$ac_given_srcdir" ;; esac - case "$ac_given_INSTALL" in - [/$]*) INSTALL="$ac_given_INSTALL" ;; - *) INSTALL="$ac_dots$ac_given_INSTALL" ;; - esac echo creating "$ac_file" rm -f "$ac_file" @@ -961,7 +869,6 @@ for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then s%@configure_input@%$configure_input%g s%@srcdir@%$srcdir%g s%@top_srcdir@%$top_srcdir%g -s%@INSTALL@%$INSTALL%g " $ac_file_inputs | (eval "$ac_sed_cmds") > $ac_file fi; done rm -f conftest.s* diff --git a/configure.in b/configure.in index 9ac0b6d9..88c32831 100644 --- a/configure.in +++ b/configure.in @@ -1,21 +1,5 @@ AC_INIT(ChangeLog) -AC_CONFIG_AUX_DIR(config) -CONFIGDIR=${srcdir}/config -AC_SUBST(CONFIGDIR) - -PACKAGE=tklib - -MAJOR_VERSION=0 -MINOR_VERSION=1 -PATCHLEVEL="" - -VERSION=${MAJOR_VERSION}.${MINOR_VERSION}${PATCHLEVEL} -NODOT_VERSION=${MAJOR_VERSION}${MINOR_VERSION} - -AC_SUBST(PACKAGE) -AC_SUBST(VERSION) - case "`uname -s`" in *win32* | *WIN32* | *CYGWIN_NT* | *CYGWIN_98* | *CYGWIN_95*) CYGPATH="cygpath -w" @@ -26,9 +10,23 @@ case "`uname -s`" in esac AC_SUBST(CYGPATH) -AC_PROG_INSTALL SC_SIMPLE_EXEEXT SC_PROG_TCLSH SC_PROG_WISH +# ### ######### ########################### + +PACKAGE=`$TCLSH_PROG ${srcdir}/sak.tcl name` +MAJOR_VERSION=`$TCLSH_PROG ${srcdir}/sak.tcl major` +MINOR_VERSION=`$TCLSH_PROG ${srcdir}/sak.tcl minor` +PATCHLEVEL="" + +VERSION=${MAJOR_VERSION}.${MINOR_VERSION}${PATCHLEVEL} +NODOT_VERSION=${MAJOR_VERSION}${MINOR_VERSION} + +AC_SUBST(PACKAGE) +AC_SUBST(VERSION) + +# ### ######### ########################### + AC_OUTPUT([Makefile]) diff --git a/install_action.tcl b/install_action.tcl new file mode 100644 index 00000000..66e13441 --- /dev/null +++ b/install_action.tcl @@ -0,0 +1,96 @@ +# -*- tcl -*- + +# This file holds the commands determining the files to install. They +# are used by the installer to actually perform the installation, and +# by 'sak' to get the per-module lists of relevant files. The +# different purposes are handled through the redefinition of the +# commands [xcopy] and [xcopyf] used by the commands here. + +proc _null {args} {} + +proc _tcl {module libdir} { + global distribution + xcopy \ + [file join $distribution modules $module] \ + [file join $libdir $module] \ + 0 *.tcl + return +} + +proc _doc {module libdir} { + global distribution + + _tcl $module $libdir + xcopy \ + [file join $distribution modules $module mpformats] \ + [file join $libdir $module mpformats] \ + 1 + return +} + +proc _tex {module libdir} { + global distribution + + _tcl $module $libdir + xcopy \ + [file join $distribution modules $module] \ + [file join $libdir $module] \ + 0 *.tex + return +} + +proc _tci {module libdir} { + global distribution + + _tcl $module $libdir + xcopyfile [file join $distribution modules $module tclIndex] \ + [file join $libdir $module] + return +} + +proc _man {module format ext docdir} { + global distribution argv argc argv0 config + + package require doctools + ::doctools::new dt -format $format -module $module + + foreach f [glob -nocomplain [file join $distribution modules $module *.man]] { + + set out [file join $docdir [file rootname [file tail $f]]].$ext + + log "Generating $out" + if {$config(dry)} {continue} + + dt configure -file $f + file mkdir [file dirname $out] + + set data [dt format [get_input $f]] + switch -exact -- $format { + nroff { + set data [string map \ + [list \ + {.so man.macros} \ + $config(man.macros)] \ + $data] + } + html {} + } + write_out $out $data + + set warnings [dt warnings] + if {[llength $warnings] > 0} { + log [join $warnings \n] + } + } + dt destroy + return +} + +proc _exa {module exadir} { + global distribution + xcopy \ + [file join $distribution examples $module] \ + [file join $exadir $module] \ + 1 + return +} diff --git a/installed_modules.tcl b/installed_modules.tcl new file mode 100755 index 00000000..6841c3f7 --- /dev/null +++ b/installed_modules.tcl @@ -0,0 +1,30 @@ +# -*- tcl -*- +# -------------------------------------------------------------- +# List of modules to install and definitions guiding the process of +# doing so. +# +# This file is shared between 'installer.tcl' and 'sak.tcl', like +# 'tcllib_version.tcl'. The swiss army knife requires access to the +# data in this file to be able to check if there are modules in the +# directory hierarchy, but missing in the list of installed modules. +# -------------------------------------------------------------- + +# Excluded: +set excluded [list \ + ] + +set modules [list] +array set guide {} +foreach {m pkg doc exa} { + autoscroll _tcl _man _null + cursor _tcl _man _null + datefield _tcl _man _null + ipentry _tcl _man _null +} { + lappend modules $m + set guide($m,pkg) $pkg + set guide($m,doc) $doc + set guide($m,exa) $exa +} + +# -------------------------------------------------------------- diff --git a/installer.tcl b/installer.tcl new file mode 100755 index 00000000..fb4fd6a2 --- /dev/null +++ b/installer.tcl @@ -0,0 +1,486 @@ +#!/bin/sh +# -*- tcl -*- \ +exec tclsh "$0" ${1+"$@"} + +# -------------------------------------------------------------- +# Installer for Tklib + +set distribution [file dirname [info script]] +lappend auto_path [file join $distribution modules] + + +# -------------------------------------------------------------- +# Version information for tklib. +# List of modules to install (and definitions guiding the process) + +source [file join $distribution tklib_version.tcl] ; # Get version information. +source [file join $distribution installed_modules.tcl] ; # Get list of installed modules. +source [file join $distribution install_action.tcl] ; # Get list of installed modules. + +# -------------------------------------------------------------- +# Low-level commands of the installation engine. + +proc gen_main_index {outdir package version} { + global config + + log "\nGenerating [file join $outdir pkgIndex.tcl]" + if {$config(dry)} {return} + + set index [open [file join $outdir pkgIndex.tcl] w] + + puts $index "# Tcl package index file, version 1.1" + puts $index "# Do NOT edit by hand. Let $package install generate this file." + puts $index "# Generated by $package installer for version $version" + + puts $index { +# All tklib packages need Tcl 8 (use [namespace]) +if {![package vsatisfies [package provide Tcl] 8]} {return} + +# Extend the auto_path to make tklib packages available +if {[lsearch -exact $::auto_path $dir] == -1} { + lappend ::auto_path $dir +} + +# For Tcl 8.3.1 and later, that's all we need +if {[package vsatisfies [package provide Tcl] 8.4]} {return} +if {(0 == [catch { + package vcompare [info patchlevel] [info patchlevel] +}]) && ( + [package vcompare [info patchlevel] 8.3.1] >= 0 +)} {return} + +# For older Tcl releases, here are equivalent contents +# of the pkgIndex.tcl files of all the modules + +if {![package vsatisfies [package provide Tcl] 8.0]} {return} +} + puts $index "" + puts $index "set maindir \$dir" + + foreach pi [lsort [glob -nocomplain [file join $outdir * pkgIndex.tcl]]] { + set subdir [file tail [file dirname $pi]] + puts $index "set dir \[file join \$maindir [list $subdir]\] ;\t source \[file join \$dir pkgIndex.tcl\]" + } + + puts $index "unset maindir" + puts $index "" + close $index + return +} + +proc xcopyfile {src dest} { + # dest can be dir or file + run file copy -force $src $dest + return +} + +proc xcopy {src dest recurse {pattern *}} { + run file mkdir $dest + foreach file [glob [file join $src $pattern]] { + set base [file tail $file] + set sub [file join $dest $base] + + if {0 == [string compare CVS $base]} {continue} + + if {[file isdirectory $file]} then { + if {$recurse} { + run file mkdir $sub + xcopy $file $sub $recurse $pattern + } + } else { + xcopyfile $file $sub + } + } +} + +proc get_input {f} {return [read [set if [open $f r]]][close $if]} +proc write_out {f text} { + global config + if {$config(dry)} {log "Generate $f" ; return} + puts -nonewline [set of [open $f w]] $text + close $of +} + + +# -------------------------------------------------------------- +# Use configuration to perform installation + +proc clear {} {global message ; set message ""} +proc msg {text} {global message ; append message $text \n ; return} +proc get {} {global message ; return $message} + +proc log {text} { + global config + if {!$config(gui)} {puts stdout $text ; flush stdout ; return} + .l.t insert end $text\n + .l.t see end + update + return +} +proc log* {text} { + global config + if {!$config(gui)} {puts -nonewline stdout $text ; flush stdout ; return} + .l.t insert end $text + .l.t see end + update + return +} + +proc run {args} { + global config + if {$config(dry)} { + log [join $args] + return + } + eval $args + + log* . + return +} + +proc xinstall {type args} { + global modules guide + foreach m $modules { + eval $guide($m,$type) $m $args + } + return +} + +proc doinstall {} { + global config tklib_version distribution tklib_name modules excluded + + if {!$config(no-exclude)} { + foreach p $excluded { + set pos [lsearch -exact $modules $p] + if {$pos < 0} {continue} + set modules [lreplace $modules $pos $pos] + } + } + + if {$config(pkg)} { + xinstall pkg $config(pkg,path) + gen_main_index $config(pkg,path) $tklib_name $tklib_version + } + if {$config(doc,nroff)} { + set config(man.macros) [string trim [get_input [file join $distribution man.macros]]] + xinstall doc nroff n $config(doc,nroff,path) + } + if {$config(doc,html)} {xinstall doc html html $config(doc,html,path)} + if {$config(exa)} {xinstall exa $config(exa,path)} + log "" + return +} + + +# -------------------------------------------------------------- +# Initialize configuration. + +array set config { + pkg 1 pkg,path {} + doc,nroff 0 doc,nroff,path {} + doc,html 0 doc,html,path {} + exa 1 exa,path {} + dry 0 wait 1 valid 1 + gui 0 no-gui 0 no-exclude 0 +} + +# -------------------------------------------------------------- +# Determine a default configuration, if possible + +proc defaults {} { + global tcl_platform config tklib_version tklib_name distribution + + if {[string compare $distribution [info nameofexecutable]] == 0} { + # Starpack. No defaults for location. + } else { + # Starkit, or unwrapped. Derive defaults location from the + # location of the executable running the installer, or the + # location of its library. + + # For a starkit [info library] is inside the running + # tclkit. Detect this and derive the lcoation from the + # location of the executable itself for that case. + + if {[string match [info nameofexecutable]* [info library]]} { + # Starkit + set libdir [file join [file dirname [file dirname [info nameofexecutable]]] lib] + } else { + # Unwrapped. + if {[catch {set libdir [lindex $::tcl_pkgPath end]}]} { + set libdir [file dirname [info library]] + } + } + + set basedir [file dirname $libdir] + set bindir [file join $basedir bin] + + if {[string compare $tcl_platform(platform) windows] == 0} { + set mandir {} + set htmldir [file join $basedir tklib_doc] + } else { + set mandir [file join $basedir man mann] + set htmldir [file join $libdir tklib${tklib_version} tklib_doc] + } + + set config(pkg,path) [file join $libdir ${tklib_name}${tklib_version}] + set config(doc,nroff,path) $mandir + set config(doc,html,path) $htmldir + set config(exa,path) [file join $bindir tklib_examples${tklib_version}] + } + + if {[string compare $tcl_platform(platform) windows] == 0} { + set config(doc,nroff) 0 + set config(doc,html) 1 + } else { + set config(doc,nroff) 1 + set config(doc,html) 0 + } + return +} + +# -------------------------------------------------------------- +# Show configuration on stdout. + +proc showpath {prefix key} { + global config + + if {$config($key)} { + if {[string length $config($key,path)] == 0} { + puts "${prefix}Empty path, invalid." + set config(valid) 0 + msg "Invalid path: [string trim $prefix " :"]" + } else { + puts "${prefix}$config($key,path)" + } + } else { + puts "${prefix}Not installed." + } +} + +proc showconfiguration {} { + global config tklib_version + + puts "Installing Tklib $tklib_version" + if {$config(dry)} { + puts "\tDry run, simulation, no actual activity." + puts "" + } + + puts "You have chosen the following configuration ..." + puts "" + + showpath "Packages: " pkg + showpath "Examples: " exa + + if {$config(doc,nroff) || $config(doc,html)} { + puts "Documentation:" + puts "" + + showpath "\tNROFF: " doc,nroff + showpath "\tHTML: " doc,html + } else { + puts "Documentation: Not installed." + } + puts "" + return +} + +# -------------------------------------------------------------- +# Setup the installer user interface + +proc browse {label key} { + global config + + set initial $config($key) + if {$initial == {}} {set initial [pwd]} + + set dir [tk_chooseDirectory \ + -title "Select directory for $label" \ + -parent . \ + -initialdir $initial \ + ] + + if {$dir == {}} {return} ; # Cancellation + + set config($key) $dir + return +} + +proc setupgui {} { + global config tklib_name tklib_version + set config(gui) 1 + + wm withdraw . + wm title . "Installing $tklib_name $tklib_version" + + foreach {w type cspan col row opts} { + .pkg checkbutton 1 0 0 {-anchor w -text {Packages:} -variable config(pkg)} + .dnr checkbutton 1 0 1 {-anchor w -text {Doc. Nroff:} -variable config(doc,nroff)} + .dht checkbutton 1 0 2 {-anchor w -text {Doc. HTML:} -variable config(doc,html)} + .exa checkbutton 1 0 3 {-anchor w -text {Examples:} -variable config(exa)} + + .spa frame 3 0 4 {-bg black -height 2} + + .dry checkbutton 2 0 6 {-anchor w -text {Simulate installation} -variable config(dry)} + + .pkge entry 1 1 0 {-width 40 -textvariable config(pkg,path)} + .dnre entry 1 1 1 {-width 40 -textvariable config(doc,nroff,path)} + .dhte entry 1 1 2 {-width 40 -textvariable config(doc,html,path)} + .exae entry 1 1 3 {-width 40 -textvariable config(exa,path)} + + .pkgb button 1 2 0 {-text ... -command {browse Packages pkg,path}} + .dnrb button 1 2 1 {-text ... -command {browse Nroff doc,nroff,path}} + .dhtb button 1 2 2 {-text ... -command {browse HTML doc,html,path}} + .exab button 1 2 3 {-text ... -command {browse Examples exa,path}} + + .sep frame 3 0 7 {-bg black -height 2} + + .run button 1 0 8 {-text {Install} -command {set ::run 1}} + .can button 1 1 8 {-text {Cancel} -command {exit}} + } { + eval [list $type $w] $opts + grid $w -column $col -row $row -sticky ew -columnspan $cspan + grid rowconfigure . $row -weight 0 + } + + grid .can -sticky e + + grid rowconfigure . 9 -weight 1 + grid columnconfigure . 0 -weight 0 + grid columnconfigure . 1 -weight 1 + + wm deiconify . + return +} + +proc handlegui {} { + setupgui + vwait ::run + showconfiguration + validate + + toplevel .l + wm title .l "Install log" + text .l.t -width 70 -height 25 -relief sunken -bd 2 + pack .l.t -expand 1 -fill both + + return +} + +# -------------------------------------------------------------- +# Handle a command line + +proc handlecmdline {} { + showconfiguration + validate + wait + return +} + +proc processargs {} { + global argv argv0 config + + while {[llength $argv] > 0} { + switch -exact -- [lindex $argv 0] { + +excluded {set config(no-exclude) 1} + -no-wait {set config(wait) 0} + -no-gui {set config(no-gui) 1} + -simulate - + -dry-run {set config(dry) 1} + -html {set config(doc,html) 1} + -nroff {set config(doc,nroff) 1} + -examples {set config(exa) 1} + -pkgs {set config(pkg) 1} + -no-html {set config(doc,html) 0} + -no-nroff {set config(doc,nroff) 0} + -no-examples {set config(exa) 0} + -no-pkgs {set config(pkg) 0} + -pkg-path { + set config(pkg) 1 + set config(pkg,path) [lindex $argv 1] + set argv [lrange $argv 1 end] + } + -nroff-path { + set config(doc,nroff) 1 + set config(doc,nroff,path) [lindex $argv 1] + set argv [lrange $argv 1 end] + } + -html-path { + set config(doc,html) 1 + set config(doc,html,path) [lindex $argv 1] + set argv [lrange $argv 1 end] + } + -example-path { + set config(exa) 1 + set config(exa,path) [lindex $argv 1] + set argv [lrange $argv 1 end] + } + -help - + default { + puts stderr "usage: $argv0 ?-dry-run/-simulate? ?-no-wait? ?-no-gui? ?-html|-no-html? ?-nroff|-no-nroff? ?-examples|-no-examples? ?-pkgs|-no-pkgs? ?-pkg-path path? ?-nroff-path path? ?-html-path path? ?-example-path path?" + exit 1 + } + } + set argv [lrange $argv 1 end] + } + return +} + +proc validate {} { + global config + + if {$config(valid)} {return} + + puts "Invalid configuration detected, aborting." + puts "" + puts "Please use the option -help to get more information" + puts "" + + if {$config(gui)} { + tk_messageBox \ + -icon error -type ok \ + -default ok \ + -title "Illegal configuration" \ + -parent . -message [get] + clear + } + exit 1 +} + +proc wait {} { + global config + + if {!$config(wait)} {return} + + puts -nonewline stdout "Is the chosen configuration ok ? y/N: " + flush stdout + set answer [gets stdin] + if {($answer == {}) || [string match "\[Nn\]*" $answer]} { + puts stdout "\tNo. Aborting." + puts stdout "" + exit 0 + } + return +} + +# -------------------------------------------------------------- +# Main code + +proc main {} { + global config + + defaults + processargs + if {$config(no-gui) || [catch {package require Tk}]} { + handlecmdline + } else { + handlegui + } + doinstall + return +} + +# -------------------------------------------------------------- +main +exit 0 +# -------------------------------------------------------------- diff --git a/main.tcl b/main.tcl new file mode 100755 index 00000000..3e62fa6e --- /dev/null +++ b/main.tcl @@ -0,0 +1,4 @@ +# -*- tcl -*- +# Entrypoint for strkit and -pack based distributions + +source [file join [file dirname [info script]] installer.tcl] diff --git a/mkIndex.tcl b/mkIndex.tcl deleted file mode 100644 index b2842bd9..00000000 --- a/mkIndex.tcl +++ /dev/null @@ -1,33 +0,0 @@ -# mkIndex.tcl -- -# -# This script generates a pkgIndex.tcl file for tcllib. It expects -# several arguments: -# outdir directory in which to create pkgIndex.tcl -# package package name (tcllib) -# version package version -# modules list of modules to include -# -# Copyright (c) 1999-2000 Ajuba Solutions. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# - -foreach {outdir package version} $argv { - break -} -set modules [lrange $argv 3 end] -cd $outdir -puts "Making pkgIndex.tcl in [pwd]" - -set index [open pkgIndex.tcl w] -puts $index "if { \[lsearch \$auto_path \[file dirname \[info script\]\]\] == -1 } {" -puts $index "\tlappend auto_path \[file dirname \[info script\]\]" -puts $index "}" -puts $index "package ifneeded $package $version {" -foreach module $modules { - puts $index "\tpackage require $module" -} -puts $index "\tpackage provide $package $version" -puts $index "}" -close $index diff --git a/mkInstallScripts.tcl b/mkInstallScripts.tcl deleted file mode 100644 index eb68394f..00000000 --- a/mkInstallScripts.tcl +++ /dev/null @@ -1,50 +0,0 @@ -# Simple Tcl script that produces install scripts for tcllib for Windows -# (INSTALL.BAT) and Unix (install.sh). -# Arguments list: -# outdir -# package -# version -# module module module module - -set outdir [lindex $argv 0] -set package [lindex $argv 1] -set version [lindex $argv 2] -set modules [lrange $argv 3 end] - -# Make an INSTALL.BAT for Windows -# - -set f [open [file join $outdir INSTALL.BAT] w] -puts $f "@echo off" -puts $f "set TCLINSTALL=C:\\Progra~1\\Tcl" -puts $f "mkdir %TCLINSTALL%\\lib\\$package$version" -puts $f "copy pkgIndex.tcl %TCLINSTALL%\\lib\\$package$version" -puts $f "for %%f in ($modules) do xcopy .\\%%f\\*.* %TCLINSTALL%\\lib\\$package$version\\%%f /E /S /I /Q /C" -close $f - -# Make an install.sh for Unix -# - -set installFile [file join $outdir install.sh] -set f [open $installFile w] -puts $f "#!/bin/sh" -puts $f "TCLINSTALL=\$1" -puts $f "if \[ \"\${TCLINSTALL\}x\" = \"x\" \] ; then \\" -puts $f " TCLINSTALL=/usr/local" -puts $f "fi" -puts $f "if \[ ! -d \$TCLINSTALL/lib/$package$version \] ; then \\" -puts $f " mkdir -p \$TCLINSTALL/lib/$package$version ; \\" -puts $f "fi" -puts $f "if \[ ! -d \$TCLINSTALL/man/mann \] ; then \\" -puts $f " mkdir -p \$TCLINSTALL/man/mann ; \\" -puts $f "fi" -puts $f "cp -f pkgIndex.tcl \$TCLINSTALL/lib/$package$version" -puts $f "for j in $modules ; do \\" -puts $f " if \[ ! -d \$TCLINSTALL/lib/$package$version/\$j \] ; then \\" -puts $f " mkdir \$TCLINSTALL/lib/$package$version/\$j ; \\" -puts $f " fi; \\" -puts $f " cp -f \$j/*.tcl \$TCLINSTALL/lib/$package$version/\$j ; \\" -puts $f " cp -f \$j/*.n \$TCLINSTALL/man/mann ; \\" -puts $f "done" -close $f -file attributes $installFile -permissions 0755 diff --git a/modules/autoscroll/autoscroll.man b/modules/autoscroll/autoscroll.man index 4a56fde1..5d8d3bf8 100644 --- a/modules/autoscroll/autoscroll.man +++ b/modules/autoscroll/autoscroll.man @@ -12,7 +12,7 @@ content of the scrollbars scrolled widget. The scrollbar must be managed by either pack or grid, other geometry managers are not supported. -[nl] +[para] When managed by pack, any geometry changes made in the scrollbars parent between the time a scrollbar is @@ -22,7 +22,7 @@ scrollbar is unmapped. When managed by grid, if anything becomes gridded in the same row and column the scrollbar occupied it will be replaced by the scrollbar when remapped. -[nl] +[para] This package may be used on any scrollbar-like widget as long as it supports the [const set] subcommand in the same diff --git a/modules/cursor/cursor.man b/modules/cursor/cursor.man new file mode 100644 index 00000000..b580f3a9 --- /dev/null +++ b/modules/cursor/cursor.man @@ -0,0 +1,44 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin cursor n 0.1] +[copyright {Jeffrey Hobbs }] + +[moddesc {Tk cursor routines}] +[titledesc {Procedures to handle CURSOR data}] +[require Tk] +[require cursor [opt 0.1]] +[description] + +The [package cursor] package provides commands to handle Tk cursors. + +[section COMMANDS] + +The following commands are available: + +[list_begin definitions] + +[call [cmd ::cursor::propagate] [arg widget] [arg cursor]] + +Sets the cursor for the specified [arg widget] and all its descendants +to [arg cursor]. + + +[call [cmd ::cursor::restore] [arg widget] [opt [arg cursor]]] + +Restore the original or previously set cursor for the specified +[arg widget] and all its descendants. If [arg cursor] is specified, +that will be used if on any widget that did not have a preset cursor +(set by a previous call to [cmd ::cursor::propagate]). + + +[call [cmd ::cursor::display] [opt [arg parent]]] + +Pops up a dialog with a listbox containing all the cursor names. +Selecting a cursor name will display it in that dialog. This is +simply for viewing any available cursors on the platform. + +[list_end] + + +[see_also cursors(n) options(n) Tk_GetCursor(3)] +[keywords cursor] +[manpage_end] diff --git a/modules/cursor/cursor.n b/modules/cursor/cursor.n deleted file mode 100644 index a7a96dfb..00000000 --- a/modules/cursor/cursor.n +++ /dev/null @@ -1,53 +0,0 @@ -'\" -*- nroff -*- -'\" -'\" Copyright (c) 2001 by Jeffrey Hobbs -'\" -'\" RCS: @(#) $Id: cursor.n,v 1.1 2001/11/08 19:10:47 hobbs Exp $ -'\" -.so man.macros -.TH cursor n 0.1 Cursor "Tk cursor routines" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH "NAME" -::cursor \- Procedures to handle CURSOR data -.SH "SYNOPSIS" -\fBpackage require Tk\fR -.sp -\fBpackage require cursor ?0.1?\fR -.sp -\fB::cursor::propagate\fR \fIwidget cursor\fR -.sp -\fB::cursor::restore\fR \fIwidget\fR ?\fIcursor\fR? -.sp -\fB::cursor::display\fR ?\fIparent\fR? -.sp -.BE - -.SH "DESCRIPTION" -.PP -The \fB::cursor\fR package provides commands to handle Tk cursors. - -.SH "COMMANDS" -.PP -The following commands are available: -.TP -\fB::cursor::propagate\fR \fIwidget cursor\fR -Sets the cursor for the specified \fIwidget\fR and all its descendants -to \fIcursor\fR. -.TP -\fB::cursor::restore\fR \fIwidget\fR ?\fIcursor\fR? -Restore the original or previously set cursor for the specified -\fIwidget\fR and all its descendants. If \fIcursor\fR is specified, -that will be used if on any widget that did not have a preset cursor -(set by a previous call to \fB::cursor::propagate\fR). -.TP -\fB::cursor::display\fR ?\fIparent\fR? -Pops up a dialog with a listbox containing all the cursor names. -Selecting a cursor name will display it in that dialog. This is -simply for viewing any available cursors on the platform. - -.SH "SEE ALSO" -cursors(n), options(n), Tk_GetCursor(3) - -.SH "KEYWORDS" -cursor diff --git a/modules/datefield/datefield.man b/modules/datefield/datefield.man new file mode 100644 index 00000000..b3e866a4 --- /dev/null +++ b/modules/datefield/datefield.man @@ -0,0 +1,58 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin datefield n 0.1] +[copyright {Keith Vetter }] +[moddesc {Tk datefield widget}] +[titledesc {Tk datefield widget}] +[require Tk] +[require datefield [opt 0.1]] +[description] + +The [package datefield] package provides the datefield widget which +is an enhanced text entry widget for the purpose of date entry. Only +valid dates of the form MM/DD/YYYY can be entered. + +[para] + +The datefield widget is, in fact, just an entry widget with +specialized bindings. This means all the command and options for an +entry widget apply equally here. + + +[section COMMANDS] + +[list_begin definitions] +[call [cmd ::datefield::datefield] [arg widgetpath] [opt [arg options]]] + +Creates and configures a date field widget. + +[list_end] + + +[section OPTIONS] + +See the [cmd entry] manual entry for details on all available options. + +[section EXAMPLE] +[example { + package require datefield + + wm title . "Datefield example" + proc DayOfWeek {args} { + set now [clock scan $::myDate] + set ::myDate2 [clock format $now -format %A] + } + trace variable myDate w DayOfWeek + + ::datefield::datefield .df -textvariable myDate + label .l1 -text "Enter a date:" -anchor e + label .l2 -text "That date is a:" -anchor e + label .l3 -textvariable myDate2 -relief sunken -width 12 + + grid .l1 .df -sticky ew + grid .l2 .l3 -sticky ew + focus .df +}] + +[see_also entry(n) clock(n)] +[keywords entry widget clock] +[manpage_end] diff --git a/modules/datefield/datefield.n b/modules/datefield/datefield.n deleted file mode 100644 index b530cf5e..00000000 --- a/modules/datefield/datefield.n +++ /dev/null @@ -1,61 +0,0 @@ -'\" -'\" Copyright (c) 2002 by Keith Vetter -'\" -'\" RCS: @(#) $Id: datefield.n,v 1.1 2002/02/26 08:02:41 keithv Exp $ -'\" -.TH datefield n 0.1 Datefield "Tk datefield widget" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH "NAME" -::datefield \- Tk datefield widget -.SH "SYNOPSIS" -\fBpackage require Tk\fR -.sp -\fBpackage require datefield ?0.1?\fR -.sp -\fB::datefield::datefield\fR \fIpathname\fR ?\fIoptions\fR? -.sp -.BE - -.SH "DESCRIPTION" -.PP -The \fB::datefield\fR package provides the datefield widget which -is an enhanced text entry widget for the purpose of date entry. Only -valid dates of the form MM/DD/YYYY can be entered. - -The datefield widget is, in fact, just an entry widget with specialized -bindings. This means all the command and options for an entry widget -apply equally here. - -.SH "OPTIONS" -.PP -See the entry manual entry for details on all available options. - -.SH "EXAMPLE" -.PP -.DS - package require datefield - - wm title . "Datefield example" - proc DayOfWeek {args} { - set now [clock scan $::myDate] - set ::myDate2 [clock format $now -format %A] - } - trace variable myDate w DayOfWeek - - ::datefield::datefield .df -textvariable myDate - label .l1 -text "Enter a date:" -anchor e - label .l2 -text "That date is a:" -anchor e - label .l3 -textvariable myDate2 -relief sunken -width 12 - - grid .l1 .df -sticky ew - grid .l2 .l3 -sticky ew - focus .df - -.DE - -.SH "SEE ALSO" -entry(n), clock(n) - -.SH "KEYWORDS" -entry, widget, clock diff --git a/sak.tcl b/sak.tcl new file mode 100755 index 00000000..51712e1a --- /dev/null +++ b/sak.tcl @@ -0,0 +1,1325 @@ +#!/bin/sh +# -*- tcl -*- \ +exec tclsh "$0" ${1+"$@"} + +# -------------------------------------------------------------- +# Perform various checks and operations on the distribution. +# SAK = Swiss Army Knife. + +set distribution [file dirname [info script]] +lappend auto_path [file join $distribution modules] + +source [file join $distribution tklib_version.tcl] ; # Get version information. + +catch {eval file delete -force [glob [file rootname [info script]].tmp.*]} + +# -------------------------------------------------------------- + +proc tclfiles {} { + global distribution + package require fileutil + set fl [fileutil::findByPattern $distribution -glob *.tcl] + proc tclfiles {} [list return $fl] + return $fl +} + +proc modtclfiles {modules} { + global mfiles guide + load_modinfo + set mfiles [list] + foreach m $modules { + eval $guide($m,pkg) $m __dummy__ + } + return $mfiles +} + + +proc modules {} { + global distribution + set fl [list] + foreach f [glob -nocomplain [file join $distribution modules *]] { + if {![file isdirectory $f]} {continue} + if {[string match CVS [file tail $f]]} {continue} + + if {![file exists [file join $f pkgIndex.tcl]]} {continue} + + lappend fl [file tail $f] + } + set fl [lsort $fl] + proc modules {} [list return $fl] + return $fl +} + +proc modules_mod {m} { + return [expr {[lsearch -exact [modules] $m] >= 0}] +} + +proc load_modinfo {} { + global distribution modules guide + source [file join $distribution installed_modules.tcl] ; # Get list of installed modules. + source [file join $distribution install_action.tcl] ; # Get list of installed modules. + proc load_modinfo {} {} + return +} + +proc imodules {} {global modules ; load_modinfo ; return $modules} + +proc imodules_mod {m} { + global modules + load_modinfo + return [expr {[lsearch -exact $modules $m] > 0}] +} + + +proc loadpkglist {fname} { + set f [open $fname r] + foreach line [split [read $f] \n] { + foreach {n v} $line break + set p($n) $v + } + close $f + return [array get p] +} + +proc ipackages {args} { + # Determine indexed packages (ifneeded, pkgIndex.tcl) + + global distribution + + if {[llength $args] == 0} {set args [modules]} + + array set p {} + foreach m $args { + set f [open [file join $distribution modules $m pkgIndex.tcl] r] + foreach line [split [read $f] \n] { + if { [regexp {#} $line]} {continue} + if {![regexp {ifneeded} $line]} {continue} + regsub {^.*ifneeded } $line {} line + regsub {([0-9]) \[.*$} $line {\1} line + + foreach {n v} $line break + set p($n) $v + } + close $f + } + return [array get p] +} + + +proc ppackages {args} { + # Determine provided packages (provide, *.tcl - pkgIndex.tcl) + + global p pf currentfile + array set p {} + + if {[llength $args] == 0} { + set files [tclfiles] + } else { + set files [modtclfiles $args] + } + + foreach f $files { + # We ignore package indices and all files not in a module. + + if {[string equal pkgIndex.tcl [file tail $f]]} {continue} + if {![regexp modules $f]} {continue} + + set fh [open $f r] + + # Source the code into a sub-interpreter. The sub interpreter + # overloads 'package provide' so that the information about + # new packages goes directly to us. We also make sure that the + # sub interpreter doesn't kill us, and will not get stuck + # early by trying to load other files, or when creating + # procedures in namespaces which do not exist due to us + # disabling most of the package management. + + set currentfile [eval file join [lrange [file split $f] end-1 end]] + + set ip [interp create] + interp alias $ip package {} xPackage + interp alias $ip source {} xNULL + interp alias $ip unknown {} xNULL + interp alias $ip proc {} xNULL + interp alias $ip exit {} xNULL + if {[catch {$ip eval [read $fh]} msg]} { + #puts "ERROR in $currentfile:\n$msg\n" + } + close $fh + interp delete $ip + } + + set pp [array get p] + unset p + return $pp +} + +proc xNULL {args} {} +proc xPackage {cmd args} { + + if {[string equal $cmd provide]} { + global p pf currentfile + foreach {n v} $args break + + # No version specified, this is an inquiry, we ignore these. + if {$v == {}} {return} + + set p($n) $v + set pf($n) $currentfile + } + return +} + + + +proc sep {} {puts ~~~~~~~~~~~~~~~~~~~~~~~~} + +proc gendoc {fmt ext args} { + global distribution + global tcl_platform + + set null 0 + if {![string compare $fmt null]} {set null 1} + if {[llength $args] == 0} {set args [modules]} + + # Direct usage of the doctools instead of the mini application 'mpexpand' ... + + package require doctools + ::doctools::new mpe -format $fmt + + if {!$null} { + file mkdir [file join doc $fmt] + } else { + mpe configure -deprecated 1 + } + + foreach m $args { + set fl [glob -nocomplain [file join $distribution modules $m *.man]] + if {[llength $fl] == 0} {continue} + + mpe configure -module $m + + foreach f $fl { + if {!$null} { + set target [file join doc $fmt \ + [file rootname [file tail $f]].$ext] + if {[file exists $target] + && [file mtime $target] > [file mtime $f]} { + continue + } + } + puts "Gen ($fmt): $f" + + if {[catch { + set result [mpe format [read [set if [open $f r]]][close $if]] + } msg]} { + puts stdout $msg + } + + set warnings [mpe warnings] + if {[llength $warnings] > 0} { + puts stdout [join $warnings \n] + } + + if {!$null} { + set of [open $target w] + puts -nonewline $of $result + close $of + } + } + } + + mpe destroy + return +} + +proc gd-cleanup {} { + global tklib_version + + puts {Cleaning up...} + + set fl [glob -nocomplain tklib-${tklib_version}*] + foreach f $fl { + puts " Deleting $f ..." + catch {file delete -force $f} + } + return +} + +proc gd-gen-archives {} { + global tklib_version + + puts {Generating archives...} + + set tar [auto_execok tar] + if {$tar != {}} { + puts " Gzipped tarball (tklib-${tklib_version}.tar.gz)..." + catch { + exec $tar cf - tklib-${tklib_version} | gzip --best > tklib-${tklib_version}.tar.gz + } + + set bzip [auto_execok bzip2] + if {$bzip != {}} { + puts " Bzipped tarball (tklib-${tklib_version}.tar.bz2)..." + exec tar cf - tklib-${tklib_version} | bzip2 > tklib-${tklib_version}.tar.bz2 + } + } + + set zip [auto_execok zip] + if {$zip != {}} { + puts " Zip archive (tklib-${tklib_version}.zip)..." + catch { + exec $zip -r tklib-${tklib_version}.zip tklib-${tklib_version} + } + } + + set sdx [auto_execok sdx] + if {$sdx != {}} { + file rename tklib-${tklib_version} tklib.vfs + + puts " Starkit (tklib-${tklib_version}.kit)..." + exec sdx wrap tklib + file rename tklib tklib-${tklib_version}.kit + + if {![file exists tclkit]} { + puts " No tclkit present in current working directory, no starpack." + } else { + puts " Starpack (tklib-${tklib_version}.exe)..." + exec sdx wrap tklib -runtime tclkit + file rename tklib tklib-${tklib_version}.exe + } + + file rename tklib.vfs tklib-${tklib_version} + } + + puts { Keeping directory for other archive types} + + ## Keep the directory for 'sdx' - kit/pack + return +} + +proc xcopyfile {src dest} { + # dest can be dir or file + global mfiles + lappend mfiles $src + return +} + +proc xcopy {src dest recurse {pattern *}} { + foreach file [glob [file join $src $pattern]] { + set base [file tail $file] + set sub [file join $dest $base] + if {0 == [string compare CVS $base]} {continue} + if {[file isdirectory $file]} then { + if {$recurse} { + xcopy $file $sub $recurse $pattern + } + } else { + xcopyfile $file $sub + } + } +} + + +proc xxcopy {src dest recurse {pattern *}} { + file mkdir $dest + foreach file [glob -nocomplain [file join $src $pattern]] { + set base [file tail $file] + set sub [file join $dest $base] + + # Exclude CVS automatically, and possibly the temp hierarchy + # itself too. + + if {0 == [string compare CVS $base]} {continue} + if {[string match tklib-* $base]} {continue} + if {[string match *~ $base]} {continue} + + if {[file isdirectory $file]} then { + if {$recurse} { + file mkdir $sub + xxcopy $file $sub $recurse $pattern + } + } else { + puts -nonewline stdout . ; flush stdout + file copy -force $file $sub + } + } +} + +proc gd-assemble {} { + global tklib_version distribution + + puts "Assembling distribution in directory 'tklib-${tklib_version}'" + + xxcopy $distribution tklib-${tklib_version} 1 + file delete -force \ + tklib-${tklib_version}/config \ + tklib-${tklib_version}/modules/ftp/example \ + tklib-${tklib_version}/modules/ftpd/examples \ + tklib-${tklib_version}/modules/stats \ + tklib-${tklib_version}/modules/fileinput + puts "" + return +} + +proc gd-gen-tap {} { + package require textutil + package require fileutil + global tklib_name tklib_version distribution tcl_platform + + set modules [imodules] + set lines [list] + # Header + lappend lines {format {TclDevKit Project File}} + lappend lines {fmtver 2.0} + lappend lines {fmttool {TclDevKit TclApp PackageDefinition} 2.5} + lappend lines {} + lappend lines "## Saved at : [clock format [clock seconds]]" + lappend lines "## By : $tcl_platform(user)" + lappend lines {##} + lappend lines "## Generated by \"[file tail [info script]] tap\"" + lappend lines "## of $tklib_name $tklib_version" + lappend lines {} + lappend lines {########} + lappend lines {#####} + lappend lines {###} + lappend lines {##} + lappend lines {#} + + # Bundle definition + lappend lines {} + lappend lines {# ###############} + lappend lines {# Complete bundle} + lappend lines {} + lappend lines [list Package [list $tklib_name $tklib_version]] + lappend lines "Base @TAP_DIR@" + lappend lines "Platform *" + lappend lines "Desc {Tklib: Bundle of all packages}" + lappend lines "Path pkgIndex.tcl" + lappend lines "Path [join $modules "\nPath "]" + + set strip [llength [file split $distribution]] + incr strip 2 + + foreach m $modules { + # File set of module ... + + lappend lines {} + lappend lines "# #########[::textutil::strRepeat {#} [string length $m]]" ; # {} + lappend lines "# Module \"$m\"" + set n 0 + foreach {p v} [ppackages $m] { + lappend lines "# \[[format %1d [incr n]]\] | \"$p\"" + } + lappend lines "# -------+" + lappend lines {} + lappend lines [list Package [list __$m 0.0]] + lappend lines "Platform *" + lappend lines "Desc {Tklib module}" + lappend lines Hidden + lappend lines "Base @TAP_DIR@/$m" + + foreach f [modtclfiles $m] { + lappend lines "Path [fileutil::stripN $f $strip]" + } + + # Packages in the module ... + foreach {p v} [ppackages $m] { + lappend lines {} + lappend lines [list Package [list $p $v]] + lappend lines "See [list __$m]" + lappend lines "Platform *" + lappend lines "Desc {Tklib package}" + } + lappend lines {} + lappend lines {#} + lappend lines "# #########[::textutil::strRepeat {#} [string length $m]]" + } + + lappend lines {} + lappend lines {#} + lappend lines {##} + lappend lines {###} + lappend lines {#####} + lappend lines {########} + + # Write definition + set f [open [file join $distribution tklib.tap] w] + puts $f [join $lines \n] + close $f + return +} + + +proc gd-gen-rpmspec {} { + global tklib_version tklib_name distribution + + set header [string map [list @@@@ $tklib_version @__@ $tklib_name] {# $Id: sak.tcl,v 1.1 2003/11/28 22:42:03 andreas_kupries Exp $ + +%define version @@@@ +%define directory /usr + +Summary: The standard Tk library +Name: @__@ +Version: %{version} +Release: 2 +Copyright: BSD +Group: Development/Languages +Source: %{name}-%{version}.tar.bz2 +URL: http://tcllib.sourceforge.net/ +Packager: Jean-Luc Fontaine +BuildArchitectures: noarch +Prefix: /usr +Requires: tcl >= 8.3.1 +BuildRequires: tcl >= 8.3.1 +Buildroot: /var/tmp/%{name}-%{version} + +%description +Tklib, the Tk Standard Library is a collection of Tcl packages that +provide Tk utility functions and widgets useful to a large collection +of Tcl/Tk programmers. +The home web site for this code is http://tcllib.sourceforge.net/. +At this web site, you will find mailing lists, web forums, databases +for bug reports and feature requests, the CVS repository (browsable +on the web, or read-only accessible via CVS), and more. +Note: also grab source tarball for more documentation, examples, ... + +%prep + +%setup -q + +%install +# compensate for missing manual files: +# - nothing yet +/usr/bin/tclsh installer.tcl -no-gui -no-wait -no-html -no-examples\ + -pkg-path $RPM_BUILD_ROOT/usr/lib/%{name}-%{version}\ + -nroff-path $RPM_BUILD_ROOT/usr/share/man/mann/ +# install HTML documentation to specific modules sub-directories: +cd modules +mkdir ../ftp; mv ftp/docs/*.html ../ftp/ +for module in exif mime textutil stooop struct; do + mkdir ../$module && mv $module/*.html ../$module/; +done +# generate list of files in the package (man pages are compressed): +find $RPM_BUILD_ROOT ! -type d |\ + sed -e "s,^$RPM_BUILD_ROOT,,;" -e 's,\.n$,\.n\.gz,;' >\ + %{_builddir}/%{name}-%{version}/files + +%clean +rm -rf $RPM_BUILD_ROOT + +%files -f %{_builddir}/%{name}-%{version}/files +%defattr(-,root,root) +%doc README ChangeLog license.terms +}] + + set f [open [file join $distribution tklib.spec] w] + puts $f $header + close $f + return +} + +proc gd-gen-yml {} { + # YAML is the format used for the FreePAN archive network. + # http://freepan.org/ + global tklib_version tklib_name distribution + set yml [string map \ + [list %V $tklib_version %N $tklib_name] \ + {dist_id: tklib +version: %V +language: tcl +description: | + This package is intended to be a collection of Tcl packages that provide + Tk utility functions and widgets useful to a large collection of Tcl/Tk + programmers. + + The home web site for this code is http://tcllib.sourceforge.net/. + At this web site, you will find mailing lists, web forums, databases + for bug reports and feature requests, the CVS repository (browsable + on the web, or read-only accessible via CVS), and more. + +categories: + - Library/Utility + - Library/Mail + - Library/Cryptography + - Library/Math +license: BSD +owner_id: AndreasKupries +wrapped_content: %N-%V/ +}] + set f [open [file join $distribution tklib.yml] w] + puts $f $yml + close $f +} + +proc docfiles {} { + global distribution + package require fileutil + set res [list] + foreach f [fileutil::findByPattern $distribution -glob *.man] { + lappend res [file rootname [file tail $f]].n + } + proc tclfiles {} [list return $res] + return $res +} + +proc gd-tip55 {} { + global tklib_version tklib_name distribution contributors + contributors + + set md {Identifier: %N +Title: Tk Standard Library +Description: This package is intended to be a collection of + Tcl packages that provide Tk utility functions and widgets + useful to a large collection of Tcl/Tk programmers. +Rights: BSD +Version: %V +URL: http://tcllib.sourceforge.net/ +Architecture: tcl +} + + regsub {Version: %V} $md "Version: $tklib_version" md + regsub {Identifier: %N} $md "Identifier: $tklib_name" md + foreach person [lsort [array names contributors]] { + set mail $contributors($person) + regsub {@} $mail " at " mail + regsub -all {\.} $mail " dot " mail + append md "Contributor: $person <$mail>\n" + } + + set f [open [file join $distribution DESCRIPTION.txt] w] + puts $f $md + close $f +} + +# Fill the global array of contributors to tklib by processing the +# ChangeLog entries. +# +proc contributors {} { + global distribution contributors + if {![info exists contributors] || [array size contributors] == 0} { + get_contributors [file join $distribution ChangeLog] + + foreach f [glob -nocomplain [file join $distribution modules *]] { + if {![file isdirectory $f]} {continue} + if {[string match CVS [file tail $f]]} {continue} + if {![file exists [file join $f ChangeLog]]} {continue} + get_contributors [file join $f ChangeLog] + } + } +} + +proc get_contributors {changelog} { + global contributors + set f [open $changelog r] + while {![eof $f]} { + gets $f line + if {[regexp {^[\d-]+\s+(.*?)<(.*?)>} $line r name mail]} { + set name [string trim $name] + if {![info exists names($name)]} { + set contributors($name) $mail + } + } + } + close $f +} + +proc validate_imodules_cmp {imvar dmvar} { + upvar $imvar im $dmvar dm + + foreach m [lsort [array names im]] { + if {![info exists dm($m)]} { + puts " Installed, does not exist: $m" + } + } + foreach m [lsort [array names dm]] { + if {![info exists im($m)]} { + puts " Missing in installer: $m" + } + } + return +} + +proc validate_imodules {} { + foreach m [imodules] {set im($m) .} + foreach m [modules] {set dm($m) .} + + validate_imodules_cmp im dm + return +} + +proc validate_imodules_mod {m} { + array set im {} + array set dm {} + if {[imodules_mod $m]} {set im($m) .} + if {[modules_mod $m]} {set dm($m) .} + + validate_imodules_cmp im dm + return +} +proc validate_versions_cmp {ipvar ppvar} { + upvar $ipvar ip $ppvar pp + set maxl 0 + foreach name [array names ip] {if {[string length $name] > $maxl} {set maxl [string length $name]}} + foreach name [array names pp] {if {[string length $name] > $maxl} {set maxl [string length $name]}} + + foreach p [lsort [array names ip]] { + if {![info exists pp($p)]} { + puts " Indexed, no provider: $p" + } + } + foreach p [lsort [array names pp]] { + if {![info exists ip($p)]} { + puts " Provided, not indexed: [format "%-*s | %s" $maxl $p $::pf($p)]" + } + } + foreach p [lsort [array names ip]] { + if { + [info exists pp($p)] && ![string equal $pp($p) $ip($p)] + } { + puts " Index/provided versions differ: [format "%-*s | %8s | %8s" $maxl $p $ip($p) $pp($p)]" + } + } +} + +proc validate_versions {} { + foreach {p v} [ipackages] {set ip($p) $v} + foreach {p v} [ppackages] {set pp($p) $v} + + validate_versions_cmp ip pp + return +} + +proc validate_versions_mod {m} { + foreach {p v} [ipackages $m] {set ip($p) $v} + foreach {p v} [ppackages $m] {set pp($p) $v} + + validate_versions_cmp ip pp + return +} + +proc validate_testsuite_mod {m} { + global distribution + if {[llength [glob -nocomplain [file join $distribution modules $m *.test]]] == 0} { + puts " Without testsuite : $m" + } + return +} + +proc validate_testsuites {} { + foreach m [modules] { + validate_testsuite_mod $m + } + return +} + +proc validate_pkgIndex_mod {m} { + global distribution + if {[llength [glob -nocomplain [file join $distribution modules $m pkgIndex.tcl]]] == 0} { + puts " Without package index : $m" + } + return +} + +proc validate_pkgIndex {} { + global distribution + foreach m [modules] { + validate_pkgIndex_mod $m + } + return +} + +proc validate_doc_existence_mod {m} { + global distribution + if {[llength [glob -nocomplain [file join $distribution modules $m {*.[13n]}]]] == 0} { + if {[llength [glob -nocomplain [file join $distribution modules $m {*.man}]]] == 0} { + puts " Without * any ** manpages : $m" + } + } elseif {[llength [glob -nocomplain [file join $distribution modules $m {*.man}]]] == 0} { + puts " Without doctools manpages : $m" + } else { + foreach f [glob -nocomplain [file join $distribution modules $m {*.[13n]}]] { + if {![file exists [file rootname $f].man]} { + puts " no .man equivalent : $f" + } + } + } + return +} + +proc validate_doc_existence {} { + global distribution + foreach m [modules] { + validate_doc_existence_mod $m + } + return +} + + +proc validate_doc_markup_mod {m} { + gendoc null null $m + return +} + +proc validate_doc_markup {} { + gendoc null null + return +} + + +proc run-frink {args} { + global distribution + + set tmp [file rootname [info script]].tmp.[pid] + + if {[llength $args] == 0} { + set files [tclfiles] + } else { + set files [modtclfiles $args] + } + + foreach f $files { + puts "FRINK ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" + puts "$f..." + puts "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" + + catch {exec frink 2> $tmp -H $f} + set data [get_input $tmp] + if {[string length $data] > 0} { + puts $data + } + } + catch {file delete -force $tmp} + return +} + +proc run-procheck {args} { + global distribution + + if {[llength $args] == 0} { + set files [tclfiles] + } else { + set files [modtclfiles $args] + } + + foreach f $files { + puts "PROCHECK ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" + puts "$f ..." + puts "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" + + catch {exec procheck >@ stdout $f} + } + return +} + +proc get_input {f} {return [read [set if [open $f r]]][close $if]} + +# -------------------------------------------------------------- +# Help + +proc __help {} { + ## critcl-modules - Return a list of modules with critcl enhancements. + ## critcl ?module? - Build a critcl module [default is tklibc]. + + puts stdout { + Commands avalable through the swiss army knife aka SAK: + + help - This help + + /Configuration + version - Return tklib version number + major - Return tklib major version number + minor - Return tklib minor version number + name - Return tklib package name + + /Development + modules - Return list of modules. + contributors - Print a list of contributors to tklib. + lmodules - See above, however one module per line + imodules - Return list of modules known to the installer. + + packages - Return indexed packages in tklib, plus versions, + one package per line. Extracted from the + package indices found in the modules. + provided - Return list and versions of provided packages + (in contrast to indexed). + vcompare pkglist - Compare package list of previous 'packages' + call with current packages. Marks all new + and unchanged packages for higher attention. + + validate ?module..? - Check listed modules for problems. + For all modules if none specified. + + test ?module...? - Run testsuite for listed modules. + For all modules if none specified. + + /Release engineering + gendist - Generate distribution from CVS snapshot + gentip55 - Generate a TIP55-style DESCRIPTION.txt file. + rpmspec - Generate a spec file for the creation of RPM's. + tap - Generate a TclApp Package Definition for use in the Tcl Dev Kit. + yml - Generate a YAML description file. + + /Documentation + nroff ?module...? - Generate manpages + html ?module...? - Generate HTML pages + tmml ?module...? - Generate TMML + text ?module...? - Generate plain text + list ?module...? - Generate a list of manpages + wiki ?module...? - Generate wiki markup + latex ?module...? - Generate LaTeX pages + dvi ?module...? - See latex, + conversion to dvi + ps ?module...? - See dvi, + conversion to PostScript + } +} + +# -------------------------------------------------------------- +# Configuration + +proc __name {} {global tklib_name ; puts -nonewline $tklib_name} +proc __version {} {global tklib_version ; puts -nonewline $tklib_version} +proc __minor {} {global tklib_version ; puts -nonewline [lindex [split $tklib_version .] 1]} +proc __major {} {global tklib_version ; puts -nonewline [lindex [split $tklib_version .] 0]} + +# -------------------------------------------------------------- +# Development + +proc __imodules {} {puts [imodules]} +proc __modules {} {puts [modules]} +proc __lmodules {} {puts [join [modules] \n]} + + +proc nparray {a} { + upvar $a packages + + set maxl 0 + foreach name [lsort [array names packages]] { + if {[string length $name] > $maxl} { + set maxl [string length $name] + } + } + foreach name [lsort [array names packages]] { + puts stdout [format "%-*s %s" $maxl $name $packages($name)] + } + return +} + +proc __packages {} { + array set packages [ipackages] + nparray packages + return +} + +proc __provided {} { + array set packages [ppackages] + nparray packages + return +} + + +proc __vcompare {} { + global argv + set oldplist [lindex $argv 0] + + array set curpkg [ipackages] + array set oldpkg [loadpkglist $oldplist] + + foreach p [array names curpkg] {set __($p) .} + foreach p [array names oldpkg] {set __($p) .} + set unified [lsort [array names __]] + unset __ + + set maxl 0 + foreach name $unified { + if {[string length $name] > $maxl} { + set maxl [string length $name] + } + } + foreach name $unified { + set suffix "" + if {![info exists curpkg($name)]} {set curpkg($name) "--"} + if {![info exists oldpkg($name)]} {set oldpkg($name) "--" ; append suffix " NEW"} + if {[string equal $oldpkg($name) $curpkg($name)]} {append suffix " \t<<<"} + puts stdout [format "%-*s %-*s %-*s" $maxl $name 8 $oldpkg($name) 8 $curpkg($name)]$suffix + } + return +} + + + +proc __test {} { + global argv distribution + # Run testsuite + + set modules $argv + if {[llength $modules] == 0} { + set modules [modules] + } + + exec [info nameofexecutable] \ + [file join $distribution all.tcl] \ + -modules $modules \ + >@ stdout 2>@ stderr + return +} + +proc checkmod {} { + global argv + set fail 0 + foreach m $argv { + if {![modules_mod $m]} { + puts " Bogus module: $m" + set fail 1 + } + } + if {$fail} { + puts " Stop." + return 0 + } + return 1 +} + +# ------------------------------------------------------------------------- +# Critcl stuff +# ------------------------------------------------------------------------- + +array set critclmodules { + tklibc {} +} + +# Build critcl modules. If no args then build the tklibc module. +proc **__critcl {} { + global argv critcl critclmodules tcl_platform + if {$tcl_platform(platform) == "windows"} { + set critcl [auto_execok tclkitsh] + if {$critcl != {}} { + set critcl [concat $critcl [auto_execok critcl.kit]] + } + } else { + set critcl [auto_execok critcl] + } + + if {$critcl != {}} { + if {[llength $argv] == 0} { + #foreach p [array names critclmodules] { + # critcl_module $p + #} + critcl_module tklibc + } else { + foreach m $argv { + if {[info exists critclmodules($m)]} { + critcl_module $m + } else { + puts "warning: $m is not a critcl module" + } + } + } + } else { + puts "error: cannot find a critcl to run." + return 1 + } + return +} + +# Prints a list of all the modules supporting critcl enhancement. +proc **__critcl-modules {} { + global critclmodules + puts tklibc + foreach m [array names critclmodules] { + puts $m + } + return +} + +proc critcl_module {pkg} { + global critcl distribution critclmodules + if {$pkg == "tklibc"} { + set files [file join $distribution modules tklibc.tcl] + foreach m [array names critclmodules] { + foreach f $critclmodules($m) { + lappend files [file join $distribution modules $f] + } + } + } else { + foreach f $critclmodules($pkg) { + lappend files [file join $distribution modules $f] + } + } + set target [file join $distribution modules] + catch { + puts "$critcl -force -libdir [list $target] -pkg [list $pkg] $files" + eval exec $critcl -force -libdir [list $target] -pkg [list $pkg] $files + } r + puts $r + return +} + +# ------------------------------------------------------------------------- + +proc __validate {} { + global argv + if {[llength $argv] == 0} { + _validate_all + } else { + if {![checkmod]} {return} + foreach m $argv { + _validate_module $m + } + } + return +} + +proc _validate_all {} { + global tklib_name tklib_version + set i 0 + + puts "Validating $tklib_name $tklib_version development" + puts "===================================================" + puts "[incr i]: Existence of testsuites ..." + puts "------------------------------------------------------" + validate_testsuites + puts "------------------------------------------------------" + puts "" + + puts "[incr i]: Existence of package indices ..." + puts "------------------------------------------------------" + validate_pkgIndex + puts "------------------------------------------------------" + puts "" + + puts "[incr i]: Consistency of package versions ..." + puts "------------------------------------------------------" + validate_versions + puts "------------------------------------------------------" + puts "" + + puts "[incr i]: Installed vs. developed modules ..." + puts "------------------------------------------------------" + validate_imodules + puts "------------------------------------------------------" + puts "" + + puts "[incr i]: Existence of documentation ..." + puts "------------------------------------------------------" + validate_doc_existence + puts "------------------------------------------------------" + puts "" + + puts "[incr i]: Validate documentation markup (doctools) ..." + puts "------------------------------------------------------" + validate_doc_markup + puts "------------------------------------------------------" + puts "" + + puts "[incr i]: Static syntax check ..." + puts "------------------------------------------------------" + + set frink [auto_execok frink] + set procheck [auto_execok procheck] + + if {$frink == {}} {puts " Tool 'frink' not found, no check"} + if {$procheck == {}} {puts " Tool 'procheck' not found, no check"} + if {($frink == {}) || ($procheck == {})} { + puts "------------------------------------------------------" + } + if {($frink == {}) && ($procheck == {})} { + return + } + if {$frink != {}} { + run-frink + puts "------------------------------------------------------" + } + if {$procheck != {}} { + run-procheck + puts "------------------------------------------------------" + } + puts "" + + return +} + +proc _validate_module {m} { + global tklib_name tklib_version + set i 0 + + puts "Validating $tklib_name $tklib_version development -- $m" + puts "===================================================" + puts "[incr i]: Existence of testsuites ..." + puts "------------------------------------------------------" + validate_testsuite_mod $m + puts "------------------------------------------------------" + puts "" + + puts "[incr i]: Existence of package indices ..." + puts "------------------------------------------------------" + validate_pkgIndex_mod $m + puts "------------------------------------------------------" + puts "" + + puts "[incr i]: Consistency of package versions ..." + puts "------------------------------------------------------" + validate_versions_mod $m + puts "------------------------------------------------------" + puts "" + + #puts "[incr i]: Installed vs. developed modules ..." + puts "------------------------------------------------------" + validate_imodules_mod $m + puts "------------------------------------------------------" + puts "" + + puts "[incr i]: Existence of documentation ..." + puts "------------------------------------------------------" + validate_doc_existence_mod $m + puts "------------------------------------------------------" + puts "" + + puts "[incr i]: Validate documentation markup (doctools) ..." + puts "------------------------------------------------------" + validate_doc_markup_mod $m + puts "------------------------------------------------------" + puts "" + + puts "[incr i]: Static syntax check ..." + puts "------------------------------------------------------" + + set frink [auto_execok frink] + set procheck [auto_execok procheck] + + if {$frink == {}} {puts " Tool 'frink' not found, no check"} + if {$procheck == {}} {puts " Tool 'procheck' not found, no check"} + if {($frink == {}) || ($procheck == {})} { + puts "------------------------------------------------------" + } + if {($frink == {}) && ($procheck == {})} { + return + } + if {$frink != {}} { + run-frink $m + puts "------------------------------------------------------" + } + if {$procheck != {}} { + run-procheck $m + puts "------------------------------------------------------" + } + puts "" + + return +} + +# -------------------------------------------------------------- +# Release engineering + +proc __gendist {} { + gd-cleanup + gd-tip55 + gd-gen-rpmspec + gd-gen-tap + gd-assemble + gd-gen-archives + + puts ...Done + return +} + +proc __gentip55 {} { + gd-tip55 + puts "Created DESCRIPTION.txt" + return +} + +proc __yml {} { + gd-gen-yml + puts "Created YAML spec file \"tklib.yml\"" + return +} + +proc __contributors {} { + global contributors + contributors + foreach person [lsort [array names contributors]] { + puts "$person <$contributors($person)>" + } + return +} + +proc __tap {} { + gd-gen-tap + puts "Created Tcl Dev Kit \"tklib.tap\"" +} + +proc __rpmspec {} { + gd-gen-rpmspec + puts "Created RPM spec file \"tklib.spec\"" +} + + +# -------------------------------------------------------------- +# Documentation + +proc __html {} {global argv ; if {![checkmod]} return ; eval gendoc html html $argv} +proc __nroff {} {global argv ; if {![checkmod]} return ; eval gendoc nroff n $argv} +proc __tmml {} {global argv ; if {![checkmod]} return ; eval gendoc tmml tmml $argv} +proc __text {} {global argv ; if {![checkmod]} return ; eval gendoc text txt $argv} +proc __wiki {} {global argv ; if {![checkmod]} return ; eval gendoc wiki wiki $argv} +proc __latex {} {global argv ; if {![checkmod]} return ; eval gendoc latex tex $argv} +proc __dvi {} { + global argv ; if {![checkmod]} return + __latex + file mkdir [file join doc dvi] + cd [file join doc dvi] + foreach f [glob -nocomplain ../latex/*.tex] { + puts "Gen (dvi): $f" + exec latex $f 1>@ stdout 2>@ stderr + } + cd ../.. +} +proc __ps {} { + global argv ; if {![checkmod]} return + __dvi + file mkdir [file join doc ps] + cd [file join doc ps] + foreach f [glob -nocomplain ../dvi/*.dvi] { + puts "Gen (dvi): $f" + exec dvips -o [file rootname [file tail $f]].ps $f 1>@ stdout 2>@ stderr + } + cd ../.. +} + +proc __list {} { + global argv ; if {![checkmod]} return + eval gendoc list l $argv + + set FILES [glob -nocomplain doc/list/*.l] + set LIST [open [file join doc list manpages.tcl] w] + + foreach file $FILES { + set f [open $file r] + puts $LIST [read $f] + close $f + } + close $LIST + + eval file delete -force $FILES + + return +} + +# -------------------------------------------------------------- + +set cmd [lindex $argv 0] +if {[llength [info procs __$cmd]] == 0} { + puts stderr "unknown command $cmd" + set fl {} + foreach p [lsort [info procs __*]] { + lappend fl [string range $p 2 end] + } + puts stderr "use: [join $fl ", "]" + exit 1 +} + +set argv [lrange $argv 1 end] +incr argc -1 + +__$cmd +exit 0 diff --git a/tklib_version.tcl b/tklib_version.tcl new file mode 100644 index 00000000..f8b75f88 --- /dev/null +++ b/tklib_version.tcl @@ -0,0 +1,2 @@ +set tklib_version 0.2 +set tklib_name tklib From 14fea90543afcb76a01abc58020c387e0a1ade5e Mon Sep 17 00:00:00 2001 From: georgeps Date: Fri, 23 Jan 2004 00:32:16 +0000 Subject: [PATCH 0002/1290] ctext 3.1.3 --- modules/ctext/ChangeLog | 601 ++++++++++++ modules/ctext/LICENSE | 26 + modules/ctext/README | 152 +++ modules/ctext/REGRESSION | 4 + modules/ctext/TODO | 1 + modules/ctext/ctext.tcl | 1000 +++++++++++++++++++ modules/ctext/ctext_scroll_test.tcl | 11 + modules/ctext/ctext_test.tcl | 82 ++ modules/ctext/ctext_test_c.tcl | 70 ++ modules/ctext/ctext_test_interactive.tcl | 89 ++ modules/ctext/ctext_test_ws.tcl | 9 + modules/ctext/function_finder.tcl | 45 + modules/ctext/install.tcl | 57 ++ modules/ctext/long_test_script | 672 +++++++++++++ modules/ctext/pkgIndex.tcl | 1 + modules/ctext/test.c | 1134 ++++++++++++++++++++++ 16 files changed, 3954 insertions(+) create mode 100644 modules/ctext/ChangeLog create mode 100644 modules/ctext/LICENSE create mode 100644 modules/ctext/README create mode 100755 modules/ctext/REGRESSION create mode 100644 modules/ctext/TODO create mode 100644 modules/ctext/ctext.tcl create mode 100644 modules/ctext/ctext_scroll_test.tcl create mode 100755 modules/ctext/ctext_test.tcl create mode 100755 modules/ctext/ctext_test_c.tcl create mode 100755 modules/ctext/ctext_test_interactive.tcl create mode 100644 modules/ctext/ctext_test_ws.tcl create mode 100755 modules/ctext/function_finder.tcl create mode 100755 modules/ctext/install.tcl create mode 100644 modules/ctext/long_test_script create mode 100644 modules/ctext/pkgIndex.tcl create mode 100644 modules/ctext/test.c diff --git a/modules/ctext/ChangeLog b/modules/ctext/ChangeLog new file mode 100644 index 00000000..1594684b --- /dev/null +++ b/modules/ctext/ChangeLog @@ -0,0 +1,601 @@ +3.1.3 - Thu Jan 22 14:51:08 GMT 2004 + + I changed the bindtags so that binding to + the parent frame will cause the child $win.t + to invoke those bindings. This means that + you can create menus that popup on + ButtonPress-3 without having to use bind.tree + or a similar mechanism. Thank Jeff Hobbs + for pointing this out. + + I fixed the destroy event handling, so that + it will now not cleanup the widget when a + temporary child of the widget is destroyed. + +3.1.2 - Fri May 23 17:33:17 GMT 2003 + + I fixed ctext::deleteHighlighClass so + that it will now delete regexp classes. + I had to modify ctext::getHighlightClasses + and ctext::addHighlightClassForRegexp to + fix it. I've decided to keep the package + provide at 3.1. + +3.1.1 - Fri May 23 00:53:39 GMT 2003 + + I made some minor changes to configure + instance handling, so that .t config + will return the proper values. Alas I + decided to add a TODO, because the values + aren't quite like standard Tk; with the + resource classes and all. + +3.1 - Thu May 22 01:30:41 GMT 2003 + + I fixed some bugs on the configure instance + handling. I added ctext::buildArgParseTable, + which improves performance, because now the + table is only generated once per widget. + + I improved cget to accept glob expressions, + which also fixed a bug with strings like: + cget -yscroll which didn't match an array + element, but do match when passed to the + real text widget. + + You can now pass strings like: + .t config -flag + + and the value for -flag will be returned + even if the flag is special to ctext. + This took some engineering to get right. + + I fixed a bug in the test files that occured + due to some fixes. Basically I'm using list + now to construct the tagInfo for each highlight + class. This caused problems, because I was + previously using strings. The test files were + using escapes to work around the quoting + problem. They have been changed and now + everything should work properly. You will + need to lookout for this problem if you + upgrade. + + I updated REGRESSION. + + The end result is a good release based on + my testing. + +3.1-alpha-5 - Thu May 15 00:39:10 GMT 2003 + + I fixed a minor bug in argument handling + in the configure instance handler. + +3.1-alpha-4 - Wed May 14 17:09:32 GMT 2003 + + I improved install.tcl by adding more + information about auto_path. + + I fixed a bug with listbox selection in + install.tcl (curselection wasn't used). + + I renamed ctext::getClasses to + ctext::getHighlightClasses. + + I made some uplevel calls list based, so + that if $win has a space in its path ctext + will work correctly. + + I made the class creation procs all use + list for storing items in the arrays. + + I modified ctext::getHighlightClasses to + return a list in the format of: + class [list items ...] + + I fixed a bug with + ctext::addHighlightClassForRegexp. It + wasn't storing the $re in the class array. + This was new to the 3.x series. + +3.1-alpha-2-3 - Tue May 13 19:30:51 GMT 2003 + + I have redone the configure instance + handling. I added -linemap_select_fg + and -linemap_select_bg. I have updated + the README to reflect the new commands + and options introduced in the 3.x series. + I have removed the TODO file, because all + tasks within it have been completed. + + I added an install.tcl script. It's + very easy to use and passes all of my + tests. + + I need to test with Malephiso, + because there may be minor issues I + haven't noticed. + +3.1-alpha-1 - Mon May 12 23:12:18 GMT 2003 + + I've made many changes that have cleaned + up the code. I have added -linemap_markable. + I changed ctext::getAr to accept a suffix. + I'm now using global variables with a + __ctext prefix, because it is easier than + using namespace variables. + + The _blink tag was renamed to __ctext_blink. + + I added ctext::deleteHighlightClass, which + works with any of the 4 class creators. It + needs more testing, but so far it passes + all of my tests. + + I want to wait about a week or so and go + over each line of code slowly. I've tried + to engineer this well, but typos happen, so... + + I need to merge more of Andreas Sievers' + changes and features. + +[At this point Andreas Sievers working on ASED +submitted his 3.0 to me and I decided to create +3.1 which merges 2.7-alpha with his work.] + +2.7-alpha - Fri May 2 13:08:48 GMT 2003 + + I have added -linemap_mark_command with + an example in ctext_test_interactive.tcl + + I addec ctext::getAr which I'm using to + store more state information about the + widget for cget and configure. I modified + cget and configure to use it, and they + are now more useful. + + This is an alpha release because I haven't + tested it much. I still need to spend + some time and review the diffs. I'll + probably get to that next week, and I'll + test it with Malephiso (my editor). I + should also update the README with + information about -linemap_mark_command. + +2.6.10 - Tue Apr 29 20:47:29 GMT 2003 + + I fixed a bug with -font handling in the + instance command. + You can now do: + .t config -font + and it will change the linemap font as + well as the main text widget. + + I cleaned up argument handling in the + constructor and instance commands. They + now use concat and are simpler. + + I added ctext::event:Destroy which now + takes care of removing an interp alias + which was missing in previous releases. + + interp alias is now used rather than + eval with a dummy proc for creating an + instance command. + + $win now has a binding that + should fix a problem some of you may + experience. + You can now do: + focus $win + and it will act like: + focus $win.t + + I removed uplevel n eval calls, which + were pointless. I didn't realize + when I wrote them that uplevel acts like + eval. + +2.6.9 - Mon Apr 28 16:17:13 GMT 2003 + + I fixed a minor focus issue by adding + -takefocus 0 to the linemap creator. + + I also removed an uplevel #0 for interp + alias, which wasn't needed. + + I removed the government clause in the + LICENSE. + + I'm pondering a rewrite of Ctext (yet again) + which will use SDynObject, and provide more + features, but the thought "Why fix it if it + isn't broken?" comes to mind. + +2.6.8 - Mon Dec 2 18:24:49 GMT 2002 + + I fixed two bugs pointed out by Neil Madden. + + The initial creation of the widget failed + when -linemap 0 was used. + + The virtual event <> was not occuring. + ---- + I cleaned up several rough areas in the code. + + I cleaned up the code in the creation of the + widget for -yscrollcommand and the linemap. + + I cleaned up the code in the configure instance + command handler. + + ---- + This release passes all of my tests with + Tcl/Tk 8.3 and 8.4. To make debugging easier + I have added ctext_test_interactive.tcl + +2.6.7 - Fri Nov 22 16:39:41 GMT 2002 + + I fixed a bug with C comment highlighting. It + wasn't updating the highlighting when the + insertion was just one character. The problem + was that the RE didn't match, because the + previous char and next char were not used to + decipher the match. + + This release was tested with Tcl/Tk 8.4 + +2.6.6 - Thu Aug 22 23:46:14 GMT 2002 + + I fixed a serious bug with ctext::matchPair + and ctext::matchQuote. The problem was that + in some cases the pattern )|}|] was causing + an infinite loop when no other patterns matched. + It was finding the same character over and over + again. This is fixed now. I'm sorry to anyone + that was bothered by this. I found it today with + Malephiso while editing a test file. It basically + locked up my editor. The long scripts and C code + I've been editing in the past haven't had this + problem, due to multiple characters matching. + + Please report BUGS. I need your help. + +2.6.5 - Tue Aug 20 23:27:23 GMT 2002 + + I fixed a minor issue with handling. + A catch was needed to prevent an error + message, due to several events + occuring in some cases. + + +2.6.4 - Tue Jul 23 19:29:49 MDT 2002 + + I fixed a minor bug with the linemap updating. + I didn't notice that with a small number of + lines it wasn't displaying the line numbers + properly. + + I fixed a major flaw with 8.4 handling. The + 8.4 text widget has some new features, and + the edit instance command wasn't dealing with + the requests properly. Now it should, but + I haven't tested it a lot. + + +2.6.3 - Fri Jul 5 11:32:42 MDT 2002 + + I made improvements to ctext::matchPair that + should improve the speed. I also fixed a + bug that occured with the pattern { \}. + + I added an edit modified instance command. + I'm not sure if it works like the Tk 8.4 + version, but it should work well enough. + + I added edit modified tests to ctext_test.tcl + + I added -class Ctext to the parent frame. + Those of you using .Xdefaults may want this. + + I updated the README for edit modified. + + It's about time for another study session of + the code to fix any bugs or potential bugs. + +2.6.2 - Mon Jul 1 09:31:39 MDT 2002 + + I fixed a bug with handling. + + I removed all calls to variable, and now use + the fully qualified namespace name for variables. + This makes the code more concise and cleaner. + + I improved the speed of + ctext::addHighlightClassForSpecialChars by + using foreach with [split $str ""]. + + I added a Destroy button to ctext_test.tcl. + + I removed the -font flags in the test files, + so it will use what's in the X resources, or + the default for Tk. + + I improved ctext::matchQuote:blink by doing + if {$count & 1} rather than if {[expr {$count & 1}]} + I need to remember that if is like expr. + + I fixed a Doh! in ctext::matchQuote. I was + not thinking that the end pos is already known + due to the switch in the instanceCmd. + + ctext::matchPair now works. Try typing a pattern + of ( ) or [ ] or { } or ( ( ) ) and so on. It's really + cool. Big thanks to Mac Cody for inspiring this. I + didn't use any of his code for MatchPair but I looked + at it to get a general idea. + +2.6.1 - Thu Jun 27 10:55:54 MDT 2002 + + I added ctext::disableComments and + ctext::enableComments. C comment highlighting + is disabled by default now. I started merging + the changes by Mac Cody into this release. I + used some of his code for making quotes blink. + I rewrote some of it to fit more with my ideals. + I'll be merging more of his great ideas into + Ctext in the future. + + I fixed a bug with the C comment highlighting. + I found that \\ was causing problems, so the + \\\\ RE addition and \\\\ check solves that. + + I replaced func_finder.tcl with a newer file that + should work better. What I should probably do is + write a minimal C parser for dealing with finding + functions, or do another trick with the C + preprocessor. + + I updated the README and ctext_test_c.tcl + +2.6 - Mon Jun 24 09:39:24 MDT 2002 + + I radically modified ctext::comments to fix bugs + with comments in quotes being highlighted and + to improve speed. It is now much faster and + simpler. I added -linemapfg and -linemapbg options. + + +2.5.2 - Sun May 19 09:36:16 MDT 2002 + + I made major changes to how the C commenting works. + I made a serious mistake with the way that C + comments were highlighted. I was invoking + ctext::comments and there could be several + after idle timers going that call it that were + relying on a global array. Basically my + state variables were getting clobbered. It + took me a while to figure this out. Now I + pass a [clock clicks] argument for each call + and it creates the array if necessary and + passes the clock clicks value in subsequent + calls. The end result is that now several + ctext::comments loops can be running at + once and they don't clobber each other. + +2.5.1 - Fri Mar 15 17:15:30 MST 2002 + + I have added ctext::update which allows you + to update a cursor or progress dialog while + Ctext highlights text. It works quite nicely + in Malephiso. I updated the README to + show the new change, and how to use it. I + also fixed a minor error in the README. + +2.5 - Sat Mar 2 23:59:07 MST 2002 + + I've fixed several critical bugs with deletion + of text. I've improved the clarity of the + code by adding ctext::instanceCmd. This also + makes it so that theoretically you could + overload ctext. The performance of deletion + and insertion may be better due to my use of + a timer for highlighting. + +2.4.1 - Sat Feb 23 23:12:49 MST 2002 + + I fixed a bug with tag removal that occured + when text was appended to an existing tag. + The fix was to use the insert position minus + one char in the call to ctext::findPreviousSpace. + + +2.4 - Tue Feb 5 16:27:46 MST 2002 + + The linemap will now update even if scrolling + hasn't occured. I tried to get this working + in previous releases, but had problems with + display updates. Now I use "after 1" with it, + so it works without blocking the GUI. + + The widget should now completely clean up after + itself I hope. I made changes to the + callback. Please let me know if it doesn't + cleanup for you. + + +2.3.5 - Wed Jan 23 23:55:51 MST 2002 + + I fixed a minor bug that caused some text tags + to be removed when they shouldn't be when deleting + the first character of a line. + + if {[$self._t compare $start < $lineStart]} { + set start $lineStart + } + +2.3.4 - Mon Jan 21 22:05:23 MST 2002 + + I added | and , to the not chars. This helps with C + syntax highlighting. + +2.3.3 - Mon Jan 14 23:06:39 MST 2002 + + I fixed a bug with C comment highlighting that occured when + the state of the comment handler was not reset when it reached + the end of the text widget. I also fixed a minor bug with + tag removal in the delete handler. + +2.3.2 - Thu Jan 10 19:48:20 MST 2002 + + I added " and ' to the not chars in the main highlighting + engine. This makes it so that char start strings like + $blah end at a " or '. So, for example with $blah" every + thing would be highlighted like the variable. Now, it only + highlights the $blah. + +2.3.1 - Fri Jan 4 22:35:19 MST 2002 + + I fixed a minor bug with the C comment handling. I now + have it working very fast for a while, and then it stops + until being restarted when / or * is found/entered in the + insert or delete widget instance commands. There is one + bug I'm trying to track down where the highlighting stops + for apparently no reason. It's probably good enough to + use for production use in Malephiso, but as usual no warranty + to you folks. + +2.3 - Mon Dec 31 15:18:05 MST 2001 + + I have added C comment highlighting. It works properly + but it flashes; which can be annoying. I'm going to work + on this more later on. + +2.2.8 - Mon Dec 31 04:18:57 MST 2001 + + I fixed some bugs with the delete instance command. + + +2.2.7 - Sun Dec 30 18:15:10 MST 2001 + + I made changes to ctext::highlight that have improved + the speed. They should help a lot with very large files. + +2.2.6 - Sun Dec 30 16:28:26 MST 2001 + + I improved the search expressions by adding -- to + deal with - in any of the search strings. Using + ctext in Malephiso has caused me to find so many bugs + that I had no idea about over the past week or so. + +2.2.5 - Sun Dec 30 11:10:38 MST 2001 + + I fixed a bug with findPreviousSpace and findNextSpace + which should improve the speed of tag removal, because + it will no longer remove char tags that it doesn't + have to. + +2.2.4 - Sun Dec 30 10:57:57 MST 2001 + + I fixed a bug with the highlighting that occured when + the whitespace is entered between a highlighted word. + + I also fixed a bug with the linemap that occured when + an empty line was pressed. + +2.2.3 - Mon Dec 24 12:53:49 MST 2001 + + I added ; to the RE for not chars in the ctext::highlight + proc. + +2.2.2 - Sun Dec 23 14:37:26 MST 2001 + + I made a minor change to the highlighting RE, so that + it handles things like [.widget cget -flag] Before this + the -flag part wouldn't have been highlighted. + + I added ctext::clearHighlightClasses which takes only + one argument; $win. + +2.2.1 - Wed Dec 19 10:18:42 MST 2001 + + I fixed a bug that occured with some text widget commands, + for example searching with -count. I had to use uplevel + in the call to the master text widget. + + +2.2 - Wed Dec 19 06:18:08 MST 2001 + + I've fixed some bugs that occured if C functions were being + highlighted. I changed addHighlightClassForSpecialChars + so that it accepts a string of characters to match. + All addHighlightClass commands now must have a window argument. + The window argument makes it so that you can now have multiple + languages highlighted in separate windows. I added + ctext::addHighlightClassForRegexp (see the test files for + examples). + + I'm going to write a script for finding all Tcl and Tk + flags via an automated search through the man pages. This + should hopefully help others with their custom editors + that use ctext. + +2.1.4 + I fixed a few bugs. Widget destruction should now work + properly. + +2.1.3: +Well, the diff between 2.1.2 and 2.1.3 is huge. To summarize I've +replaced the list that stored selected linemap lines with an array, +which has improved the performance. I've added error checking and +done a bunch of cleanup. I've changed the indentation style. + +2.1.2: +LICENSE file added and licensing changed to BSD style. + +2.1.1: +replaced addHighlightClass array setting with a list (quoting hell fix) + +2.1: +added \r to the tests for the Mac +added \r to the default regexp end of line for the Mac +removed global and replaced with upvar #0 +added ctext to the prefix of ToggledList +new ctext_test2.tcl with two ctext widgets +fixed the dos2unix script, so that {lf lf} -translation is used + +2.0.2: +fixed a bug with insert calling highlight improperly when pasting/inserting multiple lines +wrote dos2unix to convert from NT's \r\n to \n so that Unix people aren't annoyed. +update idletasks added to delete and insert instance commands + +2.0.1: +ctext_test.tcl removed extra ctext test window + +2.0-a6: +instance cget -linemap works +added more documentation to Readme.txt + +2.0-a5: +removed hardcoded comment highlighting +removed debug output and console show + +2.0-a4: +> 50% speedup during ctext::highlight due to a simpler regexp +that uses not ([^ chars]+) instead. + +2.0-a3: +fixed bug with cut instance command +added fastdelete and fastinsert instance commands +instance config -linemap and -yscrollcommand work +added highlight instance command +added copy, cut, paste, and append selection instance commands + +2.0-a2: +proc ctext::addHighlightClassForSpecialChars +proc ctext::addHighlightClassWithOnlyCharStart +highlight function works +merged delete from 1.1.1 and fixed a bug +insert bug fix + + diff --git a/modules/ctext/LICENSE b/modules/ctext/LICENSE new file mode 100644 index 00000000..3c41ca96 --- /dev/null +++ b/modules/ctext/LICENSE @@ -0,0 +1,26 @@ +This software is copyrighted by George Peter Staplin. The following +terms apply to all files associated with the software unless explicitly +disclaimed in individual files. + +The authors hereby grant permission to use, copy, modify, distribute, +and license this software and its documentation for any purpose, provided +that existing copyright notices are retained in all copies and that this +notice is included verbatim in any distributions. No written agreement, +license, or royalty fee is required for any of the authorized uses. +Modifications to this software may be copyrighted by their authors +and need not follow the licensing terms described here, provided that +the new terms are clearly indicated on the first page of each file where +they apply. + +IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY +FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY +DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE +IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE +NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +MODIFICATIONS. diff --git a/modules/ctext/README b/modules/ctext/README new file mode 100644 index 00000000..a8f2aea6 --- /dev/null +++ b/modules/ctext/README @@ -0,0 +1,152 @@ + + o Author + + George Peter Staplin + + See also: Thanks (below) + + + o Licensing + + BSD style see the LICENSE file + + + o Installation + + Ctext requires only one file named ctext.tcl. You + can source this file or if you prefer to use + "package require ctext" you can use the install.tcl + script. The install script can be run like so: + wish8.4 install.tcl + + If you are a developer I highly recommend that you + study the Usage section below. If you need an + example then see the test files (especialy + ctext_test_interactive.tcl). + + + o How it Works + + Ctext overloads the text widget and provides + new commands, named highlight, copy, paste, cut, + append, and edit. It also provides several + commands that allow you to define classes. + Each class corresponds to a tag in the widget. + + + o Usage + + Ctext can be used like so: + pack [ctext .t] + .t fastinsert end $data + .t highlight 1.0 end + + The copy, paste, and cut widget commands are frontends + for tk_text*, but they don't require giving an argument + for the text widget window. I have also addded an + append command, which appends the current selection + to the existing clipboard text. + + An edit modified command is available that keeps + track of whether or not data in the widget has been + modified. .t edit modified would return 0 if the + data hasn't been modified. To set the value after + inserting text you can use .t edit modified 0. It + will automatically be set to 1 during + insertion/deletion cut/paste etc. + + During insertion and deletion of text in the widget + the tags and highlighting will be automatically + updated, unless you specify -highlight 0 during + creation or instance configuration of the widget. + + All of the flags that the text widget supports work. + It also supports new flags. These new flags are: + + -linemap creates a line number list on the left of + the widget. + + -linemapfg changes the foreground of the linemap. + The default is the same color as the main text + widget. + + -linemapbg changes the background of the linemap. + The default is the same color as the main text + widget. + + -linemap_select_fg changes the selected + line foreground. The default is black. + + -linemap_select_bg changes the selected line + background. The default is yellow. + + -linemap_mark_command calls a procedure or command + with the path of the ctext window, the type which is + either marked or unmarked, and finally the line + number selected. The proc prototype is: + proc linemark_cmd {win type line}. See also + ctext_test_interactive.tcl + + -highlight takes a boolean value which defines + whether or not to highlight text which is inserted + or deleted. The default is 1. + + -linemap_markable takes a boolean value which + specifies whether or not lines in the linemap + are markable with the mouse. The default is 1. + + Four highlighting procedures are available for adding + keywords. Each proc takes a class, color, keyword, + and window argument. The highlight widget command will + automatically use each class that you add with any of + the three functions. If you want to change the font + of a class or another attribute you can run a + command like this: + .t tag configure $className -font {Helvetica 16} + + Note that the tag is created when you add a class. + + Normal keywords: + ctext::addHighlightClass .t class color [list string1 string2 ...] + + Strings that start with chars like $, for $var: + ctext::addHighlightClassWithOnlyCharStart .t class color "\$" + + A series of characters in a string + ctext:addHighlightClassForSpecialChars .t class color {[]{}} + + Comments, and other things that need regexp: + ctext::addHighlightClassForRegexp .t class color {#\[^\n\]*} + + ctext::clearHighlightClasses clears all of the + highlight classes from the widget specified. + Example: ctext::clearHighlightClasses .t + + To get a list of classes defined for a widget do + something like: ctext::getHighlightClasses .t + + To delete a highlight class do something like: + ctext::deleteHighlightClass .t classNameToDelete + + You can update a cursor while ctext highlights a large file + by overriding ctext::update. Simply source ctext.tcl then + create your ctext::update proc, and it will be called by + ctext. This allows you to have a progress dialog, or animated + cursor. + + If you are using C and want C comments highlighted you can + use ctext::enableComments. You can modify the colors of + C comments by configuring the tag _cComment after enabling with + the afformentioned command. The C comment highlighting is + disabled by default. + + + I have personally tested it with Tcl/Tk 8.4.4 in NetBSD. + It should work with all Tcl platforms. + + Please send comments and bugs to GeorgePS@XMission.com + + o Thanks + + Kevin Kenny, Neil Madden, Jeffrey Hobbs, Richard Suchenwirth, + Johan Bengtsson, Mac Cody, Günther, and Andreas Sievers. diff --git a/modules/ctext/REGRESSION b/modules/ctext/REGRESSION new file mode 100755 index 00000000..3c648361 --- /dev/null +++ b/modules/ctext/REGRESSION @@ -0,0 +1,4 @@ + +Due to changes between the 2.7 and 3.1 release you may need to remove escapes in your class patterns. This is due to my former inproper use of quotes, which I have now replaced with lists. The escaping is no longer necessary. + +Some fonts don't display a bitmap properly. The size of the bitmap seems to be the issue. This seems to be a bug with the text widget. diff --git a/modules/ctext/TODO b/modules/ctext/TODO new file mode 100644 index 00000000..739a3cbf --- /dev/null +++ b/modules/ctext/TODO @@ -0,0 +1 @@ +Make the flags that ctext adds have Class and resource names. Also make .t config return those resource/class names. I suspect that I could do this by making each value for a flag a list, but this needs proper planning before I go coding in the unknown. diff --git a/modules/ctext/ctext.tcl b/modules/ctext/ctext.tcl new file mode 100644 index 00000000..9a8b59bd --- /dev/null +++ b/modules/ctext/ctext.tcl @@ -0,0 +1,1000 @@ +# By George Peter Staplin +# See also the README for a list of contributors +# RCS: @(#) $Id: ctext.tcl,v 1.1.1.1 2004/01/23 00:32:16 georgeps Exp $ + +package require Tk +package provide ctext 3.1 + +namespace eval ctext {} + +#win is used as a unique token to create arrays for each ctext instance +proc ctext::getAr {win suffix name} { + set arName __ctext[set win][set suffix] + uplevel [list upvar #0 $arName $name] + return $arName +} + +proc ctext {win args} { + if {[llength $args] & 1} { + return -code error "invalid number of arguments given to ctext (uneven number after window) : $args" + } + + frame $win -class Ctext + + set tmp [text .__ctextTemp] + + ctext::getAr $win config ar + + set ar(-fg) [$tmp cget -foreground] + set ar(-bg) [$tmp cget -background] + set ar(-font) [$tmp cget -font] + set ar(-relief) [$tmp cget -relief] + destroy $tmp + set ar(-yscrollcommand) "" + set ar(-linemap) 1 + set ar(-linemapfg) $ar(-fg) + set ar(-linemapbg) $ar(-bg) + set ar(-linemap_mark_command) {} + set ar(-linemap_markable) 1 + set ar(-linemap_select_fg) black + set ar(-linemap_select_bg) yellow + set ar(-highlight) 1 + set ar(win) $win + set ar(modified) 0 + + set ar(ctextFlags) [list -yscrollcommand -linemap -linemapfg -linemapbg \ +-font -linemap_mark_command -highlight -linemap_markable -linemap_select_fg \ +-linemap_select_bg] + + array set ar $args + + foreach flag {foreground background} short {fg bg} { + if {[info exists ar(-$flag)] == 1} { + set ar(-$short) $ar(-$flag) + unset ar(-$flag) + } + } + + #Now remove flags that will confuse text and those that need modification: + foreach arg $ar(ctextFlags) { + set loc [lsearch $args $arg] + if {$loc >= 0} { + set args [lreplace $args $loc [expr {$loc + 1}]] + } + } + + text $win.l -font $ar(-font) -width 1 -height 1 \ + -relief $ar(-relief) -fg $ar(-linemapfg) -bg $ar(-linemapbg) -takefocus 0 + + set topWin [winfo toplevel $win] + bindtags $win.l [list $win.l $topWin all] + + if {$ar(-linemap) == 1} { + pack $win.l -side left -fill y + } + + set args [concat $args [list -yscrollcommand [list ctext::event:yscroll $win $ar(-yscrollcommand)]]] + + #escape $win, because it could have a space + pack [eval text \$win.t $args -font \$ar(-font)] -side right -fill both -expand 1 + + bind $win.t [list ctext::linemapUpdate $win] + bind $win.l [list ctext::linemapToggleMark $win %y] + bind $win.t [list ctext::linemapUpdate $win] + rename $win __ctextJunk$win + rename $win.t $win._t + + bind $win [list ctext::event:Destroy $win %W] + bindtags $win.t [linsert [bindtags $win.t] 0 $win] + + interp alias {} $win {} ctext::instanceCmd $win + interp alias {} $win.t {} $win + + #If the user wants C comments they should call ctext::enableComments + ctext::disableComments $win + ctext::modified $win 0 + ctext::buildArgParseTable $win + + return $win +} + +proc ctext::event:yscroll {win clientData args} { + ctext::linemapUpdate $win + + if {$clientData == ""} { + return + } + uplevel #0 $clientData $args +} + +proc ctext::event:Destroy {win dWin} { + if {![string equal $win $dWin]} { + return + } + catch {rename $win {}} + interp alias {} $win.t {} + ctext::clearHighlightClasses $win + array unset [ctext::getAr $win config ar] +} + +#This stores the arg table within the config array for each instance. +#It's used by the configure instance command. +proc ctext::buildArgParseTable win { + set argTable [list] + + lappend argTable any -linemap_mark_command { + set configAr(-linemap_mark_command) $value + break + } + + lappend argTable {1 true yes} -linemap { + pack $self.l -side left -fill y + set configAr(-linemap) 1 + break + } + + lappend argTable {0 false no} -linemap { + pack forget $self.l + set configAr(-linemap) 0 + break + } + + lappend argTable any -yscrollcommand { + set cmd [list $self._t config -yscrollcommand [list ctext::event:yscroll $self $value]] + + if {[catch $cmd res]} { + return $res + } + set configAr(-yscrollcommand) $value + break + } + + lappend argTable any -linemapfg { + if {[catch {winfo rgb $self $value} res]} { + return -code error $res + } + $self.l config -fg $value + set configAr(-linemapfg) $value + break + } + + lappend argTable any -linemapbg { + if {[catch {winfo rgb $self $value} res]} { + return -code error $res + } + $self.l config -bg $value + set configAr(-linemapbg) $value + break + } + + lappend argTable any -font { + if {[catch {$self.l config -font $value} res]} { + return -code error $res + } + $self._t config -font $value + set configAr(-font) $value + break + } + + lappend argTable {0 false no} -highlight { + set configAr(-highlight) 0 + break + } + + lappend argTable {1 true yes} -highlight { + set configAr(-highlight) 1 + break + } + + lappend argTable {0 false no} -linemap_markable { + set configAr(-linemap_markable) 0 + break + } + + lappend argTable {1 true yes} -linemap_markable { + set configAr(-linemap_markable) 1 + break + } + + lappend argTable any -linemap_select_fg { + if {[catch {winfo rgb $self $value} res]} { + return -code error $res + } + set configAr(-linemap_select_fg) $value + $self.l tag configure lmark -foreground $value + break + } + + lappend argTable any -linemap_select_bg { + if {[catch {winfo rgb $self $value} res]} { + return -code error $res + } + set configAr(-linemap_select_bg) $value + $self.l tag configure lmark -background $value + break + } + + ctext::getAr $win config ar + set ar(argTable) $argTable +} + +proc ctext::instanceCmd {self cmd args} { + #slightly different than the RE used in ctext::comments + set commentRE {\"|\\|'|/|\*} + + switch -glob -- $cmd { + append { + if {[catch {$self._t get sel.first sel.last} data] == 0} { + clipboard append -displayof $self $data + } + } + + cget { + set arg [lindex $args 0] + ctext::getAr $self config configAr + + foreach flag $configAr(ctextFlags) { + if {[string match ${arg}* $flag]} { + return [set configAr($flag)] + } + } + return [$self._t cget $arg] + } + + conf* { + ctext::getAr $self config configAr + + if {0 == [llength $args]} { + set res [$self._t configure] + set del [lsearch -glob $res -yscrollcommand*] + set res [lreplace $res $del $del] + + foreach flag $configAr(ctextFlags) { + lappend res [list $flag [set configAr($flag)]] + } + return $res + } + + array set flags {} + foreach flag $configAr(ctextFlags) { + set loc [lsearch $args $flag] + if {$loc < 0} { + continue + } + + if {[llength $args] <= ($loc + 1)} { + #.t config -flag + return [set configAr($flag)] + } + + set flagArg [lindex $args [expr {$loc + 1}]] + set args [lreplace $args $loc [expr {$loc + 1}]] + set flags($flag) $flagArg + } + + foreach {valueList flag cmd} $configAr(argTable) { + if {[info exists flags($flag)]} { + foreach valueToCheckFor $valueList { + set value [set flags($flag)] + if {[string equal "any" $valueToCheckFor]} $cmd \ + elseif {[string equal $valueToCheckFor [set flags($flag)]]} $cmd + } + } + } + + if {[llength $args]} { + #we take care of configure without args at the top of this branch + uplevel 1 [linsert $args 0 $self._t configure] + } + } + + copy { + tk_textCopy $self + } + + cut { + if {[catch {$self.t get sel.first sel.last} data] == 0} { + clipboard clear -displayof $self.t + clipboard append -displayof $self.t $data + $self delete [$self.t index sel.first] [$self.t index sel.last] + ctext::modified $self 1 + } + } + + delete { + #delete n.n ?n.n + + #first deal with delete n.n + set argsLength [llength $args] + + if {$argsLength == 1} { + set deletePos [lindex $args 0] + set prevChar [$self._t get $deletePos] + + $self._t delete $deletePos + set char [$self._t get $deletePos] + + set prevSpace [ctext::findPreviousSpace $self._t $deletePos] + set nextSpace [ctext::findNextSpace $self._t $deletePos] + + set lineStart [$self._t index "$deletePos linestart"] + set lineEnd [$self._t index "$deletePos + 1 chars lineend"] + + if {[string equal $prevChar "#"] || [string equal $char "#"]} { + set removeStart $lineStart + set removeEnd $lineEnd + } else { + set removeStart $prevSpace + set removeEnd $nextSpace + } + + foreach tag [$self._t tag names] { + if {[string equal $tag "_cComment"] != 1} { + $self._t tag remove $tag $removeStart $removeEnd + } + } + + set checkStr "$prevChar[set char]" + + if {[regexp $commentRE $checkStr]} { + after idle [list ctext::comments $self] + } + ctext::highlight $self $lineStart $lineEnd + ctext::linemapUpdate $self + } elseif {$argsLength == 2} { + #now deal with delete n.n ?n.n? + set deleteStartPos [lindex $args 0] + set deleteEndPos [lindex $args 1] + + set data [$self._t get $deleteStartPos $deleteEndPos] + + set lineStart [$self._t index "$deleteStartPos linestart"] + set lineEnd [$self._t index "$deleteEndPos + 1 chars lineend"] + eval \$self._t delete $args + + foreach tag [$self._t tag names] { + if {[string equal $tag "_cComment"] != 1} { + $self._t tag remove $tag $lineStart $lineEnd + } + } + + if {[regexp $commentRE $data]} { + after idle [list ctext::comments $self] + } + + ctext::highlight $self $lineStart $lineEnd + if {[string first "\n" $data] >= 0} { + ctext::linemapUpdate $self + } + } else { + return -code error "invalid argument(s) sent to $self delete: $args" + } + ctext::modified $self 1 + } + + fastdelete { + eval \$self._t delete $args + ctext::modified $self 1 + ctext::linemapUpdate $self + } + + fastinsert { + eval \$self._t insert $args + ctext::modified $self 1 + ctext::linemapUpdate $self + } + + highlight { + ctext::highlight $self [lindex $args 0] [lindex $args 1] + ctext::comments $self + } + + insert { + if {[llength $args] < 2} { + return -code error "please use at least 2 arguments to $self insert" + } + set insertPos [lindex $args 0] + set prevChar [$self._t get "$insertPos - 1 chars"] + set nextChar [$self._t get $insertPos] + set lineStart [$self._t index "$insertPos linestart"] + set prevSpace [ctext::findPreviousSpace $self._t ${insertPos}-1c] + set data [lindex $args 1] + eval \$self._t insert $args + + set nextSpace [ctext::findNextSpace $self._t insert] + set lineEnd [$self._t index "insert lineend"] + + if {[$self._t compare $prevSpace < $lineStart]} { + set prevSpace $lineStart + } + + if {[$self._t compare $nextSpace > $lineEnd]} { + set nextSpace $lineEnd + } + + foreach tag [$self._t tag names] { + if {[string equal $tag "_cComment"] != 1} { + $self._t tag remove $tag $prevSpace $nextSpace + } + } + + set REData $prevChar + append REData $data + append REData $nextChar + if {[regexp $commentRE $REData]} { + after idle [list ctext::comments $self] + } + + after idle [list ctext::highlight $self $lineStart $lineEnd] + switch -- $data { + "\}" { + ctext::matchPair $self "\\\{" "\\\}" "\\" + } + "\]" { + ctext::matchPair $self "\\\[" "\\\]" "\\" + } + "\)" { + ctext::matchPair $self "\\(" "\\)" "" + } + "\"" { + ctext::matchQuote $self + } + } + ctext::modified $self 1 + ctext::linemapUpdate $self + } + + paste { + tk_textPaste $self + ctext::modified $self 1 + } + + edit { + set subCmd [lindex $args 0] + set argsLength [llength $args] + + ctext::getAr $self config ar + + if {"modified" == $subCmd} { + if {$argsLength == 1} { + return $ar(modified) + } elseif {$argsLength == 2} { + set value [lindex $args 1] + set ar(modified) $value + } else { + return -code error "invalid arg(s) to $self edit modified: $args" + } + } else { + #Tk 8.4 has other edit subcommands that I don't want to emulate. + return [uplevel 1 [linsert $args 0 $self._t $cmd]] + } + } + + default { + return [uplevel 1 [linsert $args 0 $self._t $cmd]] + } + } +} + +proc ctext::tag:blink {win count} { + if {$count & 1} { + $win tag configure __ctext_blink -foreground [$win cget -bg] -background [$win cget -fg] + } else { + $win tag configure __ctext_blink -foreground [$win cget -fg] -background [$win cget -bg] + } + + if {$count == 4} { + $win tag delete __ctext_blink 1.0 end + return + } + incr count + after 50 [list ctext::tag:blink $win $count] +} + +proc ctext::matchPair {win str1 str2 escape} { + set prevChar [$win get "insert - 2 chars"] + + if {[string equal $prevChar $escape]} { + #The char that we thought might be the end is actually escaped. + return + } + + set searchRE "[set str1]|[set str2]" + set count 1 + + set pos [$win index "insert - 1 chars"] + set endPair $pos + set lastFound "" + while 1 { + set found [$win search -backwards -regexp $searchRE $pos] + + if {$found == "" || [$win compare $found > $pos]} { + return + } + + if {$lastFound != "" && [$win compare $found == $lastFound]} { + #The search wrapped and found the previous search + return + } + + set lastFound $found + set char [$win get $found] + set prevChar [$win get "$found - 1 chars"] + set pos $found + + if {[string equal $prevChar $escape]} { + continue + } elseif {[string equal $char [subst $str2]]} { + incr count + } elseif {[string equal $char [subst $str1]]} { + incr count -1 + if {$count == 0} { + set startPair $found + break + } + } else { + #This shouldn't happen. I may in the future make it return -code error + puts stderr "ctext seems to have encountered a bug in ctext::matchPair" + return + } + } + + $win tag add __ctext_blink $startPair + $win tag add __ctext_blink $endPair + ctext::tag:blink $win 0 +} + +proc ctext::matchQuote {win} { + set endQuote [$win index insert] + set start [$win index "insert - 1 chars"] + + if {[$win get "$start - 1 chars"] == "\\"} { + #the quote really isn't the end + return + } + set lastFound "" + while 1 { + set startQuote [$win search -backwards \" $start] + if {$startQuote == "" || [$win compare $startQuote > $start]} { + #The search found nothing or it wrapped. + return + } + + if {$lastFound != "" && [$win compare $lastFound == $startQuote]} { + #We found the character we found before, so it wrapped. + return + } + set lastFound $startQuote + set start [$win index "$startQuote - 1 chars"] + set prevChar [$win get $start] + + if {$prevChar == "\\"} { + continue + } + break + } + + if {[$win compare $endQuote == $startQuote]} { + #probably just \" + return + } + + $win tag add __ctext_blink $startQuote $endQuote + ctext::tag:blink $win 0 +} + +proc ctext::enableComments {win} { + $win tag configure _cComment -foreground khaki +} +proc ctext::disableComments {win} { + catch {$win tag delete _cComment} +} + +proc ctext::comments {win} { + if {[catch {$win tag cget _cComment -foreground}]} { + #C comments are disabled + return + } + + set startIndex 1.0 + set commentRE {\\\\|\"|\\\"|\\'|'|/\*|\*/} + set commentStart 0 + set isQuote 0 + set isSingleQuote 0 + set isComment 0 + $win tag remove _cComment 1.0 end + while 1 { + set index [$win search -count length -regexp $commentRE $startIndex end] + + if {$index == ""} { + break + } + + set endIndex [$win index "$index + $length chars"] + set str [$win get $index $endIndex] + set startIndex $endIndex + + if {$str == "\\\\"} { + continue + } elseif {$str == "\\\""} { + continue + } elseif {$str == "\\'"} { + continue + } elseif {$str == "\"" && $isComment == 0 && $isSingleQuote == 0} { + if {$isQuote} { + set isQuote 0 + } else { + set isQuote 1 + } + } elseif {$str == "'" && $isComment == 0 && $isQuote == 0} { + if {$isSingleQuote} { + set isSingleQuote 0 + } else { + set isSingleQuote 1 + } + } elseif {$str == "/*" && $isQuote == 0 && $isSingleQuote == 0} { + if {$isComment} { + #comment in comment + break + } else { + set isComment 1 + set commentStart $index + } + } elseif {$str == "*/" && $isQuote == 0 && $isSingleQuote == 0} { + if {$isComment} { + set isComment 0 + $win tag add _cComment $commentStart $endIndex + $win tag raise _cComment + } else { + #comment end without beginning + break + } + } + } +} + +proc ctext::addHighlightClass {win class color keywords} { + set ref [ctext::getAr $win highlight ar] + foreach word $keywords { + set ar($word) [list $class $color] + } + $win tag configure $class + + ctext::getAr $win classes classesAr + set classesAr($class) [list $ref $keywords] +} + +#For [ ] { } # etc. +proc ctext::addHighlightClassForSpecialChars {win class color chars} { + set charList [split $chars ""] + + set ref [ctext::getAr $win highlightSpecialChars ar] + foreach char $charList { + set ar($char) [list $class $color] + } + $win tag configure $class + + ctext::getAr $win classes classesAr + set classesAr($class) [list $ref $charList] +} + +proc ctext::addHighlightClassForRegexp {win class color re} { + set ref [ctext::getAr $win highlightRegexp ar] + + set ar($class) [list $re $color] + $win tag configure $class + + ctext::getAr $win classes classesAr + set classesAr($class) [list $ref $class] +} + +#For things like $blah +proc ctext::addHighlightClassWithOnlyCharStart {win class color char} { + set ref [ctext::getAr $win highlightCharStart ar] + + set ar($char) [list $class $color] + $win tag configure $class + + ctext::getAr $win classes classesAr + set classesAr($class) [list $ref $char] +} + +proc ctext::deleteHighlightClass {win classToDelete} { + ctext::getAr $win classes classesAr + + if {![info exists classesAr($classToDelete)]} { + return -code error "$classToDelete doesn't exist" + } + + foreach {ref keyList} [set classesAr($classToDelete)] { + upvar #0 $ref refAr + foreach key $keyList { + if {![info exists refAr($key)]} { + continue + } + unset refAr($key) + } + } + unset classesAr($classToDelete) +} + +proc ctext::getHighlightClasses win { + ctext::getAr $win classes classesAr + + set res [list] + + foreach {class info} [array get classesAr] { + lappend res $class + } + return $res +} + +proc ctext::findNextChar {win index char} { + set i [$win index "$index + 1 chars"] + set lineend [$win index "$i lineend"] + while 1 { + set ch [$win get $i] + if {[$win compare $i >= $lineend]} { + return "" + } + if {$ch == $char} { + return $i + } + set i [$win index "$i + 1 chars"] + } +} + +proc ctext::findNextSpace {win index} { + set i [$win index $index] + set lineStart [$win index "$i linestart"] + set lineEnd [$win index "$i lineend"] + #Sometimes the lineend fails (I don't know why), so add 1 and try again. + if {[$win compare $lineEnd == $lineStart]} { + set lineEnd [$win index "$i + 1 chars lineend"] + } + + while {1} { + set ch [$win get $i] + + if {[$win compare $i >= $lineEnd]} { + set i $lineEnd + break + } + + if {[string is space $ch]} { + break + } + set i [$win index "$i + 1 chars"] + } + return $i +} + +proc ctext::findPreviousSpace {win index} { + set i [$win index $index] + set lineStart [$win index "$i linestart"] + while {1} { + set ch [$win get $i] + + if {[$win compare $i <= $lineStart]} { + set i $lineStart + break + } + + if {[string is space $ch]} { + break + } + + set i [$win index "$i - 1 chars"] + } + return $i +} + +proc ctext::clearHighlightClasses {win} { + #no need to catch, because array unset doesn't complain + #puts [array exists ::ctext::highlight$win] + + ctext::getAr $win highlight ar + array unset ar + + ctext::getAr $win highlightSpecialChars ar + array unset ar + + ctext::getAr $win highlightRegexp ar + array unset ar + + ctext::getAr $win highlightCharStart ar + array unset ar + + ctext::getAr $win classes ar + array unset ar +} + +#This is a proc designed to be overwritten by the user. +#It can be used to update a cursor or animation while +#the text is being highlighted. +proc ctext::update {} { + +} + +proc ctext::highlight {win start end} { + ctext::getAr $win config configAr + + if {!$configAr(-highlight)} { + return + } + + set si $start + set twin "$win._t" + + #The number of times the loop has run. + set numTimesLooped 0 + set numUntilUpdate 600 + + ctext::getAr $win highlight highlightAr + ctext::getAr $win highlightSpecialChars highlightSpecialCharsAr + ctext::getAr $win highlightRegexp highlightRegexpAr + ctext::getAr $win highlightCharStart highlightCharStartAr + + while 1 { + set res [$twin search -count length -regexp -- {([^\s\(\{\[\}\]\)\.\t\n\r;\"'\|,]+)} $si $end] + if {$res == ""} { + break + } + + set wordEnd [$twin index "$res + $length chars"] + set word [$twin get $res $wordEnd] + set firstOfWord [string index $word 0] + + if {[info exists highlightAr($word)] == 1} { + set wordAttributes [set highlightAr($word)] + foreach {tagClass color} $wordAttributes break + + $twin tag add $tagClass $res $wordEnd + $twin tag configure $tagClass -foreground $color + + } elseif {[info exists highlightCharStartAr($firstOfWord)] == 1} { + set wordAttributes [set highlightCharStartAr($firstOfWord)] + foreach {tagClass color} $wordAttributes break + + $twin tag add $tagClass $res $wordEnd + $twin tag configure $tagClass -foreground $color + } + set si $wordEnd + + incr numTimesLooped + if {$numTimesLooped >= $numUntilUpdate} { + ctext::update + set numTimesLooped 0 + } + } + + foreach {ichar tagInfo} [array get highlightSpecialCharsAr] { + set si $start + foreach {tagClass color} $tagInfo break + + while 1 { + set res [$twin search -- $ichar $si $end] + if {"" == $res} { + break + } + set wordEnd [$twin index "$res + 1 chars"] + + $twin tag add $tagClass $res $wordEnd + $twin tag configure $tagClass -foreground $color + set si $wordEnd + + incr numTimesLooped + if {$numTimesLooped >= $numUntilUpdate} { + ctext::update + set numTimesLooped 0 + } + } + } + + foreach {tagClass tagInfo} [array get highlightRegexpAr] { + set si $start + foreach {re color} $tagInfo break + while 1 { + set res [$twin search -count length -regexp -- $re $si $end] + if {"" == $res} { + break + } + + set wordEnd [$twin index "$res + $length chars"] + $twin tag add $tagClass $res $wordEnd + $twin tag configure $tagClass -foreground $color + set si $wordEnd + + incr numTimesLooped + if {$numTimesLooped >= $numUntilUpdate} { + ctext::update + set numTimesLooped 0 + } + } + } +} + +proc ctext::linemapToggleMark {win y} { + ctext::getAr $win config configAr + + if {!$configAr(-linemap_markable)} { + return + } + + set markChar [$win.l index @0,$y] + set lineSelected [lindex [split $markChar .] 0] + set line [$win.l get $lineSelected.0 $lineSelected.end] + + if {$line == ""} { + return + } + + ctext::getAr $win linemap linemapAr + + if {[info exists linemapAr($line)] == 1} { + #It's already marked, so unmark it. + array unset linemapAr $line + ctext::linemapUpdate $win + set type unmarked + } else { + #This means that the line isn't toggled, so toggle it. + array set linemapAr [list $line {}] + $win.l tag add lmark $markChar [$win.l index "$markChar lineend"] + $win.l tag configure lmark -foreground $configAr(-linemap_select_fg) \ +-background $configAr(-linemap_select_bg) + set type marked + } + + if {[string length $configAr(-linemap_mark_command)]} { + uplevel #0 [linsert $configAr(-linemap_mark_command) end $win $type $line] + } +} + +#args is here because -yscrollcommand may call it +proc ctext::linemapUpdate {win args} { + if {[winfo exists $win.l] != 1} { + return + } + + set pixel 0 + set lastLine {} + set lineList [list] + set fontMetrics [font metrics [$win._t cget -font]] + set incrBy [expr {1 + ([lindex $fontMetrics 5] / 2)}] + + while {$pixel < [winfo height $win.l]} { + set idx [$win._t index @0,$pixel] + + if {$idx != $lastLine} { + set line [lindex [split $idx .] 0] + set lastLine $idx + $win.l config -width [string length $line] + lappend lineList $line + } + incr pixel $incrBy + } + + ctext::getAr $win linemap linemapAr + + $win.l delete 1.0 end + set lastLine {} + foreach line $lineList { + if {$line == $lastLine} { + $win.l insert end "\n" + } else { + if {[info exists linemapAr($line)]} { + $win.l insert end "$line\n" lmark + } else { + $win.l insert end "$line\n" + } + } + set lastLine $line + } +} + +proc ctext::modified {win value} { + ctext::getAr $win config ar + set ar(modified) $value + event generate $win <> + return $value +} diff --git a/modules/ctext/ctext_scroll_test.tcl b/modules/ctext/ctext_scroll_test.tcl new file mode 100644 index 00000000..e3dbc3c4 --- /dev/null +++ b/modules/ctext/ctext_scroll_test.tcl @@ -0,0 +1,11 @@ + +source ./ctext.tcl + +scrollbar .y -orient vertical -command {.t yview} +ctext .t -xscrollcommand {.x set} -yscrollcommand {.y set} -wrap none +scrollbar .x -orient horizontal -command {.t xview} + + +grid .y -sticky ns +grid .t -row 0 -column 1 +grid .x -column 1 -sticky we diff --git a/modules/ctext/ctext_test.tcl b/modules/ctext/ctext_test.tcl new file mode 100755 index 00000000..944a716e --- /dev/null +++ b/modules/ctext/ctext_test.tcl @@ -0,0 +1,82 @@ +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" ${1+"$@"} + +#set tcl_traceExec 1 + +proc main {} { + source ./ctext.tcl + + pack [frame .f] -fill both -expand 1 + #Of course this could be cscrollbar instead, but it's not as common. + pack [scrollbar .f.s -command {.f.t yview}] -side right -fill y + + #Dark colors + pack [ctext .f.t -linemap 1 -bg black -fg white -insertbackground yellow \ + -yscrollcommand {.f.s set}] -fill both -expand 1 + + ctext::addHighlightClass .f.t widgets purple [list obutton button label text frame toplevel \ + cscrollbar scrollbar checkbutton canvas listbox menu menubar menubutton \ + radiobutton scale entry message tk_chooseDir tk_getSaveFile \ + tk_getOpenFile tk_chooseColor tk_optionMenu] + + ctext::addHighlightClass .f.t flags orange [list -text -command -yscrollcommand \ + -xscrollcommand -background -foreground -fg -bg \ + -highlightbackground -y -x -highlightcolor -relief -width \ + -height -wrap -font -fill -side -outline -style -insertwidth \ + -textvariable -activebackground -activeforeground -insertbackground \ + -anchor -orient -troughcolor -nonewline -expand -type -message \ + -title -offset -in -after -yscroll -xscroll -forward -regexp -count \ + -exact -padx -ipadx -filetypes -all -from -to -label -value -variable \ + -regexp -backwards -forwards -bd -pady -ipady -state -row -column \ + -cursor -highlightcolors -linemap -menu -tearoff -displayof -cursor \ + -underline -tags -tag] + + ctext::addHighlightClass .f.t stackControl red {proc uplevel namespace while for foreach if else} + ctext::addHighlightClassWithOnlyCharStart .f.t vars mediumspringgreen "\$" + ctext::addHighlightClass .f.t htmlText yellow " " + ctext::addHighlightClass .f.t variable_funcs gold {set global variable unset} + ctext::addHighlightClassForSpecialChars .f.t brackets green {[]{}} + ctext::addHighlightClassForRegexp .f.t paths lightblue {\.[a-zA-Z0-9\_\-]+} + ctext::addHighlightClassForRegexp .f.t comments khaki {#[^\n\r]*} + #After overloading, insertion is a little slower with the + #regular insert, so use fastinsert. + #set fi [open Ctext_Bug_Crasher.tcl r] + set fi [open long_test_script r] + .f.t fastinsert end [read $fi] + close $fi + + pack [frame .f1] -fill x + + pack [button .f1.append -text Append -command {.f.t append}] -side left + pack [button .f1.cut -text Cut -command {.f.t cut}] -side left + pack [button .f1.copy -text Copy -command {.f.t copy}] -side left + pack [button .f1.paste -text Paste -command {.f.t paste}] -side left + .f.t highlight 1.0 end + pack [button .f1.test -text {Remove all Tags and Highlight} \ + -command {puts [time { + foreach tag [.f.t tag names] { + .f.t tag remove $tag 1.0 end + } + update idletasks + .f.t highlight 1.0 end + }] + } + ] -side left + pack [button .f1.fastdel -text {Fast Delete} -command {.f.t fastdelete 1.0 end}] -side left + + pack [frame .f2] -fill x + pack [button .f2.test2 -text {Scrollbar Command {}} -command {.f.t config -yscrollcommand {}}] -side left + pack [button .f2.cl -text {Clear Classes} -command {ctext::clearHighlightClasses .f.t}] -side left + pack [button .f2.des -text Destroy -command {destroy .f.t}] -side left + pack [button .f2.editModSet0 -text "Set Modified 0" -command {puts [.f.t edit modified 0]}] -side left + pack [button .f2.editModGet -text "Print Modified" -command {puts [.f.t edit modified]}] -side left + + pack [button .f2.exit -text Exit -command exit] -side left + + puts [.f.t cget -linemap] + puts [.f.t cget -linemapfg] + puts [.f.t cget -linemapbg] + puts [.f.t cget -bg] +} +main diff --git a/modules/ctext/ctext_test_c.tcl b/modules/ctext/ctext_test_c.tcl new file mode 100755 index 00000000..744c0479 --- /dev/null +++ b/modules/ctext/ctext_test_c.tcl @@ -0,0 +1,70 @@ +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" ${1+"$@"} + +#use :: so I don't forget it's global +#set ::tcl_traceExec 1 + +proc highlight:addClasses {win} { + ctext::addHighlightClassForSpecialChars $win brackets green {[]} + ctext::addHighlightClassForSpecialChars $win braces lawngreen {{}} + ctext::addHighlightClassForSpecialChars $win parentheses palegreen {()} + ctext::addHighlightClassForSpecialChars $win quotes "#c65e3c" {"'} + + ctext::addHighlightClass $win control red [list namespace while for if else do switch case] + + ctext::addHighlightClass $win types purple [list \ + int char u_char u_int long double float typedef unsigned signed] + + ctext::addHighlightClass $win macros mediumslateblue [list \ + #define #undef #if #ifdef #ifndef #endif #elseif #include #import #exclude] + + ctext::addHighlightClassForSpecialChars $win math cyan {+=*-/&^%!|<>} +} + +proc main {} { + source ./ctext.tcl + + pack [frame .f] -fill both -expand 1 + #Of course this could be cscrollbar instead, but it's not as common. + pack [scrollbar .f.s -command ".f.t yview"] -side right -fill y + + #Dark colors + pack [ctext .f.t -linemap 1 \ + -bg black -fg white -insertbackground yellow \ + -yscrollcommand ".f.s set"] -fill both -expand 1 + + highlight:addClasses .f.t + ctext::enableComments .f.t + + set fi [open test.c r] + .f.t fastinsert end [read $fi] + close $fi + + pack [button .append -text Append -command {.f.t append}] -side left + pack [button .cut -text Cut -command {.f.t cut}] -side left + pack [button .copy -text Copy -command {.f.t copy}] -side left + pack [button .paste -text Paste -command {.f.t paste}] -side left + .f.t highlight 1.0 end + pack [button .test -text {Remove all Tags and Highlight} \ + -command {puts [time { + foreach tag [.f.t tag names] { + .f.t tag remove $tag 1.0 end + } + update idletasks + .f.t highlight 1.0 end + }] + } + ] -side left + pack [button .test2 -text {Scrollbar Command {}} -command {.f.t config -yscrollcommand {}}] -side left + pack [button .cl -text {Clear Classes} \ + -command {ctext::clearHighlightClasses .f.t}] -side left + pack [button .exit -text Exit -command exit] -side left + #pack [ctext .ct2 -linemap 1] -side bottom + + #update + #console show + #puts [.f.t cget -linemap] + #puts [.f.t cget -bg] +} +main diff --git a/modules/ctext/ctext_test_interactive.tcl b/modules/ctext/ctext_test_interactive.tcl new file mode 100755 index 00000000..ad48a5ac --- /dev/null +++ b/modules/ctext/ctext_test_interactive.tcl @@ -0,0 +1,89 @@ +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" ${1+"$@"} + +#set tcl_traceExec 1 +proc linemap_mark_cmd {win type line} { + puts "line $line was $type in $win" +} + +proc main {} { + source ./ctext.tcl + + pack [frame .f] -fill both -expand 1 + #Of course this could be cscrollbar instead, but it's not as common. + pack [scrollbar .f.s -command {.f.t yview}] -side right -fill y + + #Dark colors + pack [ctext .f.t -bg black -fg white -insertbackground yellow \ + -yscrollcommand {.f.s set} -linemap_mark_command linemap_mark_cmd] -fill both -expand 1 + + ctext::addHighlightClass .f.t widgets purple [list obutton button label text frame toplevel \ + cscrollbar scrollbar checkbutton canvas listbox menu menubar menubutton \ + radiobutton scale entry message tk_chooseDir tk_getSaveFile \ + tk_getOpenFile tk_chooseColor tk_optionMenu] + + ctext::addHighlightClass .f.t flags orange [list -text -command -yscrollcommand \ + -xscrollcommand -background -foreground -fg -bg \ + -highlightbackground -y -x -highlightcolor -relief -width \ + -height -wrap -font -fill -side -outline -style -insertwidth \ + -textvariable -activebackground -activeforeground -insertbackground \ + -anchor -orient -troughcolor -nonewline -expand -type -message \ + -title -offset -in -after -yscroll -xscroll -forward -regexp -count \ + -exact -padx -ipadx -filetypes -all -from -to -label -value -variable \ + -regexp -backwards -forwards -bd -pady -ipady -state -row -column \ + -cursor -highlightcolors -linemap -menu -tearoff -displayof -cursor \ + -underline -tags -tag] + + ctext::addHighlightClass .f.t stackControl red {proc uplevel namespace while for foreach if else} + ctext::addHighlightClassWithOnlyCharStart .f.t vars mediumspringgreen "\$" + ctext::addHighlightClass .f.t htmlText yellow " " + ctext::addHighlightClass .f.t variable_funcs gold {set global variable unset} + ctext::addHighlightClassForSpecialChars .f.t brackets green {[]{}} + ctext::addHighlightClassForRegexp .f.t paths lightblue {\.[a-zA-Z0-9\_\-]+} + ctext::addHighlightClassForRegexp .f.t comments khaki {#[^\n\r]*} + #After overloading, insertion is a little slower with the + #regular insert, so use fastinsert. + #set fi [open Ctext_Bug_Crasher.tcl r] + set fi [open long_test_script r] + .f.t fastinsert end [read $fi] + close $fi + + pack [frame .f1] -fill x + + pack [button .f1.append -text Append -command {.f.t append}] -side left + pack [button .f1.cut -text Cut -command {.f.t cut}] -side left + pack [button .f1.copy -text Copy -command {.f.t copy}] -side left + pack [button .f1.paste -text Paste -command {.f.t paste}] -side left + .f.t highlight 1.0 end + pack [button .f1.test -text {Remove all Tags and Highlight} \ + -command {puts [time { + foreach tag [.f.t tag names] { + .f.t tag remove $tag 1.0 end + } + update idletasks + .f.t highlight 1.0 end + }] + } + ] -side left + pack [button .f1.fastdel -text {Fast Delete} -command {.f.t fastdelete 1.0 end}] -side left + + pack [frame .f2] -fill x + pack [button .f2.test2 -text {Scrollbar Command {}} -command {.f.t config -yscrollcommand {}}] -side left + pack [button .f2.cl -text {Clear Classes} -command {ctext::clearHighlightClasses .f.t}] -side left + pack [button .f2.des -text Destroy -command {destroy .f.t}] -side left + pack [button .f2.editModSet0 -text "Set Modified 0" -command {puts [.f.t edit modified 0]}] -side left + pack [button .f2.editModGet -text "Print Modified" -command {puts [.f.t edit modified]}] -side left + + pack [button .f2.exit -text Exit -command exit] -side left + + pack [entry .e] -side bottom -fill x + .e insert end "ctext::deleteHighlightClass .f.t " + bind .e {puts [eval [.e get]]} + + puts [.f.t cget -linemap] + puts [.f.t cget -linemapfg] + puts [.f.t cget -linemapbg] + puts [.f.t cget -bg] +} +main diff --git a/modules/ctext/ctext_test_ws.tcl b/modules/ctext/ctext_test_ws.tcl new file mode 100644 index 00000000..60e75c49 --- /dev/null +++ b/modules/ctext/ctext_test_ws.tcl @@ -0,0 +1,9 @@ + +source ./ctext.tcl +pack [ctext {.t blah}] + +ctext::addHighlightClass {.t blah} c blue [list bat ball boot cat hat] +ctext::addHighlightClass {.t blah} c2 red [list bozo bull bongo] +{.t blah} highlight 1.0 end + + diff --git a/modules/ctext/function_finder.tcl b/modules/ctext/function_finder.tcl new file mode 100755 index 00000000..0cf85fd1 --- /dev/null +++ b/modules/ctext/function_finder.tcl @@ -0,0 +1,45 @@ +#!/bin/tclsh8.3 + +proc main {argc argv} { + + array set functions "" + + foreach f $argv { + puts stderr "PROCESSING FILE $f" + + catch {exec cc -DNeedFunctionPrototypes -E $f} data + #set functionList [regexp -all -inline {[a-zA-Z0-9_-]+[ \t\n\r]+([a-zA-Z0-9_-]+)[ \t\n\r]+\([ \t\n\r]*([^\)]+)[ \t\n\r]*\)[ \t\n\r]*;} $data] + set functionList [regexp -all -inline {[a-zA-Z0-9_\-\*]+[ \t\n\r\*]+([a-zA-Z0-9_\-\*]+)[ \t\n\r]*\(([^\)]*)\)[ \t\n\r]*;} $data] + set functionList [concat $functionList \ + [regexp -all -inline {[a-zA-Z0-9_\-\*]+[ \t\n\r\*]+([a-zA-Z0-9_\-\*]+)[ \t\n\r]*_ANSI_ARGS_\(\(([^\)]*)\)\)[ \t\n\r]*;} $data]] + #puts "FL $functionList" + foreach {junk function args} $functionList { + #puts "FUNC $function ARGS $args" + set args [string map {"\n" "" "\r" "" "\t" " " "," ", "} $args] + regsub -all {\s{2,}} $args " " args + set functions($function) $args + } + } + + puts "array set ::functions \{" + foreach function [lsort -dictionary [array names functions]] { + if {"_" == [string index $function 0] || "_" == [string index $function end]} { + continue + } + puts "\t$function [list [set functions($function)]]" + } + puts "\}" +} + +proc sglob {pattern} { + return [glob -nocomplain $pattern] +} + +#main $argc /usr/local/include/tclDecls.h +#return + +main $argc [concat [sglob /usr/include/*.h] [sglob /usr/include/*/*.h] \ +[sglob /usr/local/include/*.h] [sglob /usr/local/include/*/*.h] \ +[sglob /usr/X11R6/include/*.h] [sglob /usr/X11R6/include/*/*.h] \ +[sglob /usr/X11R6/include/*/*/*.h] [sglob /usr/local/include/X11/*.h] \ +[sglob /usr/local/include/X11/*/*.h]] diff --git a/modules/ctext/install.tcl b/modules/ctext/install.tcl new file mode 100755 index 00000000..5cf6765e --- /dev/null +++ b/modules/ctext/install.tcl @@ -0,0 +1,57 @@ +#Run this with the wish (Tk shell) that you want to install for. +#For example: $ wish8.4 install.tcl + +proc event.select.install.path win { + set i [$win curselection] + set ::installPath [$win get $i] +} + +proc install {} { + set idir [file join $::installPath ctext] + file mkdir $idir + file copy -force pkgIndex.tcl $idir + file copy -force ctext.tcl $idir + tk_messageBox -icon info -message "Successfully installed into $idir" \ +-title {Install Successful} -type ok + + exit +} + +proc main {} { + option add *foreground black + option add *background gray65 + . config -bg gray65 + + wm title . {Ctext Installer} + label .title -text {Welcome to the Ctext installer} -font {Helvetica 14} + + message .msgauto -aspect 300 -text {The auto_path directories are automatically searched by Tcl/Tk for packages. You may select a directory to install Ctext into, or type in a new directory. Your auto_path directories are:} + + set autoLen [llength $::auto_path] + listbox .listauto -height $autoLen + + for {set i 0} {$i < $autoLen} {incr i} { + .listauto insert end [lindex $::auto_path $i] + } + + bind .listauto <> [list event.select.install.path %W] + + label .lipath -text {Install Path:} + set ::installPath [lindex $::auto_path end] + entry .installPath -textvariable ::installPath + + frame .fcontrol + frame .fcontrol.finst -relief sunken -bd 1 + pack [button .fcontrol.finst.install -text Install -command install] -padx 4 -pady 4 + button .fcontrol.cancel -text Cancel -command exit + pack .fcontrol.finst -side left -padx 5 + pack .fcontrol.cancel -side right -padx 5 + + pack .title -fill x + pack .msgauto -anchor w + pack .listauto -fill both -expand 1 + pack .lipath -anchor w + pack .installPath -fill x + pack .fcontrol -pady 10 +} +main diff --git a/modules/ctext/long_test_script b/modules/ctext/long_test_script new file mode 100644 index 00000000..1575134c --- /dev/null +++ b/modules/ctext/long_test_script @@ -0,0 +1,672 @@ +#By George Peter Staplin + +namespace eval cscrollbar { + variable buttonPressed 0 + variable lastX 0 + variable lastY 0 + +variable up_xbm { +#define up_width 18 +#define up_height 12 +static unsigned char up_bits[] = { + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x03, 0x00, 0x80, 0x07, 0x00, + 0xc0, 0x0f, 0x00, 0xe0, 0x1f, 0x00, 0xf0, 0x3f, 0x00, 0xf8, 0x7f, 0x00, + 0xfc, 0xff, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; +} + +variable down_xbm { +#define down_width 18 +#define down_height 12 +static char down_bits[] = { + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0xff, 0x00, + 0xf8, 0x7f, 0x00, 0xf0, 0x3f, 0x00, 0xe0, 0x1f, 0x00, 0xc0, 0x0f, 0x00, + 0x80, 0x07, 0x00, 0x00, 0x03, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 }; +} + +variable left_xbm { +#define left_width 12 +#define left_height 18 +static char left_bits[] = { + 0x00, 0x00, 0x00, 0x00, 0x00, 0x01, 0x80, 0x01, 0xc0, 0x01, 0xe0, 0x01, + 0xf0, 0x01, 0xf8, 0x01, 0xfc, 0x01, 0xfc, 0x01, 0xf8, 0x01, 0xf0, 0x01, + 0xe0, 0x01, 0xc0, 0x01, 0x80, 0x01, 0x00, 0x01, 0x00, 0x00, 0x00, 0x00 }; +} + +variable right_xbm { +#define right_width 12 +#define right_height 18 +static char right_bits[] = { + 0x00, 0x00, 0x00, 0x00, 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, + 0xf8, 0x00, 0xf8, 0x01, 0xf8, 0x03, 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, + 0x78, 0x00, 0x38, 0x00, 0x18, 0x00, 0x08, 0x00, 0x00, 0x00, 0x00, 0x00 }; +} +} + +#This creates the scrollbar and an instance command for it. +#cmdArgs represents the initial arguments. cmdArgs becomes smaller +#gradually as options/flags are processed, and if it contains +#anything else afterward an error is reported. + +proc cscrollbar {win args} { + + if {[expr {[llength $args] & 1}] != 0} { + return -code error "Invalid number of arguments given to cscrollbar\ +(uneven number): $args" + } + + frame $win -class Cscrollbar + upvar #0 _cscrollbar$win ar + button .__temp + set cmdArgs(-orient) vertical + + set cmdArgs(-bg) [option get $win background Color1] + if {$cmdArgs(-bg) == ""} { + set cmdArgs(-bg) [.__temp cget -bg] + } + + set cmdArgs(-fg) [option get $win foreground Color1] + if {$cmdArgs(-fg) == ""} { + set cmdArgs(-fg) [.__temp cget -fg] + } + + set cmdArgs(-slidercolor) [option get $win sliderColor Color1] + if {$cmdArgs(-slidercolor) == ""} { + set cmdArgs(-slidercolor) blue + } + + set cmdArgs(-gradient1) [option get $win gradient1 Color1] + if {$cmdArgs(-gradient1) == ""} { + set cmdArgs(-gradient1) royalblue3 + } + + set cmdArgs(-gradient2) [option get $win gradient2 Color1] + if {$cmdArgs(-gradient2) == ""} { + set cmdArgs(-gradient2) gray90 + } + + + set ar(sliderPressed) 0 + destroy .__temp + + array set cmdArgs $args + array set ar [array get cmdArgs] + + unset cmdArgs(-slidercolor) + unset cmdArgs(-gradient1) + unset cmdArgs(-gradient2) + + #synonym flags + foreach long {background foreground} short {bg fg} { + if {[info exists cmdArgs(-$long)] == 1} { + set cmdArgs(-$short) $cmdArgs(-$long) + unset cmdArgs(-long) + } + } + + if {$cmdArgs(-orient) == "vertical"} { + cscrollbar::createVertical $win $cmdArgs(-bg) $cmdArgs(-fg) + } elseif {$cmdArgs(-orient) == "horizontal"} { + cscrollbar::createHorizontal $win $cmdArgs(-bg) $cmdArgs(-fg) + } else { + return -code error {Invalid -orient option -- use vertical or horizontal} + } + + unset cmdArgs(-orient) + unset cmdArgs(-fg) + unset cmdArgs(-bg) + + if {[info exists cmdArgs(-command)] == 1} { + bind $win.1 "set cscrollbar::buttonPressed 1; cscrollbar::moveUnit {$cmdArgs(-command)} -1 %W" + bind $win.1 "set cscrollbar::buttonPressed 0; cscrollbar::moveUnit {$cmdArgs(-command)} -1 %W" + bind $win.c "cscrollbar::sliderNotPressed $win" + bind $win.2 "set cscrollbar::buttonPressed 1; cscrollbar::moveUnit {$cmdArgs(-command)} 1 %W" + bind $win.2 "set cscrollbar::buttonPressed 0; cscrollbar::moveUnit {$cmdArgs(-command)} 1 %W" + + bind $win.3 "set cscrollbar::buttonPressed 1; cscrollbar::moveUnit {$cmdArgs(-command)} -1 %W" + bind $win.3 "set cscrollbar::buttonPressed 0; cscrollbar::moveUnit {$cmdArgs(-command)} -1 %W" + bind $win.4 "set cscrollbar::buttonPressed 1; cscrollbar::moveUnit {$cmdArgs(-command)} 1 %W" + bind $win.4 "set cscrollbar::buttonPressed 0; cscrollbar::moveUnit {$cmdArgs(-command)} 1 %W" + + + bind $win "after idle [list cscrollbar::updateView $win]" + unset cmdArgs(-command) + } + + + if {[llength [array names cmdArgs]] != 0} { + return -code error "Invalid argument sent to cscrollbar: [array get cmdArgs]" + } + + rename $win _cscrollbarJunk$win + + bind $win "rename $win {};" + + proc $win {cmd args} "eval cscrollbar::instanceCmd $win \$cmd \$args" + return $win +} + +proc cscrollbar::updateView {win} { + upvar #0 _cscrollbar$win ar + if {[catch $ar(-command) res] && $res != ""} { + $win set 0 1 + } +} + +proc cscrollbar::instanceCmd {self cmd args} { + upvar #0 _cscrollbar$self ar + + switch -glob -- $cmd { + cget { + if {[info exists ar($args)] == 1} { + return $ar($args) + } else { + return -code error "unknown argument(s) to cget: $args" + } + } + + conf* { + if {[llength $args] == 0} { + foreach name [array names ar -*] { + append res "{$name $ar($name)} " + } + + return $res + } + + array set cmdArgs $args + + foreach long {background foreground} short {bg fg} { + if {[info exists cmdArgs(-$long)] == 1} { + set cmdArgs(-$short) $cmdArgs(-$long) + unset cmdArgs(-$long) + } + } + + if {[info exists cmdArgs(-gradient1)] == 1} { + set ar(-gradient1) $cmdArgs(-gradient1) + event generate $self + } + + if {[info exists cmdArgs(-gradient2)] == 2} { + set ar(-gradient2) $cmdArgs(-gradient2) + event generate $self + } + + if {[info exists cmdArgs(-bg)] == 1} { + set ar(-bg) $cmdArgs(-bg) + $self.1 config -bg $ar(-bg) + $self.c config -bg $ar(-bg) + $self.2 config -bg $ar(-bg) + + if {$ar(-orient) == "vertical"} { + $ar(upImage) config -background $ar(-bg) + $ar(upDisabledImage) config -background $ar(-bg) + $ar(downImage) config -background $ar(-bg) + $ar(downDisabledImage) config -background $ar(-bg) + } + + if {$ar(-orient) == "horizontal"} { + $ar(leftImage) config -background $ar(-bg) + $ar(leftDisabledImage) config -background $ar(-bg) + $ar(rightImage) config -background $ar(-bg) + $ar(rightDisabledImage) config -background $ar(-bg) + } + unset cmdArgs(-bg) + } + + if {[info exists cmdArgs(-fg)] == 1} { + set ar(-fg) $cmdArgs(-fg) + $self.1 config -fg $ar(-fg) + $self.2 config -fg $ar(-fg) + $self.3 config -fg $ar(-fg) + $self.4 config -fg $ar(-fg) + + if {$ar(-orient) == "vertical"} { + $ar(upImage) config -foreground $ar(-fg) + $ar(downImage) config -foreground $ar(-fg) + } + + if {$ar(-orient) == "horizontal"} { + $ar(leftImage) config -foreground $ar(-fg) + $ar(rightImage) config -foreground $ar(-fg) + } + unset cmdArgs(-fg) + } + + if {[info exists cmdArgs(-slidercolor)] == 1} { + set ar(-slidercolor) $cmdArgs(-slidercolor) + $self.c itemconfigure slider -fill $ar(-slidercolor) + unset cmdArgs(-slidercolor) + } + + if {[info exists cmdArgs(-command)] == 1} { + set ar(-command) $cmdArgs(-command) + bind $self.1 "set cscrollbar::buttonPressed 1; cscrollbar::moveUnit {$ar(-command)} -1 %W" + bind $self.1 "set cscrollbar::buttonPressed 0; cscrollbar::moveUnit {$ar(-command)} -1 %W" + bind $self.c "cscrollbar::sliderNotPressed $self" + bind $self.2 "set cscrollbar::buttonPressed 1; cscrollbar::moveUnit {$ar(-command)} 1 %W" + bind $self.2 "set cscrollbar::buttonPressed 0; cscrollbar::moveUnit {$ar(-command)} 1 %W" + + bind $self.3 "set cscrollbar::buttonPressed 1; cscrollbar::moveUnit {$ar(-command)} -1 %W" + bind $self.3 "set cscrollbar::buttonPressed 0; cscrollbar::moveUnit {$ar(-command)} -1 %W" + bind $self.4 "set cscrollbar::buttonPressed 1; cscrollbar::moveUnit {$ar(-command)} 1 %W" + bind $self.4 "set cscrollbar::buttonPressed 0; cscrollbar::moveUnit {$ar(-command)} 1 %W" + + bind $self " + if {\[catch {$ar(-command)} res\] == 0 && \$res != \"\"} { + $self set \$res + } + " + unset cmdArgs(-command) + } + + set res [llength [array names cmdArgs]] + if {$res != 0} { + return -code error "The following options were not recognized\ +by cscrollbar: [array get cmdArgs]" + } + } + + set { + set start [lindex $args 0] + set end [lindex $args 1] + + #somehow this becomes a list when I don't want it to be. + if {$end == ""} { + set end [lindex $start 1] + set start [lindex $start 0] + } + + if {$end <= 0} { + set end 1 + } + + update idletasks + + if {$ar(-orient) == "vertical"} { + if {$start == 0} { + $self.1 config -image $ar(upDisabledImage) + $self.3 config -image $ar(upDisabledImage) + } else { + $self.1 config -image $ar(upImage) + $self.3 config -image $ar(upImage) + } + + if {$end == 1} { + $self.2 config -image $ar(downDisabledImage) + $self.4 config -image $ar(downDisabledImage) + } else { + $self.2 config -image $ar(downImage) + $self.4 config -image $ar(downImage) + } + + if {$ar(sliderPressed) == 1} { + return + } + + #-2 is done for the border + set areaHeight [expr {([winfo height $self.c] - 2)}] + set startPos [expr {$start * $areaHeight}] + set endPos [expr {$end * $areaHeight}] + + if {$endPos <= 0} { + set endPos $areaHeight + } + + $self.c coords slider 0 $startPos [winfo width $self.c] $endPos + } + if {$ar(-orient) == "horizontal"} { + if {$start == 0} { + $self.1 config -image $ar(leftDisabledImage) + $self.3 config -image $ar(leftDisabledImage) + } else { + $self.1 config -image $ar(leftImage) + $self.3 config -image $ar(leftImage) + } + if {$end == 1} { + $self.2 config -image $ar(rightDisabledImage) + $self.4 config -image $ar(rightDisabledImage) + } else { + $self.2 config -image $ar(rightImage) + $self.4 config -image $ar(rightImage) + } + + if {$ar(sliderPressed) == 1} { + return + } + set areaWidth [expr {([winfo width $self.c] - 2)}] + set startPos [expr {$start * $areaWidth}] + set endPos [expr {$end * $areaWidth}] + + if {$endPos <= 0} { + set endPos $areaWidth + } + + $self.c coords slider $startPos 0 $endPos [winfo height $self.c] + } + } + + default { + #puts "$cmd $args" + } + } +} + +proc cscrollbar::createHorizontal {win bg fg} { + upvar #0 _cscrollbar$win ar + + set bd 1 + + set ar(leftImage) [image create bitmap -data $cscrollbar::left_xbm \ + -foreground $fg -background $bg] + set ar(leftDisabledImage) [image create bitmap -data $cscrollbar::left_xbm \ + -foreground gray50 -background $bg] + set ar(rightImage) [image create bitmap -data $cscrollbar::right_xbm \ + -foreground $fg -background $bg] + set ar(rightDisabledImage) [image create bitmap -data $cscrollbar::right_xbm \ + -foreground gray50 -background $bg] + + grid [label $win.1 -image $ar(leftDisabledImage) -relief raised -bg $bg -fg $fg -bd $bd] \ + -row 0 -column 0 -sticky w + + grid [label $win.2 -image $ar(rightDisabledImage) -relief raised -bg $bg -fg $fg -bd $bd] \ + -row 0 -column 1 -sticky w + + grid [canvas $win.c -relief flat -highlightthickness 0 \ + -height [winfo reqheight $win.1] -width 10 -bg $bg] \ + -row 0 -column 2 -sticky ew + + grid columnconfigure $win 2 -weight 1 + + grid [label $win.3 -image $ar(leftDisabledImage) -relief raised -bg $bg -fg $fg -bd $bd] \ + -row 0 -column 3 -sticky e + + grid [label $win.4 -image $ar(rightDisabledImage) -relief raised -bg $bg -fg $fg -bd $bd] \ + -row 0 -column 4 -sticky e + + cscrollbar::drawSlider $win 0 0 1 1 horizontal + + $win.c bind slider "cscrollbar::moveSlider $win horizontal %x" + $win.c bind slider " + set cscrollbar::lastX \[$win.c canvasx %x\] + set cscrollbar::lastY \[$win.c canvasy %y\] + " + bind $win.c "cscrollbar::drawBackground $win horizontal" +} + + +proc cscrollbar::createVertical {win bg fg} { + upvar #0 _cscrollbar$win ar + + set bd 1 + + set ar(upImage) [image create bitmap -data $cscrollbar::up_xbm \ + -foreground $fg -background $bg] + set ar(upDisabledImage) [image create bitmap -data $cscrollbar::up_xbm \ + -foreground gray50 -background $bg] + set ar(downImage) [image create bitmap -data $cscrollbar::down_xbm \ + -foreground $fg -background $bg] + set ar(downDisabledImage) [image create bitmap -data $cscrollbar::down_xbm \ + -foreground gray50 -background $bg] + + grid [label $win.1 -image $ar(upDisabledImage) -relief raised -bg $bg -fg $fg -bd $bd] \ + -row 0 -column 0 -sticky n + + grid [label $win.2 -image $ar(downDisabledImage) -relief raised -bg $bg -fg $fg -bd $bd] \ + -row 1 -column 0 -sticky n + + grid [canvas $win.c -relief flat -highlightthickness 0 \ + -width [winfo reqwidth $win.1] -height 10 -bg $bg] \ + -row 2 -column 0 -sticky ns + + grid rowconfigure $win 2 -weight 1 + grid [label $win.3 -image $ar(upDisabledImage) -relief raised -bg $bg -fg $fg -bd $bd] \ + -row 3 -column 0 -sticky s + grid [label $win.4 -image $ar(downDisabledImage) -relief raised -bg $bg -fg $fg -bd $bd] \ + -row 4 -column 0 -sticky s + + + cscrollbar::drawSlider $win 0 0 1 1 vertical + + $win.c bind slider "cscrollbar::moveSlider $win vertical %y" + $win.c bind slider " + set cscrollbar::lastX \[$win.c canvasx %x\] + set cscrollbar::lastY \[$win.c canvasy %y\] + " + bind $win.c "cscrollbar::drawBackground $win vertical" +} + + +#Based on Richard Suchenwirth's gradient code from one of his train +#projects. +proc cscrollbar::drawBackground {win type} { + upvar #0 _cscrollbar$win ar + set canv $win.c + set x1 0 + set y1 0 + set x2 [expr {[winfo width $canv] + 8}] + set y2 [expr {[winfo height $canv] + 8}] + set c1 $ar(-gradient1) + set c2 $ar(-gradient2) + + $canv delete background + + foreach {r1 g1 b1} [winfo rgb $canv $c1] break + foreach {r2 g2 b2} [winfo rgb $canv $c2] break + set redDiff [expr {$r2 - $r1}] + set greenDiff [expr {$g2 - $g1}] + set blueDiff [expr {$b2 - $b1}] + switch $type { + horizontal { + set yDiff [expr {$y2 - $y1}] + set steps [expr {int(abs($yDiff))}] + if {$steps > 255} { + set steps 255 + } + for {set i 2} {$i < $steps} {incr i} { + set p [expr {double($i) / $steps}] + set y [expr {$y1 + $yDiff * $p}] + set r [expr {int($r1 + $redDiff * $p)}] + set g [expr {int($g1 + $greenDiff * $p)}] + set b [expr {int($b1 + $blueDiff * $p)}] + + set fillColor "#" + foreach color {r g b} { + set preColor [format "%2.2x" [set $color]] + set color [format "%2.2s" $preColor] + append fillColor $color + } + + $canv create rectangle $x1 $y $x2 $y2 -outline {} -tag background \ + -fill $fillColor + } + } + + vertical { + set xDiff [expr {$x2 - $x1}] + set steps [expr {int(abs($xDiff))}] + + if {$steps > 255} { + set steps 255 + } + for {set i 2} {$i < $steps} {incr i} { + set p [expr {double($i) / $steps}] + set x [expr {$x1 + $xDiff * $p}] + set r [expr {int($r1 + $redDiff * $p)}] + set g [expr {int($g1 + $greenDiff * $p)}] + set b [expr {int($b1 + $blueDiff * $p)}] + + set fillColor "#" + foreach color {r g b} { + set preColor [format "%2.2x" [set $color]] + set color [format "%2.2s" $preColor] + append fillColor $color + } + + $canv create rectangle $x $y1 $x2 $y2 -outline {} -tag background \ + -fill $fillColor + } + } + + default { + return -code error "unknown direction \"$type\": must be one of horizontal or vertical" + } + } + + $win.c bind background "cscrollbar::scrollPages $win $type %x %y" + $win.c lower background +} + + +proc cscrollbar::drawSlider {win x1 y1 x2 y2 type} { + upvar #0 _cscrollbar$win ar + + #update idletasks + $win.c delete slider + + if {$type == "vertical"} { + set canvasWidth [winfo width $win.c] + $win.c create rectangle 0 $y1 $canvasWidth $y2 \ + -fill $ar(-slidercolor) -outline "" -tag slider -stipple gray50 + return + } + + if {$type == "horizontal"} { + set canvasHeight [winfo height $win.c] + $win.c create rectangle $x1 0 $x2 $canvasHeight \ + -fill $ar(-slidercolor) -outline "" -tag slider -stipple gray50 + return + } +} + + +proc cscrollbar::moveSlider {win type position} { + variable lastX + variable lastY + upvar #0 _cscrollbar$win ar + + if {$type == "vertical"} { + #move the slider y values which are 1 and 3 in the coords list + set sliderStartY [lindex [$win.c coords slider] 1] + set sliderEndY [lindex [$win.c coords slider] 3] + set sliderHeight [expr {$sliderEndY - $sliderStartY}] + set areaHeight [expr {[winfo height $win.c] - 1}] + + + set newY [expr {$position - $lastY}] + set upBoundResult [expr {($sliderStartY + $newY) < 0}] + set downBoundResult [expr {($sliderEndY + $newY) > $areaHeight}] + + if {$upBoundResult != 1 && $downBoundResult != 1} { + $win.c move slider 0 $newY + set lastY $position + } elseif {$upBoundResult == 1} { + set lastY [expr {$lastY - $sliderStartY}] + $win.c move slider 0 [expr {-$sliderStartY}] + } elseif {$downBoundResult == 1} { + set amountToMove [expr {-$sliderStartY + ($areaHeight - $sliderHeight)}] + set lastY [expr {$lastY + $amountToMove}] + $win.c move slider 0 $amountToMove + } + + if {[info exists ar(-command)] == 1} { + set ar(sliderPressed) 1 + eval $ar(-command) moveto [expr {$sliderStartY / $areaHeight}] + } + return + } + + if {$type == "horizontal"} { + #move the slider x values which are 0 and 2 in the coords list + set sliderStartX [lindex [$win.c coords slider] 0] + set sliderEndX [lindex [$win.c coords slider] 2] + set sliderWidth [expr {$sliderEndX - $sliderStartX}] + set areaWidth [expr {[winfo width $win.c] - 1}] + + set newX [expr {$position - $lastX}] + set leftBoundResult [expr {($sliderStartX + $newX) < 0}] + set rightBoundResult [expr {($sliderEndX + $newX) > $areaWidth}] + + if {$leftBoundResult != 1 && $rightBoundResult != 1} { + $win.c move slider $newX 0 + set lastX $position + } elseif {$leftBoundResult == 1} { + set lastX [expr {$lastX - $sliderStartX}] + $win.c move slider [expr {-$sliderStartX}] 0 + } elseif {$rightBoundResult == 1} { + set amountToMove [expr {-$sliderStartX + ($areaWidth - $sliderWidth)}] + set lastX [expr {$lastX + $amountToMove}] + $win.c move slider $amountToMove 0 + } + + if {[info exists ar(-command)] == 1} { + set ar(sliderPressed) 1 + eval $ar(-command) moveto [expr {$sliderStartX / $areaWidth}] + } + return + } +} + +#This moves the widget being scrolled a unit at a time. +#It is invoked by the arrow buttons. The arrow buttons +#are actually labels with bitmaps that have the -relief +#change. + +proc cscrollbar::moveUnit {cmd unit self} { + variable buttonPressed + + eval $cmd scroll $unit units + + $self config -relief sunken + if {$buttonPressed == 1} { + after 40 "cscrollbar::moveUnit {$cmd} $unit $self" + } else { + $self config -relief raised + } +} + +#This means that someone has pressed the trough/background +#of the scrollbar, so we should scroll a page at a time. +#Unlike Tk's scrollbar I don't continue scrolling while +#the mouse is held down. Instead I chose to scroll once. +#If the user wants it to continue they can press the mouse +#again. +proc cscrollbar::scrollPages {win type x y} { + upvar #0 _cscrollbar$win ar + + if {$type == "horizontal"} { + set sliderStartX [lindex [$win.c coords slider] 0] + set sliderEndX [lindex [$win.c coords slider] 2] + + if {$x < $sliderStartX} { + eval [concat $ar(-command) scroll -1 pages] + } + + if {$x > $sliderEndX} { + eval [concat $ar(-command) scroll 1 pages] + } + } + + if {$type == "vertical"} { + set sliderStartY [lindex [$win.c coords slider] 1] + set sliderEndY [lindex [$win.c coords slider] 3] + + if {$y < $sliderStartY} { + eval [concat $ar(-command) scroll -1 pages] + } + + if {$y > $sliderEndY} { + eval [concat $ar(-command) scroll 1 pages] + } + } +} + + +proc cscrollbar::sliderNotPressed {win} { + upvar #0 _cscrollbar$win ar + set ar(sliderPressed) 0 + + if {[catch {$ar(-command)} res] == 0 && $res != ""} { + $win set $res + } +} diff --git a/modules/ctext/pkgIndex.tcl b/modules/ctext/pkgIndex.tcl new file mode 100644 index 00000000..8a23034f --- /dev/null +++ b/modules/ctext/pkgIndex.tcl @@ -0,0 +1 @@ +package ifneeded ctext 3.1 [list source [file join $dir ctext.tcl]] diff --git a/modules/ctext/test.c b/modules/ctext/test.c new file mode 100644 index 00000000..7585f286 --- /dev/null +++ b/modules/ctext/test.c @@ -0,0 +1,1134 @@ +/*The Panache Window Manager*/ +/*By George Peter Staplin*/ +/*Please read the LICENSE file included with the Panache distribution + *for usage restrictions. + */ + +#include +#include +#include +#ifndef __STDC__ + #include +#endif +#include +#include +#include +#include +#include +#include +#include +#include "PanacheWindowList.h" + +/*Style +I use if (returnFromFunc == 1) instead of if (returnFromFunc) +I use if (returnFromFunc == 0) instead of if (!returnFromFunc) +*/ + +/*Automatic focus of new windows yes/no.*/ +/*Automatic focus of transient windows yes/no.*/ + +#define PANACHE_DIRECTORY "Panache" +#define CMD_ARGS (ClientData clientData, Tcl_Interp *interp, \ +int objc, Tcl_Obj *CONST objv[]) + +Display *dis; +XEvent report; +Window root; +Tcl_Interp *interp; +int distance_from_edge = 0; +Window mapped_window = None; +int screen; +Atom _XA_WM_STATE; +Atom _XA_WM_PROTOCOLS; +Atom _XA_WM_DELETE_WINDOW; +Window workspace_manager; +struct CList *keepAboveWindowList; +unsigned long eventMask = (ResizeRedirectMask | PropertyChangeMask | \ + EnterWindowMask | LeaveWindowMask | FocusChangeMask | KeyPressMask); + +#define winIdLength 14 +/*#define FORK_ON_START*/ + +int PanacheGetWMState (Window win); +void PanacheSelectInputForRootParented (Window win); +void PanacheConfigureNormalWindow (Window win, unsigned long value_mask); + +char Panache_Init_script[] = { + "if {[file exists $prefix/$panacheDirectory/Panache.tcl] != 1} {\n" + " puts stderr {unable to open Panache.tcl Did you run make install?}\n" + " puts stderr \"I looked in $prefix/$panacheDirectory\"\n" + " exit -1\n" + "}\n" + "proc sendToPipe str {\n" + " set str [string map {\"\n\" \"\" \"\r\" \"\"} $str]\n" + " puts $::pipe $str\n" + " flush $::pipe\n" + "}\n" + "proc getFromPipe {} {\n" + " gets $::pipe line\n" + " if {$line != \"\"} {\n" + " set cmd [lindex $line 0]\n" + " if {[llength $line] == 2} {\n" + " $cmd [lindex $line 1]\n" + " } else {\n" + " eval $line\n" + " }\n" + " }\n" + "}\n" + "set ::pipe [open \"|$wishInterpreter $prefix/$panacheDirectory/Panache.tcl\" w+]\n" + "fconfigure $::pipe -blocking 0\n" + "\n"}; + + +char *charMalloc (int size) { + char *mem = NULL; + + mem = (char *) malloc ((sizeof (char)) * size); + + if (mem == NULL) { + fprintf (stderr, "malloc failed to allocate memory This means that Panache \ +and other applications could have problems if they continue running.\n\n \ +exiting Panache now!"); + exit (-1); + } + + return mem; +} + + +void sendConfigureNotify (Window win, unsigned long value_mask, XWindowChanges *winChanges) { + XEvent xe; + XWindowAttributes wattr; + + if (XGetWindowAttributes (dis, win, &wattr) == 0) { + return; + } + + xe.type = ConfigureNotify; + xe.xconfigure.type = ConfigureNotify; + xe.xconfigure.event = win; + xe.xconfigure.window = win; + + + xe.xconfigure.x = (value_mask & CWX) ? winChanges->x : wattr.x; + xe.xconfigure.y = (value_mask & CWY) ? winChanges->y : wattr.y; + xe.xconfigure.width = (value_mask & CWWidth) ? winChanges->width : wattr.width; + xe.xconfigure.height = (value_mask & CWHeight) ? winChanges->height : wattr.height; + + xe.xconfigure.border_width = 0; + xe.xconfigure.above = None; + xe.xconfigure.override_redirect = 0; + + XSendEvent (dis, win, 0, StructureNotifyMask, &xe); + + XFlush (dis); +} + + +void sendMapNotify (Window win) { + XEvent mapNotify; + + mapNotify.type = MapNotify; + mapNotify.xmap.type = MapNotify; + mapNotify.xmap.window = win; + mapNotify.xmap.display = dis; + mapNotify.xmap.event = win; + XSendEvent (dis, win, 0, StructureNotifyMask, &mapNotify); + XFlush (dis); +} + + +int PanacheAddAllWindowsCmd CMD_ARGS { + Window dummy; + Window *children = NULL; + unsigned int nchildren; + unsigned int i; + char *winId; + char *transientForWinId; + char str[] = "sendToPipe [list add [list $winTitle] $winId $winType $transientForWinId]"; + Window twin; + + XSync (dis, 0); + /*XGrabServer (dis);*/ + + if (XQueryTree (dis, + root, + &dummy, + &dummy, + &children, + &nchildren) == 0) { + + fprintf (stderr, "Error querying the tree for the root window.\n"); + } + + for (i = 0; i < nchildren; i++) { + XTextProperty xtp; + XWMHints *wmHints = XGetWMHints (dis, children[i]); + XWindowAttributes wattr; + + xtp.value = NULL; + + if (wmHints == NULL) { + continue; + } + + if (wmHints->flags & IconWindowHint) { + continue; + } + + if (XGetWindowAttributes (dis, children[i], &wattr) == 0) { + continue; + } + + if (wattr.override_redirect == 1) { + continue; + } + + if (wmHints->flags & StateHint) { + if (wmHints->initial_state & WithdrawnState) { + continue; + } else if (wattr.map_state == 0 && PanacheGetWMState (children[i]) == 0) { + continue; + } + } + + XFree (wmHints); + + XGetWMName (dis, children[i], &xtp); + + winId = charMalloc (winIdLength); + + sprintf (winId, "%ld", children[i]); + Tcl_SetVar (interp, "winTitle", (char *) xtp.value, 0); + Tcl_SetVar (interp, "winId", winId, 0); + + if (XGetTransientForHint (dis, children[i], &twin) == 1) { + Tcl_SetVar (interp, "winType", "transient", 0); + + transientForWinId = charMalloc (winIdLength); + sprintf (transientForWinId, "%ld", twin); + Tcl_SetVar (interp, "transientForWinId", transientForWinId, 0); + free (transientForWinId); + + PanacheSelectInputForRootParented (children[i]); + + } else { + Tcl_SetVar (interp, "winType", "normal", 0); + Tcl_SetVar (interp, "transientForWinId", "", 0); + + /*Maybe I should compare the first char and then do strcmp?*/ + if (xtp.value != NULL && strcmp ((char *)xtp.value, "___Panache_GUI") != 0) { + PanacheConfigureNormalWindow (children[i], CWX|CWY|CWWidth|CWHeight); + PanacheSelectInputForRootParented (children[i]); + } + } + + XFree (xtp.value); + free (winId); + + if (Tcl_Eval (interp, str) != TCL_OK) { + fprintf (stderr, "Error in PanacheAddAllWindowsCmd: %s\n", Tcl_GetStringResult (interp)); + } + } + + if (children != NULL) { + XFree (children); + } + + /*XUngrabServer (dis);*/ + XSync (dis, 0); + + return TCL_OK; +} + + +void PanacheConfigureRequest (XConfigureRequestEvent *event) { + XWindowChanges wc; + Window twin; + int maxWidth; + int maxHeight; + + if (event->parent != root) { + return; + } + +#ifdef DEBUG + fprintf (stderr, "ConfigureRequest win %ld\n", event->window); + fprintf (stderr, "CWSibling %d\n", (event->value_mask & CWSibling) == 1); + fprintf (stderr, "CWStackMode %d\n", (event->value_mask & CWStackMode) == 1); +#endif + + maxWidth = (DisplayWidth (dis, screen) - distance_from_edge - 4); + maxHeight = DisplayHeight (dis, screen); + + wc.border_width = 0; + wc.sibling = None; + wc.stack_mode = Above; + + if (event->window == workspace_manager) { + wc.width = distance_from_edge; + wc.height = maxHeight; + wc.x = 0; + wc.y = 0; + XConfigureWindow(dis, event->window, CWX|CWY|CWWidth|CWHeight, &wc); + sendConfigureNotify (event->window, CWX|CWY|CWWidth|CWHeight, &wc); + return; + } else { + PanacheSelectInputForRootParented (event->window); + } + + if (XGetTransientForHint (dis, event->window, &twin) == 1) { + if (event->width > maxWidth) { + wc.width = maxWidth; + } else { + wc.width = event->width; + } + + wc.height = event->height; + + if (event->x < distance_from_edge) { + wc.x = distance_from_edge; + } else { + wc.x = event->x; + } + + wc.y = event->y; + XConfigureWindow (dis, event->window, event->value_mask, &wc); + sendConfigureNotify (event->window, event->value_mask, &wc); + } else { + PanacheConfigureNormalWindow (event->window, event->value_mask); + } + + XFlush (dis); +} + + +/*This configures the window and sends a ConfigureNotify event. + *It's designed for normal non-transient windows + */ +void PanacheConfigureNormalWindow ( + Window win, unsigned long value_mask) +{ + XWindowChanges wc; + XSizeHints sizeHints; + long ljunk = 0; + int maxWidth = (DisplayWidth (dis, screen) - distance_from_edge - 4); + int maxHeight = DisplayHeight (dis, screen); + + wc.border_width = 0; + wc.sibling = None; + wc.stack_mode = Above; + + wc.x = distance_from_edge; + wc.y = 0; + wc.width = maxWidth; + wc.height = maxHeight; + + if (XGetWMNormalHints (dis, win, &sizeHints, &ljunk)) { + if (sizeHints.flags & PMaxSize) { + wc.width = (sizeHints.max_width > maxWidth) ? maxWidth : sizeHints.max_width; + wc.height = (sizeHints.max_height > maxHeight) ? maxHeight : sizeHints.max_height; +#ifdef DEBUG + fprintf (stderr, "MaxSize %d %d\n", sizeHints.max_width, sizeHints.max_height); +#endif + } +#ifdef DEBUG + if (sizeHints.flags & PResizeInc) { + fprintf (stderr, "PResizeInc\n"); + fprintf (stderr, "incr %d %d\n", sizeHints.width_inc, sizeHints.height_inc); + } + if (sizeHints.flags & PAspect) { + fprintf (stderr, "PAspect x %d\n", sizeHints.min_aspect.x); + } +#endif + } + + XConfigureWindow (dis, win, value_mask, &wc); + sendConfigureNotify (win, value_mask, &wc); +} + + +/*This appends windows that are not to be managed by + *Panache to a list, and Panache will later on raise + *them above other windows. + */ +void PanacheCreateNotify (XCreateWindowEvent *event) { + + if (event->override_redirect == 0 || event->parent != root) { + return; + } + + CListAppend (keepAboveWindowList, event->window); +} + +/*X has told Panache that a DestroyNotify event occured + *to a child of the root window, so Panache removes the + *window from the window list. + */ +void PanacheDestroyNotify (XDestroyWindowEvent *event) { + Window win; + char *winId; + char str[] = "sendToPipe [list remove $winId]"; + + win = event->window; + + winId = charMalloc (winIdLength); + sprintf (winId, "%ld", win); + + Tcl_SetVar (interp, "winId", winId, 0); + free (winId); + +#ifdef DEBUG + fprintf (stderr, "DestroyNotify\n"); +#endif + + CListRemove (keepAboveWindowList, event->window); + + /*Tell Panache_GUI to remove the window*/ + if (Tcl_Eval (interp, str) != TCL_OK) { + fprintf (stderr, "Tcl_Eval error in PanacheDestroyNotify %s\n", Tcl_GetStringResult (interp)); + } +} + + +/*Panache_GUI calls this to send WM_DELETE_WINDOW or + *invoke XKillClient (if the window doesn't support + *WM_DELETE_WINDOW). We can't use XKillClient on all + *windows, because if the application has multiple + *toplevel windows sending XKillClient would destroy + *them all. + */ +int PanacheDestroyCmd CMD_ARGS { + XClientMessageEvent ev; + Window win; + Atom *wmProtocols = NULL; + Atom *protocol; + int i; + int numAtoms; + int handlesWM_DELETE_WINDOW = 0; + + + Tcl_GetLongFromObj (interp, objv[1], (long *) &win); + + if (XGetWMProtocols (dis, win, &wmProtocols, &numAtoms) == 1) { + for (i = 0, protocol = wmProtocols; i < numAtoms; i++, protocol++) { + if (*protocol == (Atom)_XA_WM_DELETE_WINDOW) { + handlesWM_DELETE_WINDOW = 1; + } + } + if (wmProtocols) { + XFree (wmProtocols); + } + } + + if (handlesWM_DELETE_WINDOW == 1) { + ev.type = ClientMessage; + ev.window = win; + ev.message_type = _XA_WM_PROTOCOLS; + ev.format = 32; + ev.data.l[0] = _XA_WM_DELETE_WINDOW; + ev.data.l[1] = CurrentTime; + XSendEvent (dis, win, 0, 0L, (XEvent *) &ev); + } else { + XKillClient (dis, win); + } + + XFlush (dis); + + return TCL_OK; +} + + +int PanacheDFECmd CMD_ARGS { + Tcl_GetIntFromObj (interp, objv[1], &distance_from_edge); + return TCL_OK; +} + + +/*Panache_GUI sends focus $winId to get here.*/ +int PanacheFocusCmd CMD_ARGS { + Window win; + + Tcl_GetLongFromObj (interp, objv[1], (long *) &win); + + if (XSetInputFocus (dis, win, RevertToParent, CurrentTime) != 1) { + fprintf (stderr, "XSetInputFocus failure within PanacheFocusCmd()"); + } + + XFlush (dis); + + return TCL_OK; +} + + +int PanacheGetWMState (Window win) { + int returnValue = 0; + Atom type; + int ijunk; + unsigned long ljunk; + unsigned long *state = NULL; + + XGetWindowProperty ( + dis, + win, + _XA_WM_STATE, + 0L, + 1L, + 0, + _XA_WM_STATE, + &type, + &ijunk, + &ljunk, + &ljunk, + (unsigned char **) &state + ); + + if (type == _XA_WM_STATE) { + returnValue = (int) *state; + } else { + /*Don't know what to do*/ + returnValue = 0; + } + + if (state != NULL) { + XFree (state); + } + + return returnValue; +} + +/*A window to keep above has the override_redirect + *attribute set to 1. + */ + +void PanacheRaiseKeepAboveWindows () { + Window win; + + CListRewind (keepAboveWindowList); + + while ((win = CListGet (keepAboveWindowList)) != NULL) { + XRaiseWindow (dis, win); + } + + XFlush (dis); +} + + +void PanacheRecursivelyGrabKey (Window win, int keycode) { + Window dummy; + Window *children = NULL; + unsigned int nchildren; + int i; + + + if (XQueryTree (dis, win, &dummy, &dummy, &children, &nchildren) == 0) { + return; + } + + for (i = 0; i < nchildren; i++) { + PanacheRecursivelyGrabKey (children[i], keycode); + XGrabKey (dis, keycode, Mod1Mask, win, 1, GrabModeAsync, GrabModeSync); + } + + if (children != NULL) { + XFree (children); + } +} + + +int PanacheReparentCmd CMD_ARGS { + Window newParent; + Window win; + + Tcl_GetLongFromObj (interp, objv[1], (long *) &win); + Tcl_GetLongFromObj (interp, objv[2], (long *) &newParent); + + XReparentWindow (dis, win, newParent, 0, 20); + + return TCL_OK; +} + + +void PanacheSelectInputForRootParented (Window win) { + + XSelectInput (dis, win, eventMask); +} + + +void PanacheSetWMState (Window win, int state) { + unsigned long data[2]; + data[0] = state; + data[1] = None; + + XChangeProperty (dis, win, _XA_WM_STATE, _XA_WM_STATE, 32, + PropModeReplace, (unsigned char *) data, 2 + ); + + XSync (dis, 0); +} + + +int PanacheTransientCmd CMD_ARGS { + Window parent; + Window win; + + Tcl_GetLongFromObj (interp, objv[1], (long *) &win); + Tcl_GetLongFromObj (interp, objv[2], (long *) &parent); + + XSetTransientForHint (dis, win, parent); + + return TCL_OK; +} + +/*This sends a string to Panache_GUI with info about the window, + *such as its title and window id. This information is processed + *within Panache_GUI and if desired PanacheMapCmd will map the + *window. + */ +void PanacheMapRequest (XMapRequestEvent *event) { + char *winId; + char *transientForWinId; + XTextProperty xtp; + char str[] = "sendToPipe [list add [list $winTitle] $winId $winType $transientForWinId]"; + Window twin; + + if (event->window == NULL) { + return; + } + + /*This makes the state iconic, so that if the user presses + *restart before mapping the window, the window will show up. + */ + PanacheSetWMState (event->window, IconicState); + + xtp.value = NULL; + + XGetWMName (dis, event->window, &xtp); + + winId = charMalloc (winIdLength); + + sprintf (winId, "%ld", event->window); + PanacheSelectInputForRootParented (event->window); + + Tcl_SetVar (interp, "winTitle", (char *) xtp.value, 0); + Tcl_SetVar (interp, "winId", winId, 0); + + if (XGetTransientForHint (dis, event->window, &twin) == 1) { + Tcl_SetVar (interp, "winType", "transient", 0); + transientForWinId = charMalloc (winIdLength); + sprintf (transientForWinId, "%ld", twin); + Tcl_SetVar (interp, "transientForWinId", transientForWinId, 0); + free (transientForWinId); + } else { + Tcl_SetVar (interp, "winType", "normal", 0); + Tcl_SetVar (interp, "transientForWinId", "", 0); + } + + XFree (xtp.value); + free (winId); + + if (Tcl_Eval (interp, str) != TCL_OK) { + fprintf (stderr, "Error in PanacheMapRequest: %s\n", Tcl_GetStringResult (interp)); + } +} + + +/*This maps a window. It may be called after PanacheMapRequest by + *Panache_GUI. This is also called when a window is over another + *window and the user selects the button for the window to display + *which causes this function to raise the window. + */ +int PanacheMapCmd CMD_ARGS { + Window win; + Window twin; + XWindowAttributes winAttrib; + + Tcl_GetLongFromObj (interp, objv[1], (long *) &win); + + PanacheSelectInputForRootParented (win); + + /*XGrabKey (dis, XK_Tab, Mod1Mask, win, 1, GrabModeAsync, GrabModeAsync);*/ + /*PanacheRecursivelyGrabKey (win, XK_Tab);*/ + + XGetWindowAttributes (dis, win, &winAttrib); + + if (winAttrib.x < distance_from_edge) { + winAttrib.x = distance_from_edge; + if (winAttrib.y < 0) { + winAttrib.y = 0; + } + XMoveWindow (dis, win, winAttrib.x, winAttrib.y); + } + + if (XGetTransientForHint (dis, win, &twin) == 1) { + PanacheSetWMState (win, NormalState); + XMapRaised (dis, win); + sendMapNotify (win); + mapped_window = win; + PanacheRaiseKeepAboveWindows (); + + return TCL_OK; + } + + + if ((PanacheGetWMState (win)) == 1) { + XRaiseWindow (dis, win); + PanacheRaiseKeepAboveWindows (); + + return TCL_OK; + } + + /*If we are here the window hasn't had its size set, or + *the WM_STATE was not 1. + */ + + PanacheSetWMState (win, NormalState); + + /*I've found that some applications get upset if you sent + *a ConfigureNotify before the MapNotify, when they are + *expecting the MapNotify to be eminent. + */ + + XMapRaised (dis, win); + sendMapNotify (win); + + PanacheConfigureNormalWindow (win, CWX|CWY|CWWidth|CWHeight); + + mapped_window = win; + PanacheRaiseKeepAboveWindows (); + + return TCL_OK; +} + + +int PanacheMapWorkspaceCmd CMD_ARGS { + XWindowChanges wc; + Window win; + + Tcl_GetLongFromObj (interp, objv[1], (long *) &win); + workspace_manager = win; + PanacheSetWMState (win, NormalState); + + wc.x = 0; + wc.y = 0; + wc.width = distance_from_edge; + wc.height = DisplayHeight (dis, screen); + + XConfigureWindow(dis, win, CWX|CWY|CWWidth|CWHeight, &wc); + sendConfigureNotify (win, CWX|CWY|CWWidth|CWHeight, &wc); + + XMapWindow (dis, win); + sendMapNotify (win); + mapped_window = win; + XFlush (dis); + + return TCL_OK; +} + + +int PanacheMoveCmd CMD_ARGS { + XEvent event; + unsigned int buttonPressed; + Window wjunk; + int ijunk; + Cursor handCursor; + Window win; + int oldX; + int oldY; + int x; + int y; + int internalX; + int internalY; + unsigned int maskReturn; + int continueEventLoop = 1; + XWindowAttributes winAttr; + + handCursor = XCreateFontCursor (dis, XC_hand2); + + XGrabPointer (dis, root, 1, + ButtonPressMask | ButtonReleaseMask | ButtonMotionMask | \ + PointerMotionHintMask, + GrabModeAsync, GrabModeAsync, + None, + handCursor, + CurrentTime + ); + + /*Wait until the user has selected the window to move.*/ + XMaskEvent (dis, ButtonPressMask, &event); + + /*The button being held down while dragging the window.*/ + buttonPressed = event.xbutton.button; + + /*fprintf (stderr, "ButtonPressed %d\n", buttonPressed);*/ + + XQueryPointer (dis, root, + &wjunk, &win, + &oldX, &oldY, + &internalX, &internalY, + &maskReturn + ); + + if (win == workspace_manager) { + XUngrabPointer (dis, CurrentTime); + XFreeCursor (dis, handCursor); + XSync (dis, 0); + + return TCL_OK; + } + + + XGetWindowAttributes (dis, win, &winAttr); + + while (continueEventLoop == 1) { + XNextEvent (dis, &event); + switch (event.type) { + case ButtonRelease: + { + if (event.xbutton.button == buttonPressed) { + continueEventLoop = 0; + } + } + break; + case MotionNotify: + { + XWindowChanges wc; + int newX; + int newY; + + while (XCheckTypedEvent (dis, MotionNotify, &event)); + + XQueryPointer (dis, root, &wjunk, &wjunk, + &x, &y, + &ijunk, &ijunk, + &maskReturn + ); + + newX = x - oldX + winAttr.x; + newY = y - oldY + winAttr.y; + + if (newX < distance_from_edge) { + + if (winAttr.override_redirect == 1) { + XMoveWindow (dis, win, distance_from_edge, newY); + } else { + wc.x = distance_from_edge; + wc.y = newY; + XConfigureWindow (dis, win, CWX | CWY, &wc); + sendConfigureNotify (win, CWX | CWY, &wc); + } + continue; + } + + if (winAttr.override_redirect == 1) { + XMoveWindow (dis, win, newX, newY); + } else { + wc.x = newX; + wc.y = newY; + XConfigureWindow (dis, win, CWX | CWY, &wc); + sendConfigureNotify (win, CWX | CWY, &wc); + } + } + break; + } + } + + /*fprintf (stderr, "win is %ld\n", win);*/ + + XUngrabPointer (dis, CurrentTime); + XFreeCursor (dis, handCursor); + + XSync (dis, 0); + + return TCL_OK; +} + + +XErrorHandler PanacheErrorHandler (Display *dis, XErrorEvent *event) { +/*I've discovered that errors are frequently timing problems. +Maybe XSync would help in some areas. +Most errors are not fatal. +*/ + return 0; +} + + +int main() { + fd_set readfds; + int nfds; + int xFd; + int pipeFd; + int inputPipeFd; + ClientData data; + int fdsTcl; + + + dis = XOpenDisplay (NULL); + screen = DefaultScreen (dis); + root = RootWindow (dis, screen); + interp = Tcl_CreateInterp (); + + XSetErrorHandler ((XErrorHandler) PanacheErrorHandler); + + _XA_WM_STATE = XInternAtom (dis, "WM_STATE", 0); + _XA_WM_PROTOCOLS = XInternAtom (dis, "WM_PROTOCOLS", 0); + _XA_WM_DELETE_WINDOW = XInternAtom (dis, "WM_DELETE_WINDOW", 0); + + keepAboveWindowList = CListInit (); + +#ifdef FORK_ON_START + { + int res; + res = fork(); + + if (res == -1) { + fprintf (stderr, "Unable to fork process."); + return 1; + } + + if (res != 0) { + exit (0); + } + } +#endif + + if (Tcl_Init (interp) != TCL_OK) { + printf ("Tcl_Init error\n"); + exit (-1); + } + +#define CREATE_CMD(cmdName,func) Tcl_CreateObjCommand (interp, \ +cmdName, func, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL) + + CREATE_CMD ("map_workspace", PanacheMapWorkspaceCmd); + CREATE_CMD ("distance_from_edge", PanacheDFECmd); + CREATE_CMD ("map", PanacheMapCmd); + CREATE_CMD ("destroy", PanacheDestroyCmd); + CREATE_CMD ("add_all_windows", PanacheAddAllWindowsCmd); + CREATE_CMD ("focus", PanacheFocusCmd); + CREATE_CMD ("transient", PanacheTransientCmd); + CREATE_CMD ("reparent", PanacheReparentCmd); + CREATE_CMD ("move", PanacheMoveCmd); + + Tcl_SetVar (interp, "wishInterpreter", WISH_INTERPRETER, 0); + Tcl_SetVar (interp, "prefix", PREFIX, 0); + Tcl_SetVar (interp, "panacheDirectory", PANACHE_DIRECTORY, 0); + + + if (Tcl_Eval (interp, Panache_Init_script) != TCL_OK) { + fprintf (stderr, "Error while evaluating Panache_Init_script within main()%s\n", Tcl_GetStringResult (interp)); + exit (-1); + } + + XSelectInput (dis, root, LeaveWindowMask | EnterWindowMask| \ + PropertyChangeMask | SubstructureRedirectMask | \ + SubstructureNotifyMask | KeyPressMask | KeyReleaseMask | \ + ResizeRedirectMask | FocusChangeMask + ); + + xFd = ConnectionNumber (dis); + + Tcl_GetChannelHandle (Tcl_GetChannel (interp, Tcl_GetVar (interp, "pipe", NULL), NULL), TCL_WRITABLE, &data); + pipeFd = (int) data; + /*fprintf (stderr, "pipeFd %d", pipeFd);*/ + + Tcl_GetChannelHandle (Tcl_GetChannel (interp, Tcl_GetVar (interp, "pipe", NULL), NULL), TCL_READABLE, &data); + inputPipeFd = (int) data; + + XFlush(dis); + + for (;;) { + + FD_ZERO (&readfds); + FD_SET (xFd, &readfds); + FD_SET (pipeFd, &readfds); + FD_SET (inputPipeFd, &readfds); + + fdsTcl = (pipeFd > inputPipeFd) ? pipeFd : inputPipeFd; + nfds = (xFd > fdsTcl) ? xFd + 1: fdsTcl + 1; + + select (nfds, &readfds, NULL, NULL, NULL); + + if (FD_ISSET (inputPipeFd, &readfds) != 0) { + if (Tcl_Eval (interp, "getFromPipe") != TCL_OK) { + fprintf (stderr, "getFromPipe error %s\n", Tcl_GetStringResult (interp)); + } + } + + if (FD_ISSET (pipeFd, &readfds) != 0) { + while (Tcl_DoOneEvent (TCL_DONT_WAIT)); + } + + if (FD_ISSET (xFd, &readfds) == 0) { + continue; + } + + while (XPending (dis) > 0) { + XNextEvent (dis, &report); + + /*fprintf (stderr, "type %d\n", report.type);*/ + switch (report.type) { + case ConfigureNotify: + /*fprintf (stderr, "ConfigureNotify \n");*/ + break; + + case CreateNotify: + PanacheCreateNotify (&report.xcreatewindow); + break; + + case ConfigureRequest: + PanacheConfigureRequest (&report.xconfigurerequest); + break; + + case DestroyNotify: + PanacheDestroyNotify (&report.xdestroywindow); + break; + + case EnterNotify: + { + Window win = report.xcrossing.window; + char *winId = NULL; + char cmd[] = "sendToPipe [list activateWindow $winId]"; + + winId = charMalloc (winIdLength); + sprintf (winId, "%ld", win); + Tcl_SetVar (interp, "winId", winId, 0); + free (winId); + + if (Tcl_Eval (interp, cmd) != TCL_OK) { + fprintf (stderr, "Error evaluating cmd in EnterNotify within main() %s\n", Tcl_GetStringResult (interp)); + } + + } + break; + + case FocusIn: + break; + + + case KeyPress: + { + char cmd[] = "sendToPipe next"; + + if (XLookupKeysym (&report.xkey, 0) == XK_Tab && (report.xkey.state & Mod1Mask)) { + fprintf (stderr, "alt tab win %ld\n", report.xkey.window); + if (Tcl_Eval (interp, cmd) != TCL_OK) { + fprintf (stderr, "Error evaluating cmd in KeyPress within main() %s\n", Tcl_GetStringResult (interp)); + } + } else { + /*Send XK_Tab*/ + } + + /* + fprintf (stderr, "1 %d \n", report.xkey.state == Mod1Mask); + fprintf (stderr, "2 %d \n", report.xkey.state == Mod2Mask); + fprintf (stderr, "3 %d \n", report.xkey.state == Mod3Mask); + fprintf (stderr, "4 %d \n", report.xkey.state == Mod4Mask); + fprintf (stderr, "5 %d \n", report.xkey.state == Mod5Mask); + */ + } + break; + + case MapRequest: + PanacheMapRequest (&report.xmaprequest); + break; + + case UnmapNotify: + { + int state = PanacheGetWMState (report.xunmap.window); + /*Mapped or Iconified*/ + if (state == 1 || state == 3) { + char *winId = NULL; + char cmd[] = "sendToPipe [list remove $winId]"; + + winId = charMalloc (winIdLength); + sprintf (winId, "%ld", report.xunmap.window); + + Tcl_SetVar (interp, "winId", winId, 0); + free (winId); + + PanacheSetWMState (report.xunmap.window, WithdrawnState); + + if (Tcl_Eval (interp, cmd) != TCL_OK) { + fprintf (stderr, "Tcl_Eval error in UnmapNotify within main() %s", Tcl_GetStringResult (interp)); + } + } + } + break; + + case PropertyNotify: + { + XTextProperty xtp; + xtp.value = NULL; + + if (XGetWMName (dis, report.xproperty.window, &xtp) == 1) { + char *winId; + char cmd[] = "sendToPipe [list title [list $winTitle] $winId]"; + + winId = charMalloc (winIdLength); + sprintf (winId, "%ld", report.xproperty.window); + + Tcl_SetVar (interp, "winTitle", (char *) xtp.value, 0); + Tcl_SetVar (interp, "winId", winId, 0); + + free (winId); + XFree (xtp.value); + + if (Tcl_Eval (interp, cmd) != TCL_OK) { + fprintf (stderr, "Tcl_Eval error in PropertyNotify: within main() %s\n", Tcl_GetStringResult (interp)); + } + } + } + break; + + + case ReparentNotify: + { + Window win = report.xreparent.window; + Window parent = report.xreparent.parent; + + /* + fprintf (stderr, "ReparentNotify\n"); + fprintf (stderr, "win %ld parent %ld event %ld\n", win, parent, event); + */ + XSelectInput (dis, win, 0); + + if (parent != root) { + char *winId; + char cmd[] = "sendToPipe [list remove $winId]"; + + winId = charMalloc (winIdLength); + sprintf (winId, "%ld", win); + Tcl_SetVar (interp, "winId", winId, 0); + free (winId); + + if (Tcl_Eval (interp, cmd) != TCL_OK) { + fprintf (stderr, "Tcl_Eval error in ReparentNotify within main() %s\n", Tcl_GetStringResult (interp)); + } + } + } + break; + + + case ResizeRequest: + { + Window twin; + Window win = report.xresizerequest.window; + + if (XGetTransientForHint (dis, win, &twin) == 1) { + XResizeWindow (dis, win, + report.xresizerequest.width, report.xresizerequest.height + ); + } + + XFlush (dis); + } + break; + + default: + break; + } + } + } + return 0; +} From 88e93189c3df00fb488a2e42991a7a2540a45600 Mon Sep 17 00:00:00 2001 From: davidw Date: Wed, 17 Mar 2004 21:27:46 +0000 Subject: [PATCH 0003/1290] * style.tcl: Created style package. --- modules/style/ChangeLog | 4 ++ modules/style/as.tcl | 128 ++++++++++++++++++++++++++++++++++++++ modules/style/lobster.tcl | 54 ++++++++++++++++ modules/style/style.tcl | 29 +++++++++ 4 files changed, 215 insertions(+) create mode 100644 modules/style/ChangeLog create mode 100644 modules/style/as.tcl create mode 100644 modules/style/lobster.tcl create mode 100644 modules/style/style.tcl diff --git a/modules/style/ChangeLog b/modules/style/ChangeLog new file mode 100644 index 00000000..1880b717 --- /dev/null +++ b/modules/style/ChangeLog @@ -0,0 +1,4 @@ +2004-03-17 David N. Welton + + * style.tcl: Created style package. + diff --git a/modules/style/as.tcl b/modules/style/as.tcl new file mode 100644 index 00000000..31fe337b --- /dev/null +++ b/modules/style/as.tcl @@ -0,0 +1,128 @@ +# as_style.tcl -- +# +# This file implements package as::style. +# +# Copyright (c) 2003 ActiveState Corporation, a division of Sophos +# + +package provide style::as 1.1 + +namespace eval style::as { + if { [tk windowingsystem] == "x11" } { + set highlightbg "#316AC5" ; # SystemHighlight + set highlightfg "white" ; # SystemHighlightText + set bg "white" ; # SystemWindow + set fg "black" ; # SystemWindowText + + ## Fonts + ## + set size -12 + set family Helvetica + set fsize -12 + set ffamily Courier + + + font create ASfont -size $size -family $family + font create ASfontBold -size $size -family $family -weight bold + font create ASfontFixed -size $fsize -family $ffamily + for {set i -2} {$i <= 4} {incr i} { + set isize [expr {$size + ($i * (($size > 0) ? 1 : -1))}] + set ifsize [expr {$fsize + ($i * (($fsize > 0) ? 1 : -1))}] + font create ASfont$i -size $isize -family $family + font create ASfontBold$i -size $isize -family $family -weight bold + font create ASfontFixed$i -size $ifsize -family $ffamily + } + + option add *Text.font ASfontFixed widgetDefault + option add *Button.font ASfont widgetDefault + option add *Canvas.font ASfont widgetDefault + option add *Checkbutton.font ASfont widgetDefault + option add *Entry.font ASfont widgetDefault + option add *Label.font ASfont widgetDefault + option add *Labelframe.font ASfont widgetDefault + option add *Listbox.font ASfont widgetDefault + option add *Menu.font ASfont widgetDefault + option add *Menubutton.font ASfont widgetDefault + option add *Message.font ASfont widgetDefault + option add *Radiobutton.font ASfont widgetDefault + option add *Spinbox.font ASfont widgetDefault + + option add *Table.font ASfont widgetDefault + option add *TreeCtrl*font ASfont widgetDefault + ## Misc + ## + option add *ScrolledWindow.ipad 0 widgetDefault + + ## Listbox + ## + option add *Listbox.background $bg widgetDefault + option add *Listbox.foreground $fg widgetDefault + option add *Listbox.selectBorderWidth 0 widgetDefault + option add *Listbox.selectForeground $highlightfg widgetDefault + option add *Listbox.selectBackground $highlightbg widgetDefault + option add *Listbox.activeStyle dotbox widgetDefault + + ## Button + ## + option add *Button.padX 1 widgetDefault + option add *Button.padY 2 widgetDefault + + ## Entry + ## + option add *Entry.background $bg widgetDefault + option add *Entry.foreground $fg widgetDefault + option add *Entry.selectBorderWidth 0 widgetDefault + option add *Entry.selectForeground $highlightfg widgetDefault + option add *Entry.selectBackground $highlightbg widgetDefault + + ## Spinbox + ## + option add *Spinbox.background $bg widgetDefault + option add *Spinbox.foreground $fg widgetDefault + option add *Spinbox.selectBorderWidth 0 widgetDefault + option add *Spinbox.selectForeground $highlightfg widgetDefault + option add *Spinbox.selectBackground $highlightbg widgetDefault + + ## Text + ## + option add *Text.background $bg widgetDefault + option add *Text.foreground $fg widgetDefault + option add *Text.selectBorderWidth 0 widgetDefault + option add *Text.selectForeground $highlightfg widgetDefault + option add *Text.selectBackground $highlightbg widgetDefault + + ## Menu + ## + option add *Menu.activeBackground $highlightbg widgetDefault + option add *Menu.activeForeground $highlightfg widgetDefault + option add *Menu.activeBorderWidth 0 widgetDefault + option add *Menu.highlightThickness 0 widgetDefault + option add *Menu.borderWidth 1 widgetDefault + + ## Menubutton + ## + option add *Menubutton.activeBackground $highlightbg widgetDefault + option add *Menubutton.activeForeground $highlightfg widgetDefault + option add *Menubutton.activeBorderWidth 0 widgetDefault + option add *Menubutton.highlightThickness 0 widgetDefault + option add *Menubutton.borderWidth 0 widgetDefault + option add *Menubutton*padX 4 widgetDefault + option add *Menubutton*padY 2 widgetDefault + + ## Scrollbar + ## + option add *Scrollbar.width 12 widgetDefault + option add *Scrollbar.troughColor #bdb6ad widgetDefault + option add *Scrollbar.borderWidth 1 widgetDefault + option add *Scrollbar.highlightThickness 0 widgetDefault + + ## PanedWindow + ## + option add *Panedwindow.borderWidth 0 widgetDefault + option add *Panedwindow.sashwidth 3 widgetDefault + option add *Panedwindow.showhandle 0 widgetDefault + option add *Panedwindow.sashpad 0 widgetDefault + option add *Panedwindow.sashrelief flat widgetDefault + option add *Panedwindow.relief flat widgetDefault + } +}; # end of namespace style::as diff --git a/modules/style/lobster.tcl b/modules/style/lobster.tcl new file mode 100644 index 00000000..e9bd647a --- /dev/null +++ b/modules/style/lobster.tcl @@ -0,0 +1,54 @@ +# lobster.tcl -- + +# The code formerly known as "gtklook" on the Tcl'ers +# wiki. Most of this code was originally written by Jeremy Collins. + +# $Id: lobster.tcl,v 1.1 2004/03/17 21:27:47 davidw Exp $ + +package provide style::lobster 0.1 + +namespace eval styles::lobster { + if { [tk windowingsystem] == "x11" } { + option add *borderWidth 1 widgetDefault + option add *activeBorderWidth 1 widgetDefault + option add *selectBorderWidth 1 widgetDefault + option add *font -adobe-helvetica-medium-r-normal-*-12-*-*-*-*-*-* widgetDefault + + option add *padX 2 widgetDefault + option add *padY 4 widgetDefault + + option add *Listbox.background white widgetDefault + option add *Listbox.selectBorderWidth 0 widgetDefault + option add *Listbox.selectForeground white widgetDefault + option add *Listbox.selectBackground #4a6984 widgetDefault + + option add *Entry.background white widgetDefault + option add *Entry.foreground black widgetDefault + option add *Entry.selectBorderWidth 0 widgetDefault + option add *Entry.selectForeground white widgetDefault + option add *Entry.selectBackground #4a6984 widgetDefault + + option add *Text.background white widgetDefault + option add *Text.selectBorderWidth 0 widgetDefault + option add *Text.selectForeground white widgetDefault + option add *Text.selectBackground #4a6984 widgetDefault + + option add *Menu.activeBackground #4a6984 widgetDefault + option add *Menu.activeForeground white widgetDefault + option add *Menu.activeBorderWidth 0 widgetDefault + option add *Menu.highlightThickness 0 widgetDefault + option add *Menu.borderWidth 2 widgetDefault + + option add *Menubutton.activeBackground #4a6984 widgetDefault + option add *Menubutton.activeForeground white widgetDefault + option add *Menubutton.activeBorderWidth 0 widgetDefault + option add *Menubutton.highlightThickness 0 widgetDefault + option add *Menubutton.borderWidth 0 widgetDefault + + option add *Labelframe.borderWidth 2 + option add *Frame.borderWidth 2 + + option add *highlightThickness 0 widgetDefault + option add *troughColor #bdb6ad widgetDefault + } +} \ No newline at end of file diff --git a/modules/style/style.tcl b/modules/style/style.tcl new file mode 100644 index 00000000..1326daf9 --- /dev/null +++ b/modules/style/style.tcl @@ -0,0 +1,29 @@ +# style.tcl -- Styles for Tk. + +# $Id: style.tcl,v 1.1 2004/03/17 21:27:47 davidw Exp $ + +# Copyright 2004 David N. Welton + +namespace eval style { + # Available styles + variable available [list lobster as] +} + +# style::names -- +# +# Return the names of all available styles. + +proc style::names {} { + variable available + return $available +} + +# style::use -- +# +# Untill I see a better way of doing it, this is just a wrapper +# for package require. The problem is that 'use'ing different +# styles won't undo the changes made by previous styles. + +proc style::use {newstyle} { + package require style::${newstyle} +} \ No newline at end of file From c4421941541738a93ae05bfff43fcaa4803534d9 Mon Sep 17 00:00:00 2001 From: davidw Date: Thu, 18 Mar 2004 08:56:47 +0000 Subject: [PATCH 0004/1290] * pkgIndex.tcl: Added package index. --- modules/style/ChangeLog | 4 ++++ modules/style/lobster.tcl | 8 ++++++-- modules/style/pkgIndex.tcl | 13 +++++++++++++ modules/style/style.tcl | 4 +++- 4 files changed, 26 insertions(+), 3 deletions(-) create mode 100644 modules/style/pkgIndex.tcl diff --git a/modules/style/ChangeLog b/modules/style/ChangeLog index 1880b717..8a4301b1 100644 --- a/modules/style/ChangeLog +++ b/modules/style/ChangeLog @@ -1,3 +1,7 @@ +2004-03-18 David N. Welton + + * pkgIndex.tcl: Added package index. + 2004-03-17 David N. Welton * style.tcl: Created style package. diff --git a/modules/style/lobster.tcl b/modules/style/lobster.tcl index e9bd647a..7fcedd93 100644 --- a/modules/style/lobster.tcl +++ b/modules/style/lobster.tcl @@ -3,16 +3,20 @@ # The code formerly known as "gtklook" on the Tcl'ers # wiki. Most of this code was originally written by Jeremy Collins. -# $Id: lobster.tcl,v 1.1 2004/03/17 21:27:47 davidw Exp $ +# $Id: lobster.tcl,v 1.2 2004/03/18 08:56:47 davidw Exp $ package provide style::lobster 0.1 namespace eval styles::lobster { if { [tk windowingsystem] == "x11" } { + set size -12 + set family Helvetica + font create LobsterFont -size $size -family $family + option add *borderWidth 1 widgetDefault option add *activeBorderWidth 1 widgetDefault option add *selectBorderWidth 1 widgetDefault - option add *font -adobe-helvetica-medium-r-normal-*-12-*-*-*-*-*-* widgetDefault + option add *font LobsterFont widgetDefault option add *padX 2 widgetDefault option add *padY 4 widgetDefault diff --git a/modules/style/pkgIndex.tcl b/modules/style/pkgIndex.tcl new file mode 100644 index 00000000..0f1c979c --- /dev/null +++ b/modules/style/pkgIndex.tcl @@ -0,0 +1,13 @@ +# Tcl package index file, version 1.1 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +package ifneeded style 0.1 [list source [file join $dir style.tcl]] +package ifneeded style::as 1.1 [list source [file join $dir as.tcl]] +package ifneeded style::lobster 0.1 [list source [file join $dir lobster.tcl]] diff --git a/modules/style/style.tcl b/modules/style/style.tcl index 1326daf9..3d7b3bd3 100644 --- a/modules/style/style.tcl +++ b/modules/style/style.tcl @@ -1,9 +1,11 @@ # style.tcl -- Styles for Tk. -# $Id: style.tcl,v 1.1 2004/03/17 21:27:47 davidw Exp $ +# $Id: style.tcl,v 1.2 2004/03/18 08:56:47 davidw Exp $ # Copyright 2004 David N. Welton +package provide style 0.1 + namespace eval style { # Available styles variable available [list lobster as] From 4dd98a41db04ab0068677e6a28ff236690e769af Mon Sep 17 00:00:00 2001 From: davidw Date: Thu, 25 Mar 2004 16:22:07 +0000 Subject: [PATCH 0005/1290] * lobster.tcl: Added internal padding to Labelframe. They look better if they have some empty space in them. Added Scrollbar things from as.tcl, which make the scrollbars nicer by narrowing them a bit. --- modules/style/ChangeLog | 7 +++++++ modules/style/as.tcl | 1 + modules/style/lobster.tcl | 14 ++++++++++---- 3 files changed, 18 insertions(+), 4 deletions(-) diff --git a/modules/style/ChangeLog b/modules/style/ChangeLog index 8a4301b1..806a6809 100644 --- a/modules/style/ChangeLog +++ b/modules/style/ChangeLog @@ -1,3 +1,10 @@ +2004-03-25 David N. Welton + + * lobster.tcl: Added internal padding to Labelframe. They look + better if they have some empty space in them. Added Scrollbar + things from as.tcl, which make the scrollbars nicer by narrowing + them a bit. + 2004-03-18 David N. Welton * pkgIndex.tcl: Added package index. diff --git a/modules/style/as.tcl b/modules/style/as.tcl index 31fe337b..e537aa7b 100644 --- a/modules/style/as.tcl +++ b/modules/style/as.tcl @@ -117,6 +117,7 @@ namespace eval style::as { option add *Scrollbar.highlightThickness 0 widgetDefault ## PanedWindow + ## option add *Panedwindow.borderWidth 0 widgetDefault option add *Panedwindow.sashwidth 3 widgetDefault diff --git a/modules/style/lobster.tcl b/modules/style/lobster.tcl index 7fcedd93..aaa14903 100644 --- a/modules/style/lobster.tcl +++ b/modules/style/lobster.tcl @@ -3,7 +3,7 @@ # The code formerly known as "gtklook" on the Tcl'ers # wiki. Most of this code was originally written by Jeremy Collins. -# $Id: lobster.tcl,v 1.2 2004/03/18 08:56:47 davidw Exp $ +# $Id: lobster.tcl,v 1.3 2004/03/25 16:22:08 davidw Exp $ package provide style::lobster 0.1 @@ -49,10 +49,16 @@ namespace eval styles::lobster { option add *Menubutton.highlightThickness 0 widgetDefault option add *Menubutton.borderWidth 0 widgetDefault - option add *Labelframe.borderWidth 2 - option add *Frame.borderWidth 2 + option add *Labelframe.borderWidth 2 widgetDefault + option add *Frame.borderWidth 2 widgetDefault + option add *Labelframe.padY 8 widgetDefault + option add *Labelframe.padX 12 widgetDefault option add *highlightThickness 0 widgetDefault - option add *troughColor #bdb6ad widgetDefault + option add *troughColor #c3c3c3 widgetDefault + + option add *Scrollbar.width 12 widgetDefault + option add *Scrollbar.borderWidth 1 widgetDefault + option add *Scrollbar.highlightThickness 0 widgetDefault } } \ No newline at end of file From 342534a0db2b4c8d7a79abddd92b73b69a600880 Mon Sep 17 00:00:00 2001 From: jfontain Date: Tue, 13 Apr 2004 14:18:56 +0000 Subject: [PATCH 0006/1290] used C style formatting in expressions. --- modules/tkpiechart/objselec.tcl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/modules/tkpiechart/objselec.tcl b/modules/tkpiechart/objselec.tcl index b684c342..8b83c470 100644 --- a/modules/tkpiechart/objselec.tcl +++ b/modules/tkpiechart/objselec.tcl @@ -1,7 +1,7 @@ # copyright (C) 1997-98 Jean-Luc Fontaine (mailto:jfontain@free.fr) # this program is free software: please read the COPYRIGHT file enclosed in this package or use the Help Copyright menu -# $Id: objselec.tcl,v 1.10 2002/05/30 17:11:45 jfontain Exp $ +# $Id: objselec.tcl,v 1.11 2004/04/13 14:18:56 jfontain Exp $ # implements selection on a list of object identifiers (sortable list of integer), for a listbox implementation, for example @@ -20,7 +20,7 @@ set last [lsearch -exact $list $selector::($this,lastSelected)] set index [lsearch -exact $list $id] selector::clear $this - if {$index>$last} { + if {$index > $last} { selector::set $this [lrange $list $last $index] 1 } else { selector::set $this [lrange $list $index $last] 1 From 674db74d63cc33649cfb7972002ad140d73f6cd9 Mon Sep 17 00:00:00 2001 From: Andreas Kupries Date: Fri, 16 Apr 2004 05:21:55 +0000 Subject: [PATCH 0007/1290] New module 'plotchart', by Arjen Markus. --- all.tcl | 26 +- examples/plotchart/plotdemos1.tcl | 142 ++++ examples/plotchart/plotdemos2.tcl | 72 ++ installed_modules.tcl | 1 + modules/plotchart/ChangeLog | 4 + modules/plotchart/pkgIndex.tcl | 12 + modules/plotchart/plot3d.tcl | 233 +++++++ modules/plotchart/plotaxis.tcl | 346 ++++++++++ modules/plotchart/plotchart.man | 1048 +++++++++++++++++++++++++++++ modules/plotchart/plotchart.tcl | 748 ++++++++++++++++++++ modules/plotchart/plotchart.test | 407 +++++++++++ modules/plotchart/plotpriv.tcl | 834 +++++++++++++++++++++++ modules/plotchart/scaling.tcl | 69 ++ 13 files changed, 3941 insertions(+), 1 deletion(-) create mode 100755 examples/plotchart/plotdemos1.tcl create mode 100755 examples/plotchart/plotdemos2.tcl create mode 100644 modules/plotchart/ChangeLog create mode 100755 modules/plotchart/pkgIndex.tcl create mode 100755 modules/plotchart/plot3d.tcl create mode 100755 modules/plotchart/plotaxis.tcl create mode 100755 modules/plotchart/plotchart.man create mode 100755 modules/plotchart/plotchart.tcl create mode 100755 modules/plotchart/plotchart.test create mode 100755 modules/plotchart/plotpriv.tcl create mode 100755 modules/plotchart/scaling.tcl diff --git a/all.tcl b/all.tcl index e8bf7766..233989c6 100644 --- a/all.tcl +++ b/all.tcl @@ -8,7 +8,7 @@ # Copyright (c) 1998-2000 by Ajuba Solutions. # All rights reserved. # -# RCS: @(#) $Id: all.tcl,v 1.2 2003/11/28 22:42:03 andreas_kupries Exp $ +# RCS: @(#) $Id: all.tcl,v 1.3 2004/04/16 05:21:55 andreas_kupries Exp $ set old_auto_path $auto_path @@ -182,6 +182,30 @@ foreach module $modules { } return $msg } + + # This constraint restricts certain tests to run on tcl 8.3+, and tcl8.4+ + if {[package vsatisfies [package provide tcltest] 2.0]} { + # tcltest2.0+ has an API to specify a test constraint + ::tcltest::testConstraint tcl8.3only \ + [expr {![package vsatisfies [package provide Tcl] 8.4]}] + ::tcltest::testConstraint tcl8.3plus \ + [expr {[package vsatisfies [package provide Tcl] 8.3]}] + ::tcltest::testConstraint tcl8.4plus \ + [expr {[package vsatisfies [package provide Tcl] 8.4]}] + + ::tcltest::testConstraint tk \ + [expr {![catch {package present Tk}]}] + } else { + # In tcltest1.0, a global variable needs to be set directly. + set ::tcltest::testConstraints(tcl8.3only) \ + [expr {![package vsatisfies [package provide Tcl] 8.4]}] + set ::tcltest::testConstraints(tcl8.3plus) \ + [expr {[package vsatisfies [package provide Tcl] 8.3]}] + set ::tcltest::testConstraints(tcl8.4plus) \ + [expr {[package vsatisfies [package provide Tcl] 8.4]}] + set ::tcltest::testConstraints(tk) \ + [expr {![catch {package present Tk}]}] + } } interp alias $c ::tcltest::cleanupTestsHook {} \ ::tcltest::cleanupTestsHook $c diff --git a/examples/plotchart/plotdemos1.tcl b/examples/plotchart/plotdemos1.tcl new file mode 100755 index 00000000..bc054d27 --- /dev/null +++ b/examples/plotchart/plotdemos1.tcl @@ -0,0 +1,142 @@ +#! /bin/sh +# -*- tcl -*- \ +exec tclsh "$0" ${1+"$@"} + +package require Tcl 8.3 +package require Tk +source ../../modules/plotchart/plotchart.tcl +package require Plotchart + +# testplot.tcl -- +# Test program for the Plotchart package +# + +# +# Main code +# +canvas .c -background white -width 400 -height 200 +canvas .c2 -background white -width 400 -height 200 +canvas .c3 -background white -width 400 -height 200 +pack .c .c2 .c3 -fill both -side top + +toplevel .h +canvas .h.c -background white -width 400 -height 200 +canvas .h.c2 -background white -width 400 -height 200 +pack .h.c .h.c2 -fill both -side top + +toplevel .v +canvas .v.c -background white -width 400 -height 200 +canvas .v.c2 -background white -width 400 -height 200 +canvas .v.c3 -background white -width 400 -height 200 +pack .v.c .v.c2 .v.c3 -fill both -side top + +set s [::Plotchart::createXYPlot .c {0.0 100.0 10.0} {0.0 100.0 20.0}] + +set xd 5.0 +set yd 20.0 +set xold 0.0 +set yold 50.0 + +$s dataconfig series1 -colour "red" + +for { set i 0 } { $i < 20 } { incr i } { + set xnew [expr {$xold+$xd}] + set ynew [expr {$yold+(rand()-0.5)*$yd}] + set ynew2 [expr {$yold+(rand()-0.5)*2.0*$yd}] + $s plot series1 $xnew $ynew + $s plot series2 $xnew $ynew2 + set xold $xnew + set yold $ynew +} + +$s xtext "X-coordinate" +$s ytext "Y-data" +$s title "Aha!" + +tkwait visibility .c +$s saveplot "aha.ps" + + +set s [::Plotchart::createPiechart .c2] + +$s plot {"Long names" 10 "Short names" 30 "Average" 40 + "Ultra-short names" 5} +# +# Note: title should be shifted up +# - distinguish a separate title area +# +$s title "Okay - this works" + + + +set s [::Plotchart::createPolarplot .c3 {3.0 1.0}] + +for { set angle 0 } { $angle < 360.0 } { set angle [expr {$angle+10.0}] } { + set rad [expr {1.0+cos($angle*$::Plotchart::torad)}] + $s plot "cardioid" $rad $angle +} + +$s title "Cardioid" + + +set s [::Plotchart::createBarchart .h.c {A B C D E} {0.0 10.0 2.0} 2] + +$s plot series1 {1.0 4.0 6.0 1.0 7.0} red +$s plot series2 {0.0 3.0 7.0 9.3 2.0} green +$s title "Arbitrary data" + + +set s [::Plotchart::createBarchart .h.c2 {A B C D E} {0.0 20.0 5.0} stacked] + +$s plot series1 {1.0 4.0 6.0 1.0 7.0} red +$s plot series2 {0.0 3.0 7.0 9.3 2.0} green +$s title "Stacked diagram" + + + +set s [::Plotchart::createHorizontalBarchart .v.c {0.0 10.0 2.0} {A B C D E} 2] + +$s plot series1 {1.0 4.0 6.0 1.0 7.0} red +$s plot series2 {0.0 3.0 7.0 9.3 2.0} green +$s title "Arbitrary data" + + +set s [::Plotchart::createHorizontalBarchart .v.c2 {0.0 20.0 5.0} {A B C D E} stacked] + +$s plot series1 {1.0 4.0 6.0 1.0 7.0} red +$s plot series2 {0.0 3.0 7.0 9.3 2.0} green +$s title "Stacked diagram" + + +set s [::Plotchart::createTimechart .v.c3 "1 january 2004" \ + "31 december 2004" 4] + +$s period "Spring" "1 march 2004" "1 june 2004" green +$s period "Summer" "1 june 2004" "1 september 2004" yellow +$s vertline "1 jan" "1 january 2004" +$s vertline "1 apr" "1 april 2004" +$s vertline "1 jul" "1 july 2004" +$s vertline "1 oct" "1 october 2004" +$s milestone "Longest day" "21 july 2004" +$s title "Seasons (northern hemisphere)" + +proc cowboyhat {x y} { + set x1 [expr {$x/9.0}] + set y1 [expr {$y/9.0}] + + expr { 3.0 * (1.0-($x1*$x1+$y1*$y1))*(1.0-($x1*$x1+$y1*$y1)) } +} + +toplevel .h3 +canvas .h3.c -bg white -width 400 -height 300 +canvas .h3.c2 -bg white -width 400 -height 250 +pack .h3.c .h3.c2 + +set s [::Plotchart::create3DPlot .h3.c {0 10 3} {-10 10 10} {0 10 2.5}] +$s title "3D Plot" +$s plotfunc cowboyhat + +set s [::Plotchart::create3DPlot .h3.c2 {0 10 3} {-10 10 10} {0 10 2.5}] +$s title "3D Plot - data " +$s colour "green" "black" +$s plotdata { {1.0 2.0 1.0 0.0} {1.1 3.0 1.1 -0.5} {3.0 1.0 4.0 5.0} } diff --git a/examples/plotchart/plotdemos2.tcl b/examples/plotchart/plotdemos2.tcl new file mode 100755 index 00000000..ebe201b0 --- /dev/null +++ b/examples/plotchart/plotdemos2.tcl @@ -0,0 +1,72 @@ +#! /bin/sh +# -*- tcl -*- \ +exec tclsh "$0" ${1+"$@"} + +package require Tcl 8.3 +package require Tk + +package require Plotchart + +# testplsec.tcl -- +# Second test program for the Plotchart package +# + +# +# Main code +# +canvas .c -background white -width 400 -height 200 +canvas .c2 -background white -width 400 -height 200 +pack .c .c2 -fill both -side top + +# +# Set up a strip chart +# +set s [::Plotchart::createStripchart .c {0.0 100.0 10.0} {0.0 100.0 20.0}] + +proc gendata {slipchart xold xd yold yd} { + set xnew [expr {$xold+$xd}] + set ynew [expr {$yold+(rand()-0.5)*$yd}] + set ynew2 [expr {$yold+(rand()-0.5)*2.0*$yd}] + $slipchart plot series1 $xnew $ynew + $slipchart plot series2 $xnew $ynew2 + + if { $xnew < 200 } { + after 500 [list gendata $slipchart $xnew $xd $ynew $yd] + } +} + +after 100 [list gendata $s 0.0 15.0 50.0 30.0] + +$s title "Aha!" + +# +# Set up an isometric plot +# +set s [::Plotchart::createIsometricPlot .c2 {0.0 100.0} {0.0 200.0} noaxes] +::Plotchart::setZoomPan .c2 +$s plot rectangle 10.0 10.0 50.0 50.0 green +$s plot filled-rectangle 20.0 20.0 40.0 40.0 red +$s plot filled-circle 70.0 70.0 40.0 yellow +$s plot circle 70.0 70.0 42.0 + +# +# Check the symbols +# +toplevel .h +canvas .h.c -bg white -width 400 -height 200 +pack .h.c -fill both +set s [::Plotchart::createXYPlot .h.c {0.0 100.0 10.0} {0.0 100.0 20.0}] + +$s dataconfig series1 -colour red -type symbol +$s dataconfig series2 -colour green -type both + +$s yconfig -format "%12.2e" + +set x 5.0 +foreach symbol {plus cross circle up down dot upfilled downfilled} { + $s dataconfig series1 -symbol $symbol + $s dataconfig series2 -symbol $symbol + $s plot series1 $x 50.0 + $s plot series2 $x 20 + set x [expr {$x+10}] +} diff --git a/installed_modules.tcl b/installed_modules.tcl index 6841c3f7..7bc67690 100755 --- a/installed_modules.tcl +++ b/installed_modules.tcl @@ -20,6 +20,7 @@ foreach {m pkg doc exa} { cursor _tcl _man _null datefield _tcl _man _null ipentry _tcl _man _null + plotchart _tcl _man _exa } { lappend modules $m set guide($m,pkg) $pkg diff --git a/modules/plotchart/ChangeLog b/modules/plotchart/ChangeLog new file mode 100644 index 00000000..200da399 --- /dev/null +++ b/modules/plotchart/ChangeLog @@ -0,0 +1,4 @@ +2004-04-15 Andreas Kupries + + * New module 'plotchart', by Arjen Markus. + diff --git a/modules/plotchart/pkgIndex.tcl b/modules/plotchart/pkgIndex.tcl new file mode 100755 index 00000000..b04f3314 --- /dev/null +++ b/modules/plotchart/pkgIndex.tcl @@ -0,0 +1,12 @@ +# Tcl package index file, version 1.1 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +if {![package vsatisfies [package provide Tcl] 8.3]} {return} +package ifneeded Plotchart 0.9 [list source [file join $dir plotchart.tcl]] diff --git a/modules/plotchart/plot3d.tcl b/modules/plotchart/plot3d.tcl new file mode 100755 index 00000000..fe395ee9 --- /dev/null +++ b/modules/plotchart/plot3d.tcl @@ -0,0 +1,233 @@ +# plot3d.tcl -- +# Facilities to draw simple 3D plots in a dedicated canvas +# +# Note: +# This source file contains the private functions for 3D plotting. +# It is the companion of "plotchart.tcl" +# + +# Draw3DAxes -- +# Draw the axes in a 3D plot +# Arguments: +# w Name of the canvas +# xmin Minimum x coordinate +# xmax Maximum x coordinate +# xstep Step size +# ymin Minimum y coordinate +# ymax Maximum y coordinate +# ystep Step size +# zmin Minimum z coordinate +# zmax Maximum z coordinate +# zstep Step size +# Result: +# None +# Side effects: +# Axes drawn in canvas +# +proc ::Plotchart::Draw3DAxes { w xmin ymin zmin + xmax ymax zmax + xstep ystep zstep } { + variable scaling + + $w delete axis3d + + # + # Create the support lines first + # + foreach {pxxmin pyxmin} [coords3DToPixel $w $scaling($w,xmin) $scaling($w,ymin) $scaling($w,zmin)] {break} + foreach {pxxmax pyxmax} [coords3DToPixel $w $scaling($w,xmax) $scaling($w,ymin) $scaling($w,zmin)] {break} + foreach {pxymax pyymax} [coords3DToPixel $w $scaling($w,xmax) $scaling($w,ymax) $scaling($w,zmin)] {break} + foreach {pxzmax pyzmax} [coords3DToPixel $w $scaling($w,xmax) $scaling($w,ymin) $scaling($w,zmax)] {break} + foreach {pxzmx2 pyzmx2} [coords3DToPixel $w $scaling($w,xmin) $scaling($w,ymin) $scaling($w,zmax)] {break} + foreach {pxymx2 pyymx2} [coords3DToPixel $w $scaling($w,xmin) $scaling($w,ymax) $scaling($w,zmin)] {break} + foreach {pxzymx pyzymx} [coords3DToPixel $w $scaling($w,xmax) $scaling($w,ymax) $scaling($w,zmax)] {break} + + $w create line $pxxmax $pyxmax $pxxmin $pyxmin \ + -fill black -tag axis3d + $w create line $pxxmax $pyxmax $pxymax $pyymax \ + -fill black -tag axis3d + $w create line $pxxmin $pyxmin $pxymx2 $pyymx2 \ + -fill black -tag axis3d + $w create line $pxymax $pyymax $pxymx2 $pyymx2 \ + -fill black -tag axis3d + $w create line $pxzmax $pyzmax $pxzymx $pyzymx \ + -fill black -tag axis3d + $w create line $pxxmax $pyxmax $pxzmax $pyzmax \ + -fill black -tag axis3d + $w create line $pxxmin $pyxmin $pxzmx2 $pyzmx2 \ + -fill black -tag axis3d + $w create line $pxzmax $pyzmax $pxzmx2 $pyzmx2 \ + -fill black -tag axis3d + $w create line $pxymax $pyymax $pxzymx $pyzymx \ + -fill black -tag axis3d + + # + # Numbers to the z-axis + # + set z $zmin + while { $z < $zmax+0.5*$zstep } { + foreach {xcrd ycrd} [coords3DToPixel $w $xmin $ymin $z] {break} + $w create text $xcrd $ycrd -text $z -tag axis3d -anchor e + set z [expr {$z+$zstep}] + } + + # + # Numbers to the x-axis + # + set x $xmin + while { $x < $xmax+0.5*$xstep } { + foreach {xcrd ycrd} [coords3DToPixel $w $x $ymax $zmin] {break} + $w create text $xcrd $ycrd -text $x -tag axis3d -anchor nw + set x [expr {$x+$xstep}] + } + + # + # Numbers to the y-axis + # + set y $ymin + while { $y < $ymax+0.5*$ystep } { + foreach {xcrd ycrd} [coords3DToPixel $w $xmin $y $zmin] {break} + $w create text $xcrd $ycrd -text $y -tag axis3d -anchor n + set y [expr {$y+$ystep}] + } + + set scaling($w,xstep) $xstep + set scaling($w,ystep) $ystep + set scaling($w,zstep) $zstep + + # + # Set the default grid size + # + GridSize3D $w 10 10 +} + +# GridSize3D -- +# Set the grid size for a 3D function plot +# Arguments: +# w Name of the canvas +# nxcells Number of cells in x-direction +# nycells Number of cells in y-direction +# Result: +# None +# Side effect: +# Store the grid sizes in the private array +# +proc ::Plotchart::GridSize3D { w nxcells nycells } { + variable scaling + + set scaling($w,nxcells) $nxcells + set scaling($w,nycells) $nycells +} + +# Draw3DFunction -- +# Plot a function of x and y +# Arguments: +# w Name of the canvas +# function Name of a procedure implementing the function +# Result: +# None +# Side effect: +# The plot of the function - given the grid +# +proc ::Plotchart::Draw3DFunction { w function } { + variable scaling + + set nxcells $scaling($w,nxcells) + set nycells $scaling($w,nycells) + set xmin $scaling($w,xmin) + set xmax $scaling($w,xmax) + set ymin $scaling($w,ymin) + set ymax $scaling($w,ymax) + set dx [expr {($xmax-$xmin)/double($nxcells)}] + set dy [expr {($ymax-$ymin)/double($nycells)}] + + foreach {fill border} $scaling($w,colours) {break} + + # + # Draw the quadrangles making up the plot in the right order: + # first y from minimum to maximum + # then x from maximum to minimum + # + for { set j 0 } { $j < $nycells } { incr j } { + set y1 [expr {$ymin + $dy*$j}] + set y2 [expr {$y1 + $dy}] + for { set i $nxcells } { $i > 0 } { incr i -1 } { + set x2 [expr {$xmin + $dx*$i}] + set x1 [expr {$x2 - $dx}] + + set z11 [$function $x1 $y1] + set z12 [$function $x1 $y2] + set z21 [$function $x2 $y1] + set z22 [$function $x2 $y2] + + foreach {px11 py11} [coords3DToPixel $w $x1 $y1 $z11] {break} + foreach {px12 py12} [coords3DToPixel $w $x1 $y2 $z12] {break} + foreach {px21 py21} [coords3DToPixel $w $x2 $y1 $z21] {break} + foreach {px22 py22} [coords3DToPixel $w $x2 $y2 $z22] {break} + + $w create polygon $px11 $py11 $px21 $py21 $px22 $py22 \ + $px12 $py12 $px11 $py11 \ + -fill $fill -outline $border + } + } +} + +# Draw3DData -- +# Plot a matrix of data as a function of x and y +# Arguments: +# w Name of the canvas +# data Nested list of data in the form of a matrix +# Result: +# None +# Side effect: +# The plot of the data +# +proc ::Plotchart::Draw3DData { w data } { + variable scaling + + set nxcells [llength [lindex $data 0]] + set nycells [llength $data] + incr nxcells -1 + incr nycells -1 + + set xmin $scaling($w,xmin) + set xmax $scaling($w,xmax) + set ymin $scaling($w,ymin) + set ymax $scaling($w,ymax) + set dx [expr {($xmax-$xmin)/double($nxcells)}] + set dy [expr {($ymax-$ymin)/double($nycells)}] + + foreach {fill border} $scaling($w,colours) {break} + + # + # Draw the quadrangles making up the data in the right order: + # first y from minimum to maximum + # then x from maximum to minimum + # + for { set j 0 } { $j < $nycells } { incr j } { + set z1data [lindex $data $j] + set z2data [lindex $data [expr {$j+1}]] + set y1 [expr {$ymin + $dy*$j}] + set y2 [expr {$y1 + $dy}] + for { set i $nxcells } { $i > 0 } { incr i -1 } { + set x2 [expr {$xmin + $dx*$i}] + set x1 [expr {$x2 - $dx}] + + set z11 [lindex $z1data [expr {$i-1}]] + set z21 [lindex $z1data $i ] + set z12 [lindex $z2data [expr {$i-1}]] + set z22 [lindex $z2data $i ] + + foreach {px11 py11} [coords3DToPixel $w $x1 $y1 $z11] {break} + foreach {px12 py12} [coords3DToPixel $w $x1 $y2 $z12] {break} + foreach {px21 py21} [coords3DToPixel $w $x2 $y1 $z21] {break} + foreach {px22 py22} [coords3DToPixel $w $x2 $y2 $z22] {break} + + $w create polygon $px11 $py11 $px21 $py21 $px22 $py22 \ + $px12 $py12 $px11 $py11 \ + -fill $fill -outline $border + } + } +} + + diff --git a/modules/plotchart/plotaxis.tcl b/modules/plotchart/plotaxis.tcl new file mode 100755 index 00000000..fe9c1ebc --- /dev/null +++ b/modules/plotchart/plotaxis.tcl @@ -0,0 +1,346 @@ +# plotaxis.tcl -- +# Facilities to draw simple plots in a dedicated canvas +# +# Note: +# This source file contains the functions for drawing the axes. +# It is the companion of "plotchart.tcl" +# + +# DrawYaxis -- +# Draw the y-axis +# Arguments: +# w Name of the canvas +# ymin Minimum y coordinate +# ymax Maximum y coordinate +# ystep Step size +# Result: +# None +# Side effects: +# Axis drawn in canvas +# +proc ::Plotchart::DrawYaxis { w ymin ymax ydelt } { + variable scaling + + set scaling($w,ydelt) $ydelt + + $w delete yaxis + + $w create line $scaling($w,pxmin) $scaling($w,pymin) \ + $scaling($w,pxmin) $scaling($w,pymax) \ + -fill black -tag yaxis + + set format "" + if { [info exists scaling($w,-format,y)] } { + set format $scaling($w,-format,y) + } + + set y $ymin + while { $y < $ymax+0.5*$ydelt } { + foreach {xcrd ycrd} [coordsToPixel $w $scaling($w,xmin) $y] {break} + set ylabel $y + if { $format != "" } { + set ylabel [format $format $y] + } + $w create text $xcrd $ycrd -text $ylabel -tag yaxis -anchor e + set y [expr {$y+$ydelt}] + } +} + +# DrawXaxis -- +# Draw the x-axis +# Arguments: +# w Name of the canvas +# xmin Minimum x coordinate +# xmax Maximum x coordinate +# xstep Step size +# Result: +# None +# Side effects: +# Axis drawn in canvas +# +proc ::Plotchart::DrawXaxis { w xmin xmax xdelt } { + variable scaling + + set scaling($w,xdelt) $xdelt + + $w delete xaxis + + $w create line $scaling($w,pxmin) $scaling($w,pymax) \ + $scaling($w,pxmax) $scaling($w,pymax) \ + -fill black -tag xaxis + + set format "" + if { [info exists scaling($w,-format,x)] } { + set format $scaling($w,-format,x) + } + + set x $xmin + while { $x < $xmax+0.5*$xdelt } { + foreach {xcrd ycrd} [coordsToPixel $w $x $scaling($w,ymin)] {break} + + set xlabel $x + if { $format != "" } { + set xlabel [format $format $x] + } + $w create text $xcrd $ycrd -text $xlabel -tag xaxis -anchor n + set x [expr {$x+$xdelt}] + } + + set scaling($w,xdelt) $xdelt +} + +# DrawXtext -- +# Draw text to the x-axis +# Arguments: +# w Name of the canvas +# text Text to be drawn +# Result: +# None +# Side effects: +# Text drawn in canvas +# +proc ::Plotchart::DrawXtext { w text } { + variable scaling + + set xt [expr {($scaling($w,pxmin)+$scaling($w,pxmax))/2}] + set yt [expr {$scaling($w,pymax)+12}] + + $w create text $xt $yt -text $text -fill black -anchor n +} + +# DrawYtext -- +# Draw text to the y-axis +# Arguments: +# w Name of the canvas +# text Text to be drawn +# Result: +# None +# Side effects: +# Text drawn in canvas +# +proc ::Plotchart::DrawYtext { w text } { + variable scaling + + set xt $scaling($w,pxmin) + set yt [expr {$scaling($w,pymin)-8}] + + $w create text $xt $yt -text $text -fill black -anchor se +} + +# DrawPolarAxes -- +# Draw thw two polar axes +# Arguments: +# w Name of the canvas +# rad_max Maximum radius +# rad_step Step in radius +# Result: +# None +# Side effects: +# Axes drawn in canvas +# +proc ::Plotchart::DrawPolarAxes { w rad_max rad_step } { + + # + # Draw the spikes + # + set angle 0.0 + + foreach {xcentre ycentre} [polarToPixel $w 0.0 0.0] {break} + + while { $angle < 360.0 } { + foreach {xcrd ycrd} [polarToPixel $w $rad_max $angle] {break} + foreach {xtxt ytxt} [polarToPixel $w [expr {1.05*$rad_max}] $angle] {break} + $w create line $xcentre $ycentre $xcrd $ycrd + if { $xcrd > $xcentre } { + set dir w + } else { + set dir e + } + $w create text $xtxt $ytxt -text $angle -anchor $dir + + set angle [expr {$angle+30}] + } + + # + # Draw the concentric circles + # + set rad $rad_step + + while { $rad < $rad_max+0.5*$rad_step } { + foreach {xright ytxt} [polarToPixel $w $rad 0.0] {break} + foreach {xleft ycrd} [polarToPixel $w $rad 180.0] {break} + foreach {xcrd ytop} [polarToPixel $w $rad 90.0] {break} + foreach {xcrd ybottom} [polarToPixel $w $rad 270.0] {break} + + $w create oval $xleft $ytop $xright $ybottom + + $w create text $xright [expr {$ytxt+3}] -text $rad -anchor n + + set rad [expr {$rad+$rad_step}] + } +} + +# DrawXlabels -- +# Draw the labels to an x-axis (barchart) +# Arguments: +# w Name of the canvas +# xlabels List of labels +# noseries Number of series or "stacked" +# Result: +# None +# Side effects: +# Axis drawn in canvas +# +proc ::Plotchart::DrawXlabels { w xlabels noseries } { + variable scaling + + $w delete xaxis + + $w create line $scaling($w,pxmin) $scaling($w,pymax) \ + $scaling($w,pxmax) $scaling($w,pymax) \ + -fill black -tag xaxis + + set x 0.5 + set scaling($w,ybase) {} + foreach label $xlabels { + foreach {xcrd ycrd} [coordsToPixel $w $x $scaling($w,ymin)] {break} + $w create text $xcrd $ycrd -text $label -tag xaxis -anchor n + set x [expr {$x+1.0}] + + lappend scaling($w,ybase) 0.0 + } + + set scaling($w,xbase) 0.0 + + if { $noseries != "stacked" } { + set scaling($w,stacked) 0 + set scaling($w,xshift) [expr {1.0/$noseries}] + set scaling($w,barwidth) [expr {1.0/$noseries}] + } else { + set scaling($w,stacked) 1 + set scaling($w,xshift) 0.0 + set scaling($w,barwidth) 0.8 + set scaling($w,xbase) 0.1 + } +} + +# DrawYlabels -- +# Draw the labels to a y-axis (barchart) +# Arguments: +# w Name of the canvas +# ylabels List of labels +# noseries Number of series or "stacked" +# Result: +# None +# Side effects: +# Axis drawn in canvas +# +proc ::Plotchart::DrawYlabels { w ylabels noseries } { + variable scaling + + $w delete yaxis + + $w create line $scaling($w,pxmin) $scaling($w,pymin) \ + $scaling($w,pxmin) $scaling($w,pymax) \ + -fill black -tag yaxis + + set y 0.5 + set scaling($w,xbase) {} + foreach label $ylabels { + foreach {xcrd ycrd} [coordsToPixel $w $scaling($w,xmin) $y] {break} + $w create text $xcrd $ycrd -text $label -tag yaxis -anchor e + set y [expr {$y+1.0}] + + lappend scaling($w,xbase) 0.0 + } + + set scaling($w,ybase) 0.0 + + if { $noseries != "stacked" } { + set scaling($w,stacked) 0 + set scaling($w,yshift) [expr {1.0/$noseries}] + set scaling($w,barwidth) [expr {1.0/$noseries}] + } else { + set scaling($w,stacked) 1 + set scaling($w,yshift) 0.0 + set scaling($w,barwidth) 0.8 + set scaling($w,ybase) 0.1 + } +} + +# XConfig -- +# Configure the x-axis for an XY plot +# Arguments: +# w Name of the canvas +# args Option and value pairs +# Result: +# None +# +proc ::Plotchart::XConfig { w args } { + AxisConfig xyplot $w x DrawXaxis $args +} + +# YConfig -- +# Configure the y-axis for an XY plot +# Arguments: +# w Name of the canvas +# args Option and value pairs +# Result: +# None +# +proc ::Plotchart::YConfig { w args } { + AxisConfig xyplot $w y DrawYaxis $args +} + +# AxisConfig -- +# Configure an axis and redraw it if necessary +# Arguments: +# plottype Type of plot +# w Name of the canvas +# orient Orientation of the axis +# drawmethod Drawing method +# option_values Option/value pairs +# Result: +# None +# +proc ::Plotchart::AxisConfig { plottype w orient drawmethod option_values } { + variable scaling + variable axis_options + variable axis_option_clear + variable axis_option_values + + set clear_data 0 + + foreach {option value} $option_values { + set idx [lsearch $axis_options $option] + if { $idx < 0 } { + return -code error "Unknown or invalid option: $option (value: $value)" + } else { + set clear [lindex $axis_option_clear $idx] + set values [lindex $axis_option_values [incr idx]] + if { $values != "..." } { + if { [lsearch $values $value] < 0 } { + return -code error "Unknown or invalid value: $value for option $option - $values" + } + } + set scaling($w,$option,$orient) $value + if { $clear } { + set clear_data 1 + } + } + } + + if { $clear_data } { + $w delete data + } + + if { $orient == "x" } { + $drawmethod $w $scaling($w,xmin) $scaling($w,xmax) $scaling($w,xdelt) + } + if { $orient == "y" } { + $drawmethod $w $scaling($w,ymin) $scaling($w,ymax) $scaling($w,ydelt) + } + if { $orient == "z" } { + $drawmethod $w $scaling($w,zmin) $scaling($w,zmax) $scaling($w,zdelt) + } +} diff --git a/modules/plotchart/plotchart.man b/modules/plotchart/plotchart.man new file mode 100755 index 00000000..5334c485 --- /dev/null +++ b/modules/plotchart/plotchart.man @@ -0,0 +1,1048 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin Plotchart n 0.9] +[copyright {2004 Arjen Markus }] +[moddesc Plotchart] +[titledesc {Simple plotting and charting package}] +[require Tcl [opt 8.3]] +[require Plotchart [opt 0.9]] + +[description] +[para] + +Plotchart is a Tcl-only package that focuses on the easy creation of +xy-plots, barcharts and other common types of graphical presentations. +The emphasis is on ease of use, rather than flexibility. The procedures +that create a plot use the entire canvas window, making the layout +of the plot completely automatic. + +[para] + +This results in the creation of an xy-plot in, say, ten lines of code: + +[para] +[example { + package require Plotchart + + canvas .c -background white -width 400 -height 200 + pack .c -fill both + + # + # Create the plot with its x- and y-axes + # + set s [::Plotchart::createXYPlot .c {0.0 100.0 10.0} {0.0 100.0 20.0}] + + foreach {x y} {0.0 32.0 10.0 50.0 25.0 60.0 78.0 11.0 } { + $s plot series1 $x $y + } + + $s title "Data series" +}] +[para] + +A drawback of the package might be that it does not do any data +management. So if the canvas that holds the plot is to be resized, the +whole plot must be redrawn. + +The advantage, though, is that it offers a number of plot and chart +types: + +[list_begin bullet] + +[bullet] +XY-plots like the one shown above with any number of data series. + +[bullet] +Stripcharts, a kind of XY-plots where the horizontal axis is adjusted +automatically. The result is a kind of sliding window on the data +series. + +[bullet] +Polar plots, where the coordinates are polar instead of cartesian. + +[bullet] + +Isometric plots, where the scale of the coordinates in the two +directions is always the same, i.e. a circle in world coordinates +appears as a circle on the screen. + +[nl] + +You can zoom in and out, as well as pan with these plots ([emph Note:] +this works best if no axes are drawn, the zooming and panning routines +do not distinguish the axes), using the mouse buttons with the control +key and the arrow keys with the control key. + +[bullet] +Piecharts, with automatic scaling to indicate the proportions. + +[bullet] +Barcharts, with either vertical or horizontal bars, stacked bars or +bars side by side. + +[bullet] +Timecharts, where bars indicate a time period and milestones or other +important moments in time are represented by triangles. + +[bullet] +3D plots (both for displaying surfaces and 3D bars) +[list_end] + +[section "PLOT CREATION COMMANDS"] + +You create the plot or chart with one single command and then fill the +plot with data: + +[list_begin definitions] + +[call [cmd ::Plotchart::createXYPlot] [arg w] [arg xaxis] [arg yaxis]] + +Create a new xy-plot. + +[list_begin arg] +[arg_def widget w in] +Name of the [emph existing] canvas widget to hold the plot. + +[arg_def list xaxis in] +A 3-element list containing minimum, maximum and stepsize for the x-axis, in this order. + +[arg_def list yaxis in] +A 3-element list containing minimum, maximum and stepsize for the y-axis, in this order. + +[list_end] +[nl] + + +[call [cmd ::Plotchart::createStripchart] [arg w] [arg xaxis] [arg yaxis]] + +Create a new strip chart. The only difference to a regular XY plot is +that the x-axis will be automatically adjusted when the x-coordinate +of a new point exceeds the maximum. + +[list_begin arg] +[arg_def widget w in] +Name of the [emph existing] canvas widget to hold the plot. + +[arg_def list xaxis in] +A 3-element list containing minimum, maximum and stepsize for the x-axis, in this order. + +[arg_def list yaxis in] +A 3-element list containing minimum, maximum and stepsize for the y-axis, in this order. + +[list_end] +[nl] + + +[call [cmd ::Plotchart::createPolarPlot] [arg w] [arg radius_data]] + +Create a new polar plot. + +[list_begin arg] +[arg_def widget w in] +Name of the [emph existing] canvas widget to hold the plot. + +[arg_def list radius_data in] +A 2-element list containing maximum radius and stepsize for the radial +axis, in this order. + +[list_end] +[nl] + + +[call [cmd ::Plotchart::createIsometricPlot] [arg w] [arg xaxis] [arg yaxis] [arg stepsize]] + +Create a new isometric plot, where the vertical and the horizontal +coordinates are scaled so that a circle will truly appear as a circle. + +[list_begin arg] +[arg_def widget w in] +Name of the [emph existing] canvas widget to hold the plot. + +[arg_def list xaxis in] +A 2-element list containing minimum, and maximum for the x-axis, in this order. + +[arg_def list yaxis in] +A 2-element list containing minimum, and maximum for the y-axis, in this order. + +[arg_def float|[const noaxes] stepsize in] + +Either the stepsize used by both axes or the keyword [const noaxes] to +signal the plot that it should use the full area of the widget, to not +draw any of the axes. + +[list_end] +[nl] + + +[call [cmd ::Plotchart::create3DPlot] [arg w] [arg xaxis] [arg yaxis] [arg zaxis]] + +Create a new 3D plot. + +[list_begin arg] +[arg_def widget w in] +Name of the [emph existing] canvas widget to hold the plot. + +[arg_def list xaxis in] +A 3-element list containing minimum, maximum and stepsize for the x-axis, in this order. + +[arg_def list yaxis in] +A 3-element list containing minimum, maximum and stepsize for the y-axis, in this order. + +[arg_def list zaxis in] +A 3-element list containing minimum, maximum and stepsize for the z-axis, in this order. + +[list_end] +[nl] + + +[call [cmd ::Plotchart::createPiechart] [arg w]] + +Create a new piechart. + +[list_begin arg] +[arg_def widget w in] +Name of the [emph existing] canvas widget to hold the plot. + +[list_end] +[nl] + + +[call [cmd ::Plotchart::createBarchart] [arg w] [arg xlabels] [arg yaxis] [arg noseries]] + +Create a new barchart with vertical bars. The horizontal axis will +display the labels contained in the argument [arg xlabels]. The number +of series given by [arg noseries] determines both the width of the +bars, and the way the series will be drawn. + +[nl] + +If the keyword [const stacked] was specified the series will be drawn +stacked on top of each other. Otherwise each series that is drawn will +be drawn shifted. + +[list_begin arg] +[arg_def widget w in] +Name of the [emph existing] canvas widget to hold the plot. + +[arg_def list xlabels in] +List of labels for the x-axis. Its length also determines the number of +bars that will be plotted per series. + +[arg_def list yaxis in] +A 3-element list containing minimum, maximum and stepsize for the y-axis, in this order. + +[arg_def int|[const stacked] noseries in] +The number of data series that will be plotted. This has to be an +integer number greater than zero (if [const stacked] is not used). + +[list_end] +[nl] + + +[call [cmd ::Plotchart::createHorizontalBarchart] [arg w] [arg xlabels] [arg yaxis] [arg noseries]] + +Create a new barchart with horizontal bars. The vertical axis will +display the labels contained in the argument [arg ylabels]. The number +of series given by [arg noseries] determines both the width of the +bars, and the way the series will be drawn. + +[nl] + +If the keyword [const stacked] was specified the series will be drawn +stacked from left to right. Otherwise each series that is drawn will +be drawn shifted. + +[list_begin arg] +[arg_def widget w in] +Name of the [emph existing] canvas widget to hold the plot. + +[arg_def list ylabels in] +List of labels for the y-axis. Its length also determines the number of +bars that will be plotted per series. + +[arg_def list yaxis in] +A 3-element list containing minimum, maximum and stepsize for the x-axis, in this order. + +[arg_def int|[const stacked] noseries in] +The number of data series that will be plotted. This has to be an +integer number greater than zero (if [const stacked] is not used). + +[list_end] +[nl] + + +[call [cmd ::Plotchart::createTimechart] [arg w] [arg time_begin] [arg time_end] [arg noitems]] + +Create a new timechart. + +The time axis (= x-axis) goes from [arg time_begin] to [arg time_end], +and the vertical spacing is determined by the number of items to plot. + +[list_begin arg] +[arg_def widget w in] +Name of the [emph existing] canvas widget to hold the plot. + +[arg_def string time_begin in] +The start time given in a form that is recognised by the [cmd clock] +command (e.g. "1 january 2004"). + +[arg_def string time_end in] +The end time given in a form that is recognised by the [cmd clock] +command (e.g. "1 january 2004"). + +[arg_def int noitems in] +Expected/maximum number of items. This determines the vertical +spacing. + +[list_end] +[list_end] + +[section "PLOT METHODS"] + +Each of the creation commands explained in the last section returns +the name of a new object command that can be used to manipulate the +plot or chart. The subcommands available to a chart command depend on +the type of the chart. + +[para] + +General subcommands for all types of charts. $anyplot is the command +returned by the creation command: + +[list_begin definitions] +[call [cmd \$anyplot] title [arg text]] + +Specify the title of the whole chart. + +[list_begin arg] +[arg_def string text in] +The text of the title to be drawn. + +[list_end] +[nl] + + +[call [cmd \$anyplot] saveplot [arg filename]] + +Draws the plot into a file, uing PostScript. + +[list_begin arg] +[arg_def string filename in] +Contain the path name of the file to write the plot to. + +[list_end] +[nl] + + +[call [cmd \$anyplot] xtext [arg text]] + +Specify the title of the x-axis, for those plots that have a straight +x-axis. + +[list_begin arg] +[arg_def string text in] +The text of the x-axis label to be drawn. + +[list_end] +[nl] + + +[call [cmd \$anyplot] ytext [arg text]] + +Specify the title of the y-axis, for those plots that have a straight +y-axis. + +[list_begin arg] +[arg_def string text in] +The text of the y-axis label to be drawn. + +[list_end] +[nl] + + +[call [cmd \$anyplot] xconfig [option -option] [arg value] ...] + +Set one or more configuration parameters for the x-axis. + +The following options are known: + +[list_begin opt] + +[opt_def format fmt] +The format for the numbers along the axis. + +[opt_def ticklength length] +The length of the tickmarks (in pixels). + +[opt_def ticklines boolean] +Whether to draw ticklines ([const true]) or not ([const false]). + +[opt_def scale scale_data] +New scale data for the axis, i.e. a 3-element list containing minimum, +maximum and stepsize for the axis, in this order. + +[nl] +[emph Beware:] Setting this option will clear all data from the plot. + +[list_end] +[nl] + + +[call [cmd \$anyplot] yconfig [option -option] [arg value] ...] + +Set one or more configuration parameters for the y-axis. This method +accepts the same options and values as the method [method xconfig]. + +[list_end] +[para] + +[emph Note:] The commands [method xconfig] and [method yconfig] are +currently implemented only for XY-plots +and only the option [option -format] has any effect. + +[para] + +For [emph {xy plots}] and [emph stripcharts]: + +[list_begin definitions] +[call [cmd \$xyplot] plot [arg series] [arg xcrd] [arg ycrd]] + +Add a data point to the plot. + +[list_begin arg] +[arg_def string series in] +Name of the data series the new point belongs to. + +[arg_def float xcrd in] +X-coordinate of the new point. + +[arg_def float ycrd in] +Y-coordinate of the new point. + +[list_end] +[list_end] +[para] + +For [emph {polar plots}]: + +[list_begin definitions] +[call [cmd \$polarplot] plot [arg series] [arg radius] [arg angle]] + +Add a data point to the polar plot. + +[list_begin arg] +[arg_def string series in] +Name of the data series the new point belongs to. + +[arg_def float radius in] +Radial coordinate of the new point. + +[arg_def float angle in] +Angular coordinate of the new point (in degrees). + +[list_end] +[list_end] +[para] + +For [emph {3D plots}]: + +[list_begin definitions] +[call [cmd \$plot3d] plotfunc [arg function]] + +Plot a function defined over two variables [var x] and [var y]. + +The resolution is determined by the set grid sizes (see the method +[method gridsize] for more information). + +[list_begin arg] +[arg_def string function in] +Name of the procedure that calculates the z-value for the given x and +y coordinates. The procedure has to accept two float arguments (x is +first argument, y is second) and return a floating-point value. + +[list_end] +[nl] + + +[call [cmd \$plot3d] gridsize [arg nxcells] [arg nycells]] + +Set the grid size in the two directions. Together they determine how +many polygons will be drawn for a function plot. + +[list_begin arg] +[arg_def int nxcells in] +Number of grid cells in x direction. Has to be an integer number +greater than zero. + +[arg_def int nycells in] +Number of grid cells in y direction. Has to be an integer number +greater than zero. + +[list_end] +[nl] + + +[call [cmd \$plot3d] plotdata [arg data]] + +Plot a matrix of data. + +[list_begin arg] +[arg_def list data in] +The data to be plotted. The data has to be provided as a nested list +with 2 levels. The outer list contains rows, drawn in y-direction, and +each row is a list whose elements are drawn in x-direction, for the +columns. Example: + +[nl] +[example { + set data { + {1.0 2.0 3.0} + {4.0 5.0 6.0} + } +}] + +[list_end] +[nl] + + +[call [cmd \$plot3d] colours [arg fill] [arg border]] + +Configure the colours to use for polygon borders and inner area. + +[list_begin arg] + +[arg_def color fill in] +The colour to use for filling the polygons. + +[arg_def color border in] +The colour to use for the border of the polygons. + +[list_end] +[list_end] +[para] + +For [emph {xy plots}], [emph stripcharts] and [emph {polar plots}]: + +[list_begin definitions] +[call [cmd \$xyplot] dataconfig [arg series] [option -option] [arg value] ...] + +Set the value for one or more options regarding the drawing of data of +a specific series. + +[list_begin arg] +[arg_def string series in] +Name of the data series whose configuration we are changing. + +[list_end] +[nl] + +The following option are known: + +[list_begin opt] +[opt_def colour c] +[opt_def color c] +The colour to be used when drawing the data series. + +[opt_def type enum] +The drawing mode chosen for the series. +This can be one of [const line], [const symbol], or [const both]. + +[opt_def symbol enum] + +What kind of symbol to draw. The value of this option is ignored when +the drawing mode [const line] was chosen. This can be one of + +[const plus], [const cross], [const circle], [const up] (triangle +pointing up), [const down] (triangle pointing down), [const dot] +(filled circle), [const upfilled] or [const downfilled] (filled +triangles). + +[list_end] +[list_end] +[para] + +For [emph piecharts]: + +[list_begin definitions] +[call [cmd \$pie] plot [arg data]] + +Fill a piechart. + +[list_begin arg] +[arg_def list data in] +A list of pairs (labels and values). The values determine the relative +size of the circle segments. The labels are drawn beside the circle. + +[list_end] + +[call [cmd \$pie] colours [arg colour1] [arg colour2] ...] + +Set the colours to be used. + +[list_begin arg] +[arg_def color colour1 in] +The first colour. + +[arg_def color colour2 in] +The second colour, and so on. + +[list_end] +[list_end] +[para] + +For [emph {vertical barcharts}]: + +[list_begin definitions] +[call [cmd \$barchart] plot [arg series] [arg ydata] [arg colour]] + +Add a data series to a barchart. + +[list_begin arg] +[arg_def string series in] +Name of the series the values belong to. + +[arg_def list ydata in] +A list of values, one for each x-axis label. + +[arg_def color colour in] +The colour of the bars. + +[list_end] +[list_end] +[para] + +For [emph {horizontal barcharts}]: + +[list_begin definitions] +[call [cmd \$barchart] plot [arg series] [arg xdata] [arg colour]] + +Add a data series to a barchart. + +[list_begin arg] +[arg_def string series in] +Name of the series the values belong to. + +[arg_def list xdata in] +A list of values, one for each y-axis label. + +[arg_def color colour in] +The colour of the bars. + +[list_end] +[list_end] +[para] + +For [emph timecharts]: + +[list_begin definitions] +[call [cmd \$timechart] period [arg text] [arg time_begin] [arg time_end] [arg colour]] + +Add a time period to the chart. + +[list_begin arg] +[arg_def string text in] +The text describing the period. + +[arg_def string time_begin in] +Start time of the period. + +[arg_def string time_end in] +Stop time of the period. + +[arg_def color colour in] +The colour of the bar (defaults to black). + +[list_end] +[nl] + + +[call [cmd \$timechart] milestone [arg text] [arg time] [arg colour]] + +Add a [term milestone] (represented as an point-down triangle) to the +chart. + +[list_begin arg] +[arg_def string text in] +The text describing the milestone. + +[arg_def string time in] +Time at which the milestone must be positioned. + +[arg_def color colour in] +The colour of the triangle (defaults to black). + +[list_end] +[nl] + + +[call [cmd \$timechart] vertline [arg text] [arg time]] + +Add a vertical line (to indicate the start of the month for instance) +to the chart. + +[list_begin arg] +[arg_def string text in] +The text appearing at the top (an abbreviation of the +date/time for instance). + +[arg_def string time in] +Time at which the line must be positioned. + +[list_end] +[list_end] +[para] + +For [emph {isometric plots}] (to be extended): + +[list_begin definitions] +[call [cmd \$isoplot] plot rectangle [arg x1] [arg y1] [arg x2] [arg y2] [arg colour]] + +Plot the outlines of a rectangle. + +[list_begin arg] +[arg_def float x1 in] +Minimum x coordinate of the rectangle to be drawn. + +[arg_def float y1 in] +Minimum y coordinate of the rectangle. + +[arg_def float x2 in] +Maximum x coordinate of the rectangle to be drawn. + +[arg_def float y2 in] +Maximum y coordinate of the rectangle. + +[arg_def color colour in] +The colour of the rectangle. + +[list_end] +[nl] + + +[call [cmd \$isoplot] plot filled-rectangle [arg x1] [arg y1] [arg x2] [arg y2] [arg colour]] + +Plot a rectangle filled with the given colour. + +[list_begin arg] +[arg_def float x1 in] +Minimum x coordinate of the rectangle to be drawn. + +[arg_def float y1 in] +Minimum y coordinate of the rectangle. + +[arg_def float x2 in] +Maximum x coordinate of the rectangle to be drawn. + +[arg_def float y2 in] +Maximum y coordinate of the rectangle. + +[arg_def color colour in] +The colour of the rectangle. + +[list_end] +[nl] + + +[call [cmd \$isoplot] plot circle [arg xc] [arg yc] [arg radius] [arg colour]] + +Plot the outline of a circle. + +[list_begin arg] +[arg_def float xc in] +X coordinate of the circle's centre. + +[arg_def float yc in] +Y coordinate of the circle's centre. + +[arg_def color colour in] +The colour of the circle. + +[list_end] +[nl] + + +[call [cmd \$isoplot] plot filled-circle [arg xc] [arg yc] [arg radius] [arg colour]] + +Plot a circle filled with the given colour. + +[list_begin arg] +[arg_def float xc in] +X coordinate of the circle's centre. + +[arg_def float yc in] +Y coordinate of the circle's centre. + +[arg_def color colour in] +The colour of the circle. + +[list_end] +[list_end] +[para] + +There are a number of public procedures that may be useful in specific +situations: [emph "Pro memorie"]. + + +[section {COORDINATE TRANSFORMATIONS}] + +Besides the commands that deal with the plots and charts directly, +there are a number of commands that can be used to convert world +coordinates to pixels and vice versa. + +These include: + +[list_begin definitions] + +[call [cmd ::Plotchart::viewPort] [arg w] [arg pxmin] [arg pymin] [arg pxmax] [arg pymax]] + +Set the viewport for window [arg w]. Should be used in cooperation +with [cmd ::Plotchart::worldCoordinates]. + +[list_begin arg] +[arg_def widget w in] +Name of the window (canvas widget) in question. + +[arg_def float pxmin in] +Left-most pixel coordinate. + +[arg_def float pymin in] +Top-most pixel coordinate (remember: the vertical pixel coordinate +starts with 0 at the top!). + +[arg_def float pxmax in] +Right-most pixel coordinate. + +[arg_def float pymax in] +Bottom-most pixel coordinate. + +[list_end] +[nl] + + +[call [cmd ::Plotchart::worldCoordinates] [arg w] [arg xmin] [arg ymin] [arg xmax] [arg ymax]] + +Set the extreme world coordinates for window [arg w]. The world +coordinates need not be in ascending order (i.e. xmin can be larger +than xmax, so that a reversal of the x-axis is achieved). + +[list_begin arg] +[arg_def widget w in] +Name of the window (canvas widget) in question. + +[arg_def float xmin in] +X-coordinate to be mapped to left side of viewport. + +[arg_def float ymin in] +Y-coordinate to be mapped to bottom of viewport. + +[arg_def float xmax in] +X-coordinate to be mapped to right side of viewport. + +[arg_def float ymax in] +Y-coordinate to be mapped to top side of viewport. + +[list_end] +[nl] + + +[call [cmd ::Plotchart::world3DCoordinates] [arg w] [arg xmin] [arg ymin] [arg zmin] [arg xmax] [arg ymax] [arg zmax]] + +Set the extreme three-dimensional world coordinates for window +[arg w]. The world coordinates need not be in ascending order (i.e. xmin +can be larger than xmax, so that a reversal of the x-axis is +achieved). + +[list_begin arg] +[arg_def widget w in] +Name of the window (canvas widget) in question. + +[arg_def float xmin in] +X-coordinate to be mapped to front side of the 3D viewport. + +[arg_def float ymin in] +Y-coordinate to be mapped to left side of the viewport. + +[arg_def float zmin in] +Z-coordinate to be mapped to bottom of viewport. + +[arg_def float xmax in] +X-coordinate to be mapped to back side of viewport. + +[arg_def float ymax in] +Y-coordinate to be mapped to right side of viewport. + +[arg_def float zmax in] +Z-coordinate to be mapped to top side of viewport. + +[list_end] +[nl] + + +[call [cmd ::Plotchart::coordsToPixel] [arg w] [arg x] [arg y]] + +Return a list of pixel coordinates valid for the given window. + +[list_begin arg] +[arg_def widget w in] +Name of the window (canvas widget) in question. + +[arg_def float x in] +X-coordinate to be mapped. + +[arg_def float y in] +Y-coordinate to be mapped. + +[list_end] +[nl] + + +[call [cmd ::Plotchart::coords3DToPixel] [arg w] [arg x] [arg y] [arg z]] + +Return a list of pixel coordinates valid for the given window. + +[list_begin arg] +[arg_def widget w in] +Name of the window (canvas widget) in question. + +[arg_def float x in] +X-coordinate to be mapped. + +[arg_def float y in] +Y-coordinate to be mapped. + +[arg_def float y in] +Z-coordinate to be mapped. + +[list_end] +[nl] + + +[call [cmd ::Plotchart::polarCoordinates] [arg w] [arg radmax]] + +Set the extreme polar coordinates for window [arg w]. The angle always +runs from 0 to 360 degrees and the radius starts at 0. Hence you only +need to give the maximum radius. + +[emph Note:] If the viewport is not square, this procedure will not +adjust the extremes, so that would result in an elliptical plot. + +[list_begin arg] +[arg_def widget w in] +Name of the window (canvas widget) in question. + +[arg_def float radmax in] +Maximum radius. + +[list_end] +[nl] + + +[call [cmd ::Plotchart::polarToPixel] [arg w] [arg rad] [arg phi]] + +Wrapper for a call to [cmd ::Plotchart::coordsToPixel], which assumes +the world coordinates and viewport are set appropriately. Converts +polar coordinates to pixel coordinates. + +[emph Note:] To be useful it should be accompanied by a matching +[cmd ::Plotchart::worldCoordinates] procedure. + +[list_begin arg] +[arg_def widget w in] +Name of the window (canvas widget) in question. + +[arg_def float rad in] +Radius of the point. + +[arg_def float phi in] +Angle to the positive x-axis. + +[list_end] +[nl] + + +[call [cmd ::Plotchart::pixelToCoords] [arg w] [arg x] [arg y]] + +Return a list of world coordinates valid for the given window. + +[list_begin arg] +[arg_def widget w in] +Name of the window (canvas widget) in question. + +[arg_def float x in] +X-pixel to be mapped. + +[arg_def float y in] +Y-pixel to be mapped. + +[list_end] +[list_end] +[para] + +Furthermore there is a routine to determine "pretty" numbers for use +with an axis: + +[list_begin definitions] +[call [cmd ::Plotchart::determineScale] [arg xmin] [arg xmax]] + +Determine "pretty" numbers from the given range and return a list +containing the minimum, maximum and stepsize that can be used for a +(linear) axis. + +[list_begin arg] +[arg_def float xmin in] +Rough minimum value for the scaling + +[arg_def float xmax in] +Rough maximum value for the scaling. + +[list_end] +[list_end] + + +[section {ROOM FOR IMPROVEMENT}] + +In this version there are a lot of things that still need to +be implemented: + +[list_begin bullet] +[bullet] +General options like legends and text to the axes. + +[bullet] +More robust handling of incorrect calls (right now the procedures may +fail when called incorrectly): + +[list_begin bullet] +[bullet] +The axis drawing routines can not handle inverse axes right now. + +[bullet] +If the user provides an invalid date/time string, the routines simply +throw an error. + +[list_end] +[list_end] + + +[section {TODO - SOME PRIVATE NOTES}] + +I have the following wishlist: + +[list_begin bullet] +[bullet] +Isometric plots - allow new items to be implemented easily. + +[bullet] +Add support for histograms where the independent axis is numerical. + +[bullet] +A general 3D viewer - emphasis on geometry, not a ray-tracer. + +[list_end] + + +[keywords {graphical presentation} plotting charts {xy-plots}] +[keywords {bar charts} {strip charts} {polar plots}] +[keywords {isometric plots} {pie charts} {time charts}] +[keywords {3D surfaces} {3D bars} {coordinates}] +[keywords {coordinate transformations}] +[manpage_end] diff --git a/modules/plotchart/plotchart.tcl b/modules/plotchart/plotchart.tcl new file mode 100755 index 00000000..491fed84 --- /dev/null +++ b/modules/plotchart/plotchart.tcl @@ -0,0 +1,748 @@ +# plotchart.tcl -- +# Facilities to draw simple plots in a dedicated canvas +# +# Note: +# This source file contains the public functions. +# The others are contained in "plotpriv.tcl" +# + +# Plotchart -- +# Namespace to hold the procedures and the private data +# +namespace eval ::Plotchart { + variable scaling + variable methodProc + variable data_series + + namespace export worldCoordinates viewPort coordsToPixel \ + polarCoordinates setZoomPan \ + createXYPlot createPolarPlot createPiechart \ + createBarchart createHorizontalBarchart \ + createTimechart createStripchart \ + createIsometricPlot create3DPlot + + # + # Array linking procedures with methods + # + set methodProc(xyplot,title) DrawTitle + set methodProc(xyplot,xtext) DrawXtext + set methodProc(xyplot,ytext) DrawYtext + set methodProc(xyplot,plot) DrawData + set methodProc(xyplot,saveplot) SavePlot + set methodProc(xyplot,dataconfig) DataConfig + set methodProc(xyplot,xconfig) XConfig + set methodProc(xyplot,yconfig) YConfig + set methodProc(piechart,title) DrawTitle + set methodProc(piechart,plot) DrawPie + set methodProc(piechart,saveplot) SavePlot + set methodProc(polarplot,title) DrawTitle + set methodProc(polarplot,plot) DrawPolarData + set methodProc(polarplot,saveplot) SavePlot + set methodProc(polarplot,dataconfig) DataConfig + set methodProc(horizbars,title) DrawTitle + set methodProc(horizbars,xtext) DrawXtext + set methodProc(horizbars,ytext) DrawYtext + set methodProc(horizbars,plot) DrawHorizBarData + set methodProc(horizbars,saveplot) SavePlot + set methodProc(horizbars,colours) SetColours + set methodProc(horizbars,colors) SetColours + set methodProc(horizbars,xconfig) XConfig + set methodProc(vertbars,title) DrawTitle + set methodProc(vertbars,xtext) DrawXtext + set methodProc(vertbars,ytext) DrawYtext + set methodProc(vertbars,plot) DrawVertBarData + set methodProc(vertbars,saveplot) SavePlot + set methodProc(vertbars,colours) SetColours + set methodProc(vertbars,colors) SetColours + set methodProc(vertbars,yconfig) YConfig + set methodProc(timechart,title) DrawTitle + set methodProc(timechart,period) DrawTimePeriod + set methodProc(timechart,milestone) DrawTimeMilestone + set methodProc(timechart,vertline) DrawTimeVertLine + set methodProc(timechart,saveplot) SavePlot + set methodProc(stripchart,title) DrawTitle + set methodProc(stripchart,xtext) DrawXtext + set methodProc(stripchart,ytext) DrawYtext + set methodProc(stripchart,plot) DrawStripData + set methodProc(stripchart,saveplot) SavePlot + set methodProc(stripchart,dataconfig) DataConfig + set methodProc(stripchart,xconfig) XConfig + set methodProc(stripchart,yconfig) YConfig + set methodProc(isometric,title) DrawTitle + set methodProc(isometric,xtext) DrawXtext + set methodProc(isometric,ytext) DrawYtext + set methodProc(isometric,plot) DrawIsometricData + set methodProc(isometric,saveplot) SavePlot + set methodProc(3dplot,title) DrawTitle + set methodProc(3dplot,plotfunc) Draw3DFunction + set methodProc(3dplot,plotdata) Draw3DData + set methodProc(3dplot,gridsize) GridSize3D + set methodProc(3dplot,saveplot) SavePlot + set methodProc(3dplot,colour) SetColours + set methodProc(3dplot,color) SetColours + set methodProc(3dplot,xconfig) XConfig + set methodProc(3dplot,yconfig) YConfig + set methodProc(3dplot,zconfig) ZConfig + + # + # Auxiliary parameters + # + variable torad + set torad [expr {3.1415926/180.0}] + + variable options + variable option_keys + variable option_values + set options {-colour -color -symbol -type} + set option_keys {-colour -colour -symbol -type} + set option_values {-colour {...} + -symbol {plus cross circle up down dot upfilled downfilled} + -type {line symbol both} + } + + variable axis_options + variable axis_option_clear + variable axis_option_values + set axis_options {-format -ticklength -ticklines -scale} + set axis_option_clear { 0 0 0 1 } + set axis_option_values {-format {...} + -ticklength {...} + -ticklines {0 1} + -scale {...} + } +} + +# setZoomPan -- +# Set up the bindings for zooming and panning +# Arguments: +# w Name of the canvas window +# Result: +# None +# Side effect: +# Bindings set up +# +proc ::Plotchart::setZoomPan { w } { + set sqrt2 [expr {sqrt(2.0)}] + set sqrt05 [expr {sqrt(0.5)}] + + bind $w [list ::Plotchart::ScaleItems $w %x %y $sqrt2] + bind $w [list ::Plotchart::ScaleItems $w %x %y $sqrt2] + bind $w [list ::Plotchart::ScaleItems $w %x %y $sqrt05] + bind $w [list ::Plotchart::ScaleItems $w %x %y $sqrt05] + bind $w [list ::Plotchart::ScaleItems $w %x %y $sqrt05] + bind $w [list ::Plotchart::MoveItems $w 0 -40] + bind $w [list ::Plotchart::MoveItems $w 0 40] + bind $w [list ::Plotchart::MoveItems $w -40 0] + bind $w [list ::Plotchart::MoveItems $w 40 0] + focus $w +} + +# viewPort -- +# Set the pixel extremes for the graph +# Arguments: +# w Name of the canvas window +# pxmin Minimum X-coordinate +# pymin Minimum Y-coordinate +# pxmax Maximum X-coordinate +# pymax Maximum Y-coordinate +# Result: +# None +# Side effect: +# Array scaling filled +# +proc ::Plotchart::viewPort { w pxmin pymin pxmax pymax } { + variable scaling + + if { $pxmin >= $pxmax || $pymin >= $pymax } { + return -code error "Inconsistent bounds for viewport" + } + + set scaling($w,pxmin) $pxmin + set scaling($w,pymin) $pymin + set scaling($w,pxmax) $pxmax + set scaling($w,pymax) $pymax + set scaling($w,new) 1 +} + +# worldCoordinates -- +# Set the extremes for the world coordinates +# Arguments: +# w Name of the canvas window +# xmin Minimum X-coordinate +# ymin Minimum Y-coordinate +# xmax Maximum X-coordinate +# ymax Maximum Y-coordinate +# Result: +# None +# Side effect: +# Array scaling filled +# +proc ::Plotchart::worldCoordinates { w xmin ymin xmax ymax } { + variable scaling + + if { $xmin == $xmax || $ymin == $ymax } { + return -code error "Minimum and maximum must differ for world coordinates" + } + + set scaling($w,xmin) [expr {double($xmin)}] + set scaling($w,ymin) [expr {double($ymin)}] + set scaling($w,xmax) [expr {double($xmax)}] + set scaling($w,ymax) [expr {double($ymax)}] + + set scaling($w,new) 1 +} + +# polarCoordinates -- +# Set the extremes for the polar coordinates +# Arguments: +# w Name of the canvas window +# radmax Maximum radius +# Result: +# None +# Side effect: +# Array scaling filled +# +proc ::Plotchart::polarCoordinates { w radmax } { + variable scaling + + if { $radmax <= 0.0 } { + return -code error "Maximum radius must be positive" + } + + set scaling($w,xmin) [expr {-double($radmax)}] + set scaling($w,ymin) [expr {-double($radmax)}] + set scaling($w,xmax) [expr {double($radmax)}] + set scaling($w,ymax) [expr {double($radmax)}] + + set scaling($w,new) 1 +} + +# world3DCoordinates -- +# Set the extremes for the world coordinates in 3D plots +# Arguments: +# w Name of the canvas window +# xmin Minimum X-coordinate +# ymin Minimum Y-coordinate +# zmin Minimum Z-coordinate +# xmax Maximum X-coordinate +# ymax Maximum Y-coordinate +# zmax Maximum Z-coordinate +# Result: +# None +# Side effect: +# Array scaling filled +# +proc ::Plotchart::world3DCoordinates { w xmin ymin zmin xmax ymax zmax } { + variable scaling + + if { $xmin == $xmax || $ymin == $ymax || $zmin == $zmax } { + return -code error "Minimum and maximum must differ for world coordinates" + } + + set scaling($w,xmin) [expr {double($xmin)}] + set scaling($w,ymin) [expr {double($ymin)}] + set scaling($w,zmin) [expr {double($zmin)}] + set scaling($w,xmax) [expr {double($xmax)}] + set scaling($w,ymax) [expr {double($ymax)}] + set scaling($w,zmax) [expr {double($zmax)}] + + set scaling($w,new) 1 +} + +# coordsToPixel -- +# Convert world coordinates to pixel coordinates +# Arguments: +# w Name of the canvas +# xcrd X-coordinate +# ycrd Y-coordinate +# Result: +# List of two elements, x- and y-coordinates in pixels +# +proc ::Plotchart::coordsToPixel { w xcrd ycrd } { + variable scaling + + if { $scaling($w,new) == 1 } { + set scaling($w,new) 0 + set width [expr {$scaling($w,pxmax)-$scaling($w,pxmin)}] + set height [expr {$scaling($w,pymax)-$scaling($w,pymin)}] + + set dx [expr {$scaling($w,xmax)-$scaling($w,xmin)}] + set dy [expr {$scaling($w,ymax)-$scaling($w,ymin)}] + set scaling($w,xfactor) [expr {$width/$dx}] + set scaling($w,yfactor) [expr {$height/$dy}] + } + + set xpix [expr {$scaling($w,pxmin)+($xcrd-$scaling($w,xmin))*$scaling($w,xfactor)}] + set ypix [expr {$scaling($w,pymin)+($scaling($w,ymax)-$ycrd)*$scaling($w,yfactor)}] + return [list $xpix $ypix] +} + +# coords3DToPixel -- +# Convert world coordinates to pixel coordinates (3D plots) +# Arguments: +# w Name of the canvas +# xcrd X-coordinate +# ycrd Y-coordinate +# zcrd Z-coordinate +# Result: +# List of two elements, x- and y-coordinates in pixels +# +proc ::Plotchart::coords3DToPixel { w xcrd ycrd zcrd } { + variable scaling + + if { $scaling($w,new) == 1 } { + set scaling($w,new) 0 + set width [expr {$scaling($w,pxmax)-$scaling($w,pxmin)}] + set height [expr {$scaling($w,pymax)-$scaling($w,pymin)}] + + set dx [expr {$scaling($w,xmax)-$scaling($w,xmin)}] + set dy [expr {$scaling($w,ymax)-$scaling($w,ymin)}] + set dz [expr {$scaling($w,zmax)-$scaling($w,zmin)}] + set scaling($w,xyfactor) [expr {$scaling($w,yfract)*$width/$dx}] + set scaling($w,xzfactor) [expr {$scaling($w,zfract)*$height/$dx}] + set scaling($w,yfactor) [expr {$width/$dy}] + set scaling($w,zfactor) [expr {$height/$dz}] + } + + # + # The values for xcrd = xmax + # + set xpix [expr {$scaling($w,pxmin)+($ycrd-$scaling($w,ymin))*$scaling($w,yfactor)}] + set ypix [expr {$scaling($w,pymin)+($scaling($w,zmax)-$zcrd)*$scaling($w,zfactor)}] + + # + # Add the shift due to xcrd-xmax + # + set xpix [expr {$xpix + $scaling($w,xyfactor)*($xcrd-$scaling($w,xmax))}] + set ypix [expr {$ypix - $scaling($w,xzfactor)*($xcrd-$scaling($w,xmax))}] + + return [list $xpix $ypix] +} + +# pixelToCoords -- +# Convert pixel coordinates to world coordinates +# Arguments: +# w Name of the canvas +# xpix X-coordinate (pixel) +# ypix Y-coordinate (pixel) +# Result: +# List of two elements, x- and y-coordinates in world coordinate system +# +proc ::Plotchart::pixelToCoords { w xpix ypix } { + variable scaling + + if { $scaling($w,new) == 1 } { + set scaling($w,new) 0 + set width [expr {$scaling($w,pxmax)-$scaling($w,pxmin)}] + set height [expr {$scaling($w,pymax)-$scaling($w,pymin)}] + + set dx [expr {$scaling($w,xmax)-$scaling($w,xmin)}] + set dy [expr {$scaling($w,ymax)-$scaling($w,ymin)}] + set scaling($w,xfactor) [expr {$width/$dx}] + set scaling($w,yfactor) [expr {$height/$dy}] + } + + set xcrd [expr {$scaling($w,xmin)+($xpix-$scaling($w,pxmin))/$scaling($w,xfactor)}] + set ycrd [expr {$scaling($w,ymax)-($ypix-$scaling($w,pymin))/$scaling($w,yfactor)}] + return [list $xcrd $ycrd] +} + +# polarToPixel -- +# Convert polar coordinates to pixel coordinates +# Arguments: +# w Name of the canvas +# rad Radius of the point +# phi Angle of the point (degrees) +# Result: +# List of two elements, x- and y-coordinates in pixels +# +proc ::Plotchart::polarToPixel { w rad phi } { + variable torad + + set xcrd [expr {$rad*cos($phi*$torad)}] + set ycrd [expr {$rad*sin($phi*$torad)}] + + coordsToPixel $w $xcrd $ycrd +} + +# createXYPlot -- +# Create a command for drawing an XY plot +# Arguments: +# w Name of the canvas +# xscale Minimum, maximum and step for x-axis (initial) +# yscale Minimum, maximum and step for y-axis +# Result: +# Name of a new command +# Note: +# The entire canvas will be dedicated to the XY plot. +# The plot will be drawn with axes +# +proc ::Plotchart::createXYPlot { w xscale yscale } { + variable data_series + + foreach s [array names data_series "$w,*"] { + unset data_series($s) + } + + set newchart "xyplot_$w" + interp alias {} $newchart {} ::Plotchart::PlotHandler xyplot $w + + foreach {pxmin pymin pxmax pymax} [MarginsRectangle $w] {break} + + foreach {xmin xmax xdelt} $xscale {break} + foreach {ymin ymax ydelt} $yscale {break} + + if { $xdelt == 0.0 || $ydelt == 0.0 } { + return -code error "Step size can not be zero" + } + + if { ($xmax-$xmin)*$xdelt < 0.0 } { + set xdelt [expr {-$xdelt}] + } + if { ($ymax-$ymin)*$ydelt < 0.0 } { + set ydelt [expr {-$ydelt}] + } + + viewPort $w $pxmin $pymin $pxmax $pymax + worldCoordinates $w $xmin $ymin $xmax $ymax + + DrawYaxis $w $ymin $ymax $ydelt + DrawXaxis $w $xmin $xmax $xdelt + DrawMask $w + + return $newchart +} + +# createStripchart -- +# Create a command for drawing a strip chart +# Arguments: +# w Name of the canvas +# xscale Minimum, maximum and step for x-axis (initial) +# yscale Minimum, maximum and step for y-axis +# Result: +# Name of a new command +# Note: +# The entire canvas will be dedicated to the stripchart. +# The stripchart will be drawn with axes +# +proc ::Plotchart::createStripchart { w xscale yscale } { + variable data_series + + set newchart [createXYPlot $w $xscale $yscale] + + interp alias {} $newchart {} + + set newchart "stripchart_$w" + interp alias {} $newchart {} ::Plotchart::PlotHandler stripchart $w + + return $newchart +} + +# createIsometricPlot -- +# Create a command for drawing an "isometric" plot +# Arguments: +# w Name of the canvas +# xscale Minimum and maximum for x-axis +# yscale Minimum and maximum for y-axis +# stepsize Step size for numbers on the axes or "noaxes" +# Result: +# Name of a new command +# Note: +# The entire canvas will be dedicated to the plot +# The plot will be drawn with or without axes +# +proc ::Plotchart::createIsometricPlot { w xscale yscale stepsize } { + variable data_series + + foreach s [array names data_series "$w,*"] { + unset data_series($s) + } + + set newchart "isometric_$w" + interp alias {} $newchart {} ::Plotchart::PlotHandler isometric $w + + if { $stepsize != "noaxes" } { + foreach {pxmin pymin pxmax pymax} [MarginsRectangle $w] {break} + } else { + set pxmin 0 + set pymin 0 + set pxmax [$w cget -width] + set pymax [$w cget -height] + } + + foreach {xmin xmax} $xscale {break} + foreach {ymin ymax} $yscale {break} + + if { $xmin == $xmax || $ymin == $ymax } { + return -code error "Extremes for axes must be different" + } + + viewPort $w $pxmin $pymin $pxmax $pymax + ScaleIsometric $w $xmin $ymin $xmax $ymax + + if { $stepsize != "noaxes" } { + DrawYaxis $w $ymin $ymax $ydelt + DrawXaxis $w $xmin $xmax $xdelt + DrawMask $w + } + + return $newchart +} + +# createPiechart -- +# Create a command for drawing a pie chart +# Arguments: +# w Name of the canvas +# Result: +# Name of a new command +# Note: +# The entire canvas will be dedicated to the pie chart. +# +proc ::Plotchart::createPiechart { w } { + variable data_series + + foreach s [array names data_series "$w,*"] { + unset data_series($s) + } + + set newchart "piechart_$w" + interp alias {} $newchart {} ::Plotchart::PlotHandler piechart $w + + foreach {pxmin pymin pxmax pymax} [MarginsCircle $w] {break} + + viewPort $w $pxmin $pymin $pxmax $pymax + $w create oval $pxmin $pymin $pxmax $pymax + + SetColours $w blue lightblue green yellow orange red magenta brown + + return $newchart +} + +# createPolarplot -- +# Create a command for drawing a polar plot +# Arguments: +# w Name of the canvas +# radius_data Maximum radius and step +# Result: +# Name of a new command +# Note: +# The entire canvas will be dedicated to the polar plot +# Possible additional arguments (optional): nautical/mathematical +# step in phi +# +proc ::Plotchart::createPolarplot { w radius_data } { + variable data_series + + foreach s [array names data_series "$w,*"] { + unset data_series($s) + } + + set newchart "polarplot_$w" + interp alias {} $newchart {} ::Plotchart::PlotHandler polarplot $w + + set rad_max [lindex $radius_data 0] + set rad_step [lindex $radius_data 1] + + if { $rad_step <= 0.0 } { + return -code error "Step size can not be zero or negative" + } + if { $rad_max <= 0.0 } { + return -code error "Maximum radius can not be zero or negative" + } + + foreach {pxmin pymin pxmax pymax} [MarginsCircle $w] {break} + + viewPort $w $pxmin $pymin $pxmax $pymax + polarCoordinates $w $rad_max + DrawPolarAxes $w $rad_max $rad_step + + return $newchart +} + +# createBarchart -- +# Create a command for drawing a barchart with vertical bars +# Arguments: +# w Name of the canvas +# xlabels List of labels for x-axis +# yscale Minimum, maximum and step for y-axis +# noseries Number of series or the keyword "stacked" +# Result: +# Name of a new command +# Note: +# The entire canvas will be dedicated to the barchart. +# +proc ::Plotchart::createBarchart { w xlabels yscale noseries } { + variable data_series + + foreach s [array names data_series "$w,*"] { + unset data_series($s) + } + + set newchart "barchart_$w" + interp alias {} $newchart {} ::Plotchart::PlotHandler vertbars $w + + foreach {pxmin pymin pxmax pymax} [MarginsRectangle $w] {break} + + set xmin 0.0 + set xmax [expr {[llength $xlabels] + 0.1}] + + foreach {ymin ymax ydelt} $yscale {break} + + if { $ydelt == 0.0 } { + return -code error "Step size can not be zero" + } + + if { ($ymax-$ymin)*$ydelt < 0.0 } { + set ydelt [expr {-$ydelt}] + } + + viewPort $w $pxmin $pymin $pxmax $pymax + worldCoordinates $w $xmin $ymin $xmax $ymax + + DrawYaxis $w $ymin $ymax $ydelt + DrawXlabels $w $xlabels $noseries + DrawMask $w + + SetColours $w blue lightblue green yellow orange red magenta brown + + return $newchart +} + +# createHorizontalBarchart -- +# Create a command for drawing a barchart with horizontal bars +# Arguments: +# w Name of the canvas +# xscale Minimum, maximum and step for x-axis +# ylabels List of labels for y-axis +# noseries Number of series or the keyword "stacked" +# Result: +# Name of a new command +# Note: +# The entire canvas will be dedicated to the barchart. +# +proc ::Plotchart::createHorizontalBarchart { w xscale ylabels noseries } { + variable data_series + + foreach s [array names data_series "$w,*"] { + unset data_series($s) + } + + set newchart "hbarchart_$w" + interp alias {} $newchart {} ::Plotchart::PlotHandler horizbars $w + + foreach {pxmin pymin pxmax pymax} [MarginsRectangle $w] {break} + + set ymin 0.0 + set ymax [expr {[llength $ylabels] + 0.1}] + + foreach {xmin xmax xdelt} $xscale {break} + + if { $xdelt == 0.0 } { + return -code error "Step size can not be zero" + } + + if { ($xmax-$xmin)*$xdelt < 0.0 } { + set xdelt [expr {-$xdelt}] + } + + viewPort $w $pxmin $pymin $pxmax $pymax + worldCoordinates $w $xmin $ymin $xmax $ymax + + DrawXaxis $w $xmin $xmax $xdelt + DrawYlabels $w $ylabels $noseries + DrawMask $w + + SetColours $w blue lightblue green yellow orange red magenta brown + + return $newchart +} + +# createTimechart -- +# Create a command for drawing a simple timechart +# Arguments: +# w Name of the canvas +# time_begin Start time (in the form of a date/time) +# time_end End time (in the form of a date/time) +# noitems Number of items to be shown (determines spacing) +# Result: +# Name of a new command +# Note: +# The entire canvas will be dedicated to the timechart. +# +proc ::Plotchart::createTimechart { w time_begin time_end noitems } { + variable data_series + variable scaling + + foreach s [array names data_series "$w,*"] { + unset data_series($s) + } + + set newchart "timechart_$w" + interp alias {} $newchart {} ::Plotchart::PlotHandler timechart $w + + foreach {pxmin pymin pxmax pymax} [MarginsRectangle $w 3] {break} + + set ymin 0.0 + set ymax $noitems + + set xmin [expr {1.0*[clock scan $time_begin]}] + set xmax [expr {1.0*[clock scan $time_end]}] + + viewPort $w $pxmin $pymin $pxmax $pymax + worldCoordinates $w $xmin $ymin $xmax $ymax + + set scaling($w,current) $ymax + set scaling($w,dy) -0.7 + + return $newchart +} + +# create3DPlot -- +# Create a simple 3D plot +# Arguments: +# w Name of the canvas +# xscale Minimum, maximum and step for x-axis (initial) +# yscale Minimum, maximum and step for y-axis +# zscale Minimum, maximum and step for z-axis +# Result: +# Name of a new command +# Note: +# The entire canvas will be dedicated to the 3D plot +# +proc ::Plotchart::create3DPlot { w xscale yscale zscale } { + variable data_series + + foreach s [array names data_series "$w,*"] { + unset data_series($s) + } + + set newchart "3dplot_$w" + interp alias {} $newchart {} ::Plotchart::PlotHandler 3dplot $w + + foreach {pxmin pymin pxmax pymax} [Margins3DPlot $w] {break} + + foreach {xmin xmax xstep} $xscale {break} + foreach {ymin ymax ystep} $yscale {break} + foreach {zmin zmax zstep} $zscale {break} + + viewPort $w $pxmin $pymin $pxmax $pymax + world3DCoordinates $w $xmin $ymin $zmin $xmax $ymax $zmax + + Draw3DAxes $w $xmin $ymin $zmin $xmax $ymax $zmax \ + $xstep $ystep $zstep + + SetColours $w grey black + + return $newchart +} + +# Load the private procedures +# +source [file join [file dirname [info script]] "plotpriv.tcl"] +source [file join [file dirname [info script]] "plotaxis.tcl"] +source [file join [file dirname [info script]] "plot3d.tcl"] +source [file join [file dirname [info script]] "scaling.tcl"] + +# Announce our presence +# +package provide Plotchart 0.9 diff --git a/modules/plotchart/plotchart.test b/modules/plotchart/plotchart.test new file mode 100755 index 00000000..70ba6a55 --- /dev/null +++ b/modules/plotchart/plotchart.test @@ -0,0 +1,407 @@ +# -*- tcl -*- +# Test cases of the Plotchart package +# +# Note: +# Most tests concentrate on the coordinate transformations, +# as these do not require graphics +# +# TODO: +# - Error handling tests +# - checks for setZoomPan (changes of coordinates) +# + +# ------------------------------------------------------------------------- +# +# Note: +# The tests assume tcltest 2.1, in order to compare +# floating-point results + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2.1 + #package require tcltest 2.2 + namespace import ::tcltest::* +} else { + # Ensure that 2.1 or higher present. + + if {![package vsatisfies [package present tcltest] 2.1]} { + puts "Aborting tests for Plotchart" + puts "Requiring tcltest 2.1, have [package present tcltest]" + return + } +} + +catch { console show } + +source [file join [file dirname [info script]] plotchart.tcl] + +puts "Plotchart [package present Plotchart]" + +# ------------------------------------------------------------------------- + +proc matchNumbers {expected actual} { + set match 1 + foreach a $actual e $expected { + if {$a != $e} { + set match 0 + break + } + } + return $match +} + +proc checkCanvasItems {w tags} { + set okay 1 + foreach tag $tags { + if {[llength [$w find withtag $tag]] == 0} { + set okay 0 + break + } + } + return $okay +} + +customMatch numbers matchNumbers + +# ------------------------------------------------------------------------- + +# +# Test cases: coordinate transformations +# To avoid round-off errors, all transforms use "round" values +# + +test Plotchart-1.1 {World coordinates to pixel - basic 1} -match numbers -body { + ::Plotchart::worldCoordinates "window" 0.0 0.0 100.0 1000.0 + ::Plotchart::viewPort "window" 0 0 100 100 + ::Plotchart::coordsToPixel "window" 0 0 +} -result {0 100} + +test Plotchart-1.2 {World coordinates to pixel - basic 2} -match numbers -body { + ::Plotchart::worldCoordinates "window" 0.0 0.0 100.0 1000.0 + ::Plotchart::viewPort "window" 0 0 100 100 + ::Plotchart::coordsToPixel "window" 10 10 +} -result {10 99} + +test Plotchart-1.3 {World coordinates to pixel - basic 3} -match numbers -body { + ::Plotchart::worldCoordinates "window" 0.0 0.0 100.0 1000.0 + ::Plotchart::viewPort "window" 10 20 110 120 + ::Plotchart::coordsToPixel "window" 100 100 +} -result {110 110} + +test Plotchart-1.4 {World coordinates to pixel - ordering} -match numbers -body { + ::Plotchart::viewPort "window" 10 20 110 120 + ::Plotchart::worldCoordinates "window" 0.0 0.0 100.0 1000.0 + ::Plotchart::coordsToPixel "window" 100 100 +} -result {110 110} + + + + +test Plotchart-2.1 {Pixel to world coordinates - basic 1} -match numbers -body { + ::Plotchart::viewPort "window" 10 20 110 120 + ::Plotchart::worldCoordinates "window" 0.0 0.0 100.0 1000.0 + ::Plotchart::pixelToCoords "window" 10 20 +} -result {0 1000} + +test Plotchart-2.2 {Pixel to world coordinates - basic 2} -match numbers -body { + ::Plotchart::viewPort "window" 10 20 110 120 + ::Plotchart::worldCoordinates "window" 0.0 0.0 100.0 1000.0 + ::Plotchart::pixelToCoords "window" 110 120 +} -result {100 0} + +test Plotchart-2.3 {Pixel to world coordinates - ordering} -match numbers -body { + ::Plotchart::worldCoordinates "window" 0.0 0.0 100.0 1000.0 + ::Plotchart::viewPort "window" 10 20 110 120 + ::Plotchart::pixelToCoords "window" 110 120 +} -result {100 0} + + +puts [::Plotchart::determineScale -0.2 0.9] +puts [::Plotchart::determineScale -0.25 0.85] +puts [::Plotchart::determineScale -0.25 0.7999] +puts [::Plotchart::determineScale 10001 10010] +puts [::Plotchart::determineScale 10001 10015] + + +test Plotchart-2.4 {Nice scale 1} -match numbers -body { + ::Plotchart::determineScale 0.1 1.0 +} -result {0.0 1.0 0.2} + +test Plotchart-2.5 {Nice scale 2} -match numbers -body { + ::Plotchart::determineScale 0.001 0.01 +} -result {0.0 0.01 0.002} + +test Plotchart-2.6 {Nice scale 3} -match numbers -body { + ::Plotchart::determineScale -0.2 0.9 +} -result {-0.2 1.0 0.2} + +test Plotchart-2.7 {Nice scale 4} -match numbers -body { + ::Plotchart::determineScale -0.25 0.85 +} -result {-0.2 1.0 0.2} + +test Plotchart-2.8 {Nice scale 5} -match numbers -body { + ::Plotchart::determineScale -0.25 0.7999 +} -result {-0.2 0.8 0.2} + +test Plotchart-2.9 {Nice scale 6} -match numbers -body { + ::Plotchart::determineScale 10001 10010 +} -result {10001 10010 2} + +test Plotchart-2.10 {Nice scale 7} -match numbers -body { + ::Plotchart::determineScale 10001 10015 +} -result {10000 10015 5} + + + + +test Plotchart-3.1 {XY-plot} -constraints tk -body { + canvas .c -width 300 -height 200 -bg white + pack .c -fill both + .c delete all + + set s [::Plotchart::createXYPlot .c {0.0 100.0 10.0} {0.0 100.0 20.0}] + + set xd 5.0 + set yd 20.0 + set xold 0.0 + set yold 50.0 + + for { set i 0 } { $i < 20 } { incr i } { + set xnew [expr {$xold+$xd}] + set ynew [expr {$yold+(rand()-0.5)*$yd}] + set ynew2 [expr {$yold+(rand()-0.5)*2.0*$yd}] + $s plot series1 $xnew $ynew + $s plot series2 $xnew $ynew2 + set xold $xnew + set yold $ynew + } + + $s title "Aha!" + + after 1000 {set waited 1} + vwait waited + set waited 0 + + set res [checkCanvasItems .c {data xaxis yaxis}] + destroy .c + set res +} -result 1 ;# {} + + +test Plotchart-3.2 {Piechart} -constraints tk -body { + canvas .c -width 300 -height 200 -bg white + pack .c -fill both + .c delete all + set s [::Plotchart::createPiechart .c] + + $s plot {"Long names" 10 "Short names" 30 "Average" 40 "Ultra-short names" 5} + $s title "Okay - this works" + + after 1000 {set waited 1} + vwait waited + set waited 0 + + #checkCanvasItems .c {data} + destroy .c + set result 1 + +} -result 1 + +test Plotchart-3.3 {Polar plot} -constraints tk -body { + canvas .c -width 300 -height 200 -bg white + pack .c -fill both + .c delete all + + set s [::Plotchart::createPolarplot .c {3.0 1.0}] + + for { set angle 0 } { $angle < 360.0 } { set angle [expr {$angle+10.0}] } { + set rad [expr {1.0+cos($angle*$::Plotchart::torad)}] + $s plot "cardioid" $rad $angle + } + + $s title "Cardioid" + + after 1000 {set waited 1} + vwait waited + set waited 0 + + set res [checkCanvasItems .c {data}] + destroy .c + set res +} -result 1 + +test Plotchart-3.4 {Barchart} -constraints tk -body { + canvas .c -width 300 -height 200 -bg white + pack .c -fill both + .c delete all + + set s [::Plotchart::createBarchart .c {A B C D E} {0.0 10.0 2.0} 2] + + $s plot series1 {1.0 4.0 6.0 1.0 7.0} red + $s plot series2 {0.0 3.0 7.0 9.3 2.0} green + $s title "Arbitrary data" + + after 1000 {set waited 1} + vwait waited + set waited 0 + + set res [checkCanvasItems .c {data yaxis}] + destroy .c + set res +} -result 1 + +test Plotchart-3.5 {Barchart (stacked)} -constraints tk -body { + canvas .c -width 300 -height 200 -bg white + pack .c -fill both + .c delete all + + set s [::Plotchart::createBarchart .c {A B C D E} {0.0 20.0 5.0} stacked] + + $s plot series1 {1.0 4.0 6.0 1.0 7.0} red + $s plot series2 {0.0 3.0 7.0 9.3 2.0} green + $s title "Stacked diagram" + + after 1000 {set waited 1} + vwait waited + set waited 0 + + set res [checkCanvasItems .c {data yaxis}] + destroy .c + set res +} -result 1 + +test Plotchart-3.6 {Horizontal barchart} -constraints tk -body { + canvas .c -width 300 -height 200 -bg white + pack .c -fill both + .c delete all + + set s [::Plotchart::createHorizontalBarchart .c {0.0 10.0 2.0} {A B C D E} 2] + + $s plot series1 {1.0 4.0 6.0 1.0 7.0} red + $s plot series2 {0.0 3.0 7.0 9.3 2.0} green + $s title "Arbitrary data" + + after 1000 {set waited 1} + vwait waited + set waited 0 + + set res [checkCanvasItems .c {data xaxis}] + destroy .c + set res +} -result 1 + +test Plotchart-3.7 {Horizontal barchart (stacked)} -constraints tk -body { + canvas .c -width 300 -height 200 -bg white + pack .c -fill both + .c delete all + + set s [::Plotchart::createHorizontalBarchart .c {0.0 20.0 5.0} {A B C D E} stacked] + + $s plot series1 {1.0 4.0 6.0 1.0 7.0} red + $s plot series2 {0.0 3.0 7.0 9.3 2.0} green + $s title "Stacked diagram" + + after 1000 {set waited 1} + vwait waited + set waited 0 + + set res [checkCanvasItems .c {data xaxis}] + destroy .c + set res +} -result 1 + +test Plotchart-3.8 {Timechart} -constraints tk -body { + canvas .c -width 300 -height 200 -bg white + pack .c -fill both + .c delete all + + set s [::Plotchart::createTimechart .c "1 january 2004" \ + "31 december 2004" 4] + + $s period "Spring" "1 march 2004" "1 june 2004" green + $s period "Summer" "1 june 2004" "1 september 2004" yellow + $s vertline "1 jan" "1 january 2004" + $s vertline "1 apr" "1 april 2004" + $s vertline "1 jul" "1 july 2004" + $s vertline "1 oct" "1 october 2004" + $s milestone "Longest day" "21 july 2004" + $s title "Seasons (northern hemisphere)" + + after 1000 {set waited 1} + vwait waited + set waited 0 + + #checkCanvasItems .c {data} + destroy .c + set result 1 + +} -result 1 + +test Plotchart-3.9 {Stripchart} -constraints tk -body { + canvas .c -width 300 -height 200 -bg white + pack .c -fill both + .c delete all + + set s [::Plotchart::createStripchart .c {0.0 100.0 10.0} {0.0 100.0 20.0}] + + proc gendata {s xold xd yold yd} { + set xnew [expr {$xold+$xd}] + set ynew [expr {$yold+(rand()-0.5)*$yd}] + set ynew2 [expr {$yold+(rand()-0.5)*2.0*$yd}] + $s plot series1 $xnew $ynew + $s plot series2 $xnew $ynew2 + + if { $xnew < 200 } { + after 200 [list gendata $s $xnew $xd $ynew $yd] + } + } + + after 100 [list gendata $s 0.0 15.0 50.0 30.0] + + $s title "Aha!" + + after 4000 {set waited 1} + vwait waited + set waited 0 + + set res [checkCanvasItems .c {data xaxis yaxis}] + destroy .c + set res +} -result 1 + +test Plotchart-3.10 {Isometric plot} -constraints tk -body { + canvas .c -width 300 -height 200 -bg white + pack .c -fill both + .c delete all + + set s [::Plotchart::createIsometricPlot .c {0.0 100.0} {0.0 200.0} noaxes] + ::Plotchart::setZoomPan .c + $s plot rectangle 10.0 10.0 50.0 50.0 green + $s plot filled-rectangle 20.0 20.0 40.0 40.0 red + $s plot filled-circle 70.0 70.0 40.0 yellow + $s plot circle 70.0 70.0 42.0 + + after 100 { + ::Plotchart::MoveItems .c 0 40 + } + after 200 { + ::Plotchart::MoveItems .c 0 -40 + } + after 300 { + ::Plotchart::ScaleItems .c 0 0 2 + } + after 400 { + ::Plotchart::ScaleItems .c 0 0 0.5 + } + + after 1000 {set waited 1} + vwait waited + set waited 0 + + #checkCanvasItems .c {data} + destroy .c + set result 1 +} -result 1 + + +# ------------------------------------------------------------------------- +::tcltest::cleanupTests diff --git a/modules/plotchart/plotpriv.tcl b/modules/plotchart/plotpriv.tcl new file mode 100755 index 00000000..957a5bf7 --- /dev/null +++ b/modules/plotchart/plotpriv.tcl @@ -0,0 +1,834 @@ +# plotpriv.tcl -- +# Facilities to draw simple plots in a dedicated canvas +# +# Note: +# This source file contains the private functions. +# It is the companion of "plotchart.tcl" +# + +# SavePlot -- +# Save the plot/chart to a PostScript file (using default options) +# Arguments: +# w Name of the canvas +# filename Name of the file to write +# Result: +# None +# Side effect: +# A (new) PostScript file +# +proc ::Plotchart::SavePlot { w filename } { + # + # Wait for the canvas to become visible - just in case. + # Then write the file + # + update idletasks + $w postscript -file $filename +} + +# MarginsRectangle -- +# Determine the margins for a rectangular plot/chart +# Arguments: +# w Name of the canvas +# notext Number of lines of text to make room for at the top +# (default: 2.0) +# Result: +# List of four values +# +proc ::Plotchart::MarginsRectangle { w {notext 2.0}} { + set pxmin 80 + set pymin [expr {int(14*$notext)}] + set pxmax [expr {[$w cget -width] - 40}] + set pymax [expr {[$w cget -height] - 30}] + + return [list $pxmin $pymin $pxmax $pymax] +} + +# MarginsCircle -- +# Determine the margins for a circular plot/chart +# Arguments: +# w Name of the canvas +# Result: +# List of four values +# +proc ::Plotchart::MarginsCircle { w } { + set pxmin 80 + set pymin 30 + set pxmax [expr {[$w cget -width] - 80}] + set pymax [expr {[$w cget -height] - 30}] + + set dx [expr {$pxmax-$pxmin+1}] + set dy [expr {$pymax-$pymin+1}] + + if { $dx < $dy } { + set pyminn [expr {($pymin+$pymax-$dx)/2}] + set pymaxn [expr {($pymin+$pymax+$dx)/2}] + set pymin $pyminn + set pymax $pymaxn + } else { + set pxminn [expr {($pxmin+$pxmax-$dy)/2}] + set pxmaxn [expr {($pxmin+$pxmax+$dy)/2}] + set pxmin $pxminn + set pxmax $pxmaxn + } + + return [list $pxmin $pymin $pxmax $pymax] +} + +# Margins3DPlot -- +# Determine the margins for a 3D plot +# Arguments: +# w Name of the canvas +# Result: +# List of four values +# +proc ::Plotchart::Margins3DPlot { w } { + variable scaling + + set yfract 0.33 + set zfract 0.50 + if { [info exists scaling($w,yfract)] } { + set yfract $scaling($w,yfract) + } else { + set scaling($w,yfract) $yfract + } + if { [info exists scaling($w,zfract)] } { + set zfract $scaling($w,zfract) + } else { + set scaling($w,zfract) $zfract + } + + set yzwidth [expr {(-120+[$w cget -width])/(1.0+$yfract)}] + set yzheight [expr {(-60+[$w cget -height])/(1.0+$zfract)}] + + set pxmin [expr {60+$yfract*$yzwidth}] + set pxmax [expr {[$w cget -width] - 60}] + set pymin 30 + set pymax [expr {30+$yzheight}] + + return [list $pxmin $pymin $pxmax $pymax] +} + +# SetColours -- +# Set the colours for those plots that treat them as a global resource +# Arguments: +# w Name of the canvas +# args List of colours to be used +# Result: +# None +# +proc ::Plotchart::SetColours { w args } { + variable scaling + + set scaling($w,colours) $args +} + +# DataConfig -- +# Configure the data series +# Arguments: +# w Name of the canvas +# series Name of the series in question +# args Option and value pairs +# Result: +# None +# +proc ::Plotchart::DataConfig { w series args } { + variable data_series + variable options + variable option_keys + variable option_values + + foreach {option value} $args { + set idx [lsearch $options $option] + if { $idx < 0 } { + return -code error "Unknown or invalid option: $option (value: $value)" + } else { + set key [lindex $option_keys $idx] + set idx [lsearch $option_values $key] + set values [lindex $option_values [incr idx]] + if { $values != "..." } { + if { [lsearch $values $value] < 0 } { + return -code error "Unknown or invalid value: $value for option $option - $values" + } + } + set data_series($w,$series,$key) $value + } + } +} + +# ScaleIsometric -- +# Determine the scaling for an isometric plot +# Arguments: +# w Name of the canvas +# xmin Minimum x coordinate +# ymin Minimum y coordinate +# xmax Maximum x coordinate +# ymax Maximum y coordinate +# (default: 1.5) +# Result: +# None +# Side effect: +# Array with scaling parameters set +# +proc ::Plotchart::ScaleIsometric { w xmin ymin xmax ymax } { + variable scaling + + set pxmin $scaling($w,pxmin) + set pymin $scaling($w,pymin) + set pxmax $scaling($w,pxmax) + set pymax $scaling($w,pymax) + + set dx [expr {($xmax-$xmin)/($pxmax-$pxmin)}] + set dy [expr {($ymax-$ymin)/($pymax-$pymin)}] + + # + # Which coordinate is dominant? + # + if { $dy < $dx } { + set yminn [expr {0.5*($ymax+$ymin) - 0.5 * $dx * ($pymax-$pymin)}] + set ymaxn [expr {0.5*($ymax+$ymin) + 0.5 * $dx * ($pymax-$pymin)}] + set ymin $yminn + set ymax $ymaxn + } else { + set xminn [expr {0.5*($xmax+$xmin) - 0.5 * $dy * ($pxmax-$pxmin)}] + set xmaxn [expr {0.5*($xmax+$xmin) + 0.5 * $dy * ($pxmax-$pxmin)}] + set xmin $xminn + set xmax $xmaxn + } + + worldCoordinates $w $xmin $ymin $xmax $ymax +} + +# PlotHandler -- +# Handle the subcommands for an XY plot or chart +# Arguments: +# type Type of plot/chart +# w Name of the canvas +# command Subcommand or method to run +# args Data for the command +# Result: +# Whatever returned by the subcommand +# +proc ::Plotchart::PlotHandler { type w command args } { + variable methodProc + + if { [info exists methodProc($type,$command)] } { + eval $methodProc($type,$command) $w $args + } else { + return -code error "No such method - $command" + } +} + +# DrawMask -- +# Draw the stuff that masks the data lines outside the graph +# Arguments: +# w Name of the canvas +# Result: +# None +# Side effects: +# Several polygons drawn in the background colour +# +proc ::Plotchart::DrawMask { w } { + variable scaling + + set width [$w cget -width] + set height [expr {[$w cget -height] + 1}] + set colour [$w cget -background] + set pxmin $scaling($w,pxmin) + set pxmax $scaling($w,pxmax) + set pymin $scaling($w,pymin) + set pymax $scaling($w,pymax) + $w create rectangle 0 0 $pxmin $height -fill $colour -outline $colour -tag mask + $w create rectangle 0 0 $width $pymin -fill $colour -outline $colour -tag mask + $w create rectangle 0 $pymax $width $height -fill $colour -outline $colour -tag mask + $w create rectangle $pxmax 0 $width $height -fill $colour -outline $colour -tag mask + + $w lower mask +} + +# DrawTitle -- +# Draw the title +# Arguments: +# w Name of the canvas +# title Title to appear above the graph +# Result: +# None +# Side effects: +# Text string drawn +# +proc ::Plotchart::DrawTitle { w title } { + variable scaling + + set width [$w cget -width] + set pymin $scaling($w,pymin) + + $w create text [expr {$width/2}] 3 -text $title \ + -anchor n -tags title +} + +# DrawData -- +# Draw the data in an XY-plot +# Arguments: +# w Name of the canvas +# series Data series +# xcrd Next x coordinate +# ycrd Next y coordinate +# Result: +# None +# Side effects: +# New data drawn in canvas +# +proc ::Plotchart::DrawData { w series xcrd ycrd } { + variable data_series + variable scaling + + # + # Draw the line piece + # + set colour "black" + if { [info exists data_series($w,$series,-colour)] } { + set colour $data_series($w,$series,-colour) + } + + set type "line" + if { [info exists data_series($w,$series,-type)] } { + set type $data_series($w,$series,-type) + } + + foreach {pxcrd pycrd} [coordsToPixel $w $xcrd $ycrd] {break} + + if { [info exists data_series($w,$series,x)] } { + set xold $data_series($w,$series,x) + set yold $data_series($w,$series,y) + foreach {pxold pyold} [coordsToPixel $w $xold $yold] {break} + if { $type == "line" || $type == "both" } { + $w create line $pxold $pyold $pxcrd $pycrd \ + -fill $colour -tag data + } + } + + if { $type == "symbol" || $type == "both" } { + set symbol "dot" + if { [info exists data_series($w,$series,-symbol)] } { + set symbol $data_series($w,$series,-symbol) + } + DrawSymbolPixel $w $series $pxcrd $pycrd $symbol $colour + } + + $w lower data + + set data_series($w,$series,x) $xcrd + set data_series($w,$series,y) $ycrd +} + +# DrawStripData -- +# Draw the data in a stripchart +# Arguments: +# w Name of the canvas +# series Data series +# xcrd Next x coordinate +# ycrd Next y coordinate +# Result: +# None +# Side effects: +# New data drawn in canvas +# +proc ::Plotchart::DrawStripData { w series xcrd ycrd } { + variable data_series + variable scaling + + if { $xcrd > $scaling($w,xmax) } { + set xdelt $scaling($w,xdelt) + set xmin $scaling($w,xmin) + set xmax $scaling($w,xmax) + + set xminorg $xmin + while { $xmax < $xcrd } { + set xmin [expr {$xmin+$xdelt}] + set xmax [expr {$xmax+$xdelt}] + } + set ymin $scaling($w,ymin) + set ymax $scaling($w,ymax) + + worldCoordinates $w $xmin $ymin $xmax $ymax + DrawXaxis $w $xmin $xmax $xdelt + + foreach {pxminorg pyminorg} [coordsToPixel $w $xminorg $ymin] {break} + foreach {pxmin pymin} [coordsToPixel $w $xmin $ymin] {break} + $w move data [expr {$pxminorg-$pxmin+1}] 0 + } + + DrawData $w $series $xcrd $ycrd +} + +# DrawSymbolPixel -- +# Draw a symbol in an xy-plot, polar plot or stripchart +# Arguments: +# w Name of the canvas +# series Data series +# pxcrd Next x (pixel) coordinate +# pycrd Next y (pixel) coordinate +# symbol What symbol to draw +# colour What colour to use +# Result: +# None +# Side effects: +# New symbol drawn in canvas +# +proc ::Plotchart::DrawSymbolPixel { w series pxcrd pycrd symbol colour } { + variable data_series + variable scaling + + set pxmin [expr {$pxcrd-4}] + set pxmax [expr {$pxcrd+4}] + set pymin [expr {$pycrd-4}] + set pymax [expr {$pycrd+4}] + + switch -- $symbol { + "plus" { $w create line $pxmin $pycrd $pxmax $pycrd \ + $pxcrd $pycrd $pxcrd $pymin \ + $pxcrd $pymax \ + -fill $colour -tag data \ + -capstyle projecting + } + "cross" { $w create line $pxmin $pymin $pxmax $pymax \ + $pxcrd $pycrd $pxmax $pymin \ + $pxmin $pymax \ + -fill $colour -tag data \ + -capstyle projecting + } + "circle" { $w create oval $pxmin $pymin $pxmax $pymax \ + -outline $colour -tag data + } + "dot" { $w create oval $pxmin $pymin $pxmax $pymax \ + -outline $colour -fill $colour -tag data + } + "up" { $w create polygon $pxmin $pymax $pxmax $pymax \ + $pxcrd $pymin \ + -outline $colour -fill {} -tag data + } + "upfilled" { $w create polygon $pxmin $pymax $pxmax $pymax \ + $pxcrd $pymin \ + -outline $colour -fill $colour -tag data + } + "down" { $w create polygon $pxmin $pymin $pxmax $pymin \ + $pxcrd $pymax \ + -outline $colour -fill {} -tag data + } + "downfilled" { $w create polygon $pxmin $pymin $pxmax $pymin \ + $pxcrd $pymax \ + -outline $colour -fill $colour -tag data + } + } +} + +# DrawPie -- +# Draw the pie +# Arguments: +# w Name of the canvas +# data Data series (pairs of label-value) +# Result: +# None +# Side effects: +# Pie filled +# +proc ::Plotchart::DrawPie { w data } { + variable data_series + variable scaling + + set pxmin $scaling($w,pxmin) + set pymin $scaling($w,pymin) + set pxmax $scaling($w,pxmax) + set pymax $scaling($w,pymax) + + # + # Determine the scale for the values + # (so we can draw the correct angles) + # + set sum 0.0 + foreach {label value} $data { + set sum [expr {$sum + $value}] + } + set factor [expr {360.0/$sum}] + + # + # Draw the line piece + # + set angle_bgn 0.0 + set angle_ext 0.0 + set sum 0.0 + + set colours $scaling($w,colours) + + set idx 0 + foreach {label value} $data { + set colour [lindex $colours $idx] + incr idx + + set angle_bgn [expr {$sum * $factor}] + set angle_ext [expr {$value * $factor}] + + $w create arc $pxmin $pymin $pxmax $pymax \ + -start $angle_bgn -extent $angle_ext \ + -fill $colour -style pieslice + + set rad [expr {($angle_bgn+0.5*$angle_ext)*3.1415926/180.0}] + set xtext [expr {($pxmin+$pxmax+cos($rad)*($pxmax-$pxmin+20))/2}] + set ytext [expr {($pymin+$pymax-sin($rad)*($pymax-$pymin+20))/2}] + if { $xtext > ($pxmin+$pymax)/2 } { + set dir w + } else { + set dir e + } + + $w create text $xtext $ytext -text $label -anchor $dir + + set sum [expr {$sum + $value}] + } +} + +# DrawPolarData -- +# Draw data given in polar coordinates +# Arguments: +# w Name of the canvas +# series Data series +# rad Next radius +# phi Next angle (in degrees) +# Result: +# None +# Side effects: +# Data drawn in canvas +# +proc ::Plotchart::DrawPolarData { w series rad phi } { + variable torad + set xcrd [expr {$rad*cos($phi*$torad)}] + set ycrd [expr {$rad*sin($phi*$torad)}] + + DrawData $w $series $xcrd $ycrd +} + +# DrawVertBarData -- +# Draw the vertical bars +# Arguments: +# w Name of the canvas +# series Data series +# ydata Series of y data +# colour The colour to use (optional) +# Result: +# None +# Side effects: +# Data bars drawn in canvas +# +proc ::Plotchart::DrawVertBarData { w series ydata {colour black}} { + variable data_series + variable scaling + + # + # Draw the bars + # + set x $scaling($w,xbase) + + set newbase {} + + foreach yvalue $ydata ybase $scaling($w,ybase) { + set xnext [expr {$x+$scaling($w,barwidth)}] + set y [expr {$yvalue+$ybase}] + foreach {px1 py1} [coordsToPixel $w $x $ybase] {break} + foreach {px2 py2} [coordsToPixel $w $xnext $y ] {break} + $w create rectangle $px1 $py1 $px2 $py2 \ + -fill $colour -tag data + $w lower data + + set x [expr {$x+1.0}] + + lappend newbase $y + } + + # + # Prepare for the next series + # + if { $scaling($w,stacked) } { + set scaling($w,ybase) $newbase + } + + set scaling($w,xbase) [expr {$scaling($w,xbase)+$scaling($w,xshift)}] +} + +# DrawHorizBarData -- +# Draw the horizontal bars +# Arguments: +# w Name of the canvas +# series Data series +# xdata Series of x data +# colour The colour to use (optional) +# Result: +# None +# Side effects: +# Data bars drawn in canvas +# +proc ::Plotchart::DrawHorizBarData { w series xdata {colour black}} { + variable data_series + variable scaling + + # + # Draw the bars + # + set y $scaling($w,ybase) + + set newbase {} + + foreach xvalue $xdata xbase $scaling($w,xbase) { + set ynext [expr {$y+$scaling($w,barwidth)}] + set x [expr {$xvalue+$xbase}] + foreach {px1 py1} [coordsToPixel $w $xbase $y ] {break} + foreach {px2 py2} [coordsToPixel $w $x $ynext] {break} + $w create rectangle $px1 $py1 $px2 $py2 \ + -fill $colour -tag data + $w lower data + + set y [expr {$y+1.0}] + + lappend newbase $x + } + + # + # Prepare for the next series + # + if { $scaling($w,stacked) } { + set scaling($w,xbase) $newbase + } + + set scaling($w,ybase) [expr {$scaling($w,ybase)+$scaling($w,yshift)}] +} + +# DrawTimePeriod -- +# Draw a period +# Arguments: +# w Name of the canvas +# text Text to identify the "period" item +# time_begin Start time +# time_end Stop time +# colour The colour to use (optional) +# Result: +# None +# Side effects: +# Data bars drawn in canvas +# +proc ::Plotchart::DrawTimePeriod { w text time_begin time_end {colour black}} { + variable data_series + variable scaling + + # + # Draw the text first + # + set ytext [expr {$scaling($w,current)+0.5*$scaling($w,dy)}] + foreach {x y} [coordsToPixel $w $scaling($w,xmin) $ytext] {break} + + $w create text 5 $y -text $text -anchor w + + # + # Draw the bar to indicate the period + # + set xmin [clock scan $time_begin] + set xmax [clock scan $time_end] + set ybott [expr {$scaling($w,current)+$scaling($w,dy)}] + + foreach {x1 y1} [coordsToPixel $w $xmin $scaling($w,current)] {break} + foreach {x2 y2} [coordsToPixel $w $xmax $ybott ] {break} + + $w create rectangle $x1 $y1 $x2 $y2 -fill $colour + + set scaling($w,current) [expr {$scaling($w,current)-1.0}] +} + +# DrawTimeVertLine -- +# Draw a vertical line with a label +# Arguments: +# w Name of the canvas +# text Text to identify the line +# time Time for which the line is drawn +# Result: +# None +# Side effects: +# Line drawn in canvas +# +proc ::Plotchart::DrawTimeVertLine { w text time {colour black}} { + variable data_series + variable scaling + + # + # Draw the text first + # + set xtime [clock scan $time] + set ytext [expr {$scaling($w,ymax)-0.5*$scaling($w,dy)}] + foreach {x y} [coordsToPixel $w $xtime $ytext] {break} + + $w create text $x $y -text $text -anchor w + + # + # Draw the line + # + foreach {x1 y1} [coordsToPixel $w $xtime $scaling($w,ymin)] {break} + foreach {x2 y2} [coordsToPixel $w $xtime $scaling($w,ymax)] {break} + + $w create line $x1 $y1 $x2 $y2 -fill black +} + +# DrawTimeMilestone -- +# Draw a "milestone" +# Arguments: +# w Name of the canvas +# text Text to identify the line +# time Time for which the milestone is drawn +# colour Optionally the colour +# Result: +# None +# Side effects: +# Line drawn in canvas +# +proc ::Plotchart::DrawTimeMilestone { w text time {colour black}} { + variable data_series + variable scaling + + # + # Draw the text first + # + set ytext [expr {$scaling($w,current)+0.5*$scaling($w,dy)}] + foreach {x y} [coordsToPixel $w $scaling($w,xmin) $ytext] {break} + + $w create text 5 $y -text $text -anchor w + + # + # Draw an upside-down triangle to indicate the time + # + set xcentre [clock scan $time] + set ytop $scaling($w,current) + set ybott [expr {$scaling($w,current)+0.8*$scaling($w,dy)}] + + foreach {x1 y1} [coordsToPixel $w $xcentre $ybott] {break} + foreach {x2 y2} [coordsToPixel $w $xcentre $ytop] {break} + + set x2 [expr {$x1-0.4*($y1-$y2)}] + set x3 [expr {$x1+0.4*($y1-$y2)}] + set y3 $y2 + + $w create polygon $x1 $y1 $x2 $y2 $x3 $y3 -fill $colour + + set scaling($w,current) [expr {$scaling($w,current)-1.0}] +} + +# ScaleItems -- +# Scale all items by a given factor +# Arguments: +# w Name of the canvas +# xcentre X-coordinate of centre +# ycentre Y-coordinate of centre +# factor The factor to scale them by +# Result: +# None +# Side effects: +# All items are scaled by the given factor and the +# world coordinates are adjusted. +# +proc ::Plotchart::ScaleItems { w xcentre ycentre factor } { + variable scaling + + $w scale all $xcentre $ycentre $factor $factor + + foreach {xc yc} [pixelToCoords $w $xcentre $ycentre] {break} + + set rfact [expr {1.0/$factor}] + set scaling($w,xfactor) [expr {$scaling($w,xfactor)*$factor}] + set scaling($w,yfactor) [expr {$scaling($w,yfactor)*$factor}] + set scaling($w,xmin) [expr {(1.0-$rfact)*$xc+$rfact*$scaling($w,xmin)}] + set scaling($w,xmax) [expr {(1.0-$rfact)*$xc+$rfact*$scaling($w,xmax)}] + set scaling($w,ymin) [expr {(1.0-$rfact)*$yc+$rfact*$scaling($w,ymin)}] + set scaling($w,ymax) [expr {(1.0-$rfact)*$yc+$rfact*$scaling($w,ymax)}] +} + +# MoveItems -- +# Move all items by a given vector +# Arguments: +# w Name of the canvas +# xmove X-coordinate of move vector +# ymove Y-coordinate of move vector +# Result: +# None +# Side effects: +# All items are moved by the given vector and the +# world coordinates are adjusted. +# +proc ::Plotchart::MoveItems { w xmove ymove } { + variable scaling + + $w move all $xmove $ymove + + set dx [expr {$scaling($w,xfactor)*$xmove}] + set dy [expr {$scaling($w,yfactor)*$ymove}] + set scaling($w,xmin) [expr {$scaling($w,xmin)+$dx}] + set scaling($w,xmax) [expr {$scaling($w,xmax)+$dx}] + set scaling($w,ymin) [expr {$scaling($w,ymin)+$dy}] + set scaling($w,ymax) [expr {$scaling($w,ymax)+$dy}] +} + +# DrawIsometricData -- +# Draw the data in an isometric plot +# Arguments: +# w Name of the canvas +# type Type of data +# args Coordinates and so on +# Result: +# None +# Side effects: +# New data drawn in canvas +# +proc ::Plotchart::DrawIsometricData { w type args } { + variable data_series + + # + # What type of data? + # + if { $type == "rectangle" } { + foreach {x1 y1 x2 y2 colour} [concat $args "black"] {break} + foreach {px1 py1} [coordsToPixel $w $x1 $y1] {break} + foreach {px2 py2} [coordsToPixel $w $x2 $y2] {break} + $w create rectangle $px1 $py1 $px2 $py2 \ + -outline $colour -tag data + $w lower data + } + + if { $type == "filled-rectangle" } { + foreach {x1 y1 x2 y2 colour} [concat $args "black"] {break} + foreach {px1 py1} [coordsToPixel $w $x1 $y1] {break} + foreach {px2 py2} [coordsToPixel $w $x2 $y2] {break} + $w create rectangle $px1 $py1 $px2 $py2 \ + -outline $colour -fill $colour -tag data + $w lower data + } + + if { $type == "filled-circle" } { + foreach {x1 y1 rad colour} [concat $args "black"] {break} + set x2 [expr {$x1+$rad}] + set y2 [expr {$y1+$rad}] + set x1 [expr {$x1-$rad}] + set y1 [expr {$y1-$rad}] + foreach {px1 py1} [coordsToPixel $w $x1 $y1] {break} + foreach {px2 py2} [coordsToPixel $w $x2 $y2] {break} + $w create oval $px1 $py1 $px2 $py2 \ + -outline $colour -fill $colour -tag data + $w lower data + } + + if { $type == "circle" } { + foreach {x1 y1 rad colour} [concat $args "black"] {break} + set x2 [expr {$x1+$rad}] + set y2 [expr {$y1+$rad}] + set x1 [expr {$x1-$rad}] + set y1 [expr {$y1-$rad}] + foreach {px1 py1} [coordsToPixel $w $x1 $y1] {break} + foreach {px2 py2} [coordsToPixel $w $x2 $y2] {break} + $w create oval $px1 $py1 $px2 $py2 \ + -outline $colour -tag data + $w lower data + } + +} diff --git a/modules/plotchart/scaling.tcl b/modules/plotchart/scaling.tcl new file mode 100755 index 00000000..b8e589a0 --- /dev/null +++ b/modules/plotchart/scaling.tcl @@ -0,0 +1,69 @@ +# scaling.tcl -- +# Make a nice scale for the axes in the Plotchart package +# + +namespace eval ::Plotchart { + namespace export determineScale +} + +# determineScale -- +# Determine nice values for an axis from the given extremes +# +# Arguments: +# xmin Minimum value +# xmax Maximum value +# Result: +# A list of three values, a nice minimum and maximum +# and stepsize +# Note: +# xmin is assumed to be smaller or equal xmax +# +proc ::Plotchart::determineScale { xmin xmax } { + set dx [expr {abs($xmax-$xmin)}] + + if { $dx == 0.0 } { + if { $xmin == 0.0 } { + return [list -0.1 0.1 0.1] + } else { + set dx [expr {0.2*abs($xmax)}] + set xmin [expr {$xmin-0.5*$dx}] + set xmax [expr {$xmin+0.5*$dx}] + } + } + + # + # Determine the factor of 10 so that dx falls within the range 1-10 + # + set expon [expr {int(log10($dx))}] + set factor [expr {pow(10.0,$expon)}] + + set dx [expr {$dx/$factor}] + + foreach {limit step} {1.4 0.2 2.0 0.5 5.0 1.0 10.0 2.0} { + if { $dx < $limit } { + break + } + } + + set nicemin [expr {$step*$factor*int($xmin/$factor/$step)}] + set nicemax [expr {$step*$factor*int($xmax/$factor/$step)}] + if { $nicemax < $xmax } { + set nicemax [expr {$nicemax+$step}] + } + + return [list $nicemin $nicemax [expr {$step*$factor}]] +} + +if 0 { + # + # Some simple test cases + # + namespace import ::Plotchart::determineScale + puts [determineScale 0.1 1.0] + puts [determineScale 0.001 0.01] + puts [determineScale -0.2 0.9] + puts [determineScale -0.25 0.85] + puts [determineScale -0.25 0.7999] + puts [determineScale 10001 10010] + puts [determineScale 10001 10015] +} From 7638c02568730f586c6b0c6a44e0a5ff6da02e77 Mon Sep 17 00:00:00 2001 From: Andreas Kupries Date: Thu, 22 Apr 2004 04:33:16 +0000 Subject: [PATCH 0008/1290] Integrated documentation updates sent in by Arjen. New module: 'plotchart', by Arjen Markus. --- modules/plotchart/plotchart.man | 74 +++++++++++++++++++++++++++++---- 1 file changed, 65 insertions(+), 9 deletions(-) diff --git a/modules/plotchart/plotchart.man b/modules/plotchart/plotchart.man index 5334c485..a0b1fd56 100755 --- a/modules/plotchart/plotchart.man +++ b/modules/plotchart/plotchart.man @@ -217,7 +217,7 @@ bars, and the way the series will be drawn. If the keyword [const stacked] was specified the series will be drawn stacked on top of each other. Otherwise each series that is drawn will -be drawn shifted. +be drawn shifted to the right. [list_begin arg] [arg_def widget w in] @@ -249,7 +249,7 @@ bars, and the way the series will be drawn. If the keyword [const stacked] was specified the series will be drawn stacked from left to right. Otherwise each series that is drawn will -be drawn shifted. +be drawn shifted upward. [list_begin arg] [arg_def widget w in] @@ -282,11 +282,11 @@ and the vertical spacing is determined by the number of items to plot. Name of the [emph existing] canvas widget to hold the plot. [arg_def string time_begin in] -The start time given in a form that is recognised by the [cmd clock] +The start time given in a form that is recognised by the [cmd "clock scan"] command (e.g. "1 january 2004"). [arg_def string time_end in] -The end time given in a form that is recognised by the [cmd clock] +The end time given in a form that is recognised by the [cmd "clock scan"] command (e.g. "1 january 2004"). [arg_def int noitems in] @@ -323,7 +323,7 @@ The text of the title to be drawn. [call [cmd \$anyplot] saveplot [arg filename]] -Draws the plot into a file, uing PostScript. +Draws the plot into a file, using PostScript. [list_begin arg] [arg_def string filename in] @@ -495,8 +495,8 @@ columns. Example: [nl] [example { set data { - {1.0 2.0 3.0} - {4.0 5.0 6.0} + {1.0 2.0 3.0} + {4.0 5.0 6.0} } }] @@ -923,7 +923,8 @@ runs from 0 to 360 degrees and the radius starts at 0. Hence you only need to give the maximum radius. [emph Note:] If the viewport is not square, this procedure will not -adjust the extremes, so that would result in an elliptical plot. +adjust the extremes, so that would result in an elliptical plot. The +creation routine for a polar plot always determines a square viewport. [list_begin arg] [arg_def widget w in] @@ -943,7 +944,8 @@ the world coordinates and viewport are set appropriately. Converts polar coordinates to pixel coordinates. [emph Note:] To be useful it should be accompanied by a matching -[cmd ::Plotchart::worldCoordinates] procedure. +[cmd ::Plotchart::worldCoordinates] procedure. This is automatically +taken care of in the creation routine for polar plots. [list_begin arg] [arg_def widget w in] @@ -998,6 +1000,60 @@ Rough maximum value for the scaling. [list_end] +[section {OTHER OUTPUT FORMATS}] + +Besides output to the canvas on screen, the module is capable, via +[cmd {canvas postscript}], of producing PostScript files. One may wonder +whether it is possible to extend this set of output formats and the +answer is "yes". This section tries to sum up the aspects of using this +module for another sort of output. +[para] +One way you can create output files in a different format, is by +examining the contents of the canvas after everything has been drawn and +render that contents in the right form. This is probably the easiest +way, as it involves nothing more than the re-creation of all the +elements in the plot that are already there. +[para] +The drawback of that method is that you need to have a display, which is +not always the case if you run a CGI server or something like that. +[para] +An alternative is to emulate the canvas command. For this to work, you +need to know which canvas subcommands are used and what for. Obviously, +the [emph create] subcommand is used to create the lines, texts and +other items. But also the [emph raise] and [emph lower] subcommands are +used, because with these the module can influence the drawing order - +important to simulate a clipping rectangle around the axes. (The routine +DrawMask is responsible for this - if the output format supports proper +clipping areas, then a redefinition of this routine might just solve +this). +[para] +Furthermore, the module uses the [emph cget] subcommand to find out the +sizes of the canvas. A more mundane aspect of this is that the module +currently assumes that the text is 14 pixels high and that 80 pixels in +width suffice for the axis' labels. No "hook" is provided to customise +this. +[para] +In summary: +[list_begin bullet] +[bullet] +Emulate the [emph create] subcommand to create all the items in the +correct format + +[bullet] +Emulate the [emph cget] subcommand for the options -width and -height to +allow the correct calculation of the rectangle's position and size + +[bullet] +Solve the problem of [emph raising] and [emph lowering] the items so +that they are properly clipped, for instance by redefining the +routine DrawMask. + +[bullet] +Take care of the currently fixed text size properties + +[list_end] + + [section {ROOM FOR IMPROVEMENT}] In this version there are a lot of things that still need to From 6cfdc8667f39229cc8fb993aabfb07c35f684e2a Mon Sep 17 00:00:00 2001 From: jfontain Date: Wed, 28 Apr 2004 21:14:19 +0000 Subject: [PATCH 0009/1290] reformatted in 80 columns width. --- modules/tkpiechart/objselec.tcl | 11 +++-- modules/tkpiechart/relirect.tcl | 88 +++++++++++++++++++++------------ 2 files changed, 62 insertions(+), 37 deletions(-) diff --git a/modules/tkpiechart/objselec.tcl b/modules/tkpiechart/objselec.tcl index 8b83c470..42faee05 100644 --- a/modules/tkpiechart/objselec.tcl +++ b/modules/tkpiechart/objselec.tcl @@ -1,10 +1,11 @@ -# copyright (C) 1997-98 Jean-Luc Fontaine (mailto:jfontain@free.fr) -# this program is free software: please read the COPYRIGHT file enclosed in this package or use the Help Copyright menu +# copyright (C) 1997-2004 Jean-Luc Fontaine (mailto:jfontain@free.fr) +# this program is free software: please read the COPYRIGHT file enclosed in this +# package or use the Help Copyright menu -# $Id: objselec.tcl,v 1.11 2004/04/13 14:18:56 jfontain Exp $ - -# implements selection on a list of object identifiers (sortable list of integer), for a listbox implementation, for example +# $Id: objselec.tcl,v 1.12 2004/04/28 21:14:19 jfontain Exp $ +# implements selection on a list of object identifiers (sortable list of +# integers), for a listbox implementation, for example ::stooop::class objectSelector { diff --git a/modules/tkpiechart/relirect.tcl b/modules/tkpiechart/relirect.tcl index 9f37cb1b..6d09fa1f 100644 --- a/modules/tkpiechart/relirect.tcl +++ b/modules/tkpiechart/relirect.tcl @@ -1,11 +1,13 @@ -# $Id: relirect.tcl,v 1.4 2002/05/30 17:11:45 jfontain Exp $ +# $Id: relirect.tcl,v 1.5 2004/04/28 21:14:19 jfontain Exp $ ::stooop::class canvasReliefRectangle { proc canvasReliefRectangle {this canvas args} switched {$args} { - set ($this,topLeft) [$canvas create line 0 0 0 0 0 0 -tags canvasReliefRectangle($this)] - set ($this,bottomRight) [$canvas create line 0 0 0 0 0 0 -tags canvasReliefRectangle($this)] + set ($this,topLeft)\ + [$canvas create line 0 0 0 0 0 0 -tags canvasReliefRectangle($this)] + set ($this,bottomRight)\ + [$canvas create line 0 0 0 0 0 0 -tags canvasReliefRectangle($this)] set ($this,canvas) $canvas switched::complete $this } @@ -14,7 +16,8 @@ $($this,canvas) delete canvasReliefRectangle($this) } - proc options {this} { ;# force background initialization for color calculations + proc options {this} { + # force background initialization for color calculations return [list\ [list -background white]\ [list -coordinates {0 0 0 0} {0 0 0 0}]\ @@ -22,59 +25,80 @@ ] } - proc set-background {this value} { ;# algorithm stolen from tkUnix3d.c - set intensity 65535 ;# maximum intensity + proc set-background {this value} { ;# algorithm stolen from tkUnix3d.c + set intensity 65535 ;# maximum intensity foreach {red green blue} [winfo rgb $($this,canvas) $value] {} - if {(($red*0.5*$red)+($green*1.0*$green)+($blue*0.28*$blue))<($intensity*0.05*$intensity)} { + if {\ + (\ + ($red * 0.5 * $red) + ($green * 1.0 * $green) +\ + ($blue * 0.28 * $blue)\ + ) < ($intensity * 0.05 * $intensity)\ + } { set ($this,dark) [format {#%04X%04X%04X}\ - [expr {($intensity+(3*$red))/4}] [expr {($intensity+(3*$green))/4}] [expr {($intensity+(3*$blue))/4}]\ + [expr {($intensity + (3 * $red)) / 4}]\ + [expr {($intensity + (3 * $green)) / 4}]\ + [expr {($intensity + (3 * $blue)) / 4}]\ ] } else { - set ($this,dark) [format {#%04X%04X%04X} [expr {(60*$red)/100}] [expr {(60*$green)/100}] [expr {(60*$blue)/100}]] + set ($this,dark) [format {#%04X%04X%04X}\ + [expr {(60 * $red) / 100}] [expr {(60 * $green) / 100}]\ + [expr {(60 * $blue) / 100}]\ + ] } - if {$green>($intensity*0.95)} { - set ($this,light) [format {#%04X%04X%04X} [expr {(90*$red)/100}] [expr {(90*$green)/100}] [expr {(90*$blue)/100}]] + if {$green > ($intensity * 0.95)} { + set ($this,light) [format {#%04X%04X%04X}\ + [expr {(90 * $red) / 100}] [expr {(90 * $green) / 100}]\ + [expr {(90 * $blue) / 100}]\ + ] } else { - set tmp1 [expr {(14*$red)/10}] - if {$tmp1>$intensity} {set tmp1 $intensity} - set tmp2 [expr {($intensity+$red)/2}] - set lightRed [expr {($tmp1>$tmp2)?$tmp1:$tmp2}] - set tmp1 [expr {(14*$green)/10}] - if {$tmp1>$intensity} {set tmp1 $intensity} - set tmp2 [expr {($intensity+$green)/2}] - set lightGreen [expr {($tmp1>$tmp2)?$tmp1:$tmp2}] - set tmp1 [expr {(14*$blue)/10}] - if {$tmp1>$intensity} {set tmp1 $intensity} - set tmp2 [expr {($intensity+$blue)/2}] - set lightBlue [expr {($tmp1>$tmp2)?$tmp1:$tmp2}] - set ($this,light) [format {#%04X%04X%04X} $lightRed $lightGreen $lightBlue] + set tmp1 [expr {(14 * $red) / 10}] + if {$tmp1 > $intensity} {set tmp1 $intensity} + set tmp2 [expr {($intensity + $red) / 2}] + set lightRed [expr {$tmp1 > $tmp2? $tmp1: $tmp2}] + set tmp1 [expr {(14 * $green) / 10}] + if {$tmp1 > $intensity} {set tmp1 $intensity} + set tmp2 [expr {($intensity + $green) / 2}] + set lightGreen [expr {$tmp1 > $tmp2? $tmp1: $tmp2}] + set tmp1 [expr {(14 * $blue) / 10}] + if {$tmp1 > $intensity} {set tmp1 $intensity} + set tmp2 [expr {($intensity + $blue) / 2}] + set lightBlue [expr {$tmp1 > $tmp2? $tmp1: $tmp2}] + set ($this,light)\ + [format {#%04X%04X%04X} $lightRed $lightGreen $lightBlue] } update $this } proc set-coordinates {this value} { foreach {left top right bottom} $value {} - $($this,canvas) coords $($this,topLeft) $left $bottom $left $top $right $top - $($this,canvas) coords $($this,bottomRight) $right $top $right $bottom $left $bottom + $($this,canvas) coords $($this,topLeft)\ + $left $bottom $left $top $right $top + $($this,canvas) coords $($this,bottomRight)\ + $right $top $right $bottom $left $bottom } proc set-relief {this value} { - if {![info exists ($this,dark)]} return ;# colors not yet calculated + if {![info exists ($this,dark)]} return ;# colors not yet calculated update $this } proc update {this} { switch $switched::($this,-relief) { flat { - $($this,canvas) itemconfigure canvasReliefRectangle($this) -fill $switched::($this,-background) + $($this,canvas) itemconfigure canvasReliefRectangle($this)\ + -fill $switched::($this,-background) } raised { - $($this,canvas) itemconfigure $($this,topLeft) -fill $($this,light) - $($this,canvas) itemconfigure $($this,bottomRight) -fill $($this,dark) + $($this,canvas) itemconfigure $($this,topLeft)\ + -fill $($this,light) + $($this,canvas) itemconfigure $($this,bottomRight)\ + -fill $($this,dark) } sunken { - $($this,canvas) itemconfigure $($this,topLeft) -fill $($this,dark) - $($this,canvas) itemconfigure $($this,bottomRight) -fill $($this,light) + $($this,canvas) itemconfigure $($this,topLeft)\ + -fill $($this,dark) + $($this,canvas) itemconfigure $($this,bottomRight)\ + -fill $($this,light) } default { error "bad relief value \"$value\": must be flat, raised or sunken" From 6ffe1cecada6125d998c6466cad2af1dcbc1f890 Mon Sep 17 00:00:00 2001 From: jfontain Date: Sun, 2 May 2004 16:01:18 +0000 Subject: [PATCH 0010/1290] Initial revision --- modules/tkpiechart/canvaslabel.man | 71 ++++++++++++++ modules/tkpiechart/demo.tcl | 103 ++++++++++++++++++++ modules/tkpiechart/pie.man | 86 ++++++++++++++++ modules/tkpiechart/pieboxlabeler.man | 42 ++++++++ modules/tkpiechart/pieperipherallabeler.man | 47 +++++++++ 5 files changed, 349 insertions(+) create mode 100644 modules/tkpiechart/canvaslabel.man create mode 100755 modules/tkpiechart/demo.tcl create mode 100644 modules/tkpiechart/pie.man create mode 100644 modules/tkpiechart/pieboxlabeler.man create mode 100644 modules/tkpiechart/pieperipherallabeler.man diff --git a/modules/tkpiechart/canvaslabel.man b/modules/tkpiechart/canvaslabel.man new file mode 100644 index 00000000..44d6ad68 --- /dev/null +++ b/modules/tkpiechart/canvaslabel.man @@ -0,0 +1,71 @@ +[comment {-*- tk -*- canvasLabel manpage}] +[manpage_begin canvasLabel n 6.6] +[copyright {1995-2004 Jean-Luc Fontaine }] +[moddesc {canvasLabel class}] +[titledesc {tkpiechart canvas label class}] + +[require stooop 4.1] +[require switched 2.2] +[require tkpiechart 6.6] +[description] +The canvasLabel class brings some Tk label widget functionality to the canvas text item, such as a background and a border. +[para]The canvasLabel is built with a bullet rectangle on the left side of the text. The relief changes according to the select state, with a traditionally sunken relief when selected. +[para]The label has a specific tag, which can be used to retrieve the coordinates of the object or move it, thanks to the canvas facilities. +[list_begin definitions] +[call [cmd stooop::new] [class canvasLabel] [arg canvas] [opt options]] +Creates a canvasLabel object in the specified Tk canvas. The canvasLabel object identifier is returned (referred to as [emph canvasLabelObject] in this document). +[call [cmd switched::configure] [arg canvasLabelObject] [opt options]] +Configures a canvasLabel object or returns all the options with their current values if no options are passed as parameters. +[call [cmd switched::cget] [arg canvasLabelObject] [arg option]] +Returns an option value for the specified canvasLabel object. +[call [cmd stooop::delete] [arg canvasLabelObject]] +Deletes the specified canvasLabel object. +[list_end] + +[section OPTIONS] +[list_begin opt] +[opt_def -anchor value] +Specifies the anchor position of the rectangle and the text, relative to the positioning point. The behavior is similar to the [option -anchor] option of the [syscmd canvas] [emph text] item, except that the rectangle is taken into account. The default is [emph center]. +[opt_def -background color] +Specifies the background color of the bullet rectangle, as in the [option -fill] option of the [syscmd canvas] [emph rectangle] item. The default is transparent (empty string). +[opt_def -bordercolor color] +Specifies the border color of the rectangle, as in the [option -outline] option of the [syscmd canvas] [emph rectangle] item. The default is black. +[opt_def -borderwidth value] +Specifies the border width of the rectangle, as in the [option -width] option of the [syscmd canvas] [emph rectangle] item. By default, the width is 1 pixel, which is the minimum width. +[opt_def -bulletwidth value] +Specifies the width of the rectangle placed to the left of the text. Defaults to [emph 10]. +[opt_def -font value] +Specifies the font of the text, as in the [option -font] option of the [syscmd canvas] [emph text] item. The default is system dependent. +[opt_def -foreground color] +Specifies the color of the text, as in the [option -fill] option of the [syscmd canvas] [emph text] item. The default is black. +[opt_def -justify value] +Specifies how to justify the text, as in the [option -justify] option of the [syscmd canvas] [emph text] item. The default is [emph left]. +[opt_def -minimumwidth value] +The total label width will not go below the specified value, but may be larger if the label text requires it. +[opt_def -padding value] +Specifies how much space to leave between the text and the closest rectangle edge. Units are identical to those specified in the [syscmd canvas] [emph COORDINATES] manual section. +[opt_def -scale list] +List of 2 floating point numbers used to set the scaling factor in the x and y axis. Scaling is applied immediately and defaults to 1. +[opt_def -select boolean] +Sets the label state. +[opt_def -selectrelief value] +Either [emph flat], [emph raised] or [emph sunken]. Specifies the 3D effect desired for the text area when the label is selected. +[opt_def -stipple bitmap] +Specifies the stipple pattern filling the rectangle, as in the [option -stipple] option of the [syscmd canvas] [emph rectangle] item. There is no bitmap by default. +[opt_def -text text] +Specifies the string to be displayed in the text area, as in the [option -text] option of the [syscmd canvas] [emph text] item. The default is an empty string. +[opt_def -textbackground color] +Specifies the color of the text area background. +[opt_def -width value] +Specifies a maximum line length for the text, as in the [option -width] option of the [syscmd canvas] [emph text] item. The default is [emph 0]. +[list_end] + +[section TAGS] +The labeler has the following specific tag (see the [syscmd canvas] manual page [emph {ITEM IDS AND TAGS}] section for more information): +[list_begin bullet] + [bullet]canvasLabel(canvasLabelObject) +[list_end] + +[see_also pie pieBoxLabeler piePeripheralLabeler] +[keywords pie slice labeler canvas] +[manpage_end] diff --git a/modules/tkpiechart/demo.tcl b/modules/tkpiechart/demo.tcl new file mode 100755 index 00000000..b7d98674 --- /dev/null +++ b/modules/tkpiechart/demo.tcl @@ -0,0 +1,103 @@ +#!/bin/sh +# the next line restarts using the interpreter \ +exec wish "$0" "$@" + + +package require stooop 4.1 +namespace import stooop::* +package require switched 2.2 +package require tkpiechart 6.3 + + +pack [label .m -relief sunken -text\ + "you may move a pie by holding down mouse button 1 over any part of it"\ +] -fill x + +set canvas [canvas .c -highlightthickness 0] +pack $canvas -fill both -expand 1 + +set pie1 [new pie\ + $canvas 0 0 -height 100 -thickness 20 -background gray\ + -labeler [new pieBoxLabeler $canvas -justify center -offset 10]\ + -title "this is pie #1" -titlefont fixed -titleoffset 6 -selectable 1\ +] +# create a few slices +set slice11 [pie::newSlice $pie1] +set slice12 [pie::newSlice $pie1] +set slice13 [pie::newSlice $pie1] +set slice14 [pie::newSlice $pie1 {some text}] + +set pie2 [new pie\ + $canvas 0 0 -height 100 -thickness 10 -background white\ + -labeler [\ + new piePeripheralLabeler $canvas\ + -font {-weight bold -family Helvetica -size -20}\ + -smallfont {-family Helvetica -size -8} -bulletwidth 1c\ + ]\ + -title "this is pie #2" -titleoffset 10\ +] +set slice21 [pie::newSlice $pie2] +set slice22 [pie::newSlice $pie2] + +# move pies through their tags +$canvas move pie($pie1) 10 40 +$canvas move pie($pie2) 240 40 + +# move pie when holding mouse button 1 in pie/labels area +for {set index 1} {$index <= 2} {incr index} { + $canvas bind pie([set pie$index]) " + set xLast($index) %x + set yLast($index) %y + " + $canvas bind pie([set pie$index]) " + $canvas move pie([set pie$index])\ + \[expr %x - \$xLast($index)\] \[expr %y - \$yLast($index)\] + set xLast($index) %x + set yLast($index) %y + " +} + +# add a couple of buttons +button .d -text {Delete Pies} -command " + # delete pies thus freeing pie data and destroying pie widgets + delete $pie1 $pie2 + .d configure -state disabled + set delete 1 +" +button .q -text Exit -command exit +pack .d .q -side left -fill x -expand 1 + +# now start some animation + +set delete 0 +set u 1 + +proc refresh {} { + if {$::delete} return + # size the slices in a semi randow way (slice size in per cent of whole pie) + set ::u [expr (3 * $::u) % 31] + pie::sizeSlice $::pie1 $::slice11 [expr $::u / 100.0] + set ::u [expr (5 * $::u) % 31] + pie::sizeSlice $::pie1 $::slice12 [expr $::u / 100.0] + set ::u [expr (7 * $::u) % 31] + # display lebel value in percent for this slice + pie::sizeSlice $::pie1 $::slice13 [expr $::u / 100.0] "$::u %" + pie::sizeSlice $::pie2 $::slice21 [expr $::u / 100.0] $::u + set ::u [expr (11 * $::u) % 31] + pie::sizeSlice $::pie1 $::slice14 [expr $::u / 100.0] + pie::sizeSlice $::pie2 $::slice22 [expr $::u / 100.0] $::u + update + after 3000 refresh +} + +proc resize {width height} { + set width [expr {$width / 2.0}] + set height [expr {$height / 2.0}] + switched::configure $::pie1 -width $width -height $height + switched::configure $::pie2 -width $width -height $height + $::canvas configure -scrollregion [$::canvas bbox all] +} + +$canvas configure -width 400 -height 300 +bind $canvas "resize %w %h" +refresh diff --git a/modules/tkpiechart/pie.man b/modules/tkpiechart/pie.man new file mode 100644 index 00000000..81567a4d --- /dev/null +++ b/modules/tkpiechart/pie.man @@ -0,0 +1,86 @@ +[comment {-*- tk -*- pie manpage}] +[manpage_begin pie n 6.6] +[copyright {1995-2004 Jean-Luc Fontaine }] +[moddesc {tkpiechart pie class}] +[titledesc {2D or 3D pie chart object in a canvas}] + +[require stooop 4.1] +[require switched 2.2] +[require tkpiechart 6.6] +[description] +A pie object is used to visualize a set of values, usually as shares of a total. Each value is represented by a colored slice, which may have a 2 dimensional or 3 dimensional look. Each slice is associated with a label displaying the data name, and a numerical field showing the percentage taken by the slice. The labels are placed by the chosen labeler object ([option -labeler] option). Each label color matches its related slice. +[para]A pie chart is made of Tk canvas items, found in [class pieBoxLabeler], [class piePeripheralLabeler] and [class canvasLabel] objects, that compose the pie object. The pie constructor creates the pie itself and its background slice within the parent canvas. Once the pie object exists, slices can be created and resized. At the time the pie is created, the parent Tk [syscmd canvas] widget must exist. +[para]Slice colors are automatically generated, using a default color list for all pies, unless another list is used (using the [option -colors] option). When a 3D look is used, the slice edge is darker than its top while using the same color tone. +[list_begin definitions] +[call [cmd stooop::new] [class pie] [arg canvas] [arg x] [arg y] [opt options]] +Creates a pie object in the specified Tk canvas. The upper left corner of the pie is placed at the specified coordinates in the canvas. The pie object identifier is returned (referred to as [emph pieObject] in this document). +[call [cmd switched::configure] [arg pieObject] [opt options]] +Configures a pie object or returns all the options with their current values if no options are passed as parameters. +[call [cmd switched::cget] [arg pieObject] [arg option]] +Returns an option value for the specified pie object. +[call [cmd stooop::delete] [arg pieObject]] +Deletes the specified pie object. +[list_end] + +[section OVERVIEW] +The pie class is part of the tkpiechart extension that allows the programmer to create and dynamically update 2D or 3D pie charts in a Tcl/Tk application. The tkpiechart package is written in Tcl only, using object oriented techniques thanks to the stooop package, included in tcllib. + +[section OPTIONS] +[list_begin opt] +[opt_def -autoupdate boolean] +Boolean value specifying whether all the slices and their labels are redrawn when a slice size is changed. On by default. Turn it off and invoke [method pie::update] if you change many slices at once and want to improve performance. +[opt_def -background color] +Slices may or may not fill up the 100% of the pie. The unoccupied part of the pie is a slice that takes 100% of the pie. It is by default transparent with a black border. The color of this background slice may be set by the user using color names as in the [option -background] standard option (see the Tk [syscmd options] manual page for more details). When the pie has a 3D look, the background of a slice edge is darker than the top and uses the same color tone. +[opt_def -colors list] +Specifies a list of colors for slices. In this case, the slice colors will successively be drawn from the list in the list order, cycling through if there are more slices than colors in the list. Colors are specified in the same format as the [option -background] option. +[opt_def -height value] +Specifies the total height for the pie, including the room taken by the labeler labels. The pie slices are resized when labels are added or deleted (when adding or deleting slices) so that the total height remains constant. This value may be specified in any of the forms described in the [syscmd canvas] [emph COORDINATES] manual section. +[opt_def -labeler object] +Specifies a placer object for the slice labels, so that, for example, slice values may be placed next to them. If not specified, the [emph pieBoxLabeler] (see corresponding manual) is used, the other option being the [emph piePeripheralLabeler] class. Each labeler has a specific behavior which may be set via its options. The labeler object is automatically deleted when the pie object is itself deleted. The labeler cannot be changed once the pie is created. +[opt_def -selectable boolean] +Boolean value specifying whether slices are selectable or not. Acceptable values are those defined by the Tcl language itself for boolean values. If selectable, slices can be selected with the first mouse button, by clicking on either the slice or its label. Selection can be extended by using the classical [emph control] or [emph shift] clicks. The list of currently selected slices can be retrieved at any time using the [method selectedSlices] pie class member procedure. +[opt_def -title text] +Title text to be placed above the pie. +[opt_def -titlefont value] +Font for the title text. +[opt_def -titleoffset value] +Distance between the bottom of the title text and the top of the pie slices. This value may be specified in any of the forms described in the sizes section below. +[opt_def -thickness value] +The thickness is set to 0 by default, giving the pie a simple 2D shape, much faster to display. A positive thickness value will give the pie a 3D look with matched darker colors for the slices edges. These values may be specified in any of the forms described in the [emph SIZES] section below. +[opt_def -width value] +Specifies the total width for the pie, including the room taken by the labeler labels. The pie slices are resized when labels are added or deleted (when adding or deleting slices) so that the total width remains constant. This value may be specified in any of the forms described in the [syscmd canvas] [emph COORDINATES] manual section. +[list_end] + +[section {MEMBER PROCEDURES}] +[list_begin definitions] +[call pie::newSlice [arg pieObject] [opt labelText]] +Creates a slice. A unique object identifier is returned (referred to as [emph sliceObject] in this document). The slice color is automatically allocated and the slice label placed using the specified labeler (using the [option -labeler] option). The slice itself is placed after (clockwise) the existing slices. The slice object identifier will be used for sizing and resizing the slice. +[nl]If the label text is not specified, it will be set to [emph {"slice n"}], [emph n] being the number of the slice in the order of creation (first slice is number 1). +[call pie::deleteSlice [arg pieObject] [arg sliceObject]] +Deletes a slice. The following slices (clockwise) if any are then moved to compensate for the empty space left by the deleted slice. +[call pie::sizeSlice [arg pieObject] [arg sliceObject] [arg unitShare] [opt displayedValue]] +Sizes or resizes a slice. The slice is then automatically recalculated so it occupies the proper share of the whole pie. The [arg unitShare] parameter is a floating point number expressed in share (between 0 and 1) of the whole pie. The following slices (clockwise) are moved to accommodate the new slice size. The slice size value next to the slice label is also updated with the new share value or [arg displayedValue] if specified. +[call pie::labelSlice [arg pieObject] [arg sliceObject] [arg string]] +Updates a slice label. Can be invoked at any time. +[call pie::selectedSlices [arg pieObject]] +Returns a list of currently selected slice objects. +[list_end] + +[section TAGS] +The whole pie, the pie graphics (all slices), and each slice have the following specific tags: +[list_begin bullet] + [bullet][var {pie(pieObject)}] + [bullet][var {pieSlices(pieObject)}] + [bullet][var {slice(sliceObject)}] +[list_end] +For example, the whole pie can be moved using the [syscmd canvas] [cmd move] command on the pie tag, or bindings on slices can be set using the slice tags (see the [syscmd canvas] manual page [emph {ITEM IDS AND TAGS}] section for more information). + +[section SIZES] +All sizes related to pies are stored as floating point numbers. The coordinates and sizes are specified in screen units, which are floating point numbers optionally followed by one of several letters as specified in the [syscmd canvas] [emph COORDINATES] manual section. + +[section LIMITATIONS] +If the number of slices is too big, identical colors will be used for some of the slices. You may set your own colors in this case. + +[see_also pieBoxLabeler piePeripheralLabeler canvasLabel] +[keywords pie slice labeler canvas] +[manpage_end] diff --git a/modules/tkpiechart/pieboxlabeler.man b/modules/tkpiechart/pieboxlabeler.man new file mode 100644 index 00000000..f3500980 --- /dev/null +++ b/modules/tkpiechart/pieboxlabeler.man @@ -0,0 +1,42 @@ +[comment {-*- tk -*- pieBoxLabeler manpage}] +[manpage_begin pieBoxLabeler n 6.6] +[copyright {1995-2004 Jean-Luc Fontaine }] +[moddesc {pieBoxLabeler class}] +[titledesc {tkpiechart pie box style labeler class}] + +[require stooop 4.1] +[require switched 2.2] +[require tkpiechart 6.6] +[description] +The pie box style labeler object is used as a slice label placer for a [class pie] object and is passed to the pie constructor via its [option -labeler] option (see the [class pie] class manual). +[para]The labels are arranged in 2 columns below the pie graphics. Each label text is placed to the right of a rectangle, the background color of which matches its corresponding slice. The slice share value is placed to the right of the label text, separated by a semicolon. Each label is actually a canvasLabel object (see the [class canvasLabel] class manual for further information). +[para]There is no need to delete a [class pieBoxLabeler] object as it is automatically handled by the pie class. +[list_begin definitions] +[call [cmd stooop::new] [class pieBoxLabeler] [arg canvas] [opt options]] +Creates a pieBoxLabeler object in the specified Tk canvas. The pieBoxLabeler object identifier is returned (referred to as [emph pieBoxLabelerObject] in this document). +[call [cmd switched::configure] [arg pieBoxLabelerObject] [opt options]] +Configures a pieBoxLabeler object or returns all the options with their current values if no options are passed as parameters. +[call [cmd switched::cget] [arg pieBoxLabelerObject] [arg option]] +Returns an option value for the specified pieBoxLabeler object. +[list_end] + +[section OPTIONS] +[list_begin opt] +[opt_def -font value] +Specifies a font for the slice labels. If not specified, the default font is system dependent. +[opt_def -justify value] +Specifies how to justify labels within their own column. Must be one of [emph left], [emph center] or [emph right]. Defaults to [emph left]. For example, if justification is [emph right], all column labels right edges are aligned. +[opt_def -offset value] +Specifies the distance between the pie graphics and the closest slice label. This value may be specified in any of the forms described in the [syscmd canvas] [emph COORDINATES] manual section. +[list_end] + +[section TAGS] +The labeler has the following specific tag (see the [syscmd canvas] manual page [emph {ITEM IDS AND TAGS}] section for more information): +[list_begin bullet] + [bullet]pieBoxLabeler(pieBoxLabelerObject) +[list_end] + +[see_also pie piePeripheralLabeler canvasLabel] +[keywords pie slice labeler canvas] +[manpage_end] + diff --git a/modules/tkpiechart/pieperipherallabeler.man b/modules/tkpiechart/pieperipherallabeler.man new file mode 100644 index 00000000..297644cd --- /dev/null +++ b/modules/tkpiechart/pieperipherallabeler.man @@ -0,0 +1,47 @@ +[comment {-*- tk -*- piePeripheralLabeler manpage}] +[manpage_begin piePeripheralLabeler n 6.6] +[copyright {1995-2004 Jean-Luc Fontaine }] +[moddesc {piePeripheralLabeler class}] +[titledesc {tkpiechart pie peripheral style labeler class}] + +[require stooop 4.1] +[require switched 2.2] +[require tkpiechart 6.6] +[description] +The pie peripheral style labeler object is used as a slice label placer for a [class pie] object and is passed to the pie constructor via its [option -labeler] option (see the [class pie] class manual). +[para]The slice description text labels are arranged in 2 columns below the pie graphics, whereas the slice values are placed next to the slice and actually follow the slice as the pie is updated. Each description label text is placed to the right of a rectangle, the background color of which matches its corresponding slice. Each description label is actually a canvasLabel object. +[para]There is no need to delete a [class piePeripheralLabeler] object as it is automatically handled by the pie class. +[list_begin definitions] +[call [cmd stooop::new] [class piePeripheralLabeler] [arg canvas] [opt options]] +Creates a piePeripheralLabeler object in the specified Tk canvas. The piePeripheralLabeler object identifier is returned (refered to as [emph piePeripheralLabelerObject] in this document). +[call [cmd switched::configure] [arg piePeripheralLabelerObject] [opt options]] +Configures a piePeripheralLabeler object or returns all the options with their current values if no options are passed as parameters. +[call [cmd switched::cget] [arg piePeripheralLabelerObject] [arg option]] +Returns an option value for the specified piePeripheralLabeler object. +[list_end] + +[section OPTIONS] +[list_begin opt] +[opt_def -font value] +Specifies a font for the slice labels. If not specified, the default font is system dependent. +[opt_def -justify value] +Specifies how to justify labels within their own column. Must be one of [emph left], [emph center] or [emph right]. Defaults to [emph left]. For example, if justification is [emph right], all column labels right edges are aligned. +[opt_def -offset value] +Specifies the distance between the pie graphics and the closest slice label. This value may be specified in any of the forms described in the [syscmd canvas] [emph COORDINATES] manual section. +[opt_def -smallfont] +Specifies a font for the slice values. It is usually a small font in order to avoid values overlapping when 2 slices are very close to each other. If not specified, the description label font ([option -font] option) is used. +[opt_def -widestvaluetext] +Specifies a string of maximum width for slice values (placed around the pie next to the slices), so that enough room is allocated for these value labels when the pie width and height are set. It defaults to 00.0. For example, it could be set to "00.00 %". + +[list_end] + +[section TAGS] +The labeler has the following specific tag (see the [syscmd canvas] manual page [emph {ITEM IDS AND TAGS}] section for more information): +[list_begin bullet] + [bullet]piePeripheralLabeler(piePeripheralLabelerObject) +[list_end] + +[see_also pie pieBoxLabeler canvasLabel] +[keywords pie slice labeler canvas] +[manpage_end] + From aa1c6297775971cab51c8db955dc6671b8643356 Mon Sep 17 00:00:00 2001 From: jfontain Date: Sun, 2 May 2004 16:04:39 +0000 Subject: [PATCH 0011/1290] removed RCS id, added copyright. --- modules/tkpiechart/demo.tcl | 2 ++ modules/tkpiechart/relirect.tcl | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/modules/tkpiechart/demo.tcl b/modules/tkpiechart/demo.tcl index b7d98674..7e4ef5fd 100755 --- a/modules/tkpiechart/demo.tcl +++ b/modules/tkpiechart/demo.tcl @@ -2,6 +2,8 @@ # the next line restarts using the interpreter \ exec wish "$0" "$@" +# copyright (C) 1995-2004 Jean-Luc Fontaine (mailto:jfontain@free.fr) + package require stooop 4.1 namespace import stooop::* diff --git a/modules/tkpiechart/relirect.tcl b/modules/tkpiechart/relirect.tcl index 6d09fa1f..2d574b55 100644 --- a/modules/tkpiechart/relirect.tcl +++ b/modules/tkpiechart/relirect.tcl @@ -1,4 +1,4 @@ -# $Id: relirect.tcl,v 1.5 2004/04/28 21:14:19 jfontain Exp $ +# copyright (C) 1995-2004 Jean-Luc Fontaine (mailto:jfontain@free.fr) ::stooop::class canvasReliefRectangle { From bab82423623b025daf7ea7acd6feed55fb1bb172 Mon Sep 17 00:00:00 2001 From: jfontain Date: Sun, 2 May 2004 16:56:31 +0000 Subject: [PATCH 0012/1290] removed package requirements. --- modules/tkpiechart/pieboxlabeler.man | 3 --- modules/tkpiechart/pieperipherallabeler.man | 3 --- 2 files changed, 6 deletions(-) diff --git a/modules/tkpiechart/pieboxlabeler.man b/modules/tkpiechart/pieboxlabeler.man index f3500980..7e855042 100644 --- a/modules/tkpiechart/pieboxlabeler.man +++ b/modules/tkpiechart/pieboxlabeler.man @@ -4,9 +4,6 @@ [moddesc {pieBoxLabeler class}] [titledesc {tkpiechart pie box style labeler class}] -[require stooop 4.1] -[require switched 2.2] -[require tkpiechart 6.6] [description] The pie box style labeler object is used as a slice label placer for a [class pie] object and is passed to the pie constructor via its [option -labeler] option (see the [class pie] class manual). [para]The labels are arranged in 2 columns below the pie graphics. Each label text is placed to the right of a rectangle, the background color of which matches its corresponding slice. The slice share value is placed to the right of the label text, separated by a semicolon. Each label is actually a canvasLabel object (see the [class canvasLabel] class manual for further information). diff --git a/modules/tkpiechart/pieperipherallabeler.man b/modules/tkpiechart/pieperipherallabeler.man index 297644cd..bcd66171 100644 --- a/modules/tkpiechart/pieperipherallabeler.man +++ b/modules/tkpiechart/pieperipherallabeler.man @@ -4,9 +4,6 @@ [moddesc {piePeripheralLabeler class}] [titledesc {tkpiechart pie peripheral style labeler class}] -[require stooop 4.1] -[require switched 2.2] -[require tkpiechart 6.6] [description] The pie peripheral style labeler object is used as a slice label placer for a [class pie] object and is passed to the pie constructor via its [option -labeler] option (see the [class pie] class manual). [para]The slice description text labels are arranged in 2 columns below the pie graphics, whereas the slice values are placed next to the slice and actually follow the slice as the pie is updated. Each description label text is placed to the right of a rectangle, the background color of which matches its corresponding slice. Each description label is actually a canvasLabel object. From 852e003582e7a317a5a35d0def7268208449c7db Mon Sep 17 00:00:00 2001 From: Andreas Kupries Date: Wed, 19 May 2004 01:57:56 +0000 Subject: [PATCH 0013/1290] Added tkpiechart to list of installed modules. Brought main ChangeLog uptodate with respect ot new modules and when they were added. --- ChangeLog | 23 +++++++++++++++++++++++ installed_modules.tcl | 1 + 2 files changed, 24 insertions(+) diff --git a/ChangeLog b/ChangeLog index fb698cd0..064ed372 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,26 @@ +2004-05-18 Andreas Kupries + + * New module 'tkpiechart'. This has been donated by Jean-Luc + Fontaine. Thanks. It is based on his stoop OO package, found in + our sibling 'Tcllib'. + + * installed_modules.tcl: Added tkpiechart to the list of installed + modules. + +2004-04-15 Andreas Kupries + + * New module 'plotchart', by Arjen Markus. Thanks for this + donation. + +2004-04-04 David N. Welton + + * New module 'style'. Various Tk styles/themes. + +2004-04-15 Andreas Kupries + + * New module 'ctext', by George Peter Staplin. Thanks for this + donation. + 2003-11-28 Andreas Kupries * Reworked the entire build system to use the same framework as diff --git a/installed_modules.tcl b/installed_modules.tcl index 7bc67690..ea0c5fed 100755 --- a/installed_modules.tcl +++ b/installed_modules.tcl @@ -21,6 +21,7 @@ foreach {m pkg doc exa} { datefield _tcl _man _null ipentry _tcl _man _null plotchart _tcl _man _exa + tkpiechart _tcl _man _null } { lappend modules $m set guide($m,pkg) $pkg From 697a1e9438bf2532f47ef410baa33cfb9e1b3e87 Mon Sep 17 00:00:00 2001 From: Arjen Markus Date: Wed, 9 Jun 2004 10:26:51 +0000 Subject: [PATCH 0014/1290] Corrected an error in scaling.tcl and the associated tests - the lower bound was wrong in some cases --- modules/plotchart/plotchart.test | 19 ++++++++----------- modules/plotchart/scaling.tcl | 3 +++ 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/modules/plotchart/plotchart.test b/modules/plotchart/plotchart.test index 70ba6a55..520cb94d 100755 --- a/modules/plotchart/plotchart.test +++ b/modules/plotchart/plotchart.test @@ -38,6 +38,11 @@ puts "Plotchart [package present Plotchart]" # ------------------------------------------------------------------------- +# +# Note: +# The tests are formulated such that the resulting numbers +# are exact. There is no need for a tolerance in the comparison +# proc matchNumbers {expected actual} { set match 1 foreach a $actual e $expected { @@ -114,14 +119,6 @@ test Plotchart-2.3 {Pixel to world coordinates - ordering} -match numbers -body ::Plotchart::pixelToCoords "window" 110 120 } -result {100 0} - -puts [::Plotchart::determineScale -0.2 0.9] -puts [::Plotchart::determineScale -0.25 0.85] -puts [::Plotchart::determineScale -0.25 0.7999] -puts [::Plotchart::determineScale 10001 10010] -puts [::Plotchart::determineScale 10001 10015] - - test Plotchart-2.4 {Nice scale 1} -match numbers -body { ::Plotchart::determineScale 0.1 1.0 } -result {0.0 1.0 0.2} @@ -136,15 +133,15 @@ test Plotchart-2.6 {Nice scale 3} -match numbers -body { test Plotchart-2.7 {Nice scale 4} -match numbers -body { ::Plotchart::determineScale -0.25 0.85 -} -result {-0.2 1.0 0.2} +} -result {-0.4 1.0 0.2} test Plotchart-2.8 {Nice scale 5} -match numbers -body { ::Plotchart::determineScale -0.25 0.7999 -} -result {-0.2 0.8 0.2} +} -result {-0.4 0.8 0.2} test Plotchart-2.9 {Nice scale 6} -match numbers -body { ::Plotchart::determineScale 10001 10010 -} -result {10001 10010 2} +} -result {10000 10010 2} test Plotchart-2.10 {Nice scale 7} -match numbers -body { ::Plotchart::determineScale 10001 10015 diff --git a/modules/plotchart/scaling.tcl b/modules/plotchart/scaling.tcl index b8e589a0..6b2982aa 100755 --- a/modules/plotchart/scaling.tcl +++ b/modules/plotchart/scaling.tcl @@ -50,6 +50,9 @@ proc ::Plotchart::determineScale { xmin xmax } { if { $nicemax < $xmax } { set nicemax [expr {$nicemax+$step}] } + if { $nicemin > $xmin } { + set nicemin [expr {$nicemin-$step}] + } return [list $nicemin $nicemax [expr {$step*$factor}]] } From 3f44de59ba22945f038a458b95c298154ce421ee Mon Sep 17 00:00:00 2001 From: Arjen Markus Date: Thu, 10 Jun 2004 07:31:05 +0000 Subject: [PATCH 0015/1290] Included fuzzy comparisons for better determination of "nice" bounds --- modules/plotchart/scaling.tcl | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/modules/plotchart/scaling.tcl b/modules/plotchart/scaling.tcl index 6b2982aa..f43bb5fa 100755 --- a/modules/plotchart/scaling.tcl +++ b/modules/plotchart/scaling.tcl @@ -4,6 +4,23 @@ namespace eval ::Plotchart { namespace export determineScale + + # + # Try and load the math::fuzzy package for better + # comparisons + # + if { [catch { + package require math::fuzzy + namespace import ::math::fuzzy::tlt + namespace import ::math::fuzzy::tgt + }] } { + proc tlt {a b} { + expr {$a < $b } + } + proc tgt {a b} { + expr {$a > $b } + } + } } # determineScale -- @@ -47,10 +64,10 @@ proc ::Plotchart::determineScale { xmin xmax } { set nicemin [expr {$step*$factor*int($xmin/$factor/$step)}] set nicemax [expr {$step*$factor*int($xmax/$factor/$step)}] - if { $nicemax < $xmax } { + if { [tlt $nicemax $xmax] } { set nicemax [expr {$nicemax+$step}] } - if { $nicemin > $xmin } { + if { [tgt $nicemin $xmin] } { set nicemin [expr {$nicemin-$step}] } From 72061ee34b2d57300dcee133048013eb9d09aed6 Mon Sep 17 00:00:00 2001 From: Jeffrey Hobbs Date: Tue, 29 Jun 2004 18:08:41 +0000 Subject: [PATCH 0016/1290] * pkgIndex.tcl: style::as is version 1.2 * as.tcl: much more elaborate version of style::as that is meant to change style across platforms. This auto-inits, but allows for reinitialization with higher priority (needed for CDE/KDE/...). --- modules/style/ChangeLog | 7 + modules/style/as.tcl | 524 +++++++++++++++++++++++++++++-------- modules/style/pkgIndex.tcl | 2 +- 3 files changed, 425 insertions(+), 108 deletions(-) diff --git a/modules/style/ChangeLog b/modules/style/ChangeLog index 806a6809..a4ced01d 100644 --- a/modules/style/ChangeLog +++ b/modules/style/ChangeLog @@ -1,3 +1,10 @@ +2004-06-29 Jeff Hobbs + + * pkgIndex.tcl: style::as is version 1.2 + * as.tcl: much more elaborate version of style::as that is meant + to change style across platforms. This auto-inits, but allows for + reinitialization with higher priority (needed for CDE/KDE/...). + 2004-03-25 David N. Welton * lobster.tcl: Added internal padding to Labelframe. They look diff --git a/modules/style/as.tcl b/modules/style/as.tcl index e537aa7b..bbd3ef41 100644 --- a/modules/style/as.tcl +++ b/modules/style/as.tcl @@ -1,27 +1,151 @@ # as_style.tcl -- # -# This file implements package as::style. +# This file implements package style::as. # # Copyright (c) 2003 ActiveState Corporation, a division of Sophos # - -package provide style::as 1.1 +# Basic use: +# +# style::as::init ?which? +# style::as::reset ?which? +# style::as::enable ?what ?args?? +# ie: enable control-mousewheel local|global +# namespace eval style::as { - if { [tk windowingsystem] == "x11" } { - set highlightbg "#316AC5" ; # SystemHighlight - set highlightfg "white" ; # SystemHighlightText - set bg "white" ; # SystemWindow - set fg "black" ; # SystemWindowText + variable version 1.2 + variable highlightbg "#316AC5" ; # SystemHighlight + variable highlightfg "white" ; # SystemHighlightText + variable bg "white" ; # SystemWindow + variable fg "black" ; # SystemWindowText - ## Fonts - ## - set size -12 - set family Helvetica - set fsize -12 - set ffamily Courier + # This may need to be adjusted for some window managers that are + # more aggressive with their own Xdefaults (like KDE and CDE) + variable prio "widgetDefault" + # assume MouseWheel binding is the same across widget classes + variable mw + set mw(classes) [list Text Listbox Table TreeCtrl] + if {![info exists mw(binding)]} { + # do this only once, in case of re-source-ing + set mw(binding) [bind Text ] + if {[tk windowingsystem] eq "x11"} { + set mw(binding4) [bind Text <4>] + set mw(binding5) [bind Text <5>] + } + } +}; # end of namespace style::as + +proc style::as::init {args} { + variable prio + if {[llength $args]} { + set arg [lindex $args 0] + set len [string length $arg] + if {$len > 2 && [string equal -len $len $arg "-priority"]} { + set prio [lindex $args 1] + set args [lrange $args 2 end] + } + } + if {[llength $args]} { + foreach what $args { + style::as::init_$what + } + } else { + foreach cmd [info procs init_*] { + $cmd + } + } + + if {$::tcl_platform(os) eq "Windows CE"} { + # WinCE is for small screens, with 240x320 (QVGA) the most common. + # Adapt the defaults to that size. + option add *font {Tahoma 7} $prio + option add *Button.borderWidth 1 $prio + option add *Entry.borderWidth 1 $prio + option add *Listbox.borderWidth 1 $prio + option add *Spinbox.borderWidth 1 $prio + option add *Text.borderWidth 1 $prio + option add *Scrollbar.width 11 $prio + option add *padY 0 $prio + } +} +proc style::as::reset {args} { + if {[llength $args]} { + foreach what $args { + style::as::reset_$what + } + } else { + foreach cmd [info commands style::as::reset_*] { + $cmd + } + } +} +proc style::as::enable {what args} { + switch -exact $what { + mousewheel { init_mousewheel } + control-mousewheel { + set type [lindex $args 0]; # should be local or global + bind all \ + [list ::style::as::CtrlMouseWheel %W %X %Y %D $type] + bind all \ + [list ::style::as::CtrlMouseWheel %W %X %Y 120 $type] + bind all \ + [list ::style::as::CtrlMouseWheel %W %X %Y -120 $type] + if {[tk windowingsystem] eq "x11"} { + bind all \ + [list ::style::as::CtrlMouseWheel %W %X %Y 120 $type] + bind all \ + [list ::style::as::CtrlMouseWheel %W %X %Y -120 $type] + } + } + default { + return -code error "unknown option \"$what\"" + } + } +} +proc style::as::disable {what args} { + switch -exact $what { + mousewheel { reset_mousewheel } + control-mousewheel { + bind all {} + bind all {} + bind all {} + if {[tk windowingsystem] eq "x11"} { + bind all {} + bind all {} + } + } + default { + return -code error "unknown option \"$what\"" + } + } +} + +## Fonts +## +proc style::as::init_fonts {args} { + if {[lsearch -exact [font names] ASfont] == -1} { + switch -exact [tk windowingsystem] { + "x11" { + set size -12 + set family Helvetica + set fsize -12 + set ffamily Courier + } + "win32" { + set size 8 + set family Tahoma + set fsize 9 + set ffamily Courier + } + "aqua" - "macintosh" { + set size 11 + set family "Lucida Grande" + set size 11 + set family Courier + } + } font create ASfont -size $size -family $family font create ASfontBold -size $size -family $family -weight bold font create ASfontFixed -size $fsize -family $ffamily @@ -32,98 +156,284 @@ namespace eval style::as { font create ASfontBold$i -size $isize -family $family -weight bold font create ASfontFixed$i -size $ifsize -family $ffamily } + } + + if {1 || [tk windowingsystem] eq "x11"} { + variable prio - option add *Text.font ASfontFixed widgetDefault - option add *Button.font ASfont widgetDefault - option add *Canvas.font ASfont widgetDefault - option add *Checkbutton.font ASfont widgetDefault - option add *Entry.font ASfont widgetDefault - option add *Label.font ASfont widgetDefault - option add *Labelframe.font ASfont widgetDefault - option add *Listbox.font ASfont widgetDefault - option add *Menu.font ASfont widgetDefault - option add *Menubutton.font ASfont widgetDefault - option add *Message.font ASfont widgetDefault - option add *Radiobutton.font ASfont widgetDefault - option add *Spinbox.font ASfont widgetDefault - - option add *Table.font ASfont widgetDefault - option add *TreeCtrl*font ASfont widgetDefault - ## Misc - ## - option add *ScrolledWindow.ipad 0 widgetDefault - - ## Listbox - ## - option add *Listbox.background $bg widgetDefault - option add *Listbox.foreground $fg widgetDefault - option add *Listbox.selectBorderWidth 0 widgetDefault - option add *Listbox.selectForeground $highlightfg widgetDefault - option add *Listbox.selectBackground $highlightbg widgetDefault - option add *Listbox.activeStyle dotbox widgetDefault - - ## Button - ## - option add *Button.padX 1 widgetDefault - option add *Button.padY 2 widgetDefault - - ## Entry - ## - option add *Entry.background $bg widgetDefault - option add *Entry.foreground $fg widgetDefault - option add *Entry.selectBorderWidth 0 widgetDefault - option add *Entry.selectForeground $highlightfg widgetDefault - option add *Entry.selectBackground $highlightbg widgetDefault - - ## Spinbox - ## - option add *Spinbox.background $bg widgetDefault - option add *Spinbox.foreground $fg widgetDefault - option add *Spinbox.selectBorderWidth 0 widgetDefault - option add *Spinbox.selectForeground $highlightfg widgetDefault - option add *Spinbox.selectBackground $highlightbg widgetDefault - - ## Text - ## - option add *Text.background $bg widgetDefault - option add *Text.foreground $fg widgetDefault - option add *Text.selectBorderWidth 0 widgetDefault - option add *Text.selectForeground $highlightfg widgetDefault - option add *Text.selectBackground $highlightbg widgetDefault - - ## Menu - ## - option add *Menu.activeBackground $highlightbg widgetDefault - option add *Menu.activeForeground $highlightfg widgetDefault - option add *Menu.activeBorderWidth 0 widgetDefault - option add *Menu.highlightThickness 0 widgetDefault - option add *Menu.borderWidth 1 widgetDefault - - ## Menubutton - ## - option add *Menubutton.activeBackground $highlightbg widgetDefault - option add *Menubutton.activeForeground $highlightfg widgetDefault - option add *Menubutton.activeBorderWidth 0 widgetDefault - option add *Menubutton.highlightThickness 0 widgetDefault - option add *Menubutton.borderWidth 0 widgetDefault - option add *Menubutton*padX 4 widgetDefault - option add *Menubutton*padY 2 widgetDefault - - ## Scrollbar - ## - option add *Scrollbar.width 12 widgetDefault - option add *Scrollbar.troughColor #bdb6ad widgetDefault - option add *Scrollbar.borderWidth 1 widgetDefault - option add *Scrollbar.highlightThickness 0 widgetDefault - - ## PanedWindow - - ## - option add *Panedwindow.borderWidth 0 widgetDefault - option add *Panedwindow.sashwidth 3 widgetDefault - option add *Panedwindow.showhandle 0 widgetDefault - option add *Panedwindow.sashpad 0 widgetDefault - option add *Panedwindow.sashrelief flat widgetDefault - option add *Panedwindow.relief flat widgetDefault + option add *Text.font ASfontFixed $prio + option add *Button.font ASfont $prio + option add *Canvas.font ASfont $prio + option add *Checkbutton.font ASfont $prio + option add *Entry.font ASfont $prio + option add *Label.font ASfont $prio + option add *Labelframe.font ASfont $prio + option add *Listbox.font ASfont $prio + option add *Menu.font ASfont $prio + option add *Menubutton.font ASfont $prio + option add *Message.font ASfont $prio + option add *Radiobutton.font ASfont $prio + option add *Spinbox.font ASfont $prio + + option add *Table.font ASfont $prio + option add *TreeCtrl*font ASfont $prio } -}; # end of namespace style::as +} + +proc style::as::reset_fonts {args} { +} + +proc style::as::CtrlMouseWheel {W X Y D {what local}} { + set w [winfo containing $X $Y] + if {[winfo exists $w]} { + set top [winfo toplevel $w] + while {[catch {$w cget -font} font] + || ![string match "ASfont*" $font]} { + if {$w eq $top} { return } + set w [winfo parent $w] + } + if {$what eq "local"} { + # get current font size (0 by default) and adjust the current + # widget's font to the next sized preconfigured font + set cnt [regexp -nocase -- {([a-z]+)(\-?\d)?} $font -> name size] + if {$size eq ""} { + set size [expr {($D > 0) ? 1 : -1}] + } else { + set size [expr {$size + (($D > 0) ? 1 : -1)}] + } + set font $name$size + if {[lsearch -exact [font names] $font] != -1} { + catch {$w configure -font $font} + } + } else { + # readjust all the font sizes based on the current one + set size [font configure ASfont -size] + incr size [expr {($D > 0) ? 1 : -1}] + # but we do have limits on how small/large things can get + if {$size < 6 || $size > 18} { return } + font configure ASfont -size $size + font configure ASfontBold -size $size + font configure ASfontFixed -size [expr {$size+1}] + # force reconfigure of this widget with the same font in + # case it doesn't have a WorldChanged function + catch {$w configure -font $font} + if {0} { + # we shouldn't need this if the user isn't improperly + # switching between global/local ctrl-mswhl modes + for {set i -2} {$i <= 4} {incr i} { + font configure ASfont$i \ + -size [expr {$size+$i}] -family $family + font configure ASfontBold$i \ + -size [expr {$size+$i}] -family $family -weight bold + font configure ASfontFixed$i \ + -size [expr {$size+1+$i}] -family Courier + } + } + } + } +} + +## Misc +## +proc style::as::init_misc {args} { + variable prio + option add *ScrolledWindow.ipad 0 $prio +} + +## Listbox +## +proc style::as::init_listbox {args} { + variable prio + if {[tk windowingsystem] eq "x11"} { + variable highlightbg + variable highlightfg + variable bg + variable fg + option add *Listbox.background $bg $prio + option add *Listbox.foreground $fg $prio + option add *Listbox.selectBorderWidth 0 $prio + option add *Listbox.selectForeground $highlightfg $prio + option add *Listbox.selectBackground $highlightbg $prio + } + option add *Listbox.activeStyle dotbox $prio +} + +## Button +## +proc style::as::init_button {args} { + variable prio + if {[tk windowingsystem] eq "x11"} { + option add *Button.padX 1 $prio + option add *Button.padY 2 $prio + } +} + +## Entry +## +proc style::as::init_entry {args} { + if {[tk windowingsystem] eq "x11"} { + variable prio + variable highlightbg + variable highlightfg + variable bg + variable fg + option add *Entry.background $bg $prio + option add *Entry.foreground $fg $prio + option add *Entry.selectBorderWidth 0 $prio + option add *Entry.selectForeground $highlightfg $prio + option add *Entry.selectBackground $highlightbg $prio + } +} + +## Spinbox +## +proc style::as::init_spinbox {args} { + if {[tk windowingsystem] eq "x11"} { + variable prio + variable highlightbg + variable highlightfg + variable bg + variable fg + option add *Spinbox.background $bg $prio + option add *Spinbox.foreground $fg $prio + option add *Spinbox.selectBorderWidth 0 $prio + option add *Spinbox.selectForeground $highlightfg $prio + option add *Spinbox.selectBackground $highlightbg $prio + } +} + +## Text +## +proc style::as::init_text {args} { + if {[tk windowingsystem] eq "x11"} { + variable prio + variable highlightbg + variable highlightfg + variable bg + variable fg + option add *Text.background $bg $prio + option add *Text.foreground $fg $prio + option add *Text.selectBorderWidth 0 $prio + option add *Text.selectForeground $highlightfg $prio + option add *Text.selectBackground $highlightbg $prio + } +} + +## Menu +## +proc style::as::init_menu {args} { + if {[tk windowingsystem] eq "x11"} { + variable prio + variable highlightbg + variable highlightfg + option add *Menu.activeBackground $highlightbg $prio + option add *Menu.activeForeground $highlightfg $prio + option add *Menu.activeBorderWidth 0 $prio + option add *Menu.highlightThickness 0 $prio + option add *Menu.borderWidth 1 $prio + } +} + +## Menubutton +## +proc style::as::init_menubutton {args} { + variable prio + variable highlightbg + variable highlightfg + option add *Menubutton.activeBackground $highlightbg $prio + option add *Menubutton.activeForeground $highlightfg $prio + option add *Menubutton.activeBorderWidth 0 $prio + option add *Menubutton.highlightThickness 0 $prio + option add *Menubutton.borderWidth 0 $prio + option add *Menubutton*padX 4 $prio + option add *Menubutton*padY 2 $prio +} + +## Scrollbar +## +proc style::as::init_scrollbar {args} { + variable prio + if {[tk windowingsystem] eq "x11"} { + option add *Scrollbar.width 12 $prio + option add *Scrollbar.troughColor "#bdb6ad" $prio + } + option add *Scrollbar.borderWidth 1 $prio + option add *Scrollbar.highlightThickness 0 $prio +} + +## PanedWindow +## +proc style::as::init_panedwindow {args} { + variable prio + option add *Panedwindow.borderWidth 0 $prio + option add *Panedwindow.sashWidth 3 $prio + option add *Panedwindow.showHandle 0 $prio + option add *Panedwindow.sashPad 0 $prio + option add *Panedwindow.sashRelief flat $prio + option add *Panedwindow.relief flat $prio +} + +## MouseWheel +## +proc style::as::MouseWheel {wFired X Y D} { + # do not double-fire in case the class already has a binding + if {[bind [winfo class $wFired] ] ne ""} { return } + # obtain the window the mouse is over + set w [winfo containing $X $Y] + # if we are outside the app, try and scroll the focus widget + if {![winfo exists $w]} { catch {set w [focus]} } + if {[winfo exists $w]} { + # scrollbars have different call conventions + if {[winfo class $w] eq "Scrollbar"} { + catch {tk::ScrollByUnits $w \ + [string index [$w cget -orient] 0] \ + [expr {-($D/30)}]} + } else { + catch {$w yview scroll [expr {- ($D / 120) * 4}] units} + } + } +} +proc style::as::init_mousewheel {args} { + variable mw + + # Create a catch-all MouseWheel proc & binding and + # alter default bindings to allow toplevel binding to control all + bind all [list ::style::as::MouseWheel %W %X %Y %D] + foreach class $mw(classes) { + bind $class {} + } + #if {[bind [winfo toplevel %W] ] ne ""} { continue } + #%W yview scroll [expr {- (%D / 120) * 4}] units + + if {[tk windowingsystem] eq "x11"} { + # Support for mousewheels on Linux/Unix commonly comes through + # mapping the wheel to the extended buttons. + bind all <4> [list ::style::as::MouseWheel %W %X %Y 120] + bind all <5> [list ::style::as::MouseWheel %W %X %Y -120] + foreach class $mw(classes) { + bind $class <4> {} + bind $class <5> {} + } + } +} +proc style::as::reset_mousewheel {args} { + # Remove catch-all MouseWheel binding and restore default bindings + variable mw + + bind all {} + foreach class $mw(classes) { + bind $class $mw(binding) + } + if {[tk windowingsystem] eq "x11"} { + bind all <4> {} + bind all <5> {} + foreach class $mw(classes) { + bind $class <4> $mw(binding4) + bind $class <5> $mw(binding5) + } + } +} + +style::as::init + +package provide style::as $style::as::version diff --git a/modules/style/pkgIndex.tcl b/modules/style/pkgIndex.tcl index 0f1c979c..de23816a 100644 --- a/modules/style/pkgIndex.tcl +++ b/modules/style/pkgIndex.tcl @@ -9,5 +9,5 @@ # full path name of this file's directory. package ifneeded style 0.1 [list source [file join $dir style.tcl]] -package ifneeded style::as 1.1 [list source [file join $dir as.tcl]] +package ifneeded style::as 1.2 [list source [file join $dir as.tcl]] package ifneeded style::lobster 0.1 [list source [file join $dir lobster.tcl]] From 340aa11fc3ce55321bff277b3cbc9d9e379bce99 Mon Sep 17 00:00:00 2001 From: Andreas Kupries Date: Wed, 30 Jun 2004 02:03:22 +0000 Subject: [PATCH 0017/1290] Import Jeff's updates to style. Fixed installer bug, did not install style, nor ctext. Import of Arjen's changes to make test more reliable. Added tkpiechart to list of installed modules. Brought main ChangeLog uptodate with respect ot new modules and when they were added. --- ChangeLog | 5 +++++ install_action.tcl | 13 +++++++++++++ installed_modules.tcl | 2 ++ 3 files changed, 20 insertions(+) diff --git a/ChangeLog b/ChangeLog index 064ed372..83ba32bd 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2004-06-29 Andreas Kupries + + * install_action.tcl: Added ctext and style to list of + * installed_modules.tcl: installed modules. + 2004-05-18 Andreas Kupries * New module 'tkpiechart'. This has been donated by Jean-Luc diff --git a/install_action.tcl b/install_action.tcl index 66e13441..7de4e78b 100644 --- a/install_action.tcl +++ b/install_action.tcl @@ -17,6 +17,19 @@ proc _tcl {module libdir} { return } +proc _ctxt {module libdir} { + global distribution + xcopy \ + [file join $distribution modules $module] \ + [file join $libdir $module] \ + 0 ctext.tcl + xcopy \ + [file join $distribution modules $module] \ + [file join $libdir $module] \ + 0 pkgIndex.tcl + return +} + proc _doc {module libdir} { global distribution diff --git a/installed_modules.tcl b/installed_modules.tcl index ea0c5fed..32f57fc8 100755 --- a/installed_modules.tcl +++ b/installed_modules.tcl @@ -18,8 +18,10 @@ array set guide {} foreach {m pkg doc exa} { autoscroll _tcl _man _null cursor _tcl _man _null + ctext _ctxt _man _null datefield _tcl _man _null ipentry _tcl _man _null + style _tcl _man _null plotchart _tcl _man _exa tkpiechart _tcl _man _null } { From 41e8a13ec65c387dbbab600400ea5784b6580e5a Mon Sep 17 00:00:00 2001 From: Jeffrey Hobbs Date: Thu, 22 Jul 2004 21:07:01 +0000 Subject: [PATCH 0018/1290] * installed_modules.tcl: added ico to list of installed modules. * modules/ico/*: new 'ico' module for extracting icos from exe/ico files - works x-platform. --- ChangeLog | 6 + installed_modules.tcl | 1 + modules/ico/ChangeLog | 7 + modules/ico/ico.tcl | 879 +++++++++++++++++++++++++++++++++++++++ modules/ico/pkgIndex.tcl | 8 + 5 files changed, 901 insertions(+) create mode 100644 modules/ico/ChangeLog create mode 100644 modules/ico/ico.tcl create mode 100644 modules/ico/pkgIndex.tcl diff --git a/ChangeLog b/ChangeLog index 83ba32bd..f04d02e0 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2004-07-22 Jeff Hobbs + + * installed_modules.tcl: added ico to list of installed modules. + * modules/ico/*: new 'ico' module for extracting icos from exe/ico + files - works x-platform. + 2004-06-29 Andreas Kupries * install_action.tcl: Added ctext and style to list of diff --git a/installed_modules.tcl b/installed_modules.tcl index 32f57fc8..6955f752 100755 --- a/installed_modules.tcl +++ b/installed_modules.tcl @@ -20,6 +20,7 @@ foreach {m pkg doc exa} { cursor _tcl _man _null ctext _ctxt _man _null datefield _tcl _man _null + ico _tcl _man _null ipentry _tcl _man _null style _tcl _man _null plotchart _tcl _man _exa diff --git a/modules/ico/ChangeLog b/modules/ico/ChangeLog new file mode 100644 index 00000000..c9ee2e46 --- /dev/null +++ b/modules/ico/ChangeLog @@ -0,0 +1,7 @@ +2004-07-22 Jeff Hobbs + + * ico.tcl: added to tklib as v0.2. + Primary usage is like so: + set file bin/wish.exe + set icos [::ico::getIcons $file] + set img [::ico::getIconImage $file -index 1] diff --git a/modules/ico/ico.tcl b/modules/ico/ico.tcl new file mode 100644 index 00000000..e0f574d0 --- /dev/null +++ b/modules/ico/ico.tcl @@ -0,0 +1,879 @@ +# ico.tcl -- +# +# Win32 ico manipulation code +# +# Copyright (c) 2003 Aaron Faupell +# Copyright (c) 2003-2004 ActiveState Corporation +# + +# JH: speed has been considered in these routines, although they +# may not be fully optimized. Running EXEtoICO on explorer.exe, +# which has nearly 100 icons, takes .2 secs on a P4/2.4ghz machine. +# + +# Sample usage: +# set file bin/wish.exe +# set icos [::ico::getIcons $file] +# set img [::ico::getIconImage $file -index 1] + +package require Tcl 8.4 +package require Tk + +# Instantiate vars we need for this package +namespace eval ::ico { + # don't look farther than this for icos past beginning or last ico found + variable maxIcoSearch 32768; #16384 ; #32768 + + # stores cached indices of icons found + variable ICONS + array set ICONS {} + + # used for 4bpp number conversion + variable BITS + array set BITS [list {} 0 0000 0 0001 1 0010 2 0011 3 0100 4 \ + 0101 5 0110 6 0111 7 1000 8 1001 9 \ + 1010 10 1011 11 1100 12 1101 13 1110 14 1111 15 \ + \ + 00000 00 00001 0F 00010 17 00011 1F \ + 00100 27 00101 2F 00110 37 00111 3F \ + 01000 47 01001 4F 01010 57 01011 5F \ + 01100 67 01101 6F 01110 77 01111 7F \ + 10000 87 10001 8F 10010 97 10011 9F \ + 10100 A7 10101 AF 10110 B7 10111 BF \ + 11000 C7 11001 CF 11010 D7 11011 DF \ + 11100 E7 11101 EF 11110 F7 11111 FF] +} + + +# getIcons -- +# +# List of icons in the file (each element a list of w h and bpp) +# +# ARGS: +# file File to extra icon info from. +# ?-type? Type of file. If not specified, it is derived from +# the file extension. Currently recognized types are +# EXE, DLL, ICO and ICL +# +# RETURNS: +# list of icons' dimensions as tuples {width height bpp} +# +proc ::ico::getIcons {file args} { + foreach {key val} $args { + if {$key eq "-type"} { + set type $val + } else { + return -code error "unknown option \"$key\": must be -type" + } + } + if {![info exists type]} { + # $type wasn't specified - get it from the extension + set type [string trimleft [string toupper [file extension $file]] .] + } + if {[info commands IconInfo$type] == ""} { + return -code error "unsupported file format $type" + } + IconInfo$type [file normalize $file] +} + +# getIconColors -- +# +# Get pixel data of icon @ index in file +# +# ARGS: +# file File to extra icon info from. +# index Index of icon in the file to use. The ordering is the +# same as returned by getIcons. (0-based) +# ?-type? Type of file. If not specified, it is derived from +# the file extension. Currently recognized types are +# EXE, DLL, ICO and ICL +# +# RETURNS: +# pixel data as a list that could be passed to 'image create' +# +proc ::ico::getIconColors {file index args} { + foreach {key val} $args { + if {$key eq "-type"} { + set type $val + } else { + return -code error "unknown option \"$key\": must be -type" + } + } + if {![info exists type]} { + # $type wasn't specified - get it from the extension + set type [string trimleft [string toupper [file extension $file]] .] + } + if {[info commands extractIcon$type] == ""} { + return -code error "unsupported file format $type" + } + return [eval [list getColors] [extractIcon$type [file normalize $file] $index]] +} + +# getIconColors -- +# +# Get icon @ index in file as tk image +# +# ARGS: +# file File to extra icon info from. +# index Index of icon in the file to use. The ordering is the +# same as returned by getIcons. (0-based) +# ?-type? Type of file. If not specified, it is derived from +# the file extension. Currently recognized types are +# EXE, DLL, ICO and ICL +# +# RETURNS: +# Tk image based on the specified icon +# +proc ::ico::getIconImage {file index args} { + set colors [eval [linsert $args 0 getIconColors $file $index]] + return [createImage $colors] +} + +# writeIcon -- +# +# Overwrite write icon @ index in file of specific type with depth/pixel data +# +# ARGS: +# file File to extra icon info from. +# index Index of icon in the file to use. The ordering is the +# same as returned by getIcons. (0-based) +# bpp bit depth of icon we are writing +# data Either pixel color data (as returned by getIconColors) +# or the name of a Tk image. +# ?-type? Type of file. If not specified, it is derived from +# the file extension. Currently recognized types are +# EXE, DLL, ICO and ICL +# +# RETURNS: +# Tk image based on the specified icon +# +proc ::ico::writeIcon {file index bpp data args} { + set index 0 + foreach {key val} $args { + if {$key eq "-type"} { + set type $val + } else { + return -code error "unknown option \"$key\": must be -type" + } + } + if {![info exists type]} { + # $type wasn't specified - get it from the extension + set type [string trimleft [string toupper [file extension $file]] .] + } + if {[info commands writeIcon$type] == ""} { + return -code error "unsupported file format $type" + } + if {[llength $data] == 1} {set data [getColorsFromImage $data]} + if {$bpp != 1 && $bpp != 4 && $bpp != 8 && $bpp != 24 && $bpp != 32} { + return -code error "invalid color depth" + } + set palette {} + if {$bpp <= 8} { + set palette [getPaletteFromColors $data] + if {[lindex $palette 0] > (1 << $bpp)} { + return -code error "specified color depth too low" + } + set data [lindex $palette 2] + set palette [lindex $palette 1] + append palette [string repeat \000 [expr {(1 << ($bpp + 2)) - [string length $palette]}]] + } + set and [getAndMaskFromColors $data] + set xor [getXORFromColors $bpp $data] + # writeIcon$type file index w h bpp palette xor and + writeIcon$type [file normalize $file] $index \ + [llength [lindex $data 0]] [llength $data] $bpp $palette $xor $and +} + +## +## Internal helper commands. +## Some may be appropriate for exposing later, but would need docs +## and make sure they "fit" in the API. +## + +proc ::ico::CopyICO {f1 i1 f2 i2} { + set s [lindex [getIcons $f1] $i1] + writeIcon $f2 [lindex $s 2] [translateColors [getIconColors $f1 $i1]] \ + -type ICO -index $i2 +} + +proc ::ico::formatColor {r g b} { + format "#%02X%02X%02X" [scan $r %c] [scan $g %c] [scan $b %c] +} + +proc ::ico::translateColors {colors} { + set new {} + foreach line $colors { + set tline {} + foreach x $line { + if {$x == ""} {lappend tline {}; continue} + lappend tline [scan $x "#%2x%2x%2x"] + } + set new [linsert $new 0 $tline] + } + return $new +} + +proc ::ico::transparentColor {img color} { + if {[string match "#*" $color]} { + set color [scan $x "#%2x%2x%2x"] + } + set w [image width $img] + set h [image height $img] + for {set y 0} {$y < $h} {incr y} { + for {set x 0} {$x < $w} {incr x} { + if {[$img get $x $y] eq $color} {$img transparency set $x $y 1} + } + } +} + +proc ::ico::getdword {fh} { + binary scan [read $fh 4] i* tmp + return $tmp +} + +proc ::ico::getword {fh} { + binary scan [read $fh 2] s* tmp + return $tmp +} + +proc ::ico::bputs {fh format args} { + puts -nonewline $fh [eval [list binary format $format] $args] +} + +proc ::ico::createImage {colors} { + set h [llength $colors] + set w [llength [lindex $colors 0]] + set img [image create photo -width $w -height $h] + if {0} { + # if image supported "" colors as transparent pixels, + # we could use this much faster op + $img put -to 0 0 $colors + } else { + for {set x 0} {$x < $w} {incr x} { + for {set y 0} {$y < $h} {incr y} { + set clr [lindex $colors $y $x] + if {$clr ne ""} { + $img put -to $x $y $clr + } + } + } + } + return $img +} + +proc ::ico::getColors {w h bpp palette xor and} { + # Create initial empty color array that we'll set indices in + set colors {} + set row {} + set empty {} + for {set x 0} {$x < $w} {incr x} { lappend row $empty } + for {set y 0} {$y < $h} {incr y} { lappend colors $row } + + set x 0 + set y [expr {$h-1}] + if {$bpp == 1} { + binary scan $xor B* xorBits + foreach i [split $xorBits {}] a [split $and {}] { + if {$x == $w} { set x 0; incr y -1 } + if {$a == 0} { + lset colors $y $x [lindex $palette $i] + } + incr x + } + } elseif {$bpp == 4} { + variable BITS + binary scan $xor B* xorBits + set i 0 + foreach a [split $and {}] { + if {$x == $w} { set x 0; incr y -1 } + if {$a == 0} { + set bits [string range $xorBits $i [expr {$i+3}]] + lset colors $y $x [lindex $palette $BITS($bits)] + } + incr i 4 + incr x + } + } elseif {$bpp == 8} { + foreach i [split $xor {}] a [split $and {}] { + if {$x == $w} { set x 0; incr y -1 } + if {$a == 0} { + lset colors $y $x [lindex $palette [scan $i %c]] + } + incr x + } + } elseif {$bpp == 16} { + variable BITS + binary scan $xor b* xorBits + set i 0 + foreach a [split $and {}] { + if {$x == $w} { set x 0; incr y -1 } + if {$a == 0} { + set b1 [string range $xorBits $i [expr {$i+4}]] + set b2 [string range $xorBits [expr {$i+5}] [expr {$i+9}]] + set b3 [string range $xorBits [expr {$i+10}] [expr {$i+14}]] + lset colors $y $x "#$BITS($b3)$BITS($b2)$BITS($b1)" + } + incr i 16 + incr x + } + } elseif {$bpp == 24} { + foreach {b g r} [split $xor {}] a [split $and {}] { + if {$x == $w} { set x 0; incr y -1 } + if {$a == 0} { + lset colors $y $x [formatColor $r $g $b] + } + incr x + } + } elseif {$bpp == 32} { + foreach {b g r a} [split $xor {}] a [split $and {}] { + if {$x == $w} { set x 0; incr y -1 } + if {$a == 0} { + lset colors $y $x [formatColor $r $g $b] + } + incr x + } + } + return $colors +} + +proc ::ico::getAndMaskFromColors {colors} { + set and {} + foreach line $colors { + set l {} + foreach x $line {append l [expr {$x == ""}]} + append l [string repeat 0 [expr {[string length $l] % 32}]] + foreach {a b c d e f g h} [split $l {}] { + append and [binary format B8 $a$b$c$d$e$f$g$h] + } + } + return $and +} + +proc ::ico::getXORFromColors {bpp colors} { + set xor {} + if {$bpp == 1} { + foreach line $colors { + foreach {a b c d e f g h} $line { + foreach x {a b c d e f g h} { + if {[set $x] == ""} {set $x 0} + } + binary scan $a$b$c$d$e$f$g$h bbbbbbbb h g f e d c b a + append xor [binary format b8 $a$b$c$d$e$f$g$h] + } + } + } elseif {$bpp == 4} { + foreach line $colors { + foreach {a b} $line { + if {$a == ""} {set a 0} + if {$b == ""} {set b 0} + binary scan $a$b b4b4 b a + append xor [binary format b8 $a$b] + } + } + } elseif {$bpp == 8} { + foreach line $colors { + foreach x $line { + if {$x == ""} {set x 0} + append xor [binary format c $x] + } + } + } elseif {$bpp == 24} { + foreach line $colors { + foreach x $line { + if {![llength $x]} { + append xor [binary format ccc 0 0 0] + } else { + foreach {a b c n} $x { + append xor [binary format ccc $c $b $a] + } + } + } + } + } elseif {$bpp == 32} { + foreach line $colors { + foreach x $line { + if {![llength $x]} { + append xor [binary format cccc 0 0 0 0] + } else { + foreach {a b c n} $x { + if {$n == ""} {set n 0} + append xor [binary format cccc $c $b $a $n] + } + } + } + } + } + return $xor +} + +proc ::ico::getColorsFromImage {img} { + set w [image width $img] + set h [image height $img] + set r {} + for {set y [expr $h - 1]} {$y > -1} {incr y -1} { + set l {} + for {set x 0} {$x < $w} {incr x} { + if {[$img transparency get $x $y]} { + lappend l {} + } else { + lappend l [$img get $x $y] + } + } + lappend r $l + } + return $r +} + +proc ::ico::getPaletteFromColors {colors} { + set palette {} + array set tpal {} + set new {} + set i 0 + foreach line $colors { + set tline {} + foreach x $line { + if {$x == ""} {lappend tline {}; continue} + if {![info exists tpal($x)]} { + foreach {a b c n} $x { + append palette [binary format cccc $c $b $a 0] + } + set tpal($x) $i + incr i + } + lappend tline $tpal($x) + } + lappend new $tline + } + return [list $i $palette $new] +} + +proc ::ico::readDIB {fh w h bpp} { + if {$bpp == 1 || $bpp == 4 || $bpp == 8} { + set colors [read $fh [expr {1 << ($bpp + 2)}]] + } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} { + set colors {} + } else { + return -code error "unsupported color depth: $bpp" + } + + set palette [list] + foreach {b g r x} [split $colors {}] { + lappend palette [formatColor $r $g $b] + } + + set xor [read $fh [expr {int(($w * $h) * ($bpp / 8.0))}]] + set and1 [read $fh [expr {(($w * $h) + ($h * ($w % 32))) / 8}]] + + set and {} + set row [expr {($w + abs($w - 32)) / 8}] + set len [expr {$row * $h}] + for {set i 0} {$i < $len} {incr i $row} { + binary scan [string range $and1 $i [expr {$i + $row}]] B$w tmp + append and $tmp + } + + return [list $palette $xor $and] +} + +proc ::ico::IconInfoICO {file} { + set fh [open $file r] + fconfigure $fh -translation binary + + # both words must be read to keep in sync with later reads + if {"[getword $fh] [getword $fh]" != "0 1"} { + return -code error "not an icon file" + } + set num [getword $fh] + set r {} + for {set i 0} {$i < $num} {incr i} { + set info {} + lappend info [scan [read $fh 1] %c] [scan [read $fh 1] %c] + set bpp [scan [read $fh 1] %c] + if {$bpp == 0} { + set orig [tell $fh] + seek $fh 9 current + seek $fh [expr {[getdword $fh] + 14}] start + lappend info [getword $fh] + seek $fh $orig start + } else { + lappend info [expr {int(sqrt($bpp))}] + } + lappend r $info + seek $fh 13 current + } + close $fh + return $r +} + +proc ::ico::extractIconICO {file index} { + set fh [open $file r] + fconfigure $fh -translation binary + + # both words must be read to keep in sync with later reads + if {"[getword $fh] [getword $fh]" != "0 1"} { + return -code error "not an icon file" + } + if {$index < 0 || $index >= [getword $fh]} { + return -code error "index out of range" + } + + seek $fh [expr {(16 * $index) + 12}] current + seek $fh [getdword $fh] start + + binary scan [read $fh 16] iiiss s w h p bpp + set h [expr {$h / 2}] + seek $fh 24 current + + # readDIB returns: {palette xor and} + set pxa [readDIB $fh $w $h $bpp] + + close $fh + return [concat [list $w $h $bpp] $pxa] +} + +proc ::ico::writeIconICO {file index w h bpp palette xor and} { + if {![file exists $file]} { + set fh [open $file w+] + fconfigure $fh -translation binary + bputs $fh sss 0 1 0 + seek $fh 0 start + } else { + set fh [open $file r+] + fconfigure $fh -translation binary + } + if {[file size $file] > 4 && "[getword $fh] [getword $fh]" != "0 1"} { + close $fh + return -code error "not an icon file" + } + set num [getword $fh] + if {$index == "end"} { set index $num } + if {$index < 0 || $index > $num} { + close $fh + return -code error "index out of range" + } + set colors 0 + if {$bpp <= 8} {set colors [expr {1 << $bpp}]} + set size [expr {[string length $palette] + [string length $xor] + [string length $and]}] + if {$index == $num} { + seek $fh -2 current + bputs $fh s [expr {$num + 1}] + seek $fh [expr {$num * 16}] current + set olddata [read $fh] + set cur 0 + while {$cur < $num} { + seek $fh [expr {($cur * 16) + 18}] start + set toff [getdword $fh] + seek $fh -4 current + bputs $fh i [expr {$toff + 16}] + incr cur + } + bputs $fh ccccss $w $h $colors 0 1 $bpp + bputs $fh ii [expr {$size + 40}] [expr {[string length $olddata] + [tell $fh] + 8}] + puts -nonewline $fh $olddata + bputs $fh iiissiiiiii 40 $w [expr {$h * 2}] 1 $bpp 0 $size 0 0 0 0 + puts -nonewline $fh $palette + puts -nonewline $fh $xor + puts -nonewline $fh $and + } else { + seek $fh [expr {($index * 16) + 8}] current + set len [getdword $fh] + set offset [getdword $fh] + set cur [expr {$index + 1}] + while {$cur < $num} { + seek $fh [expr {($cur * 16) + 18}] start + set toff [getdword $fh] + seek $fh -4 current + bputs $fh i [expr {$toff + (($size + 40) - $len)}] + incr cur + } + seek $fh [expr {$offset + $len}] start + set olddata [read $fh] + seek $fh [expr {($index * 16) + 6}] start + bputs $fh ccccssi $w $h $colors 0 1 $bpp [expr {$size + 40}] + seek $fh $offset start + bputs $fh iiissiiiiii 40 $w [expr {$h * 2}] 1 $bpp 0 $size 0 0 0 0 + puts -nonewline $fh $palette + puts -nonewline $fh $xor + puts -nonewline $fh $and + puts -nonewline $fh $olddata + } + close $fh +} + +proc ::ico::checkEXE {exe {mode r}} { + set fh [open $exe $mode] + fconfigure $fh -translation binary + + # verify PE header + if {[read $fh 2] != "MZ"} { + close $fh + return -code error "not a DOS executable" + } + seek $fh 60 start + seek $fh [getword $fh] start + set sig [read $fh 4] + if {$sig eq "PE\000\000"} { + # move past header data + seek $fh 24 current + seek $fh [getdword $fh] start + } elseif {[string match "NE*" $sig]} { + seek $fh 34 current + seek $fh [getdword $fh] start + } else { + close $fh + return -code error "executable header not found" + } + + # return file handle + return $fh +} + +proc ::ico::calcSize {w h bpp {offset 0}} { + # calculate byte size of ICO. + # often passed $w twice because $h is double $w in the binary data + set s [expr {int(($w*$h) * ($bpp/8.0)) \ + + ((($w*$h) + ($h*($w%32)))/8) + $offset}] + if {$bpp <= 8} { set s [expr {$s + (1 << ($bpp + 2))}] } + return $s +} + +proc ::ico::SearchForIcos {file fh {index -1}} { + variable ICONS ; # stores icos offsets by index, and [list w h bpp] + variable maxIcoSearch ; # don't look farther than this for icos + set readsize 512 ; # chunked read size + + if {[info exists ICONS($file,$index)]} { + return $ICONS($file,$index) + } + + set last 0 ; # tell point of last ico found + set idx -1 ; # index of icos found + set pos 0 + set offset [tell $fh] + set data [read $fh $readsize] + set lastoffset $offset + + while {1} { + if {$pos > ($readsize - 20)} { + if {[eof $fh] || ($last && ([tell $fh]-$last) >= $maxIcoSearch)} { + # set the -1 index to indicate we've read the whole file + set ICONS($file,-1) $idx + break + } + + seek $fh [expr {$pos - $readsize}] current + set offset [tell $fh] + + if {$offset <= $lastoffset} { + # We made no progress (anymore). This means that we + # have reached the end of the file and processed a + # short block of 16 byte. And that we are now trying + # to read and process the same block again. Squashing + # the infinite loop just starting up right now. + + set ICONS($file,-1) $idx + break + } + set lastoffset $offset + + set pos 0 + set data [read $fh $readsize] + } + + binary scan [string range $data $pos [expr {$pos + 20}]] \ + iiissi s w h p bpp comp + if {$s == 40 && $p == 1 && $comp == 0 && $w == ($h / 2)} { + set ICONS($file,[incr idx]) [expr {$offset + $pos}] + set ICONS($file,$idx,data) [list $w $w $bpp] + # stop if we found requested index + if {$index >= 0 && $idx == $index} { break } + incr pos [calcSize $w $w $bpp 40] + set last [expr {$offset + $pos}] + } else { + incr pos 4 + } + } + + return $idx +} + +proc ::ico::IconInfoEXE {file} { + variable ICONS + + set file [file normalize $file] + set fh [checkEXE $file] + set cnt [SearchForIcos $file $fh] + + set icons [list] + for {set i 0} {$i <= $cnt} {incr i} { + lappend icons $ICONS($file,$i,data) + } + + close $fh + return $icons +} + +proc ::ico::extractIconEXE {file index} { + variable ICONS + + set file [file normalize $file] + set fh [checkEXE $file] + set cnt [SearchForIcos $file $fh $index] + + if {$cnt < $index} { return -code error "index out of range" } + + set idx $ICONS($file,$index) + set ico $ICONS($file,$index,data) + + seek $fh [expr {$idx + 40}] start + + # readDIB returns: {palette xor and} + set pxa [eval [list readDIB $fh] $ico] ; # $ico == $w $h $bpp + close $fh + return [concat $ico $pxa] +} + +proc ::ico::writeIconEXE {file index w0 h0 bpp0 palette xor and} { + variable ICONS + + set file [file normalize $file] + set fh [checkEXE $file r+] + set cnt [SearchForIcos $file $fh $index] + + if {$cnt < $index} { return -code error "index out of range" } + + set idx $ICONS($file,$index) + set ico $ICONS($file,$index,data) + foreach {w h bpp} $ico { break } + + seek $fh [expr {$idx + 40}] start + + if {$w0 != $w || $h0 != $h || $bpp0 != $bpp} { + close $fh + return -code error "icon format differs from original" + } + puts -nonewline $fh $palette + puts -nonewline $fh $xor + puts -nonewline $fh $and + close $fh +} + +# Convert icons found in exefile into a regular icon file. +proc ::ico::EXEtoICO {exeFile icoFile} { + variable ICONS + + set file [file normalize $exeFile] + set fh [checkEXE $file] + set cnt [SearchForIcos $file $fh] + + for {set i 0} {$i <= $cnt} {incr i} { + set idx $ICONS($file,$i) + set ico $ICONS($file,$i,data) + seek $fh $idx start + eval [list lappend dir] $ico + append data [read $fh [eval calcSize $ico 40]] + } + close $fh + + # write them out to a file + set ifh [open $icoFile w+] + fconfigure $ifh -translation binary + + bputs $ifh sss 0 1 [expr {$cnt + 1}] + set offset [expr {6 + (($cnt + 1) * 16)}] + foreach {w h bpp} $dir { + set colors 0 + if {$bpp <= 8} {set colors [expr {1 << $bpp}]} + set s [calcSize $w $h $bpp 40] + lappend fix $offset $s + bputs $ifh ccccssii $w $h $colors 0 1 $bpp $s $offset + set offset [expr {$offset + $s}] + } + puts -nonewline $ifh $data + foreach {offset size} $fix { + seek $ifh [expr {$offset + 20}] start + bputs $ifh i $s + } + close $ifh +} + +interp alias {} ::ico::IconInfoDLL {} ::ico::IconInfoEXE +interp alias {} ::ico::extractIconDLL {} ::ico::extractIconEXE +interp alias {} ::ico::writeIconDLL {} ::ico::writeIconEXE +interp alias {} ::ico::IconInfoICL {} ::ico::IconInfoEXE +interp alias {} ::ico::extractIconICL {} ::ico::extractIconEXE +interp alias {} ::ico::writeIconICL {} ::ico::writeIconEXE + +proc ::ico::reset {{file {}}} { + variable ICONS + if {$file ne ""} { + array unset ICONS $file,* + } else { + unset ICONS + array set ICONS {} + } +} + +proc ::ico::showaux {files} { + if {[llength $files]} { + set file [lindex $files 0] + Show $f + update + after 50 [list ::ico::showaux [lrange $files 1 end]] + } +} + +# Application level command: Find icons in a file and show them. +proc ::ico::Show {file {type {}} {top .}} { + package require BWidget + + set file [file normalize $file] + set icos [getIcons $file] + set wname [string map {. _ : _} $file] + + if {$top eq "."} { set w ""} else { set w $top } + + set mf $w.mainsw + if {![winfo exists $mf]} { + set sw [ScrolledWindow $mf] + set sf [ScrollableFrame $mf.sf -constrainedwidth 1] + $sw setwidget $sf + pack $sw -fill both -expand 1 + grid columnconfigure [$mf.sf getframe] 0 -weight 1 + } + set mf [$mf.sf getframe] + + set lf $mf.f$wname + if {[winfo exists $lf]} { destroy $lf } + if {![llength $icos]} { + label $lf -text "No icons in '$file'" -anchor w + grid $lf -sticky ew + } else { + labelframe $lf -text "[llength $icos] Icons in '$file'" + grid $lf -sticky news + set sw [ScrolledWindow $lf.sw$wname] + set sf [ScrollableFrame $lf.sf$wname -constrainedheight 1 -height 70] + $sw setwidget $sf + set sf [$sf getframe] + pack $sw -fill both -expand 1 + set col 0 + for {set x 0} {$x < [llength $icos]} {incr x} { + # catch in case theres any icons with unsupported color + if {[catch {getIconImage $file $x} img]} { + set txt "ERROR: $img" + set lbl [label $sf.lbl$wname-$x -anchor w -text $txt] + grid $lbl -sticky s -row 0 -column [incr col] + } else { + set txt [eval {format "$x: %sx%s %sbpp"} [lindex $icos $x]] + set lbl [label $sf.lbl$wname-$x -anchor w -text $txt \ + -compound top -image $img] + grid $lbl -sticky s -row 0 -column [incr col] + } + update idletasks + } + } + grid rowconfigure $top 0 -weight 1 + grid columnconfigure $top 0 -weight 1 +} + +package provide ico 0.2 diff --git a/modules/ico/pkgIndex.tcl b/modules/ico/pkgIndex.tcl new file mode 100644 index 00000000..d2b3a97c --- /dev/null +++ b/modules/ico/pkgIndex.tcl @@ -0,0 +1,8 @@ +# pkgIndex.tcl -- +# +# Copyright (c) 2003 ActiveState Corporation. +# All rights reserved. +# +# RCS: @(#) $Id: pkgIndex.tcl,v 1.1 2004/07/22 21:07:01 hobbs Exp $ + +package ifneeded ico 0.2 [list source [file join $dir ico.tcl]] From 5e4b2e5e1299cfef9390d3b7fb9263580230e4b3 Mon Sep 17 00:00:00 2001 From: Jeffrey Hobbs Date: Thu, 22 Jul 2004 23:08:56 +0000 Subject: [PATCH 0019/1290] CopyICO: correct writeIcon passing of index arg --- modules/ico/ico.tcl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/modules/ico/ico.tcl b/modules/ico/ico.tcl index e0f574d0..494bc959 100644 --- a/modules/ico/ico.tcl +++ b/modules/ico/ico.tcl @@ -192,8 +192,8 @@ proc ::ico::writeIcon {file index bpp data args} { proc ::ico::CopyICO {f1 i1 f2 i2} { set s [lindex [getIcons $f1] $i1] - writeIcon $f2 [lindex $s 2] [translateColors [getIconColors $f1 $i1]] \ - -type ICO -index $i2 + writeIcon $f2 $i2 [lindex $s 2] [translateColors [getIconColors $f1 $i1]] \ + -type ICO } proc ::ico::formatColor {r g b} { From 7b8a9bc28e01d8c35dcc16e5833746ec96899cd8 Mon Sep 17 00:00:00 2001 From: Andreas Kupries Date: Fri, 23 Jul 2004 01:05:39 +0000 Subject: [PATCH 0020/1290] Changelog merge. New module: ico. --- modules/ico/ChangeLog | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/modules/ico/ChangeLog b/modules/ico/ChangeLog index c9ee2e46..7eaad6a9 100644 --- a/modules/ico/ChangeLog +++ b/modules/ico/ChangeLog @@ -1,7 +1,7 @@ -2004-07-22 Jeff Hobbs - - * ico.tcl: added to tklib as v0.2. - Primary usage is like so: - set file bin/wish.exe - set icos [::ico::getIcons $file] - set img [::ico::getIconImage $file -index 1] +2004-07-22 Jeff Hobbs + + * ico.tcl: added to tklib as v0.2. + Primary usage is like so: + set file bin/wish.exe + set icos [::ico::getIcons $file] + set img [::ico::getIconImage $file -index 1] From 292e34a950c7d5419031b218b5b89cca53e8b116 Mon Sep 17 00:00:00 2001 From: Jeffrey Hobbs Date: Sun, 25 Jul 2004 00:18:10 +0000 Subject: [PATCH 0021/1290] * ico.tcl (::ico::getIconImageFromData): add call to retrive icon image from ICO info as data (not "official", may change). --- modules/ico/ChangeLog | 5 ++ modules/ico/ico.tcl | 117 +++++++++++++++++++++++++++++++++++++++--- 2 files changed, 114 insertions(+), 8 deletions(-) diff --git a/modules/ico/ChangeLog b/modules/ico/ChangeLog index 7eaad6a9..c5e68c2a 100644 --- a/modules/ico/ChangeLog +++ b/modules/ico/ChangeLog @@ -1,3 +1,8 @@ +2004-07-24 Jeff Hobbs + + * ico.tcl (::ico::getIconImageFromData): add call to retrive icon + image from ICO info as data (not "official", may change). + 2004-07-22 Jeff Hobbs * ico.tcl: added to tklib as v0.2. diff --git a/modules/ico/ico.tcl b/modules/ico/ico.tcl index 494bc959..08d44615 100644 --- a/modules/ico/ico.tcl +++ b/modules/ico/ico.tcl @@ -109,7 +109,7 @@ proc ::ico::getIconColors {file index args} { return [eval [list getColors] [extractIcon$type [file normalize $file] $index]] } -# getIconColors -- +# getIconImage -- # # Get icon @ index in file as tk image # @@ -190,6 +190,23 @@ proc ::ico::writeIcon {file index bpp data args} { ## and make sure they "fit" in the API. ## +# getIconImageFromData -- +# +# Get icon @ index in data as tk image +# +# ARGS: +# data data to extra icon info from. Must be in ICO format. +# index Index of icon to use. The ordering is the +# same as returned by getIcons. (0-based) +# +# RETURNS: +# Tk image based on the specified icon +# +proc ::ico::getIconImageFromData {data index} { + set colors [eval [linsert [extractIconICOData $data $index] 0 getColors]] + return [createImage $colors] +} + proc ::ico::CopyICO {f1 i1 f2 i2} { set s [lindex [getIcons $f1] $i1] writeIcon $f2 $i2 [lindex $s 2] [translateColors [getIconColors $f1 $i1]] \ @@ -448,26 +465,60 @@ proc ::ico::getPaletteFromColors {colors} { } proc ::ico::readDIB {fh w h bpp} { + set palette [list] if {$bpp == 1 || $bpp == 4 || $bpp == 8} { set colors [read $fh [expr {1 << ($bpp + 2)}]] + foreach {b g r x} [split $colors {}] { + lappend palette [formatColor $r $g $b] + } } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} { - set colors {} + # do nothing } else { return -code error "unsupported color depth: $bpp" } + set xor [read $fh [expr {int(($w * $h) * ($bpp / 8.0))}]] + set and1 [read $fh [expr {(($w * $h) + ($h * ($w % 32))) / 8}]] + + set and {} + set row [expr {($w + abs($w - 32)) / 8}] + set len [expr {$row * $h}] + for {set i 0} {$i < $len} {incr i $row} { + binary scan [string range $and1 $i [expr {$i + $row}]] B$w tmp + append and $tmp + } + + return [list $palette $xor $and] +} + +proc ::ico::readDIBData {data cnt w h bpp} { set palette [list] - foreach {b g r x} [split $colors {}] { - lappend palette [formatColor $r $g $b] + if {$bpp == 1 || $bpp == 4 || $bpp == 8} { + # Could do: [binary scan $data @${cnt}c$len colors] + # and iter over colors, but this is more consistent with $fh version + set len [expr {1 << ($bpp + 2)}] + set colors [string range $data $cnt [expr {$cnt + $len - 1}]] + foreach {b g r x} [split $colors {}] { + lappend palette [formatColor $r $g $b] + } + incr cnt $len + } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} { + # do nothing + } else { + return -code error "unsupported color depth: $bpp" } - set xor [read $fh [expr {int(($w * $h) * ($bpp / 8.0))}]] - set and1 [read $fh [expr {(($w * $h) + ($h * ($w % 32))) / 8}]] + # Use -1 to account for string range inclusiveness + set end [expr {$cnt + int(($w * $h) * ($bpp / 8.0)) - 1}] + set xor [string range $data $cnt $end] + set and1 [string range $data [expr {$end + 1}] \ + [expr {$end + ((($w * $h) + ($h * ($w % 32))) / 8) - 1}]] set and {} set row [expr {($w + abs($w - 32)) / 8}] set len [expr {$row * $h}] for {set i 0} {$i < $len} {incr i $row} { + # Has to be decoded by row, in order binary scan [string range $and1 $i [expr {$i + $row}]] B$w tmp append and $tmp } @@ -505,6 +556,33 @@ proc ::ico::IconInfoICO {file} { return $r } +proc ::ico::IconInfoICOData {data} { + if {[binary scan $data sss h1 h2 num] != 3 || $h1 != 0 || $h2 != 1} { + return -code error "not icon data" + } + set r {} + set cnt 6 + for {set i 0} {$i < $num} {incr i} { + if {[binary scan $data @${cnt}ccc w h bpp] != 3} { + return -code error "error decoding icon data" + } + incr cnt 3 + set info [list $w $h] + if {$bpp == 0} { + set off [expr {$cnt + 9}] + binary scan $data @${off}i off + incr off 14 + binary scan $data @${off}s bpp + lappend info $bpp + } else { + lappend info [expr {int(sqrt($bpp))}] + } + lappend r $info + incr cnt 13 + } + return $r +} + proc ::ico::extractIconICO {file index} { set fh [open $file r] fconfigure $fh -translation binary @@ -513,8 +591,9 @@ proc ::ico::extractIconICO {file index} { if {"[getword $fh] [getword $fh]" != "0 1"} { return -code error "not an icon file" } - if {$index < 0 || $index >= [getword $fh]} { - return -code error "index out of range" + set num [getword $fh] + if {$index < 0 || $index >= $num} { + return -code error "index out of range: must be between 0 and $num" } seek $fh [expr {(16 * $index) + 12}] current @@ -531,6 +610,28 @@ proc ::ico::extractIconICO {file index} { return [concat [list $w $h $bpp] $pxa] } +proc ::ico::extractIconICOData {data index} { + if {[binary scan $data sss h1 h2 num] != 3 || $h1 != 0 || $h2 != 1} { + return -code error "not icon data" + } + if {$index < 0 || $index >= $num} { + return -code error "index out of range: must be between 0 and $num" + } + # Move to ico location + set cnt [expr {6 + (16 * $index) + 12}] + binary scan $data @${cnt}i loc + # Read info from location + binary scan $data @${loc}iiiss s w h p bpp + set h [expr {$h / 2}] + # Move over location info + magic offset to start of DIB + set cnt [expr {$loc + 16 + 24}] + + # readDIB returns: {palette xor and} + set pxa [readDIBData $data $cnt $w $h $bpp] + + return [concat [list $w $h $bpp] $pxa] +} + proc ::ico::writeIconICO {file index w h bpp palette xor and} { if {![file exists $file]} { set fh [open $file w+] From b57dc66c4d652c74520516b38d32c0449625d8b9 Mon Sep 17 00:00:00 2001 From: afaupell Date: Mon, 26 Jul 2004 07:26:56 +0000 Subject: [PATCH 0022/1290] *** empty log message *** --- modules/ico/ico.man | 32 +++ modules/ico/ico.tcl | 538 ++++++++++++++++++++++---------------------- 2 files changed, 296 insertions(+), 274 deletions(-) create mode 100644 modules/ico/ico.man diff --git a/modules/ico/ico.man b/modules/ico/ico.man new file mode 100644 index 00000000..1544c81f --- /dev/null +++ b/modules/ico/ico.man @@ -0,0 +1,32 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin ico n 0.2] +[moddesc {}] +[titledesc {}] +[require Tcl 8.4] +[require ico [ico 0.2]] +[description] + +This package provides functions for reading and writing Windows icons +from ICO ICL EXE and DLL files. + +[para] + +[list_begin definitions] + +[call [cmd ::ico::getIconList] [arg file] [opt "[arg option] [arg value]..."]] +[call [cmd ::ico::getIcon] [arg file] [arg index] [opt "[arg option] [arg value]..."]] +[call [cmd ::ico::writeIcon] [arg file] [arg index] [arg depth] [arg data] [opt "[arg option] [arg value]..."]] +[call [cmd ::ico::copyIcon] [arg file] [arg index] [arg file2] [arg index2] [opt "[arg option] [arg value]..."]] +[call [cmd ::ico::EXEtoICO] [arg file] [arg file2] +[call [cmd ::ico::clearCache] [opt file] +[call [cmd ::ico::transparentColor] [arg image] [arg color] +[call [cmd ::ico::Show] [arg file] [opt "[arg option] [arg value]..."]] + + +[list_end] + + + +[keywords entry {icon ico exe dll}] +[manpage_end] + diff --git a/modules/ico/ico.tcl b/modules/ico/ico.tcl index 08d44615..3a42253a 100644 --- a/modules/ico/ico.tcl +++ b/modules/ico/ico.tcl @@ -13,11 +13,10 @@ # Sample usage: # set file bin/wish.exe -# set icos [::ico::getIcons $file] -# set img [::ico::getIconImage $file -index 1] +# set icos [::ico::getIconList $file] +# set img [::ico::getIcon $file 1 -format image] package require Tcl 8.4 -package require Tk # Instantiate vars we need for this package namespace eval ::ico { @@ -45,7 +44,7 @@ namespace eval ::ico { } -# getIcons -- +# getIconList -- # # List of icons in the file (each element a list of w h and bpp) # @@ -58,75 +57,57 @@ namespace eval ::ico { # RETURNS: # list of icons' dimensions as tuples {width height bpp} # -proc ::ico::getIcons {file args} { - foreach {key val} $args { - if {$key eq "-type"} { - set type $val - } else { - return -code error "unknown option \"$key\": must be -type" - } +proc ::ico::getIconList {file args} { + parseOpts type $args + if {![info exists type]} { + # $type wasn't specified - get it from the extension + set type [string trimleft [string toupper [file extension $file]] .] + } + if {[info commands getIconList$type] == ""} { + return -code error "unsupported file format $type" } if {![info exists type]} { # $type wasn't specified - get it from the extension set type [string trimleft [string toupper [file extension $file]] .] } - if {[info commands IconInfo$type] == ""} { - return -code error "unsupported file format $type" - } - IconInfo$type [file normalize $file] + getIconList$type [file normalize $file] } -# getIconColors -- +# getIcon -- # # Get pixel data of icon @ index in file # # ARGS: -# file File to extra icon info from. -# index Index of icon in the file to use. The ordering is the -# same as returned by getIcons. (0-based) -# ?-type? Type of file. If not specified, it is derived from -# the file extension. Currently recognized types are -# EXE, DLL, ICO and ICL +# file File to extra icon info from. +# index Index of icon in the file to use. The ordering is the +# same as returned by getIconList. (0-based) +# ?-type? Type of file. If not specified, it is derived from +# the file extension. Currently recognized types are +# EXE, DLL, ICO and ICL +# ?-format? Output format. Must be one of "image" or "colors" +# image will return the name of a Tk image. colors will return a +# a list of pixel values +# ?-name? If output is image, use this as the name of Tk image created # # RETURNS: # pixel data as a list that could be passed to 'image create' # -proc ::ico::getIconColors {file index args} { - foreach {key val} $args { - if {$key eq "-type"} { - set type $val - } else { - return -code error "unknown option \"$key\": must be -type" - } - } +proc ::ico::getIcon {file index args} { + set name {} + set format image + parseOpts {type format name} $args if {![info exists type]} { - # $type wasn't specified - get it from the extension - set type [string trimleft [string toupper [file extension $file]] .] + # $type wasn't specified - get it from the extension + set type [string trimleft [string toupper [file extension $file]] .] } - if {[info commands extractIcon$type] == ""} { - return -code error "unsupported file format $type" + if {[info commands getRawIconData$type] == ""} { + return -code error "unsupported file format $type" } - return [eval [list getColors] [extractIcon$type [file normalize $file] $index]] -} - -# getIconImage -- -# -# Get icon @ index in file as tk image -# -# ARGS: -# file File to extra icon info from. -# index Index of icon in the file to use. The ordering is the -# same as returned by getIcons. (0-based) -# ?-type? Type of file. If not specified, it is derived from -# the file extension. Currently recognized types are -# EXE, DLL, ICO and ICL -# -# RETURNS: -# Tk image based on the specified icon -# -proc ::ico::getIconImage {file index args} { - set colors [eval [linsert $args 0 getIconColors $file $index]] - return [createImage $colors] + set colors [eval [list getColors] [getRawIconData$type [file normalize $file] $index]] + if {$format == "image"} { + return [createImage $colors $name] + } + return $colors } # writeIcon -- @@ -136,9 +117,9 @@ proc ::ico::getIconImage {file index args} { # ARGS: # file File to extra icon info from. # index Index of icon in the file to use. The ordering is the -# same as returned by getIcons. (0-based) +# same as returned by getIconList. (0-based) # bpp bit depth of icon we are writing -# data Either pixel color data (as returned by getIconColors) +# data Either pixel color data (as returned by getIcon -format color) # or the name of a Tk image. # ?-type? Type of file. If not specified, it is derived from # the file extension. Currently recognized types are @@ -148,22 +129,19 @@ proc ::ico::getIconImage {file index args} { # Tk image based on the specified icon # proc ::ico::writeIcon {file index bpp data args} { - set index 0 - foreach {key val} $args { - if {$key eq "-type"} { - set type $val - } else { - return -code error "unknown option \"$key\": must be -type" - } - } + parseOpts type $args if {![info exists type]} { - # $type wasn't specified - get it from the extension - set type [string trimleft [string toupper [file extension $file]] .] + # $type wasn't specified - get it from the extension + set type [string trimleft [string toupper [file extension $file]] .] } if {[info commands writeIcon$type] == ""} { return -code error "unsupported file format $type" } - if {[llength $data] == 1} {set data [getColorsFromImage $data]} + if {[llength $data] == 1} { + set data [getColorsFromImage $data] + } elseif {[string match "#*" [lindex $data 0 0]]} { + set data [translateColors $data] + } if {$bpp != 1 && $bpp != 4 && $bpp != 8 && $bpp != 24 && $bpp != 32} { return -code error "invalid color depth" } @@ -184,39 +162,156 @@ proc ::ico::writeIcon {file index bpp data args} { [llength [lindex $data 0]] [llength $data] $bpp $palette $xor $and } -## -## Internal helper commands. -## Some may be appropriate for exposing later, but would need docs -## and make sure they "fit" in the API. -## -# getIconImageFromData -- +# copyIcon -- # -# Get icon @ index in data as tk image +# Copies an icon directly from one file to another # # ARGS: -# data data to extra icon info from. Must be in ICO format. -# index Index of icon to use. The ordering is the -# same as returned by getIcons. (0-based) +# file File to extra icon info from. +# index Index of icon in the file to use. The ordering is the +# same as returned by getIconList. (0-based) +# ?-fromtype? Type of source file. If not specified, it is derived from +# the file extension. Currently recognized types are +# EXE, DLL, ICO and ICL +# ?-totype? Type of destination file. If not specified, it is derived from +# the file extension. Currently recognized types are +# EXE, DLL, ICO and ICL # # RETURNS: -# Tk image based on the specified icon +# nothing # -proc ::ico::getIconImageFromData {data index} { - set colors [eval [linsert [extractIconICOData $data $index] 0 getColors]] - return [createImage $colors] +proc ::ico::copyIcon {f1 i1 f2 i2 args} { + set totype {} + set fromtype {} + parseOpts {fromtype totype} $args + set s [lindex [getIconList $f1 -type $fromtype] $i1] + writeIcon $f2 $i2 [lindex $s 2] [translateColors [getIcon $f1 $i1 -format colors]] -type $totype } -proc ::ico::CopyICO {f1 i1 f2 i2} { - set s [lindex [getIcons $f1] $i1] - writeIcon $f2 $i2 [lindex $s 2] [translateColors [getIconColors $f1 $i1]] \ - -type ICO +# +# transparentColor -- +# +# Turns on transparency for all pixels in the Tk image that match the color +# +# ARGS: +# img Name of the Tk image to modify +# color Color in #hex format which will be made transparent +# +# RETURNS: +# nothing +# +proc ::ico::transparentColor {img color} { + if {[string match "#*" $color]} { + set color [scan $x "#%2x%2x%2x"] + } + set w [image width $img] + set h [image height $img] + for {set y 0} {$y < $h} {incr y} { + for {set x 0} {$x < $w} {incr x} { + if {[$img get $x $y] eq $color} {$img transparency set $x $y 1} + } + } } +# +# clearCache -- +# +# Clears the cache of icon offsets +# +# ARGS: +# file optional filename +# +# +# RETURNS: +# nothing +# +proc ::ico::clearCache {{file {}}} { + variable ICONS + if {$file ne ""} { + array unset ICONS $file,* + } else { + unset ICONS + array set ICONS {} + } +} + +# +# EXEtoICO -- +# +# Convert all icons found in exefile into a regular icon file +# +# ARGS: +# exeFile Input EXE filename +# icoFile Output ICO filename +# +# RETURNS: +# nothing +# +proc ::ico::EXEtoICO {exeFile icoFile} { + variable ICONS + + set file [file normalize $exeFile] + set fh [checkEXE $file] + set cnt [SearchForIcos $file $fh] + + for {set i 0} {$i <= $cnt} {incr i} { + set idx $ICONS($file,$i) + set ico $ICONS($file,$i,data) + seek $fh $idx start + eval [list lappend dir] $ico + append data [read $fh [eval calcSize $ico 40]] + } + close $fh + + # write them out to a file + set ifh [open $icoFile w+] + fconfigure $ifh -translation binary + + bputs $ifh sss 0 1 [expr {$cnt + 1}] + set offset [expr {6 + (($cnt + 1) * 16)}] + foreach {w h bpp} $dir { + set colors 0 + if {$bpp <= 8} {set colors [expr {1 << $bpp}]} + set s [calcSize $w $h $bpp 40] + lappend fix $offset $s + bputs $ifh ccccssii $w $h $colors 0 1 $bpp $s $offset + set offset [expr {$offset + $s}] + } + puts -nonewline $ifh $data + foreach {offset size} $fix { + seek $ifh [expr {$offset + 20}] start + bputs $ifh i $s + } + close $ifh +} + +## +## Internal helper commands. +## Some may be appropriate for exposing later, but would need docs +## and make sure they "fit" in the API. +## + +# helper proc to parse optional arguments to some of the public procs +proc ::ico::parseOpts {acc opts} { + foreach {key val} $opts { + set key [string trimleft $key -] + if {[lsearch -exact $acc $key] >= 0} { + upvar $key $key + set $key $val + } elseif {$key != ""} { + return -code error "unknown option \"$key\": must be one of $acc" + } + } +} + +# formats a single color from the decimal list format to the #hex format proc ::ico::formatColor {r g b} { format "#%02X%02X%02X" [scan $r %c] [scan $g %c] [scan $b %c] } +# translates a color list from the #hex format to the decimal list format +# #0000FF {0 0 255} proc ::ico::translateColors {colors} { set new {} foreach line $colors { @@ -230,19 +325,6 @@ proc ::ico::translateColors {colors} { return $new } -proc ::ico::transparentColor {img color} { - if {[string match "#*" $color]} { - set color [scan $x "#%2x%2x%2x"] - } - set w [image width $img] - set h [image height $img] - for {set y 0} {$y < $h} {incr y} { - for {set x 0} {$x < $w} {incr x} { - if {[$img get $x $y] eq $color} {$img transparency set $x $y 1} - } - } -} - proc ::ico::getdword {fh} { binary scan [read $fh 4] i* tmp return $tmp @@ -253,14 +335,16 @@ proc ::ico::getword {fh} { return $tmp } +# binary puts proc ::ico::bputs {fh format args} { puts -nonewline $fh [eval [list binary format $format] $args] } -proc ::ico::createImage {colors} { +# creates a Tk image from a list of colors in the #hex format +proc ::ico::createImage {colors {name {}}} { set h [llength $colors] set w [llength [lindex $colors 0]] - set img [image create photo -width $w -height $h] + set img [eval image create photo $name -width $w -height $h] if {0} { # if image supported "" colors as transparent pixels, # we could use this much faster op @@ -278,13 +362,14 @@ proc ::ico::createImage {colors} { return $img } +# return a list of colors in the #hex format from raw icon data returned by readDIB proc ::ico::getColors {w h bpp palette xor and} { # Create initial empty color array that we'll set indices in set colors {} set row {} set empty {} for {set x 0} {$x < $w} {incr x} { lappend row $empty } - for {set y 0} {$y < $h} {incr y} { lappend colors $row } + for {set y 0} {$y < $h} {incr y} { lappend colors $row } set x 0 set y [expr {$h-1}] @@ -353,6 +438,8 @@ proc ::ico::getColors {w h bpp palette xor and} { return $colors } +# creates a binary formatted AND mask by reading a list of colors in the decimal list format +# and checking for empty colors which designate transparency proc ::ico::getAndMaskFromColors {colors} { set and {} foreach line $colors { @@ -366,6 +453,8 @@ proc ::ico::getAndMaskFromColors {colors} { return $and } +# creates a binary formatted XOR mask in the specified depth format from +# a list of colors in the decimal list format proc ::ico::getXORFromColors {bpp colors} { set xor {} if {$bpp == 1} { @@ -423,6 +512,9 @@ proc ::ico::getXORFromColors {bpp colors} { return $xor } +# translates a Tk image into a list of colors in the #hex format +# one element per pixel and {} designating transparent +# used by writeIcon when writing from a Tk image proc ::ico::getColorsFromImage {img} { set w [image width $img] set h [image height $img] @@ -441,6 +533,10 @@ proc ::ico::getColorsFromImage {img} { return $r } +# creates a palette from a list of colors in the decimal list format +# a palette consists of 3 values, the number of colors, the palette entry itself, +# and the color list transformed to point to palette entries instead of color names +# the palette entry itself is stored as 32bpp in "G B R padding" order proc ::ico::getPaletteFromColors {colors} { set palette {} array set tpal {} @@ -464,69 +560,41 @@ proc ::ico::getPaletteFromColors {colors} { return [list $i $palette $new] } -proc ::ico::readDIB {fh w h bpp} { - set palette [list] +# read a Device Independent Bitmap from the current offset and return the +# width, height, depth, palette, XOR mask, and AND mask +proc ::ico::readDIB {fh} { + binary scan [read $fh 16] x4iix2s w h bpp + set h [expr {$h / 2}] + seek $fh 24 current + if {$bpp == 1 || $bpp == 4 || $bpp == 8} { set colors [read $fh [expr {1 << ($bpp + 2)}]] - foreach {b g r x} [split $colors {}] { - lappend palette [formatColor $r $g $b] - } } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} { - # do nothing + set colors {} } else { return -code error "unsupported color depth: $bpp" } - set xor [read $fh [expr {int(($w * $h) * ($bpp / 8.0))}]] - set and1 [read $fh [expr {(($w * $h) + ($h * ($w % 32))) / 8}]] - - set and {} - set row [expr {($w + abs($w - 32)) / 8}] - set len [expr {$row * $h}] - for {set i 0} {$i < $len} {incr i $row} { - binary scan [string range $and1 $i [expr {$i + $row}]] B$w tmp - append and $tmp - } - - return [list $palette $xor $and] -} - -proc ::ico::readDIBData {data cnt w h bpp} { set palette [list] - if {$bpp == 1 || $bpp == 4 || $bpp == 8} { - # Could do: [binary scan $data @${cnt}c$len colors] - # and iter over colors, but this is more consistent with $fh version - set len [expr {1 << ($bpp + 2)}] - set colors [string range $data $cnt [expr {$cnt + $len - 1}]] - foreach {b g r x} [split $colors {}] { - lappend palette [formatColor $r $g $b] - } - incr cnt $len - } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} { - # do nothing - } else { - return -code error "unsupported color depth: $bpp" + foreach {b g r x} [split $colors {}] { + lappend palette [formatColor $r $g $b] } - # Use -1 to account for string range inclusiveness - set end [expr {$cnt + int(($w * $h) * ($bpp / 8.0)) - 1}] - set xor [string range $data $cnt $end] - set and1 [string range $data [expr {$end + 1}] \ - [expr {$end + ((($w * $h) + ($h * ($w % 32))) / 8) - 1}]] + set xor [read $fh [expr {int(($w * $h) * ($bpp / 8.0))}]] + set and1 [read $fh [expr {(($w * $h) + ($h * ($w % 32))) / 8}]] set and {} set row [expr {($w + abs($w - 32)) / 8}] set len [expr {$row * $h}] for {set i 0} {$i < $len} {incr i $row} { - # Has to be decoded by row, in order binary scan [string range $and1 $i [expr {$i + $row}]] B$w tmp append and $tmp } - return [list $palette $xor $and] + return [list $w $h $bpp $palette $xor $and] } -proc ::ico::IconInfoICO {file} { +proc ::ico::getIconListICO {file} { set fh [open $file r] fconfigure $fh -translation binary @@ -556,80 +624,28 @@ proc ::ico::IconInfoICO {file} { return $r } -proc ::ico::IconInfoICOData {data} { - if {[binary scan $data sss h1 h2 num] != 3 || $h1 != 0 || $h2 != 1} { - return -code error "not icon data" - } - set r {} - set cnt 6 - for {set i 0} {$i < $num} {incr i} { - if {[binary scan $data @${cnt}ccc w h bpp] != 3} { - return -code error "error decoding icon data" - } - incr cnt 3 - set info [list $w $h] - if {$bpp == 0} { - set off [expr {$cnt + 9}] - binary scan $data @${off}i off - incr off 14 - binary scan $data @${off}s bpp - lappend info $bpp - } else { - lappend info [expr {int(sqrt($bpp))}] - } - lappend r $info - incr cnt 13 - } - return $r -} - -proc ::ico::extractIconICO {file index} { +# returns an icon in the format of width, height, depth, palette, xor mask, and mask +proc ::ico::getRawIconDataICO {file index} { set fh [open $file r] fconfigure $fh -translation binary # both words must be read to keep in sync with later reads if {"[getword $fh] [getword $fh]" != "0 1"} { + close $fh return -code error "not an icon file" } - set num [getword $fh] - if {$index < 0 || $index >= $num} { - return -code error "index out of range: must be between 0 and $num" + if {$index < 0 || $index >= [getword $fh]} { + return -code error "index out of range" } seek $fh [expr {(16 * $index) + 12}] current seek $fh [getdword $fh] start - binary scan [read $fh 16] iiiss s w h p bpp - set h [expr {$h / 2}] - seek $fh 24 current - - # readDIB returns: {palette xor and} - set pxa [readDIB $fh $w $h $bpp] + # readDIB returns: {w h bpp palette xor and} + set dib [readDIB $fh] close $fh - return [concat [list $w $h $bpp] $pxa] -} - -proc ::ico::extractIconICOData {data index} { - if {[binary scan $data sss h1 h2 num] != 3 || $h1 != 0 || $h2 != 1} { - return -code error "not icon data" - } - if {$index < 0 || $index >= $num} { - return -code error "index out of range: must be between 0 and $num" - } - # Move to ico location - set cnt [expr {6 + (16 * $index) + 12}] - binary scan $data @${cnt}i loc - # Read info from location - binary scan $data @${loc}iiiss s w h p bpp - set h [expr {$h / 2}] - # Move over location info + magic offset to start of DIB - set cnt [expr {$loc + 16 + 24}] - - # readDIB returns: {palette xor and} - set pxa [readDIBData $data $cnt $w $h $bpp] - - return [concat [list $w $h $bpp] $pxa] + return $dib } proc ::ico::writeIconICO {file index w h bpp palette xor and} { @@ -655,11 +671,16 @@ proc ::ico::writeIconICO {file index w h bpp palette xor and} { set colors 0 if {$bpp <= 8} {set colors [expr {1 << $bpp}]} set size [expr {[string length $palette] + [string length $xor] + [string length $and]}] + + # if we are adding a new icon at the end if {$index == $num} { + # increment the icon count seek $fh -2 current bputs $fh s [expr {$num + 1}] + # save all the data past the icon dir entries seek $fh [expr {$num * 16}] current set olddata [read $fh] + # increment all the offsets in the existing dir entries by 16 to account for our new entry set cur 0 while {$cur < $num} { seek $fh [expr {($cur * 16) + 18}] start @@ -668,17 +689,24 @@ proc ::ico::writeIconICO {file index w h bpp palette xor and} { bputs $fh i [expr {$toff + 16}] incr cur } + # insert new icon dir entry bputs $fh ccccss $w $h $colors 0 1 $bpp bputs $fh ii [expr {$size + 40}] [expr {[string length $olddata] + [tell $fh] + 8}] + # put all the icon data back puts -nonewline $fh $olddata + # put our new icon at the end bputs $fh iiissiiiiii 40 $w [expr {$h * 2}] 1 $bpp 0 $size 0 0 0 0 puts -nonewline $fh $palette puts -nonewline $fh $xor puts -nonewline $fh $and } else { + # we are overwriting an icon - not necesarily the same size + # get existing icon offset and length seek $fh [expr {($index * 16) + 8}] current set len [getdword $fh] set offset [getdword $fh] + # adjust offset in existing icon dir entries higher than our new icon to account + # for new icon length set cur [expr {$index + 1}] while {$cur < $num} { seek $fh [expr {($cur * 16) + 18}] start @@ -687,10 +715,13 @@ proc ::ico::writeIconICO {file index w h bpp palette xor and} { bputs $fh i [expr {$toff + (($size + 40) - $len)}] incr cur } + # save all data after new icon seek $fh [expr {$offset + $len}] start set olddata [read $fh] + # overwrite icon dir entry seek $fh [expr {($index * 16) + 6}] start bputs $fh ccccssi $w $h $colors 0 1 $bpp [expr {$size + 40}] + # insert new icon and saved data seek $fh $offset start bputs $fh iiissiiiiii 40 $w [expr {$h * 2}] 1 $bpp 0 $size 0 0 0 0 puts -nonewline $fh $palette @@ -701,6 +732,7 @@ proc ::ico::writeIconICO {file index w h bpp palette xor and} { close $fh } +# checks if file is a windows executable and returns an open file handle at the start of the data segment proc ::ico::checkEXE {exe {mode r}} { set fh [open $exe $mode] fconfigure $fh -translation binary @@ -729,15 +761,16 @@ proc ::ico::checkEXE {exe {mode r}} { return $fh } +# calculate byte size of an icon. +# often passed $w twice because $h is double $w in the binary data proc ::ico::calcSize {w h bpp {offset 0}} { - # calculate byte size of ICO. - # often passed $w twice because $h is double $w in the binary data set s [expr {int(($w*$h) * ($bpp/8.0)) \ + ((($w*$h) + ($h*($w%32)))/8) + $offset}] if {$bpp <= 8} { set s [expr {$s + (1 << ($bpp + 2))}] } return $s } +# find all the icons in an executable and cache their size and offsets proc ::ico::SearchForIcos {file fh {index -1}} { variable ICONS ; # stores icos offsets by index, and [list w h bpp] variable maxIcoSearch ; # don't look farther than this for icos @@ -798,7 +831,7 @@ proc ::ico::SearchForIcos {file fh {index -1}} { return $idx } -proc ::ico::IconInfoEXE {file} { +proc ::ico::getIconListEXE {file} { variable ICONS set file [file normalize $file] @@ -814,7 +847,8 @@ proc ::ico::IconInfoEXE {file} { return $icons } -proc ::ico::extractIconEXE {file index} { +# returns an icon in the format of width, height, depth, palette, xor mask, and mask +proc ::ico::getRawIconDataEXE {file index} { variable ICONS set file [file normalize $file] @@ -823,15 +857,12 @@ proc ::ico::extractIconEXE {file index} { if {$cnt < $index} { return -code error "index out of range" } - set idx $ICONS($file,$index) - set ico $ICONS($file,$index,data) - - seek $fh [expr {$idx + 40}] start + seek $fh $ICONS($file,$index) start - # readDIB returns: {palette xor and} - set pxa [eval [list readDIB $fh] $ico] ; # $ico == $w $h $bpp + # readDIB returns: {w h bpp palette xor and} + set dib [readDIB $fh] close $fh - return [concat $ico $pxa] + return $dib } proc ::ico::writeIconEXE {file index w0 h0 bpp0 palette xor and} { @@ -841,6 +872,7 @@ proc ::ico::writeIconEXE {file index w0 h0 bpp0 palette xor and} { set fh [checkEXE $file r+] set cnt [SearchForIcos $file $fh $index] + if {$index == "end"} {set index $cnt} if {$cnt < $index} { return -code error "index out of range" } set idx $ICONS($file,$index) @@ -859,62 +891,13 @@ proc ::ico::writeIconEXE {file index w0 h0 bpp0 palette xor and} { close $fh } -# Convert icons found in exefile into a regular icon file. -proc ::ico::EXEtoICO {exeFile icoFile} { - variable ICONS - - set file [file normalize $exeFile] - set fh [checkEXE $file] - set cnt [SearchForIcos $file $fh] - - for {set i 0} {$i <= $cnt} {incr i} { - set idx $ICONS($file,$i) - set ico $ICONS($file,$i,data) - seek $fh $idx start - eval [list lappend dir] $ico - append data [read $fh [eval calcSize $ico 40]] - } - close $fh - - # write them out to a file - set ifh [open $icoFile w+] - fconfigure $ifh -translation binary - - bputs $ifh sss 0 1 [expr {$cnt + 1}] - set offset [expr {6 + (($cnt + 1) * 16)}] - foreach {w h bpp} $dir { - set colors 0 - if {$bpp <= 8} {set colors [expr {1 << $bpp}]} - set s [calcSize $w $h $bpp 40] - lappend fix $offset $s - bputs $ifh ccccssii $w $h $colors 0 1 $bpp $s $offset - set offset [expr {$offset + $s}] - } - puts -nonewline $ifh $data - foreach {offset size} $fix { - seek $ifh [expr {$offset + 20}] start - bputs $ifh i $s - } - close $ifh -} - -interp alias {} ::ico::IconInfoDLL {} ::ico::IconInfoEXE -interp alias {} ::ico::extractIconDLL {} ::ico::extractIconEXE +interp alias {} ::ico::getIconListDLL {} ::ico::getIconListEXE +interp alias {} ::ico::getRawIconDataDLL {} ::ico::getRawIconDataEXE interp alias {} ::ico::writeIconDLL {} ::ico::writeIconEXE -interp alias {} ::ico::IconInfoICL {} ::ico::IconInfoEXE -interp alias {} ::ico::extractIconICL {} ::ico::extractIconEXE +interp alias {} ::ico::getIconListICL {} ::ico::getIconListEXE +interp alias {} ::ico::getRawIconDataICL {} ::ico::getRawIconDataEXE interp alias {} ::ico::writeIconICL {} ::ico::writeIconEXE -proc ::ico::reset {{file {}}} { - variable ICONS - if {$file ne ""} { - array unset ICONS $file,* - } else { - unset ICONS - array set ICONS {} - } -} - proc ::ico::showaux {files} { if {[llength $files]} { set file [lindex $files 0] @@ -925,14 +908,21 @@ proc ::ico::showaux {files} { } # Application level command: Find icons in a file and show them. -proc ::ico::Show {file {type {}} {top .}} { +proc ::ico::Show {file args} { package require BWidget + + set parent . + parseOpts {type parent} $args + if {![info exists type]} { + # $type wasn't specified - get it from the extension + set type [string trimleft [string toupper [file extension $file]] .] + } set file [file normalize $file] - set icos [getIcons $file] + set icos [getIconList $file -type $type] set wname [string map {. _ : _} $file] - if {$top eq "."} { set w ""} else { set w $top } + if {$parent eq "."} { set w ""} else { set w $parent } set mf $w.mainsw if {![winfo exists $mf]} { @@ -960,7 +950,7 @@ proc ::ico::Show {file {type {}} {top .}} { set col 0 for {set x 0} {$x < [llength $icos]} {incr x} { # catch in case theres any icons with unsupported color - if {[catch {getIconImage $file $x} img]} { + if {[catch {getIcon $file $x -type $type} img]} { set txt "ERROR: $img" set lbl [label $sf.lbl$wname-$x -anchor w -text $txt] grid $lbl -sticky s -row 0 -column [incr col] @@ -973,8 +963,8 @@ proc ::ico::Show {file {type {}} {top .}} { update idletasks } } - grid rowconfigure $top 0 -weight 1 - grid columnconfigure $top 0 -weight 1 + grid rowconfigure $parent 0 -weight 1 + grid columnconfigure $parent 0 -weight 1 } package provide ico 0.2 From 4a7660c75a172444e5f3f4bd53dd4cf1d1cd35df Mon Sep 17 00:00:00 2001 From: afaupell Date: Mon, 26 Jul 2004 18:58:52 +0000 Subject: [PATCH 0023/1290] working on the documentation --- modules/ico/ico.man | 52 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 52 insertions(+) diff --git a/modules/ico/ico.man b/modules/ico/ico.man index 1544c81f..0642213b 100644 --- a/modules/ico/ico.man +++ b/modules/ico/ico.man @@ -11,16 +11,68 @@ from ICO ICL EXE and DLL files. [para] +[para] +[example { + button .explore -image [::ico::getIcon explorer.exe 0 -name explore] + set i [lsearch [::ico::getIconList tclkit.exe] {32 32 8}]] + set colorlist [::ico::getIcon tclkit.exe $i -format colors -type EXE] +}] +[para] + [list_begin definitions] [call [cmd ::ico::getIconList] [arg file] [opt "[arg option] [arg value]..."]] +[list_begin opt] +[opt_def -type value] +[list_end opt] + [call [cmd ::ico::getIcon] [arg file] [arg index] [opt "[arg option] [arg value]..."]] +[list_begin opt] +[opt_def -type value] +[opt_def -format value] +[opt_def -name value] +[list_end opt] + + [call [cmd ::ico::writeIcon] [arg file] [arg index] [arg depth] [arg data] [opt "[arg option] [arg value]..."]] +[list_begin arg] +[arg_def fileName file] +[arg_def integer index] +[arg_def integer depth] +[arg_def options args] +[list_end arg] + +[list_begin opt] +[opt_def -type value] +[list_end opt] + + [call [cmd ::ico::copyIcon] [arg file] [arg index] [arg file2] [arg index2] [opt "[arg option] [arg value]..."]] +[list_begin opt] +[opt_def -fromtype value] +[opt_def -totype value] +[list_end opt] + + [call [cmd ::ico::EXEtoICO] [arg file] [arg file2] +[list_begin opt] +[opt_def -type value] +[list_end opt] + + [call [cmd ::ico::clearCache] [opt file] + + + [call [cmd ::ico::transparentColor] [arg image] [arg color] + + + [call [cmd ::ico::Show] [arg file] [opt "[arg option] [arg value]..."]] +[list_begin opt] +[opt_def -type value] +[opt_def -parent value] +[list_end opt] [list_end] From 511b63f52c59987718023122bb6569f02d93340a Mon Sep 17 00:00:00 2001 From: afaupell Date: Mon, 26 Jul 2004 22:58:58 +0000 Subject: [PATCH 0024/1290] fixed -fromtype and -totype arguments to copyIco --- modules/ico/ico.tcl | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/modules/ico/ico.tcl b/modules/ico/ico.tcl index 3a42253a..02247aa7 100644 --- a/modules/ico/ico.tcl +++ b/modules/ico/ico.tcl @@ -168,7 +168,7 @@ proc ::ico::writeIcon {file index bpp data args} { # Copies an icon directly from one file to another # # ARGS: -# file File to extra icon info from. +# file File to extract icon info from. # index Index of icon in the file to use. The ordering is the # same as returned by getIconList. (0-based) # ?-fromtype? Type of source file. If not specified, it is derived from @@ -182,11 +182,16 @@ proc ::ico::writeIcon {file index bpp data args} { # nothing # proc ::ico::copyIcon {f1 i1 f2 i2 args} { - set totype {} - set fromtype {} parseOpts {fromtype totype} $args - set s [lindex [getIconList $f1 -type $fromtype] $i1] - writeIcon $f2 $i2 [lindex $s 2] [translateColors [getIcon $f1 $i1 -format colors]] -type $totype + if {![info exists fromtype]} { + # $type wasn't specified - get it from the extension + set fromtype [string trimleft [string toupper [file extension $f1]] .] + } + if {![info exists totype]} { + # $type wasn't specified - get it from the extension + set totype [string trimleft [string toupper [file extension $f2]] .] + } + writeIcon $f2 $i2 [lindex [getIconList $f1 -type $fromtype] $i1 2] [getIcon $f1 $i1 -format colors] -type $totype } # @@ -305,7 +310,7 @@ proc ::ico::parseOpts {acc opts} { } } -# formats a single color from the decimal list format to the #hex format +# formats a single color from a binary decimal list format to the #hex format proc ::ico::formatColor {r g b} { format "#%02X%02X%02X" [scan $r %c] [scan $g %c] [scan $b %c] } @@ -893,10 +898,10 @@ proc ::ico::writeIconEXE {file index w0 h0 bpp0 palette xor and} { interp alias {} ::ico::getIconListDLL {} ::ico::getIconListEXE interp alias {} ::ico::getRawIconDataDLL {} ::ico::getRawIconDataEXE -interp alias {} ::ico::writeIconDLL {} ::ico::writeIconEXE +interp alias {} ::ico::writeIconDLL {} ::ico::writeIconEXE interp alias {} ::ico::getIconListICL {} ::ico::getIconListEXE interp alias {} ::ico::getRawIconDataICL {} ::ico::getRawIconDataEXE -interp alias {} ::ico::writeIconICL {} ::ico::writeIconEXE +interp alias {} ::ico::writeIconICL {} ::ico::writeIconEXE proc ::ico::showaux {files} { if {[llength $files]} { From 1051a775164ae5121197aad2df21d387f596958e Mon Sep 17 00:00:00 2001 From: afaupell Date: Mon, 26 Jul 2004 23:11:45 +0000 Subject: [PATCH 0025/1290] ico.tcl: rewrite of copyIcon to use a lower level data format to increase speed ico.man many additions to the man page, still a work in progress. --- modules/ico/ico.man | 30 +++++++++++++++++++++++++++--- modules/ico/ico.tcl | 8 +++++++- 2 files changed, 34 insertions(+), 4 deletions(-) diff --git a/modules/ico/ico.man b/modules/ico/ico.man index 0642213b..001879d1 100644 --- a/modules/ico/ico.man +++ b/modules/ico/ico.man @@ -3,7 +3,7 @@ [moddesc {}] [titledesc {}] [require Tcl 8.4] -[require ico [ico 0.2]] +[require ico [opt 0.2]] [description] This package provides functions for reading and writing Windows icons @@ -26,6 +26,8 @@ from ICO ICL EXE and DLL files. [opt_def -type value] [list_end opt] +Returns a list of icons found in [arg file] where each element has the format {width height depth} + [call [cmd ::ico::getIcon] [arg file] [arg index] [opt "[arg option] [arg value]..."]] [list_begin opt] [opt_def -type value] @@ -33,6 +35,12 @@ from ICO ICL EXE and DLL files. [opt_def -name value] [list_end opt] +Extracts the icon at [arg index] from [arg file]. The default [opt -format] is [const image] which will return +the name of a Tk image containing the icon. Optionally [arg -name] may be used to specify the name of the Tk +image that is created. If [opt -format] is [const colors] then a list of color names in the #RRGGBB format is +returned. Each list element is a horizontal row. Each horizontal row contains a list of colors for all the pixels +in that row from left to right. + [call [cmd ::ico::writeIcon] [arg file] [arg index] [arg depth] [arg data] [opt "[arg option] [arg value]..."]] [list_begin arg] @@ -46,6 +54,18 @@ from ICO ICL EXE and DLL files. [opt_def -type value] [list_end opt] +[arg index] is the 0 based index of the icon to write. When writing to an EXE, DLL, or ICL you may only overwrite +existing icons with an icon of the same dimensions and color depth. When writing to an ICO, [arg index] may be one +greater than the last icon which will append a new icon to the file. When wrting to an ICO, [arg index] will accept +[const end] which will cause the new icon to be appended to the file. When writing the other types [const end] will +refer to the last existing icon. + +[arg data] is either a list of colors in the format returned by [cmd getIcon -format colors] or the name of a Tk +image. + +[arg depth] must be one of 1, 4, 8, 24 or 32. If [arg data] has more colors than the color depth allows an error +will be generated. + [call [cmd ::ico::copyIcon] [arg file] [arg index] [arg file2] [arg index2] [opt "[arg option] [arg value]..."]] [list_begin opt] @@ -53,27 +73,31 @@ from ICO ICL EXE and DLL files. [opt_def -totype value] [list_end opt] +Copies the icon at [arg index] in [arg file] to [arg index2] in [arg file2]. + [call [cmd ::ico::EXEtoICO] [arg file] [arg file2] [list_begin opt] [opt_def -type value] [list_end opt] +Extracts all icons from the executable [arg file] to the ICO file [arg file2] -[call [cmd ::ico::clearCache] [opt file] +[call [cmd ::ico::clearCache] [opt file] [call [cmd ::ico::transparentColor] [arg image] [arg color] - [call [cmd ::ico::Show] [arg file] [opt "[arg option] [arg value]..."]] [list_begin opt] [opt_def -type value] [opt_def -parent value] [list_end opt] +Application level command which displays a window showing all the icons in [arg file] with information about them + [list_end] diff --git a/modules/ico/ico.tcl b/modules/ico/ico.tcl index 02247aa7..39bd05ab 100644 --- a/modules/ico/ico.tcl +++ b/modules/ico/ico.tcl @@ -191,7 +191,13 @@ proc ::ico::copyIcon {f1 i1 f2 i2 args} { # $type wasn't specified - get it from the extension set totype [string trimleft [string toupper [file extension $f2]] .] } - writeIcon $f2 $i2 [lindex [getIconList $f1 -type $fromtype] $i1 2] [getIcon $f1 $i1 -format colors] -type $totype + if {[info commands writeIcon$totype] == ""} { + return -code error "unsupported file format $totype" + } + if {[info commands getRawIconData$fromtype] == ""} { + return -code error "unsupported file format $fromtype" + } + eval [list writeIcon$totype $f2 $i2]] [getRawIconData$fromtype $f1 $i1] } # From 2d9dec96381d9d45de38071a29a1cc88a3a4c290 Mon Sep 17 00:00:00 2001 From: afaupell Date: Mon, 26 Jul 2004 23:17:52 +0000 Subject: [PATCH 0026/1290] updates to man page --- modules/ico/ico.man | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/modules/ico/ico.man b/modules/ico/ico.man index 001879d1..1205bea8 100644 --- a/modules/ico/ico.man +++ b/modules/ico/ico.man @@ -86,9 +86,13 @@ Extracts all icons from the executable [arg file] to the ICO file [arg file2] [call [cmd ::ico::clearCache] [opt file] +The [cmd getIconList] command caches icon offsets inside EXE, DLL, and ICL files in order to speed up extraction. +This command clears that cache for the specific [opt file] or all files. + [call [cmd ::ico::transparentColor] [arg image] [arg color] +Sets every pixel matching [arg color] in Tk image [arg image] to transparent. [call [cmd ::ico::Show] [arg file] [opt "[arg option] [arg value]..."]] [list_begin opt] From 678d9c1e716cdb97ff2bd02dfa887a288409af90 Mon Sep 17 00:00:00 2001 From: Jeffrey Hobbs Date: Tue, 27 Jul 2004 00:19:44 +0000 Subject: [PATCH 0027/1290] * pkgIndex.tcl, ico.man, ico.tcl: add -type ICODATA as a way pass ICO data instead of a filename. Currently supports read, not write. Made 'package require Tk' only get called as necessary for the api. Code cleanup, update to v0.3. --- modules/ico/ChangeLog | 10 +++ modules/ico/ico.man | 4 +- modules/ico/ico.tcl | 190 ++++++++++++++++++++++++++++++--------- modules/ico/pkgIndex.tcl | 4 +- 4 files changed, 160 insertions(+), 48 deletions(-) diff --git a/modules/ico/ChangeLog b/modules/ico/ChangeLog index c5e68c2a..0cba6018 100644 --- a/modules/ico/ChangeLog +++ b/modules/ico/ChangeLog @@ -1,3 +1,13 @@ +2004-07-26 Jeff Hobbs + + * pkgIndex.tcl, ico.man, ico.tcl: add -type ICODATA as a way pass + ICO data instead of a filename. Currently supports read, not write. + Made 'package require Tk' only get called as necessary for the api. + Code cleanup, update to v0.3. + + * ico.man (new): + * ico.tcl: revamp of API from Aaron, more public APIs. + 2004-07-24 Jeff Hobbs * ico.tcl (::ico::getIconImageFromData): add call to retrive icon diff --git a/modules/ico/ico.man b/modules/ico/ico.man index 1205bea8..d399284d 100644 --- a/modules/ico/ico.man +++ b/modules/ico/ico.man @@ -1,9 +1,9 @@ [comment {-*- tcl -*- doctools manpage}] -[manpage_begin ico n 0.2] +[manpage_begin ico n 0.3] [moddesc {}] [titledesc {}] [require Tcl 8.4] -[require ico [opt 0.2]] +[require ico [opt 0.3]] [description] This package provides functions for reading and writing Windows icons diff --git a/modules/ico/ico.tcl b/modules/ico/ico.tcl index 39bd05ab..497b0c5b 100644 --- a/modules/ico/ico.tcl +++ b/modules/ico/ico.tcl @@ -61,21 +61,17 @@ proc ::ico::getIconList {file args} { parseOpts type $args if {![info exists type]} { # $type wasn't specified - get it from the extension - set type [string trimleft [string toupper [file extension $file]] .] + set type [fileext $file] } - if {[info commands getIconList$type] == ""} { + if {![llength [info commands getIconList$type]]} { return -code error "unsupported file format $type" } - if {![info exists type]} { - # $type wasn't specified - get it from the extension - set type [string trimleft [string toupper [file extension $file]] .] - } getIconList$type [file normalize $file] } # getIcon -- # -# Get pixel data of icon @ index in file +# Get pixel data or image of icon @ index in file # # ARGS: # file File to extra icon info from. @@ -85,9 +81,10 @@ proc ::ico::getIconList {file args} { # the file extension. Currently recognized types are # EXE, DLL, ICO and ICL # ?-format? Output format. Must be one of "image" or "colors" -# image will return the name of a Tk image. colors will return a -# a list of pixel values -# ?-name? If output is image, use this as the name of Tk image created +# 'image' will return the name of a Tk image. +# 'colors' will return a list of pixel values +# ?-name? If output is image, use this as the name of Tk image +# created # # RETURNS: # pixel data as a list that could be passed to 'image create' @@ -98,13 +95,17 @@ proc ::ico::getIcon {file index args} { parseOpts {type format name} $args if {![info exists type]} { # $type wasn't specified - get it from the extension - set type [string trimleft [string toupper [file extension $file]] .] + set type [fileext $file] } - if {[info commands getRawIconData$type] == ""} { + if {![llength [info commands getRawIconData$type]]} { return -code error "unsupported file format $type" } - set colors [eval [list getColors] [getRawIconData$type [file normalize $file] $index]] - if {$format == "image"} { + # ICODATA is a pure data type - not a real file + if {$type ne "ICODATA"} { + set file [file normalize $file] + } + set colors [eval [linsert [getRawIconData$type $file $index] 0 getColors]] + if {$format eq "image"} { return [createImage $colors $name] } return $colors @@ -132,9 +133,9 @@ proc ::ico::writeIcon {file index bpp data args} { parseOpts type $args if {![info exists type]} { # $type wasn't specified - get it from the extension - set type [string trimleft [string toupper [file extension $file]] .] + set type [fileext $file] } - if {[info commands writeIcon$type] == ""} { + if {![llength [info commands writeIcon$type]]} { return -code error "unsupported file format $type" } if {[llength $data] == 1} { @@ -185,19 +186,19 @@ proc ::ico::copyIcon {f1 i1 f2 i2 args} { parseOpts {fromtype totype} $args if {![info exists fromtype]} { # $type wasn't specified - get it from the extension - set fromtype [string trimleft [string toupper [file extension $f1]] .] + set fromtype [fileext $f1] } if {![info exists totype]} { # $type wasn't specified - get it from the extension - set totype [string trimleft [string toupper [file extension $f2]] .] + set totype [fileext $f2] } - if {[info commands writeIcon$totype] == ""} { + if {![llength [info commands writeIcon$totype]]} { return -code error "unsupported file format $totype" } - if {[info commands getRawIconData$fromtype] == ""} { + if {![llength [info commands getRawIconData$fromtype]]} { return -code error "unsupported file format $fromtype" } - eval [list writeIcon$totype $f2 $i2]] [getRawIconData$fromtype $f1 $i1] + eval [list writeIcon$totype $f2 $i2] [getRawIconData$fromtype $f1 $i1] } # @@ -213,6 +214,7 @@ proc ::ico::copyIcon {f1 i1 f2 i2 args} { # nothing # proc ::ico::transparentColor {img color} { + package require Tk if {[string match "#*" $color]} { set color [scan $x "#%2x%2x%2x"] } @@ -303,6 +305,11 @@ proc ::ico::EXEtoICO {exeFile icoFile} { ## and make sure they "fit" in the API. ## +# gets the file extension as we use it internally (upper case, no '.') +proc ::ico::fileext {file} { + return [string trimleft [string toupper [file extension $file]] .] +} + # helper proc to parse optional arguments to some of the public procs proc ::ico::parseOpts {acc opts} { foreach {key val} $opts { @@ -310,7 +317,7 @@ proc ::ico::parseOpts {acc opts} { if {[lsearch -exact $acc $key] >= 0} { upvar $key $key set $key $val - } elseif {$key != ""} { + } elseif {$key ne ""} { return -code error "unknown option \"$key\": must be one of $acc" } } @@ -328,7 +335,7 @@ proc ::ico::translateColors {colors} { foreach line $colors { set tline {} foreach x $line { - if {$x == ""} {lappend tline {}; continue} + if {$x eq ""} {lappend tline {}; continue} lappend tline [scan $x "#%2x%2x%2x"] } set new [linsert $new 0 $tline] @@ -353,9 +360,14 @@ proc ::ico::bputs {fh format args} { # creates a Tk image from a list of colors in the #hex format proc ::ico::createImage {colors {name {}}} { + package require Tk set h [llength $colors] set w [llength [lindex $colors 0]] - set img [eval image create photo $name -width $w -height $h] + if {$name ne ""} { + set img [image create photo $name -width $w -height $h] + } else { + set img [image create photo -width $w -height $h] + } if {0} { # if image supported "" colors as transparent pixels, # we could use this much faster op @@ -373,7 +385,8 @@ proc ::ico::createImage {colors {name {}}} { return $img } -# return a list of colors in the #hex format from raw icon data returned by readDIB +# return a list of colors in the #hex format from raw icon data +# returned by readDIB proc ::ico::getColors {w h bpp palette xor and} { # Create initial empty color array that we'll set indices in set colors {} @@ -455,7 +468,7 @@ proc ::ico::getAndMaskFromColors {colors} { set and {} foreach line $colors { set l {} - foreach x $line {append l [expr {$x == ""}]} + foreach x $line {append l [expr {$x eq ""}]} append l [string repeat 0 [expr {[string length $l] % 32}]] foreach {a b c d e f g h} [split $l {}] { append and [binary format B8 $a$b$c$d$e$f$g$h] @@ -527,6 +540,7 @@ proc ::ico::getXORFromColors {bpp colors} { # one element per pixel and {} designating transparent # used by writeIcon when writing from a Tk image proc ::ico::getColorsFromImage {img} { + package require Tk set w [image width $img] set h [image height $img] set r {} @@ -556,7 +570,7 @@ proc ::ico::getPaletteFromColors {colors} { foreach line $colors { set tline {} foreach x $line { - if {$x == ""} {lappend tline {}; continue} + if {$x eq ""} {lappend tline {}; continue} if {![info exists tpal($x)]} { foreach {a b c n} $x { append palette [binary format cccc $c $b $a 0] @@ -571,33 +585,75 @@ proc ::ico::getPaletteFromColors {colors} { return [list $i $palette $new] } -# read a Device Independent Bitmap from the current offset and return the -# width, height, depth, palette, XOR mask, and AND mask +# read a Device Independent Bitmap from the current offset, return: +# {width height depth palette XOR_mask AND_mask} proc ::ico::readDIB {fh} { binary scan [read $fh 16] x4iix2s w h bpp set h [expr {$h / 2}] seek $fh 24 current + set palette [list] if {$bpp == 1 || $bpp == 4 || $bpp == 8} { set colors [read $fh [expr {1 << ($bpp + 2)}]] + foreach {b g r x} [split $colors {}] { + lappend palette [formatColor $r $g $b] + } } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} { - set colors {} + # do nothing here } else { return -code error "unsupported color depth: $bpp" } + set xor [read $fh [expr {int(($w * $h) * ($bpp / 8.0))}]] + set and1 [read $fh [expr {(($w * $h) + ($h * ($w % 32))) / 8}]] + + set and {} + set row [expr {($w + abs($w - 32)) / 8}] + set len [expr {$row * $h}] + for {set i 0} {$i < $len} {incr i $row} { + binary scan [string range $and1 $i [expr {$i + $row}]] B$w tmp + append and $tmp + } + + return [list $w $h $bpp $palette $xor $and] +} + +# read a Device Independent Bitmap from raw data, return: +# {width height depth palette XOR_mask AND_mask} +proc ::ico::readDIBFromData {data loc} { + # Read info from location + binary scan $data @${loc}x4iix2s w h bpp + set h [expr {$h / 2}] + # Move over w/h/bpp info + magic offset to start of DIB + set cnt [expr {$loc + 16 + 24}] + set palette [list] - foreach {b g r x} [split $colors {}] { - lappend palette [formatColor $r $g $b] + if {$bpp == 1 || $bpp == 4 || $bpp == 8} { + # Could do: [binary scan $data @${cnt}c$len colors] + # and iter over colors, but this is more consistent with $fh version + set len [expr {1 << ($bpp + 2)}] + set colors [string range $data $cnt [expr {$cnt + $len - 1}]] + foreach {b g r x} [split $colors {}] { + lappend palette [formatColor $r $g $b] + } + incr cnt $len + } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} { + # do nothing here + } else { + return -code error "unsupported color depth: $bpp" } - set xor [read $fh [expr {int(($w * $h) * ($bpp / 8.0))}]] - set and1 [read $fh [expr {(($w * $h) + ($h * ($w % 32))) / 8}]] + # Use -1 to account for string range inclusiveness + set end [expr {$cnt + int(($w * $h) * ($bpp / 8.0)) - 1}] + set xor [string range $data $cnt $end] + set and1 [string range $data [expr {$end + 1}] \ + [expr {$end + ((($w * $h) + ($h * ($w % 32))) / 8) - 1}]] set and {} set row [expr {($w + abs($w - 32)) / 8}] set len [expr {$row * $h}] for {set i 0} {$i < $len} {incr i $row} { + # Has to be decoded by row, in order binary scan [string range $and1 $i [expr {$i + $row}]] B$w tmp append and $tmp } @@ -610,7 +666,7 @@ proc ::ico::getIconListICO {file} { fconfigure $fh -translation binary # both words must be read to keep in sync with later reads - if {"[getword $fh] [getword $fh]" != "0 1"} { + if {"[getword $fh] [getword $fh]" ne "0 1"} { return -code error "not an icon file" } set num [getword $fh] @@ -635,13 +691,41 @@ proc ::ico::getIconListICO {file} { return $r } -# returns an icon in the format of width, height, depth, palette, xor mask, and mask +proc ::ico::getIconListICODATA {data} { + if {[binary scan $data sss h1 h2 num] != 3 || $h1 != 0 || $h2 != 1} { + return -code error "not icon data" + } + set r {} + set cnt 6 + for {set i 0} {$i < $num} {incr i} { + if {[binary scan $data @${cnt}ccc w h bpp] != 3} { + return -code error "error decoding icon data" + } + incr cnt 3 + set info [list $w $h] + if {$bpp == 0} { + set off [expr {$cnt + 9}] + binary scan $data @${off}i off + incr off 14 + binary scan $data @${off}s bpp + lappend info $bpp + } else { + lappend info [expr {int(sqrt($bpp))}] + } + lappend r $info + incr cnt 13 + } + return $r +} + +# returns an icon in the form: +# {width height depth palette xor_mask and_mask} proc ::ico::getRawIconDataICO {file index} { set fh [open $file r] fconfigure $fh -translation binary # both words must be read to keep in sync with later reads - if {"[getword $fh] [getword $fh]" != "0 1"} { + if {"[getword $fh] [getword $fh]" ne "0 1"} { close $fh return -code error "not an icon file" } @@ -659,6 +743,23 @@ proc ::ico::getRawIconDataICO {file index} { return $dib } +proc ::ico::getRawIconDataICODATA {data index} { + if {[binary scan $data sss h1 h2 num] != 3 || $h1 != 0 || $h2 != 1} { + return -code error "not icon data" + } + if {$index < 0 || $index >= $num} { + return -code error "index out of range: must be between 0 and $num" + } + # Move to ico location + set cnt [expr {6 + (16 * $index) + 12}] + binary scan $data @${cnt}i loc + + # readDIB returns: {w h bpp palette xor and} + set dib [readDIBFromData $data $loc] + + return $dib +} + proc ::ico::writeIconICO {file index w h bpp palette xor and} { if {![file exists $file]} { set fh [open $file w+] @@ -669,12 +770,12 @@ proc ::ico::writeIconICO {file index w h bpp palette xor and} { set fh [open $file r+] fconfigure $fh -translation binary } - if {[file size $file] > 4 && "[getword $fh] [getword $fh]" != "0 1"} { + if {[file size $file] > 4 && "[getword $fh] [getword $fh]" ne "0 1"} { close $fh return -code error "not an icon file" } set num [getword $fh] - if {$index == "end"} { set index $num } + if {$index eq "end"} { set index $num } if {$index < 0 || $index > $num} { close $fh return -code error "index out of range" @@ -749,7 +850,7 @@ proc ::ico::checkEXE {exe {mode r}} { fconfigure $fh -translation binary # verify PE header - if {[read $fh 2] != "MZ"} { + if {[read $fh 2] ne "MZ"} { close $fh return -code error "not a DOS executable" } @@ -858,7 +959,8 @@ proc ::ico::getIconListEXE {file} { return $icons } -# returns an icon in the format of width, height, depth, palette, xor mask, and mask +# returns an icon in the form: +# {width height depth palette xor_mask and_mask} proc ::ico::getRawIconDataEXE {file index} { variable ICONS @@ -883,7 +985,7 @@ proc ::ico::writeIconEXE {file index w0 h0 bpp0 palette xor and} { set fh [checkEXE $file r+] set cnt [SearchForIcos $file $fh $index] - if {$index == "end"} {set index $cnt} + if {$index eq "end"} {set index $cnt} if {$cnt < $index} { return -code error "index out of range" } set idx $ICONS($file,$index) @@ -926,7 +1028,7 @@ proc ::ico::Show {file args} { parseOpts {type parent} $args if {![info exists type]} { # $type wasn't specified - get it from the extension - set type [string trimleft [string toupper [file extension $file]] .] + set type [fileext $file] } set file [file normalize $file] @@ -978,4 +1080,4 @@ proc ::ico::Show {file args} { grid columnconfigure $parent 0 -weight 1 } -package provide ico 0.2 +package provide ico 0.3 diff --git a/modules/ico/pkgIndex.tcl b/modules/ico/pkgIndex.tcl index d2b3a97c..a4678fbb 100644 --- a/modules/ico/pkgIndex.tcl +++ b/modules/ico/pkgIndex.tcl @@ -3,6 +3,6 @@ # Copyright (c) 2003 ActiveState Corporation. # All rights reserved. # -# RCS: @(#) $Id: pkgIndex.tcl,v 1.1 2004/07/22 21:07:01 hobbs Exp $ +# RCS: @(#) $Id: pkgIndex.tcl,v 1.2 2004/07/27 00:19:44 hobbs Exp $ -package ifneeded ico 0.2 [list source [file join $dir ico.tcl]] +package ifneeded ico 0.3 [list source [file join $dir ico.tcl]] From cb9c055181df3f39e02e310c2a80202b63164239 Mon Sep 17 00:00:00 2001 From: Jeffrey Hobbs Date: Tue, 27 Jul 2004 00:21:25 +0000 Subject: [PATCH 0028/1290] add RCS id text --- modules/ico/ico.tcl | 1 + 1 file changed, 1 insertion(+) diff --git a/modules/ico/ico.tcl b/modules/ico/ico.tcl index 497b0c5b..ee5f37a8 100644 --- a/modules/ico/ico.tcl +++ b/modules/ico/ico.tcl @@ -5,6 +5,7 @@ # Copyright (c) 2003 Aaron Faupell # Copyright (c) 2003-2004 ActiveState Corporation # +# RCS: @(#) $Id: ico.tcl,v 1.8 2004/07/27 00:21:25 hobbs Exp $ # JH: speed has been considered in these routines, although they # may not be fully optimized. Running EXEtoICO on explorer.exe, From 05756aeb0b8b939452525468c46ead758c042697 Mon Sep 17 00:00:00 2001 From: Andreas Kupries Date: Tue, 27 Jul 2004 02:35:11 +0000 Subject: [PATCH 0029/1290] Fixed bugs in doc, reordered stuff a bit. Import ico work by Jeff and Aaron. --- modules/ico/ChangeLog | 5 ++ modules/ico/ico.man | 142 ++++++++++++++++++++++++++---------------- 2 files changed, 95 insertions(+), 52 deletions(-) diff --git a/modules/ico/ChangeLog b/modules/ico/ChangeLog index 0cba6018..7ff8521a 100644 --- a/modules/ico/ChangeLog +++ b/modules/ico/ChangeLog @@ -1,3 +1,8 @@ +2004-07-26 Andreas Kupries + + * ico.man: Reworked the documentation a bit (fixed bugs, reordered + stuff a bit). + 2004-07-26 Jeff Hobbs * pkgIndex.tcl, ico.man, ico.tcl: add -type ICODATA as a way pass diff --git a/modules/ico/ico.man b/modules/ico/ico.man index d399284d..e27b99f0 100644 --- a/modules/ico/ico.man +++ b/modules/ico/ico.man @@ -1,112 +1,150 @@ [comment {-*- tcl -*- doctools manpage}] [manpage_begin ico n 0.3] -[moddesc {}] -[titledesc {}] +[moddesc {Windows ICO handling}] +[titledesc {Reading and writing windows icons}] [require Tcl 8.4] [require ico [opt 0.3]] [description] This package provides functions for reading and writing Windows icons -from ICO ICL EXE and DLL files. +from ICO, ICL, EXE, and DLL files. -[para] -[para] -[example { - button .explore -image [::ico::getIcon explorer.exe 0 -name explore] - set i [lsearch [::ico::getIconList tclkit.exe] {32 32 8}]] - set colorlist [::ico::getIcon tclkit.exe $i -format colors -type EXE] -}] -[para] +[section API] [list_begin definitions] [call [cmd ::ico::getIconList] [arg file] [opt "[arg option] [arg value]..."]] + +Returns a list of icons found in [arg file] where each element has the +format {width height depth}. Recognizes the following [arg option]s. + [list_begin opt] [opt_def -type value] -[list_end opt] +[list_end] +[nl] -Returns a list of icons found in [arg file] where each element has the format {width height depth} [call [cmd ::ico::getIcon] [arg file] [arg index] [opt "[arg option] [arg value]..."]] + +Extracts the icon at [arg index] from [arg file]. + +The default [option -format] is [const image] which will return the +name of a Tk image containing the icon. Optionally [option -name] may +be used to specify the name of the Tk image that is created. If +[option -format] is [const colors] then a list of color names in the +#RRGGBB format is returned. Each list element is a horizontal +row. Each horizontal row contains a list of colors for all the pixels +in that row from left to right. + +Recognizes the following [arg option]s. + [list_begin opt] [opt_def -type value] [opt_def -format value] [opt_def -name value] -[list_end opt] - -Extracts the icon at [arg index] from [arg file]. The default [opt -format] is [const image] which will return -the name of a Tk image containing the icon. Optionally [arg -name] may be used to specify the name of the Tk -image that is created. If [opt -format] is [const colors] then a list of color names in the #RRGGBB format is -returned. Each list element is a horizontal row. Each horizontal row contains a list of colors for all the pixels -in that row from left to right. +[list_end] +[nl] [call [cmd ::ico::writeIcon] [arg file] [arg index] [arg depth] [arg data] [opt "[arg option] [arg value]..."]] + [list_begin arg] -[arg_def fileName file] -[arg_def integer index] -[arg_def integer depth] -[arg_def options args] -[list_end arg] +[arg_def fileName file in] +[arg_def integer index in] -[list_begin opt] -[opt_def -type value] -[list_end opt] +This is the 0-based index of the icon to write. When writing to an +EXE, DLL, or ICL file you may only overwrite existing icons with an +icon of the same dimensions and color depth. + +When writing to an ICO, [arg index] may be one greater than the last +icon. This will append a new icon to the file. + +When writing to an ICO, [arg index] will accept [const end]. This will +also cause the new icon to be appended to the file. -[arg index] is the 0 based index of the icon to write. When writing to an EXE, DLL, or ICL you may only overwrite -existing icons with an icon of the same dimensions and color depth. When writing to an ICO, [arg index] may be one -greater than the last icon which will append a new icon to the file. When wrting to an ICO, [arg index] will accept -[const end] which will cause the new icon to be appended to the file. When writing the other types [const end] will -refer to the last existing icon. +When writing the other types [const end] will refer to the last +existing icon. -[arg data] is either a list of colors in the format returned by [cmd getIcon -format colors] or the name of a Tk -image. -[arg depth] must be one of 1, 4, 8, 24 or 32. If [arg data] has more colors than the color depth allows an error -will be generated. +[arg_def integer depth in] + +This argument must have a value of 1, 4, 8, 24 or 32. If [arg data] +has more colors than the color depth allows an error will be +generated. + + +[arg_def options data in] + +This argument is either a list of colors in the format returned by +[cmd {::ico::getIcon -format colors}] or the name of a Tk image. + + +[list_end] +[nl] + +Recognizes the following [arg option]s. + +[list_begin opt] +[opt_def -type value] +[list_end] +[nl] [call [cmd ::ico::copyIcon] [arg file] [arg index] [arg file2] [arg index2] [opt "[arg option] [arg value]..."]] + +Copies the icon at [arg index] in [arg file] to [arg index2] in [arg file2]. + [list_begin opt] [opt_def -fromtype value] [opt_def -totype value] -[list_end opt] +[list_end] +[nl] -Copies the icon at [arg index] in [arg file] to [arg index2] in [arg file2]. +[call [cmd ::ico::EXEtoICO] [arg file] [arg file2]] + +Extracts all icons from the executable [arg file] to the ICO file [arg file2] -[call [cmd ::ico::EXEtoICO] [arg file] [arg file2] [list_begin opt] [opt_def -type value] -[list_end opt] - -Extracts all icons from the executable [arg file] to the ICO file [arg file2] +[list_end] +[nl] -[call [cmd ::ico::clearCache] [opt file] +[call [cmd ::ico::clearCache] [opt file]] -The [cmd getIconList] command caches icon offsets inside EXE, DLL, and ICL files in order to speed up extraction. -This command clears that cache for the specific [opt file] or all files. +The [cmd ::ico::getIconList] command caches icon offsets inside EXE, DLL, and +ICL files in order to speed up extraction. This command clears that +cache for the specific [opt file] or all files. -[call [cmd ::ico::transparentColor] [arg image] [arg color] +[call [cmd ::ico::transparentColor] [arg image] [arg color]] Sets every pixel matching [arg color] in Tk image [arg image] to transparent. + [call [cmd ::ico::Show] [arg file] [opt "[arg option] [arg value]..."]] + +Application level command which displays a window showing all the +icons in [arg file] with information about them. + [list_begin opt] [opt_def -type value] [opt_def -parent value] -[list_end opt] +[list_end] +[list_end] -Application level command which displays a window showing all the icons in [arg file] with information about them +[section EXAMPLE] -[list_end] - +[example { + button .explore -image [::ico::getIcon explorer.exe 0 -name explore] + set i [lsearch [::ico::getIconList tclkit.exe] {32 32 8}]] + set colorlist [::ico::getIcon tclkit.exe $i -format colors -type EXE] +}] -[keywords entry {icon ico exe dll}] +[keywords entry icon ico exe dll] [manpage_end] From ebf3d3538034ca71675338b1f3d1a62957592698 Mon Sep 17 00:00:00 2001 From: afaupell Date: Tue, 27 Jul 2004 06:20:43 +0000 Subject: [PATCH 0030/1290] 2004-07-26 Aaron Faupell * ico.tcl: renamed some of the private API to be more descriptive. bugfix in writeIcon and translateColors and CopyIcon. simplified writeIconEXE. --- modules/ico/ChangeLog | 6 ++++++ modules/ico/ico.tcl | 31 ++++++++++++++----------------- 2 files changed, 20 insertions(+), 17 deletions(-) diff --git a/modules/ico/ChangeLog b/modules/ico/ChangeLog index 7ff8521a..e138d692 100644 --- a/modules/ico/ChangeLog +++ b/modules/ico/ChangeLog @@ -1,3 +1,9 @@ +2004-07-26 Aaron Faupell + + * ico.tcl: renamed some of the private API to be more descriptive. + bugfix in writeIcon and translateColors and CopyIcon. simplified + writeIconEXE. + 2004-07-26 Andreas Kupries * ico.man: Reworked the documentation a bit (fixed bugs, reordered diff --git a/modules/ico/ico.tcl b/modules/ico/ico.tcl index ee5f37a8..5647bb7d 100644 --- a/modules/ico/ico.tcl +++ b/modules/ico/ico.tcl @@ -5,7 +5,7 @@ # Copyright (c) 2003 Aaron Faupell # Copyright (c) 2003-2004 ActiveState Corporation # -# RCS: @(#) $Id: ico.tcl,v 1.8 2004/07/27 00:21:25 hobbs Exp $ +# RCS: @(#) $Id: ico.tcl,v 1.9 2004/07/27 06:20:43 afaupell Exp $ # JH: speed has been considered in these routines, although they # may not be fully optimized. Running EXEtoICO on explorer.exe, @@ -105,7 +105,7 @@ proc ::ico::getIcon {file index args} { if {$type ne "ICODATA"} { set file [file normalize $file] } - set colors [eval [linsert [getRawIconData$type $file $index] 0 getColors]] + set colors [eval [linsert [getRawIconData$type $file $index] 0 getIconAsColorList]] if {$format eq "image"} { return [createImage $colors $name] } @@ -140,8 +140,8 @@ proc ::ico::writeIcon {file index bpp data args} { return -code error "unsupported file format $type" } if {[llength $data] == 1} { - set data [getColorsFromImage $data] - } elseif {[string match "#*" [lindex $data 0 0]]} { + set data [getColorListFromImage $data] + } elseif {[lsearch -glob [join $data] #*] > -1} { set data [translateColors $data] } if {$bpp != 1 && $bpp != 4 && $bpp != 8 && $bpp != 24 && $bpp != 32} { @@ -199,7 +199,8 @@ proc ::ico::copyIcon {f1 i1 f2 i2 args} { if {![llength [info commands getRawIconData$fromtype]]} { return -code error "unsupported file format $fromtype" } - eval [list writeIcon$totype $f2 $i2] [getRawIconData$fromtype $f1 $i1] + set src [getRawIconData$fromtype $f1 $i1] + writeIcon $f2 $i2 [lindex $src 2] [eval getIconAsColorList $src] -type $totype } # @@ -217,7 +218,7 @@ proc ::ico::copyIcon {f1 i1 f2 i2 args} { proc ::ico::transparentColor {img color} { package require Tk if {[string match "#*" $color]} { - set color [scan $x "#%2x%2x%2x"] + set color [scan $color "#%2x%2x%2x"] } set w [image width $img] set h [image height $img] @@ -388,7 +389,7 @@ proc ::ico::createImage {colors {name {}}} { # return a list of colors in the #hex format from raw icon data # returned by readDIB -proc ::ico::getColors {w h bpp palette xor and} { +proc ::ico::getIconAsColorList {w h bpp palette xor and} { # Create initial empty color array that we'll set indices in set colors {} set row {} @@ -540,7 +541,7 @@ proc ::ico::getXORFromColors {bpp colors} { # translates a Tk image into a list of colors in the #hex format # one element per pixel and {} designating transparent # used by writeIcon when writing from a Tk image -proc ::ico::getColorsFromImage {img} { +proc ::ico::getColorListFromImage {img} { package require Tk set w [image width $img] set h [image height $img] @@ -940,7 +941,6 @@ proc ::ico::SearchForIcos {file fh {index -1}} { incr pos 4 } } - return $idx } @@ -979,7 +979,7 @@ proc ::ico::getRawIconDataEXE {file index} { return $dib } -proc ::ico::writeIconEXE {file index w0 h0 bpp0 palette xor and} { +proc ::ico::writeIconEXE {file index w h bpp palette xor and} { variable ICONS set file [file normalize $file] @@ -989,16 +989,13 @@ proc ::ico::writeIconEXE {file index w0 h0 bpp0 palette xor and} { if {$index eq "end"} {set index $cnt} if {$cnt < $index} { return -code error "index out of range" } - set idx $ICONS($file,$index) - set ico $ICONS($file,$index,data) - foreach {w h bpp} $ico { break } - - seek $fh [expr {$idx + 40}] start - - if {$w0 != $w || $h0 != $h || $bpp0 != $bpp} { + if {[list $w $h $bpp] != $ICONS($file,$index,data)} { close $fh return -code error "icon format differs from original" } + + seek $fh [expr {$ICONS($file,$index) + 40}] start + puts -nonewline $fh $palette puts -nonewline $fh $xor puts -nonewline $fh $and From c554d5f4f7457c869baa5dfac392dd397eb67093 Mon Sep 17 00:00:00 2001 From: Andreas Kupries Date: Wed, 28 Jul 2004 02:30:45 +0000 Subject: [PATCH 0031/1290] Added package index for tkpiechart, courtesy of Daniel Steffen. Changelog merge. --- modules/tkpiechart/pkgIndex.tcl | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 modules/tkpiechart/pkgIndex.tcl diff --git a/modules/tkpiechart/pkgIndex.tcl b/modules/tkpiechart/pkgIndex.tcl new file mode 100644 index 00000000..4d84ad00 --- /dev/null +++ b/modules/tkpiechart/pkgIndex.tcl @@ -0,0 +1,3 @@ +# Package index file created with stooop version 4.4.1 for stooop packages + +package ifneeded tkpiechart 6.6 [list tclPkgSetup $dir tkpiechart 6.6 {{pie.tcl source {::pie::_copy ::pie::buttonPress ::pie::buttonRelease ::pie::complete ::pie::currentSlice ::pie::darken ::pie::deleteSlice ::pie::labelSlice ::pie::maximum ::pie::minimum ::pie::newSlice ::pie::options ::pie::pie ::pie::selectedSlices ::pie::set-autoupdate ::pie::set-background ::pie::set-colors ::pie::set-height ::pie::set-labeler ::pie::set-selectable ::pie::set-thickness ::pie::set-title ::pie::set-titlefont ::pie::set-titleoffset ::pie::set-width ::pie::setLabelsState ::pie::setSliceBackground ::pie::setSliceLabelBackground ::pie::sizeSlice ::pie::sliceLabelTag ::pie::update ::pie::~pie}} {slice.tcl source {::slice::_copy ::slice::complete ::slice::data ::slice::normalizedAngle ::slice::options ::slice::rotate ::slice::set-bottomcolor ::slice::set-deletecommand ::slice::set-height ::slice::set-scale ::slice::set-startandextent ::slice::set-topcolor ::slice::slice ::slice::update ::slice::updateBottom ::slice::~slice}} {pielabel.tcl source {::pieLabeler::_copy ::pieLabeler::_updateSlices ::pieLabeler::delete ::pieLabeler::label ::pieLabeler::labelBackground ::pieLabeler::labelTextBackground ::pieLabeler::new ::pieLabeler::pieLabeler ::pieLabeler::room ::pieLabeler::selectState ::pieLabeler::set ::pieLabeler::update ::pieLabeler::updateSlices ::pieLabeler::~pieLabeler}} {boxlabel.tcl source {::pieBoxLabeler::_copy ::pieBoxLabeler::delete ::pieBoxLabeler::label ::pieBoxLabeler::labelBackground ::pieBoxLabeler::labelTextBackground ::pieBoxLabeler::new ::pieBoxLabeler::options ::pieBoxLabeler::pieBoxLabeler ::pieBoxLabeler::room ::pieBoxLabeler::selectState ::pieBoxLabeler::set ::pieBoxLabeler::set-font ::pieBoxLabeler::set-justify ::pieBoxLabeler::set-offset ::pieBoxLabeler::set-xoffset ::pieBoxLabeler::update ::pieBoxLabeler::~pieBoxLabeler}} {canlabel.tcl source {::canvasLabel::_copy ::canvasLabel::canvasLabel ::canvasLabel::eventuallyDeleteRelief ::canvasLabel::options ::canvasLabel::set-anchor ::canvasLabel::set-background ::canvasLabel::set-bordercolor ::canvasLabel::set-borderwidth ::canvasLabel::set-bulletwidth ::canvasLabel::set-font ::canvasLabel::set-foreground ::canvasLabel::set-justify ::canvasLabel::set-minimumwidth ::canvasLabel::set-padding ::canvasLabel::set-scale ::canvasLabel::set-select ::canvasLabel::set-selectrelief ::canvasLabel::set-stipple ::canvasLabel::set-text ::canvasLabel::set-textbackground ::canvasLabel::set-width ::canvasLabel::update ::canvasLabel::updateRelief ::canvasLabel::~canvasLabel}} {perilabel.tcl source {::piePeripheralLabeler::_copy ::piePeripheralLabeler::anglePosition ::piePeripheralLabeler::delete ::piePeripheralLabeler::label ::piePeripheralLabeler::labelBackground ::piePeripheralLabeler::labelTextBackground ::piePeripheralLabeler::new ::piePeripheralLabeler::options ::piePeripheralLabeler::piePeripheralLabeler ::piePeripheralLabeler::position ::piePeripheralLabeler::room ::piePeripheralLabeler::selectState ::piePeripheralLabeler::set ::piePeripheralLabeler::set-bulletwidth ::piePeripheralLabeler::set-font ::piePeripheralLabeler::set-justify ::piePeripheralLabeler::set-offset ::piePeripheralLabeler::set-smallfont ::piePeripheralLabeler::set-widestvaluetext ::piePeripheralLabeler::update ::piePeripheralLabeler::updateSlices ::piePeripheralLabeler::~piePeripheralLabeler}} {labarray.tcl source {::canvasLabelsArray::_copy ::canvasLabelsArray::canvasLabelsArray ::canvasLabelsArray::delete ::canvasLabelsArray::height ::canvasLabelsArray::labels ::canvasLabelsArray::manage ::canvasLabelsArray::options ::canvasLabelsArray::set-justify ::canvasLabelsArray::set-width ::canvasLabelsArray::update ::canvasLabelsArray::~canvasLabelsArray}} {selector.tcl source {::selector::_copy ::selector::_extend ::selector::_list ::selector::_selected ::selector::add ::selector::clear ::selector::deselect ::selector::extend ::selector::list ::selector::options ::selector::ordered ::selector::remove ::selector::select ::selector::selected ::selector::selector ::selector::set ::selector::set-selectcommand ::selector::toggle ::selector::unset ::selector::update ::selector::~selector}} {objselec.tcl source {::objectSelector::_copy ::objectSelector::extend ::objectSelector::objectSelector ::objectSelector::~objectSelector}} {relirect.tcl source {::canvasReliefRectangle::_copy ::canvasReliefRectangle::canvasReliefRectangle ::canvasReliefRectangle::options ::canvasReliefRectangle::set-background ::canvasReliefRectangle::set-coordinates ::canvasReliefRectangle::set-relief ::canvasReliefRectangle::update ::canvasReliefRectangle::~canvasReliefRectangle}}}] From 9c962bbdc28cc5d591e4b06c11f1bc5300f5be57 Mon Sep 17 00:00:00 2001 From: afaupell Date: Wed, 28 Jul 2004 03:32:19 +0000 Subject: [PATCH 0032/1290] 2004-07-27 Aaron Faupell * ico.tcl: undocumented windows feature: if the first palette entry isnt black, the transparent background displays in odd colors. fixed getPaletteFromColors to initialize palette with black. changed header writing to use 0 for planes to be consistant with windows. --- modules/ico/ChangeLog | 7 +++++++ modules/ico/ico.tcl | 17 ++++++++--------- 2 files changed, 15 insertions(+), 9 deletions(-) diff --git a/modules/ico/ChangeLog b/modules/ico/ChangeLog index e138d692..8603d2cf 100644 --- a/modules/ico/ChangeLog +++ b/modules/ico/ChangeLog @@ -1,3 +1,10 @@ +2004-07-27 Aaron Faupell + + * ico.tcl: undocumented windows feature: if the first palette entry + isnt black, the transparent background displays in odd colors. fixed + getPaletteFromColors to initialize palette with black. changed header + writing to use 0 for planes to be consistant with windows. + 2004-07-26 Aaron Faupell * ico.tcl: renamed some of the private API to be more descriptive. diff --git a/modules/ico/ico.tcl b/modules/ico/ico.tcl index 5647bb7d..83e3728a 100644 --- a/modules/ico/ico.tcl +++ b/modules/ico/ico.tcl @@ -5,7 +5,7 @@ # Copyright (c) 2003 Aaron Faupell # Copyright (c) 2003-2004 ActiveState Corporation # -# RCS: @(#) $Id: ico.tcl,v 1.9 2004/07/27 06:20:43 afaupell Exp $ +# RCS: @(#) $Id: ico.tcl,v 1.10 2004/07/28 03:32:19 afaupell Exp $ # JH: speed has been considered in these routines, although they # may not be fully optimized. Running EXEtoICO on explorer.exe, @@ -271,9 +271,8 @@ proc ::ico::EXEtoICO {exeFile icoFile} { set cnt [SearchForIcos $file $fh] for {set i 0} {$i <= $cnt} {incr i} { - set idx $ICONS($file,$i) set ico $ICONS($file,$i,data) - seek $fh $idx start + seek $fh $ICONS($file,$i) start eval [list lappend dir] $ico append data [read $fh [eval calcSize $ico 40]] } @@ -453,7 +452,7 @@ proc ::ico::getIconAsColorList {w h bpp palette xor and} { incr x } } elseif {$bpp == 32} { - foreach {b g r a} [split $xor {}] a [split $and {}] { + foreach {b g r n} [split $xor {}] a [split $and {}] { if {$x == $w} { set x 0; incr y -1 } if {$a == 0} { lset colors $y $x [formatColor $r $g $b] @@ -565,10 +564,10 @@ proc ::ico::getColorListFromImage {img} { # and the color list transformed to point to palette entries instead of color names # the palette entry itself is stored as 32bpp in "G B R padding" order proc ::ico::getPaletteFromColors {colors} { - set palette {} - array set tpal {} + set palette "\x00\x00\x00\x00" + array set tpal {{0 0 0} 0} set new {} - set i 0 + set i 1 foreach line $colors { set tline {} foreach x $line { @@ -804,7 +803,7 @@ proc ::ico::writeIconICO {file index w h bpp palette xor and} { incr cur } # insert new icon dir entry - bputs $fh ccccss $w $h $colors 0 1 $bpp + bputs $fh ccccss $w $h $colors 0 0 $bpp bputs $fh ii [expr {$size + 40}] [expr {[string length $olddata] + [tell $fh] + 8}] # put all the icon data back puts -nonewline $fh $olddata @@ -834,7 +833,7 @@ proc ::ico::writeIconICO {file index w h bpp palette xor and} { set olddata [read $fh] # overwrite icon dir entry seek $fh [expr {($index * 16) + 6}] start - bputs $fh ccccssi $w $h $colors 0 1 $bpp [expr {$size + 40}] + bputs $fh ccccssi $w $h $colors 0 0 $bpp [expr {$size + 40}] # insert new icon and saved data seek $fh $offset start bputs $fh iiissiiiiii 40 $w [expr {$h * 2}] 1 $bpp 0 $size 0 0 0 0 From e224d976e80080c83965889020d38d1deef3c718 Mon Sep 17 00:00:00 2001 From: georgeps Date: Thu, 12 Aug 2004 09:14:44 +0000 Subject: [PATCH 0033/1290] bugfix -- see ChangeLog --- modules/ctext/ctext.tcl | 30 ++++++++++++++++-------------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/modules/ctext/ctext.tcl b/modules/ctext/ctext.tcl index 9a8b59bd..373cf9c7 100644 --- a/modules/ctext/ctext.tcl +++ b/modules/ctext/ctext.tcl @@ -1,6 +1,6 @@ # By George Peter Staplin # See also the README for a list of contributors -# RCS: @(#) $Id: ctext.tcl,v 1.1.1.1 2004/01/23 00:32:16 georgeps Exp $ +# RCS: @(#) $Id: ctext.tcl,v 1.2 2004/08/12 09:14:44 georgeps Exp $ package require Tk package provide ctext 3.1 @@ -57,26 +57,30 @@ proc ctext {win args} { #Now remove flags that will confuse text and those that need modification: foreach arg $ar(ctextFlags) { - set loc [lsearch $args $arg] - if {$loc >= 0} { + if {[set loc [lsearch $args $arg]] >= 0} { set args [lreplace $args $loc [expr {$loc + 1}]] } } text $win.l -font $ar(-font) -width 1 -height 1 \ - -relief $ar(-relief) -fg $ar(-linemapfg) -bg $ar(-linemapbg) -takefocus 0 + -relief $ar(-relief) -fg $ar(-linemapfg) \ + -bg $ar(-linemapbg) -takefocus 0 set topWin [winfo toplevel $win] bindtags $win.l [list $win.l $topWin all] if {$ar(-linemap) == 1} { - pack $win.l -side left -fill y + grid $win.l -sticky ns -row 0 -column 0 } set args [concat $args [list -yscrollcommand [list ctext::event:yscroll $win $ar(-yscrollcommand)]]] #escape $win, because it could have a space - pack [eval text \$win.t $args -font \$ar(-font)] -side right -fill both -expand 1 + eval text \$win.t -font \$ar(-font) $args + + grid $win.t -row 0 -column 1 -sticky news + grid rowconfigure $win 0 -weight 100 + grid columnconfigure $win 1 -weight 100 bind $win.t [list ctext::linemapUpdate $win] bind $win.l [list ctext::linemapToggleMark $win %y] @@ -128,13 +132,16 @@ proc ctext::buildArgParseTable win { } lappend argTable {1 true yes} -linemap { - pack $self.l -side left -fill y + grid $self.l -sticky ns -row 0 -column 0 + grid columnconfigure $self 0 \ + -minsize [winfo reqwidth $self.l] set configAr(-linemap) 1 break } lappend argTable {0 false no} -linemap { - pack forget $self.l + grid forget $self.l + grid columnconfigure $self 0 -minsize 0 set configAr(-linemap) 0 break } @@ -721,12 +728,7 @@ proc ctext::deleteHighlightClass {win classToDelete} { proc ctext::getHighlightClasses win { ctext::getAr $win classes classesAr - set res [list] - - foreach {class info} [array get classesAr] { - lappend res $class - } - return $res + array names classesAr } proc ctext::findNextChar {win index char} { From ddf0d46ba8aeeba0e28b48b84a5aebb9ded9e5c3 Mon Sep 17 00:00:00 2001 From: georgeps Date: Thu, 12 Aug 2004 09:15:05 +0000 Subject: [PATCH 0034/1290] update --- modules/ctext/ChangeLog | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/modules/ctext/ChangeLog b/modules/ctext/ChangeLog index 1594684b..0d7cbd56 100644 --- a/modules/ctext/ChangeLog +++ b/modules/ctext/ChangeLog @@ -1,3 +1,19 @@ +3.1.4 - Thu Aug 12 03:10:06 UTC 2004 + + ctext.tcl was changed to fix a bug that + occured when the geometry management of the + ctext widget was such that it wouldn't enlarge + when [$inst configure -linemap 1] was invoked. + + This was fixed using grid and a -minsize. The + previous manager was pack. Grid behaves in an + appropriate manner for this situation with the + proper weights and -minsize. + + Thanks to Arjen Markus for testing and bringing + this up. + + 3.1.3 - Thu Jan 22 14:51:08 GMT 2004 I changed the bindtags so that binding to From 06e1431027bbb7faf1a7feea07dcbba2ac31958f Mon Sep 17 00:00:00 2001 From: afaupell Date: Tue, 17 Aug 2004 17:36:41 +0000 Subject: [PATCH 0035/1290] 2004-08-17 Aaron Faupell * ico.tcl: CheckEXE removed and replaced by new SearchForIcos which calls SearchForIcosNE or SearchForIcosPE which atually parse the window resource tables resulting in a nice speed improvement over the old linear search. Also corrected all usage of fconfigure. --- modules/ico/ChangeLog | 7 ++ modules/ico/ico.man | 36 ++++-- modules/ico/ico.tcl | 247 ++++++++++++++++++++++++------------------ 3 files changed, 177 insertions(+), 113 deletions(-) diff --git a/modules/ico/ChangeLog b/modules/ico/ChangeLog index 8603d2cf..e606b5e5 100644 --- a/modules/ico/ChangeLog +++ b/modules/ico/ChangeLog @@ -1,3 +1,10 @@ +2004-08-17 Aaron Faupell + + * ico.tcl: CheckEXE removed and replaced by new SearchForIcos which + calls SearchForIcosNE or SearchForIcosPE which atually parse the + window resource tables resulting in a nice speed improvement + over the old linear search. Also corrected all usage of fconfigure. + 2004-07-27 Aaron Faupell * ico.tcl: undocumented windows feature: if the first palette entry diff --git a/modules/ico/ico.man b/modules/ico/ico.man index e27b99f0..e2bf5cf7 100644 --- a/modules/ico/ico.man +++ b/modules/ico/ico.man @@ -20,7 +20,7 @@ Returns a list of icons found in [arg file] where each element has the format {width height depth}. Recognizes the following [arg option]s. [list_begin opt] -[opt_def -type value] +[opt_def -type fileFormat] [list_end] [nl] @@ -40,7 +40,7 @@ in that row from left to right. Recognizes the following [arg option]s. [list_begin opt] -[opt_def -type value] +[opt_def -type fileFormat] [opt_def -format value] [opt_def -name value] [list_end] @@ -69,7 +69,7 @@ existing icon. [arg_def integer depth in] -This argument must have a value of 1, 4, 8, 24 or 32. If [arg data] +This argument must have a value of [const 1], [const 4], [const 8], [const 24], or [const 32]. If [arg data] has more colors than the color depth allows an error will be generated. @@ -86,7 +86,7 @@ This argument is either a list of colors in the format returned by Recognizes the following [arg option]s. [list_begin opt] -[opt_def -type value] +[opt_def -type fileFormat] [list_end] [nl] @@ -96,8 +96,8 @@ Recognizes the following [arg option]s. Copies the icon at [arg index] in [arg file] to [arg index2] in [arg file2]. [list_begin opt] -[opt_def -fromtype value] -[opt_def -totype value] +[opt_def -fromtype fileFormat] +[opt_def -totype fileFormat] [list_end] [nl] @@ -107,7 +107,7 @@ Copies the icon at [arg index] in [arg file] to [arg index2] in [arg file2]. Extracts all icons from the executable [arg file] to the ICO file [arg file2] [list_begin opt] -[opt_def -type value] +[opt_def -type fileFormat] [list_end] [nl] @@ -130,8 +130,8 @@ Application level command which displays a window showing all the icons in [arg file] with information about them. [list_begin opt] -[opt_def -type value] -[opt_def -parent value] +[opt_def -type fileFormat] +[opt_def -parent pathName] [list_end] [list_end] @@ -144,6 +144,24 @@ icons in [arg file] with information about them. set colorlist [::ico::getIcon tclkit.exe $i -format colors -type EXE] }] +[section LIMITATIONS] + +Icons may not be added or removed from file types other than ICO. Icons in these files +may only be replaced with icons of the same dimensions and color depth. +[nl] + +Icons of 8bpp or lower must include black in the pallete, this means if your icon does +not have black in it, you will need to leave a color free so that it may be included by +writeIcon. +[nl] + +There is currently no way to read alpha channel information from 32bpp icons. +[nl] + +Tk images do not have an alpha channel so the only way to write a true 32bpp icon is from +a color list. writing a 32bpp icon from a Tkimage is identical to writing a 24bpp icon. + + [keywords entry icon ico exe dll] [manpage_end] diff --git a/modules/ico/ico.tcl b/modules/ico/ico.tcl index 83e3728a..7f71e8c1 100644 --- a/modules/ico/ico.tcl +++ b/modules/ico/ico.tcl @@ -5,7 +5,7 @@ # Copyright (c) 2003 Aaron Faupell # Copyright (c) 2003-2004 ActiveState Corporation # -# RCS: @(#) $Id: ico.tcl,v 1.10 2004/07/28 03:32:19 afaupell Exp $ +# RCS: @(#) $Id: ico.tcl,v 1.11 2004/08/17 17:36:41 afaupell Exp $ # JH: speed has been considered in these routines, although they # may not be fully optimized. Running EXEtoICO on explorer.exe, @@ -21,9 +21,6 @@ package require Tcl 8.4 # Instantiate vars we need for this package namespace eval ::ico { - # don't look farther than this for icos past beginning or last ico found - variable maxIcoSearch 32768; #16384 ; #32768 - # stores cached indices of icons found variable ICONS array set ICONS {} @@ -267,12 +264,16 @@ proc ::ico::EXEtoICO {exeFile icoFile} { variable ICONS set file [file normalize $exeFile] - set fh [checkEXE $file] - set cnt [SearchForIcos $file $fh] + set cnt [SearchForIcos $file] + set dir {} + set data {} + + set fh [open $file] + fconfigure $fh -eofchar {} -encoding binary -translation lf for {set i 0} {$i <= $cnt} {incr i} { + seek $fh $ICONS($file,$i) start set ico $ICONS($file,$i,data) - seek $fh $ICONS($file,$i) start eval [list lappend dir] $ico append data [read $fh [eval calcSize $ico 40]] } @@ -280,7 +281,7 @@ proc ::ico::EXEtoICO {exeFile icoFile} { # write them out to a file set ifh [open $icoFile w+] - fconfigure $ifh -translation binary + fconfigure $ifh -eofchar {} -encoding binary -translation lf bputs $ifh sss 0 1 [expr {$cnt + 1}] set offset [expr {6 + (($cnt + 1) * 16)}] @@ -295,7 +296,7 @@ proc ::ico::EXEtoICO {exeFile icoFile} { puts -nonewline $ifh $data foreach {offset size} $fix { seek $ifh [expr {$offset + 20}] start - bputs $ifh i $s + bputs $ifh i $size } close $ifh } @@ -354,6 +355,16 @@ proc ::ico::getword {fh} { return $tmp } +proc ::ico::getulong {fh} { + binary scan [read $fh 4] i tmp + return [format %u $tmp] +} + +proc ::ico::getushort {fh} { + binary scan [read $fh 2] s tmp + return [expr {$tmp & 0x0000FFFF}] +} + # binary puts proc ::ico::bputs {fh format args} { puts -nonewline $fh [eval [list binary format $format] $args] @@ -537,7 +548,7 @@ proc ::ico::getXORFromColors {bpp colors} { return $xor } -# translates a Tk image into a list of colors in the #hex format +# translates a Tk image into a list of colors in the {r g b} format # one element per pixel and {} designating transparent # used by writeIcon when writing from a Tk image proc ::ico::getColorListFromImage {img} { @@ -664,7 +675,7 @@ proc ::ico::readDIBFromData {data loc} { proc ::ico::getIconListICO {file} { set fh [open $file r] - fconfigure $fh -translation binary + fconfigure $fh -eofchar {} -encoding binary -translation lf # both words must be read to keep in sync with later reads if {"[getword $fh] [getword $fh]" ne "0 1"} { @@ -723,7 +734,7 @@ proc ::ico::getIconListICODATA {data} { # {width height depth palette xor_mask and_mask} proc ::ico::getRawIconDataICO {file index} { set fh [open $file r] - fconfigure $fh -translation binary + fconfigure $fh -eofchar {} -encoding binary -translation lf # both words must be read to keep in sync with later reads if {"[getword $fh] [getword $fh]" ne "0 1"} { @@ -764,12 +775,12 @@ proc ::ico::getRawIconDataICODATA {data index} { proc ::ico::writeIconICO {file index w h bpp palette xor and} { if {![file exists $file]} { set fh [open $file w+] - fconfigure $fh -translation binary + fconfigure $fh -eofchar {} -encoding binary -translation lf bputs $fh sss 0 1 0 seek $fh 0 start } else { set fh [open $file r+] - fconfigure $fh -translation binary + fconfigure $fh -eofchar {} -encoding binary -translation lf } if {[file size $file] > 4 && "[getword $fh] [getword $fh]" ne "0 1"} { close $fh @@ -845,35 +856,6 @@ proc ::ico::writeIconICO {file index w h bpp palette xor and} { close $fh } -# checks if file is a windows executable and returns an open file handle at the start of the data segment -proc ::ico::checkEXE {exe {mode r}} { - set fh [open $exe $mode] - fconfigure $fh -translation binary - - # verify PE header - if {[read $fh 2] ne "MZ"} { - close $fh - return -code error "not a DOS executable" - } - seek $fh 60 start - seek $fh [getword $fh] start - set sig [read $fh 4] - if {$sig eq "PE\000\000"} { - # move past header data - seek $fh 24 current - seek $fh [getdword $fh] start - } elseif {[string match "NE*" $sig]} { - seek $fh 34 current - seek $fh [getdword $fh] start - } else { - close $fh - return -code error "executable header not found" - } - - # return file handle - return $fh -} - # calculate byte size of an icon. # often passed $w twice because $h is double $w in the binary data proc ::ico::calcSize {w h bpp {offset 0}} { @@ -883,79 +865,137 @@ proc ::ico::calcSize {w h bpp {offset 0}} { return $s } -# find all the icons in an executable and cache their size and offsets -proc ::ico::SearchForIcos {file fh {index -1}} { +proc ::ico::SearchForIcos {file {index -1}} { variable ICONS ; # stores icos offsets by index, and [list w h bpp] - variable maxIcoSearch ; # don't look farther than this for icos - set readsize 512 ; # chunked read size if {[info exists ICONS($file,$index)]} { return $ICONS($file,$index) } + set fh [open $file] + fconfigure $fh -eofchar {} -encoding binary -translation lf + if {[read $fh 2] ne "MZ"} { + close $fh + return -code error "unknown file format" + } + seek $fh 60 start + seek $fh [getword $fh] start + set sig [read $fh 4] + seek $fh -4 current + if {$sig eq "PE\000\000"} { + return [SearchForIcosPE $fh $file $index] + } elseif {[string match NE* $sig]} { + return [SearchForIcosNE $fh $file $index] + } else { + return -code error "unknown file format" + } +} - set last 0 ; # tell point of last ico found - set idx -1 ; # index of icos found - set pos 0 - set offset [tell $fh] - set data [read $fh $readsize] - set lastoffset $offset - - while {1} { - if {$pos > ($readsize - 20)} { - if {[eof $fh] || ($last && ([tell $fh]-$last) >= $maxIcoSearch)} { - # set the -1 index to indicate we've read the whole file - set ICONS($file,-1) $idx - break - } - - seek $fh [expr {$pos - $readsize}] current - set offset [tell $fh] - - if {$offset <= $lastoffset} { - # We made no progress (anymore). This means that we - # have reached the end of the file and processed a - # short block of 16 byte. And that we are now trying - # to read and process the same block again. Squashing - # the infinite loop just starting up right now. - - set ICONS($file,-1) $idx - break - } - set lastoffset $offset +# parse the resource table of 16 bit windows files for icons +proc ::ico::SearchForIcosNE {fh file index} { + variable ICONS ; # stores icos offsets by index, and [list w h bpp] + set idx -1 ; # index of icos found - set pos 0 - set data [read $fh $readsize] - } + seek $fh 36 current + seek $fh [expr {[getword $fh] - 38}] current + + set base [tell $fh] + set shift [expr {int(pow(2, [getushort $fh]))}] + while {[set type [expr {[getushort $fh] & 0x7fff}]] != 0} { + set num [getushort $fh] + if {$type != 3} { + seek $fh [expr {($num * 12) + 4}] current + continue + } + seek $fh 4 current + for {set i 0} {$i < $num} {incr i} { + incr idx + set ICONS($file,$idx) [expr {[getushort $fh] * $shift}] + seek $fh 10 current + set cur [tell $fh] + + seek $fh $ICONS($file,$idx) start + binary scan [read $fh 16] x4iix2s w h bpp + set ICONS($file,$idx,data) [list $w [expr {$h / 2}] $bpp] + + seek $fh $cur start + } + close $fh + return $idx + } + close $fh + return -1 +} - binary scan [string range $data $pos [expr {$pos + 20}]] \ - iiissi s w h p bpp comp - if {$s == 40 && $p == 1 && $comp == 0 && $w == ($h / 2)} { - set ICONS($file,[incr idx]) [expr {$offset + $pos}] - set ICONS($file,$idx,data) [list $w $w $bpp] - # stop if we found requested index - if {$index >= 0 && $idx == $index} { break } - incr pos [calcSize $w $w $bpp 40] - set last [expr {$offset + $pos}] - } else { - incr pos 4 - } +# parse the resource tree of 32 bit windows files for icons +proc ::ico::SearchForIcosPE {fh file index} { + variable ICONS ; # stores icos offsets by index, and [list w h bpp] + set idx -1 ; # index of icos found + + # find the .rsrc section by reading the coff header + binary scan [read $fh 24] x6sx12s sections headersize + seek $fh $headersize current + for {set i 0} {$i < $sections} {incr i} { + binary scan [read $fh 40] a8x4ix4i type baserva base + if {[string match .rsrc* $type]} {break} + } + # no resource section found = no icons + if {![string match .rsrc* $type]} { + close $fh + return -1 } - return $idx + seek $fh $base start + + seek $fh 12 current + set entries [expr {[getushort $fh] + [getushort $fh]}] + for {set i 0} {$i < $entries} {incr i} { + set name [getulong $fh] + set offset [expr {[getulong $fh] & 0x7fffffff}] + if {$name != 3} {continue} + seek $fh [expr {$base + $offset + 12}] start + + set entries2 [expr {[getushort $fh] + [getushort $fh]}] + for {set i2 0} {$i2 < $entries2} {incr i2} { + seek $fh 4 current + set offset [expr {[getulong $fh] & 0x7fffffff}] + set cur2 [tell $fh] + seek $fh [expr {$offset + $base + 12}] start + + set entries3 [expr {[getushort $fh] + [getushort $fh]}] + for {set i3 0} {$i3 < $entries3} {incr i3} { + seek $fh 4 current + set offset [expr {[getulong $fh] & 0x7fffffff}] + set cur3 [tell $fh] + seek $fh [expr {$offset + $base}] start + + set rva [getulong $fh] + incr idx + set ICONS($file,$idx) [expr {$rva - $baserva + $base}] + seek $fh $ICONS($file,$idx) start + binary scan [read $fh 16] x4iix2s w h bpp + set ICONS($file,$idx,data) [list $w [expr {$h / 2}] $bpp] + + seek $fh $cur3 start + } + seek $fh $cur2 start + } + close $fh + return $idx + } + close $fh + return -1 } proc ::ico::getIconListEXE {file} { variable ICONS set file [file normalize $file] - set fh [checkEXE $file] - set cnt [SearchForIcos $file $fh] + set cnt [SearchForIcos $file] set icons [list] for {set i 0} {$i <= $cnt} {incr i} { lappend icons $ICONS($file,$i,data) } - close $fh return $icons } @@ -965,11 +1005,12 @@ proc ::ico::getRawIconDataEXE {file index} { variable ICONS set file [file normalize $file] - set fh [checkEXE $file] - set cnt [SearchForIcos $file $fh $index] + set cnt [SearchForIcos $file $index] if {$cnt < $index} { return -code error "index out of range" } + set fh [open $file] + fconfigure $fh -eofchar {} -encoding binary -translation lf seek $fh $ICONS($file,$index) start # readDIB returns: {w h bpp palette xor and} @@ -982,22 +1023,20 @@ proc ::ico::writeIconEXE {file index w h bpp palette xor and} { variable ICONS set file [file normalize $file] - set fh [checkEXE $file r+] set cnt [SearchForIcos $file $fh $index] if {$index eq "end"} {set index $cnt} if {$cnt < $index} { return -code error "index out of range" } if {[list $w $h $bpp] != $ICONS($file,$index,data)} { - close $fh return -code error "icon format differs from original" } - + + set fh [open $file r+] + fconfigure $fh -eofchar {} -encoding binary -translation lf seek $fh [expr {$ICONS($file,$index) + 40}] start - puts -nonewline $fh $palette - puts -nonewline $fh $xor - puts -nonewline $fh $and + puts -nonewline $fh $palette$xor$and close $fh } @@ -1028,7 +1067,7 @@ proc ::ico::Show {file args} { set type [fileext $file] } - set file [file normalize $file] + set file [file normalize $file] set icos [getIconList $file -type $type] set wname [string map {. _ : _} $file] From e59d14884df6d92d88b0ae169692d56d8dadbc17 Mon Sep 17 00:00:00 2001 From: Jeffrey Hobbs Date: Tue, 17 Aug 2004 19:09:23 +0000 Subject: [PATCH 0036/1290] * as.tcl: Change style::use to call style::${style}::init * style.tcl: procedure, so a simple package require doesn't * lobster.tcl: actually do anything. Add init to lobster and * pkgIndex.tcl: correct namespace usage. Move lobster and style to v0.2. style::use now takes args to pass to init, eg: style::use as -priority 80 --- modules/style/ChangeLog | 9 +++ modules/style/as.tcl | 3 +- modules/style/lobster.tcl | 134 +++++++++++++++++++++---------------- modules/style/pkgIndex.tcl | 4 +- modules/style/style.tcl | 12 ++-- 5 files changed, 95 insertions(+), 67 deletions(-) diff --git a/modules/style/ChangeLog b/modules/style/ChangeLog index a4ced01d..139fb4c2 100644 --- a/modules/style/ChangeLog +++ b/modules/style/ChangeLog @@ -1,3 +1,12 @@ +2004-08-17 Jeff Hobbs + + * as.tcl: Change style::use to call style::${style}::init + * style.tcl: procedure, so a simple package require doesn't + * lobster.tcl: actually do anything. Add init to lobster and + * pkgIndex.tcl: correct namespace usage. Move lobster and style + to v0.2. style::use now takes args to pass to init, eg: + style::use as -priority 80 + 2004-06-29 Jeff Hobbs * pkgIndex.tcl: style::as is version 1.2 diff --git a/modules/style/as.tcl b/modules/style/as.tcl index bbd3ef41..974dfa1a 100644 --- a/modules/style/as.tcl +++ b/modules/style/as.tcl @@ -37,6 +37,7 @@ namespace eval style::as { }; # end of namespace style::as proc style::as::init {args} { + package require Tk variable prio if {[llength $args]} { @@ -434,6 +435,4 @@ proc style::as::reset_mousewheel {args} { } } -style::as::init - package provide style::as $style::as::version diff --git a/modules/style/lobster.tcl b/modules/style/lobster.tcl index aaa14903..98ddbcf5 100644 --- a/modules/style/lobster.tcl +++ b/modules/style/lobster.tcl @@ -3,62 +3,80 @@ # The code formerly known as "gtklook" on the Tcl'ers # wiki. Most of this code was originally written by Jeremy Collins. -# $Id: lobster.tcl,v 1.3 2004/03/25 16:22:08 davidw Exp $ - -package provide style::lobster 0.1 - -namespace eval styles::lobster { - if { [tk windowingsystem] == "x11" } { - set size -12 - set family Helvetica - font create LobsterFont -size $size -family $family - - option add *borderWidth 1 widgetDefault - option add *activeBorderWidth 1 widgetDefault - option add *selectBorderWidth 1 widgetDefault - option add *font LobsterFont widgetDefault - - option add *padX 2 widgetDefault - option add *padY 4 widgetDefault - - option add *Listbox.background white widgetDefault - option add *Listbox.selectBorderWidth 0 widgetDefault - option add *Listbox.selectForeground white widgetDefault - option add *Listbox.selectBackground #4a6984 widgetDefault - - option add *Entry.background white widgetDefault - option add *Entry.foreground black widgetDefault - option add *Entry.selectBorderWidth 0 widgetDefault - option add *Entry.selectForeground white widgetDefault - option add *Entry.selectBackground #4a6984 widgetDefault - - option add *Text.background white widgetDefault - option add *Text.selectBorderWidth 0 widgetDefault - option add *Text.selectForeground white widgetDefault - option add *Text.selectBackground #4a6984 widgetDefault - - option add *Menu.activeBackground #4a6984 widgetDefault - option add *Menu.activeForeground white widgetDefault - option add *Menu.activeBorderWidth 0 widgetDefault - option add *Menu.highlightThickness 0 widgetDefault - option add *Menu.borderWidth 2 widgetDefault - - option add *Menubutton.activeBackground #4a6984 widgetDefault - option add *Menubutton.activeForeground white widgetDefault - option add *Menubutton.activeBorderWidth 0 widgetDefault - option add *Menubutton.highlightThickness 0 widgetDefault - option add *Menubutton.borderWidth 0 widgetDefault - - option add *Labelframe.borderWidth 2 widgetDefault - option add *Frame.borderWidth 2 widgetDefault - option add *Labelframe.padY 8 widgetDefault - option add *Labelframe.padX 12 widgetDefault - - option add *highlightThickness 0 widgetDefault - option add *troughColor #c3c3c3 widgetDefault - - option add *Scrollbar.width 12 widgetDefault - option add *Scrollbar.borderWidth 1 widgetDefault - option add *Scrollbar.highlightThickness 0 widgetDefault +# $Id: lobster.tcl,v 1.4 2004/08/17 19:09:23 hobbs Exp $ + +namespace eval style::lobster { + # This may need to be adjusted for some window managers that are + # more aggressive with their own Xdefaults (like KDE and CDE) + variable prio "widgetDefault" +} + +proc style::lobster::init {args} { + package require Tk + variable prio + + if {[llength $args]} { + set arg [lindex $args 0] + set len [string length $arg] + if {$len > 2 && [string equal -len $len $arg "-priority"]} { + set prio [lindex $args 1] + set args [lrange $args 2 end] + } + } + + if {[string equal [tk windowingsystem] "x11"]} { + set size -12 + set family Helvetica + font create LobsterFont -size $size -family $family + + option add *borderWidth 1 $prio + option add *activeBorderWidth 1 $prio + option add *selectBorderWidth 1 $prio + option add *font LobsterFont $prio + + option add *padX 2 $prio + option add *padY 4 $prio + + option add *Listbox.background white $prio + option add *Listbox.selectBorderWidth 0 $prio + option add *Listbox.selectForeground white $prio + option add *Listbox.selectBackground #4a6984 $prio + + option add *Entry.background white $prio + option add *Entry.foreground black $prio + option add *Entry.selectBorderWidth 0 $prio + option add *Entry.selectForeground white $prio + option add *Entry.selectBackground #4a6984 $prio + + option add *Text.background white $prio + option add *Text.selectBorderWidth 0 $prio + option add *Text.selectForeground white $prio + option add *Text.selectBackground #4a6984 $prio + + option add *Menu.activeBackground #4a6984 $prio + option add *Menu.activeForeground white $prio + option add *Menu.activeBorderWidth 0 $prio + option add *Menu.highlightThickness 0 $prio + option add *Menu.borderWidth 2 $prio + + option add *Menubutton.activeBackground #4a6984 $prio + option add *Menubutton.activeForeground white $prio + option add *Menubutton.activeBorderWidth 0 $prio + option add *Menubutton.highlightThickness 0 $prio + option add *Menubutton.borderWidth 0 $prio + + option add *Labelframe.borderWidth 2 $prio + option add *Frame.borderWidth 2 $prio + option add *Labelframe.padY 8 $prio + option add *Labelframe.padX 12 $prio + + option add *highlightThickness 0 $prio + option add *troughColor #c3c3c3 $prio + + option add *Scrollbar.width 12 $prio + option add *Scrollbar.borderWidth 1 $prio + option add *Scrollbar.highlightThickness 0 $prio } -} \ No newline at end of file +} + +package provide style::lobster 0.2 diff --git a/modules/style/pkgIndex.tcl b/modules/style/pkgIndex.tcl index de23816a..48390eb4 100644 --- a/modules/style/pkgIndex.tcl +++ b/modules/style/pkgIndex.tcl @@ -8,6 +8,6 @@ # script is sourced, the variable $dir must contain the # full path name of this file's directory. -package ifneeded style 0.1 [list source [file join $dir style.tcl]] +package ifneeded style 0.2 [list source [file join $dir style.tcl]] package ifneeded style::as 1.2 [list source [file join $dir as.tcl]] -package ifneeded style::lobster 0.1 [list source [file join $dir lobster.tcl]] +package ifneeded style::lobster 0.2 [list source [file join $dir lobster.tcl]] diff --git a/modules/style/style.tcl b/modules/style/style.tcl index 3d7b3bd3..94714670 100644 --- a/modules/style/style.tcl +++ b/modules/style/style.tcl @@ -1,10 +1,11 @@ # style.tcl -- Styles for Tk. -# $Id: style.tcl,v 1.2 2004/03/18 08:56:47 davidw Exp $ +# $Id: style.tcl,v 1.3 2004/08/17 19:09:23 hobbs Exp $ # Copyright 2004 David N. Welton +# Copyright 2004 ActiveState Corporation -package provide style 0.1 +package provide style 0.2 namespace eval style { # Available styles @@ -22,10 +23,11 @@ proc style::names {} { # style::use -- # -# Untill I see a better way of doing it, this is just a wrapper +# Until I see a better way of doing it, this is just a wrapper # for package require. The problem is that 'use'ing different # styles won't undo the changes made by previous styles. -proc style::use {newstyle} { +proc style::use {newstyle args} { package require style::${newstyle} -} \ No newline at end of file + eval [linsert $args 0 style::${newstyle}::init] +} From 50cf535685d218e3b27d74ca53ce623f4a28ebfa Mon Sep 17 00:00:00 2001 From: Andreas Kupries Date: Wed, 18 Aug 2004 03:45:18 +0000 Subject: [PATCH 0037/1290] Manpage merge. Import Jeff's work on style. Import Aaron's work on ico. Import GPS' work on ctext. Added package index for tkpiechart, courtesy of Daniel Steffen. --- modules/ctext/ctext.tcl | 2 +- modules/ico/ico.man | 13 +++++++++---- 2 files changed, 10 insertions(+), 5 deletions(-) diff --git a/modules/ctext/ctext.tcl b/modules/ctext/ctext.tcl index 373cf9c7..2c8dd081 100644 --- a/modules/ctext/ctext.tcl +++ b/modules/ctext/ctext.tcl @@ -1,6 +1,6 @@ # By George Peter Staplin # See also the README for a list of contributors -# RCS: @(#) $Id: ctext.tcl,v 1.2 2004/08/12 09:14:44 georgeps Exp $ +# RCS: @(#) $Id: ctext.tcl,v 1.3 2004/08/18 03:45:18 andreas_kupries Exp $ package require Tk package provide ctext 3.1 diff --git a/modules/ico/ico.man b/modules/ico/ico.man index e2bf5cf7..8981be77 100644 --- a/modules/ico/ico.man +++ b/modules/ico/ico.man @@ -69,9 +69,9 @@ existing icon. [arg_def integer depth in] -This argument must have a value of [const 1], [const 4], [const 8], [const 24], or [const 32]. If [arg data] -has more colors than the color depth allows an error will be -generated. +This argument must have a value of [const 1], [const 4], [const 8], +[const 24], or [const 32]. If [arg data] has more colors than the +color depth allows an error will be generated. [arg_def options data in] @@ -104,7 +104,7 @@ Copies the icon at [arg index] in [arg file] to [arg index2] in [arg file2]. [call [cmd ::ico::EXEtoICO] [arg file] [arg file2]] -Extracts all icons from the executable [arg file] to the ICO file [arg file2] +Extracts all icons from the executable [arg file] to the ICO file [arg file2]. [list_begin opt] [opt_def -type fileFormat] @@ -161,6 +161,11 @@ There is currently no way to read alpha channel information from 32bpp icons. Tk images do not have an alpha channel so the only way to write a true 32bpp icon is from a color list. writing a 32bpp icon from a Tkimage is identical to writing a 24bpp icon. +[example { + button .explore -image [::ico::getIcon explorer.exe 0 -name explore] + set i [lsearch [::ico::getIconList tclkit.exe] {32 32 8}]] + set colorlist [::ico::getIcon tclkit.exe $i -format colors -type EXE] +}] [keywords entry icon ico exe dll] From a7b2ec7ce6eb4a109924bc80ee4d876e2c19b306 Mon Sep 17 00:00:00 2001 From: Andreas Kupries Date: Wed, 18 Aug 2004 16:51:36 +0000 Subject: [PATCH 0038/1290] * ico.man: Fixed problems with formatting of ico manpage. --- modules/ico/ChangeLog | 4 ++++ modules/ico/ico.man | 7 ++++--- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/modules/ico/ChangeLog b/modules/ico/ChangeLog index e606b5e5..279706cc 100644 --- a/modules/ico/ChangeLog +++ b/modules/ico/ChangeLog @@ -1,3 +1,7 @@ +2004-08-18 Andreas Kupries + + * ico.man: Fixed problems with formatting of ico manpage. + 2004-08-17 Aaron Faupell * ico.tcl: CheckEXE removed and replaced by new SearchForIcos which diff --git a/modules/ico/ico.man b/modules/ico/ico.man index 8981be77..a794f815 100644 --- a/modules/ico/ico.man +++ b/modules/ico/ico.man @@ -148,19 +148,20 @@ icons in [arg file] with information about them. Icons may not be added or removed from file types other than ICO. Icons in these files may only be replaced with icons of the same dimensions and color depth. -[nl] +[para] Icons of 8bpp or lower must include black in the pallete, this means if your icon does not have black in it, you will need to leave a color free so that it may be included by writeIcon. -[nl] +[para] There is currently no way to read alpha channel information from 32bpp icons. -[nl] +[para] Tk images do not have an alpha channel so the only way to write a true 32bpp icon is from a color list. writing a 32bpp icon from a Tkimage is identical to writing a 24bpp icon. +[para] [example { button .explore -image [::ico::getIcon explorer.exe 0 -name explore] set i [lsearch [::ico::getIconList tclkit.exe] {32 32 8}]] From 51f7eeb7b5839b73d36657dc564914f54a9a7514 Mon Sep 17 00:00:00 2001 From: afaupell Date: Wed, 18 Aug 2004 19:23:40 +0000 Subject: [PATCH 0039/1290] 2004-08-18 Aaron Faupell * ico.tcl: added support for reading from BMP files Modified transparentColor to work on pixel list also. * ico.man: updated with the new functionality --- modules/ico/ChangeLog | 6 ++++ modules/ico/ico.man | 7 ++-- modules/ico/ico.tcl | 78 +++++++++++++++++++++++++++++++++++-------- 3 files changed, 75 insertions(+), 16 deletions(-) diff --git a/modules/ico/ChangeLog b/modules/ico/ChangeLog index 279706cc..e41b8011 100644 --- a/modules/ico/ChangeLog +++ b/modules/ico/ChangeLog @@ -1,3 +1,9 @@ +2004-08-18 Aaron Faupell + + * ico.tcl: added support for reading from BMP files + Modified transparentColor to work on pixel list also. + * ico.man: updated with the new functionality + 2004-08-18 Andreas Kupries * ico.man: Fixed problems with formatting of ico manpage. diff --git a/modules/ico/ico.man b/modules/ico/ico.man index a794f815..cfd59207 100644 --- a/modules/ico/ico.man +++ b/modules/ico/ico.man @@ -7,7 +7,7 @@ [description] This package provides functions for reading and writing Windows icons -from ICO, ICL, EXE, and DLL files. +from ICO, EXE, DLL, ICL, and BMP files. [section API] @@ -121,7 +121,10 @@ cache for the specific [opt file] or all files. [call [cmd ::ico::transparentColor] [arg image] [arg color]] -Sets every pixel matching [arg color] in Tk image [arg image] to transparent. +If [arg image] is a single word it is assumed to be the name of a Tk image. +All pixels matching [arg color] in the [arg image] will be set transparent. +Alternatively, [arg image] may be a color list in which case a modified list +is returned. [call [cmd ::ico::Show] [arg file] [opt "[arg option] [arg value]..."]] diff --git a/modules/ico/ico.tcl b/modules/ico/ico.tcl index 7f71e8c1..d45660ee 100644 --- a/modules/ico/ico.tcl +++ b/modules/ico/ico.tcl @@ -5,7 +5,7 @@ # Copyright (c) 2003 Aaron Faupell # Copyright (c) 2003-2004 ActiveState Corporation # -# RCS: @(#) $Id: ico.tcl,v 1.11 2004/08/17 17:36:41 afaupell Exp $ +# RCS: @(#) $Id: ico.tcl,v 1.12 2004/08/18 19:23:40 afaupell Exp $ # JH: speed has been considered in these routines, although they # may not be fully optimized. Running EXEtoICO on explorer.exe, @@ -203,27 +203,40 @@ proc ::ico::copyIcon {f1 i1 f2 i2 args} { # # transparentColor -- # -# Turns on transparency for all pixels in the Tk image that match the color +# Turns on transparency for all pixels in the image that match the color # # ARGS: -# img Name of the Tk image to modify +# img Name of the Tk image to modify, or an image in color list format # color Color in #hex format which will be made transparent # # RETURNS: -# nothing +# the data or image after modification # proc ::ico::transparentColor {img color} { - package require Tk - if {[string match "#*" $color]} { - set color [scan $color "#%2x%2x%2x"] - } - set w [image width $img] - set h [image height $img] - for {set y 0} {$y < $h} {incr y} { - for {set x 0} {$x < $w} {incr x} { - if {[$img get $x $y] eq $color} {$img transparency set $x $y 1} - } + if {[llength $img] == 1} { + package require Tk + if {[string match "#*" $color]} { + set color [scan $color "#%2x%2x%2x"] + } + set w [image width $img] + set h [image height $img] + for {set y 0} {$y < $h} {incr y} { + for {set x 0} {$x < $w} {incr x} { + if {[$img get $x $y] eq $color} {$img transparency set $x $y 1} + } + } + } else { + set y 0 + foreach row $img { + set x 0 + foreach px $row { + if {$px == $color} {lset img $y $x {}} + incr x + } + incr y + } } + return $img } # @@ -730,6 +743,15 @@ proc ::ico::getIconListICODATA {data} { return $r } +proc ::ico::getIconListBMP {file} { + set fh [open $file] + if {[read $fh 2] != "BM"} { close $fh; return -code error "not a BMP file" } + seek $fh 14 start + binary scan [read $fh 16] x4iix2s w h bpp + close $fh + return [list $w $h $bpp] +} + # returns an icon in the form: # {width height depth palette xor_mask and_mask} proc ::ico::getRawIconDataICO {file index} { @@ -856,6 +878,34 @@ proc ::ico::writeIconICO {file index w h bpp palette xor and} { close $fh } +# returns an icon in the form: +# {width height depth palette xor_mask and_mask} +proc ::ico::getRawIconDataBMP {file {index {}}} { + set fh [open $file] + if {[read $fh 2] != "BM"} { close $fh; return -code error "not a BMP file" } + seek $fh 14 start + binary scan [read $fh 16] x4iix2s w h bpp + seek $fh 24 current + + set palette [list] + if {$bpp == 1 || $bpp == 4 || $bpp == 8} { + set colors [read $fh [expr {1 << ($bpp + 2)}]] + foreach {b g r x} [split $colors {}] { + lappend palette [formatColor $r $g $b] + } + } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} { + # do nothing here + } else { + return -code error "unsupported color depth: $bpp" + } + + set xor [read $fh [expr {int(($w * $h) * ($bpp / 8.0))}]] + set and [string repeat 0 [expr {$w * $h}]] + close $fh + + return [list $w $h $bpp $palette $xor $and] +} + # calculate byte size of an icon. # often passed $w twice because $h is double $w in the binary data proc ::ico::calcSize {w h bpp {offset 0}} { From 4c3da49eefb0fde23c39de602125eeeb1584394a Mon Sep 17 00:00:00 2001 From: Jeffrey Hobbs Date: Wed, 18 Aug 2004 20:39:11 +0000 Subject: [PATCH 0040/1290] * as.tcl (style::as::init_misc): add Tree and some Tix widget defs --- modules/style/ChangeLog | 4 ++++ modules/style/as.tcl | 15 +++++++++++++++ 2 files changed, 19 insertions(+) diff --git a/modules/style/ChangeLog b/modules/style/ChangeLog index 139fb4c2..c65727a3 100644 --- a/modules/style/ChangeLog +++ b/modules/style/ChangeLog @@ -1,3 +1,7 @@ +2004-08-18 Jeff Hobbs + + * as.tcl (style::as::init_misc): add Tree and some Tix widget defs + 2004-08-17 Jeff Hobbs * as.tcl: Change style::use to call style::${style}::init diff --git a/modules/style/as.tcl b/modules/style/as.tcl index 974dfa1a..0888407b 100644 --- a/modules/style/as.tcl +++ b/modules/style/as.tcl @@ -238,7 +238,21 @@ proc style::as::CtrlMouseWheel {W X Y D {what local}} { ## proc style::as::init_misc {args} { variable prio + variable highlightbg + variable highlightfg + variable bg + variable fg option add *ScrolledWindow.ipad 0 $prio + + # Various other common widgets from popular widget sets + foreach class {HList Tree Tree.c TixHList TixTree} { + option add *$class.borderWidth 1 $prio + option add *$class.background $bg $prio + option add *$class.foreground $fg $prio + option add *$class.selectBorderWidth 0 $prio + option add *$class.selectForeground $highlightfg $prio + option add *$class.selectBackground $highlightbg $prio + } } ## Listbox @@ -267,6 +281,7 @@ proc style::as::init_button {args} { option add *Button.padX 1 $prio option add *Button.padY 2 $prio } + option add *Button.highlightThickness 1 $prio } ## Entry From a8972835f3595c751bab48e34e8dea833c83a32a Mon Sep 17 00:00:00 2001 From: Arjen Markus Date: Thu, 19 Aug 2004 07:14:12 +0000 Subject: [PATCH 0041/1290] Integrated proposed changes by Stefan Finzel (see ChangeLog) --- modules/plotchart/ChangeLog | 6 ++ modules/plotchart/plotchart.man | 17 ++++ modules/plotchart/plotchart.tcl | 34 +++++++ modules/plotchart/plotpriv.tcl | 174 ++++++++++++++++++++++++-------- 4 files changed, 188 insertions(+), 43 deletions(-) diff --git a/modules/plotchart/ChangeLog b/modules/plotchart/ChangeLog index 200da399..fd4748e0 100644 --- a/modules/plotchart/ChangeLog +++ b/modules/plotchart/ChangeLog @@ -1,3 +1,9 @@ +2004-08-19 Arjen Markus + + * Added modifications by Stefan Finzel. + * One public procedure added: pixelToIndex (by Stefan Finzel) + * Added export of several described (public) procedures that were missing + 2004-04-15 Andreas Kupries * New module 'plotchart', by Arjen Markus. diff --git a/modules/plotchart/plotchart.man b/modules/plotchart/plotchart.man index a0b1fd56..ee85d22e 100755 --- a/modules/plotchart/plotchart.man +++ b/modules/plotchart/plotchart.man @@ -975,6 +975,23 @@ X-pixel to be mapped. [arg_def float y in] Y-pixel to be mapped. +[list_end] + +[call [cmd ::Plotchart::pixelToIndex] [arg w] [arg x] [arg y]] + +Return the index of the pie segment containing the pixel coordinates +(x,y) + +[list_begin arg] +[arg_def widget w in] +Name of the window (canvas widget) in question, holding a piechart. + +[arg_def float x in] +X-pixel to be mapped. + +[arg_def float y in] +Y-pixel to be mapped. + [list_end] [list_end] [para] diff --git a/modules/plotchart/plotchart.tcl b/modules/plotchart/plotchart.tcl index 491fed84..f93d3304 100755 --- a/modules/plotchart/plotchart.tcl +++ b/modules/plotchart/plotchart.tcl @@ -16,6 +16,9 @@ namespace eval ::Plotchart { namespace export worldCoordinates viewPort coordsToPixel \ polarCoordinates setZoomPan \ + world3DCoordinates coordsToPixel \ + coords3DToPixel polarToPixel \ + pixelToCoords pixelToIndex determineScale \ createXYPlot createPolarPlot createPiechart \ createBarchart createHorizontalBarchart \ createTimechart createStripchart \ @@ -347,6 +350,37 @@ proc ::Plotchart::pixelToCoords { w xpix ypix } { return [list $xcrd $ycrd] } +# pixelToIndex -- +# Convert pixel coordinates to elements list index +# Arguments: +# w Name of the canvas +# xpix X-coordinate (pixel) +# ypix Y-coordinate (pixel) +# Result: +# Elements list index +# +proc ::Plotchart::pixelToIndex { w xpix ypix } { + variable scaling + variable torad + + set idx -1 + set radius [expr {($scaling(${w},pxmax) - $scaling(${w},pxmin)) / 2}] + set xrel [expr {${xpix} - $scaling(${w},pxmin) - ${radius}}] + set yrel [expr {-${ypix} + $scaling(${w},pymin) + ${radius}}] + if {[expr {pow(${radius},2) < (pow(${xrel},2) + pow(${yrel},2))}]} { + # do nothing out of pie chart + } elseif {[info exists scaling(${w},angles)]} { + set xy_angle [expr {(360 + round(atan2(${yrel},${xrel})/${torad})) % 360}] + foreach angle $scaling(${w},angles) { + if {${xy_angle} <= ${angle}} { + break + } + incr idx + } + } + return ${idx} +} + # polarToPixel -- # Convert polar coordinates to pixel coordinates # Arguments: diff --git a/modules/plotchart/plotpriv.tcl b/modules/plotchart/plotpriv.tcl index 957a5bf7..3842e8db 100755 --- a/modules/plotchart/plotpriv.tcl +++ b/modules/plotchart/plotpriv.tcl @@ -122,6 +122,41 @@ proc ::Plotchart::SetColours { w args } { set scaling($w,colours) $args } +# CycleColours -- +# create cycling colours for those plots that treat them as a global resource +# Arguments: +# colours List of colours to be used. An empty list will activate to default colours +# nr_data Number of data records +# Result: +# List of 'nr_data' colours to be used +# +proc ::Plotchart::CycleColours { colours nr_data } { + if {![llength ${colours}]} { + # force to most usable default colour list + set colours {green blue red cyan yellow magenta} + } + + if {[llength ${colours}] < ${nr_data}} { + # cycle through colours + set init_colours ${colours} + set colours {} + set pos 0 + for {set nr 0} {${nr} < ${nr_data}} {incr nr} { + lappend colours [lindex ${init_colours} ${pos}] + incr pos + if {[llength ${init_colours}] <= ${pos}} { + set pos 0 + } + } + if {[string equal [lindex ${colours} 0] [lindex ${colours} end]]} { + # keep first and last colour different from selected colours + # this will /sometimes fail in cases with only one/two colours in list + set colours [lreplace ${colours} end end [lindex ${colours} 1]] + } + } + return ${colours} +} + # DataConfig -- # Configure the data series # Arguments: @@ -440,49 +475,70 @@ proc ::Plotchart::DrawPie { w data } { set pxmax $scaling($w,pxmax) set pymax $scaling($w,pymax) - # - # Determine the scale for the values - # (so we can draw the correct angles) - # - set sum 0.0 - foreach {label value} $data { - set sum [expr {$sum + $value}] - } - set factor [expr {360.0/$sum}] - - # - # Draw the line piece - # - set angle_bgn 0.0 - set angle_ext 0.0 - set sum 0.0 - - set colours $scaling($w,colours) - - set idx 0 - foreach {label value} $data { - set colour [lindex $colours $idx] - incr idx - - set angle_bgn [expr {$sum * $factor}] - set angle_ext [expr {$value * $factor}] - - $w create arc $pxmin $pymin $pxmax $pymax \ - -start $angle_bgn -extent $angle_ext \ - -fill $colour -style pieslice - - set rad [expr {($angle_bgn+0.5*$angle_ext)*3.1415926/180.0}] - set xtext [expr {($pxmin+$pxmax+cos($rad)*($pxmax-$pxmin+20))/2}] - set ytext [expr {($pymin+$pymax-sin($rad)*($pymax-$pymin+20))/2}] - if { $xtext > ($pxmin+$pymax)/2 } { - set dir w - } else { - set dir e - } - - $w create text $xtext $ytext -text $label -anchor $dir - - set sum [expr {$sum + $value}] + set colours $scaling(${w},colours) + + if {[llength ${data}] == 2} { + # use canvas create oval as arc does not fill with colour for a full circle + set colour [lindex ${colours} 0] + ${w} create oval ${pxmin} ${pymin} ${pxmax} ${pymax} -fill ${colour} + # text looks nicer at 45 degree + set rad [expr {45.0 * 3.1415926 / 180.0}] + set xtext [expr {(${pxmin}+${pxmax}+cos(${rad})*(${pxmax}-${pxmin}+20))/2}] + set ytext [expr {(${pymin}+${pymax}-sin(${rad})*(${pymax}-${pymin}+20))/2}] + foreach {label value} ${data} { + break + } + ${w} create text ${xtext} ${ytext} -text ${label} -anchor w + set scaling($w,angles) {0 360} + } else { + # + # Determine the scale for the values + # (so we can draw the correct angles) + # + + set sum 0.0 + foreach {label value} $data { + set sum [expr {$sum + $value}] + } + set factor [expr {360.0/$sum}] + + # + # Draw the line piece + # + set angle_bgn 0.0 + set angle_ext 0.0 + set sum 0.0 + + set idx 0 + + unset -nocomplain scaling(${w},angles) + set colours [CycleColours ${colours} [expr {[llength ${data}] / 2}]] + + foreach {label value} $data { + set colour [lindex $colours $idx] + incr idx + + set angle_bgn [expr {$sum * $factor}] + set angle_ext [expr {$value * $factor}] + lappend scaling(${w},angles) [expr {int(${angle_bgn})}] + + $w create arc $pxmin $pymin $pxmax $pymax \ + -start $angle_bgn -extent $angle_ext \ + -fill $colour -style pieslice + + set rad [expr {($angle_bgn+0.5*$angle_ext)*3.1415926/180.0}] + set xtext [expr {($pxmin+$pxmax+cos($rad)*($pxmax-$pxmin+20))/2}] + set ytext [expr {($pymin+$pymax-sin($rad)*($pymax-$pymin+20))/2}] + if { $xtext > ($pxmin+$pymax)/2 } { + set dir w + } else { + set dir e + } + + $w create text $xtext $ytext -text $label -anchor $dir + + set sum [expr {$sum + $value}] + } } } @@ -526,10 +582,26 @@ proc ::Plotchart::DrawVertBarData { w series ydata {colour black}} { # Draw the bars # set x $scaling($w,xbase) + + # + # set the colours + # + if {[llength ${colour}]} { + set colours ${colour} + } elseif {[info exists scaling(${w},colours)]} { + set colours $scaling(${w},colours) + } else { + set colours {} + } + set colours [CycleColours ${colours} [llength ${ydata}]] set newbase {} + set idx 0 foreach yvalue $ydata ybase $scaling($w,ybase) { + set colour [lindex ${colours} ${idx}] + incr idx + set xnext [expr {$x+$scaling($w,barwidth)}] set y [expr {$yvalue+$ybase}] foreach {px1 py1} [coordsToPixel $w $x $ybase] {break} @@ -574,9 +646,25 @@ proc ::Plotchart::DrawHorizBarData { w series xdata {colour black}} { # set y $scaling($w,ybase) + # + # set the colours + # + if {[llength ${colour}]} { + set colours ${colour} + } elseif {[info exists scaling(${w},colours)]} { + set colours $scaling(${w},colours) + } else { + set colours {} + } + set colours [CycleColours ${colours} [llength ${xdata}]] + set newbase {} + set idx 0 foreach xvalue $xdata xbase $scaling($w,xbase) { + set colour [lindex ${colours} ${idx}] + incr idx + set ynext [expr {$y+$scaling($w,barwidth)}] set x [expr {$xvalue+$xbase}] foreach {px1 py1} [coordsToPixel $w $xbase $y ] {break} From 644e0684923fcf5bcad1c3eb9710cd788c2e3d44 Mon Sep 17 00:00:00 2001 From: Andreas Kupries Date: Fri, 20 Aug 2004 04:41:10 +0000 Subject: [PATCH 0042/1290] Manpage merge Import Jeff's changes to style. Import plotchart changes by Arjen. Import ico changes by Aaron. Manpage merge. --- modules/ico/ico.man | 1 - 1 file changed, 1 deletion(-) diff --git a/modules/ico/ico.man b/modules/ico/ico.man index cfd59207..f3560a49 100644 --- a/modules/ico/ico.man +++ b/modules/ico/ico.man @@ -171,7 +171,6 @@ a color list. writing a 32bpp icon from a Tkimage is identical to writing a 24bp set colorlist [::ico::getIcon tclkit.exe $i -format colors -type EXE] }] - [keywords entry icon ico exe dll] [manpage_end] From 9c69217fcec2438c22bf3cfd9e43e8aa38809d9e Mon Sep 17 00:00:00 2001 From: afaupell Date: Sat, 21 Aug 2004 00:15:14 +0000 Subject: [PATCH 0043/1290] 2004-08-20 Aaron Faupell * ico.tcl: added writing of BMP and ICODATA types. --- modules/ico/ChangeLog | 4 + modules/ico/ico.tcl | 199 ++++++++++++++++++++++++------------------ 2 files changed, 116 insertions(+), 87 deletions(-) diff --git a/modules/ico/ChangeLog b/modules/ico/ChangeLog index e41b8011..95284812 100644 --- a/modules/ico/ChangeLog +++ b/modules/ico/ChangeLog @@ -1,3 +1,7 @@ +2004-08-20 Aaron Faupell + + * ico.tcl: added writing of BMP and ICODATA types. + 2004-08-18 Aaron Faupell * ico.tcl: added support for reading from BMP files diff --git a/modules/ico/ico.tcl b/modules/ico/ico.tcl index d45660ee..dc89ea56 100644 --- a/modules/ico/ico.tcl +++ b/modules/ico/ico.tcl @@ -5,7 +5,7 @@ # Copyright (c) 2003 Aaron Faupell # Copyright (c) 2003-2004 ActiveState Corporation # -# RCS: @(#) $Id: ico.tcl,v 1.12 2004/08/18 19:23:40 afaupell Exp $ +# RCS: @(#) $Id: ico.tcl,v 1.13 2004/08/21 00:15:14 afaupell Exp $ # JH: speed has been considered in these routines, although they # may not be fully optimized. Running EXEtoICO on explorer.exe, @@ -610,6 +610,15 @@ proc ::ico::getPaletteFromColors {colors} { return [list $i $palette $new] } +# calculate byte size of an icon. +# often passed $w twice because $h is double $w in the binary data +proc ::ico::calcSize {w h bpp {offset 0}} { + set s [expr {int(($w*$h) * ($bpp/8.0)) \ + + ((($w*$h) + ($h*($w%32)))/8) + $offset}] + if {$bpp <= 8} { set s [expr {$s + (1 << ($bpp + 2))}] } + return $s +} + # read a Device Independent Bitmap from the current offset, return: # {width height depth palette XOR_mask AND_mask} proc ::ico::readDIB {fh} { @@ -752,6 +761,20 @@ proc ::ico::getIconListBMP {file} { return [list $w $h $bpp] } +proc ::ico::getIconListEXE {file} { + variable ICONS + + set file [file normalize $file] + set cnt [SearchForIcos $file] + + set icons [list] + for {set i 0} {$i <= $cnt} {incr i} { + lappend icons $ICONS($file,$i,data) + } + + return $icons +} + # returns an icon in the form: # {width height depth palette xor_mask and_mask} proc ::ico::getRawIconDataICO {file index} { @@ -794,6 +817,55 @@ proc ::ico::getRawIconDataICODATA {data index} { return $dib } +# returns an icon in the form: +# {width height depth palette xor_mask and_mask} +proc ::ico::getRawIconDataBMP {file {index 0}} { + if {$index != 0} {return -code error "index out of range"} + set fh [open $file] + if {[read $fh 2] != "BM"} { close $fh; return -code error "not a BMP file" } + seek $fh 14 start + binary scan [read $fh 16] x4iix2s w h bpp + seek $fh 24 current + + set palette [list] + if {$bpp == 1 || $bpp == 4 || $bpp == 8} { + set colors [read $fh [expr {1 << ($bpp + 2)}]] + foreach {b g r x} [split $colors {}] { + lappend palette [formatColor $r $g $b] + } + } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} { + # do nothing here + } else { + return -code error "unsupported color depth: $bpp" + } + + set xor [read $fh [expr {int(($w * $h) * ($bpp / 8.0))}]] + set and [string repeat 0 [expr {$w * $h}]] + close $fh + + return [list $w $h $bpp $palette $xor $and] +} + +# returns an icon in the form: +# {width height depth palette xor_mask and_mask} +proc ::ico::getRawIconDataEXE {file index} { + variable ICONS + + set file [file normalize $file] + set cnt [SearchForIcos $file $index] + + if {$cnt < $index} { return -code error "index out of range" } + + set fh [open $file] + fconfigure $fh -eofchar {} -encoding binary -translation lf + seek $fh $ICONS($file,$index) start + + # readDIB returns: {w h bpp palette xor and} + set dib [readDIB $fh] + close $fh + return $dib +} + proc ::ico::writeIconICO {file index w h bpp palette xor and} { if {![file exists $file]} { set fh [open $file w+] @@ -878,41 +950,49 @@ proc ::ico::writeIconICO {file index w h bpp palette xor and} { close $fh } -# returns an icon in the form: -# {width height depth palette xor_mask and_mask} -proc ::ico::getRawIconDataBMP {file {index {}}} { - set fh [open $file] - if {[read $fh 2] != "BM"} { close $fh; return -code error "not a BMP file" } - seek $fh 14 start - binary scan [read $fh 16] x4iix2s w h bpp - seek $fh 24 current - - set palette [list] - if {$bpp == 1 || $bpp == 4 || $bpp == 8} { - set colors [read $fh [expr {1 << ($bpp + 2)}]] - foreach {b g r x} [split $colors {}] { - lappend palette [formatColor $r $g $b] - } - } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} { - # do nothing here - } else { - return -code error "unsupported color depth: $bpp" - } +proc ::ico::writeIconICODATA {file index w h bpp palette xor and} { + if {$index != 0} {return -code error "index out of range"} + upvar 2 [file tail $file] data + set data [binary format sss 0 1 1] + set colors 0 + if {$bpp <= 8} {set colors [expr {1 << $bpp}]} + set size [expr {[string length $palette] + [string length $xor] + [string length $and]}] + append data [binary format ccccssii $w $h $colors 0 0 $bpp [expr {$size + 40}] 22] + append data [binary format iiissiiiiii 40 $w [expr {$h * 2}] 1 $bpp 0 $size 0 0 0 0] + append data $palette $xor $and +} - set xor [read $fh [expr {int(($w * $h) * ($bpp / 8.0))}]] - set and [string repeat 0 [expr {$w * $h}]] +proc ::ico::writeIconBMP {file index w h bpp palette xor and} { + if {$index != 0} {return -code error "index out of range"} + set fh [open $file w+] + fconfigure $fh -eofchar {} -encoding binary -translation lf + set size [expr {[string length $palette] + [string length $xor]}] + # bitmap header: magic, file size, reserved, reserved, offset of bitmap data + bputs $fh a2issi BM [expr {14 + 40 + $size}] 0 0 54 + bputs $fh iiissiiiiii 40 $w $h 1 $bpp 0 $size 0 0 0 0 + puts -nonewline $fh $palette$xor close $fh - - return [list $w $h $bpp $palette $xor $and] } -# calculate byte size of an icon. -# often passed $w twice because $h is double $w in the binary data -proc ::ico::calcSize {w h bpp {offset 0}} { - set s [expr {int(($w*$h) * ($bpp/8.0)) \ - + ((($w*$h) + ($h*($w%32)))/8) + $offset}] - if {$bpp <= 8} { set s [expr {$s + (1 << ($bpp + 2))}] } - return $s +proc ::ico::writeIconEXE {file index w h bpp palette xor and} { + variable ICONS + + set file [file normalize $file] + set cnt [SearchForIcos $file $fh $index] + + if {$index eq "end"} {set index $cnt} + if {$cnt < $index} { return -code error "index out of range" } + + if {[list $w $h $bpp] != $ICONS($file,$index,data)} { + return -code error "icon format differs from original" + } + + set fh [open $file r+] + fconfigure $fh -eofchar {} -encoding binary -translation lf + seek $fh [expr {$ICONS($file,$index) + 40}] start + + puts -nonewline $fh $palette$xor$and + close $fh } proc ::ico::SearchForIcos {file {index -1}} { @@ -1035,61 +1115,6 @@ proc ::ico::SearchForIcosPE {fh file index} { return -1 } -proc ::ico::getIconListEXE {file} { - variable ICONS - - set file [file normalize $file] - set cnt [SearchForIcos $file] - - set icons [list] - for {set i 0} {$i <= $cnt} {incr i} { - lappend icons $ICONS($file,$i,data) - } - - return $icons -} - -# returns an icon in the form: -# {width height depth palette xor_mask and_mask} -proc ::ico::getRawIconDataEXE {file index} { - variable ICONS - - set file [file normalize $file] - set cnt [SearchForIcos $file $index] - - if {$cnt < $index} { return -code error "index out of range" } - - set fh [open $file] - fconfigure $fh -eofchar {} -encoding binary -translation lf - seek $fh $ICONS($file,$index) start - - # readDIB returns: {w h bpp palette xor and} - set dib [readDIB $fh] - close $fh - return $dib -} - -proc ::ico::writeIconEXE {file index w h bpp palette xor and} { - variable ICONS - - set file [file normalize $file] - set cnt [SearchForIcos $file $fh $index] - - if {$index eq "end"} {set index $cnt} - if {$cnt < $index} { return -code error "index out of range" } - - if {[list $w $h $bpp] != $ICONS($file,$index,data)} { - return -code error "icon format differs from original" - } - - set fh [open $file r+] - fconfigure $fh -eofchar {} -encoding binary -translation lf - seek $fh [expr {$ICONS($file,$index) + 40}] start - - puts -nonewline $fh $palette$xor$and - close $fh -} - interp alias {} ::ico::getIconListDLL {} ::ico::getIconListEXE interp alias {} ::ico::getRawIconDataDLL {} ::ico::getRawIconDataEXE interp alias {} ::ico::writeIconDLL {} ::ico::writeIconEXE From 9f55f5c48c29987645764a26b4f1c7a799637455 Mon Sep 17 00:00:00 2001 From: Jeffrey Hobbs Date: Mon, 6 Sep 2004 19:40:15 +0000 Subject: [PATCH 0044/1290] create ASfontFixedBold --- modules/style/ChangeLog | 4 ++++ modules/style/as.tcl | 3 +++ 2 files changed, 7 insertions(+) diff --git a/modules/style/ChangeLog b/modules/style/ChangeLog index c65727a3..6888e71e 100644 --- a/modules/style/ChangeLog +++ b/modules/style/ChangeLog @@ -1,3 +1,7 @@ +2004-09-06 Jeff Hobbs + + * as.tcl (style::as::init_fonts): create ASfontFixedBold + 2004-08-18 Jeff Hobbs * as.tcl (style::as::init_misc): add Tree and some Tix widget defs diff --git a/modules/style/as.tcl b/modules/style/as.tcl index 0888407b..eb67a85d 100644 --- a/modules/style/as.tcl +++ b/modules/style/as.tcl @@ -150,12 +150,15 @@ proc style::as::init_fonts {args} { font create ASfont -size $size -family $family font create ASfontBold -size $size -family $family -weight bold font create ASfontFixed -size $fsize -family $ffamily + font create ASfontFixedBold -size $fsize -family $ffamily -weight bold for {set i -2} {$i <= 4} {incr i} { set isize [expr {$size + ($i * (($size > 0) ? 1 : -1))}] set ifsize [expr {$fsize + ($i * (($fsize > 0) ? 1 : -1))}] font create ASfont$i -size $isize -family $family font create ASfontBold$i -size $isize -family $family -weight bold font create ASfontFixed$i -size $ifsize -family $ffamily + font create ASfontFixedBold$i \ + -size $fsize -family $ffamily -weight bold } } From 1f8f668b00a6943ed20afcd7931b299697615b47 Mon Sep 17 00:00:00 2001 From: Jeffrey Hobbs Date: Fri, 10 Sep 2004 05:11:55 +0000 Subject: [PATCH 0045/1290] * as.tcl: use system colors on Windows for highlightbg, highlightfg, bg and fg defaults --- modules/style/ChangeLog | 5 +++++ modules/style/as.tcl | 8 ++++++++ 2 files changed, 13 insertions(+) diff --git a/modules/style/ChangeLog b/modules/style/ChangeLog index 6888e71e..54fe2468 100644 --- a/modules/style/ChangeLog +++ b/modules/style/ChangeLog @@ -1,3 +1,8 @@ +2004-09-09 Jeff Hobbs + + * as.tcl: use system colors on Windows for highlightbg, + highlightfg, bg and fg defaults + 2004-09-06 Jeff Hobbs * as.tcl (style::as::init_fonts): create ASfontFixedBold diff --git a/modules/style/as.tcl b/modules/style/as.tcl index eb67a85d..1daeb3fa 100644 --- a/modules/style/as.tcl +++ b/modules/style/as.tcl @@ -18,6 +18,14 @@ namespace eval style::as { variable highlightfg "white" ; # SystemHighlightText variable bg "white" ; # SystemWindow variable fg "black" ; # SystemWindowText + if {[string equal $::tcl_platform(platform) "windows"]} { + # Use the system colors on Windows, as they can adapt + # to the user's personal color scheme + set highlightbg "SystemHighlight" + set highlightfg "SystemHighlightText" + set bg "SystemWindow" + set fg "SystemWindowText" + } # This may need to be adjusted for some window managers that are # more aggressive with their own Xdefaults (like KDE and CDE) From c19e2661d9b9ffc37c2ec00c67eef96427035987 Mon Sep 17 00:00:00 2001 From: afaupell Date: Mon, 27 Sep 2004 20:48:04 +0000 Subject: [PATCH 0046/1290] aron Faupell * ico.tcl bugfix in writeIconEXE, called SearchForIcos with wrong args --- modules/ico/ChangeLog | 5 +++++ modules/ico/ico.tcl | 4 ++-- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/modules/ico/ChangeLog b/modules/ico/ChangeLog index 95284812..1e7bba68 100644 --- a/modules/ico/ChangeLog +++ b/modules/ico/ChangeLog @@ -1,3 +1,8 @@ +2004-08-20 Aaron Faupell + + * ico.tcl bugfix in writeIconEXE, called SearchForIcos + with wrong args + 2004-08-20 Aaron Faupell * ico.tcl: added writing of BMP and ICODATA types. diff --git a/modules/ico/ico.tcl b/modules/ico/ico.tcl index dc89ea56..1326e0f7 100644 --- a/modules/ico/ico.tcl +++ b/modules/ico/ico.tcl @@ -5,7 +5,7 @@ # Copyright (c) 2003 Aaron Faupell # Copyright (c) 2003-2004 ActiveState Corporation # -# RCS: @(#) $Id: ico.tcl,v 1.13 2004/08/21 00:15:14 afaupell Exp $ +# RCS: @(#) $Id: ico.tcl,v 1.14 2004/09/27 20:48:04 afaupell Exp $ # JH: speed has been considered in these routines, although they # may not be fully optimized. Running EXEtoICO on explorer.exe, @@ -978,7 +978,7 @@ proc ::ico::writeIconEXE {file index w h bpp palette xor and} { variable ICONS set file [file normalize $file] - set cnt [SearchForIcos $file $fh $index] + set cnt [SearchForIcos $file $index] if {$index eq "end"} {set index $cnt} if {$cnt < $index} { return -code error "index out of range" } From 43da8d75a2ab3a69cb7f3ee7052d85be5674802f Mon Sep 17 00:00:00 2001 From: Arjen Markus Date: Wed, 29 Sep 2004 11:21:25 +0000 Subject: [PATCH 0047/1290] Fixed bug 1035281 - scaling: a factor "$factor" was missing. Also changed the "unset -nocomplain" in plotpriv.tcl to "array unset" - Tcl 8.3 becomes acceptable now --- modules/plotchart/plotchart.test | 4 ++++ modules/plotchart/plotpriv.tcl | 2 +- modules/plotchart/scaling.tcl | 5 +++-- 3 files changed, 8 insertions(+), 3 deletions(-) diff --git a/modules/plotchart/plotchart.test b/modules/plotchart/plotchart.test index 520cb94d..34bda341 100755 --- a/modules/plotchart/plotchart.test +++ b/modules/plotchart/plotchart.test @@ -147,6 +147,10 @@ test Plotchart-2.10 {Nice scale 7} -match numbers -body { ::Plotchart::determineScale 10001 10015 } -result {10000 10015 5} +test Plotchart-2.11 {Nice scale 8} -match numbers -body { + ::Plotchart::determineScale -1.7 26.8 +} -result {-10.0 30.0 10.0} + diff --git a/modules/plotchart/plotpriv.tcl b/modules/plotchart/plotpriv.tcl index 3842e8db..e62db156 100755 --- a/modules/plotchart/plotpriv.tcl +++ b/modules/plotchart/plotpriv.tcl @@ -511,7 +511,7 @@ proc ::Plotchart::DrawPie { w data } { set idx 0 - unset -nocomplain scaling(${w},angles) + array unset scaling ${w},angles set colours [CycleColours ${colours} [expr {[llength ${data}] / 2}]] foreach {label value} $data { diff --git a/modules/plotchart/scaling.tcl b/modules/plotchart/scaling.tcl index f43bb5fa..04365a6f 100755 --- a/modules/plotchart/scaling.tcl +++ b/modules/plotchart/scaling.tcl @@ -64,11 +64,12 @@ proc ::Plotchart::determineScale { xmin xmax } { set nicemin [expr {$step*$factor*int($xmin/$factor/$step)}] set nicemax [expr {$step*$factor*int($xmax/$factor/$step)}] + if { [tlt $nicemax $xmax] } { - set nicemax [expr {$nicemax+$step}] + set nicemax [expr {$nicemax+$step*$factor}] } if { [tgt $nicemin $xmin] } { - set nicemin [expr {$nicemin-$step}] + set nicemin [expr {$nicemin-$step*$factor}] } return [list $nicemin $nicemax [expr {$step*$factor}]] From c1e595d41bc948bbbb0c5ff6c245bfd2a0cb48a2 Mon Sep 17 00:00:00 2001 From: Arjen Markus Date: Wed, 29 Sep 2004 11:23:36 +0000 Subject: [PATCH 0048/1290] Updated the ChangeLog file --- modules/plotchart/ChangeLog | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/modules/plotchart/ChangeLog b/modules/plotchart/ChangeLog index fd4748e0..e978af9a 100644 --- a/modules/plotchart/ChangeLog +++ b/modules/plotchart/ChangeLog @@ -1,3 +1,10 @@ +2004-09-29 Arjen Markus + + * Fixed bug 1035281 - wrong scaling for -1.7 -- 26.8 + (new test case) + * Fixed dependency on -nocomplain flag for unset (plotpriv.tcl) + Plotchart should work with Tcl 8.3 now + 2004-08-19 Arjen Markus * Added modifications by Stefan Finzel. From 808d2619fa2c4bf2516c86e0180d5ea97549cc15 Mon Sep 17 00:00:00 2001 From: Arjen Markus Date: Thu, 30 Sep 2004 08:04:58 +0000 Subject: [PATCH 0049/1290] Solved a rounding problem with label 0.0 when drawing axes (bug 1035281) --- modules/plotchart/plotaxis.tcl | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/modules/plotchart/plotaxis.tcl b/modules/plotchart/plotaxis.tcl index fe9c1ebc..439c4b49 100755 --- a/modules/plotchart/plotaxis.tcl +++ b/modules/plotchart/plotaxis.tcl @@ -43,6 +43,9 @@ proc ::Plotchart::DrawYaxis { w ymin ymax ydelt } { } $w create text $xcrd $ycrd -text $ylabel -tag yaxis -anchor e set y [expr {$y+$ydelt}] + if { abs($y) < 0.5*$ydelt } { + set y 0.0 + } } } @@ -84,6 +87,9 @@ proc ::Plotchart::DrawXaxis { w xmin xmax xdelt } { } $w create text $xcrd $ycrd -text $xlabel -tag xaxis -anchor n set x [expr {$x+$xdelt}] + if { abs($x) < 0.5*$xdelt } { + set x 0.0 + } } set scaling($w,xdelt) $xdelt From 9757a2cc7ec8adcd9d571984adc6188ded2cb9be Mon Sep 17 00:00:00 2001 From: mgbacke Date: Mon, 10 Jan 2005 06:19:18 +0000 Subject: [PATCH 0050/1290] ::ipentry::ipentry was not returning --- modules/ipentry/ipentry.tcl | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/modules/ipentry/ipentry.tcl b/modules/ipentry/ipentry.tcl index 4e4eac63..20986b3c 100644 --- a/modules/ipentry/ipentry.tcl +++ b/modules/ipentry/ipentry.tcl @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: ipentry.tcl,v 1.3 2003/08/02 21:01:39 afaupell Exp $ +# RCS: @(#) $Id: ipentry.tcl,v 1.4 2005/01/10 06:19:18 mgbacke Exp $ package provide ipentry 0.1 @@ -46,6 +46,7 @@ proc ::ipentry::ipentry {w args} { if {[llength $args] > 0} { eval [list $w configure] $args } + return $w } proc ::ipentry::keypress {w key} { From 173ddb54e279b4b141388768712b35c18c345ea9 Mon Sep 17 00:00:00 2001 From: mgbacke Date: Mon, 10 Jan 2005 06:21:33 +0000 Subject: [PATCH 0051/1290] *** empty log message *** --- ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ChangeLog b/ChangeLog index f04d02e0..4c131f4a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2005-01-09 Marty Backe + + * modules/ipentry/ipentry.tcl: Bug fix - widget creation was not + returning the widget name. + 2004-07-22 Jeff Hobbs * installed_modules.tcl: added ico to list of installed modules. From b5acf2697dba453114cb7e20d1b61adf92043ad6 Mon Sep 17 00:00:00 2001 From: Andreas Kupries Date: Mon, 10 Jan 2005 19:48:45 +0000 Subject: [PATCH 0052/1290] Moved the information about the ipentry change from the global to the module specific ChangeLog. --- ChangeLog | 5 ----- modules/ipentry/ChangeLog | 13 ++++++++++--- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/ChangeLog b/ChangeLog index 4c131f4a..f04d02e0 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,8 +1,3 @@ -2005-01-09 Marty Backe - - * modules/ipentry/ipentry.tcl: Bug fix - widget creation was not - returning the widget name. - 2004-07-22 Jeff Hobbs * installed_modules.tcl: added ico to list of installed modules. diff --git a/modules/ipentry/ChangeLog b/modules/ipentry/ChangeLog index 582f1f34..3a0eef50 100644 --- a/modules/ipentry/ChangeLog +++ b/modules/ipentry/ChangeLog @@ -1,8 +1,15 @@ +2005-01-09 Marty Backe + + * ipentry.tcl: Bug fix - widget creation was not returning the + widget name. + 2003-08-02 Aaron Faupell - ipentry.tcl: added highlightcolor, highlightbackground, highlightthickness options - ipentry.man: added docs for above, as well as disabledforeground, readonlybackground + * ipentry.tcl: added highlightcolor, highlightbackground, + highlightthickness options + * ipentry.man: added docs for above, as well as + disabledforeground, readonlybackground 2003-07-23 Aaron Faupell - initial import + * initial import From 8b429fb2d9d8864f70e573d3863e5d967f215c46 Mon Sep 17 00:00:00 2001 From: davidw Date: Wed, 2 Feb 2005 15:25:46 +0000 Subject: [PATCH 0053/1290] * lobster.tcl (style::lobster::init): Use nicer fonts for the popup dialogs. --- modules/style/ChangeLog | 5 +++++ modules/style/lobster.tcl | 8 +++++++- 2 files changed, 12 insertions(+), 1 deletion(-) diff --git a/modules/style/ChangeLog b/modules/style/ChangeLog index 54fe2468..5dce0dbb 100644 --- a/modules/style/ChangeLog +++ b/modules/style/ChangeLog @@ -1,3 +1,8 @@ +2005-02-02 David N. Welton + + * lobster.tcl (style::lobster::init): Use nicer fonts for the + popup dialogs. + 2004-09-09 Jeff Hobbs * as.tcl: use system colors on Windows for highlightbg, diff --git a/modules/style/lobster.tcl b/modules/style/lobster.tcl index 98ddbcf5..c7b72d58 100644 --- a/modules/style/lobster.tcl +++ b/modules/style/lobster.tcl @@ -3,7 +3,7 @@ # The code formerly known as "gtklook" on the Tcl'ers # wiki. Most of this code was originally written by Jeremy Collins. -# $Id: lobster.tcl,v 1.4 2004/08/17 19:09:23 hobbs Exp $ +# $Id: lobster.tcl,v 1.5 2005/02/02 15:25:46 davidw Exp $ namespace eval style::lobster { # This may need to be adjusted for some window managers that are @@ -28,6 +28,7 @@ proc style::lobster::init {args} { set size -12 set family Helvetica font create LobsterFont -size $size -family $family + font create LobsterFont -size $size -family $family -weight bold option add *borderWidth 1 $prio option add *activeBorderWidth 1 $prio @@ -76,6 +77,11 @@ proc style::lobster::init {args} { option add *Scrollbar.width 12 $prio option add *Scrollbar.borderWidth 1 $prio option add *Scrollbar.highlightThickness 0 $prio + + # These don't seem to take effect without the startupFile + # level specified. + option add *Dialog.msg.font LobsterBold startupFile + option add *Dialog.dtl.font LobsterBold startupFile } } From 35b890844edd7dc756b4f6164c3351c43281c418 Mon Sep 17 00:00:00 2001 From: davidw Date: Wed, 2 Feb 2005 17:04:12 +0000 Subject: [PATCH 0054/1290] Fixed oops - LobsterFont -> LobsterBold. --- modules/style/lobster.tcl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/modules/style/lobster.tcl b/modules/style/lobster.tcl index c7b72d58..06c81a6a 100644 --- a/modules/style/lobster.tcl +++ b/modules/style/lobster.tcl @@ -3,7 +3,7 @@ # The code formerly known as "gtklook" on the Tcl'ers # wiki. Most of this code was originally written by Jeremy Collins. -# $Id: lobster.tcl,v 1.5 2005/02/02 15:25:46 davidw Exp $ +# $Id: lobster.tcl,v 1.6 2005/02/02 17:04:12 davidw Exp $ namespace eval style::lobster { # This may need to be adjusted for some window managers that are @@ -28,7 +28,7 @@ proc style::lobster::init {args} { set size -12 set family Helvetica font create LobsterFont -size $size -family $family - font create LobsterFont -size $size -family $family -weight bold + font create LobsterBold -size $size -family $family -weight bold option add *borderWidth 1 $prio option add *activeBorderWidth 1 $prio From e08914f8fe151b6020ea1ca7ef951d97bde226f9 Mon Sep 17 00:00:00 2001 From: Arjen Markus Date: Fri, 4 Mar 2005 14:04:40 +0000 Subject: [PATCH 0055/1290] Added contour plotting routines by Mark Stucky --- modules/plotchart/ChangeLog | 5 + modules/plotchart/plotchart.man | 62 +- modules/plotchart/plotchart.tcl | 9 +- modules/plotchart/plotcontour.tcl | 1697 ++++++++++++++++++++++++++++ modules/plotchart/plotcontour.test | 201 ++++ 5 files changed, 1971 insertions(+), 3 deletions(-) create mode 100755 modules/plotchart/plotcontour.tcl create mode 100755 modules/plotchart/plotcontour.test diff --git a/modules/plotchart/ChangeLog b/modules/plotchart/ChangeLog index e978af9a..614065ea 100644 --- a/modules/plotchart/ChangeLog +++ b/modules/plotchart/ChangeLog @@ -1,3 +1,8 @@ +2005-03-04 Arjen Markus + + * Added the contour plotting routines by Mark Stucky + (Documentation for 3D contour plot still missing) + 2004-09-29 Arjen Markus * Fixed bug 1035281 - wrong scaling for -1.7 -- 26.8 diff --git a/modules/plotchart/plotchart.man b/modules/plotchart/plotchart.man index ee85d22e..29b95447 100755 --- a/modules/plotchart/plotchart.man +++ b/modules/plotchart/plotchart.man @@ -1,10 +1,10 @@ [comment {-*- tcl -*- doctools manpage}] -[manpage_begin Plotchart n 0.9] +[manpage_begin Plotchart n 1.0] [copyright {2004 Arjen Markus }] [moddesc Plotchart] [titledesc {Simple plotting and charting package}] [require Tcl [opt 8.3]] -[require Plotchart [opt 0.9]] +[require Plotchart [opt 1.0]] [description] [para] @@ -422,6 +422,64 @@ Y-coordinate of the new point. [list_end] [para] +For [emph {xy plots}]: + +[list_begin definitions] +[call [cmd \$xyplot] contourlines [arg xcrd] [arg ycrd] [arg values] [opt classes]] + +Draw contour lines for the values given on the grid. The grid is defined +by the xcrd and ycrd arguments (they give the x- and y-coordinates of +the grid cell corners). The values are given at these corners. The +classes determine which contour lines are drawn. If a value on one of +the corners is missing, the contour lines in that cell will not be +drawn. + +[list_begin arg] +[arg_def list xcrd in] +List of lists, each value is an x-coordinate for a grid cell corner + +[arg_def list ycrd in] +List of lists, each value is an y-coordinate for a grid cell corner + +[arg_def list values in] +List of lists, each value is the value at a grid cell corner + +[arg_def list classes in] +List of class values or a list of lists of two elements (each inner list +the class value and the colour to be used). If empty or missing, the +classes are determined automatically. +[nl] +[emph Note:] The class values must enclose the whole range of values. +[nl] + +[list_end] + +[call [cmd \$xyplot] contourfill [arg xcrd] [arg ycrd] [arg values] [opt classes]] + +Draw filled contours for the values given on the grid. (The use of this +method is identical to the "contourlines" method). + +[call [cmd \$xyplot] contourbox [arg xcrd] [arg ycrd] [arg values] [opt classes]] + +Draw the cells as filled quadrangles. The colour is determined from +the average of the values on all four corners. + +[call [cmd \$xyplot] colourmap [arg colours]] + +Set the colours to be used with the contour methods. The argument is +either a predefined colourmap (rainbow, white-blue, white-red, +white-black, green-red, blue-red) or a list of colours. When selecting +the colours for actually drawing the contours, the given colours will be +interpolated (based on the HLS scheme). + +[list_begin arg] +[arg_def list colours in] +List of colour names or colour values +[list_end] + +[list_end] +[para] + For [emph {polar plots}]: [list_begin definitions] diff --git a/modules/plotchart/plotchart.tcl b/modules/plotchart/plotchart.tcl index f93d3304..1a35f8f2 100755 --- a/modules/plotchart/plotchart.tcl +++ b/modules/plotchart/plotchart.tcl @@ -31,6 +31,10 @@ namespace eval ::Plotchart { set methodProc(xyplot,xtext) DrawXtext set methodProc(xyplot,ytext) DrawYtext set methodProc(xyplot,plot) DrawData + set methodProc(xyplot,grid) DrawGrid + set methodProc(xyplot,contourlines) DrawIsolines + set methodProc(xyplot,contourfill) DrawShades + set methodProc(xyplot,contourbox) DrawBox set methodProc(xyplot,saveplot) SavePlot set methodProc(xyplot,dataconfig) DataConfig set methodProc(xyplot,xconfig) XConfig @@ -86,6 +90,7 @@ namespace eval ::Plotchart { set methodProc(3dplot,xconfig) XConfig set methodProc(3dplot,yconfig) YConfig set methodProc(3dplot,zconfig) ZConfig + set methodProc(3dplot,plotfuncont) Draw3DFunctionContour # # Auxiliary parameters @@ -113,6 +118,7 @@ namespace eval ::Plotchart { -ticklines {0 1} -scale {...} } + variable contour_options } # setZoomPan -- @@ -776,7 +782,8 @@ source [file join [file dirname [info script]] "plotpriv.tcl"] source [file join [file dirname [info script]] "plotaxis.tcl"] source [file join [file dirname [info script]] "plot3d.tcl"] source [file join [file dirname [info script]] "scaling.tcl"] +source [file join [file dirname [info script]] "plotcontour.tcl"] # Announce our presence # -package provide Plotchart 0.9 +package provide Plotchart 1.0 diff --git a/modules/plotchart/plotcontour.tcl b/modules/plotchart/plotcontour.tcl new file mode 100755 index 00000000..1b27610e --- /dev/null +++ b/modules/plotchart/plotcontour.tcl @@ -0,0 +1,1697 @@ +# plotcontour.tcl -- +# Contour plotting test program for the Plotchart package +# +# Author: Mark Stucky +# +# The basic idea behind the method used for contouring within this sample +# is primarily based on : +# +# (1) "Contour Plots of Large Data Sets" by Chris Johnston +# Computer Language, May 1986 +# +# a somewhat similar method was also described in +# +# (2) "A Contouring Subroutine" by Paul D. Bourke +# BYTE, June 1987 +# http://astronomy.swin.edu.au/~pbourke/projection/conrec/ +# +# In (1) it is assumed that you have a N x M grid of data that you need +# to process. In order to generate a contour, each cell of the grid +# is handled without regard to it's neighbors. This is unlike many other +# contouring algorithms that follow the current contour line into +# neighboring cells in an attempt to produce "smoother" contours. +# +# In general the method described is: +# +# 1) for each four cornered cell of the grid, +# calculate the center of the cell (average of the four corners) +# +# data(i ,j) : Point (1) +# data(i+1,j) : Point (2) +# data(i+1,j+1) : Point (3) +# data(i ,j+1) : Point (4) +# center : Point (5) +# +# (4)-------------(3) +# | \ / | +# | \ / | +# | \ / | +# | \ / | +# | \ / | +# | (5) | +# | / \ | +# | / \ | +# | / \ | +# ^ | / \ | +# | | / \ | +# J (1)-------------(2) +# +# I -> +# +# This divides the cell into four triangles. +# +# 2) Each of the five points in the cell can be assigned a sign (+ or -) +# depending upon whether the point is above (+) the current contour +# or below (-). +# +# A contour will cross an edge whenever the points on the boundary of +# the edge are of an opposite sign. +# +# A few examples : +# +# (-) (-) (-) | (+) (-) (-) (+) | (-) +# \ _ \ +# \ / \ \ +# (-) - (-) | _ /(+) | - (+) - +# / / / \ +# / / / \ +# (-) | (+) (-) | (+) (+) | (-) (-) | (+) +# +# +# (Hopefully the "rough" character diagrams above give you the +# general idea) +# +# It turns out that there are 32 possibles combinations of + and - +# and therefore 32 basic paths through the cell. And if you swap +# the (+) and (-) in the diagram above, the "same" basic path is +# generated: +# +# (+) (+) (+) | (-) (+) (+) (-) | (+) +# \ _ \ +# \ / \ \ +# (+) - (+) | _ /(-) | - (-) - +# / / / \ +# / / / \ +# (+) | (-) (+) | (-) (-) | (+) (+) | (-) +# +# +# So, it turns out that there are 16 basic paths through the cell. +# +############################################################################### +# +# The original article/code worked on all four triangles together and +# generated one of the 16 paths. +# +# For this version of the code, I split the cell into the four triangles +# and handle each triangle individually. +# +# Doing it this way is slower than the above method for calculating the +# contour lines. But since it "simplifies" the code when doing "color filled" +# contours, I opted for the longer calculation times. +# +# +# AM: +# Introduce the following methods in createXYPlot: +# - grid Draw the grid (x,y needed) +# - contourlines Draw isolines (x,y,z needed) +# - contourfill Draw shades (x,y,z needed) +# - contourbox Draw uniformly coloured cells (x,y,z needed) +# +# This needs still to be done: +# - colourmap Set colours to be used (possibly interpolated) +# +# Note: +# To get the RGB values of a named colour: +# winfo rgb . color (divide by 256) +# +# The problem: +# What interface do we use? +# +# Changes: +# - Capitalised several proc names (to indicate they are private to +# the Plotchart package) +# - Changed the data structure from an array to a list of lists. +# This means: +# - No confusion about the start of indices +# - Lists can be passed as ordinary arguments +# - In principle they are faster, but that does not really +# matter here +# To do: +# - Absorb all global arrays into the Plotchart system of private data +# - Get rid of the bug in the shades algorithm ;) +# + +# DrawGrid -- +# Draw the grid as contained in the lists of coordinates +# Arguments: +# w Canvas to draw in +# x X-coordinates of grid points (list of lists) +# y Y-coordinates of grid points (list of lists) +# Result: +# None +# Side effect: +# Grid drawn as lines between the vertices +# Note: +# STILL TO DO +# A cell is only drawn if there are four well-defined +# corners. If the x or y coordinate is missing, the cell is +# skipped. +# +proc ::Plotchart::DrawGrid {w x y} { + + set maxrow [llength $x] + set maxcol [llength [lindex $x 0]] + + for {set i 0} {$i < $maxrow} {incr i} { + set xylist {} + for {set j 0} {$j < $maxcol} {incr j} { + lappend xylist [lindex $x $i $j] [lindex $y $i $j] + } + C_line $w $xylist black + } + + for {set j 0} {$j < $maxcol} {incr j} { + set xylist {} + for {set i 0} {$i < $maxrow} {incr i} { + lappend xylist [lindex $x $i $j] [lindex $y $i $j] + } + C_line $w $xylist black + } +} + +# DrawIsolines -- +# Draw isolines in the given grid +# Arguments: +# canv Canvas to draw in +# x X-coordinates of grid points (list of lists) +# y Y-coordinates of grid points (list of lists) +# f Values of the parameter on the grid cell corners +# cont List of contour classes (or empty to indicate +# automatic scaling +# Result: +# None +# Side effect: +# Isolines drawn +# Note: +# A cell is only drawn if there are four well-defined +# corners. If the x or y coordinate is missing or the value is +# missing, the cell is skipped. +# +proc ::Plotchart::DrawIsolines {canv x y f {cont {}} } { + variable contour_options + + set contour_options(simple_box_contour) 0 + set contour_options(filled_contour) 0 + +# DrawContour $canv $x $y $f 0.0 100.0 20.0 + DrawContour $canv $x $y $f $cont +} + +# DrawShades -- +# Draw filled contours in the given grid +# Arguments: +# canv Canvas to draw in +# x X-coordinates of grid points (list of lists) +# y Y-coordinates of grid points (list of lists) +# f Values of the parameter on the grid cell corners +# cont List of contour classes (or empty to indicate +# automatic scaling +# Result: +# None +# Side effect: +# Shades (filled contours) drawn +# Note: +# A cell is only drawn if there are four well-defined +# corners. If the x or y coordinate is missing or the value is +# missing, the cell is skipped. +# +proc ::Plotchart::DrawShades {canv x y f {cont {}} } { + variable contour_options + + set contour_options(simple_box_contour) 0 + set contour_options(filled_contour) 1 + +# DrawContour $canv $x $y $f 0.0 100.0 20.0 + DrawContour $canv $x $y $f $cont +} + +# DrawBox -- +# Draw filled cells in the given grid (colour chosen according +# to the _average_ of the four corner values) +# Arguments: +# canv Canvas to draw in +# x X-coordinates of grid points (list of lists) +# y Y-coordinates of grid points (list of lists) +# f Values of the parameter on the grid cell corners +# cont List of contour classes (or empty to indicate +# automatic scaling +# Result: +# None +# Side effect: +# Filled cells (quadrangles) drawn +# Note: +# A cell is only drawn if there are four well-defined +# corners. If the x or y coordinate is missing or the value is +# missing, the cell is skipped. +# +proc ::Plotchart::DrawBox {canv x y f {cont {}} } { + variable contour_options + + set contour_options(simple_box_contour) 1 + set contour_options(filled_contour) 0 + +# DrawContour $canv $x $y $f 0.0 100.0 20.0 + DrawContour $canv $x $y $f $cont +} + +# Draw3DFunctionContour -- +# Plot a function of x and y with a color filled contour +# Arguments: +# w Name of the canvas +# function Name of a procedure implementing the function +# cont contour levels +# Result: +# None +# Side effect: +# The plot of the function - given the grid +# +proc ::Plotchart::Draw3DFunctionContour { w function {cont {}} } { + variable scaling + variable contour_options + + set contour_options(simple_box_contour) 0 + set contour_options(filled_contour) 1 + set noTrans 0 + + ::Plotchart::setColormapColors [llength $cont] + + set nxcells $scaling($w,nxcells) + set nycells $scaling($w,nycells) + set xmin $scaling($w,xmin) + set xmax $scaling($w,xmax) + set ymin $scaling($w,ymin) + set ymax $scaling($w,ymax) + set dx [expr {($xmax-$xmin)/double($nxcells)}] + set dy [expr {($ymax-$ymin)/double($nycells)}] + + foreach {fill border} $scaling($w,colours) {break} + + # + # Draw the quadrangles making up the plot in the right order: + # first y from minimum to maximum + # then x from maximum to minimum + # + for { set j 0 } { $j < $nycells } { incr j } { + set y1 [expr {$ymin + $dy*$j}] + set y2 [expr {$y1 + $dy}] + for { set i $nxcells } { $i > 0 } { incr i -1 } { + set x2 [expr {$xmin + $dx*$i}] + set x1 [expr {$x2 - $dx}] + + set z11 [$function $x1 $y1] + set z12 [$function $x1 $y2] + set z21 [$function $x2 $y1] + set z22 [$function $x2 $y2] + + foreach {px11 py11} [coords3DToPixel $w $x1 $y1 $z11] {break} + foreach {px12 py12} [coords3DToPixel $w $x1 $y2 $z12] {break} + foreach {px21 py21} [coords3DToPixel $w $x2 $y1 $z21] {break} + foreach {px22 py22} [coords3DToPixel $w $x2 $y2 $z22] {break} + + set xb [list $px11 $px21 $px22 $px12] + set yb [list $py11 $py21 $py22 $py12] + set fb [list $z11 $z21 $z22 $z12 ] + + Box_contour $w $xb $yb $fb $cont $noTrans + + $w create line $px11 $py11 $px21 $py21 $px22 $py22 \ + $px12 $py12 $px11 $py11 \ + -fill $border + } + } +} + + +# DrawContour -- +# Routine that loops over the grid and delegates the actual drawing +# Arguments: +# canv Canvas to draw in +# x X-coordinates of grid points (list of lists) +# y Y-coordinates of grid points (list of lists) +# f Values of the parameter on the grid cell corners +# cont List of contour classes (or empty to indicate +# automatic scaling) +# Result: +# None +# Side effect: +# Isolines, shades or boxes drawn +# Note: +# A cell is only drawn if there are four well-defined +# corners. If the x or y coordinate is missing or the value is +# missing, the cell is skipped. +# +proc ::Plotchart::DrawContour {canv x y f cont} { + variable contour_options + variable colorMap + + # + # Construct the class-colour list + # + set cont [MakeContourClasses $f $cont] + + set fmin [lindex $cont 0 0] + set fmax [lindex $cont end 0] + set ncont [llength $cont] + + # Now that we know how many entries (ncont), create + # the colormap colors + # + # I moved this into MakeContourClasses... + # ::Plotchart::setColormapColors $ncont + + set maxrow [llength $x] + set maxcol [llength [lindex $x 0]] + + for {set i 0} {$i < $maxrow-1} {incr i} { + set i1 [expr {$i + 1}] + for {set j 0} {$j < $maxcol-1} {incr j} { + set j1 [expr {$j + 1}] + + set x1 [lindex $x $i1 $j] + set x2 [lindex $x $i $j] + set x3 [lindex $x $i $j1] + set x4 [lindex $x $i1 $j1] + + set y1 [lindex $y $i1 $j] + set y2 [lindex $y $i $j] + set y3 [lindex $y $i $j1] + set y4 [lindex $y $i1 $j1] + + set f1 [lindex $f $i1 $j] + set f2 [lindex $f $i $j] + set f3 [lindex $f $i $j1] + set f4 [lindex $f $i1 $j1] + + set xb [list $x1 $x2 $x3 $x4] + set yb [list $y1 $y2 $y3 $y4] + set fb [list $f1 $f2 $f3 $f4] + + if { [lsearch $fb {}] >= 0 || + [lsearch $xb {}] >= 0 || + [lsearch $yb {}] >= 0 } { + continue + } + + Box_contour $canv $xb $yb $fb $cont + } + } +} + +# Box_contour -- +# Draw a filled box +# Arguments: +# canv Canvas to draw in +# xb X-coordinates of the four corners +# yb Y-coordinates of the four corners +# fb Values of the parameter on the four corners +# cont List of contour classes and colours +# Result: +# None +# Side effect: +# Box drawn for a single cell +# +proc ::Plotchart::Box_contour {canv xb yb fb cont {doTrans 1}} { + variable colorMap + variable contour_options + + foreach {x1 x2 x3 x4} $xb {} + foreach {y1 y2 y3 y4} $yb {} + foreach {f1 f2 f3 f4} $fb {} + + set xc [expr {($x1 + $x2 + $x3 + $x4) * 0.25}] + set yc [expr {($y1 + $y2 + $y3 + $y4) * 0.25}] + set fc [expr {($f1 + $f2 + $f3 + $f4) * 0.25}] + + if {$contour_options(simple_box_contour)} { + + set fmin [lindex $cont 0] + set fmax [lindex $cont end] + set ncont [llength $cont] + + set ic 0 + for {set i 0} {$i < $ncont} {incr i} { + set ff [lindex $cont $i 0] + if {$ff <= $fc} { + set ic $i + } + } + + set xylist [list $x1 $y1 $x2 $y2 $x3 $y3 $x4 $y4] + + # canvasPlot::polygon $win $xylist -fill $cont($ic,color) + ### C_polygon $canv $xylist $cont($ic,color) + C_polygon $canv $xylist [lindex $cont $ic 1] + + } else { + +#debug# puts "Tri_contour 1)" + Tri_contour $canv $x1 $y1 $f1 $x2 $y2 $f2 $xc $yc $fc $cont $doTrans + +#debug# puts "Tri_contour 2)" + Tri_contour $canv $x2 $y2 $f2 $x3 $y3 $f3 $xc $yc $fc $cont $doTrans + +#debug# puts "Tri_contour 3)" + Tri_contour $canv $x3 $y3 $f3 $x4 $y4 $f4 $xc $yc $fc $cont $doTrans + +#debug# puts "Tri_contour 4)" + Tri_contour $canv $x4 $y4 $f4 $x1 $y1 $f1 $xc $yc $fc $cont $doTrans + + } + +} + +# Tri_contour -- +# Draw isolines or shades in a triangle +# Arguments: +# canv Canvas to draw in +# x1,x2,x3 X-coordinate of the three corners +# y1,y2,y3 Y-coordinates of the three corners +# f1,f2,f3 Values of the parameter on the three corners +# cont List of contour classes and colours +# Result: +# None +# Side effect: +# Isolines/shades drawn for a single triangle +# +proc ::Plotchart::Tri_contour { canv x1 y1 f1 x2 y2 f2 x3 y3 f3 cont {doTrans 1} } { + variable contour_options + variable colorMap + + set ncont [llength $cont] + + + # Find the min/max function values for this triangle + # + set tfmin [min $f1 $f2 $f3] + set tfmax [max $f1 $f2 $f3] + + # Based on the above min/max, figure out which + # contour levels/colors that bracket this interval + # + set imin 0 + set imax 0 ;#mbs# + for {set i 0} {$i < $ncont} {incr i} { + set ff [lindex $cont $i] ; ### set ff $cont($i,fval) + if {$ff <= $tfmin} { + set imin $i + set imax $i + } + if { $ff <= $tfmax} { + set imax $i + } + } + + set vertlist {} + + # Loop over all contour levels of interest for this triangle + # + for {set ic $imin} {$ic <= $imax} {incr ic} { + + # Get the value for this contour level + # + set ff [lindex $cont $ic 0] ;### set ff $cont($ic,fval) + + set xylist {} + set pxylist {} + + # Classify the triangle based on whether the functional values, f1,f2,f3 + # are above (+), below (-), or equal (=) to the current contour level ff + # + set s1 [::Plotchart::setFLevel $f1 $ff] + set s2 [::Plotchart::setFLevel $f2 $ff] + set s3 [::Plotchart::setFLevel $f3 $ff] + + set class "$s1$s2$s3" + + # Describe class here... + + # ( - - - ) : Case A, + # ( - - = ) : Case B, color a point, do nothing + # ( - - + ) : Case C, contour between {23}-{31} + # ( - = - ) : Case D, color a point, do nothing + # ( - = = ) : Case E, contour line between 2-3 + # ( - = + ) : Case F, contour between 2-{31} + # ( - + - ) : Case G, contour between {12}-{23} + # ( - + = ) : Case H, contour between {12}-3 + # ( - + + ) : Case I, contour between {12}-{31} + # ( = - - ) : Case J, color a point, do nothing + # ( = - = ) : Case K, contour line between 1-3 + # ( = - + ) : Case L, contour between 1-{23} + # ( = = - ) : Case M, contour line between 1-2 + # ( = = = ) : Case N, fill full triangle, return + # ( = = + ) : Case M, + # ( = + - ) : Case L, + # ( = + = ) : Case K, + # ( = + + ) : Case J, + # ( + - - ) : Case I, + # ( + - = ) : Case H, + # ( + - + ) : Case G, + # ( + = - ) : Case F, + # ( + = = ) : Case E, + # ( + = + ) : Case D, + # ( + + - ) : Case C, + # ( + + = ) : Case B, + # ( + + + ) : Case A, + + + switch -- $class { + + ############### Case A ############### + + "---" { +#debug# puts "class A = $class , $ic , $ff" + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + return + } + + "+++" { +#debug# puts "class A = $class , $ic , $ff" + if {$contour_options(filled_contour)} { + if {$ic == $imax} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + } + } + + ############### Case N ############### + + "===" { +#debug# puts "class N = $class , $ic , $ff" + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + return + } + + ############### Case B ############### + + "--=" { +#debug# puts "class B = $class , $ic , $ff" + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + return + } + + "++=" { +#debug# puts "class B= $class , $ic , $ff , do nothing unless ic == imax" + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + } + } + + ############### Case D ############### + + "-=-" { +#debug# puts "class D = $class , $ic , $ff" + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + return + } + + "+=+" { +#debug# puts "class D = $class , $ic , $ff , do nothing unless ic == imax" + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + } + } + + ############### Case J ############### + + "=--" { +#debug# puts "class J = $class , $ic , $ff" + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + return + } + + "=++" { +#debug# puts "class J = $class , $ic , $ff , do nothing unless ic == imax" + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + } + } + + ############### Case K ############### + + "=-=" { +#debug# puts "class K = $class , $ic , $ff" + set xylist [list $x1 $y1 $x3 $y3] + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + return + + } + + "=+=" { +#debug# puts "class K = $class , $ic , $ff" + set xylist [list $x1 $y1 $x3 $y3] + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + + } else { + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + } + } + + ############### Case E ############### + + "-==" { +#debug# puts "class E = $class , $ic , $ff" + set xylist [list $x2 $y2 $x3 $y3] + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + return + } + + "+==" { +#debug# puts "class E = $class , $ic , $ff" + set xylist [list $x2 $y2 $x3 $y3] + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + + } else { + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + } + } + + ############### Case M ############### + + "==-" { +#debug# puts "class M = $class , $ic , $ff" + set xylist [list $x1 $y1 $x2 $y2] + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + return + } + + "==+" { +#debug# puts "class M = $class , $ic , $ff" + set xylist [list $x1 $y1 $x2 $y2] + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + + } else { + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + } + + } + + ############### Case F ############### + + "-=+" { +#debug# puts "class F = $class , $ic , $ff" + set xylist [list $x2 $y2] + set xyf2 [fintpl $x3 $y3 $f3 $x1 $y1 $f1 $ff] + foreach {xx yy} $xyf2 {} + lappend xylist $xx $yy + + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x1 $y1 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + + set x1 $xx; set y1 $yy; set f1 $ff + + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + } + + } + + "+=-" { +#debug# puts "class F = $class , $ic , $ff" + set xylist [list $x2 $y2] + set xyf2 [fintpl $x3 $y3 $f3 $x1 $y1 $f1 $ff] + foreach {xx yy} $xyf2 {} + lappend xylist $xx $yy + + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x3 $y3 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + + set x3 $xx; set y3 $yy; set f3 $ff + + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + } + + } + + ############### Case H ############### + + "-+=" { +#debug# puts "class H = $class , $ic , $ff" + set xylist [fintpl $x1 $y1 $f1 $x2 $y2 $f2 $ff] + foreach {xx yy} $xylist {} + lappend xylist $x3 $y3 + + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x1 $y1 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + + set x1 $xx; set y1 $yy; set f1 $ff + + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + } + + } + + "+-=" { +#debug# puts "class H = $class , $ic , $ff" + set xylist [fintpl $x1 $y1 $f1 $x2 $y2 $f2 $ff] + foreach {xx yy} $xylist {} + lappend xylist $x3 $y3 + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x2 $y2 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + + set x2 $xx; set y2 $yy; set f2 $ff + + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + } + + } + + ############### Case L ############### + + "=-+" { +#debug# puts "class L = $class , $ic , $ff" + set xylist [fintpl $x2 $y2 $f2 $x3 $y3 $f3 $ff] + foreach {xx yy} $xylist {} + lappend xylist $x1 $y1 + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x2 $y2 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + + set x2 $xx; set y2 $yy; set f2 $ff + + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + } + + } + + "=+-" { +#debug# puts "class L = $class , $ic , $ff" + set xylist [fintpl $x2 $y2 $f2 $x3 $y3 $f3 $ff] + foreach {xx yy} $xylist {} + lappend xylist $x1 $y1 + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x3 $y3 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + + set x3 $xx; set y3 $yy; set f3 $ff + + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + } + + } + + ############### Case C ############### + + "--+" { +#debug# puts "class C = $class , $ic , $ff" + set xyf1 [fintpl $x2 $y2 $f2 $x3 $y3 $f3 $ff] + set xyf2 [fintpl $x3 $y3 $f3 $x1 $y1 $f1 $ff] + set xylist $xyf1 + foreach {xx1 yy1} $xyf1 {} + foreach {xx2 yy2} $xyf2 {} + lappend xylist $xx2 $yy2 + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x1 $y1 $x2 $y2 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + if {$ic == $imax} { + set pxylist $xylist + lappend pxylist $x3 $y3 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + set oldlist {} + set x1 $xx1; set y1 $yy1; set f1 $ff + set x2 $xx2; set y2 $yy2; set f2 $ff + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + } + } + + "++-" { +#debug# puts "class C = $class , $ic , $ff" + set xyf1 [fintpl $x2 $y2 $f2 $x3 $y3 $f3 $ff] + set xyf2 [fintpl $x3 $y3 $f3 $x1 $y1 $f1 $ff] + set xylist $xyf1 + foreach {xx1 yy1} $xyf1 {} + foreach {xx2 yy2} $xyf2 {} + lappend xylist $xx2 $yy2 + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x3 $y3 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x1 $y1 $x2 $y2 + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + } + + } else { + +#debug# puts "call Tri_contour : 1) $class" +#debug# puts " : $xx1 $yy1 $ff $xx2 $yy2 $ff $x1 $y1 $f1" + Tri_contour $canv $xx1 $yy1 $ff $xx2 $yy2 $ff $x1 $y1 $f1 $cont $doTrans + +#debug# puts "call Tri_contour : 2) $class" +#debug# puts " : $xx1 $yy1 $ff $x1 $y1 $f1 $x2 $y2 $f2" + Tri_contour $canv $xx1 $yy1 $ff $x1 $y1 $f1 $x2 $y2 $f2 $cont $doTrans + + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + return + + } + + ############### Case G ############### + + "-+-" { +#debug# puts "class G = $class , $ic , $ff" + set xyf1 [fintpl $x1 $y1 $f1 $x2 $y2 $f2 $ff] + set xyf2 [fintpl $x2 $y2 $f2 $x3 $y3 $f3 $ff] + set xylist $xyf1 + foreach {xx1 yy1} $xyf1 {} + foreach {xx2 yy2} $xyf2 {} + lappend xylist $xx2 $yy2 + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x3 $y3 $x1 $y1 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + if {$ic == $imax} { + set pxylist $xylist + lappend pxylist $x2 $y2 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + set oldlist {} + set x1 $xx1; set y1 $yy1; set f1 $ff + set x3 $xx2; set y3 $yy2; set f3 $ff + + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + } + + } + + "+-+" { +#debug# puts "class G = $class , $ic , $ff" + set xyf1 [fintpl $x1 $y1 $f1 $x2 $y2 $f2 $ff] + set xyf2 [fintpl $x2 $y2 $f2 $x3 $y3 $f3 $ff] + foreach {xx1 yy1} $xyf1 {} + foreach {xx2 yy2} $xyf2 {} + set xylist $xyf1 + lappend xylist $xx2 $yy2 + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x2 $y2 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x3 $y3 $x1 $y1 + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + } + + } else { + +#debug# puts "call Tri_contour : 1) $class" +#debug# puts " : $xx1 $yy1 $ff $xx2 $yy2 $ff $x3 $y3 $f3" + Tri_contour $canv $xx1 $yy1 $ff $xx2 $yy2 $ff $x3 $y3 $f3 $cont $doTrans + +#debug# puts "call Tri_contour : 2) $class" +#debug# puts " : $xx1 $yy1 $ff $x3 $y3 $f3 $x1 $y1 $f1" + Tri_contour $canv $xx1 $yy1 $ff $x3 $y3 $f3 $x1 $y1 $f1 $cont $doTrans + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + return + + } + + ############### Case I ############### + + "+--" { +#debug# puts "class I = $class , $ic , $ff" + set xyf1 [fintpl $x1 $y1 $f1 $x2 $y2 $f2 $ff] + set xyf2 [fintpl $x3 $y3 $f3 $x1 $y1 $f1 $ff] + set xylist $xyf1 + foreach {xx1 yy1} $xyf1 {} + foreach {xx2 yy2} $xyf2 {} + lappend xylist $xx2 $yy2 + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x3 $y3 $x2 $y2 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + if {$ic == $imax} { + set pxylist $xylist + lappend pxylist $x1 $y1 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + set oldlist {} + set x2 $xx1; set y2 $yy1; set f2 $ff + set x3 $xx2; set y3 $yy2; set f3 $ff + + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + } + + } + + "-++" { +#debug# puts "class I = $class , $ic , $ff" + set xyf1 [fintpl $x1 $y1 $f1 $x2 $y2 $f2 $ff] + set xyf2 [fintpl $x3 $y3 $f3 $x1 $y1 $f1 $ff] + foreach {xx1 yy1} $xyf1 {} + foreach {xx2 yy2} $xyf2 {} + set xylist $xyf1 + lappend xylist $xx2 $yy2 + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x1 $y1 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x3 $y3 $x2 $y2 + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + } + + } else { + +#debug# puts "call Tri_contour : 1) $class" +#debug# puts " : $xx1 $yy1 $ff $xx2 $yy2 $ff $x3 $y3 $f3" + Tri_contour $canv $xx1 $yy1 $ff $xx2 $yy2 $ff $x3 $y3 $f3 $cont $doTrans + +#debug# puts "call Tri_contour : 2) $class" +#debug# puts " : $xx1 $yy1 $ff $x3 $y3 $f3 $x2 $y2 $f2" + Tri_contour $canv $xx1 $yy1 $ff $x3 $y3 $f3 $x2 $y2 $f2 $cont $doTrans + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + return + + } + + } + + } +} + +# setFLevel -- +# Auxiliary function: used to classify one functional value to another +# Arguments: +# f1 Second break point and value +# f2 Value to find +# Result: +# + f1 > f2 +# = f1 = f2 +# - f1 < f2 +# +proc ::Plotchart::setFLevel {f1 f2} { + if {$f1 > $f2} { + return "+" + } else { + if {$f1 < $f2} { + return "-" + } else { + return "=" + } + } +} + +# fintpl -- +# Auxiliary function: inverse interpolation +# Arguments: +# x1,y1,f1 First break point and value +# x2,y2,f2 Second break point and value +# ff Value to find +# Result: +# x,y coordinates of point with that value +# +proc ::Plotchart::fintpl {x1 y1 f1 x2 y2 f2 ff} { + + if {[expr {$f2 - $f1}] != 0.0} { + set xx [expr {$x1 + (($ff - $f1)*($x2 - $x1)/($f2 - $f1))}] + set yy [expr {$y1 + (($ff - $f1)*($y2 - $y1)/($f2 - $f1))}] + } else { + + # If the logic was handled correctly above, this point + # should never be reached. + # + # puts "FINTPL : f1 == f2 : x1,y1 : $x1 , $y1 : x2,y2 : $x2 , $y2" + set xx $x1 + set yy $y1 + } + + set xmin [min $x1 $x2] + set xmax [max $x1 $x2] + set ymin [min $y1 $y2] + set ymax [max $y1 $y2] + + if {$xx < $xmin} { set xx $xmin } + if {$xx > $xmax} { set xx $xmax } + if {$yy < $ymin} { set yy $ymin } + if {$yy > $ymax} { set yy $ymax } + + return [list $xx $yy] +} + +# min -- +# Auxiliary function: find the minimum of the arguments +# Arguments: +# val First value +# args All others +# Result: +# Minimum over the arguments +# +proc ::Plotchart::min { val args } { + set min $val + foreach val $args { + if { $val < $min } { + set min $val + } + } + return $min +} + +# max -- +# Auxiliary function: find the maximum of the arguments +# Arguments: +# val First value +# args All others +# Result: +# Maximum over the arguments +# +proc ::Plotchart::max { val args } { + set max $val + foreach val $args { + if { $val > $max } { + set max $val + } + } + return $max +} + +# C_line -- +# Draw a line +# Arguments: +# canv Canvas to draw in +# xylist List of raw coordinates +# color Chosen colour +# args Any additional arguments (for line style and such) +# Result: +# None +# +proc ::Plotchart::C_line {canv xylist color {doTrans 1} } { + + if {$doTrans} { + set wxylist {} + foreach {xx yy} $xylist { + foreach {pxcrd pycrd} [::Plotchart::coordsToPixel $canv $xx $yy] {break} + lappend wxylist $pxcrd $pycrd + } + eval "$canv create line $wxylist -fill $color" + + } else { + $canv create line $xylist -fill $color + } +} + +# C_polygon -- +# Draw a polygon +# Arguments: +# canv Canvas to draw in +# xylist List of raw coordinates +# color Chosen colour +# args Any additional arguments (for line style and such) +# Result: +# None +# +proc ::Plotchart::C_polygon {canv xylist color {doTrans 1}} { + + if {$doTrans} { + set wxylist {} + foreach {xx yy} $xylist { + foreach {pxcrd pycrd} [::Plotchart::coordsToPixel $canv $xx $yy] {break} + lappend wxylist $pxcrd $pycrd + } + eval "$canv create polygon $wxylist -fill $color" + + } else { + $canv create polygon $xylist -fill $color + } +} + +# MakeContourClasses -- +# Return contour classes and colours +# Arguments: +# values List of values +# classes Given list of classes or class/colours +# Result: +# List of pairs of class limits and colours +# Note: +# This should become more sophisticated! +# +proc ::Plotchart::MakeContourClasses {values classes} { + variable contour_options + variable colorMap + + if { [llength $classes] == 0 } { + set min {} + set max {} + foreach row $values { + foreach v $row { + if { $v == {} } {continue} + + if { $min == {} || $min > $v } { + set min $v + } + + if { $max == {} || $max < $v } { + set max $v + } + } + } + + foreach {xmin xmax xstep} [determineScale $min $max] {break} + + # + # The contour classes must encompass all values + # There might be a problem with border cases + # + set classes {} + set x $xmin + + while { $x < $xmax+0.5*$xstep } { + #mbs# lappend classes [list $x] + set x [expr {$x+$xstep}] + lappend classes [list $x] + } + + # Now that we know how many entries (ncont), create + # the colormap colors + # + ::Plotchart::setColormapColors [expr [llength $classes] + 1] + + } elseif { [llength [lindex $classes 0]] == 1 } { + #mbs# Changed the above line from " == 2 " to " == 1 " + ::Plotchart::setColormapColors [llength $classes] + return $classes + } + + # + # Add the colours + # +##### set cont {} +##### set c 0 +##### +##### foreach x $classes { +##### set col [lindex $contour_options(colourmap) $c] +##### if { $col == {} } { +##### set c 0 +##### set col [lindex $contour_options(colourmap) $c] +##### } +##### lappend cont [list $x $col] +##### incr c +##### } +##### +##### return $cont + + puts "classes (cont) : $classes" + + return $classes +} + + +# setColormapColors -- +# Auxiliary function: Based on the current colormap type +# create a colormap with requested number of entries +# Arguments: +# ncont Number of colors in the colormap +# Result: +# List of colours +# +proc ::Plotchart::setColormapColors {ncont} { + variable colorMapType + variable colorMap + +#debug# puts "SetColormapColors : ncont = $ncont" + + # Note : The default colormap is "jet" + + switch $colorMapType { + + custom { + return + } + + hsv { + set hueStart 0.0 + set hueEnd 240.0 + set colorMap {} + + for {set i 0} {$i <= $ncont} {incr i} { + set dh [expr {($hueStart - $hueEnd) / ($ncont - 1)}] + set hue [expr {$hueStart - ($i * $dh)}] + if {$hue < 0.0} { + set hue [expr {360.0 + $hue}] + } + set rgbList [Hsv2rgb $hue 1.0 1.0] + set r [expr {int([lindex $rgbList 0] * 65535)}] + set g [expr {int([lindex $rgbList 1] * 65535)}] + set b [expr {int([lindex $rgbList 2] * 65535)}] + + set color [format "#%.4x%.4x%.4x" $r $g $b] + lappend colorMap $color + } + } + + hot { + set colorMap {} + set nc1 [expr {int($ncont * 0.33)}] + set nc2 [expr {int($ncont * 0.67)}] + + for {set i 0} {$i <= $ncont} {incr i} { + + if {$i <= $nc1} { + set fval [expr { double($i) / (double($nc1)) } ] + set r [expr {int($fval * 65535)}] + set g 0 + set b 0 + } else { + if {$i <= $nc2} { + set fval [expr { double($i-$nc1) / (double($nc2-$nc1)) } ] + set r 65535 + set g [expr {int($fval * 65535)}] + set b 0 + } else { + set fval [expr { double($i-$nc2) / (double($ncont-$nc2)) } ] + set r 65535 + set g 65535 + set b [expr {int($fval * 65535)}] + } + } + set color [format "#%.4x%.4x%.4x" $r $g $b] + lappend colorMap $color + } + } + + cool { + set colorMap {} + + for {set i 0} {$i <= $ncont} {incr i} { + + set fval [expr { double($i) / (double($ncont)-1) } ] + set val [expr { 1.0 - $fval }] + + set r [expr {int($fval * 65535)}] + set g [expr {int($val * 65535)}] + set b 65535 + + set color [format "#%.4x%.4x%.4x" $r $g $b] + lappend colorMap $color + } + } + + grey - + gray { + set colorMap {} + + for {set i 0} {$i <= $ncont} {incr i} { + + set fval [expr { double($i) / (double($ncont)-1) } ] + set val [expr {0.4 + (0.5 * $fval) }] + + set r [expr {int($val * 65535)}] + set g [expr {int($val * 65535)}] + set b [expr {int($val * 65535)}] + + set color [format "#%.4x%.4x%.4x" $r $g $b] + lappend colorMap $color + } + } + + jet - + default { + set hueStart 240.0 + set hueEnd 0.0 + set colorMap {} + + for {set i 0} {$i <= $ncont} {incr i} { + set dh [expr {($hueStart - $hueEnd) / ($ncont - 1)}] + set hue [expr {$hueStart - ($i * $dh)}] + if {$hue < 0.0} { + set hue [expr {360.0 + $hue}] + } + set rgbList [Hsv2rgb $hue 1.0 1.0] + set r [expr {int([lindex $rgbList 0] * 65535)}] + set g [expr {int([lindex $rgbList 1] * 65535)}] + set b [expr {int([lindex $rgbList 2] * 65535)}] + + set color [format "#%.4x%.4x%.4x" $r $g $b] + lappend colorMap $color + } + } + + } +} + +# setColormapColors -- +# Define the current colormap type +# Arguments: +# cmap Type of colormap +# Result: +# Updated the internal variable "colorMapType" +# Note: +# Possibly handle "custom" colormaps differently +# At present, if the user passes in a list (length > 1) +# rather than a string, then it is assumes that (s)he +# passed in a list of colors. +# +proc ::Plotchart::Colormap {cmap} { + variable colorMapType + variable colorMap + + switch $cmap { + + "grey" - + "gray" { set colorMapType $cmap } + + "jet" { set colorMapType $cmap } + + "hot" { set colorMapType $cmap } + + "cool" { set colorMapType $cmap } + + "hsv" { set colorMapType $cmap } + + default { + if {[string is alpha $cmap] == 1} { + puts "Colormap : Unknown colorMapType, $cmap. Using JET" + set colorMapType jet + + } else { + if {[llength $cmap] > 1} { + set colorMapType "custom" + set colorMap $cmap + } + } + } + } +} + + + +######################################################################## +# The following two routines were borrowed from : +# +# http://mini.net/cgi-bin/wikit/666.html +######################################################################## + +# Rgb2hsv -- +# +# Convert a color value from the RGB model to HSV model. +# +# Arguments: +# r g b the red, green, and blue components of the color +# value. The procedure expects, but does not +# ascertain, them to be in the range 0 to 1. +# +# Results: +# The result is a list of three real number values. The +# first value is the Hue component, which is in the range +# 0.0 to 360.0, or -1 if the Saturation component is 0. +# The following to values are Saturation and Value, +# respectively. They are in the range 0.0 to 1.0. +# +# Credits: +# This routine is based on the Pascal source code for an +# RGB/HSV converter in the book "Computer Graphics", by +# Baker, Hearn, 1986, ISBN 0-13-165598-1, page 304. +# +proc ::Plotchart::Rgb2hsv {r g b} { + set h [set s [set v 0.0]]] + set sorted [lsort -real [list $r $g $b]] + set v [expr {double([lindex $sorted end])}] + set m [lindex $sorted 0] + + set dist [expr {double($v-$m)}] + if {$v} { + set s [expr {$dist/$v}] + } + if {$s} { + set r' [expr {($v-$r)/$dist}] ;# distance of color from red + set g' [expr {($v-$g)/$dist}] ;# distance of color from green + set b' [expr {($v-$b)/$dist}] ;# distance of color from blue + if {$v==$r} { + if {$m==$g} { + set h [expr {5+${b'}}] + } else { + set h [expr {1-${g'}}] + } + } elseif {$v==$g} { + if {$m==$b} { + set h [expr {1+${r'}}] + } else { + set h [expr {3-${b'}}] + } + } else { + if {$m==$r} { + set h [expr {3+${g'}}] + } else { + set h [expr {5-${r'}}] + } + } + set h [expr {$h*60}] ;# convert to degrees + } else { + # hue is undefined if s == 0 + set h -1 + } + return [list $h $s $v] +} + +# Hsv2rgb -- +# +# Convert a color value from the HSV model to RGB model. +# +# Arguments: +# h s v the hue, saturation, and value components of +# the color value. The procedure expects, but +# does not ascertain, h to be in the range 0.0 to +# 360.0 and s, v to be in the range 0.0 to 1.0. +# +# Results: +# The result is a list of three real number values, +# corresponding to the red, green, and blue components +# of a color value. They are in the range 0.0 to 1.0. +# +# Credits: +# This routine is based on the Pascal source code for an +# HSV/RGB converter in the book "Computer Graphics", by +# Baker, Hearn, 1986, ISBN 0-13-165598-1, page 304. +# +proc ::Plotchart::Hsv2rgb {h s v} { + set v [expr {double($v)}] + set r [set g [set b 0.0]] + if {$h == 360} { set h 0 } + # if you feed the output of rgb2hsv back into this + # converter, h could have the value -1 for + # grayscale colors. Set it to any value in the + # valid range. + if {$h == -1} { set h 0 } + set h [expr {$h/60}] + set i [expr {int(floor($h))}] + set f [expr {$h - $i}] + set p1 [expr {$v*(1-$s)}] + set p2 [expr {$v*(1-($s*$f))}] + set p3 [expr {$v*(1-($s*(1-$f)))}] + switch -- $i { + 0 { set r $v ; set g $p3 ; set b $p1 } + 1 { set r $p2 ; set g $v ; set b $p1 } + 2 { set r $p1 ; set g $v ; set b $p3 } + 3 { set r $p1 ; set g $p2 ; set b $v } + 4 { set r $p3 ; set g $p1 ; set b $v } + 5 { set r $v ; set g $p1 ; set b $p2 } + } + return [list $r $g $b] +} + +# +# Define default colour maps +# +namespace eval ::Plotchart { + set contour_options(colourmap,rainbow) \ + {darkblue blue cyan green yellow orange red magenta} + set contour_options(colourmap,white-blue) \ + {white paleblue cyan blue darkblue} + + set contour_options(colourmap,detailed) { +#00000000ffff +#000035e4ffff +#00006bc9ffff +#0000a1aeffff +#0000d793ffff +#0000fffff285 +#0000ffffbca0 +#0000ffff86bc +#0000ffff50d7 +#0000ffff1af2 +#1af2ffff0000 +#50d7ffff0000 +#86bcffff0000 +#bca0ffff0000 +#f285ffff0000 +#ffffd7930000 +#ffffa1ae0000 +#ffff6bc90000 +#ffff35e40000 +#ffff00000000 +#ffff00000000 +} + set contour_options(colourmap) $contour_options(colourmap,detailed) +} +# End of plotcontour.tcl diff --git a/modules/plotchart/plotcontour.test b/modules/plotchart/plotcontour.test new file mode 100755 index 00000000..e52233e2 --- /dev/null +++ b/modules/plotchart/plotcontour.test @@ -0,0 +1,201 @@ +# Informal test for plotcontour +# +source plotchart.tcl + +######################################################################## + +proc cowboyhat {x y} { + set x1 [expr {$x/9.0}] + set y1 [expr {$y/9.0}] + + expr { 3.0 * (1.0-($x1*$x1+$y1*$y1))*(1.0-($x1*$x1+$y1*$y1)) } +} + + +# +# Main code +# +set choice 1 + +if {$choice == 0} { + +set x { {0.0 1.0 2.0 3.0} + {0.0 1.0 2.0 3.0} + {0.0 1.0 2.0 3.0} + {0.0 1.0 2.0 3.0} } + +set y { {0.0 0.0 0.0 0.0} + {1.0 1.0 1.0 1.0} + {2.0 2.0 2.0 2.0} + {3.0 3.0 3.0 3.0} } + + +set f { {0.0 0.0 2.0 3.0} + {0.0 0.0 2.0 3.0} + {2.0 2.0 3.0 4.0} + {3.0 3.0 4.0 5.0} } + +set contours [list 1.0 2.0 3.0 4.0 5.0 ] + +# set contours [list 1.0 1.3 1.6 2.0 2.3 2.6 3.0 3.3 3.6 4.0 4.3 4.6 5.0 5.3 ] + +set xlimits {0 3.5 0.5} +set ylimits {0 3.5 0.5} + +} + + +if {$choice == 1} { + +set x { {0.0 100.0 200.0} + {0.0 100.0 200.0} + {0.0 100.0 200.0} + {0.0 100.0 200.0}} +set y { {0.0 0.0 0.0} + {30.0 30.0 30.0} + {60.0 60.0 60.0} + {90.0 90.0 90.0}} +set f { {0.0 1.0 10.0} + { 0.0 30.0 30.0} + {10.0 60.0 60.0} + {30.0 90.0 90.0}} + +set contours [list \ + 0.0 \ + 5.2631578947 \ + 10.5263157895 \ + 15.7894736842 \ + 21.0526315789 \ + 26.3157894737 \ + 31.5789473684 \ + 36.8421052632 \ + 42.1052631579 \ + 47.3684210526 \ + 52.6315789474 \ + 57.8947368421 \ + 63.1578947368 \ + 68.4210526316 \ + 73.6842105263 \ + 78.9473684211 \ + 84.2105263158 \ + 89.4736842105 \ + 94.7368421053 \ + 100.0 \ + 105.263157895 \ + ] + + set xlimits {0 200 50} + set ylimits {0 100 20} + +} + +######################################################################## + +wm title . "Contour Demo : shade (jet colormap)" + +set c [canvas .c -background white \ + -width 500 -height 500] + +pack $c -fill both -side top + +set chart [::Plotchart::createXYPlot $c $xlimits $ylimits] + +::Plotchart::Colormap jet + +#$chart contourlines $x $y $f $contours +$chart contourfill $x $y $f $contours +#$chart contourbox $x $y $f $contours +$chart grid $x $y + +set t [toplevel .contourlines] +wm title $t "Contour Demo : contourlines (default colormap)" +set c [canvas $t.c -background white \ + -width 500 -height 500] +pack $c -fill both -side top + +set chart1 [::Plotchart::createXYPlot $c $xlimits $ylimits] +$chart1 grid $x $y +$chart1 contourlines $x $y $f $contours + + +set t [toplevel .hot] +wm title $t "Contour Demo : contourlines (hot colormap)" +set c [canvas $t.c -background white \ + -width 500 -height 500] +pack $c -fill both -side top + +set chart2 [::Plotchart::createXYPlot $c $xlimits $ylimits] +::Plotchart::Colormap hot +$chart2 contourfill $x $y $f $contours +$chart2 grid $x $y + + +set t [toplevel .gray] +wm title $t "Contour Demo : gray contourfill , jet contourlines" +set c [canvas $t.c -background white \ + -width 500 -height 500] +pack $c -fill both -side top + +set chart3 [::Plotchart::createXYPlot $c $xlimits $ylimits] +::Plotchart::Colormap gray +$chart3 contourfill $x $y $f $contours + +::Plotchart::Colormap jet +$chart3 contourlines $x $y $f $contours +$chart3 grid $x $y + + +set t [toplevel .cool] +wm title $t "Contour Demo : contourlines (cool colormap)" +set c [canvas $t.c -background white \ + -width 500 -height 500] +pack $c -fill both -side top + +set chart4 [::Plotchart::createXYPlot $c $xlimits $ylimits] +::Plotchart::Colormap cool +$chart4 contourfill $x $y $f $contours +$chart4 grid $x $y + + + +set t [toplevel .defcont] +wm title $t "Contour Demo : default contours (jet colormap)" +set c [canvas $t.c -background white \ + -width 500 -height 500] +pack $c -fill both -side top + +set chart5 [::Plotchart::createXYPlot $c $xlimits $ylimits] +::Plotchart::Colormap jet +$chart5 contourfill $x $y $f +$chart5 grid $x $y + + + +set t [toplevel .3dcontour] +wm title $t "Contour Demo : contours on a 3DPlot" +set c [canvas $t.c -background white \ + -width 500 -height 500] +pack $c -fill both -side top + +set xlimits {-10. 10. 10. } +set ylimits {-10. 10. 10. } +set zlimits { -5. 10. 5. } + +set zmin 0.0 +set zmax 3.0 + +set nc 51 +set dz [expr {($zmax - $zmin) / ($nc - 1)}] + +set contours {} +for {set cnt 1} {$cnt < $nc} {incr cnt} { + set zval [expr {$zmin + ($dz * ($cnt - 1))}] + lappend contours $zval +} + +set chart6 [::Plotchart::create3DPlot $c $xlimits $ylimits $zlimits] +::Plotchart::Colormap jet +$chart6 title "3D Plot" +$chart6 plotfuncont cowboyhat $contours + + From 1ec593add6353ad77782bb3a0a230329af843f7d Mon Sep 17 00:00:00 2001 From: Andreas Kupries Date: Sat, 5 Mar 2005 02:06:22 +0000 Subject: [PATCH 0056/1290] Imported contour plotting commands. By Mark Stucky, via Arjen Markus. Import patch changing fonts for popup dialogs, by David Welton Import of Bugfix ipentry by Marty Backe --- modules/ipentry/ipentry.tcl | 2 +- modules/plotchart/plotcontour.tcl | 3394 ++++++++++++++--------------- 2 files changed, 1698 insertions(+), 1698 deletions(-) diff --git a/modules/ipentry/ipentry.tcl b/modules/ipentry/ipentry.tcl index 20986b3c..31561c6b 100644 --- a/modules/ipentry/ipentry.tcl +++ b/modules/ipentry/ipentry.tcl @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: ipentry.tcl,v 1.4 2005/01/10 06:19:18 mgbacke Exp $ +# RCS: @(#) $Id: ipentry.tcl,v 1.5 2005/03/05 02:06:22 andreas_kupries Exp $ package provide ipentry 0.1 diff --git a/modules/plotchart/plotcontour.tcl b/modules/plotchart/plotcontour.tcl index 1b27610e..05fe1312 100755 --- a/modules/plotchart/plotcontour.tcl +++ b/modules/plotchart/plotcontour.tcl @@ -1,1697 +1,1697 @@ -# plotcontour.tcl -- -# Contour plotting test program for the Plotchart package -# -# Author: Mark Stucky -# -# The basic idea behind the method used for contouring within this sample -# is primarily based on : -# -# (1) "Contour Plots of Large Data Sets" by Chris Johnston -# Computer Language, May 1986 -# -# a somewhat similar method was also described in -# -# (2) "A Contouring Subroutine" by Paul D. Bourke -# BYTE, June 1987 -# http://astronomy.swin.edu.au/~pbourke/projection/conrec/ -# -# In (1) it is assumed that you have a N x M grid of data that you need -# to process. In order to generate a contour, each cell of the grid -# is handled without regard to it's neighbors. This is unlike many other -# contouring algorithms that follow the current contour line into -# neighboring cells in an attempt to produce "smoother" contours. -# -# In general the method described is: -# -# 1) for each four cornered cell of the grid, -# calculate the center of the cell (average of the four corners) -# -# data(i ,j) : Point (1) -# data(i+1,j) : Point (2) -# data(i+1,j+1) : Point (3) -# data(i ,j+1) : Point (4) -# center : Point (5) -# -# (4)-------------(3) -# | \ / | -# | \ / | -# | \ / | -# | \ / | -# | \ / | -# | (5) | -# | / \ | -# | / \ | -# | / \ | -# ^ | / \ | -# | | / \ | -# J (1)-------------(2) -# -# I -> -# -# This divides the cell into four triangles. -# -# 2) Each of the five points in the cell can be assigned a sign (+ or -) -# depending upon whether the point is above (+) the current contour -# or below (-). -# -# A contour will cross an edge whenever the points on the boundary of -# the edge are of an opposite sign. -# -# A few examples : -# -# (-) (-) (-) | (+) (-) (-) (+) | (-) -# \ _ \ -# \ / \ \ -# (-) - (-) | _ /(+) | - (+) - -# / / / \ -# / / / \ -# (-) | (+) (-) | (+) (+) | (-) (-) | (+) -# -# -# (Hopefully the "rough" character diagrams above give you the -# general idea) -# -# It turns out that there are 32 possibles combinations of + and - -# and therefore 32 basic paths through the cell. And if you swap -# the (+) and (-) in the diagram above, the "same" basic path is -# generated: -# -# (+) (+) (+) | (-) (+) (+) (-) | (+) -# \ _ \ -# \ / \ \ -# (+) - (+) | _ /(-) | - (-) - -# / / / \ -# / / / \ -# (+) | (-) (+) | (-) (-) | (+) (+) | (-) -# -# -# So, it turns out that there are 16 basic paths through the cell. -# -############################################################################### -# -# The original article/code worked on all four triangles together and -# generated one of the 16 paths. -# -# For this version of the code, I split the cell into the four triangles -# and handle each triangle individually. -# -# Doing it this way is slower than the above method for calculating the -# contour lines. But since it "simplifies" the code when doing "color filled" -# contours, I opted for the longer calculation times. -# -# -# AM: -# Introduce the following methods in createXYPlot: -# - grid Draw the grid (x,y needed) -# - contourlines Draw isolines (x,y,z needed) -# - contourfill Draw shades (x,y,z needed) -# - contourbox Draw uniformly coloured cells (x,y,z needed) -# -# This needs still to be done: -# - colourmap Set colours to be used (possibly interpolated) -# -# Note: -# To get the RGB values of a named colour: -# winfo rgb . color (divide by 256) -# -# The problem: -# What interface do we use? -# -# Changes: -# - Capitalised several proc names (to indicate they are private to -# the Plotchart package) -# - Changed the data structure from an array to a list of lists. -# This means: -# - No confusion about the start of indices -# - Lists can be passed as ordinary arguments -# - In principle they are faster, but that does not really -# matter here -# To do: -# - Absorb all global arrays into the Plotchart system of private data -# - Get rid of the bug in the shades algorithm ;) -# - -# DrawGrid -- -# Draw the grid as contained in the lists of coordinates -# Arguments: -# w Canvas to draw in -# x X-coordinates of grid points (list of lists) -# y Y-coordinates of grid points (list of lists) -# Result: -# None -# Side effect: -# Grid drawn as lines between the vertices -# Note: -# STILL TO DO -# A cell is only drawn if there are four well-defined -# corners. If the x or y coordinate is missing, the cell is -# skipped. -# -proc ::Plotchart::DrawGrid {w x y} { - - set maxrow [llength $x] - set maxcol [llength [lindex $x 0]] - - for {set i 0} {$i < $maxrow} {incr i} { - set xylist {} - for {set j 0} {$j < $maxcol} {incr j} { - lappend xylist [lindex $x $i $j] [lindex $y $i $j] - } - C_line $w $xylist black - } - - for {set j 0} {$j < $maxcol} {incr j} { - set xylist {} - for {set i 0} {$i < $maxrow} {incr i} { - lappend xylist [lindex $x $i $j] [lindex $y $i $j] - } - C_line $w $xylist black - } -} - -# DrawIsolines -- -# Draw isolines in the given grid -# Arguments: -# canv Canvas to draw in -# x X-coordinates of grid points (list of lists) -# y Y-coordinates of grid points (list of lists) -# f Values of the parameter on the grid cell corners -# cont List of contour classes (or empty to indicate -# automatic scaling -# Result: -# None -# Side effect: -# Isolines drawn -# Note: -# A cell is only drawn if there are four well-defined -# corners. If the x or y coordinate is missing or the value is -# missing, the cell is skipped. -# -proc ::Plotchart::DrawIsolines {canv x y f {cont {}} } { - variable contour_options - - set contour_options(simple_box_contour) 0 - set contour_options(filled_contour) 0 - -# DrawContour $canv $x $y $f 0.0 100.0 20.0 - DrawContour $canv $x $y $f $cont -} - -# DrawShades -- -# Draw filled contours in the given grid -# Arguments: -# canv Canvas to draw in -# x X-coordinates of grid points (list of lists) -# y Y-coordinates of grid points (list of lists) -# f Values of the parameter on the grid cell corners -# cont List of contour classes (or empty to indicate -# automatic scaling -# Result: -# None -# Side effect: -# Shades (filled contours) drawn -# Note: -# A cell is only drawn if there are four well-defined -# corners. If the x or y coordinate is missing or the value is -# missing, the cell is skipped. -# -proc ::Plotchart::DrawShades {canv x y f {cont {}} } { - variable contour_options - - set contour_options(simple_box_contour) 0 - set contour_options(filled_contour) 1 - -# DrawContour $canv $x $y $f 0.0 100.0 20.0 - DrawContour $canv $x $y $f $cont -} - -# DrawBox -- -# Draw filled cells in the given grid (colour chosen according -# to the _average_ of the four corner values) -# Arguments: -# canv Canvas to draw in -# x X-coordinates of grid points (list of lists) -# y Y-coordinates of grid points (list of lists) -# f Values of the parameter on the grid cell corners -# cont List of contour classes (or empty to indicate -# automatic scaling -# Result: -# None -# Side effect: -# Filled cells (quadrangles) drawn -# Note: -# A cell is only drawn if there are four well-defined -# corners. If the x or y coordinate is missing or the value is -# missing, the cell is skipped. -# -proc ::Plotchart::DrawBox {canv x y f {cont {}} } { - variable contour_options - - set contour_options(simple_box_contour) 1 - set contour_options(filled_contour) 0 - -# DrawContour $canv $x $y $f 0.0 100.0 20.0 - DrawContour $canv $x $y $f $cont -} - -# Draw3DFunctionContour -- -# Plot a function of x and y with a color filled contour -# Arguments: -# w Name of the canvas -# function Name of a procedure implementing the function -# cont contour levels -# Result: -# None -# Side effect: -# The plot of the function - given the grid -# -proc ::Plotchart::Draw3DFunctionContour { w function {cont {}} } { - variable scaling - variable contour_options - - set contour_options(simple_box_contour) 0 - set contour_options(filled_contour) 1 - set noTrans 0 - - ::Plotchart::setColormapColors [llength $cont] - - set nxcells $scaling($w,nxcells) - set nycells $scaling($w,nycells) - set xmin $scaling($w,xmin) - set xmax $scaling($w,xmax) - set ymin $scaling($w,ymin) - set ymax $scaling($w,ymax) - set dx [expr {($xmax-$xmin)/double($nxcells)}] - set dy [expr {($ymax-$ymin)/double($nycells)}] - - foreach {fill border} $scaling($w,colours) {break} - - # - # Draw the quadrangles making up the plot in the right order: - # first y from minimum to maximum - # then x from maximum to minimum - # - for { set j 0 } { $j < $nycells } { incr j } { - set y1 [expr {$ymin + $dy*$j}] - set y2 [expr {$y1 + $dy}] - for { set i $nxcells } { $i > 0 } { incr i -1 } { - set x2 [expr {$xmin + $dx*$i}] - set x1 [expr {$x2 - $dx}] - - set z11 [$function $x1 $y1] - set z12 [$function $x1 $y2] - set z21 [$function $x2 $y1] - set z22 [$function $x2 $y2] - - foreach {px11 py11} [coords3DToPixel $w $x1 $y1 $z11] {break} - foreach {px12 py12} [coords3DToPixel $w $x1 $y2 $z12] {break} - foreach {px21 py21} [coords3DToPixel $w $x2 $y1 $z21] {break} - foreach {px22 py22} [coords3DToPixel $w $x2 $y2 $z22] {break} - - set xb [list $px11 $px21 $px22 $px12] - set yb [list $py11 $py21 $py22 $py12] - set fb [list $z11 $z21 $z22 $z12 ] - - Box_contour $w $xb $yb $fb $cont $noTrans - - $w create line $px11 $py11 $px21 $py21 $px22 $py22 \ - $px12 $py12 $px11 $py11 \ - -fill $border - } - } -} - - -# DrawContour -- -# Routine that loops over the grid and delegates the actual drawing -# Arguments: -# canv Canvas to draw in -# x X-coordinates of grid points (list of lists) -# y Y-coordinates of grid points (list of lists) -# f Values of the parameter on the grid cell corners -# cont List of contour classes (or empty to indicate -# automatic scaling) -# Result: -# None -# Side effect: -# Isolines, shades or boxes drawn -# Note: -# A cell is only drawn if there are four well-defined -# corners. If the x or y coordinate is missing or the value is -# missing, the cell is skipped. -# -proc ::Plotchart::DrawContour {canv x y f cont} { - variable contour_options - variable colorMap - - # - # Construct the class-colour list - # - set cont [MakeContourClasses $f $cont] - - set fmin [lindex $cont 0 0] - set fmax [lindex $cont end 0] - set ncont [llength $cont] - - # Now that we know how many entries (ncont), create - # the colormap colors - # - # I moved this into MakeContourClasses... - # ::Plotchart::setColormapColors $ncont - - set maxrow [llength $x] - set maxcol [llength [lindex $x 0]] - - for {set i 0} {$i < $maxrow-1} {incr i} { - set i1 [expr {$i + 1}] - for {set j 0} {$j < $maxcol-1} {incr j} { - set j1 [expr {$j + 1}] - - set x1 [lindex $x $i1 $j] - set x2 [lindex $x $i $j] - set x3 [lindex $x $i $j1] - set x4 [lindex $x $i1 $j1] - - set y1 [lindex $y $i1 $j] - set y2 [lindex $y $i $j] - set y3 [lindex $y $i $j1] - set y4 [lindex $y $i1 $j1] - - set f1 [lindex $f $i1 $j] - set f2 [lindex $f $i $j] - set f3 [lindex $f $i $j1] - set f4 [lindex $f $i1 $j1] - - set xb [list $x1 $x2 $x3 $x4] - set yb [list $y1 $y2 $y3 $y4] - set fb [list $f1 $f2 $f3 $f4] - - if { [lsearch $fb {}] >= 0 || - [lsearch $xb {}] >= 0 || - [lsearch $yb {}] >= 0 } { - continue - } - - Box_contour $canv $xb $yb $fb $cont - } - } -} - -# Box_contour -- -# Draw a filled box -# Arguments: -# canv Canvas to draw in -# xb X-coordinates of the four corners -# yb Y-coordinates of the four corners -# fb Values of the parameter on the four corners -# cont List of contour classes and colours -# Result: -# None -# Side effect: -# Box drawn for a single cell -# -proc ::Plotchart::Box_contour {canv xb yb fb cont {doTrans 1}} { - variable colorMap - variable contour_options - - foreach {x1 x2 x3 x4} $xb {} - foreach {y1 y2 y3 y4} $yb {} - foreach {f1 f2 f3 f4} $fb {} - - set xc [expr {($x1 + $x2 + $x3 + $x4) * 0.25}] - set yc [expr {($y1 + $y2 + $y3 + $y4) * 0.25}] - set fc [expr {($f1 + $f2 + $f3 + $f4) * 0.25}] - - if {$contour_options(simple_box_contour)} { - - set fmin [lindex $cont 0] - set fmax [lindex $cont end] - set ncont [llength $cont] - - set ic 0 - for {set i 0} {$i < $ncont} {incr i} { - set ff [lindex $cont $i 0] - if {$ff <= $fc} { - set ic $i - } - } - - set xylist [list $x1 $y1 $x2 $y2 $x3 $y3 $x4 $y4] - - # canvasPlot::polygon $win $xylist -fill $cont($ic,color) - ### C_polygon $canv $xylist $cont($ic,color) - C_polygon $canv $xylist [lindex $cont $ic 1] - - } else { - -#debug# puts "Tri_contour 1)" - Tri_contour $canv $x1 $y1 $f1 $x2 $y2 $f2 $xc $yc $fc $cont $doTrans - -#debug# puts "Tri_contour 2)" - Tri_contour $canv $x2 $y2 $f2 $x3 $y3 $f3 $xc $yc $fc $cont $doTrans - -#debug# puts "Tri_contour 3)" - Tri_contour $canv $x3 $y3 $f3 $x4 $y4 $f4 $xc $yc $fc $cont $doTrans - -#debug# puts "Tri_contour 4)" - Tri_contour $canv $x4 $y4 $f4 $x1 $y1 $f1 $xc $yc $fc $cont $doTrans - - } - -} - -# Tri_contour -- -# Draw isolines or shades in a triangle -# Arguments: -# canv Canvas to draw in -# x1,x2,x3 X-coordinate of the three corners -# y1,y2,y3 Y-coordinates of the three corners -# f1,f2,f3 Values of the parameter on the three corners -# cont List of contour classes and colours -# Result: -# None -# Side effect: -# Isolines/shades drawn for a single triangle -# -proc ::Plotchart::Tri_contour { canv x1 y1 f1 x2 y2 f2 x3 y3 f3 cont {doTrans 1} } { - variable contour_options - variable colorMap - - set ncont [llength $cont] - - - # Find the min/max function values for this triangle - # - set tfmin [min $f1 $f2 $f3] - set tfmax [max $f1 $f2 $f3] - - # Based on the above min/max, figure out which - # contour levels/colors that bracket this interval - # - set imin 0 - set imax 0 ;#mbs# - for {set i 0} {$i < $ncont} {incr i} { - set ff [lindex $cont $i] ; ### set ff $cont($i,fval) - if {$ff <= $tfmin} { - set imin $i - set imax $i - } - if { $ff <= $tfmax} { - set imax $i - } - } - - set vertlist {} - - # Loop over all contour levels of interest for this triangle - # - for {set ic $imin} {$ic <= $imax} {incr ic} { - - # Get the value for this contour level - # - set ff [lindex $cont $ic 0] ;### set ff $cont($ic,fval) - - set xylist {} - set pxylist {} - - # Classify the triangle based on whether the functional values, f1,f2,f3 - # are above (+), below (-), or equal (=) to the current contour level ff - # - set s1 [::Plotchart::setFLevel $f1 $ff] - set s2 [::Plotchart::setFLevel $f2 $ff] - set s3 [::Plotchart::setFLevel $f3 $ff] - - set class "$s1$s2$s3" - - # Describe class here... - - # ( - - - ) : Case A, - # ( - - = ) : Case B, color a point, do nothing - # ( - - + ) : Case C, contour between {23}-{31} - # ( - = - ) : Case D, color a point, do nothing - # ( - = = ) : Case E, contour line between 2-3 - # ( - = + ) : Case F, contour between 2-{31} - # ( - + - ) : Case G, contour between {12}-{23} - # ( - + = ) : Case H, contour between {12}-3 - # ( - + + ) : Case I, contour between {12}-{31} - # ( = - - ) : Case J, color a point, do nothing - # ( = - = ) : Case K, contour line between 1-3 - # ( = - + ) : Case L, contour between 1-{23} - # ( = = - ) : Case M, contour line between 1-2 - # ( = = = ) : Case N, fill full triangle, return - # ( = = + ) : Case M, - # ( = + - ) : Case L, - # ( = + = ) : Case K, - # ( = + + ) : Case J, - # ( + - - ) : Case I, - # ( + - = ) : Case H, - # ( + - + ) : Case G, - # ( + = - ) : Case F, - # ( + = = ) : Case E, - # ( + = + ) : Case D, - # ( + + - ) : Case C, - # ( + + = ) : Case B, - # ( + + + ) : Case A, - - - switch -- $class { - - ############### Case A ############### - - "---" { -#debug# puts "class A = $class , $ic , $ff" - if {$contour_options(filled_contour)} { - set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] - C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans - } - return - } - - "+++" { -#debug# puts "class A = $class , $ic , $ff" - if {$contour_options(filled_contour)} { - if {$ic == $imax} { - set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] - set ictmp [expr {$ic + 1}] - C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans - return - } - } - } - - ############### Case N ############### - - "===" { -#debug# puts "class N = $class , $ic , $ff" - if {$contour_options(filled_contour)} { - set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] - C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans - } - return - } - - ############### Case B ############### - - "--=" { -#debug# puts "class B = $class , $ic , $ff" - if {$contour_options(filled_contour)} { - set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] - C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans - } - return - } - - "++=" { -#debug# puts "class B= $class , $ic , $ff , do nothing unless ic == imax" - if {$ic == $imax} { - if {$contour_options(filled_contour)} { - set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] - set ictmp [expr {$ic + 1}] - C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans - return - } - } - } - - ############### Case D ############### - - "-=-" { -#debug# puts "class D = $class , $ic , $ff" - if {$contour_options(filled_contour)} { - set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] - C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans - } - return - } - - "+=+" { -#debug# puts "class D = $class , $ic , $ff , do nothing unless ic == imax" - if {$ic == $imax} { - if {$contour_options(filled_contour)} { - set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] - set ictmp [expr {$ic + 1}] - C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans - return - } - } - } - - ############### Case J ############### - - "=--" { -#debug# puts "class J = $class , $ic , $ff" - if {$contour_options(filled_contour)} { - set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] - C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans - } - return - } - - "=++" { -#debug# puts "class J = $class , $ic , $ff , do nothing unless ic == imax" - if {$ic == $imax} { - if {$contour_options(filled_contour)} { - set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] - set ictmp [expr {$ic + 1}] - C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans - return - } - } - } - - ############### Case K ############### - - "=-=" { -#debug# puts "class K = $class , $ic , $ff" - set xylist [list $x1 $y1 $x3 $y3] - if {$contour_options(filled_contour)} { - set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] - C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans - } - C_line $canv $xylist [lindex $colorMap $ic] $doTrans - return - - } - - "=+=" { -#debug# puts "class K = $class , $ic , $ff" - set xylist [list $x1 $y1 $x3 $y3] - if {$ic == $imax} { - if {$contour_options(filled_contour)} { - set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] - set ictmp [expr {$ic + 1}] - C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans - return - } - C_line $canv $xylist [lindex $colorMap $ic] $doTrans - - } else { - C_line $canv $xylist [lindex $colorMap $ic] $doTrans - } - } - - ############### Case E ############### - - "-==" { -#debug# puts "class E = $class , $ic , $ff" - set xylist [list $x2 $y2 $x3 $y3] - if {$contour_options(filled_contour)} { - set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] - C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans - } - C_line $canv $xylist [lindex $colorMap $ic] $doTrans - return - } - - "+==" { -#debug# puts "class E = $class , $ic , $ff" - set xylist [list $x2 $y2 $x3 $y3] - if {$ic == $imax} { - if {$contour_options(filled_contour)} { - set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] - set ictmp [expr {$ic + 1}] - C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans - return - } - C_line $canv $xylist [lindex $colorMap $ic] $doTrans - - } else { - C_line $canv $xylist [lindex $colorMap $ic] $doTrans - } - } - - ############### Case M ############### - - "==-" { -#debug# puts "class M = $class , $ic , $ff" - set xylist [list $x1 $y1 $x2 $y2] - if {$contour_options(filled_contour)} { - set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] - C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans - } - C_line $canv $xylist [lindex $colorMap $ic] $doTrans - return - } - - "==+" { -#debug# puts "class M = $class , $ic , $ff" - set xylist [list $x1 $y1 $x2 $y2] - if {$ic == $imax} { - if {$contour_options(filled_contour)} { - set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] - set ictmp [expr {$ic + 1}] - C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans - return - } - C_line $canv $xylist [lindex $colorMap $ic] $doTrans - - } else { - C_line $canv $xylist [lindex $colorMap $ic] $doTrans - } - - } - - ############### Case F ############### - - "-=+" { -#debug# puts "class F = $class , $ic , $ff" - set xylist [list $x2 $y2] - set xyf2 [fintpl $x3 $y3 $f3 $x1 $y1 $f1 $ff] - foreach {xx yy} $xyf2 {} - lappend xylist $xx $yy - - if {$contour_options(filled_contour)} { - set pxylist $xylist - lappend pxylist $x1 $y1 - C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans - } - C_line $canv $xylist [lindex $colorMap $ic] $doTrans - - set x1 $xx; set y1 $yy; set f1 $ff - - if {$ic == $imax} { - if {$contour_options(filled_contour)} { - set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] - set ictmp [expr {$ic + 1}] - C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans - return - } - } - - } - - "+=-" { -#debug# puts "class F = $class , $ic , $ff" - set xylist [list $x2 $y2] - set xyf2 [fintpl $x3 $y3 $f3 $x1 $y1 $f1 $ff] - foreach {xx yy} $xyf2 {} - lappend xylist $xx $yy - - if {$contour_options(filled_contour)} { - set pxylist $xylist - lappend pxylist $x3 $y3 - C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans - } - C_line $canv $xylist [lindex $colorMap $ic] $doTrans - - set x3 $xx; set y3 $yy; set f3 $ff - - if {$ic == $imax} { - if {$contour_options(filled_contour)} { - set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] - set ictmp [expr {$ic + 1}] - C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans - return - } - } - - } - - ############### Case H ############### - - "-+=" { -#debug# puts "class H = $class , $ic , $ff" - set xylist [fintpl $x1 $y1 $f1 $x2 $y2 $f2 $ff] - foreach {xx yy} $xylist {} - lappend xylist $x3 $y3 - - if {$contour_options(filled_contour)} { - set pxylist $xylist - lappend pxylist $x1 $y1 - C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans - } - C_line $canv $xylist [lindex $colorMap $ic] $doTrans - - set x1 $xx; set y1 $yy; set f1 $ff - - if {$ic == $imax} { - if {$contour_options(filled_contour)} { - set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] - set ictmp [expr {$ic + 1}] - C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans - return - } - } - - } - - "+-=" { -#debug# puts "class H = $class , $ic , $ff" - set xylist [fintpl $x1 $y1 $f1 $x2 $y2 $f2 $ff] - foreach {xx yy} $xylist {} - lappend xylist $x3 $y3 - C_line $canv $xylist [lindex $colorMap $ic] $doTrans - - if {$contour_options(filled_contour)} { - set pxylist $xylist - lappend pxylist $x2 $y2 - C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans - } - C_line $canv $xylist [lindex $colorMap $ic] $doTrans - - set x2 $xx; set y2 $yy; set f2 $ff - - if {$ic == $imax} { - if {$contour_options(filled_contour)} { - set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] - set ictmp [expr {$ic + 1}] - C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans - return - } - } - - } - - ############### Case L ############### - - "=-+" { -#debug# puts "class L = $class , $ic , $ff" - set xylist [fintpl $x2 $y2 $f2 $x3 $y3 $f3 $ff] - foreach {xx yy} $xylist {} - lappend xylist $x1 $y1 - C_line $canv $xylist [lindex $colorMap $ic] $doTrans - - if {$contour_options(filled_contour)} { - set pxylist $xylist - lappend pxylist $x2 $y2 - C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans - } - C_line $canv $xylist [lindex $colorMap $ic] $doTrans - - set x2 $xx; set y2 $yy; set f2 $ff - - if {$ic == $imax} { - if {$contour_options(filled_contour)} { - set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] - set ictmp [expr {$ic + 1}] - C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans - return - } - } - - } - - "=+-" { -#debug# puts "class L = $class , $ic , $ff" - set xylist [fintpl $x2 $y2 $f2 $x3 $y3 $f3 $ff] - foreach {xx yy} $xylist {} - lappend xylist $x1 $y1 - C_line $canv $xylist [lindex $colorMap $ic] $doTrans - - if {$contour_options(filled_contour)} { - set pxylist $xylist - lappend pxylist $x3 $y3 - C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans - } - C_line $canv $xylist [lindex $colorMap $ic] $doTrans - - set x3 $xx; set y3 $yy; set f3 $ff - - if {$ic == $imax} { - if {$contour_options(filled_contour)} { - set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] - set ictmp [expr {$ic + 1}] - C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans - return - } - } - - } - - ############### Case C ############### - - "--+" { -#debug# puts "class C = $class , $ic , $ff" - set xyf1 [fintpl $x2 $y2 $f2 $x3 $y3 $f3 $ff] - set xyf2 [fintpl $x3 $y3 $f3 $x1 $y1 $f1 $ff] - set xylist $xyf1 - foreach {xx1 yy1} $xyf1 {} - foreach {xx2 yy2} $xyf2 {} - lappend xylist $xx2 $yy2 - if {$contour_options(filled_contour)} { - set pxylist $xylist - lappend pxylist $x1 $y1 $x2 $y2 - C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans - if {$ic == $imax} { - set pxylist $xylist - lappend pxylist $x3 $y3 - C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans - } - } - C_line $canv $xylist [lindex $colorMap $ic] $doTrans - set oldlist {} - set x1 $xx1; set y1 $yy1; set f1 $ff - set x2 $xx2; set y2 $yy2; set f2 $ff - if {$ic == $imax} { - if {$contour_options(filled_contour)} { - set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] - set ictmp [expr {$ic + 1}] - C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans - return - } - } - } - - "++-" { -#debug# puts "class C = $class , $ic , $ff" - set xyf1 [fintpl $x2 $y2 $f2 $x3 $y3 $f3 $ff] - set xyf2 [fintpl $x3 $y3 $f3 $x1 $y1 $f1 $ff] - set xylist $xyf1 - foreach {xx1 yy1} $xyf1 {} - foreach {xx2 yy2} $xyf2 {} - lappend xylist $xx2 $yy2 - if {$contour_options(filled_contour)} { - set pxylist $xylist - lappend pxylist $x3 $y3 - C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans - } - - if {$ic == $imax} { - if {$contour_options(filled_contour)} { - set pxylist $xylist - lappend pxylist $x1 $y1 $x2 $y2 - set ictmp [expr {$ic + 1}] - C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans - } - - } else { - -#debug# puts "call Tri_contour : 1) $class" -#debug# puts " : $xx1 $yy1 $ff $xx2 $yy2 $ff $x1 $y1 $f1" - Tri_contour $canv $xx1 $yy1 $ff $xx2 $yy2 $ff $x1 $y1 $f1 $cont $doTrans - -#debug# puts "call Tri_contour : 2) $class" -#debug# puts " : $xx1 $yy1 $ff $x1 $y1 $f1 $x2 $y2 $f2" - Tri_contour $canv $xx1 $yy1 $ff $x1 $y1 $f1 $x2 $y2 $f2 $cont $doTrans - - } - C_line $canv $xylist [lindex $colorMap $ic] $doTrans - return - - } - - ############### Case G ############### - - "-+-" { -#debug# puts "class G = $class , $ic , $ff" - set xyf1 [fintpl $x1 $y1 $f1 $x2 $y2 $f2 $ff] - set xyf2 [fintpl $x2 $y2 $f2 $x3 $y3 $f3 $ff] - set xylist $xyf1 - foreach {xx1 yy1} $xyf1 {} - foreach {xx2 yy2} $xyf2 {} - lappend xylist $xx2 $yy2 - if {$contour_options(filled_contour)} { - set pxylist $xylist - lappend pxylist $x3 $y3 $x1 $y1 - C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans - if {$ic == $imax} { - set pxylist $xylist - lappend pxylist $x2 $y2 - C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans - } - } - C_line $canv $xylist [lindex $colorMap $ic] $doTrans - set oldlist {} - set x1 $xx1; set y1 $yy1; set f1 $ff - set x3 $xx2; set y3 $yy2; set f3 $ff - - if {$ic == $imax} { - if {$contour_options(filled_contour)} { - set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] - set ictmp [expr {$ic + 1}] - C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans - return - } - } - - } - - "+-+" { -#debug# puts "class G = $class , $ic , $ff" - set xyf1 [fintpl $x1 $y1 $f1 $x2 $y2 $f2 $ff] - set xyf2 [fintpl $x2 $y2 $f2 $x3 $y3 $f3 $ff] - foreach {xx1 yy1} $xyf1 {} - foreach {xx2 yy2} $xyf2 {} - set xylist $xyf1 - lappend xylist $xx2 $yy2 - if {$contour_options(filled_contour)} { - set pxylist $xylist - lappend pxylist $x2 $y2 - C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans - } - - if {$ic == $imax} { - if {$contour_options(filled_contour)} { - set pxylist $xylist - lappend pxylist $x3 $y3 $x1 $y1 - set ictmp [expr {$ic + 1}] - C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans - } - - } else { - -#debug# puts "call Tri_contour : 1) $class" -#debug# puts " : $xx1 $yy1 $ff $xx2 $yy2 $ff $x3 $y3 $f3" - Tri_contour $canv $xx1 $yy1 $ff $xx2 $yy2 $ff $x3 $y3 $f3 $cont $doTrans - -#debug# puts "call Tri_contour : 2) $class" -#debug# puts " : $xx1 $yy1 $ff $x3 $y3 $f3 $x1 $y1 $f1" - Tri_contour $canv $xx1 $yy1 $ff $x3 $y3 $f3 $x1 $y1 $f1 $cont $doTrans - } - C_line $canv $xylist [lindex $colorMap $ic] $doTrans - return - - } - - ############### Case I ############### - - "+--" { -#debug# puts "class I = $class , $ic , $ff" - set xyf1 [fintpl $x1 $y1 $f1 $x2 $y2 $f2 $ff] - set xyf2 [fintpl $x3 $y3 $f3 $x1 $y1 $f1 $ff] - set xylist $xyf1 - foreach {xx1 yy1} $xyf1 {} - foreach {xx2 yy2} $xyf2 {} - lappend xylist $xx2 $yy2 - if {$contour_options(filled_contour)} { - set pxylist $xylist - lappend pxylist $x3 $y3 $x2 $y2 - C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans - if {$ic == $imax} { - set pxylist $xylist - lappend pxylist $x1 $y1 - C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans - } - } - C_line $canv $xylist [lindex $colorMap $ic] $doTrans - set oldlist {} - set x2 $xx1; set y2 $yy1; set f2 $ff - set x3 $xx2; set y3 $yy2; set f3 $ff - - if {$ic == $imax} { - if {$contour_options(filled_contour)} { - set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] - set ictmp [expr {$ic + 1}] - C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans - return - } - } - - } - - "-++" { -#debug# puts "class I = $class , $ic , $ff" - set xyf1 [fintpl $x1 $y1 $f1 $x2 $y2 $f2 $ff] - set xyf2 [fintpl $x3 $y3 $f3 $x1 $y1 $f1 $ff] - foreach {xx1 yy1} $xyf1 {} - foreach {xx2 yy2} $xyf2 {} - set xylist $xyf1 - lappend xylist $xx2 $yy2 - if {$contour_options(filled_contour)} { - set pxylist $xylist - lappend pxylist $x1 $y1 - C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans - } - - if {$ic == $imax} { - if {$contour_options(filled_contour)} { - set pxylist $xylist - lappend pxylist $x3 $y3 $x2 $y2 - set ictmp [expr {$ic + 1}] - C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans - } - - } else { - -#debug# puts "call Tri_contour : 1) $class" -#debug# puts " : $xx1 $yy1 $ff $xx2 $yy2 $ff $x3 $y3 $f3" - Tri_contour $canv $xx1 $yy1 $ff $xx2 $yy2 $ff $x3 $y3 $f3 $cont $doTrans - -#debug# puts "call Tri_contour : 2) $class" -#debug# puts " : $xx1 $yy1 $ff $x3 $y3 $f3 $x2 $y2 $f2" - Tri_contour $canv $xx1 $yy1 $ff $x3 $y3 $f3 $x2 $y2 $f2 $cont $doTrans - } - C_line $canv $xylist [lindex $colorMap $ic] $doTrans - return - - } - - } - - } -} - -# setFLevel -- -# Auxiliary function: used to classify one functional value to another -# Arguments: -# f1 Second break point and value -# f2 Value to find -# Result: -# + f1 > f2 -# = f1 = f2 -# - f1 < f2 -# -proc ::Plotchart::setFLevel {f1 f2} { - if {$f1 > $f2} { - return "+" - } else { - if {$f1 < $f2} { - return "-" - } else { - return "=" - } - } -} - -# fintpl -- -# Auxiliary function: inverse interpolation -# Arguments: -# x1,y1,f1 First break point and value -# x2,y2,f2 Second break point and value -# ff Value to find -# Result: -# x,y coordinates of point with that value -# -proc ::Plotchart::fintpl {x1 y1 f1 x2 y2 f2 ff} { - - if {[expr {$f2 - $f1}] != 0.0} { - set xx [expr {$x1 + (($ff - $f1)*($x2 - $x1)/($f2 - $f1))}] - set yy [expr {$y1 + (($ff - $f1)*($y2 - $y1)/($f2 - $f1))}] - } else { - - # If the logic was handled correctly above, this point - # should never be reached. - # - # puts "FINTPL : f1 == f2 : x1,y1 : $x1 , $y1 : x2,y2 : $x2 , $y2" - set xx $x1 - set yy $y1 - } - - set xmin [min $x1 $x2] - set xmax [max $x1 $x2] - set ymin [min $y1 $y2] - set ymax [max $y1 $y2] - - if {$xx < $xmin} { set xx $xmin } - if {$xx > $xmax} { set xx $xmax } - if {$yy < $ymin} { set yy $ymin } - if {$yy > $ymax} { set yy $ymax } - - return [list $xx $yy] -} - -# min -- -# Auxiliary function: find the minimum of the arguments -# Arguments: -# val First value -# args All others -# Result: -# Minimum over the arguments -# -proc ::Plotchart::min { val args } { - set min $val - foreach val $args { - if { $val < $min } { - set min $val - } - } - return $min -} - -# max -- -# Auxiliary function: find the maximum of the arguments -# Arguments: -# val First value -# args All others -# Result: -# Maximum over the arguments -# -proc ::Plotchart::max { val args } { - set max $val - foreach val $args { - if { $val > $max } { - set max $val - } - } - return $max -} - -# C_line -- -# Draw a line -# Arguments: -# canv Canvas to draw in -# xylist List of raw coordinates -# color Chosen colour -# args Any additional arguments (for line style and such) -# Result: -# None -# -proc ::Plotchart::C_line {canv xylist color {doTrans 1} } { - - if {$doTrans} { - set wxylist {} - foreach {xx yy} $xylist { - foreach {pxcrd pycrd} [::Plotchart::coordsToPixel $canv $xx $yy] {break} - lappend wxylist $pxcrd $pycrd - } - eval "$canv create line $wxylist -fill $color" - - } else { - $canv create line $xylist -fill $color - } -} - -# C_polygon -- -# Draw a polygon -# Arguments: -# canv Canvas to draw in -# xylist List of raw coordinates -# color Chosen colour -# args Any additional arguments (for line style and such) -# Result: -# None -# -proc ::Plotchart::C_polygon {canv xylist color {doTrans 1}} { - - if {$doTrans} { - set wxylist {} - foreach {xx yy} $xylist { - foreach {pxcrd pycrd} [::Plotchart::coordsToPixel $canv $xx $yy] {break} - lappend wxylist $pxcrd $pycrd - } - eval "$canv create polygon $wxylist -fill $color" - - } else { - $canv create polygon $xylist -fill $color - } -} - -# MakeContourClasses -- -# Return contour classes and colours -# Arguments: -# values List of values -# classes Given list of classes or class/colours -# Result: -# List of pairs of class limits and colours -# Note: -# This should become more sophisticated! -# -proc ::Plotchart::MakeContourClasses {values classes} { - variable contour_options - variable colorMap - - if { [llength $classes] == 0 } { - set min {} - set max {} - foreach row $values { - foreach v $row { - if { $v == {} } {continue} - - if { $min == {} || $min > $v } { - set min $v - } - - if { $max == {} || $max < $v } { - set max $v - } - } - } - - foreach {xmin xmax xstep} [determineScale $min $max] {break} - - # - # The contour classes must encompass all values - # There might be a problem with border cases - # - set classes {} - set x $xmin - - while { $x < $xmax+0.5*$xstep } { - #mbs# lappend classes [list $x] - set x [expr {$x+$xstep}] - lappend classes [list $x] - } - - # Now that we know how many entries (ncont), create - # the colormap colors - # - ::Plotchart::setColormapColors [expr [llength $classes] + 1] - - } elseif { [llength [lindex $classes 0]] == 1 } { - #mbs# Changed the above line from " == 2 " to " == 1 " - ::Plotchart::setColormapColors [llength $classes] - return $classes - } - - # - # Add the colours - # -##### set cont {} -##### set c 0 -##### -##### foreach x $classes { -##### set col [lindex $contour_options(colourmap) $c] -##### if { $col == {} } { -##### set c 0 -##### set col [lindex $contour_options(colourmap) $c] -##### } -##### lappend cont [list $x $col] -##### incr c -##### } -##### -##### return $cont - - puts "classes (cont) : $classes" - - return $classes -} - - -# setColormapColors -- -# Auxiliary function: Based on the current colormap type -# create a colormap with requested number of entries -# Arguments: -# ncont Number of colors in the colormap -# Result: -# List of colours -# -proc ::Plotchart::setColormapColors {ncont} { - variable colorMapType - variable colorMap - -#debug# puts "SetColormapColors : ncont = $ncont" - - # Note : The default colormap is "jet" - - switch $colorMapType { - - custom { - return - } - - hsv { - set hueStart 0.0 - set hueEnd 240.0 - set colorMap {} - - for {set i 0} {$i <= $ncont} {incr i} { - set dh [expr {($hueStart - $hueEnd) / ($ncont - 1)}] - set hue [expr {$hueStart - ($i * $dh)}] - if {$hue < 0.0} { - set hue [expr {360.0 + $hue}] - } - set rgbList [Hsv2rgb $hue 1.0 1.0] - set r [expr {int([lindex $rgbList 0] * 65535)}] - set g [expr {int([lindex $rgbList 1] * 65535)}] - set b [expr {int([lindex $rgbList 2] * 65535)}] - - set color [format "#%.4x%.4x%.4x" $r $g $b] - lappend colorMap $color - } - } - - hot { - set colorMap {} - set nc1 [expr {int($ncont * 0.33)}] - set nc2 [expr {int($ncont * 0.67)}] - - for {set i 0} {$i <= $ncont} {incr i} { - - if {$i <= $nc1} { - set fval [expr { double($i) / (double($nc1)) } ] - set r [expr {int($fval * 65535)}] - set g 0 - set b 0 - } else { - if {$i <= $nc2} { - set fval [expr { double($i-$nc1) / (double($nc2-$nc1)) } ] - set r 65535 - set g [expr {int($fval * 65535)}] - set b 0 - } else { - set fval [expr { double($i-$nc2) / (double($ncont-$nc2)) } ] - set r 65535 - set g 65535 - set b [expr {int($fval * 65535)}] - } - } - set color [format "#%.4x%.4x%.4x" $r $g $b] - lappend colorMap $color - } - } - - cool { - set colorMap {} - - for {set i 0} {$i <= $ncont} {incr i} { - - set fval [expr { double($i) / (double($ncont)-1) } ] - set val [expr { 1.0 - $fval }] - - set r [expr {int($fval * 65535)}] - set g [expr {int($val * 65535)}] - set b 65535 - - set color [format "#%.4x%.4x%.4x" $r $g $b] - lappend colorMap $color - } - } - - grey - - gray { - set colorMap {} - - for {set i 0} {$i <= $ncont} {incr i} { - - set fval [expr { double($i) / (double($ncont)-1) } ] - set val [expr {0.4 + (0.5 * $fval) }] - - set r [expr {int($val * 65535)}] - set g [expr {int($val * 65535)}] - set b [expr {int($val * 65535)}] - - set color [format "#%.4x%.4x%.4x" $r $g $b] - lappend colorMap $color - } - } - - jet - - default { - set hueStart 240.0 - set hueEnd 0.0 - set colorMap {} - - for {set i 0} {$i <= $ncont} {incr i} { - set dh [expr {($hueStart - $hueEnd) / ($ncont - 1)}] - set hue [expr {$hueStart - ($i * $dh)}] - if {$hue < 0.0} { - set hue [expr {360.0 + $hue}] - } - set rgbList [Hsv2rgb $hue 1.0 1.0] - set r [expr {int([lindex $rgbList 0] * 65535)}] - set g [expr {int([lindex $rgbList 1] * 65535)}] - set b [expr {int([lindex $rgbList 2] * 65535)}] - - set color [format "#%.4x%.4x%.4x" $r $g $b] - lappend colorMap $color - } - } - - } -} - -# setColormapColors -- -# Define the current colormap type -# Arguments: -# cmap Type of colormap -# Result: -# Updated the internal variable "colorMapType" -# Note: -# Possibly handle "custom" colormaps differently -# At present, if the user passes in a list (length > 1) -# rather than a string, then it is assumes that (s)he -# passed in a list of colors. -# -proc ::Plotchart::Colormap {cmap} { - variable colorMapType - variable colorMap - - switch $cmap { - - "grey" - - "gray" { set colorMapType $cmap } - - "jet" { set colorMapType $cmap } - - "hot" { set colorMapType $cmap } - - "cool" { set colorMapType $cmap } - - "hsv" { set colorMapType $cmap } - - default { - if {[string is alpha $cmap] == 1} { - puts "Colormap : Unknown colorMapType, $cmap. Using JET" - set colorMapType jet - - } else { - if {[llength $cmap] > 1} { - set colorMapType "custom" - set colorMap $cmap - } - } - } - } -} - - - -######################################################################## -# The following two routines were borrowed from : -# -# http://mini.net/cgi-bin/wikit/666.html -######################################################################## - -# Rgb2hsv -- -# -# Convert a color value from the RGB model to HSV model. -# -# Arguments: -# r g b the red, green, and blue components of the color -# value. The procedure expects, but does not -# ascertain, them to be in the range 0 to 1. -# -# Results: -# The result is a list of three real number values. The -# first value is the Hue component, which is in the range -# 0.0 to 360.0, or -1 if the Saturation component is 0. -# The following to values are Saturation and Value, -# respectively. They are in the range 0.0 to 1.0. -# -# Credits: -# This routine is based on the Pascal source code for an -# RGB/HSV converter in the book "Computer Graphics", by -# Baker, Hearn, 1986, ISBN 0-13-165598-1, page 304. -# -proc ::Plotchart::Rgb2hsv {r g b} { - set h [set s [set v 0.0]]] - set sorted [lsort -real [list $r $g $b]] - set v [expr {double([lindex $sorted end])}] - set m [lindex $sorted 0] - - set dist [expr {double($v-$m)}] - if {$v} { - set s [expr {$dist/$v}] - } - if {$s} { - set r' [expr {($v-$r)/$dist}] ;# distance of color from red - set g' [expr {($v-$g)/$dist}] ;# distance of color from green - set b' [expr {($v-$b)/$dist}] ;# distance of color from blue - if {$v==$r} { - if {$m==$g} { - set h [expr {5+${b'}}] - } else { - set h [expr {1-${g'}}] - } - } elseif {$v==$g} { - if {$m==$b} { - set h [expr {1+${r'}}] - } else { - set h [expr {3-${b'}}] - } - } else { - if {$m==$r} { - set h [expr {3+${g'}}] - } else { - set h [expr {5-${r'}}] - } - } - set h [expr {$h*60}] ;# convert to degrees - } else { - # hue is undefined if s == 0 - set h -1 - } - return [list $h $s $v] -} - -# Hsv2rgb -- -# -# Convert a color value from the HSV model to RGB model. -# -# Arguments: -# h s v the hue, saturation, and value components of -# the color value. The procedure expects, but -# does not ascertain, h to be in the range 0.0 to -# 360.0 and s, v to be in the range 0.0 to 1.0. -# -# Results: -# The result is a list of three real number values, -# corresponding to the red, green, and blue components -# of a color value. They are in the range 0.0 to 1.0. -# -# Credits: -# This routine is based on the Pascal source code for an -# HSV/RGB converter in the book "Computer Graphics", by -# Baker, Hearn, 1986, ISBN 0-13-165598-1, page 304. -# -proc ::Plotchart::Hsv2rgb {h s v} { - set v [expr {double($v)}] - set r [set g [set b 0.0]] - if {$h == 360} { set h 0 } - # if you feed the output of rgb2hsv back into this - # converter, h could have the value -1 for - # grayscale colors. Set it to any value in the - # valid range. - if {$h == -1} { set h 0 } - set h [expr {$h/60}] - set i [expr {int(floor($h))}] - set f [expr {$h - $i}] - set p1 [expr {$v*(1-$s)}] - set p2 [expr {$v*(1-($s*$f))}] - set p3 [expr {$v*(1-($s*(1-$f)))}] - switch -- $i { - 0 { set r $v ; set g $p3 ; set b $p1 } - 1 { set r $p2 ; set g $v ; set b $p1 } - 2 { set r $p1 ; set g $v ; set b $p3 } - 3 { set r $p1 ; set g $p2 ; set b $v } - 4 { set r $p3 ; set g $p1 ; set b $v } - 5 { set r $v ; set g $p1 ; set b $p2 } - } - return [list $r $g $b] -} - -# -# Define default colour maps -# -namespace eval ::Plotchart { - set contour_options(colourmap,rainbow) \ - {darkblue blue cyan green yellow orange red magenta} - set contour_options(colourmap,white-blue) \ - {white paleblue cyan blue darkblue} - - set contour_options(colourmap,detailed) { -#00000000ffff -#000035e4ffff -#00006bc9ffff -#0000a1aeffff -#0000d793ffff -#0000fffff285 -#0000ffffbca0 -#0000ffff86bc -#0000ffff50d7 -#0000ffff1af2 -#1af2ffff0000 -#50d7ffff0000 -#86bcffff0000 -#bca0ffff0000 -#f285ffff0000 -#ffffd7930000 -#ffffa1ae0000 -#ffff6bc90000 -#ffff35e40000 -#ffff00000000 -#ffff00000000 -} - set contour_options(colourmap) $contour_options(colourmap,detailed) -} -# End of plotcontour.tcl +# plotcontour.tcl -- +# Contour plotting test program for the Plotchart package +# +# Author: Mark Stucky +# +# The basic idea behind the method used for contouring within this sample +# is primarily based on : +# +# (1) "Contour Plots of Large Data Sets" by Chris Johnston +# Computer Language, May 1986 +# +# a somewhat similar method was also described in +# +# (2) "A Contouring Subroutine" by Paul D. Bourke +# BYTE, June 1987 +# http://astronomy.swin.edu.au/~pbourke/projection/conrec/ +# +# In (1) it is assumed that you have a N x M grid of data that you need +# to process. In order to generate a contour, each cell of the grid +# is handled without regard to it's neighbors. This is unlike many other +# contouring algorithms that follow the current contour line into +# neighboring cells in an attempt to produce "smoother" contours. +# +# In general the method described is: +# +# 1) for each four cornered cell of the grid, +# calculate the center of the cell (average of the four corners) +# +# data(i ,j) : Point (1) +# data(i+1,j) : Point (2) +# data(i+1,j+1) : Point (3) +# data(i ,j+1) : Point (4) +# center : Point (5) +# +# (4)-------------(3) +# | \ / | +# | \ / | +# | \ / | +# | \ / | +# | \ / | +# | (5) | +# | / \ | +# | / \ | +# | / \ | +# ^ | / \ | +# | | / \ | +# J (1)-------------(2) +# +# I -> +# +# This divides the cell into four triangles. +# +# 2) Each of the five points in the cell can be assigned a sign (+ or -) +# depending upon whether the point is above (+) the current contour +# or below (-). +# +# A contour will cross an edge whenever the points on the boundary of +# the edge are of an opposite sign. +# +# A few examples : +# +# (-) (-) (-) | (+) (-) (-) (+) | (-) +# \ _ \ +# \ / \ \ +# (-) - (-) | _ /(+) | - (+) - +# / / / \ +# / / / \ +# (-) | (+) (-) | (+) (+) | (-) (-) | (+) +# +# +# (Hopefully the "rough" character diagrams above give you the +# general idea) +# +# It turns out that there are 32 possibles combinations of + and - +# and therefore 32 basic paths through the cell. And if you swap +# the (+) and (-) in the diagram above, the "same" basic path is +# generated: +# +# (+) (+) (+) | (-) (+) (+) (-) | (+) +# \ _ \ +# \ / \ \ +# (+) - (+) | _ /(-) | - (-) - +# / / / \ +# / / / \ +# (+) | (-) (+) | (-) (-) | (+) (+) | (-) +# +# +# So, it turns out that there are 16 basic paths through the cell. +# +############################################################################### +# +# The original article/code worked on all four triangles together and +# generated one of the 16 paths. +# +# For this version of the code, I split the cell into the four triangles +# and handle each triangle individually. +# +# Doing it this way is slower than the above method for calculating the +# contour lines. But since it "simplifies" the code when doing "color filled" +# contours, I opted for the longer calculation times. +# +# +# AM: +# Introduce the following methods in createXYPlot: +# - grid Draw the grid (x,y needed) +# - contourlines Draw isolines (x,y,z needed) +# - contourfill Draw shades (x,y,z needed) +# - contourbox Draw uniformly coloured cells (x,y,z needed) +# +# This needs still to be done: +# - colourmap Set colours to be used (possibly interpolated) +# +# Note: +# To get the RGB values of a named colour: +# winfo rgb . color (divide by 256) +# +# The problem: +# What interface do we use? +# +# Changes: +# - Capitalised several proc names (to indicate they are private to +# the Plotchart package) +# - Changed the data structure from an array to a list of lists. +# This means: +# - No confusion about the start of indices +# - Lists can be passed as ordinary arguments +# - In principle they are faster, but that does not really +# matter here +# To do: +# - Absorb all global arrays into the Plotchart system of private data +# - Get rid of the bug in the shades algorithm ;) +# + +# DrawGrid -- +# Draw the grid as contained in the lists of coordinates +# Arguments: +# w Canvas to draw in +# x X-coordinates of grid points (list of lists) +# y Y-coordinates of grid points (list of lists) +# Result: +# None +# Side effect: +# Grid drawn as lines between the vertices +# Note: +# STILL TO DO +# A cell is only drawn if there are four well-defined +# corners. If the x or y coordinate is missing, the cell is +# skipped. +# +proc ::Plotchart::DrawGrid {w x y} { + + set maxrow [llength $x] + set maxcol [llength [lindex $x 0]] + + for {set i 0} {$i < $maxrow} {incr i} { + set xylist {} + for {set j 0} {$j < $maxcol} {incr j} { + lappend xylist [lindex $x $i $j] [lindex $y $i $j] + } + C_line $w $xylist black + } + + for {set j 0} {$j < $maxcol} {incr j} { + set xylist {} + for {set i 0} {$i < $maxrow} {incr i} { + lappend xylist [lindex $x $i $j] [lindex $y $i $j] + } + C_line $w $xylist black + } +} + +# DrawIsolines -- +# Draw isolines in the given grid +# Arguments: +# canv Canvas to draw in +# x X-coordinates of grid points (list of lists) +# y Y-coordinates of grid points (list of lists) +# f Values of the parameter on the grid cell corners +# cont List of contour classes (or empty to indicate +# automatic scaling +# Result: +# None +# Side effect: +# Isolines drawn +# Note: +# A cell is only drawn if there are four well-defined +# corners. If the x or y coordinate is missing or the value is +# missing, the cell is skipped. +# +proc ::Plotchart::DrawIsolines {canv x y f {cont {}} } { + variable contour_options + + set contour_options(simple_box_contour) 0 + set contour_options(filled_contour) 0 + +# DrawContour $canv $x $y $f 0.0 100.0 20.0 + DrawContour $canv $x $y $f $cont +} + +# DrawShades -- +# Draw filled contours in the given grid +# Arguments: +# canv Canvas to draw in +# x X-coordinates of grid points (list of lists) +# y Y-coordinates of grid points (list of lists) +# f Values of the parameter on the grid cell corners +# cont List of contour classes (or empty to indicate +# automatic scaling +# Result: +# None +# Side effect: +# Shades (filled contours) drawn +# Note: +# A cell is only drawn if there are four well-defined +# corners. If the x or y coordinate is missing or the value is +# missing, the cell is skipped. +# +proc ::Plotchart::DrawShades {canv x y f {cont {}} } { + variable contour_options + + set contour_options(simple_box_contour) 0 + set contour_options(filled_contour) 1 + +# DrawContour $canv $x $y $f 0.0 100.0 20.0 + DrawContour $canv $x $y $f $cont +} + +# DrawBox -- +# Draw filled cells in the given grid (colour chosen according +# to the _average_ of the four corner values) +# Arguments: +# canv Canvas to draw in +# x X-coordinates of grid points (list of lists) +# y Y-coordinates of grid points (list of lists) +# f Values of the parameter on the grid cell corners +# cont List of contour classes (or empty to indicate +# automatic scaling +# Result: +# None +# Side effect: +# Filled cells (quadrangles) drawn +# Note: +# A cell is only drawn if there are four well-defined +# corners. If the x or y coordinate is missing or the value is +# missing, the cell is skipped. +# +proc ::Plotchart::DrawBox {canv x y f {cont {}} } { + variable contour_options + + set contour_options(simple_box_contour) 1 + set contour_options(filled_contour) 0 + +# DrawContour $canv $x $y $f 0.0 100.0 20.0 + DrawContour $canv $x $y $f $cont +} + +# Draw3DFunctionContour -- +# Plot a function of x and y with a color filled contour +# Arguments: +# w Name of the canvas +# function Name of a procedure implementing the function +# cont contour levels +# Result: +# None +# Side effect: +# The plot of the function - given the grid +# +proc ::Plotchart::Draw3DFunctionContour { w function {cont {}} } { + variable scaling + variable contour_options + + set contour_options(simple_box_contour) 0 + set contour_options(filled_contour) 1 + set noTrans 0 + + ::Plotchart::setColormapColors [llength $cont] + + set nxcells $scaling($w,nxcells) + set nycells $scaling($w,nycells) + set xmin $scaling($w,xmin) + set xmax $scaling($w,xmax) + set ymin $scaling($w,ymin) + set ymax $scaling($w,ymax) + set dx [expr {($xmax-$xmin)/double($nxcells)}] + set dy [expr {($ymax-$ymin)/double($nycells)}] + + foreach {fill border} $scaling($w,colours) {break} + + # + # Draw the quadrangles making up the plot in the right order: + # first y from minimum to maximum + # then x from maximum to minimum + # + for { set j 0 } { $j < $nycells } { incr j } { + set y1 [expr {$ymin + $dy*$j}] + set y2 [expr {$y1 + $dy}] + for { set i $nxcells } { $i > 0 } { incr i -1 } { + set x2 [expr {$xmin + $dx*$i}] + set x1 [expr {$x2 - $dx}] + + set z11 [$function $x1 $y1] + set z12 [$function $x1 $y2] + set z21 [$function $x2 $y1] + set z22 [$function $x2 $y2] + + foreach {px11 py11} [coords3DToPixel $w $x1 $y1 $z11] {break} + foreach {px12 py12} [coords3DToPixel $w $x1 $y2 $z12] {break} + foreach {px21 py21} [coords3DToPixel $w $x2 $y1 $z21] {break} + foreach {px22 py22} [coords3DToPixel $w $x2 $y2 $z22] {break} + + set xb [list $px11 $px21 $px22 $px12] + set yb [list $py11 $py21 $py22 $py12] + set fb [list $z11 $z21 $z22 $z12 ] + + Box_contour $w $xb $yb $fb $cont $noTrans + + $w create line $px11 $py11 $px21 $py21 $px22 $py22 \ + $px12 $py12 $px11 $py11 \ + -fill $border + } + } +} + + +# DrawContour -- +# Routine that loops over the grid and delegates the actual drawing +# Arguments: +# canv Canvas to draw in +# x X-coordinates of grid points (list of lists) +# y Y-coordinates of grid points (list of lists) +# f Values of the parameter on the grid cell corners +# cont List of contour classes (or empty to indicate +# automatic scaling) +# Result: +# None +# Side effect: +# Isolines, shades or boxes drawn +# Note: +# A cell is only drawn if there are four well-defined +# corners. If the x or y coordinate is missing or the value is +# missing, the cell is skipped. +# +proc ::Plotchart::DrawContour {canv x y f cont} { + variable contour_options + variable colorMap + + # + # Construct the class-colour list + # + set cont [MakeContourClasses $f $cont] + + set fmin [lindex $cont 0 0] + set fmax [lindex $cont end 0] + set ncont [llength $cont] + + # Now that we know how many entries (ncont), create + # the colormap colors + # + # I moved this into MakeContourClasses... + # ::Plotchart::setColormapColors $ncont + + set maxrow [llength $x] + set maxcol [llength [lindex $x 0]] + + for {set i 0} {$i < $maxrow-1} {incr i} { + set i1 [expr {$i + 1}] + for {set j 0} {$j < $maxcol-1} {incr j} { + set j1 [expr {$j + 1}] + + set x1 [lindex $x $i1 $j] + set x2 [lindex $x $i $j] + set x3 [lindex $x $i $j1] + set x4 [lindex $x $i1 $j1] + + set y1 [lindex $y $i1 $j] + set y2 [lindex $y $i $j] + set y3 [lindex $y $i $j1] + set y4 [lindex $y $i1 $j1] + + set f1 [lindex $f $i1 $j] + set f2 [lindex $f $i $j] + set f3 [lindex $f $i $j1] + set f4 [lindex $f $i1 $j1] + + set xb [list $x1 $x2 $x3 $x4] + set yb [list $y1 $y2 $y3 $y4] + set fb [list $f1 $f2 $f3 $f4] + + if { [lsearch $fb {}] >= 0 || + [lsearch $xb {}] >= 0 || + [lsearch $yb {}] >= 0 } { + continue + } + + Box_contour $canv $xb $yb $fb $cont + } + } +} + +# Box_contour -- +# Draw a filled box +# Arguments: +# canv Canvas to draw in +# xb X-coordinates of the four corners +# yb Y-coordinates of the four corners +# fb Values of the parameter on the four corners +# cont List of contour classes and colours +# Result: +# None +# Side effect: +# Box drawn for a single cell +# +proc ::Plotchart::Box_contour {canv xb yb fb cont {doTrans 1}} { + variable colorMap + variable contour_options + + foreach {x1 x2 x3 x4} $xb {} + foreach {y1 y2 y3 y4} $yb {} + foreach {f1 f2 f3 f4} $fb {} + + set xc [expr {($x1 + $x2 + $x3 + $x4) * 0.25}] + set yc [expr {($y1 + $y2 + $y3 + $y4) * 0.25}] + set fc [expr {($f1 + $f2 + $f3 + $f4) * 0.25}] + + if {$contour_options(simple_box_contour)} { + + set fmin [lindex $cont 0] + set fmax [lindex $cont end] + set ncont [llength $cont] + + set ic 0 + for {set i 0} {$i < $ncont} {incr i} { + set ff [lindex $cont $i 0] + if {$ff <= $fc} { + set ic $i + } + } + + set xylist [list $x1 $y1 $x2 $y2 $x3 $y3 $x4 $y4] + + # canvasPlot::polygon $win $xylist -fill $cont($ic,color) + ### C_polygon $canv $xylist $cont($ic,color) + C_polygon $canv $xylist [lindex $cont $ic 1] + + } else { + +#debug# puts "Tri_contour 1)" + Tri_contour $canv $x1 $y1 $f1 $x2 $y2 $f2 $xc $yc $fc $cont $doTrans + +#debug# puts "Tri_contour 2)" + Tri_contour $canv $x2 $y2 $f2 $x3 $y3 $f3 $xc $yc $fc $cont $doTrans + +#debug# puts "Tri_contour 3)" + Tri_contour $canv $x3 $y3 $f3 $x4 $y4 $f4 $xc $yc $fc $cont $doTrans + +#debug# puts "Tri_contour 4)" + Tri_contour $canv $x4 $y4 $f4 $x1 $y1 $f1 $xc $yc $fc $cont $doTrans + + } + +} + +# Tri_contour -- +# Draw isolines or shades in a triangle +# Arguments: +# canv Canvas to draw in +# x1,x2,x3 X-coordinate of the three corners +# y1,y2,y3 Y-coordinates of the three corners +# f1,f2,f3 Values of the parameter on the three corners +# cont List of contour classes and colours +# Result: +# None +# Side effect: +# Isolines/shades drawn for a single triangle +# +proc ::Plotchart::Tri_contour { canv x1 y1 f1 x2 y2 f2 x3 y3 f3 cont {doTrans 1} } { + variable contour_options + variable colorMap + + set ncont [llength $cont] + + + # Find the min/max function values for this triangle + # + set tfmin [min $f1 $f2 $f3] + set tfmax [max $f1 $f2 $f3] + + # Based on the above min/max, figure out which + # contour levels/colors that bracket this interval + # + set imin 0 + set imax 0 ;#mbs# + for {set i 0} {$i < $ncont} {incr i} { + set ff [lindex $cont $i] ; ### set ff $cont($i,fval) + if {$ff <= $tfmin} { + set imin $i + set imax $i + } + if { $ff <= $tfmax} { + set imax $i + } + } + + set vertlist {} + + # Loop over all contour levels of interest for this triangle + # + for {set ic $imin} {$ic <= $imax} {incr ic} { + + # Get the value for this contour level + # + set ff [lindex $cont $ic 0] ;### set ff $cont($ic,fval) + + set xylist {} + set pxylist {} + + # Classify the triangle based on whether the functional values, f1,f2,f3 + # are above (+), below (-), or equal (=) to the current contour level ff + # + set s1 [::Plotchart::setFLevel $f1 $ff] + set s2 [::Plotchart::setFLevel $f2 $ff] + set s3 [::Plotchart::setFLevel $f3 $ff] + + set class "$s1$s2$s3" + + # Describe class here... + + # ( - - - ) : Case A, + # ( - - = ) : Case B, color a point, do nothing + # ( - - + ) : Case C, contour between {23}-{31} + # ( - = - ) : Case D, color a point, do nothing + # ( - = = ) : Case E, contour line between 2-3 + # ( - = + ) : Case F, contour between 2-{31} + # ( - + - ) : Case G, contour between {12}-{23} + # ( - + = ) : Case H, contour between {12}-3 + # ( - + + ) : Case I, contour between {12}-{31} + # ( = - - ) : Case J, color a point, do nothing + # ( = - = ) : Case K, contour line between 1-3 + # ( = - + ) : Case L, contour between 1-{23} + # ( = = - ) : Case M, contour line between 1-2 + # ( = = = ) : Case N, fill full triangle, return + # ( = = + ) : Case M, + # ( = + - ) : Case L, + # ( = + = ) : Case K, + # ( = + + ) : Case J, + # ( + - - ) : Case I, + # ( + - = ) : Case H, + # ( + - + ) : Case G, + # ( + = - ) : Case F, + # ( + = = ) : Case E, + # ( + = + ) : Case D, + # ( + + - ) : Case C, + # ( + + = ) : Case B, + # ( + + + ) : Case A, + + + switch -- $class { + + ############### Case A ############### + + "---" { +#debug# puts "class A = $class , $ic , $ff" + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + return + } + + "+++" { +#debug# puts "class A = $class , $ic , $ff" + if {$contour_options(filled_contour)} { + if {$ic == $imax} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + } + } + + ############### Case N ############### + + "===" { +#debug# puts "class N = $class , $ic , $ff" + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + return + } + + ############### Case B ############### + + "--=" { +#debug# puts "class B = $class , $ic , $ff" + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + return + } + + "++=" { +#debug# puts "class B= $class , $ic , $ff , do nothing unless ic == imax" + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + } + } + + ############### Case D ############### + + "-=-" { +#debug# puts "class D = $class , $ic , $ff" + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + return + } + + "+=+" { +#debug# puts "class D = $class , $ic , $ff , do nothing unless ic == imax" + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + } + } + + ############### Case J ############### + + "=--" { +#debug# puts "class J = $class , $ic , $ff" + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + return + } + + "=++" { +#debug# puts "class J = $class , $ic , $ff , do nothing unless ic == imax" + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + } + } + + ############### Case K ############### + + "=-=" { +#debug# puts "class K = $class , $ic , $ff" + set xylist [list $x1 $y1 $x3 $y3] + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + return + + } + + "=+=" { +#debug# puts "class K = $class , $ic , $ff" + set xylist [list $x1 $y1 $x3 $y3] + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + + } else { + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + } + } + + ############### Case E ############### + + "-==" { +#debug# puts "class E = $class , $ic , $ff" + set xylist [list $x2 $y2 $x3 $y3] + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + return + } + + "+==" { +#debug# puts "class E = $class , $ic , $ff" + set xylist [list $x2 $y2 $x3 $y3] + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + + } else { + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + } + } + + ############### Case M ############### + + "==-" { +#debug# puts "class M = $class , $ic , $ff" + set xylist [list $x1 $y1 $x2 $y2] + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + return + } + + "==+" { +#debug# puts "class M = $class , $ic , $ff" + set xylist [list $x1 $y1 $x2 $y2] + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + + } else { + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + } + + } + + ############### Case F ############### + + "-=+" { +#debug# puts "class F = $class , $ic , $ff" + set xylist [list $x2 $y2] + set xyf2 [fintpl $x3 $y3 $f3 $x1 $y1 $f1 $ff] + foreach {xx yy} $xyf2 {} + lappend xylist $xx $yy + + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x1 $y1 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + + set x1 $xx; set y1 $yy; set f1 $ff + + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + } + + } + + "+=-" { +#debug# puts "class F = $class , $ic , $ff" + set xylist [list $x2 $y2] + set xyf2 [fintpl $x3 $y3 $f3 $x1 $y1 $f1 $ff] + foreach {xx yy} $xyf2 {} + lappend xylist $xx $yy + + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x3 $y3 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + + set x3 $xx; set y3 $yy; set f3 $ff + + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + } + + } + + ############### Case H ############### + + "-+=" { +#debug# puts "class H = $class , $ic , $ff" + set xylist [fintpl $x1 $y1 $f1 $x2 $y2 $f2 $ff] + foreach {xx yy} $xylist {} + lappend xylist $x3 $y3 + + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x1 $y1 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + + set x1 $xx; set y1 $yy; set f1 $ff + + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + } + + } + + "+-=" { +#debug# puts "class H = $class , $ic , $ff" + set xylist [fintpl $x1 $y1 $f1 $x2 $y2 $f2 $ff] + foreach {xx yy} $xylist {} + lappend xylist $x3 $y3 + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x2 $y2 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + + set x2 $xx; set y2 $yy; set f2 $ff + + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + } + + } + + ############### Case L ############### + + "=-+" { +#debug# puts "class L = $class , $ic , $ff" + set xylist [fintpl $x2 $y2 $f2 $x3 $y3 $f3 $ff] + foreach {xx yy} $xylist {} + lappend xylist $x1 $y1 + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x2 $y2 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + + set x2 $xx; set y2 $yy; set f2 $ff + + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + } + + } + + "=+-" { +#debug# puts "class L = $class , $ic , $ff" + set xylist [fintpl $x2 $y2 $f2 $x3 $y3 $f3 $ff] + foreach {xx yy} $xylist {} + lappend xylist $x1 $y1 + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x3 $y3 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + + set x3 $xx; set y3 $yy; set f3 $ff + + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + } + + } + + ############### Case C ############### + + "--+" { +#debug# puts "class C = $class , $ic , $ff" + set xyf1 [fintpl $x2 $y2 $f2 $x3 $y3 $f3 $ff] + set xyf2 [fintpl $x3 $y3 $f3 $x1 $y1 $f1 $ff] + set xylist $xyf1 + foreach {xx1 yy1} $xyf1 {} + foreach {xx2 yy2} $xyf2 {} + lappend xylist $xx2 $yy2 + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x1 $y1 $x2 $y2 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + if {$ic == $imax} { + set pxylist $xylist + lappend pxylist $x3 $y3 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + set oldlist {} + set x1 $xx1; set y1 $yy1; set f1 $ff + set x2 $xx2; set y2 $yy2; set f2 $ff + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + } + } + + "++-" { +#debug# puts "class C = $class , $ic , $ff" + set xyf1 [fintpl $x2 $y2 $f2 $x3 $y3 $f3 $ff] + set xyf2 [fintpl $x3 $y3 $f3 $x1 $y1 $f1 $ff] + set xylist $xyf1 + foreach {xx1 yy1} $xyf1 {} + foreach {xx2 yy2} $xyf2 {} + lappend xylist $xx2 $yy2 + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x3 $y3 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x1 $y1 $x2 $y2 + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + } + + } else { + +#debug# puts "call Tri_contour : 1) $class" +#debug# puts " : $xx1 $yy1 $ff $xx2 $yy2 $ff $x1 $y1 $f1" + Tri_contour $canv $xx1 $yy1 $ff $xx2 $yy2 $ff $x1 $y1 $f1 $cont $doTrans + +#debug# puts "call Tri_contour : 2) $class" +#debug# puts " : $xx1 $yy1 $ff $x1 $y1 $f1 $x2 $y2 $f2" + Tri_contour $canv $xx1 $yy1 $ff $x1 $y1 $f1 $x2 $y2 $f2 $cont $doTrans + + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + return + + } + + ############### Case G ############### + + "-+-" { +#debug# puts "class G = $class , $ic , $ff" + set xyf1 [fintpl $x1 $y1 $f1 $x2 $y2 $f2 $ff] + set xyf2 [fintpl $x2 $y2 $f2 $x3 $y3 $f3 $ff] + set xylist $xyf1 + foreach {xx1 yy1} $xyf1 {} + foreach {xx2 yy2} $xyf2 {} + lappend xylist $xx2 $yy2 + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x3 $y3 $x1 $y1 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + if {$ic == $imax} { + set pxylist $xylist + lappend pxylist $x2 $y2 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + set oldlist {} + set x1 $xx1; set y1 $yy1; set f1 $ff + set x3 $xx2; set y3 $yy2; set f3 $ff + + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + } + + } + + "+-+" { +#debug# puts "class G = $class , $ic , $ff" + set xyf1 [fintpl $x1 $y1 $f1 $x2 $y2 $f2 $ff] + set xyf2 [fintpl $x2 $y2 $f2 $x3 $y3 $f3 $ff] + foreach {xx1 yy1} $xyf1 {} + foreach {xx2 yy2} $xyf2 {} + set xylist $xyf1 + lappend xylist $xx2 $yy2 + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x2 $y2 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x3 $y3 $x1 $y1 + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + } + + } else { + +#debug# puts "call Tri_contour : 1) $class" +#debug# puts " : $xx1 $yy1 $ff $xx2 $yy2 $ff $x3 $y3 $f3" + Tri_contour $canv $xx1 $yy1 $ff $xx2 $yy2 $ff $x3 $y3 $f3 $cont $doTrans + +#debug# puts "call Tri_contour : 2) $class" +#debug# puts " : $xx1 $yy1 $ff $x3 $y3 $f3 $x1 $y1 $f1" + Tri_contour $canv $xx1 $yy1 $ff $x3 $y3 $f3 $x1 $y1 $f1 $cont $doTrans + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + return + + } + + ############### Case I ############### + + "+--" { +#debug# puts "class I = $class , $ic , $ff" + set xyf1 [fintpl $x1 $y1 $f1 $x2 $y2 $f2 $ff] + set xyf2 [fintpl $x3 $y3 $f3 $x1 $y1 $f1 $ff] + set xylist $xyf1 + foreach {xx1 yy1} $xyf1 {} + foreach {xx2 yy2} $xyf2 {} + lappend xylist $xx2 $yy2 + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x3 $y3 $x2 $y2 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + if {$ic == $imax} { + set pxylist $xylist + lappend pxylist $x1 $y1 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + set oldlist {} + set x2 $xx1; set y2 $yy1; set f2 $ff + set x3 $xx2; set y3 $yy2; set f3 $ff + + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist [list $x1 $y1 $x2 $y2 $x3 $y3] + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + return + } + } + + } + + "-++" { +#debug# puts "class I = $class , $ic , $ff" + set xyf1 [fintpl $x1 $y1 $f1 $x2 $y2 $f2 $ff] + set xyf2 [fintpl $x3 $y3 $f3 $x1 $y1 $f1 $ff] + foreach {xx1 yy1} $xyf1 {} + foreach {xx2 yy2} $xyf2 {} + set xylist $xyf1 + lappend xylist $xx2 $yy2 + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x1 $y1 + C_polygon $canv $pxylist [lindex $colorMap $ic] $doTrans + } + + if {$ic == $imax} { + if {$contour_options(filled_contour)} { + set pxylist $xylist + lappend pxylist $x3 $y3 $x2 $y2 + set ictmp [expr {$ic + 1}] + C_polygon $canv $pxylist [lindex $colorMap $ictmp] $doTrans + } + + } else { + +#debug# puts "call Tri_contour : 1) $class" +#debug# puts " : $xx1 $yy1 $ff $xx2 $yy2 $ff $x3 $y3 $f3" + Tri_contour $canv $xx1 $yy1 $ff $xx2 $yy2 $ff $x3 $y3 $f3 $cont $doTrans + +#debug# puts "call Tri_contour : 2) $class" +#debug# puts " : $xx1 $yy1 $ff $x3 $y3 $f3 $x2 $y2 $f2" + Tri_contour $canv $xx1 $yy1 $ff $x3 $y3 $f3 $x2 $y2 $f2 $cont $doTrans + } + C_line $canv $xylist [lindex $colorMap $ic] $doTrans + return + + } + + } + + } +} + +# setFLevel -- +# Auxiliary function: used to classify one functional value to another +# Arguments: +# f1 Second break point and value +# f2 Value to find +# Result: +# + f1 > f2 +# = f1 = f2 +# - f1 < f2 +# +proc ::Plotchart::setFLevel {f1 f2} { + if {$f1 > $f2} { + return "+" + } else { + if {$f1 < $f2} { + return "-" + } else { + return "=" + } + } +} + +# fintpl -- +# Auxiliary function: inverse interpolation +# Arguments: +# x1,y1,f1 First break point and value +# x2,y2,f2 Second break point and value +# ff Value to find +# Result: +# x,y coordinates of point with that value +# +proc ::Plotchart::fintpl {x1 y1 f1 x2 y2 f2 ff} { + + if {[expr {$f2 - $f1}] != 0.0} { + set xx [expr {$x1 + (($ff - $f1)*($x2 - $x1)/($f2 - $f1))}] + set yy [expr {$y1 + (($ff - $f1)*($y2 - $y1)/($f2 - $f1))}] + } else { + + # If the logic was handled correctly above, this point + # should never be reached. + # + # puts "FINTPL : f1 == f2 : x1,y1 : $x1 , $y1 : x2,y2 : $x2 , $y2" + set xx $x1 + set yy $y1 + } + + set xmin [min $x1 $x2] + set xmax [max $x1 $x2] + set ymin [min $y1 $y2] + set ymax [max $y1 $y2] + + if {$xx < $xmin} { set xx $xmin } + if {$xx > $xmax} { set xx $xmax } + if {$yy < $ymin} { set yy $ymin } + if {$yy > $ymax} { set yy $ymax } + + return [list $xx $yy] +} + +# min -- +# Auxiliary function: find the minimum of the arguments +# Arguments: +# val First value +# args All others +# Result: +# Minimum over the arguments +# +proc ::Plotchart::min { val args } { + set min $val + foreach val $args { + if { $val < $min } { + set min $val + } + } + return $min +} + +# max -- +# Auxiliary function: find the maximum of the arguments +# Arguments: +# val First value +# args All others +# Result: +# Maximum over the arguments +# +proc ::Plotchart::max { val args } { + set max $val + foreach val $args { + if { $val > $max } { + set max $val + } + } + return $max +} + +# C_line -- +# Draw a line +# Arguments: +# canv Canvas to draw in +# xylist List of raw coordinates +# color Chosen colour +# args Any additional arguments (for line style and such) +# Result: +# None +# +proc ::Plotchart::C_line {canv xylist color {doTrans 1} } { + + if {$doTrans} { + set wxylist {} + foreach {xx yy} $xylist { + foreach {pxcrd pycrd} [::Plotchart::coordsToPixel $canv $xx $yy] {break} + lappend wxylist $pxcrd $pycrd + } + eval "$canv create line $wxylist -fill $color" + + } else { + $canv create line $xylist -fill $color + } +} + +# C_polygon -- +# Draw a polygon +# Arguments: +# canv Canvas to draw in +# xylist List of raw coordinates +# color Chosen colour +# args Any additional arguments (for line style and such) +# Result: +# None +# +proc ::Plotchart::C_polygon {canv xylist color {doTrans 1}} { + + if {$doTrans} { + set wxylist {} + foreach {xx yy} $xylist { + foreach {pxcrd pycrd} [::Plotchart::coordsToPixel $canv $xx $yy] {break} + lappend wxylist $pxcrd $pycrd + } + eval "$canv create polygon $wxylist -fill $color" + + } else { + $canv create polygon $xylist -fill $color + } +} + +# MakeContourClasses -- +# Return contour classes and colours +# Arguments: +# values List of values +# classes Given list of classes or class/colours +# Result: +# List of pairs of class limits and colours +# Note: +# This should become more sophisticated! +# +proc ::Plotchart::MakeContourClasses {values classes} { + variable contour_options + variable colorMap + + if { [llength $classes] == 0 } { + set min {} + set max {} + foreach row $values { + foreach v $row { + if { $v == {} } {continue} + + if { $min == {} || $min > $v } { + set min $v + } + + if { $max == {} || $max < $v } { + set max $v + } + } + } + + foreach {xmin xmax xstep} [determineScale $min $max] {break} + + # + # The contour classes must encompass all values + # There might be a problem with border cases + # + set classes {} + set x $xmin + + while { $x < $xmax+0.5*$xstep } { + #mbs# lappend classes [list $x] + set x [expr {$x+$xstep}] + lappend classes [list $x] + } + + # Now that we know how many entries (ncont), create + # the colormap colors + # + ::Plotchart::setColormapColors [expr [llength $classes] + 1] + + } elseif { [llength [lindex $classes 0]] == 1 } { + #mbs# Changed the above line from " == 2 " to " == 1 " + ::Plotchart::setColormapColors [llength $classes] + return $classes + } + + # + # Add the colours + # +##### set cont {} +##### set c 0 +##### +##### foreach x $classes { +##### set col [lindex $contour_options(colourmap) $c] +##### if { $col == {} } { +##### set c 0 +##### set col [lindex $contour_options(colourmap) $c] +##### } +##### lappend cont [list $x $col] +##### incr c +##### } +##### +##### return $cont + + puts "classes (cont) : $classes" + + return $classes +} + + +# setColormapColors -- +# Auxiliary function: Based on the current colormap type +# create a colormap with requested number of entries +# Arguments: +# ncont Number of colors in the colormap +# Result: +# List of colours +# +proc ::Plotchart::setColormapColors {ncont} { + variable colorMapType + variable colorMap + +#debug# puts "SetColormapColors : ncont = $ncont" + + # Note : The default colormap is "jet" + + switch $colorMapType { + + custom { + return + } + + hsv { + set hueStart 0.0 + set hueEnd 240.0 + set colorMap {} + + for {set i 0} {$i <= $ncont} {incr i} { + set dh [expr {($hueStart - $hueEnd) / ($ncont - 1)}] + set hue [expr {$hueStart - ($i * $dh)}] + if {$hue < 0.0} { + set hue [expr {360.0 + $hue}] + } + set rgbList [Hsv2rgb $hue 1.0 1.0] + set r [expr {int([lindex $rgbList 0] * 65535)}] + set g [expr {int([lindex $rgbList 1] * 65535)}] + set b [expr {int([lindex $rgbList 2] * 65535)}] + + set color [format "#%.4x%.4x%.4x" $r $g $b] + lappend colorMap $color + } + } + + hot { + set colorMap {} + set nc1 [expr {int($ncont * 0.33)}] + set nc2 [expr {int($ncont * 0.67)}] + + for {set i 0} {$i <= $ncont} {incr i} { + + if {$i <= $nc1} { + set fval [expr { double($i) / (double($nc1)) } ] + set r [expr {int($fval * 65535)}] + set g 0 + set b 0 + } else { + if {$i <= $nc2} { + set fval [expr { double($i-$nc1) / (double($nc2-$nc1)) } ] + set r 65535 + set g [expr {int($fval * 65535)}] + set b 0 + } else { + set fval [expr { double($i-$nc2) / (double($ncont-$nc2)) } ] + set r 65535 + set g 65535 + set b [expr {int($fval * 65535)}] + } + } + set color [format "#%.4x%.4x%.4x" $r $g $b] + lappend colorMap $color + } + } + + cool { + set colorMap {} + + for {set i 0} {$i <= $ncont} {incr i} { + + set fval [expr { double($i) / (double($ncont)-1) } ] + set val [expr { 1.0 - $fval }] + + set r [expr {int($fval * 65535)}] + set g [expr {int($val * 65535)}] + set b 65535 + + set color [format "#%.4x%.4x%.4x" $r $g $b] + lappend colorMap $color + } + } + + grey - + gray { + set colorMap {} + + for {set i 0} {$i <= $ncont} {incr i} { + + set fval [expr { double($i) / (double($ncont)-1) } ] + set val [expr {0.4 + (0.5 * $fval) }] + + set r [expr {int($val * 65535)}] + set g [expr {int($val * 65535)}] + set b [expr {int($val * 65535)}] + + set color [format "#%.4x%.4x%.4x" $r $g $b] + lappend colorMap $color + } + } + + jet - + default { + set hueStart 240.0 + set hueEnd 0.0 + set colorMap {} + + for {set i 0} {$i <= $ncont} {incr i} { + set dh [expr {($hueStart - $hueEnd) / ($ncont - 1)}] + set hue [expr {$hueStart - ($i * $dh)}] + if {$hue < 0.0} { + set hue [expr {360.0 + $hue}] + } + set rgbList [Hsv2rgb $hue 1.0 1.0] + set r [expr {int([lindex $rgbList 0] * 65535)}] + set g [expr {int([lindex $rgbList 1] * 65535)}] + set b [expr {int([lindex $rgbList 2] * 65535)}] + + set color [format "#%.4x%.4x%.4x" $r $g $b] + lappend colorMap $color + } + } + + } +} + +# setColormapColors -- +# Define the current colormap type +# Arguments: +# cmap Type of colormap +# Result: +# Updated the internal variable "colorMapType" +# Note: +# Possibly handle "custom" colormaps differently +# At present, if the user passes in a list (length > 1) +# rather than a string, then it is assumes that (s)he +# passed in a list of colors. +# +proc ::Plotchart::Colormap {cmap} { + variable colorMapType + variable colorMap + + switch $cmap { + + "grey" - + "gray" { set colorMapType $cmap } + + "jet" { set colorMapType $cmap } + + "hot" { set colorMapType $cmap } + + "cool" { set colorMapType $cmap } + + "hsv" { set colorMapType $cmap } + + default { + if {[string is alpha $cmap] == 1} { + puts "Colormap : Unknown colorMapType, $cmap. Using JET" + set colorMapType jet + + } else { + if {[llength $cmap] > 1} { + set colorMapType "custom" + set colorMap $cmap + } + } + } + } +} + + + +######################################################################## +# The following two routines were borrowed from : +# +# http://mini.net/cgi-bin/wikit/666.html +######################################################################## + +# Rgb2hsv -- +# +# Convert a color value from the RGB model to HSV model. +# +# Arguments: +# r g b the red, green, and blue components of the color +# value. The procedure expects, but does not +# ascertain, them to be in the range 0 to 1. +# +# Results: +# The result is a list of three real number values. The +# first value is the Hue component, which is in the range +# 0.0 to 360.0, or -1 if the Saturation component is 0. +# The following to values are Saturation and Value, +# respectively. They are in the range 0.0 to 1.0. +# +# Credits: +# This routine is based on the Pascal source code for an +# RGB/HSV converter in the book "Computer Graphics", by +# Baker, Hearn, 1986, ISBN 0-13-165598-1, page 304. +# +proc ::Plotchart::Rgb2hsv {r g b} { + set h [set s [set v 0.0]]] + set sorted [lsort -real [list $r $g $b]] + set v [expr {double([lindex $sorted end])}] + set m [lindex $sorted 0] + + set dist [expr {double($v-$m)}] + if {$v} { + set s [expr {$dist/$v}] + } + if {$s} { + set r' [expr {($v-$r)/$dist}] ;# distance of color from red + set g' [expr {($v-$g)/$dist}] ;# distance of color from green + set b' [expr {($v-$b)/$dist}] ;# distance of color from blue + if {$v==$r} { + if {$m==$g} { + set h [expr {5+${b'}}] + } else { + set h [expr {1-${g'}}] + } + } elseif {$v==$g} { + if {$m==$b} { + set h [expr {1+${r'}}] + } else { + set h [expr {3-${b'}}] + } + } else { + if {$m==$r} { + set h [expr {3+${g'}}] + } else { + set h [expr {5-${r'}}] + } + } + set h [expr {$h*60}] ;# convert to degrees + } else { + # hue is undefined if s == 0 + set h -1 + } + return [list $h $s $v] +} + +# Hsv2rgb -- +# +# Convert a color value from the HSV model to RGB model. +# +# Arguments: +# h s v the hue, saturation, and value components of +# the color value. The procedure expects, but +# does not ascertain, h to be in the range 0.0 to +# 360.0 and s, v to be in the range 0.0 to 1.0. +# +# Results: +# The result is a list of three real number values, +# corresponding to the red, green, and blue components +# of a color value. They are in the range 0.0 to 1.0. +# +# Credits: +# This routine is based on the Pascal source code for an +# HSV/RGB converter in the book "Computer Graphics", by +# Baker, Hearn, 1986, ISBN 0-13-165598-1, page 304. +# +proc ::Plotchart::Hsv2rgb {h s v} { + set v [expr {double($v)}] + set r [set g [set b 0.0]] + if {$h == 360} { set h 0 } + # if you feed the output of rgb2hsv back into this + # converter, h could have the value -1 for + # grayscale colors. Set it to any value in the + # valid range. + if {$h == -1} { set h 0 } + set h [expr {$h/60}] + set i [expr {int(floor($h))}] + set f [expr {$h - $i}] + set p1 [expr {$v*(1-$s)}] + set p2 [expr {$v*(1-($s*$f))}] + set p3 [expr {$v*(1-($s*(1-$f)))}] + switch -- $i { + 0 { set r $v ; set g $p3 ; set b $p1 } + 1 { set r $p2 ; set g $v ; set b $p1 } + 2 { set r $p1 ; set g $v ; set b $p3 } + 3 { set r $p1 ; set g $p2 ; set b $v } + 4 { set r $p3 ; set g $p1 ; set b $v } + 5 { set r $v ; set g $p1 ; set b $p2 } + } + return [list $r $g $b] +} + +# +# Define default colour maps +# +namespace eval ::Plotchart { + set contour_options(colourmap,rainbow) \ + {darkblue blue cyan green yellow orange red magenta} + set contour_options(colourmap,white-blue) \ + {white paleblue cyan blue darkblue} + + set contour_options(colourmap,detailed) { +#00000000ffff +#000035e4ffff +#00006bc9ffff +#0000a1aeffff +#0000d793ffff +#0000fffff285 +#0000ffffbca0 +#0000ffff86bc +#0000ffff50d7 +#0000ffff1af2 +#1af2ffff0000 +#50d7ffff0000 +#86bcffff0000 +#bca0ffff0000 +#f285ffff0000 +#ffffd7930000 +#ffffa1ae0000 +#ffff6bc90000 +#ffff35e40000 +#ffff00000000 +#ffff00000000 +} + set contour_options(colourmap) $contour_options(colourmap,detailed) +} +# End of plotcontour.tcl From aa4d41eedec79f014973ab25d7d723e07308a2a8 Mon Sep 17 00:00:00 2001 From: Jeffrey Hobbs Date: Tue, 8 Mar 2005 19:14:10 +0000 Subject: [PATCH 0057/1290] * as.tcl (style::as::init_fonts): corrected fsize, ffamily spelling for aqua fonts. --- modules/style/ChangeLog | 5 +++++ modules/style/as.tcl | 4 ++-- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/modules/style/ChangeLog b/modules/style/ChangeLog index 5dce0dbb..5cb3279b 100644 --- a/modules/style/ChangeLog +++ b/modules/style/ChangeLog @@ -1,3 +1,8 @@ +2005-03-08 Jeff Hobbs + + * as.tcl (style::as::init_fonts): corrected fsize, ffamily + spelling for aqua fonts. + 2005-02-02 David N. Welton * lobster.tcl (style::lobster::init): Use nicer fonts for the diff --git a/modules/style/as.tcl b/modules/style/as.tcl index 1daeb3fa..3f6c64ae 100644 --- a/modules/style/as.tcl +++ b/modules/style/as.tcl @@ -151,8 +151,8 @@ proc style::as::init_fonts {args} { "aqua" - "macintosh" { set size 11 set family "Lucida Grande" - set size 11 - set family Courier + set fsize 11 + set ffamily Courier } } font create ASfont -size $size -family $family From 703cbf15693f14f16f6263cb824c6b2bc2ee1af0 Mon Sep 17 00:00:00 2001 From: Arjen Markus Date: Fri, 11 Mar 2005 12:52:45 +0000 Subject: [PATCH 0058/1290] Correction of plotcontour.test - tcllib bug 116005 --- modules/plotchart/ChangeLog | 5 +++++ modules/plotchart/plotcontour.test | 23 ++++++++++++++++++++++- 2 files changed, 27 insertions(+), 1 deletion(-) diff --git a/modules/plotchart/ChangeLog b/modules/plotchart/ChangeLog index 614065ea..18796893 100644 --- a/modules/plotchart/ChangeLog +++ b/modules/plotchart/ChangeLog @@ -1,3 +1,8 @@ +2005-03-11 Arjen Markus + + * Solved problem with plotcontour.test (works correctly + from sak.tcl now - still requires formalisation) + 2005-03-04 Arjen Markus * Added the contour plotting routines by Mark Stucky diff --git a/modules/plotchart/plotcontour.test b/modules/plotchart/plotcontour.test index e52233e2..439f9149 100755 --- a/modules/plotchart/plotcontour.test +++ b/modules/plotchart/plotcontour.test @@ -1,7 +1,9 @@ # Informal test for plotcontour # -source plotchart.tcl +source [file join [file dirname [info script]] plotchart.tcl] +package require Plotchart +test "Plotcontours-1.0" "Informal test for plotcontour" { ######################################################################## proc cowboyhat {x y} { @@ -108,6 +110,7 @@ $chart contourfill $x $y $f $contours $chart grid $x $y set t [toplevel .contourlines] +lappend windows $t wm title $t "Contour Demo : contourlines (default colormap)" set c [canvas $t.c -background white \ -width 500 -height 500] @@ -119,6 +122,7 @@ $chart1 contourlines $x $y $f $contours set t [toplevel .hot] +lappend windows $t wm title $t "Contour Demo : contourlines (hot colormap)" set c [canvas $t.c -background white \ -width 500 -height 500] @@ -131,6 +135,7 @@ $chart2 grid $x $y set t [toplevel .gray] +lappend windows $t wm title $t "Contour Demo : gray contourfill , jet contourlines" set c [canvas $t.c -background white \ -width 500 -height 500] @@ -146,6 +151,7 @@ $chart3 grid $x $y set t [toplevel .cool] +lappend windows $t wm title $t "Contour Demo : contourlines (cool colormap)" set c [canvas $t.c -background white \ -width 500 -height 500] @@ -159,6 +165,7 @@ $chart4 grid $x $y set t [toplevel .defcont] +lappend windows $t wm title $t "Contour Demo : default contours (jet colormap)" set c [canvas $t.c -background white \ -width 500 -height 500] @@ -172,6 +179,7 @@ $chart5 grid $x $y set t [toplevel .3dcontour] +lappend windows $t wm title $t "Contour Demo : contours on a 3DPlot" set c [canvas $t.c -background white \ -width 500 -height 500] @@ -198,4 +206,17 @@ set chart6 [::Plotchart::create3DPlot $c $xlimits $ylimits $zlimits] $chart6 title "3D Plot" $chart6 plotfuncont cowboyhat $contours +after 10000 { + foreach t $windows { + destroy $t + } + set vv 1 +} +vwait vv +set v 1 +} 1 + + +# ------------------------------------------------------------------------- +::tcltest::cleanupTests From 8189bafbdb55a9d4a1763813b7cfed159de6017e Mon Sep 17 00:00:00 2001 From: afaupell Date: Wed, 16 Mar 2005 05:59:20 +0000 Subject: [PATCH 0059/1290] 2005-03-15 Aaron Faupell ipentry.tcl: fixed tab traversal and selection issue with arrow keys --- modules/ipentry/ipentry.man | 4 ++-- modules/ipentry/ipentry.tcl | 23 +++++++++++++++-------- 2 files changed, 17 insertions(+), 10 deletions(-) diff --git a/modules/ipentry/ipentry.man b/modules/ipentry/ipentry.man index f0ef83f6..85c27362 100644 --- a/modules/ipentry/ipentry.man +++ b/modules/ipentry/ipentry.man @@ -42,8 +42,8 @@ are modified to be within the range. [call [arg pathName] [method icursor] [arg index]] Sets the position of the widgets insertion cursor. Only integer values between -0 and 15 are valid. Because of the way the widget works, setting the icursor -will only have an effect if the widget already has the input focus. +0 and 15 are valid. Setting the icursor will only have an effect if the widget +already has the input focus. [call [arg pathName] [method configure] [arg option] [arg value]...] diff --git a/modules/ipentry/ipentry.tcl b/modules/ipentry/ipentry.tcl index 31561c6b..e61f8e7e 100644 --- a/modules/ipentry/ipentry.tcl +++ b/modules/ipentry/ipentry.tcl @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: ipentry.tcl,v 1.5 2005/03/05 02:06:22 andreas_kupries Exp $ +# RCS: @(#) $Id: ipentry.tcl,v 1.6 2005/03/16 05:59:20 afaupell Exp $ package provide ipentry 0.1 @@ -25,6 +25,7 @@ namespace eval ::ipentry { bind IPEntrybindtag {::ipentry::FocusOut %W} bind IPEntrybindtag <> {::ipentry::Paste %W CLIPBOARD} bind IPEntrybindtag <> {::ipentry::Paste %W PRIMARY} + bind IPEntrybindtag {::ipentry::tab %W; break} } proc ::ipentry::ipentry {w args} { @@ -42,7 +43,7 @@ proc ::ipentry::ipentry {w args} { rename ::$w ::ipentry::_$w interp alias {} ::$w {} ::ipentry::widgetCommand $w bind $w [list rename ::$w {}] - bind $w [list focus $w.0] + #bind $w [list focus $w.0] if {[llength $args] > 0} { eval [list $w configure] $args } @@ -60,6 +61,10 @@ proc ::ipentry::keypress {w key} { $w insert insert $key } +proc ::ipentry::tab {w} { + tk::TabToWindow [tk_focusNext [winfo parent $w].3] +} + proc ::ipentry::backspace {w} { if {[$w selection present]} { $w delete sel.first sel.last @@ -74,7 +79,7 @@ proc ::ipentry::backspace {w} { proc ::ipentry::dot {w} { if {[string length [$w get]] > 0} { - skip $w next + skip $w next 1 } } @@ -154,25 +159,27 @@ proc ::ipentry::validate {w key} { $w selection range 0 end return 0 } elseif {$i == 2} { - skip $w next + skip $w next 1 } return 1 } if {[string length $s] >= 3 && ![$w selection present]} { - if {$i == 3} { skip $w next } + if {$i == 3} { skip $w next 1 } return 0 } return 1 } -proc ::ipentry::skip {w dir} { +proc ::ipentry::skip {w dir {sel 0}} { set n [string index $w end] if {$dir == "next"} { if { $n >= 3 } { return } set next [string trimright $w "0123"][expr {$n + 1}] focus $next - $next icursor 0 - $next selection range 0 end + if {$sel} { + $next icursor 0 + $next selection range 0 end + } } else { if { $n <= 0 } { return } set prev [string trimright $w "0123"][expr {$n - 1}] From e9b6b08edab1ece2decbba5a822d154070a5253f Mon Sep 17 00:00:00 2001 From: afaupell Date: Thu, 17 Mar 2005 19:39:45 +0000 Subject: [PATCH 0060/1290] 2005-03-15 Aaron Faupell * initial import --- modules/getstring/ChangeLog | 3 + modules/getstring/pkgIndex.tcl | 13 ++++ modules/getstring/tk_getString.man | 41 ++++++++++++ modules/getstring/tk_getString.tcl | 103 +++++++++++++++++++++++++++++ 4 files changed, 160 insertions(+) create mode 100644 modules/getstring/ChangeLog create mode 100644 modules/getstring/pkgIndex.tcl create mode 100644 modules/getstring/tk_getString.man create mode 100644 modules/getstring/tk_getString.tcl diff --git a/modules/getstring/ChangeLog b/modules/getstring/ChangeLog new file mode 100644 index 00000000..ad8e0fff --- /dev/null +++ b/modules/getstring/ChangeLog @@ -0,0 +1,3 @@ +2005-03-17 Aaron Faupell + + * initial import diff --git a/modules/getstring/pkgIndex.tcl b/modules/getstring/pkgIndex.tcl new file mode 100644 index 00000000..3607eff4 --- /dev/null +++ b/modules/getstring/pkgIndex.tcl @@ -0,0 +1,13 @@ +# Tcl package index file, version 1.1 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +if { ![package vsatisfies [package provide Tcl] 8.4] } { return } +package ifneeded tk_getString 0.1 [list source [file join $dir tk_getString.tcl]] + diff --git a/modules/getstring/tk_getString.man b/modules/getstring/tk_getString.man new file mode 100644 index 00000000..d9bde4f9 --- /dev/null +++ b/modules/getstring/tk_getString.man @@ -0,0 +1,41 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin getstring n 0.1] +[moddesc {A dialog which prompts for a string input}] +[titledesc {A string dialog}] +[require Tcl 8.4] +[require tk_getString [opt 0.1]] +[description] + +This package provides a dialog which consists of an Entry, OK, and Cancel buttons. + +[para] + +[list_begin definitions] + +[call [cmd ::dialogs::tk_getString] [arg pathName] [arg variable] [arg title] [arg text] [opt options]] + +Creates a dialog which prompts the user with [arg text] to input a text string. The contents of +the entry is put in the [arg variable] upon closure of the dialog. The command returns a boolean +indicating if the user pressed OK or not. The dialog is centered in its parent toplevel unless +its parent is . in which case the dialog is centered in the screen. The currently recognized +options are -allowempty, -validate, -invalidcmd, and -validatecmd. -allowempty takes a boolean +argument indicating if the dialog should accept an empty entry. The validation options simply +pass their arguments through to the entry widget. + +[list_end] + +[section EXAMPLE] + +[example { +package require tk_getString +namespace import tk_getString::* + +if {[tk_getString .gs text "String Dialog" "Feed me a string please:"]} { + puts "user entered: $text" +} + +}] + +[keywords entry dialog string] +[manpage_end] + diff --git a/modules/getstring/tk_getString.tcl b/modules/getstring/tk_getString.tcl new file mode 100644 index 00000000..e2b46901 --- /dev/null +++ b/modules/getstring/tk_getString.tcl @@ -0,0 +1,103 @@ +# tk_getString.tcl -- +# +# A dialog which prompts for a string input +# +# Copyright (c) 2005 Aaron Faupell +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: tk_getString.tcl,v 1.1 2005/03/17 19:39:45 afaupell Exp $ + +package require Tk +package provide tk_getString 0.1 + +namespace eval ::dialogs { + namespace export tk_getString +} + +if {[tk windowingsystem] == "win32"} { + option add *TkSDialog*Button.width -10 widgetDefault + option add *TkSDialog*Button.padX 1m widgetDefault +} else { + option add *TkSDialog.borderWidth 1 widgetDefault + option add *TkSDialog*Button.width 5 widgetDefault +} +option add *TkSDialog*Entry.width 20 widgetDefault + +proc ::dialogs::getStringEnable {w} { + if {![winfo exists $w.entry]} {return} + if {[$w.entry get] != ""} { + $w.ok configure -state normal + } else { + $w.ok configure -state disabled + } +} + +proc ::dialogs::tk_getString {w var title text args} { + set allowempty 0 + set entryoptions {} + foreach {opt arg} $args { + if {$opt == "-allowempty" && [string is boolean -strict $arg] && $arg} { + set allowempty 1 + } elseif {[string match -inv* $opt] || [string match -valid* $opt]} { + lappend entryoptions $opt $arg + } + } + + variable ::tk::Priv + upvar $var result + catch {destroy $w} + set focus [focus] + set grab [grab current .] + + toplevel $w -relief raised -class TkSDialog + wm title $w $title + wm iconname $w $title + wm protocol $w WM_DELETE_WINDOW {set ::tk::Priv(button) 0} + wm transient $w [winfo toplevel [winfo parent $w]] + + eval [list entry $w.entry] $entryoptions + button $w.ok -text OK -default active -command {set ::tk::Priv(button) 1} + button $w.cancel -text Cancel -command {set ::tk::Priv(button) 0} + label $w.label -text $text + + grid $w.label -columnspan 2 -sticky ew -padx 3 -pady 3 + grid $w.entry -columnspan 2 -sticky ew -padx 3 -pady 3 + grid $w.ok $w.cancel -padx 3 -pady 3 + grid rowconfigure $w 2 -weight 1 + grid columnconfigure $w {0 1} -uniform 1 -weight 1 + + bind $w [list $w.ok invoke] + bind $w [list $w.cancel invoke] + bind $w {set ::tk::Priv(button) 0} + if {!$allowempty} { + bind $w.entry [list after idle [list ::dialogs::getStringEnable $w]] + $w.ok configure -state disabled + } + + wm withdraw $w + update idletasks + focus $w.entry + if {[winfo parent $w] == "."} { + set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 - [winfo vrootx $w]}] + set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 - [winfo vrooty $w]}] + } else { + set t [winfo toplevel [winfo parent $w]] + set x [expr {[winfo width $t]/2 - [winfo reqwidth $w]/2 - [winfo vrootx $w]}] + set y [expr {[winfo height $t]/2 - [winfo reqheight $w]/2 - [winfo vrooty $w]}] + } + wm geom $w +$x+$y + wm deiconify $w + grab $w + + tkwait variable ::tk::Priv(button) + set result [$w.entry get] + bind $w {} + grab release $w + destroy $w + focus -force $focus + if {$grab != ""} {grab $grab} + update idletasks + return $::tk::Priv(button) +} From 973b847f8bfea43d9d56804870e5ccae5ac82e43 Mon Sep 17 00:00:00 2001 From: Andreas Kupries Date: Fri, 18 Mar 2005 03:15:56 +0000 Subject: [PATCH 0061/1290] New module, getstring, a dialog prompting for a single string, through an entry. Import of changes to focus bindings of ipentry. --- modules/getstring/tk_getString.tcl | 2 +- modules/ipentry/ipentry.tcl | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/modules/getstring/tk_getString.tcl b/modules/getstring/tk_getString.tcl index e2b46901..d59f1367 100644 --- a/modules/getstring/tk_getString.tcl +++ b/modules/getstring/tk_getString.tcl @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tk_getString.tcl,v 1.1 2005/03/17 19:39:45 afaupell Exp $ +# RCS: @(#) $Id: tk_getString.tcl,v 1.2 2005/03/18 03:15:56 andreas_kupries Exp $ package require Tk package provide tk_getString 0.1 diff --git a/modules/ipentry/ipentry.tcl b/modules/ipentry/ipentry.tcl index e61f8e7e..322c83d1 100644 --- a/modules/ipentry/ipentry.tcl +++ b/modules/ipentry/ipentry.tcl @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: ipentry.tcl,v 1.6 2005/03/16 05:59:20 afaupell Exp $ +# RCS: @(#) $Id: ipentry.tcl,v 1.7 2005/03/18 03:15:57 andreas_kupries Exp $ package provide ipentry 0.1 From b90f923a018d2b9beb44cf69dc582567a33a19ba Mon Sep 17 00:00:00 2001 From: georgeps Date: Mon, 21 Mar 2005 18:36:18 +0000 Subject: [PATCH 0062/1290] New file from Uwe Koleska --- modules/ctext/ctext_tcl.tcl | 43 +++++++++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) create mode 100644 modules/ctext/ctext_tcl.tcl diff --git a/modules/ctext/ctext_tcl.tcl b/modules/ctext/ctext_tcl.tcl new file mode 100644 index 00000000..72b467d0 --- /dev/null +++ b/modules/ctext/ctext_tcl.tcl @@ -0,0 +1,43 @@ +# RCS: @(#) $Id: ctext_tcl.tcl,v 1.1 2005/03/21 18:36:18 georgeps Exp $ + +package provide ctext_tcl 0.8 + +proc ctext::setHighlightTcl {w} { + set color(widgets) red3 + set color(flags) orange3 + set color(stackControl) red + set color(vars) magenta4 + set color(variable_funcs) red4 + set color(brackets) DeepPink + set color(comments) blue4 + set color(strings) green4 + + ctext::addHighlightClass $w widgets $color(widgets) \ + [list obutton button label text frame toplevel cscrollbar \ + scrollbar checkbutton canvas listbox menu menubar menubutton \ + radiobutton scale entry message tk_chooseDir tk_getSaveFile \ + tk_getOpenFile tk_chooseColor tk_optionMenu] + + ctext::addHighlightClass $w flags $color(flags) \ + [list -text -command -yscrollcommand \ + -xscrollcommand -background -foreground -fg -bg \ + -highlightbackground -y -x -highlightcolor -relief -width \ + -height -wrap -font -fill -side -outline -style -insertwidth \ + -textvariable -activebackground -activeforeground \ + -insertbackground -anchor -orient -troughcolor -nonewline \ + -expand -type -message -title -offset -in -after -yscroll \ + -xscroll -forward -regexp -count -exact -padx -ipadx \ + -filetypes -all -from -to -label -value -variable \ + -regexp -backwards -forwards -bd -pady -ipady -state -row \ + -column -cursor -highlightcolors -linemap -menu -tearoff \ + -displayof -cursor -underline -tags -tag -length] + + ctext::addHighlightClass $w stackControl $color(stackControl) \ + [list proc uplevel namespace while for foreach if else] + ctext::addHighlightClassWithOnlyCharStart $w vars $color(vars) "\$" + ctext::addHighlightClass $w variable_funcs $color(variable_funcs) \ + [list set global variable unset] + ctext::addHighlightClassForSpecialChars $w brackets $color(brackets) {[]{}} + ctext::addHighlightClassForRegexp $w comments $color(comments) {\#[^\n\r]*} + ctext::addHighlightClassForRegexp $w strings $color(strings) {"(\\"|[^"])*"} +} From 54aaa46034d7e7742c2af7c231e91eb2c713b008 Mon Sep 17 00:00:00 2001 From: georgeps Date: Mon, 21 Mar 2005 18:39:40 +0000 Subject: [PATCH 0063/1290] I added and entry about the new ctext_tcl.tcl syntax mode. --- modules/ctext/ChangeLog | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/modules/ctext/ChangeLog b/modules/ctext/ChangeLog index 0d7cbd56..e6cd1fd8 100644 --- a/modules/ctext/ChangeLog +++ b/modules/ctext/ChangeLog @@ -1,3 +1,12 @@ + +3.1.5 - Mon Mar 21 11:23:09 GMT 2005 + + ctext_tcl.tcl was contributed to ctext by + Uwe Koloska. It provides easy syntax + highlighting for Tcl scripts. He has apparently + added ctext to Nagelfar. + http://spjuth.pointclark.net/Nagelfar.html + 3.1.4 - Thu Aug 12 03:10:06 UTC 2004 ctext.tcl was changed to fix a bug that From 9dbb8c850804d6fc3462165ed688458bf44a1c07 Mon Sep 17 00:00:00 2001 From: afaupell Date: Tue, 22 Mar 2005 09:19:05 +0000 Subject: [PATCH 0064/1290] 2005-03-22 Aaron Faupell * tk_getString.tcl: tweaked padding, made focus -force for windows, fixed namespace, moved variable from ::tk to own namepsace, fixed argument handli --- modules/getstring/ChangeLog | 5 ++++ modules/getstring/tk_getString.tcl | 38 +++++++++++++++++------------- 2 files changed, 26 insertions(+), 17 deletions(-) diff --git a/modules/getstring/ChangeLog b/modules/getstring/ChangeLog index ad8e0fff..2d8978cd 100644 --- a/modules/getstring/ChangeLog +++ b/modules/getstring/ChangeLog @@ -1,3 +1,8 @@ +2005-03-22 Aaron Faupell + + * tk_getString.tcl: tweaked padding, made focus -force for windows, fixed namespace, moved variable from ::tk to own namepsace, fixed argument handling + + 2005-03-17 Aaron Faupell * initial import diff --git a/modules/getstring/tk_getString.tcl b/modules/getstring/tk_getString.tcl index d59f1367..1fee1993 100644 --- a/modules/getstring/tk_getString.tcl +++ b/modules/getstring/tk_getString.tcl @@ -7,17 +7,17 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tk_getString.tcl,v 1.2 2005/03/18 03:15:56 andreas_kupries Exp $ +# RCS: @(#) $Id: tk_getString.tcl,v 1.3 2005/03/22 09:19:05 afaupell Exp $ package require Tk package provide tk_getString 0.1 -namespace eval ::dialogs { +namespace eval ::getstring { namespace export tk_getString } if {[tk windowingsystem] == "win32"} { - option add *TkSDialog*Button.width -10 widgetDefault + option add *TkSDialog*Button.width -8 widgetDefault option add *TkSDialog*Button.padX 1m widgetDefault } else { option add *TkSDialog.borderWidth 1 widgetDefault @@ -25,7 +25,7 @@ if {[tk windowingsystem] == "win32"} { } option add *TkSDialog*Entry.width 20 widgetDefault -proc ::dialogs::getStringEnable {w} { +proc ::getstring::getStringEnable {w} { if {![winfo exists $w.entry]} {return} if {[$w.entry get] != ""} { $w.ok configure -state normal @@ -34,18 +34,21 @@ proc ::dialogs::getStringEnable {w} { } } -proc ::dialogs::tk_getString {w var title text args} { +proc ::getstring::tk_getString {w var title text args} { set allowempty 0 set entryoptions {} + if {([llength $args] % 2) > 0} {error "all options require a single argument"} foreach {opt arg} $args { if {$opt == "-allowempty" && [string is boolean -strict $arg] && $arg} { set allowempty 1 } elseif {[string match -inv* $opt] || [string match -valid* $opt]} { lappend entryoptions $opt $arg + } else { + error "unknown option $opt" } } - variable ::tk::Priv + variable ::getstring::result upvar $var result catch {destroy $w} set focus [focus] @@ -54,31 +57,32 @@ proc ::dialogs::tk_getString {w var title text args} { toplevel $w -relief raised -class TkSDialog wm title $w $title wm iconname $w $title - wm protocol $w WM_DELETE_WINDOW {set ::tk::Priv(button) 0} + wm protocol $w WM_DELETE_WINDOW {set ::getstring::result 0} wm transient $w [winfo toplevel [winfo parent $w]] + wm resizable $w 1 0 eval [list entry $w.entry] $entryoptions - button $w.ok -text OK -default active -command {set ::tk::Priv(button) 1} - button $w.cancel -text Cancel -command {set ::tk::Priv(button) 0} + button $w.ok -text OK -default active -command {set ::getstring::result 1} + button $w.cancel -text Cancel -command {set ::getstring::result 0} label $w.label -text $text - grid $w.label -columnspan 2 -sticky ew -padx 3 -pady 3 - grid $w.entry -columnspan 2 -sticky ew -padx 3 -pady 3 - grid $w.ok $w.cancel -padx 3 -pady 3 + grid $w.label -columnspan 2 -sticky ew -padx 5 -pady 3 + grid $w.entry -columnspan 2 -sticky ew -padx 5 -pady 3 + grid $w.ok $w.cancel -padx 4 -pady 7 grid rowconfigure $w 2 -weight 1 grid columnconfigure $w {0 1} -uniform 1 -weight 1 bind $w [list $w.ok invoke] bind $w [list $w.cancel invoke] - bind $w {set ::tk::Priv(button) 0} + bind $w {set ::getstring::result 0} if {!$allowempty} { - bind $w.entry [list after idle [list ::dialogs::getStringEnable $w]] + bind $w.entry [list after idle [list ::getstring::getStringEnable $w]] $w.ok configure -state disabled } wm withdraw $w update idletasks - focus $w.entry + focus -force $w.entry if {[winfo parent $w] == "."} { set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 - [winfo vrootx $w]}] set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 - [winfo vrooty $w]}] @@ -91,7 +95,7 @@ proc ::dialogs::tk_getString {w var title text args} { wm deiconify $w grab $w - tkwait variable ::tk::Priv(button) + tkwait variable ::getstring::result set result [$w.entry get] bind $w {} grab release $w @@ -99,5 +103,5 @@ proc ::dialogs::tk_getString {w var title text args} { focus -force $focus if {$grab != ""} {grab $grab} update idletasks - return $::tk::Priv(button) + return $::getstring::result } From f04b6701de9fd83243b4531d5871bbdef29a9411 Mon Sep 17 00:00:00 2001 From: afaupell Date: Fri, 25 Mar 2005 02:59:52 +0000 Subject: [PATCH 0065/1290] 2005-03-23 Aaron Faupell * initial import --- modules/history/ChangeLog | 3 + modules/history/history.man | 70 ++++++++++++++++++++++ modules/history/history.tcl | 112 +++++++++++++++++++++++++++++++++++ modules/history/pkgIndex.tcl | 13 ++++ 4 files changed, 198 insertions(+) create mode 100644 modules/history/ChangeLog create mode 100644 modules/history/history.man create mode 100644 modules/history/history.tcl create mode 100644 modules/history/pkgIndex.tcl diff --git a/modules/history/ChangeLog b/modules/history/ChangeLog new file mode 100644 index 00000000..2448d106 --- /dev/null +++ b/modules/history/ChangeLog @@ -0,0 +1,3 @@ +2005-03-23 Aaron Faupell + + * initial import diff --git a/modules/history/history.man b/modules/history/history.man new file mode 100644 index 00000000..3c216a90 --- /dev/null +++ b/modules/history/history.man @@ -0,0 +1,70 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin ipentry n 0.1] +[moddesc {Provides a history for Entry widgets}] +[titledesc {Provides a history for Entry widgets}] +[require Tcl 8.4] +[require history [opt 0.1]] +[description] + +This package provides a convenient history mechanism for Entry widgets. +The history may be accessed with the up and down arrow keys. + +[para] + +[list_begin definitions] + +[call [cmd ::history::init] [arg pathName] [opt length]] + +Arranges to remember the history of the named Entry widget. An optional length +determines the number of history entries to keep. This may be changed later +with [cmd ::history::configure]. History entries must be added with the +[cmd ::history::add] command before they can be seen. + +[call [cmd ::history::remove] [arg pathName]] + +Forgets all history entries for the Entry [arg pathName] and removes the history +bindings. + + +[call [cmd ::history::add] [arg pathName] [arg text]] + +This command is used to add history entries to an Entry that has previously had +[cmd ::history::init] called on it. This command should be called from your Entry +handler with the contents of the entry (or whatever you wish to add to the history). + + +[call [cmd ::history::get] [arg pathName]] + +This command returns a list containing the history entries for the Entry [arg pathName] + +[call [cmd ::history::clear] [arg pathName]] + +This command clears the history list for the named Entry. + +[call [cmd ::history::configure] [arg pathName] [arg option] [opt value]] + +This command queries or sets configuration options. Currently the options recognized +are [arg length] and [arg alert]. Setting the length determines the number of history entries to keep for +the named Entry. Alert specifies the command to run when the user reaches the end of the history, it defaults to [call bell]. Although configure requires a [arg pathName] argument, the setting for alert is global and the path is ignored. + +[list_end] + +[example { +entry .e +bind .e [list ProcessEntry %W] +::history::init .e +pack .e + +proc ProcessEntry {w} { + set text [$w get] + if {$text == ""} { return } + ::history::add $w $text + puts $text + $w delete 0 end +} + +}] + +[keywords entry history] +[manpage_end] + diff --git a/modules/history/history.tcl b/modules/history/history.tcl new file mode 100644 index 00000000..ba68e1f2 --- /dev/null +++ b/modules/history/history.tcl @@ -0,0 +1,112 @@ +# history.tcl -- +# +# Provides a history mechanism for entry widgets +# +# Copyright (c) 2005 Aaron Faupell +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: history.tcl,v 1.1 2005/03/25 02:59:52 afaupell Exp $ + +package provide history 0.1 + +namespace eval history { + bind History {::history::up %W} + bind History {::history::down %W} +} + +proc ::history::init {w {len 30}} { + variable history + variable prefs + set bt [bindtags $w] + if {[lsearch $bt History] > -1} { error "$w already has a history" } + if {[set i [lsearch $bt $w]] < 0} { error "cant find $w in bindtags" } + bindtags $w [linsert $bt [expr {$i + 1}] History] + array set history [list $w,list {} $w,cur -1] + set prefs(maxlen,$w) $len + return $w +} + +proc ::history::remove {w} { + variable history + variable prefs + set bt [bindtags $w] + if {[set i [lsearch $bt History]] < 0} { error "$w has no history" } + bindtags $w [lreplace $bt $i $i] + unset prefs(maxlen,$w) history($w,list) history($w,cur) +} + +proc ::history::add {w line} { + variable history + variable prefs + if {$history($w,cur) > -1 && [lindex $history($w,list) $history($w,cur)] == $line} { + set history($w,list) [lreplace $history($w,list) $history($w,cur) $history($w,cur)] + } + set history($w,list) [linsert $history($w,list) 0 $line] + set history($w,list) [lrange $history($w,list) 0 $prefs(maxlen,$w)] + set history($w,cur) -1 +} + +proc ::history::up {w} { + variable history + if {[lindex $history($w,list) [expr {$history($w,cur) + 1}]] != ""} { + if {$history($w,cur) == -1} { + set history($w,tmp) [$w get] + } + $w delete 0 end + incr history($w,cur) + $w insert end [lindex $history($w,list) $history($w,cur)] + } else { + alert $w + } +} + +proc ::history::down {w} { + variable history + if {$history($w,cur) != -1} { + $w delete 0 end + if {$history($w,cur) == 0} { + $w insert end $history($w,tmp) + set history($w,cur) -1 + } else { + incr history($w,cur) -1 + $w insert end [lindex $history($w,list) $history($w,cur)] + } + } else { + alert $w + } +} + +proc ::history::get {w} { + variable history + return $history($w,list) +} + +proc ::history::clear {w} { + variable history + set history($w,cur) -1 + set history($w,list) {} + unset -nocomplain history($w,tmp) +} + +proc ::history::configure {w option {value {}}} { + variable history + variable prefs + switch -exact -- $option { + length { + if {$value == ""} { return $prefs(maxlen,$w) } + if {![string is integer -strict $value]} { error "length must be an integer" } + set prefs(maxlen,$w) $value + } + alert { + if {$value == ""} { return [info body ::history::alert] } + proc ::history::alert w $value + } + default { + error "unknown option $option" + } + } +} + +proc ::history::alert {w} {bell} diff --git a/modules/history/pkgIndex.tcl b/modules/history/pkgIndex.tcl new file mode 100644 index 00000000..215cdbcb --- /dev/null +++ b/modules/history/pkgIndex.tcl @@ -0,0 +1,13 @@ +# Tcl package index file, version 1.1 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +if { ![package vsatisfies [package provide Tcl] 8.4] } { return } +package ifneeded history 0.1 [list source [file join $dir history.tcl]] + From 66bf6526302354de6e14f7adb2888048a3b98abc Mon Sep 17 00:00:00 2001 From: afaupell Date: Fri, 25 Mar 2005 04:07:58 +0000 Subject: [PATCH 0066/1290] 2005-03-24 Aaron Faupell * autoscroll.tcl: added commands wrap and unwrap * autoscroll.man: added docs for wrap and unwrap, and an example --- modules/autoscroll/ChangeLog | 5 +++ modules/autoscroll/autoscroll.man | 20 +++++++++++ modules/autoscroll/autoscroll.tcl | 56 +++++++++++++++++++++++++++++-- 3 files changed, 79 insertions(+), 2 deletions(-) diff --git a/modules/autoscroll/ChangeLog b/modules/autoscroll/ChangeLog index 5b0d4796..0a84c93c 100644 --- a/modules/autoscroll/ChangeLog +++ b/modules/autoscroll/ChangeLog @@ -1,3 +1,8 @@ +2005-03-24 Aaron Faupell + + * autoscroll.tcl: added commands wrap and unwrap + * autoscroll.man: added docs for wrap and unwrap, and an example + 2003-07-27 Aaron Faupell initial import diff --git a/modules/autoscroll/autoscroll.man b/modules/autoscroll/autoscroll.man index 5d8d3bf8..cc03393d 100644 --- a/modules/autoscroll/autoscroll.man +++ b/modules/autoscroll/autoscroll.man @@ -42,6 +42,26 @@ to be mapped and unmapped as needed. Returns the named scrollbar to its original static state. +[call [cmd ::autoscroll::wrap]] + +Arranges for all scrollbars created after this command is run +to be automatically mapped and unmapped as needed. + +[call [cmd ::autoscroll::unwrap]] + +Turns off the automatic autoscrolling of all new scrollbars. +Does not effect existing scrollbars + [list_end] + +[example { +text .t -yscrollcommand ".scrolly set" +scrollbar .scrolly -orient v -command ".t yview" +pack .scrolly -side right -fill y +pack .t -side left -fill both -expand 1 +::autoscroll::autoscroll .scrolly +}] + + [keywords scroll scrollbar] [manpage_end] diff --git a/modules/autoscroll/autoscroll.tcl b/modules/autoscroll/autoscroll.tcl index dfc82ef9..5c468da0 100644 --- a/modules/autoscroll/autoscroll.tcl +++ b/modules/autoscroll/autoscroll.tcl @@ -1,4 +1,4 @@ -# ipentry.tcl -- +# autoscroll.tcl -- # # Package to create scroll bars that automatically appear when # a window is too small to display its content. @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: autoscroll.tcl,v 1.1 2003/07/28 05:00:27 afaupell Exp $ +# RCS: @(#) $Id: autoscroll.tcl,v 1.2 2005/03/25 04:07:59 afaupell Exp $ package provide autoscroll 1.0 @@ -181,4 +181,56 @@ proc ::autoscroll::destroyed { w } { proc ::autoscroll::map { w } { wm geometry [winfo toplevel $w] [wm geometry [winfo toplevel $w]] +} + + #---------------------------------------------------------------------- + # + # ::autoscroll::wrap -- + # + # Arrange for all new scrollbars to be automatically autoscrolled + # + # Parameters: + # None. + # + # Results: + # None. + # + # Side effects: + # ::scrollbar is overloaded to automatically autoscroll any new + # scrollbars. + # + #---------------------------------------------------------------------- + +proc ::autoscroll::wrap {} { + if {[info commands ::autoscroll::_scrollbar] != ""} {return} + rename ::scrollbar ::autoscroll::_scrollbar + proc ::scrollbar {w args} { + eval ::autoscroll::_scrollbar [list $w] $args + ::autoscroll::autoscroll $w + return $w + } +} + + #---------------------------------------------------------------------- + # + # ::autoscroll::unwrap -- + # + # Turns off automatic autoscrolling of new scrollbars. Does not + # effect existing scrollbars. + # + # Parameters: + # None. + # + # Results: + # None. + # + # Side effects: + # ::scrollbar is returned to its original state + # + #---------------------------------------------------------------------- + +proc ::autoscroll::unwrap {} { + if {[info commands ::autoscroll::_scrollbar] == ""} {return} + rename ::scrollbar {} + rename ::autoscroll::_scrollbar ::scrollbar } \ No newline at end of file From 6bddb9986f734bcd8efa34e84f3500e013e25ded Mon Sep 17 00:00:00 2001 From: afaupell Date: Fri, 25 Mar 2005 19:02:44 +0000 Subject: [PATCH 0067/1290] 2005-03-24 Aaron Faupell * bumped version number for new wrap commands --- modules/autoscroll/ChangeLog | 4 ++++ modules/autoscroll/autoscroll.man | 4 ++-- modules/autoscroll/autoscroll.tcl | 6 +++--- modules/autoscroll/pkgIndex.tcl | 2 +- 4 files changed, 10 insertions(+), 6 deletions(-) diff --git a/modules/autoscroll/ChangeLog b/modules/autoscroll/ChangeLog index 0a84c93c..5d2659d5 100644 --- a/modules/autoscroll/ChangeLog +++ b/modules/autoscroll/ChangeLog @@ -1,3 +1,7 @@ +2005-03-24 Aaron Faupell + + * bumped version number for new wrap commands + 2005-03-24 Aaron Faupell * autoscroll.tcl: added commands wrap and unwrap diff --git a/modules/autoscroll/autoscroll.man b/modules/autoscroll/autoscroll.man index cc03393d..9c5f5328 100644 --- a/modules/autoscroll/autoscroll.man +++ b/modules/autoscroll/autoscroll.man @@ -1,9 +1,9 @@ [comment {-*- tcl -*- doctools manpage}] -[manpage_begin autoscroll n 1.0] +[manpage_begin autoscroll n 1.1] [moddesc {Automatic mapping of scrollbars}] [titledesc {Provides for a scrollbar to automatically mapped and unmapped as needed}] [require Tcl] -[require autoscroll [opt 1.0]] +[require autoscroll [opt 1.1]] [description] This package allows scrollbars to be mapped and diff --git a/modules/autoscroll/autoscroll.tcl b/modules/autoscroll/autoscroll.tcl index 5c468da0..460e851b 100644 --- a/modules/autoscroll/autoscroll.tcl +++ b/modules/autoscroll/autoscroll.tcl @@ -8,9 +8,9 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: autoscroll.tcl,v 1.2 2005/03/25 04:07:59 afaupell Exp $ +# RCS: @(#) $Id: autoscroll.tcl,v 1.3 2005/03/25 19:02:45 afaupell Exp $ -package provide autoscroll 1.0 +package provide autoscroll 1.1 namespace eval ::autoscroll { namespace export autoscroll unautoscroll @@ -233,4 +233,4 @@ proc ::autoscroll::unwrap {} { if {[info commands ::autoscroll::_scrollbar] == ""} {return} rename ::scrollbar {} rename ::autoscroll::_scrollbar ::scrollbar -} \ No newline at end of file +} diff --git a/modules/autoscroll/pkgIndex.tcl b/modules/autoscroll/pkgIndex.tcl index 3995ce13..061c8799 100644 --- a/modules/autoscroll/pkgIndex.tcl +++ b/modules/autoscroll/pkgIndex.tcl @@ -9,5 +9,5 @@ # full path name of this file's directory. if { ![package vsatisfies [package provide Tcl] 8.2] } { return } -package ifneeded autoscroll 1.0 [list source [file join $dir autoscroll.tcl]] +package ifneeded autoscroll 1.1 [list source [file join $dir autoscroll.tcl]] From 37ef067d6a539ba6a70bac20fa0e40b1dbdb091d Mon Sep 17 00:00:00 2001 From: Andreas Kupries Date: Thu, 31 Mar 2005 03:15:47 +0000 Subject: [PATCH 0068/1290] New module, history handling for entry widgets. Can be attached to any entry after the fact. Imported tweaks to getstring dialog, by Aaron Faupell. Ditto fixes for robustness. Import of syntax highlighting for Tcl, contributed by Uwe Kolowska, SF import by GPS. Import of wrap commands, extension to autoscrool by Aaron Faupell. --- modules/autoscroll/autoscroll.tcl | 2 +- modules/ctext/ctext_tcl.tcl | 2 +- modules/getstring/tk_getString.tcl | 2 +- modules/history/history.tcl | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/modules/autoscroll/autoscroll.tcl b/modules/autoscroll/autoscroll.tcl index 460e851b..7a8cb6ee 100644 --- a/modules/autoscroll/autoscroll.tcl +++ b/modules/autoscroll/autoscroll.tcl @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: autoscroll.tcl,v 1.3 2005/03/25 19:02:45 afaupell Exp $ +# RCS: @(#) $Id: autoscroll.tcl,v 1.4 2005/03/31 03:15:47 andreas_kupries Exp $ package provide autoscroll 1.1 diff --git a/modules/ctext/ctext_tcl.tcl b/modules/ctext/ctext_tcl.tcl index 72b467d0..34120e82 100644 --- a/modules/ctext/ctext_tcl.tcl +++ b/modules/ctext/ctext_tcl.tcl @@ -1,4 +1,4 @@ -# RCS: @(#) $Id: ctext_tcl.tcl,v 1.1 2005/03/21 18:36:18 georgeps Exp $ +# RCS: @(#) $Id: ctext_tcl.tcl,v 1.2 2005/03/31 03:15:48 andreas_kupries Exp $ package provide ctext_tcl 0.8 diff --git a/modules/getstring/tk_getString.tcl b/modules/getstring/tk_getString.tcl index 1fee1993..eb728509 100644 --- a/modules/getstring/tk_getString.tcl +++ b/modules/getstring/tk_getString.tcl @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tk_getString.tcl,v 1.3 2005/03/22 09:19:05 afaupell Exp $ +# RCS: @(#) $Id: tk_getString.tcl,v 1.4 2005/03/31 03:15:48 andreas_kupries Exp $ package require Tk package provide tk_getString 0.1 diff --git a/modules/history/history.tcl b/modules/history/history.tcl index ba68e1f2..2724f22d 100644 --- a/modules/history/history.tcl +++ b/modules/history/history.tcl @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: history.tcl,v 1.1 2005/03/25 02:59:52 afaupell Exp $ +# RCS: @(#) $Id: history.tcl,v 1.2 2005/03/31 03:15:48 andreas_kupries Exp $ package provide history 0.1 From cc2e09948a297481d07bffe92fb87d6f7f61811d Mon Sep 17 00:00:00 2001 From: Andreas Kupries Date: Thu, 31 Mar 2005 20:03:47 +0000 Subject: [PATCH 0069/1290] * installed_modules.tcl: Added 'get'string' and 'history' to the list of installed modules. These are new modules added a few days ago, by Aaron Faupell. --- ChangeLog | 8 +++++++- installed_modules.tcl | 6 ++++-- 2 files changed, 11 insertions(+), 3 deletions(-) diff --git a/ChangeLog b/ChangeLog index f04d02e0..4825bb90 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,8 +1,14 @@ +2005-03-31 Andreas Kupries + + * installed_modules.tcl: Added 'get'string' and 'history' to the + list of installed modules. These are new modules added a few + days ago, by Aaron Faupell. + 2004-07-22 Jeff Hobbs * installed_modules.tcl: added ico to list of installed modules. * modules/ico/*: new 'ico' module for extracting icos from exe/ico - files - works x-platform. + files - works x-platform. 2004-06-29 Andreas Kupries diff --git a/installed_modules.tcl b/installed_modules.tcl index 6955f752..0980db1f 100755 --- a/installed_modules.tcl +++ b/installed_modules.tcl @@ -17,13 +17,15 @@ set modules [list] array set guide {} foreach {m pkg doc exa} { autoscroll _tcl _man _null - cursor _tcl _man _null ctext _ctxt _man _null + cursor _tcl _man _null datefield _tcl _man _null + getstring _tcl _man _null + history _tcl _man _null ico _tcl _man _null ipentry _tcl _man _null - style _tcl _man _null plotchart _tcl _man _exa + style _tcl _man _null tkpiechart _tcl _man _null } { lappend modules $m From cee5766417029ec4fa703725b466dcb501db46f9 Mon Sep 17 00:00:00 2001 From: afaupell Date: Fri, 1 Apr 2005 03:41:55 +0000 Subject: [PATCH 0070/1290] 2005-03-31 Aaron Faupell * Fixed argument handling again, added -geometry option --- modules/getstring/ChangeLog | 8 +++- modules/getstring/tk_getString.man | 32 +++++++++------ modules/getstring/tk_getString.tcl | 65 +++++++++++++++++++----------- 3 files changed, 68 insertions(+), 37 deletions(-) diff --git a/modules/getstring/ChangeLog b/modules/getstring/ChangeLog index 2d8978cd..5c2ae4d0 100644 --- a/modules/getstring/ChangeLog +++ b/modules/getstring/ChangeLog @@ -1,6 +1,12 @@ +2005-03-31 Aaron Faupell + + * Fixed argument handling again, added -geometry option + 2005-03-22 Aaron Faupell - * tk_getString.tcl: tweaked padding, made focus -force for windows, fixed namespace, moved variable from ::tk to own namepsace, fixed argument handling + * tk_getString.tcl: tweaked padding, made focus -force for windows, + fixed namespace, moved variable from ::tk to own namepsace, + fixed argument handling 2005-03-17 Aaron Faupell diff --git a/modules/getstring/tk_getString.man b/modules/getstring/tk_getString.man index d9bde4f9..24c458cb 100644 --- a/modules/getstring/tk_getString.man +++ b/modules/getstring/tk_getString.man @@ -6,31 +6,39 @@ [require tk_getString [opt 0.1]] [description] -This package provides a dialog which consists of an Entry, OK, and Cancel buttons. +This package provides a dialog which consists of an Entry, OK, and +Cancel buttons. [para] [list_begin definitions] -[call [cmd ::dialogs::tk_getString] [arg pathName] [arg variable] [arg title] [arg text] [opt options]] +[call [cmd ::getstring::tk_getString] [arg pathName] [arg variable] [arg text]\ +[opt options]] -Creates a dialog which prompts the user with [arg text] to input a text string. The contents of -the entry is put in the [arg variable] upon closure of the dialog. The command returns a boolean -indicating if the user pressed OK or not. The dialog is centered in its parent toplevel unless -its parent is . in which case the dialog is centered in the screen. The currently recognized -options are -allowempty, -validate, -invalidcmd, and -validatecmd. -allowempty takes a boolean -argument indicating if the dialog should accept an empty entry. The validation options simply -pass their arguments through to the entry widget. +Creates a dialog which prompts the user with [arg text] to input a text string. +The contents of the entry are put in the [arg variable] upon closure of the +dialog. The command returns a boolean indicating if the user pressed OK or +not. If -geometry is not specified, the dialog is centered in its parent +toplevel unless its parent is . in which case the dialog is centered in the +screen. + +Options: +-title +-allowempty a boolean argument indicating if the dialog should accept an empty entry +-entryoptions simply passes its arguments through to the entry widget. This is valuble for performing extra validation +using the Entry widget validation hooks. +-geometry specifies the geometry of the window [list_end] [section EXAMPLE] [example { -package require tk_getString -namespace import tk_getString::* +package require getstring +namespace import getstring::* -if {[tk_getString .gs text "String Dialog" "Feed me a string please:"]} { +if {[tk_getString .gs text "Feed me a string please:"]} { puts "user entered: $text" } diff --git a/modules/getstring/tk_getString.tcl b/modules/getstring/tk_getString.tcl index eb728509..c159bc77 100644 --- a/modules/getstring/tk_getString.tcl +++ b/modules/getstring/tk_getString.tcl @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tk_getString.tcl,v 1.4 2005/03/31 03:15:48 andreas_kupries Exp $ +# RCS: @(#) $Id: tk_getString.tcl,v 1.5 2005/04/01 03:41:55 afaupell Exp $ package require Tk package provide tk_getString 0.1 @@ -25,28 +25,14 @@ if {[tk windowingsystem] == "win32"} { } option add *TkSDialog*Entry.width 20 widgetDefault -proc ::getstring::getStringEnable {w} { - if {![winfo exists $w.entry]} {return} - if {[$w.entry get] != ""} { - $w.ok configure -state normal - } else { - $w.ok configure -state disabled - } -} - -proc ::getstring::tk_getString {w var title text args} { - set allowempty 0 - set entryoptions {} - if {([llength $args] % 2) > 0} {error "all options require a single argument"} - foreach {opt arg} $args { - if {$opt == "-allowempty" && [string is boolean -strict $arg] && $arg} { - set allowempty 1 - } elseif {[string match -inv* $opt] || [string match -valid* $opt]} { - lappend entryoptions $opt $arg - } else { - error "unknown option $opt" - } +proc ::getstring::tk_getString {w var text args} { + array set options { + -allowempty 0 + -entryoptions {} + -title "Enter Information" } + parseOpts options {{-allowempty boolean} {-entryoptions {}} {-geometry {}} \ + {-title {}} $args variable ::getstring::result upvar $var result @@ -83,15 +69,18 @@ proc ::getstring::tk_getString {w var title text args} { wm withdraw $w update idletasks focus -force $w.entry - if {[winfo parent $w] == "."} { + if {[info exists options(-geometry)]} { + wm geometry $w $options(-geometry) + } elseif {[winfo parent $w] == "."} { set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 - [winfo vrootx $w]}] set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 - [winfo vrooty $w]}] + wm geom $w +$x+$y } else { set t [winfo toplevel [winfo parent $w]] set x [expr {[winfo width $t]/2 - [winfo reqwidth $w]/2 - [winfo vrootx $w]}] set y [expr {[winfo height $t]/2 - [winfo reqheight $w]/2 - [winfo vrooty $w]}] + wm geom $w +$x+$y } - wm geom $w +$x+$y wm deiconify $w grab $w @@ -105,3 +94,31 @@ proc ::getstring::tk_getString {w var title text args} { update idletasks return $::getstring::result } + +proc ::getstring::parseOpts {var opts input} { + upvar $var output + for {set i 0} {$i < [llength $input]} {incr i} { + for {set a 0} {$a < [llength $opts]} {incr a} { + if {[lindex $opts $a 0] == [lindex $input $i]} { break } + } + if {$a == [llength $opts]} { error "unknown option [lindex $input $i]" } + set opt [lindex $opts $a] + if {[llength $opt] > 1} { + foreach {opt type} $opt {break} + if {[incr i] >= [llength $input]} { error "$opt requires an argument" } + if {$type != "" && ![string is $type -strict [lindex $input $i]]} { error "$opt requires argument of type $type" } + set output($opt) [lindex $input $i] + } else { + set output($opt) {} + } + } +} + +proc ::getstring::getStringEnable {w} { + if {![winfo exists $w.entry]} {return} + if {[$w.entry get] != ""} { + $w.ok configure -state normal + } else { + $w.ok configure -state disabled + } +} \ No newline at end of file From 30efbd2980bea0c962a618715f66323578fff668 Mon Sep 17 00:00:00 2001 From: afaupell Date: Fri, 1 Apr 2005 03:52:41 +0000 Subject: [PATCH 0071/1290] 2005-03-31 Aaron Faupell * initial import --- modules/swaplist/ChangeLog | 3 + modules/swaplist/pkgIndex.tcl | 13 ++ modules/swaplist/swaplist.man | 52 +++++ modules/swaplist/swaplist.tcl | 396 ++++++++++++++++++++++++++++++++++ 4 files changed, 464 insertions(+) create mode 100644 modules/swaplist/ChangeLog create mode 100644 modules/swaplist/pkgIndex.tcl create mode 100644 modules/swaplist/swaplist.man create mode 100755 modules/swaplist/swaplist.tcl diff --git a/modules/swaplist/ChangeLog b/modules/swaplist/ChangeLog new file mode 100644 index 00000000..406192d4 --- /dev/null +++ b/modules/swaplist/ChangeLog @@ -0,0 +1,3 @@ +2005-03-31 Aaron Faupell + + * initial import diff --git a/modules/swaplist/pkgIndex.tcl b/modules/swaplist/pkgIndex.tcl new file mode 100644 index 00000000..12dff914 --- /dev/null +++ b/modules/swaplist/pkgIndex.tcl @@ -0,0 +1,13 @@ +# Tcl package index file, version 1.1 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +if { ![package vsatisfies [package provide Tcl] 8.4] } { return } +package ifneeded swaplist 0.1 [list source [file join $dir swaplist.tcl]] + diff --git a/modules/swaplist/swaplist.man b/modules/swaplist/swaplist.man new file mode 100644 index 00000000..3bd98f3f --- /dev/null +++ b/modules/swaplist/swaplist.man @@ -0,0 +1,52 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin getstring n 0.1] +[moddesc {A dialog which allows a user to move options between two lists}] +[titledesc {A dialog which allows a user to move options between two lists}] +[require Tcl 8.4] +[require swaplist [opt 0.1]] +[description] + +This package provides a dialog which consists of 2 listboxes, along with buttons to move items +between them and reorder the right list. +[para] + +[list_begin definitions] + +[call [cmd ::swaplist::swaplist] [arg pathName] [arg variable] [arg completeList] [arg selectedList] [opt options]] + +Creates a dialog which presents the user with a pair of listboxes. Items are selected by using the buttons to move +them to the right list. The contents of the right list are put in the [arg variable] upon closure of the dialog. +The command returns a boolean indicating if the user pressed OK or not. If -geometry is not specified, the +dialog is centered in its parent toplevel unless its parent is . in which case the dialog is centered in the screen. + +Options: +-embed if this flag is supplied, the procedure will create a swaplist widget named [arg pathName], with the [arg variable] set as the +listvariable for the right side listbox. This flag will also cause the -title and -geometry flags to be ignored. +-reorder boolean specifying if buttons allowing the user to change the order of the right listbox should appear or not. defaults to true +-title sets the title of the dialog window. defaults to "Configuration" +-llabel sets the heading above the left list. defaults to "Available:" +-rlabel sets the heading above the right list. defaults to "Selected:" +-lbuttontext sets the text on the "move left" button. defaults to "<<" +-rbuttontext sets the text on the "move right" button. defaults to ">>" +-ubuttontext sets the text on the "move up" button. defaults to "Move Up" +-dbuttontext sets the text on the "move down" button. defaults to "Move Down" +-geometry sets the geometry of the dialog window. +screen. + +[list_end] + +[section EXAMPLE] + +[example { +package require swaplist +namespace import swaplist::* + +if {[swaplist .slist opts "1 2 3 4 5 6 7 8 9" "1 3 5"]} { + puts "user chose numbers: $ops" +} + +}] + +[keywords dialog disjointlistbox listbox] +[manpage_end] + diff --git a/modules/swaplist/swaplist.tcl b/modules/swaplist/swaplist.tcl new file mode 100755 index 00000000..dd2e1fbd --- /dev/null +++ b/modules/swaplist/swaplist.tcl @@ -0,0 +1,396 @@ +# swaplist.tcl -- +# +# A dialog which allows a user to move options between two lists +# +# Copyright (c) 2005 Aaron Faupell +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: swaplist.tcl,v 1.1 2005/04/01 03:52:41 afaupell Exp $ + +package provide swaplist 0.1 + +namespace eval swaplist { + namespace export swaplist +} + +if {[tk windowingsystem] == "win32"} { + option add *Swaplist*Button.width -10 widgetDefault + option add *Swaplist*Button.padX 1m widgetDefault + option add *Swaplist*Border.borderWidth 2 widgetDefault + option add *Swaplist*Border*Listbox.borderWidth 0 widgetDefault +} else { + option add *Swaplist.borderWidth 1 widgetDefault + option add *Swaplist*Button.width 5 widgetDefault +} + +proc ::swaplist::swaplist {w var list1 list2 args} { + array set options { + -title "Configuration" + } + parseOpts options {{-llabel {}} {-rlabel {}} {-title {}} -embed \ + {-reorder boolean} {-geometry {}} {-lbuttontext {}} \ + {-rbuttontext {}} {-ubuttontext {}} {-dbuttontext {}}} \ + $args + + if {[info exists options(-embed)]} { + frame $w + unset options(-embed) + return [eval [list ::swaplist::createSwaplist $w $var $list1 $list2] [array get options]] + } + + catch {destroy $w} + set focus [focus] + set grab [grab current .] + + toplevel $w -class Swaplist -relief raised + wm title $w $options(-title) + wm protocol $w WM_DELETE_WINDOW {set ::swaplist::whichButton 0} + wm transient $w [winfo toplevel [winfo parent $w]] + + eval [list ::swaplist::createSwaplist $w ::swaplist::selectedList $list1 $list2] [array get options] + + frame $w.oc -pady 7 + button $w.oc.ok -default active -text "OK" -command {set ::swaplist::whichButton 1} + button $w.oc.cancel -text "Cancel" -command {set ::swaplist::whichButton 0} + pack $w.oc.cancel -side right -padx 7 + pack $w.oc.ok -side right + grid $w.oc -columnspan 4 -row 2 -column 0 -sticky ew -columnspan 4 + + bind $w [list $w.oc.ok invoke] + bind $w [list $w.oc.cancel invoke] + bind $w {set ::swaplist::whichButton 0} + + #SetButtonState $w + + wm withdraw $w + update idletasks + if {[info exists options(-geometry)]} { + wm geometry $w $options(-geometry) + } elseif {[winfo parent $w] == "."} { + set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 - [winfo vrootx $w]}] + set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 - [winfo vrooty $w]}] + wm geometry $w +$x+$y + } else { + set t [winfo toplevel [winfo parent $w]] + set x [expr {[winfo width $t]/2 - [winfo reqwidth $w]/2 - [winfo vrootx $w]}] + set y [expr {[winfo height $t]/2 - [winfo reqheight $w]/2 - [winfo vrooty $w]}] + wm geometry $w +$x+$y + } + wm deiconify $w + grab $w + + tkwait variable ::swaplist::whichButton + upvar $var results + set results $::swaplist::selectedList + bind $w {} + grab release $w + destroy $w + focus -force $focus + if {$grab != ""} {grab $grab} + update idletasks + return $::swaplist::whichButton +} + +proc ::swaplist::createSwaplist {w var list1 list2 args} { + array set options { + -reorder 1 + -llabel "Available:" + -rlabel "Selected:" + -lbuttontext "<<" + -rbuttontext ">>" + -ubuttontext "Move Up" + -dbuttontext "Move Down" + } + parseOpts options {{-llabel {}} {-rlabel {}} {-title {}} \ + {-reorder boolean} {-lbuttontext {}} {-geometry {}}\ + {-rbuttontext {}} {-ubuttontext {}} {-dbuttontext {}}} \ + $args + + set olist $list1 + + # remove items in list2 from list1 + foreach x $list2 { + if {[set i [lsearch $list1 $x]] >= 0} { + set list1 [lreplace $list1 $i $i] + } + } + + label $w.heading1 -text $options(-llabel) -anchor w + label $w.heading2 -text $options(-rlabel) -anchor w + + foreach x {list1 list2} { + frame $w.$x -class Border -relief sunken + scrollbar $w.$x.scrolly -orient v -command [list $w.$x.list yview] + scrollbar $w.$x.scrollx -orient h -command [list $w.$x.list xview] + listbox $w.$x.list -selectmode extended -yscrollcommand [list $w.$x.scrolly set] -xscrollcommand [list $w.$x.scrollx set] + grid $w.$x.list -row 0 -column 0 -sticky nesw + grid $w.$x.scrolly -row 0 -column 1 -sticky ns + grid $w.$x.scrollx -row 1 -column 0 -sticky ew + grid columnconfigure $w.$x 0 -weight 1 + grid rowconfigure $w.$x 0 -weight 1 + } + $w.list2.list configure -listvariable $var + $w.list2.list delete 0 end + eval [list $w.list1.list insert end] $list1 + eval [list $w.list2.list insert end] $list2 + + set width [min 5 $options(-lbuttontext) $options(-rbuttontext)] + frame $w.lr + button $w.lr.left -width $width -text $options(-lbuttontext) -command [list ::swaplist::ShiftL $w $olist] + if {$options(-reorder)} { + button $w.lr.right -width $width -text $options(-rbuttontext) -command [list ::swaplist::ShiftRNormal $w $olist] + } else { + button $w.lr.right -width $width -text $options(-rbuttontext) -command [list ::swaplist::ShiftRNoReorder $w $olist] + } + grid $w.lr.right -pady 4 + grid $w.lr.left -pady 4 + grid columnconfigure $w.lr 0 -uniform 1 + + set width [min 3 $options(-ubuttontext) $options(-dbuttontext)] + frame $w.ud + button $w.ud.up -width $width -text $options(-ubuttontext) -command [list ::swaplist::ShiftUD $w.list2.list u] + button $w.ud.down -width $width -text $options(-dbuttontext) -command [list ::swaplist::ShiftUD $w.list2.list d] + pack $w.ud.up -side top -pady 4 + pack $w.ud.down -side bottom -pady 4 + + grid $w.heading1 -row 0 -column 0 -sticky ew -padx {3 0} -pady 3 + grid $w.heading2 -row 0 -column 2 -sticky ew -padx {0 3} -pady 3 + grid $w.list1 -row 1 -column 0 -sticky nesw -padx {3 0} + grid $w.lr -row 1 -column 1 -padx 7 + grid $w.list2 -row 1 -column 2 -sticky nesw -padx {0 3} + if {$options(-reorder)} { + grid $w.ud -row 1 -column 3 -padx {2 5} + } + grid columnconfigure $w {0 2} -weight 1 + grid rowconfigure $w 1 -weight 1 + + bind $w [list ::swaplist::UpDown %W %K] + bind $w [list ::swaplist::UpDown %W %K] + bind $w.list1.list [list ::swaplist::Double %W] + bind $w.list2.list [list ::swaplist::Double %W] + #bind $w.list1.list <> [list ::swaplist::SetButtonState %W] + #bind $w.list2.list <> [list ::swaplist::SetButtonState %W] + + if {![catch {package present autoscroll}]} { + ::autoscroll::autoscroll $w.list1.scrollx + ::autoscroll::autoscroll $w.list1.scrolly + ::autoscroll::autoscroll $w.list2.scrollx + ::autoscroll::autoscroll $w.list2.scrolly + } + + #SetButtonState $w + return $w +} + +proc ::swaplist::parseOpts {var opts input} { + upvar $var output + for {set i 0} {$i < [llength $input]} {incr i} { + for {set a 0} {$a < [llength $opts]} {incr a} { + if {[lindex $opts $a 0] == [lindex $input $i]} { break } + } + if {$a == [llength $opts]} { error "unknown option [lindex $input $i]" } + set opt [lindex $opts $a] + if {[llength $opt] > 1} { + foreach {opt type} $opt {break} + if {[incr i] >= [llength $input]} { error "$opt requires an argument" } + if {$type != "" && ![string is $type -strict [lindex $input $i]]} { error "$opt requires argument of type $type" } + set output($opt) [lindex $input $i] + } else { + set output($opt) {} + } + } +} + +# return the min unless string1 or string2 is longer, if so return length of the longer one +proc ::swaplist::min {min s1 s2} { + if {[string length $s1] > $min || [string length $s2] > $min} { + return [expr { + ([string length $s1] > [string length $s2]) \ + ? [string length $s1] \ + : [string length $s2] + }] + } else { + return $min + } +} + +# return a list in reversed order +proc ::swaplist::lreverse {list} { + set new {} + foreach x $list {set new [linsert $new 0 $x]} + return $new +} + +# binding for "move left" button +proc ::swaplist::ShiftL {w olist} { + set from $w.list2.list + set to $w.list1.list + + if {[set cur [$from curselection]] == ""} { return } + foreach x [lreverse $cur] { + set name [$from get $x] + $from delete $x + set i [FindPos $olist [$to get 0 end] $name] + $to insert $i $name + $to selection set $i + } + if {[llength $cur] == 1} {$to see $i} + if {[lindex $cur 0] == 0} { + $from selection set 0 + } elseif {[lindex $cur 0] == [$from index end]} { + $from selection set end + } else { + $from selection set [lindex $cur 0] + } +} + +# binding for "move right" button if -reorder is true +proc ::swaplist::ShiftRNormal {w olist} { + set from $w.list1.list + set to $w.list2.list + + if {[set cur [$from curselection]] == ""} { return } + $to selection clear 0 end + foreach x $cur { + $to insert end [$from get $x] + $to selection set end + } + foreach x [lreverse $cur] { + $from delete $x + } + $to see end +} + +# binding for "move right" button if -reorder is false +proc ::swaplist::ShiftRNoReorder {w olist} { + set from $w.list1.list + set to $w.list2.list + + if {[set cur [$from curselection]] == ""} { return } + foreach x $cur { + set name [$from get $x] + $to insert [FindPos $olist [$to get 0 end] $name] $name + } + foreach x [lreverse $cur] { $from delete $x } + if {[$from index end] == 0} { + foreach x $new {$to selection set $x} + } elseif {[lindex $cur 0] == 0} { + $from selection set 0 + } elseif {[lindex $cur 0] == [$from index end]} { + $from selection set end + } else { + $from selection set [lindex $cur 0] + } +} + +# binding for "move up" and "move down" buttons +proc ::swaplist::ShiftUD {w dir} { + if {[set sel [$w curselection]] == ""} { return } + set list {} + # delete in reverse order so shifting indexes dont bite us + foreach x [lreverse $sel] { + # make a list in correct order with the items index and contents + set list [linsert $list 0 [list $x [$w get $x]]] + $w delete $x + } + if {$dir == "u"} { + set n 0 + foreach x $list { + set i [lindex $x 0] + if {[incr i -1] < $n} {set i $n} + $w insert $i [lindex $x 1] + $w selection set $i + incr n + } + $w see [expr {[lindex $list 0 0] - 1}] + } + if {$dir == "d"} { + set n [$w index end] + foreach x $list { + set i [lindex $x 0] + if {[incr i] > $n} {set i $n} + $w insert $i [lindex $x 1] + $w selection set $i + incr n + } + $w see $i + } +} + +# find the position $el should have in $curlist, by looking at $olist +# $curlist should be a subset of $olist +proc ::swaplist::FindPos {olist curlist el} { + set orig [lsearch $olist $el] + set end [llength $curlist] + for {set i 0} {$i <= $end} {incr i} { + if {[lsearch $olist [lindex $curlist $i]] > $orig} { break } + } + return $i +} + +# binding for the up and down arrow keys, just dispatch and have tk +# do the right thing +proc ::swaplist::UpDown {w key} { + if {[winfo toplevel $w] != $w} {return} + if {[set cur [$w.list2.list curselection]] != ""} { + tk::ListboxUpDown $w.list2.list [string map {Up -1 Down 1} $key] + } elseif {[set cur [$w.list1.list curselection]] != ""} { + tk::ListboxUpDown $w.list1.list [string map {Up -1 Down 1} $key] + } else { + return + } +} + +# binding for double click, just invoke the left or right button +proc ::swaplist::Double {w} { + set top [winfo toplevel $w] + if {[string match *.list1.* $w]} { + $top.lr.right invoke + } elseif {[string match *.list2.* $w]} { + $top.lr.left invoke + } +} + +proc ::swaplist::SetButtonState {w} { + set top [winfo toplevel $w] + if {[$top.list2.list curselection] != ""} { + $top.lr.left configure -state normal + $top.lr.right configure -state disabled + } elseif {[$top.list1.list curselection] != ""} { + $top.lr.left configure -state disabled + $top.lr.right configure -state normal + } else { + $top.lr.left configure -state disabled + $top.lr.right configure -state disabled + } + + if {[set cur [$top.list2.list curselection]] == ""} { + $top.ud.up configure -state disabled + $top.ud.down configure -state disabled + } elseif {$cur == 0} { + $top.ud.up configure -state disabled + $top.ud.down configure -state normal + } elseif {$cur == ([$top.list2.list index end] - 1)} { + $top.ud.up configure -state normal + $top.ud.down configure -state disabled + } else { + $top.ud.up configure -state normal + $top.ud.down configure -state normal + } +} + + +console show +puts [swaplist::swaplist .config var "name_f name_l phone_h phone_w pager phone_c email_h email_w fax_h fax_w street_h street_w city_h city_w state_h state_w zip_h zip_w notes" "5"] +puts $var +puts [swaplist::swaplist .config var "1 2 3 4 5 6 7 8 9" "1 3 5" -reorder 1 -ubuttontext "/\\" -dbuttontext "\\/" -reorder 0] +puts $var + +toplevel .t +namespace eval ::test {set blah {1 2 3}} +pack [swaplist::swaplist .t.f ::test::blah {a b c} {a} -embed] -expand 1 -fill both +puts $var +puts $::test::blah +#exit From caecabad9f4437e54fc38372893b787d9aece4d0 Mon Sep 17 00:00:00 2001 From: afaupell Date: Fri, 1 Apr 2005 04:44:34 +0000 Subject: [PATCH 0072/1290] *** empty log message *** --- modules/swaplist/swaplist.tcl | 15 +-------------- 1 file changed, 1 insertion(+), 14 deletions(-) diff --git a/modules/swaplist/swaplist.tcl b/modules/swaplist/swaplist.tcl index dd2e1fbd..e6d3c7b5 100755 --- a/modules/swaplist/swaplist.tcl +++ b/modules/swaplist/swaplist.tcl @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: swaplist.tcl,v 1.1 2005/04/01 03:52:41 afaupell Exp $ +# RCS: @(#) $Id: swaplist.tcl,v 1.2 2005/04/01 04:44:34 afaupell Exp $ package provide swaplist 0.1 @@ -381,16 +381,3 @@ proc ::swaplist::SetButtonState {w} { } } - -console show -puts [swaplist::swaplist .config var "name_f name_l phone_h phone_w pager phone_c email_h email_w fax_h fax_w street_h street_w city_h city_w state_h state_w zip_h zip_w notes" "5"] -puts $var -puts [swaplist::swaplist .config var "1 2 3 4 5 6 7 8 9" "1 3 5" -reorder 1 -ubuttontext "/\\" -dbuttontext "\\/" -reorder 0] -puts $var - -toplevel .t -namespace eval ::test {set blah {1 2 3}} -pack [swaplist::swaplist .t.f ::test::blah {a b c} {a} -embed] -expand 1 -fill both -puts $var -puts $::test::blah -#exit From 3b540a96471a205180d2659351807a5b95c272d1 Mon Sep 17 00:00:00 2001 From: Andreas Kupries Date: Fri, 1 Apr 2005 17:46:24 +0000 Subject: [PATCH 0073/1290] * tklib_history.man: Typo fix in manpage_begin. * history.man: Renamed to "tklib_history.man" to avoid clashing with the "history.n" manpage provided by the Tcl core itself. --- modules/history/ChangeLog | 7 +++++++ modules/history/{history.man => tklib_history.man} | 2 +- 2 files changed, 8 insertions(+), 1 deletion(-) rename modules/history/{history.man => tklib_history.man} (98%) diff --git a/modules/history/ChangeLog b/modules/history/ChangeLog index 2448d106..9b720cda 100644 --- a/modules/history/ChangeLog +++ b/modules/history/ChangeLog @@ -1,3 +1,10 @@ +2005-04-01 Andreas Kupries + + * tklib_history.man: Typo fix in manpage_begin. + + * history.man: Renamed to "tklib_history.man" to avoid clashing + with the "history.n" manpage provided by the Tcl core itself. + 2005-03-23 Aaron Faupell * initial import diff --git a/modules/history/history.man b/modules/history/tklib_history.man similarity index 98% rename from modules/history/history.man rename to modules/history/tklib_history.man index 3c216a90..c7633782 100644 --- a/modules/history/history.man +++ b/modules/history/tklib_history.man @@ -1,5 +1,5 @@ [comment {-*- tcl -*- doctools manpage}] -[manpage_begin ipentry n 0.1] +[manpage_begin history n 0.1] [moddesc {Provides a history for Entry widgets}] [titledesc {Provides a history for Entry widgets}] [require Tcl 8.4] From 3ebd54154f2b6ff2dba3a25f3ee10d581e9fb4f5 Mon Sep 17 00:00:00 2001 From: Andreas Kupries Date: Fri, 1 Apr 2005 18:03:05 +0000 Subject: [PATCH 0074/1290] * swaplist.man: Fixed typo in heading, a reference to 'getstring'. Also made the list of options a true list. --- modules/swaplist/ChangeLog | 5 +++++ modules/swaplist/swaplist.man | 42 +++++++++++++++++++++++++---------- 2 files changed, 35 insertions(+), 12 deletions(-) diff --git a/modules/swaplist/ChangeLog b/modules/swaplist/ChangeLog index 406192d4..c7b39ac2 100644 --- a/modules/swaplist/ChangeLog +++ b/modules/swaplist/ChangeLog @@ -1,3 +1,8 @@ +2005-04-01 Andreas Kupries + + * swaplist.man: Fixed typo in heading, a reference to + 'getstring'. Also made the list of options a true list. + 2005-03-31 Aaron Faupell * initial import diff --git a/modules/swaplist/swaplist.man b/modules/swaplist/swaplist.man index 3bd98f3f..bfa1ab93 100644 --- a/modules/swaplist/swaplist.man +++ b/modules/swaplist/swaplist.man @@ -1,5 +1,5 @@ [comment {-*- tcl -*- doctools manpage}] -[manpage_begin getstring n 0.1] +[manpage_begin swaplist n 0.1] [moddesc {A dialog which allows a user to move options between two lists}] [titledesc {A dialog which allows a user to move options between two lists}] [require Tcl 8.4] @@ -19,19 +19,37 @@ them to the right list. The contents of the right list are put in the [arg varia The command returns a boolean indicating if the user pressed OK or not. If -geometry is not specified, the dialog is centered in its parent toplevel unless its parent is . in which case the dialog is centered in the screen. +[nl] + Options: --embed if this flag is supplied, the procedure will create a swaplist widget named [arg pathName], with the [arg variable] set as the + +[comment { + The list below is the simplest for describing options. + + A more complex is to use 'tkoption' instead of 'opt', + and 'tkoption_def' instead of 'opt_def'. + + I (AK) refrained from doing so as I do not know the + names and classes used for the options in the option + database. +}] + +[list_begin opt] + +[opt_def -embed] if this flag is supplied, the procedure will create a swaplist widget named [arg pathName], with the [arg variable] set as the listvariable for the right side listbox. This flag will also cause the -title and -geometry flags to be ignored. --reorder boolean specifying if buttons allowing the user to change the order of the right listbox should appear or not. defaults to true --title sets the title of the dialog window. defaults to "Configuration" --llabel sets the heading above the left list. defaults to "Available:" --rlabel sets the heading above the right list. defaults to "Selected:" --lbuttontext sets the text on the "move left" button. defaults to "<<" --rbuttontext sets the text on the "move right" button. defaults to ">>" --ubuttontext sets the text on the "move up" button. defaults to "Move Up" --dbuttontext sets the text on the "move down" button. defaults to "Move Down" --geometry sets the geometry of the dialog window. -screen. + +[opt_def -reorder] boolean specifying if buttons allowing the user to change the order of the right listbox should appear or not. defaults to true +[opt_def -title] sets the title of the dialog window. defaults to "Configuration" +[opt_def -llabel] sets the heading above the left list. defaults to "Available:" +[opt_def -rlabel] sets the heading above the right list. defaults to "Selected:" +[opt_def -lbuttontext] sets the text on the "move left" button. defaults to "<<" +[opt_def -rbuttontext] sets the text on the "move right" button. defaults to ">>" +[opt_def -ubuttontext] sets the text on the "move up" button. defaults to "Move Up" +[opt_def -dbuttontext] sets the text on the "move down" button. defaults to "Move Down" +[opt_def -geometry] sets the geometry of the dialog window. screen. + +[list_end] [list_end] From 5b3166861e59cfdfca2b49cb1e70f5a41cee55e6 Mon Sep 17 00:00:00 2001 From: Andreas Kupries Date: Fri, 1 Apr 2005 18:13:25 +0000 Subject: [PATCH 0075/1290] * installed_modules.tcl: Added new module 'swap_list' to the list of installed modules. --- ChangeLog | 5 +++++ installed_modules.tcl | 1 + 2 files changed, 6 insertions(+) diff --git a/ChangeLog b/ChangeLog index 4825bb90..8ebf6350 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2005-04-01 Andreas Kupries + + * installed_modules.tcl: Added new module 'swap_list' to the list + of installed modules. + 2005-03-31 Andreas Kupries * installed_modules.tcl: Added 'get'string' and 'history' to the diff --git a/installed_modules.tcl b/installed_modules.tcl index 0980db1f..773d524d 100755 --- a/installed_modules.tcl +++ b/installed_modules.tcl @@ -26,6 +26,7 @@ foreach {m pkg doc exa} { ipentry _tcl _man _null plotchart _tcl _man _exa style _tcl _man _null + swaplist _tcl _man _null tkpiechart _tcl _man _null } { lappend modules $m From 1a0e6292e7afba8c73f49b3b589e7b6d31c9b4dc Mon Sep 17 00:00:00 2001 From: afaupell Date: Fri, 1 Apr 2005 21:37:44 +0000 Subject: [PATCH 0076/1290] 2005-04-01 Aaron Faupell * autoscroll.tcl: updated to not fail if autoscroll called twice on a the same scrollbar --- modules/autoscroll/ChangeLog | 5 +++++ modules/autoscroll/autoscroll.tcl | 7 ++++--- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/modules/autoscroll/ChangeLog b/modules/autoscroll/ChangeLog index 5d2659d5..73031e58 100644 --- a/modules/autoscroll/ChangeLog +++ b/modules/autoscroll/ChangeLog @@ -1,3 +1,8 @@ +2005-04-01 Aaron Faupell + + * autoscroll.tcl: updated to not fail if autoscroll called twice + on a the same scrollbar + 2005-03-24 Aaron Faupell * bumped version number for new wrap commands diff --git a/modules/autoscroll/autoscroll.tcl b/modules/autoscroll/autoscroll.tcl index 7a8cb6ee..51d187d9 100644 --- a/modules/autoscroll/autoscroll.tcl +++ b/modules/autoscroll/autoscroll.tcl @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: autoscroll.tcl,v 1.4 2005/03/31 03:15:47 andreas_kupries Exp $ +# RCS: @(#) $Id: autoscroll.tcl,v 1.5 2005/04/01 21:37:44 afaupell Exp $ package provide autoscroll 1.1 @@ -40,8 +40,9 @@ namespace eval ::autoscroll { #---------------------------------------------------------------------- proc ::autoscroll::autoscroll { w } { - rename $w [namespace current]::renamed$w - interp alias {} ::$w {} [namespace current]::widgetCommand $w + if { [info commands ::autoscroll::renamed$w] != "" } { return $w } + rename $w ::autoscroll::renamed$w + interp alias {} ::$w {} ::autoscroll::widgetCommand $w bindtags $w [linsert [bindtags $w] 1 Autoscroll] eval [list ::$w set] [renamed$w get] return $w From 045028696c20824dce64b5446add82b94161d0a5 Mon Sep 17 00:00:00 2001 From: afaupell Date: Sat, 2 Apr 2005 06:18:56 +0000 Subject: [PATCH 0077/1290] 2005-04-02 Aaron Faupell * initial import --- modules/tooltip/ChangeLog | 3 + modules/tooltip/pkgIndex.tcl | 4 + modules/tooltip/tipstack.tcl | 169 ++++++++++++++++++ modules/tooltip/tooltip.man | 43 +++++ modules/tooltip/tooltip.tcl | 328 +++++++++++++++++++++++++++++++++++ 5 files changed, 547 insertions(+) create mode 100644 modules/tooltip/ChangeLog create mode 100644 modules/tooltip/pkgIndex.tcl create mode 100644 modules/tooltip/tipstack.tcl create mode 100644 modules/tooltip/tooltip.man create mode 100644 modules/tooltip/tooltip.tcl diff --git a/modules/tooltip/ChangeLog b/modules/tooltip/ChangeLog new file mode 100644 index 00000000..3fcf6eb6 --- /dev/null +++ b/modules/tooltip/ChangeLog @@ -0,0 +1,3 @@ +2005-04-02 Aaron Faupell + + * initial import diff --git a/modules/tooltip/pkgIndex.tcl b/modules/tooltip/pkgIndex.tcl new file mode 100644 index 00000000..f5403967 --- /dev/null +++ b/modules/tooltip/pkgIndex.tcl @@ -0,0 +1,4 @@ +# -*- tcl -*- + +package ifneeded tooltip 1.1 [list source [file join $dir tooltip.tcl]] +package ifneeded tipstack 1.0 [list source [file join $dir tipstack.tcl]] diff --git a/modules/tooltip/tipstack.tcl b/modules/tooltip/tipstack.tcl new file mode 100644 index 00000000..c743d052 --- /dev/null +++ b/modules/tooltip/tipstack.tcl @@ -0,0 +1,169 @@ +# tipstack.tcl -- +# +# Based on 'tooltip', provides a dynamic stack of tip texts per +# widget. This allows dynamic transient changes to the tips, for +# example to temporarily replace a standard epxlanation with an +# error message. +# +# Copyright (c) 2003 ActiveState Corporation. +# +# See the file "license.terms" for information on usage and +# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: tipstack.tcl,v 1.1 2005/04/02 06:18:56 afaupell Exp $ +# + +# ### ######### ########################### +# Requisites + +package require tooltip +namespace eval ::tipstack {} + +# ### ######### ########################### +# Public API +# +## Basic syntax for all commands having a widget reference: +# +## tipstack::command .w ... +## tipstack::command .m -index foo ... + +# ### ######### ########################### +## Push new text for a widget (or menu) + +proc ::tipstack::push {args} { + if {([llength $args] != 2) && (([llength $args] != 4))} { + return -code error "wrong#args: expected w ?-index index? text" + } + + # Extract valueable parts. + + set text [lindex $args end] + set wref [lrange $args 0 end-1] + + # Remember new data (setup/extend db) + + variable db + if {![info exists db($wref)]} { + set db($wref) [list $text] + } else { + lappend db($wref) $text + } + + # Forward to standard tooltip package. + + eval [linsert [linsert $wref end $text] 0 tooltip::tooltip] + return +} + +# ### ######### ########################### +## Pop text from stack of tip for widget. +## ! Keeps the bottom-most entry. + +proc ::tipstack::pop {args} { + if {([llength $args] != 1) && (([llength $args] != 3))} { + return -code error "wrong#args: expected w ?-index index?" + } + # args == wref (see 'push'). + set wref $args + + # Pop top information form the database. Except if the + # text is the last in the stack. Then we will keep it, it + # is the baseline for the widget. + + variable db + if {![info exists db($wref)]} { + set text "" + } else { + set data $db($wref) + + if {[llength $data] == 1} { + set text [lindex $data 0] + } else { + set data [lrange $data 0 end-1] + set text [lindex $data end] + + set db($wref) $data + } + } + + # Forward to standard tooltip package. + + eval [linsert [linsert $wref end $text] 0 tooltip::tooltip] + return +} + +# ### ######### ########################### +## Clears out all data about a widget (or menu). + +proc ::tipstack::clear {args} { + + if {([llength $args] != 1) && (([llength $args] != 3))} { + return -code error "wrong#args: expected w ?-index index?" + } + # args == wref (see 'push'). + set wref $args + + # Remove data about widget. + + variable db + catch {unset db($wref)} + + eval [linsert [linsert $wref end ""] 0 tooltip::tooltip] + return +} + +# ### ######### ########################### +## Convenient definition of tooltips for multiple +## independent widgets. No menus possible + +proc ::tipstack::def {defs} { + foreach {path text} $defs { + push $path $text + } + return +} + +# ### ######### ########################### +## Convenient definition of tooltips for multiple +## widgets in a containing widget. No menus possible. +## This is for megawidgets. + +proc ::tipstack::defsub {base defs} { + foreach {subpath text} $defs { + push $base$subpath $text + } + return +} + +# ### ######### ########################### +## Convenient clearage of tooltips for multiple +## widgets in a containing widget. No menus possible. +## This is for megawidgets. + +proc ::tipstack::clearsub {base} { + variable db + + foreach k [array names db ${base}*] { + # Danger. Will fail if 'base' matches a menu reference. + clear $k $text + } + return +} + +# ### ######### ########################### +# Internal commands -- None + +# ### ######### ########################### +## Data structures + +namespace eval ::tipstack { + # Map from widget references to stack of tooltips. + + variable db + array set db {} +} + +# ### ######### ########################### +# Ready + +package provide tipstack 1.0 diff --git a/modules/tooltip/tooltip.man b/modules/tooltip/tooltip.man new file mode 100644 index 00000000..4307399a --- /dev/null +++ b/modules/tooltip/tooltip.man @@ -0,0 +1,43 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tooltip n 1.1] +[moddesc {}] +[titledesc {}] +[require Tcl 8.4] +[require tooltip [opt 1.1]] +[description] + +This package provides tooltips, a small text message that is +displayed when the mouse hovers over a widget. + +[para] + +[list_begin definitions] + +[call [cmd ::tooltip::tooltip] [arg command] [opt options]] +commands: +[call clear [opt pattern]] +[call delay [opt millisecs] +[call disable] +[call enable] + +[call [cmd ::tooltip::tooltip] [arg pathName] [opt options] [opt message] +This command arranges for widget [pathName] to display a tooltip with +message [opt message] +[list_begin opt] +[opt_def -index] +[opt_def -item] +[list_end] + +[list_end] + +[section EXAMPLE] + +[example { +package require tooltip +pack [label .l -text "label"] +tooltip::tooltip .l "This is a label widget" +}] + + +[keywords tooltip hover balloon help] +[manpage_end] diff --git a/modules/tooltip/tooltip.tcl b/modules/tooltip/tooltip.tcl new file mode 100644 index 00000000..b053f6f9 --- /dev/null +++ b/modules/tooltip/tooltip.tcl @@ -0,0 +1,328 @@ +# tooltip.tcl -- +# +# Balloon help +# +# Copyright (c) 1996-2003 Jeffrey Hobbs +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: tooltip.tcl,v 1.1 2005/04/02 06:18:57 afaupell Exp $ +# +# Initiated: 28 October 1996 + + +package require Tk 8.4 +package provide tooltip 1.1 + + +#------------------------------------------------------------------------ +# PROCEDURE +# tooltip::tooltip +# +# DESCRIPTION +# Implements a tooltip (balloon help) system +# +# ARGUMENTS +# tooltip