tcllib-1.15/0000755000175000017500000000000012104363635012232 5ustar sergeisergeitcllib-1.15/README.developer0000644000175000017500000003271512077663115015113 0ustar sergeisergeiRCS: @(#) $Id: README.developer,v 1.6 2009/06/02 22:49:55 andreas_kupries Exp $ Welcome to the tcllib, the Tcl Standard Library. ================================================ Introduction ------------ This README is intended to be a guide to the tools available to a Developer working on Tcllib to help him with his tasks, i.e. making the tasks easier to perform. It is our hope that this will improve the quality of even non-released revisions of Tcllib, and make the work of the release manager easier as well. Audience -------- The intended audience are, first and foremost, developers beginning to work on Tcllib. To an experienced developer this document will be less of a guide and more of a reference. Anybody else interested in working on Tcllib is invited as well. Directory hierarchy and file basics ------------------------------------ The main directories under the tcllib top directory are modules/ examples/ and apps/ Each directory FOO under modules/ represents one package, sometimes more. In the case of the latter the packages are usually related in some way. Examples are the base64, math, and struct modules, with loose (base64) to strong (math) relations between the packages. Examples associated with a module FOO, if there are any, are placed into the directory examples/FOO Any type of distributable application can be found under apps/, together with their documentation, if any. Note that the apps/ directory is currently not split into sub-directories. Regarding the files in Tcllib, the most common types found are .tcl Tcl code for a package. .man Documentation for a package, in doctools format. .test Test suite for a package, or part of. Based on tcltest. .bench Performance benchmarks for a package, or part of. Based on modules/bench .pcx Syntax rules for TclDevKit's tclchecker. Using these rules allows tclchecker to check the use of commands of a Tcllib package X without having to scan the implementation of X, i.e. its .tcl files. Adding a new module ------------------- Assuming that FOO is the name of the new module, and T is the toplevel directory of the Tcllib sources (1) Create the directory T/modules/FOO and put all the files of the module into it. Note: * The file 'pkgIndex.tcl' is required. * Implementation files should have the extension '.tcl', naturally. * If available, documentation should be in doctools format, and the files should have the extension '.man' for SAK to recognize them. * If available the testsuite(s) should use 'tcltest' and the general format as used by the other modules in Tcllib (declaration of minimally needed Tcl, tcltest, supporting packages, etc.). The file(s) should have the extension '.test' for SAK to recognize them. Note that an empty testsuite, or a testsuite which does not perform any tests is less than useful and will not be accepted. * If available the benchmark(s) should use 'bench' and the general format as used by the other modules in Tcllib. The file(s) should have the extension '.bench' for SAK to recognize them. * Other files can be named and placed as the module sees fit. (2) If the new module has an example application A which is polished enough for general use, put this application into the file "T/apps/A.tcl", and its documentation into the file "T/apps/A.man". While documentation for the application is optional, it is preferred. For examples which are not full-fledged applications, a skeleton, or not really polished for use, etc., create the directory T/examples/FOO/ and put them there. A key difference is what happens to them on installation, and what the target audience is. The examples are for developers using packages in Tcllib, whereas the applications are also for users of Tcllib which do not have an interest in developing for and with it. As such, they are installed as regular commands, accessible through the PATH, and example files are not installed. (3) To make Tcllib's installer aware of FOO, edit the file T/support/installation/modules.tcl Add a line 'Module FOO $impaction $docaction $exaction'. The various actions describe to the installer how to install the implementation files, the documentation, and the examples. Add a line 'Application A' for any application A which was added to T/apps for FOO. The following actions are available: Implementation _tcl - Copy all .tcl files in T/modules/FOO into the installation. _tcr - See above, does it for .tcl files in subdirectories as well. _tci - _tcl + Copying of a tclIndex - special to modules 'math', 'control'. _msg - _tcl + Copying of subdir 'msgs' - special to modules 'dns', 'log'. _doc - _tcl + Copying of subdir 'mpformats' - special to module 'doctools'. _tex - _tcl + Copying of .tex files - special to module 'textutil'. The _null action, see below, is available in principle too, but a module without implementation does not make sense. Documentation _null - Module has no documentation, do nothing. _man - Process the .man files in T/modules/FOO and install the results (nroff and/or HTML) in the proper location, as given to the installer. Examples _null - Module has no examples, do nothing _exa - Copy the directory T/examples/FOO (recursively) to the install location for examples. Testing modules --------------- To run the testsuite of a module FOO in tcllib use the 'test run' argument of sak.tcl, like so: % pwd /the/tcllib/toplevel/directory % ./sak.tcl test run FOO or % ./sak.tcl test run modules/FOO To run the testsuites of all modules either invoke 'test run' without a module name, or use 'make test'. The latter assumes that configure was run for Tcllib before, i.e.: % ./sak.tcl test run or % ./sak.tcl test run % make test In all of the above cases the result will be a combination of progress display and testsuite log, showing for each module the tests that pass or failed and how many of each in a summary at the end. To get a detailed log, it is necessary to invoke 'test run' with additional options. First example: % ./sak.tcl test run -l LOG FOO This shows the same short log on the terminal, and writes a detailed log to the file LOG.log, and excerpts to other files (LOG.summary, LOG.failures, etc.). Second example: % ./sak.tcl test run -v FOO % make test > LOG This writes the detailed log to stdout, or to the file LOG, instead of the short log. In all cases, the detailed log contains a list of all test cases executed, which failed, and how they failed (expected versus actual results). Note: The commands % make test and % make test > LOG are able to generate different output (short vs long log) because the Makefile target contains code which detects that stdout has been redirected to a file and acts accordingly. Non-developers should reports problems in Tcllib's bug tracker. Information about its location and the relevant category can be found in the section 'BUGS, IDEAS, FEEDBACK' of the manpage of the module and/or package. Module documentation -------------------- The main format used for the documentation of packages in Tcllib is 'doctools', the support packages of which are part of Tcllib, see the module 'doctools'. To convert this documentation to HTML or nroff manpages, or some other format use the 'doc' argument of sak.tcl, like so: % pwd /the/tcllib/toplevel/directory % ./sak.tcl doc html FOO or % ./sak.tcl doc html modules/FOO The result of the conversion can be found in the newly-created 'doc' directory in the current working directory. The set of formats the documentation can be converted into can be queried via % ./sak.tcl help doc To convert the documentation of all modules either invoke 'test run' without a module name, or use 'make html-doc', etc.. The latter assumes that configure was run for Tcllib before, i.e.: % ./sak.tcl doc html % make html-doc Note the special format 'validate'. Using this format does not convert the documentation to anything (and the sub-directory 'doc' will not be created), it just checks that the documentation is syntactically correct. I.e. % ./sak.tcldoc validate modules/FOO % ./sak.tcldoc validate Validating modules ------------------ Running the testsuite of a module, or checking the syntax of its documentation (see the previous sections) are two forms of validation. The 'validate' command of sak.tcl provides a few more. The online documentation of this command is available via % ./sak.tcl help validate The validated parts are man pages, testsuites, version information, and syntax. The latter only if various static syntax checkers are available on the PATH, like TclDevKit's tclchecker. Note that testsuite validation is not the execution of the testsuites, only if a package has a testsuite or not. It is strongly recommended to validate a module before committing any type of change made to it. It is recommended to validate all modules before committing any type of change made to one of them. We have package inter-dependencies between packages in Tcllib, thus changing one package may break others, and just validating the changed package will not catch such problems. Writing Tests ------------- While a previous section talked about running the testsuite for a module and the packages therein this has no meaning if the module in question has no testsuites at all. This section gives a very basic overview on methodologies for writing tests and testsuites. First there are "drudgery" tests. Written to check absolutely basic assumptions which should never fail. Example: For a command FOO taking two arguments, three tests calling it with zero, one, and three arguments. The basic checks that the command fails if it has not enough arguments, or too many. After that come the tests checking things based on our knowledge of the command, about its properties and assumptions. Some examples based on the graph operations added during Google's Summer of Code 2009. ** The BellmanFord command in struct::graph::ops takes a _startnode_ as argument, and this node should be a node of the graph. equals one test case checking the behavior when the specified node is not a node a graph. This often gives rise to code in the implementation which explicitly checks the assumption and throws a nice error. Instead of letting the algorithm fails later in some weird non-deterministic way. Such checks cannot be done always. The graph argument for example is just a command in itself, and while we expect it to exhibit a certain interface, i.e. set of sub-commands aka methods, we cannot check that it has them, except by actually trying to use them. That is done by the algorithm anyway, so an explicit check is just overhead we can get by without. ** IIRC one of the distinguishing characteristic of either BellmanFord and/or Johnson is that they are able to handle negative weights. Whereas Dijkstra requires positive weights. This induces (at least) three testcases ... Graph with all positive weights, all negative, and a mix of positive and negative weights. Thinking further does the algorithm handle the weight '0' as well ? Another test case, or several, if we mix zero with positive and negative weights. ** The two algorithms we are currently thinking about are about distances between nodes, and distance can be 'Inf'inity, i.e. nodes may not be connected. This means that good test cases are (1) Strongly connected graph (2) Connected graph (3) Disconnected graph. At the extremes of (1) and (3) we have the fully connected graphs and graphs without edges, only nodes, i.e. completely disconnected. ** IIRC both of the algorithms take weighted arcs, and fill in a default if arcs are left unweighted in the input graph. This also induces three test cases: (1) Graph will all arcs with explicit weights. (2) Graph without weights at all. (3) Graph with mixture of weighted and unweighted graphs. What was described above via examples is called 'black-box' testing. Test cases are designed and written based on our knowledge of the properties of the algorithm and its inputs, without referencing a particular implementation. Going further, a complement to 'black-box' testing is 'white-box'. For this we know the implementation of the algorithm, we look at it and design our tests cases so that they force the code through all possible paths in the implementation. Wherever a decision is made we have a test cases forcing a specific direction of the decision, for all possible directions. In practice I often hope that the black-box tests I have made are enough to cover all the paths, obviating the need for white-box tests. So, if you, dear reader, now believe that writing tests for an algorithm takes at least as much time as coding the algorithm, and often more time, then you are completely right. It does. Much more time. See for example also http://sqlite.org/testing.html, a writeup on how the Sqlite database engine is tested. An interesting connection is to documentation. In one direction, the properties you are checking with black-box testing are properties which should be documented in the algorithm man page. And conversely, if you have documentation of properties of an algorithm then this is a good reference to base black-box tests on. In practice test cases and documentation often get written together, cross-influencing each other. And the actual writing of test cases is a mix of black and white box, possibly influencing the implementation while writing the tests. Like writing test for 'startnode not in input graph' serving as reminder to put in a check for this into the code. tcllib-1.15/README.releasemgr0000644000175000017500000000153712077663115015252 0ustar sergeisergeiRCS: @(#) $Id: README.releasemgr,v 1.2 2009/07/10 16:33:31 andreas_kupries Exp $ Welcome to the tcllib, the Tcl Standard Library. ================================================ Introduction ------------ This README is intended to be a guide to the tools available to a Release manager working on the creation of a release of Tcllib. Audience -------- The intended audience is the release manager of Tcllib, his deputies, and anybody else interested in the task. Basics ------ < Flesh this out > sak.tcl < Tasks, and how to perform them > Uploading and releasing files to SourceForge -------------------------------------------- The main form to upload files is https://frs.sourceforge.net/webupload This is WebDAV. The place to manage the releases the files are for is https://sourceforge.net/project/admin/editpackages.php?group_id=12883 tcllib-1.15/sak.tcl0000755000175000017500000020151112104363437013517 0ustar sergeisergei#!/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]] set auto_path [linsert $auto_path 0 [file join $distribution modules]] set critcldefault {} set critclnotes {} set dist_excluded {} proc package_name {text} {global package_name ; set package_name $text} proc package_version {text} {global package_version ; set package_version $text} proc dist_exclude {path} {global dist_excluded ; lappend dist_excluded $path} proc critcl {name files} { global critclmodules set critclmodules($name) $files return } proc critcl_main {name files} { global critcldefault set critcldefault $name critcl $name $files return } proc critcl_notes {text} { global critclnotes set critclnotes [string map {{\n } \n} $text] return } source [file join $distribution support installation version.tcl] ; # Get version information. set package_nv ${package_name}-${package_version} catch {eval file delete -force [glob [file rootname [info script]].tmp.*]} # -------------------------------------------------------------- # SAK internal debugging support. # Configuration, change as needed set debug 0 if {$debug} { proc sakdebug {script} {uplevel 1 $script ; return} } else { proc sakdebug {args} {} } # -------------------------------------------------------------- # Internal helper to load packages straight out of the local directory # tree. Not something from an installation, possibly incompatible. proc getpackage {package tclmodule} { global distribution if {[catch {package present $package}]} { set src [file join \ $distribution modules \ $tclmodule] if {[file exists $src]} { uplevel #0 [list source $src] } else { # Fallback package require $package } } } # -------------------------------------------------------------- proc tclfiles {} { global distribution getpackage fileutil fileutil/fileutil.tcl set fl [fileutil::findByPattern $distribution -glob *.tcl] # Remove files under SCCS. They are repository, not sources to check. set tmp {} foreach f $fl { if {[string match *SCCS* $f]} continue lappend tmp $f } proc tclfiles {} [list return $tmp] return $tmp } 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 dealias {modules} { set _ {} foreach m $modules { if {[file exists $m]} { set m [file tail $m] } lappend _ $m } return $_ } proc load_modinfo {} { global distribution modules guide source [file join $distribution support installation modules.tcl] ; # Get list of installed modules. source [file join $distribution support installation actions.tcl] ; # Get installer support code. 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}] } # Result: dict (package name --> list of package versions). proc loadpkglist {fname} { set f [open $fname r] foreach line [split [read $f] \n] { set line [string trim $line] if {[string match @* $line]} continue if {$line == {}} continue foreach {n v} $line break lappend p($n) $v set p($n) [lsort -uniq -dict $p($n)] } close $f return [array get p] } # Result: dict (package name => list of (list of package versions, module)). 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 v [string trimright $v \\] if {![info exists p($n)]} { set p($n) [list $v $m] } else { # We have multiple versions of the same package. We # remember all versions. foreach {vlist mx} $p($n) break lappend vlist $v set p($n) [list [lsort -uniq -dict $vlist] $mx] } } close $f } return [array get p] } # Result: dict (package name --> list of package versions). proc ppackages {args} { # Determine provided packages (provide, *.tcl - pkgIndex.tcl) # We cache results for a bit of speed, some stuff uses this # multiple times for the same arguments. global ppcache if {[info exists ppcache($args)]} { return $ppcache($args) } global p pf currentfile array set p {} if {[llength $args] == 0} { set files [tclfiles] } else { set files [modtclfiles $args] } getpackage fileutil fileutil/fileutil.tcl set capout [fileutil::tempfile] ; set capcout [open $capout w] set caperr [fileutil::tempfile] ; set capcerr [open $caperr w] array set notprovided {} 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} # We use two methods to extract the version information from a # module and its packages. First we do a static scan for # appropriate statements. If that did not work out we try to # execute the script in a modified interpreter which lets us # pick up dynamically generated version data (like stored in # variables). If the second method fails as well we give up. # Method I. Static scan. # We do heuristic scanning of the code to locate suitable # package provide statements. set fh [open $f r] set currentfile [eval file join [lrange [file split $f] end-1 end]] set ok -1 foreach line [split [read $fh] \n] { if {[regexp "\#\\s*@sak\\s+notprovided\\s+(\[^\\s\]+)" $line -> nppname]} { sakdebug {puts stderr "PRAGMA notprovided = $nppname"} set notprovided($nppname) . } regsub "\#.*$" $line {} line if {![regexp {provide} $line]} {continue} if {![regexp {package} $line]} {continue} # Now a stronger check for the actual command if {![regexp {package[ ][ ]*provide} $line]} {continue} set xline $line regsub {^.*provide } $line {} line regsub {\].*$} $line {\1} line sakdebug {puts stderr __$f\ _________$line} foreach {n v} $line break # HACK ... # Module 'page', package 'page::gen::peg::cpkg'. # Has a provide statement inside a template codeblock. # Name is placeholder @@. Ignore this specific name. # Better would be to use general static Tcl parsing # to find that the string is a variable value. if {[string equal $n @@]} continue if {[regexp {^[0-9]+(\.[0-9]+)*$} $v]} { lappend p($n) $v set p($n) [lsort -uniq -dict $p($n)] set pf($n,$v) $currentfile set ok 1 # We continue the scan. The file may provide several # versions of the same package, or multiple packages. continue } # 'package provide foo' are tests. Ignore. if {$v == ""} continue # We do not set the state to bad if we found ok provide # statements before, only if nothing was found before. if {$ok < 0} { set ok 0 # No good version found on the current line. We scan # further through the file and hope for more luck. sakdebug {puts stderr @_$f\ _________$xline\t<$n>\t($v)} } } close $fh # Method II. Restricted Execution. # We now try to run the code through a safe interpreter # and hope for better luck regarding package information. if {$ok == -1} {sakdebug {puts stderr $f\ IGNORE}} if {$ok == 0} { sakdebug {puts -nonewline stderr $f\ EVAL} # 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 fh [open $f r] set ip [interp create] # Kill control structures. Namespace is required, but we # skip everything related to loading of packages, # i.e. 'command import'. $ip eval { rename ::if ::_if_ rename ::namespace ::_namespace_ proc ::if {args} {} proc ::namespace {cmd args} { #puts stderr "_nscmd_ $cmd" ::_if_ {[string equal $cmd import]} return #puts stderr "_nsdo_ $cmd $args" return [uplevel 1 [linsert $args 0 ::_namespace_ $cmd]] } } # Kill more package stuff, and ensure that unknown # commands are neither loaded nor abort execution. We also # stop anything trying to kill the application at large. 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 # From here on no redefinitions anymore, proc == xNULL !! $ip eval {close stdout} ; interp share {} $capcout $ip $ip eval {close stderr} ; interp share {} $capcerr $ip if {[catch {$ip eval [read $fh]} msg]} { sakdebug {puts stderr "ERROR in $currentfile:\n$::errorInfo\n"} } sakdebug {puts stderr ""} close $fh interp delete $ip } } close $capcout ; file delete $capout close $capcerr ; file delete $caperr # Process the accumulated pragma information, remove all the # packages which exist but not really, in terms of indexing. foreach n [array names notprovided] { catch { unset p($n) } array unset pf $n,* } set pp [array get p] unset p set ppcache($args) $pp 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} sakdebug {puts stderr \tOK\ $n\ =\ $v} lappend p($n) $v set p($n) [lsort -uniq -dict $p($n)] set pf($n,$v) $currentfile } return } proc sep {} {puts ~~~~~~~~~~~~~~~~~~~~~~~~} proc gd-cleanup {} { global package_nv puts {Cleaning up...} set fl [glob -nocomplain ${package_nv}*] foreach f $fl { puts " Deleting $f ..." catch {file delete -force $f} } return } proc gd-gen-archives {} { global package_name package_nv puts {Generating archives...} set tar [auto_execok tar] if {$tar != {}} { puts " Gzipped tarball (${package_nv}.tar.gz)..." catch { exec $tar cf - ${package_nv} | gzip --best > ${package_nv}.tar.gz } set bzip [auto_execok bzip2] if {$bzip != {}} { puts " Bzipped tarball (${package_nv}.tar.bz2)..." exec tar cf - ${package_nv} | bzip2 > ${package_nv}.tar.bz2 } } set zip [auto_execok zip] if {$zip != {}} { puts " Zip archive (${package_nv}.zip)..." catch { exec $zip -r ${package_nv}.zip ${package_nv} } } set sdx [auto_execok sdx] if {$sdx != {}} { file copy -force [file join ${package_nv} support installation main.tcl] \ [file join ${package_nv} main.tcl] file rename ${package_nv} ${package_name}.vfs puts " Starkit (${package_nv}.kit)..." exec sdx wrap ${package_name} file rename ${package_name} ${package_nv}.kit if {![file exists tclkit]} { puts " No tclkit present in current working directory, no starpack." } else { puts " Starpack (${package_nv}.exe)..." exec sdx wrap ${package_name} -runtime tclkit file rename ${package_name} ${package_nv}.exe } file rename ${package_name}.vfs ${package_nv} } 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 *}} { if {[string equal $pattern *] || !$recurse} { 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 } } } else { foreach file [glob [file join $src *]] { set base [file tail $file] set sub [file join $dest $base] if {[string equal CVS $base]} {continue} if {[file isdirectory $file]} then { if {$recurse} { xcopy $file $sub $recurse $pattern } } else { if {![string match $pattern $base]} {continue} xcopyfile $file $sub } } } } proc xxcopy {src dest recurse {pattern *}} { global package_name file mkdir $dest foreach file [glob -nocomplain [file join $src $pattern]] { set base [file tail $file] set sub [file join $dest $base] # Exclude CVS, SCCS, ... automatically, and possibly the temp # hierarchy itself too. if {0 == [string compare CVS $base]} {continue} if {0 == [string compare SCCS $base]} {continue} if {0 == [string compare BitKeeper $base]} {continue} if {[string match ${package_name}-* $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 package_nv distribution dist_excluded puts "Assembling distribution in directory '${package_nv}'" xxcopy $distribution ${package_nv} 1 foreach f $dist_excluded { file delete -force [file join $package_nv $f] } puts "" return } proc normalize-version {v} { # Strip everything after the first non-version character, and any # trailing dots left behind by that, to avoid the insertion of bad # version numbers into the generated .tap file. regsub {[^0-9.].*$} $v {} v return [string trimright $v .] } proc gd-gen-tap {} { getpackage textutil textutil/textutil.tcl getpackage fileutil fileutil/fileutil.tcl global package_name package_version distribution tcl_platform set pname [textutil::cap $package_name] set modules [imodules] array set pd [getpdesc] 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 $package_name $package_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 $package_name [normalize-version $package_version]]] lappend lines "Base @TAP_DIR@" lappend lines "Platform *" lappend lines "Desc \{$pname: 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 vlist} [ppackages $m] { foreach v $vlist { lappend lines "# \[[format %1d [incr n]]\] | \"$p\" ($v)" } } if {$n > 1} { # Multiple packages (*). We create one hidden package to # contain all the files and then have all the true # packages in the module refer to it. # # (*) This can also be one package for which we have # several versions. Or a combination thereof. array set _ {} foreach {p vlist} [ppackages $m] { catch {set _([lindex $pd($p) 0]) .} } set desc [string trim [join [array names _] ", "] " \n\t\r,"] if {$desc == ""} {set desc "$pname module"} unset _ lappend lines "# -------+" lappend lines {} lappend lines [list Package [list __$m 0.0]] lappend lines "Platform *" lappend lines "Desc \{$desc\}" lappend lines Hidden lappend lines "Base @TAP_DIR@/$m" foreach f [lsort -dict [modtclfiles $m]] { lappend lines "Path [fileutil::stripN $f $strip]" } # Packages in the module ... foreach {p vlist} [ppackages $m] { # NO DANGER. As we are listing only the packages P for # the module any other version of P in a different # module is _not_ listed here. set desc "" catch {set desc [string trim [lindex $pd($p) 1]]} if {$desc == ""} {set desc "$pname package"} foreach v $vlist { lappend lines {} lappend lines [list Package [list $p [normalize-version $v]]] lappend lines "See [list __$m]" lappend lines "Platform *" lappend lines "Desc \{$desc\}" } } } else { # A single package in the module. And only one version of # it as well. Otherwise we are in the multi-pkg branch. foreach {p vlist} [ppackages $m] break set desc "" catch {set desc [string trim [lindex $pd($p) 1]]} if {$desc == ""} {set desc "$pname package"} set v [lindex $vlist 0] lappend lines "# -------+" lappend lines {} lappend lines [list Package [list $p [normalize-version $v]]] lappend lines "Platform *" lappend lines "Desc \{$desc\}" lappend lines "Base @TAP_DIR@/$m" foreach f [lsort -dict [modtclfiles $m]] { lappend lines "Path [fileutil::stripN $f $strip]" } } 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 ${package_name}.tap] w] puts $f [join $lines \n] close $f return } proc getpdesc {} { global argv ; if {![checkmod]} return package require sak::doc sak::doc::Gen desc l $argv array set _ {} foreach file [glob -nocomplain doc/desc/*.l] { set f [open $file r] foreach l [split [read $f] \n] { foreach {p sd d} $l break set _($p) [list $sd $d] } close $f } file delete -force doc/desc return [array get _] } proc gd-gen-rpmspec {} { global package_version package_name distribution set in [file join $distribution support releases package_rpm.txt] set out [file join $distribution ${package_name}.spec] write_out $out [string map \ [list \ @PACKAGE_VERSION@ $package_version \ @PACKAGE_NAME@ $package_name] \ [get_input $in]] return } proc gd-gen-yml {} { # YAML is the format used for the FreePAN archive network. # http://freepan.org/ global package_version package_name distribution set in [file join $distribution support releases package_yml.txt] set out [file join $distribution ${package_name}.yml] write_out $out [string map \ [list \ @PACKAGE_VERSION@ $package_version \ @PACKAGE_NAME@ $package_name] \ [get_input $in]] return } proc docfiles {} { global distribution getpackage fileutil fileutil/fileutil.tcl set res [list] foreach f [fileutil::findByPattern $distribution -glob *.man] { # Remove files under SCCS. They are repository, not sources to check. if {[string match *SCCS* $f]} continue lappend res [file rootname [file tail $f]].n } proc docfiles {} [list return $res] return $res } proc gd-tip55 {} { global package_version package_name distribution contributors contributors set in [file join $distribution support releases package_tip55.txt] set out [file join $distribution DESCRIPTION.txt] set md [string map \ [list \ @PACKAGE_VERSION@ $package_version \ @PACKAGE_NAME@ $package_name] \ [get_input $in]] 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" } write_out $out $md return } # Fill the global array of contributors to the bundle 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} { global pf getpackage struct::set struct/sets.tcl 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)]} { foreach k [array names pf $p,*] { puts " Provided, not indexed: [format "%-*s | %s" $maxl $p $pf($k)]" } } } foreach p [lsort [array names ip]] { if {![info exists pp($p)]} continue if {[struct::set equal $pp($p) $ip($p)]} continue # Compute intersection and set differences. foreach {__ pmi imp} [struct::set intersect3 $pp($p) $ip($p)] break puts " Index/provided versions differ: [format "%-*s | %8s | %8s" $maxl $p $imp $pmi]" } } proc validate_versions {} { foreach {p vm} [ipackages] {set ip($p) [lindex $vm 0]} foreach {p vlist} [ppackages] {set pp($p) $vlist} validate_versions_cmp ip pp return } proc validate_versions_mod {m} { foreach {p vm} [ipackages $m] {set ip($p) [lindex $vm 0]} foreach {p vlist} [ppackages $m] {set pp($p) $vlist} 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 bench_mod {mlist paths interp flags norm format verbose output} { global distribution env tcl_platform getpackage logger logger/logger.tcl getpackage bench bench/bench.tcl ::logger::setlevel $verbose set pattern tclsh* if {$interp != {}} { set pattern [file tail $interp] set paths [list [file dirname $interp]] } elseif {![llength $paths]} { # Using the environment PATH is not a good default for # SAK. Use the interpreter running SAK as the default. if 0 { set paths [split $env(PATH) \ [expr {($tcl_platform(platform) == "windows") ? ";" : ":"}]] } set interp [info nameofexecutable] set pattern [file tail $interp] set paths [list [file dirname $interp]] } set interps [bench::versions \ [bench::locate $pattern $paths]] if {![llength $interps]} { puts "No interpreters found" return } if {[llength $flags]} { set cmd [linsert $flags 0 bench::run] } else { set cmd [list bench::run] } array set DATA {} foreach m $mlist { set files [glob -nocomplain [file join $distribution modules $m *.bench]] if {![llength $files]} { bench::log::warn "No benchmark files found for module \"$m\"" continue } set run $cmd lappend run $interps $files array set DATA [eval $run] } _bench_write $output [array get DATA] $norm $format return } proc bench_all {flags norm format verbose output} { bench_mod [modules] $flags $norm $format $verbose $output return } proc _bench_write {output data norm format} { if {$norm != {}} { getpackage logger logger/logger.tcl getpackage bench bench/bench.tcl set data [bench::norm $data $norm] } set data [bench::out::$format $data] if {$output == {}} { puts $data } else { set output [open $output w] puts $output "# -*- tcl -*- bench/$format" puts $output $data close $output } } 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} { package require sak::doc sak::doc::Gen null null [list $m] return } proc validate_doc_markup {} { package require sak::doc sak::doc::Gen null null [modules] 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 [lsort -dict [modtclfiles $args]] } foreach f $files { puts "FRINK ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" puts "$f..." puts "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" catch {exec frink 2> $tmp -HJ $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 [lsort -dict [modtclfiles $args]] } foreach f $files { puts "PROCHECK ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" puts "$f ..." puts "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" catch {exec procheck >@ stdout $f} } return } proc run-tclchecker {args} { global distribution if {[llength $args] == 0} { set files [tclfiles] } else { set files [lsort -dict [modtclfiles $args]] } foreach f $files { puts "TCLCHECKER ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" puts "$f ..." puts "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" catch {exec tclchecker >@ stdout $f} } return } proc run-nagelfar {args} { global distribution if {[llength $args] == 0} { set files [tclfiles] } else { set files [lsort -dict [modtclfiles $args]] } foreach f $files { puts "NAGELFAR ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" puts "$f ..." puts "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" catch {exec nagelfar >@ stdout $f} } return } proc get_input {f} {return [read [set if [open $f r]]][close $if]} proc write_out {f text} { catch {file delete -force $f} puts -nonewline [set of [open $f w]] $text close $of } proc location_PACKAGES {} { global distribution return [file join $distribution support releases PACKAGES] } proc gd-gen-packages {} { global package_version distribution set P [location_PACKAGES] file copy -force $P $P.LAST set f [open $P w] puts $f "@@ RELEASE $package_version" puts $f "" array set packages {} foreach {p vm} [ipackages] { set packages($p) [lindex $vm 0] } nparray packages $f close $f } proc modified-modules {} { global distribution set mlist [modules] set modified [list] foreach m $mlist { set cl [file join $distribution modules $m ChangeLog] if {![file exists $cl]} { lappend modified [list $m no-changelog] continue } # Look for 'Released and tagged' within # the first four lines of the file. If # not present assume that the line is # deeper down, indicating that the module # has been modified since the last release. set f [open $cl r] set n 0 set mod 1 while {$n < 5} { gets $f line incr n if {[string match -nocase "*Released and tagged*" $line]} { if {$n <= 4} {set mod 0 ; break} } } if {$mod} { lappend modified $m } close $f } return $modified } # -------------------------------------------------------------- # Handle modules using docstrip proc docstripUser {m} { global distribution set mdir [file join $distribution modules $m] if {[llength [glob -nocomplain -dir $mdir *.stitch]]} {return 1} return 0 } proc docstripRegen {m} { global distribution puts "$m ..." getpackage docstrip docstrip/docstrip.tcl set mdir [file join $distribution modules $m] foreach sf [glob -nocomplain -dir $mdir *.stitch] { puts "* [file tail $sf] ..." set here [pwd] set fail [catch { cd [file dirname $sf] docstripRunStitch [file tail $sf] } msg] cd $here if {$fail} { puts " [join [split $::errorInfo \n] "\n "]" } } return } proc docstripRunStitch {sf} { # Run the stitch file in a restricted sandbox ... set box [restrictedIp { input ::dsrs::Input options ::dsrs::Options stitch ::dsrs::Stitch reset ::dsrs::Reset }] ::dsrs::Init set fail [catch {interp eval $box [get_input $sf]} msg] if {$fail} { puts " [join [split $::errorInfo \n] "\n "]" } else { ::dsrs::Final } interp delete $box return } proc emptyIp {} { set box [interp create] foreach c [interp eval $box {info commands}] { if {[string equal $c "rename"]} continue interp eval $box [list rename $c {}] } # Rename command goes last. interp eval $box [list rename rename {}] return $box } proc restrictedIp {dict} { set box [emptyIp] foreach {cmd localcmd} $dict { interp alias $box $cmd {} $localcmd } return $box } # -------------------------------------------------------------- # docstrip low level operations for stitching. namespace eval ::dsrs { # Standard preamble to preambles variable preamble {} append preamble \n append preamble "This is the file `@output@'," \n append preamble "generated with the SAK utility" \n append preamble "(sak docstrip/regen)." \n append preamble \n append preamble "The original source files were:" \n append preamble \n append preamble "@input@ (with options: `@guards@')" \n append preamble \n # Standard postamble to postambles variable postamble {} append postamble \n append postamble \n append postamble "End of file `@output@'." # Default values for the options which are relevant to the # application itself and thus have to be defined always. # They are processed as global options, as part of argv. variable defaults {-metaprefix {%} -preamble {} -postamble {}} variable options ; array set options {} variable outputs ; array set outputs {} variable inputs ; array set inputs {} variable input {} } proc ::dsrs::Init {} { variable outputs ; unset outputs ; array set outputs {} variable inputs ; unset inputs ; array set inputs {} variable input {} Reset ; # options return } proc ::dsrs::Reset {} { variable defaults variable options ; unset options ; array set options {} eval [linsert $defaults 0 Options] return } proc ::dsrs::Input {sourcefile} { # Relative to current directory = directory containing the active # stitch file. variable input $sourcefile } proc ::dsrs::Options {args} { variable options variable preamble variable postamble while {[llength $args]} { set opt [lindex $args 0] switch -exact -- $opt { -nopreamble - -nopostamble { set o -[string range $opt 3 end] set options($o) "" set args [lrange $args 1 end] } -preamble { set val $preamble[lindex $args 1] set options($opt) $val set args [lrange $args 2 end] } -postamble { set val [lindex $args 1]$postamble set options($opt) $val set args [lrange $args 2 end] } -metaprefix - -onerror - -trimlines { set val [lindex $args 1] set options($opt) $val set args [lrange $args 2 end] } default { return -code error "Unknown option: \"$opt\"" } } } return } proc ::dsrs::Stitch {outputfile guards} { variable options variable inputs variable input variable outputs variable preamble variable postamble if {[string equal $input {}]} { return -code error "No input file defined" } if {![info exist inputs($input)]} { set inputs($input) [get_input $input] } set intext $inputs($input) set otext "" set c $options(-metaprefix) set cc $c$c set pmap [list @output@ $outputfile \ @input@ $input \ @guards@ $guards] if {[info exists options(-preamble)]} { set pre $options(-preamble) if {![string equal $pre ""]} { append otext [Subst $pre $pmap $cc] \n } } array set o [array get options] catch {unset o(-preamble)} catch {unset o(-postamble)} set opt [array get o] append otext [eval [linsert $opt 0 docstrip::extract $intext $guards]] if {[info exists options(-postamble)]} { set post $options(-postamble) if {![string equal $post ""]} { append otext [Subst $post $pmap $cc] } } # Accumulate outputs in memory append outputs($outputfile) $otext return } proc ::dsrs::Subst {text pmap cc} { return [string trim "$cc [join [split [string map $pmap $text] \n] "\n$cc "]"] } proc ::dsrs::Final {} { variable outputs foreach o [array names outputs] { puts " = Writing $o ..." if {[string equal \ docstrip/docstrip.tcl \ [file join [file tail [pwd]] $o]]} { # We are writing over code required by ourselves. # For easy recovery in case of problems we save # the original puts " *Saving original of code important to docstrip/regen itself*" write_out $o.bak [get_input $o] } write_out $o $outputs($o) } } # -------------------------------------------------------------- # Configuration proc __name {} {global package_name ; puts -nonewline $package_name} proc __version {} {global package_version ; puts -nonewline $package_version} proc __minor {} {global package_version ; puts -nonewline [lindex [split $package_version .] 1]} proc __major {} {global package_version ; puts -nonewline [lindex [split $package_version .] 0]} # -------------------------------------------------------------- # Development proc __imodules {} {puts [imodules]} proc __modules {} {puts [modules]} proc __lmodules {} {puts [join [modules] \n]} proc nparray {a {chan stdout}} { 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]] { foreach v $packages($name) { puts $chan [format "%-*s %s" $maxl $name $v] } } return } proc __packages {} { array set packages {} foreach {p vm} [ipackages] { set packages($p) [lindex $vm 0] } nparray packages return } proc __provided {} { array set packages [ppackages] nparray packages return } proc __vcompare {} { global argv set oldplist [lindex $argv 0] pkg-compare $oldplist return } proc __rstatus {} { global distribution approved catch { set f [file join $distribution .APPROVE] set f [open $f r] while {![eof $f]} { if {[gets $f line] < 0} continue set line [string trim $line] if {$line == {}} continue set approved($line) . } close $f } pkg-compare [location_PACKAGES] return } proc pkg-compare {oldplist} { global approved ; array set approved {} getpackage struct::set struct/sets.tcl array set curpkg [ipackages] array set oldpkg [loadpkglist $oldplist] array set mod {} array set changed {} foreach m [modified-modules] { set mod($m) . } foreach p [array names curpkg] { set __($p) . foreach {vlist module} $curpkg($p) break set curpkg($p) $vlist set changed($p) [info exists mod($module)] } 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] } } set maxm 0 foreach m [modules] { if {[string length $m] > $maxm} { set maxm [string length $m] } } set lastm "" foreach m [lsort -dict [modules]] { set packages {} foreach {p ___} [ppackages $m] { lappend packages $p } foreach name [lsort -dict $packages] { set skip 0 set suffix "" set prefix " " if {![info exists curpkg($name)]} {set curpkg($name) {}} if {![info exists oldpkg($name)]} { set oldpkg($name) {} set suffix " NEW" set prefix "Nn " set skip 1 } if {!$skip} { # Draw attention to changed packages where version is # unchanged. set vequal [struct::set equal $oldpkg($name) $curpkg($name)] if {$changed($name)} { if {$vequal} { # Changed according to ChangeLog, Version is not. ALERT. set prefix "!! " set suffix "\t<<< MISMATCH. Version ==, ChangeLog ++" } else { # Both changelog and version number indicate a change. # Small alert, have to classify the order of changes. set prefix "cv " set suffix "\t=== Classify changes." } } else { if {$vequal} { # Versions are unchanged, changelog also indicates no change. # No particular attention here. } else { # Versions changed, but according to changelog nothing in code. ALERT. set prefix "!! " set suffix "\t<<< MISMATCH. ChangeLog ==, Version ++" } } if {[info exists approved($name)]} { set prefix " " set suffix "" } } # To handle multiple versions we match the found versions up # by major version. We assume that we have only one version # per major version. This allows us to detect changes within # each major version, new major versions, etc. array set om {} ; foreach v $oldpkg($name) {set om([lindex [split $v .] 0]) $v} array set cm {} ; foreach v $curpkg($name) {set cm([lindex [split $v .] 0]) $v} set all [lsort -dict [struct::set union [array names om] [array names cm]]] sakdebug { puts @@@@@@@@@@@@@@@@ parray om parray cm puts all\ $all puts @@@@@@@@@@@@@@@@ } foreach v $all { if {![string equal $m $lastm]} { set mdis $m } else { set mdis "" } set lastm $m if {[info exists om($v)]} {set ov $om($v)} else {set ov "--"} if {[info exists cm($v)]} {set cv $cm($v)} else {set cv "--"} puts stdout ${prefix}[format "%-*s %-*s %-*s %-*s" \ $maxm $mdis $maxl $name 8 $ov 8 $cv]$suffix } unset om cm } } return } proc checkmod {} { global argv package require sak::util return [sak::util::checkModules argv] } # ------------------------------------------------------------------------- # Critcl stuff # ------------------------------------------------------------------------- # Build critcl modules. If no args then build the default critcl module. proc __critcl {} { global argv critcl critclmodules critcldefault critclnotes tcl_platform if {$tcl_platform(platform) == "windows"} { # Windows is a bit more complicated. We have to choose an # interpreter, and a starkit for it, and call both. # # We prefer tclkitsh, but try to make do with a tclsh. That # one will have to have all the necessary packages to support # starkits. ActiveTcl for example. set interpreter {} foreach i {critcl.exe tclkitsh tclsh} { set interpreter [auto_execok $i] if {$interpreter != {}} break } if {$interpreter == {}} { return -code error \ "failed to find either tclkitsh.exe or tclsh.exe in path" } # The critcl starkit can come out of the environment, or we # try to locate it using several possible names. We try to # find it if and only if we did not find a critcl starpack # before. if {[file tail $interpreter] == "critcl.exe"} { set critcl $interpreter } else { set kit {} if {[info exists ::env(CRITCL)]} { set kit $::env(CRITCL) } else { foreach k {critcl.kit critcl} { set kit [auto_execok $k] if {$kit != {}} break } } if {$kit == {}} { return -code error "failed to find critcl.kit or critcl in \ path.\n\ You may wish to set the CRITCL environment variable to the\ location of your critcl(.kit) file." } set critcl [concat $interpreter $kit] } } else { # My, isn't it simpler under unix. set critcl [auto_execok critcl] } set flags "" while {[string match -* [set option [lindex $argv 0]]]} { # -debug and -clean only work with critcl >= v04 switch -exact -- $option { -keep { append flags " -keep" } -debug { append flags " -debug [lindex $argv 1]" set argv [lreplace $argv 0 0] } -clean { append flags " -clean" } -target { append flags " -target [lindex $argv 1]" set argv [lreplace $argv 0 0] } -- { set argv [lreplace $argv 0 0]; break } default { break } } set argv [lreplace $argv 0 0] } if {$critcl != {}} { if {[llength $argv] == 0} { puts stderr "[string repeat - 72]" puts stderr "Building critcl components." if {$critclnotes != {}} { puts stderr $critclnotes } puts stderr "[string repeat - 72]" critcl_module $critcldefault $flags } else { foreach m [dealias $argv] { if {[info exists critclmodules($m)]} { critcl_module $m $flags } 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 critcldefault foreach m [lsort -dict [array names critclmodules]] { if {$m == $critcldefault} { puts "$m **" } else { puts $m } } return } proc critcl_module {pkg {extra ""}} { global critcl distribution critclmodules critcldefault if {$pkg == $critcldefault} { set files {} foreach f $critclmodules($critcldefault) { lappend files [file join $distribution modules $f] } foreach m [array names critclmodules] { if {$m == $critcldefault} continue 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 $extra -force -libdir [list $target] -pkg [list $pkg] $files" eval exec $critcl $extra -force -libdir [list $target] -pkg [list $pkg] $files } r puts $r return } # ------------------------------------------------------------------------- proc __bench/edit {} { global argv argv0 set format text set output {} while {[string match -* [set option [lindex $argv 0]]]} { set val [lindex $argv 1] switch -exact -- $option { -format { switch -exact -- $val { raw - csv - text {} default { return -error "Bad format \"$val\", expected text, csv, or raw" } } set format $val } -o {set output $val} -- { set argv [lrange $argv 1 end] break } default { break } } set argv [lrange $argv 2 end] } switch -exact -- $format { raw {} csv { getpackage csv csv/csv.tcl getpackage bench::out::csv bench/bench_wcsv.tcl } text { getpackage report report/report.tcl getpackage struct::matrix struct/matrix.tcl getpackage bench::out::text bench/bench_wtext.tcl } } getpackage bench::in bench/bench_read.tcl getpackage bench bench/bench.tcl if {[llength $argv] != 3} { puts "Usage: $argv0 benchdata column newvalue" } foreach {in col new} $argv break _bench_write $output \ [bench::edit \ [bench::in::read $in] \ $col $new] \ {} $format return } proc __bench/del {} { global argv argv0 set format text set output {} while {[string match -* [set option [lindex $argv 0]]]} { set val [lindex $argv 1] switch -exact -- $option { -format { switch -exact -- $val { raw - csv - text {} default { return -error "Bad format \"$val\", expected text, csv, or raw" } } set format $val } -o {set output $val} -- { set argv [lrange $argv 1 end] break } default { break } } set argv [lrange $argv 2 end] } switch -exact -- $format { raw {} csv { getpackage csv csv/csv.tcl getpackage bench::out::csv bench/bench_wcsv.tcl } text { getpackage report report/report.tcl getpackage struct::matrix struct/matrix.tcl getpackage bench::out::text bench/bench_wtext.tcl } } getpackage bench::in bench/bench_read.tcl getpackage bench bench/bench.tcl if {[llength $argv] < 2} { puts "Usage: $argv0 benchdata column..." } set in [lindex $argv 0] set data [bench::in::read $in] foreach c [lrange $argv 1 end] { set data [bench::del $data $c] } _bench_write $output $data {} $format return } proc __bench/show {} { global argv set format text set output {} set norm {} while {[string match -* [set option [lindex $argv 0]]]} { set val [lindex $argv 1] switch -exact -- $option { -format { switch -exact -- $val { raw - csv - text {} default { return -error "Bad format \"$val\", expected text, csv, or raw" } } set format $val } -o {set output $val} -norm {set norm $val} -- { set argv [lrange $argv 1 end] break } default { break } } set argv [lrange $argv 2 end] } switch -exact -- $format { raw {} csv { getpackage csv csv/csv.tcl getpackage bench::out::csv bench/bench_wcsv.tcl } text { getpackage report report/report.tcl getpackage struct::matrix struct/matrix.tcl getpackage bench::out::text bench/bench_wtext.tcl } } getpackage bench::in bench/bench_read.tcl array set DATA {} foreach path $argv { array set DATA [bench::in::read $path] } _bench_write $output [array get DATA] $norm $format return } proc __bench {} { global argv # I. Process command line arguments for the # benchmark commands - Validation, possible # translation ... set flags {} set norm {} set format text set verbose warn set output {} set paths {} set interp {} while {[string match -* [set option [lindex $argv 0]]]} { set val [lindex $argv 1] switch -exact -- $option { -throwerrors {lappend flags -errors $val} -match - -rmatch - -iters - -threads {lappend flags $option $val} -o {set output $val} -norm {set norm $val} -path {lappend paths $val} -interp {set interp $val} -format { switch -exact -- $val { raw - csv - text {} default { return -error "Bad format \"$val\", expected text, csv, or raw" } } set format $val } -verbose { set verbose info set argv [lrange $argv 1 end] continue } -debug { set verbose debug set argv [lrange $argv 1 end] continue } -- { set argv [lrange $argv 1 end] break } default { break } } set argv [lrange $argv 2 end] } switch -exact -- $format { raw {} csv { getpackage csv csv/csv.tcl getpackage bench::out::csv bench/bench_wcsv.tcl } text { getpackage report report/report.tcl getpackage struct::matrix struct/matrix.tcl getpackage bench::out::text bench/bench_wtext.tcl } } # Choose between benchmarking everything, or # only selected modules. if {[llength $argv] == 0} { _bench_all $paths $interp $flags $norm $format $verbose $output } else { if {![checkmod]} {return} _bench_module [dealias $argv] $paths $interp $flags $norm $format $verbose $output } return } proc _bench_module {mlist paths interp flags norm format verbose output} { global package_name package_version puts "Benchmarking $package_name $package_version development" puts "======================================================" bench_mod $mlist $paths $interp $flags $norm $format $verbose $output puts "------------------------------------------------------" puts "" return } proc _bench_all {paths flags interp norm format verbose output} { _bench_module [modules] $paths $interp $flags $norm $format $verbose $output return } # ------------------------------------------------------------------------- proc __oldvalidate_v {} { global argv if {[llength $argv] == 0} { _validate_all_v } else { if {![checkmod]} {return} foreach m [dealias $argv] { _validate_module_v $m } } return } proc _validate_all_v {} { global package_name package_version set i 0 puts "Validating $package_name $package_version development" puts "===================================================" puts "[incr i]: Consistency of package versions ..." puts "------------------------------------------------------" validate_versions puts "------------------------------------------------------" puts "" return } proc _validate_module_v {m} { global package_name package_version set i 0 puts "Validating $package_name $package_version development -- $m" puts "===================================================" puts "[incr i]: Consistency of package versions ..." puts "------------------------------------------------------" validate_versions_mod $m puts "------------------------------------------------------" puts "" return } proc __oldvalidate {} { global argv if {[llength $argv] == 0} { _validate_all } else { if {![checkmod]} {return} foreach m $argv { _validate_module $m } } return } proc _validate_all {} { global package_name package_version set i 0 puts "Validating $package_name $package_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] set tclchecker [auto_execok tclchecker] set nagelfar [auto_execok nagelfar] if {$frink == {}} {puts " Tool 'frink' not found, no check"} if {($procheck == {}) || ($tclchecker == {})} { puts " Tools 'procheck'/'tclchecker' not found, no check" } if {$nagelfar == {}} {puts " Tool 'nagelfar' not found, no check"} if {($frink == {}) || ($procheck == {}) || ($tclchecker == {}) || ($nagelfar == {})} { puts "------------------------------------------------------" } if {($frink == {}) && ($procheck == {}) && ($tclchecker == {}) && ($nagelfar == {})} { return } if {$frink != {}} { run-frink puts "------------------------------------------------------" } if {$tclchecker != {}} { run-tclchecker puts "------------------------------------------------------" } elseif {$procheck != {}} { run-procheck puts "------------------------------------------------------" } if {$nagelfar !={}} { run-nagelfar puts "------------------------------------------------------" } puts "" return } proc _validate_module {m} { global package_name package_version set i 0 puts "Validating $package_name $package_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] set nagelfar [auto_execok nagelfar] set tclchecker [auto_execok tclchecker] if {$frink == {}} {puts " Tool 'frink' not found, no check"} if {($procheck == {}) || ($tclchecker == {})} { puts " Tools 'procheck'/'tclchecker' not found, no check" } if {$nagelfar == {}} {puts " Tool 'nagelfar' not found, no check"} if {($frink == {}) || ($procheck == {}) || ($tclchecker == {}) || ($nagelfar == {})} { puts "------------------------------------------------------" } if {($frink == {}) && ($procheck == {}) && ($nagelfar == {}) && ($tclchecker == {})} { return } if {$frink != {}} { run-frink $m puts "------------------------------------------------------" } if {$tclchecker != {}} { run-tclchecker $m puts "------------------------------------------------------" } elseif {$procheck != {}} { run-procheck $m puts "------------------------------------------------------" } if {$nagelfar !={}} { run-nagelfar $m puts "------------------------------------------------------" } puts "" return } # -------------------------------------------------------------- # Release engineering proc __gendist {} { gd-cleanup gd-tip55 gd-gen-rpmspec gd-gen-tap gd-gen-yml gd-assemble gd-gen-archives puts ...Done return } proc __gentip55 {} { gd-tip55 puts "Created DESCRIPTION.txt" return } proc __yml {} { global package_name gd-gen-yml puts "Created YAML spec file \"${package_name}.yml\"" return } proc __contributors {} { global contributors contributors foreach person [lsort [array names contributors]] { puts "$person <$contributors($person)>" } return } proc __tap {} { global package_name gd-gen-tap puts "Created Tcl Dev Kit \"${package_name}.tap\"" } proc __rpmspec {} { global package_name gd-gen-rpmspec puts "Created RPM spec file \"${package_name}.spec\"" } proc __release {} { # Regenerate PACKAGES, and extend global argv argv0 distribution package_name package_version getpackage textutil textutil/textutil.tcl if {[llength $argv] != 2} { puts stderr "$argv0: wrong#args: release name sf-user-id" exit 1 } foreach {name sfuser} $argv break set email "<${sfuser}@users.sourceforge.net>" set pname [textutil::cap $package_name] set notice "[clock format [clock seconds] -format "%Y-%m-%d"] $name $email * * Released and tagged $pname $package_version ======================== * " set logs [list [file join $distribution ChangeLog]] foreach m [modules] { set m [file join $distribution modules $m ChangeLog] if {![file exists $m]} continue lappend logs $m } foreach f $logs { puts "\tAdding release notice to $f" set fh [open $f r] ; set data [read $fh] ; close $fh set fh [open $f w] ; puts -nonewline $fh $notice$data ; close $fh } gd-gen-packages return } proc __approve {} { global argv distribution # Record the package as approved. This will suppress any alerts # for that package by rstatus. Required for packages which have # been classified, and for packages where a MISMATCH is bogus (due # to several packages sharing a ChangeLog) set f [open [file join $distribution .APPROVE] a] foreach package $argv { puts $f $package } close $f return } # -------------------------------------------------------------- # Documentation proc __desc {} { global argv ; if {![checkmod]} return array set pd [getpdesc] getpackage struct::matrix struct/matrix.tcl getpackage textutil textutil/textutil.tcl struct::matrix m m add columns 3 puts {Descriptions...} if {[llength $argv] == 0} {set argv [modules]} foreach m [lsort [dealias $argv]] { array set _ {} set pkg {} foreach {p vlist} [ppackages $m] { catch {set _([lindex $pd($p) 0]) .} lappend pkg $p } set desc [string trim [join [array names _] ", "] " \n\t\r,"] set desc [textutil::adjust $desc -length 20] unset _ m add row [list $m $desc] m add row {} foreach p [lsort -dictionary $pkg] { set desc "" catch {set desc [lindex $pd($p) 1]} if {$desc != ""} { set desc [string trim $desc] set desc [textutil::adjust $desc -length 50] m add row [list {} $p $desc] } else { m add row [list {**} $p ] } } m add row {} } m format 2chan puts "" return } proc __desc/2 {} { global argv ; if {![checkmod]} return array set pd [getpdesc] getpackage struct::matrix struct/matrix.tcl getpackage textutil textutil/textutil.tcl puts {Descriptions...} if {[llength $argv] == 0} {set argv [modules]} foreach m [lsort [dealias $argv]] { struct::matrix m m add columns 3 m add row {} set pkg {} foreach {p vlist} [ppackages $m] {lappend pkg $p} foreach p [lsort -dictionary $pkg] { set desc "" set sdes "" catch {set desc [lindex $pd($p) 1]} catch {set sdes [lindex $pd($p) 0]} if {$desc != ""} { set desc [string trim $desc] #set desc [textutil::adjust $desc -length 50] } if {$desc != ""} { set desc [string trim $desc] #set desc [textutil::adjust $desc -length 50] } m add row [list $p " $sdes" " $desc"] } m format 2chan puts "" m destroy } return } # -------------------------------------------------------------- proc __docstrip/users {} { # Print the list of modules using docstrip for their code. set argv [modules] foreach m [lsort $argv] { if {[docstripUser $m]} { puts $m } } return } proc __docstrip/regen {} { # Regenerate modules based on docstrip. global argv ; if {![checkmod]} return if {[llength $argv] == 0} {set argv [modules]} foreach m [lsort [dealias $argv]] { if {[docstripUser $m]} { docstripRegen $m } } return } # -------------------------------------------------------------- ## Make sak specific packages visible. lappend auto_path [file join $distribution support devel sak] # -------------------------------------------------------------- ## Dispatcher to the sak commands. set cmd [lindex $argv 0] set argv [lrange $argv 1 end] incr argc -1 # Prefer a command implementation found in the support tree. # Then see if the command is implemented here, in this file. # At last fail and report possible commands. set base [file dirname [info script]] set sbase [file join $base support devel sak] set cbase [file join $sbase $cmd] set cmdf [file join $cbase cmd.tcl] if {[file exists $cmdf] && [file readable $cmdf]} { source $cmdf exit 0 } if {[llength [info procs __$cmd]] == 0} { puts stderr "$argv0 : Illegal command \"$cmd\"" set fl {} foreach p [info procs __*] { lappend fl [string range $p 2 end] } foreach p [glob -nocomplain -directory $sbase */cmd.tcl] { lappend fl [lindex [file split $p] end-1] } regsub -all . $argv0 { } blank puts stderr "$blank : Should have been [linsert [join [lsort -uniq $fl] ", "] end-1 or]" exit 1 } __$cmd exit 0 tcllib-1.15/ChangeLog0000644000175000017500000030073312104363437014012 0ustar sergeisergei2013-02-01 Andreas Kupries * * Released and tagged Tcllib 1.15 ======================== * 2013-01-28 Andreas Kupries * modules/fileutil: New package 'fileutil::decode'. * modules/zip: New module 'zip', with packages 'zipfile::encode' and 'zipfile::decode' 2013-01-24 Andreas Kupries * New module and packages: clock (rfc2822, iso8601). Tcl 8.5 only. 2013-01-08 Andreas Kupries * configure.in: [Bug 3593146]: Extended with CYGPATH usage to allow building under cygwin. * configure: Regenerated (autoconf 2.67). 2012-08-07 Andreas Kupries * modules/generator: Generators (via the coroutines of Tcl 8.6). Provided by Neil Madden. * support/installation/modules.tcl: 2011-12-13 Andreas Kupries * * Released and tagged Tcllib 1.14 ======================== * 2011-11-07 Andreas Kupries * sak.tcl (xcopy): Fixed bug a preventing the detection of files in subdirectories; copied from the installer. * sak.tcl (ipackages): Fixed bug (reuse of varname) which placed packages into the wrong module. 2011-05-31 Andreas Kupries * New module and package: oo::util. Right now only easy referencing of instance methods for callbacks. * New module and package: lambda. Easy anonymous procedures for Tcl 8.5+. * New module and package: try. Tcl 8.5+ forward compatibility implementation of try/catch/finally (TIP 329). 2011-04-21 Andreas Kupries * modules/struct/queue_c.tcl: Disabled the critcl debug settings used * modules/pt/pt_rdengine_c.tcl: to work around bugs in critcl v2's * modules/pt/pt_parse_peg_c.tcl: handling of C companion files. * modules/pt/pt_cparam_config_critcl.tcl: * sak.tcl (__critcl): Fixed processing of -debug, added the forgotten handling of its argument. Plus added handling of option -target. * ./modules/sha1/sha256.h: Fixed the conditional definition of uint64_t and uint32_t for aix and hpux machines. 2011-04-06 Andreas Kupries * modules/valtype: New module: Validation types. snit validation types for various classes of numbers (ISBN, EAN, ...) and general check-digit algorithms (luhn(5), verhoeff, ...). 2011-01-24 Andreas Kupries * * Released and tagged Tcllib 1.13 ======================== * 2011-01-13 Andreas Kupries * sak.tcl: Trim dross of extracted version numbers. * support/devel/sak/note/cmd.tcl: Extended 'sak note' to accept * support/devel/sak/note/help.txt: a file of note data. 2011-01-12 Andreas Kupries * modules/hook: New module 'hook'. * support/installation/modules.tcl: 2010-11-25 Andreas Kupries * examples/mime/maildemo.tcl: [Patch 3117246]: Added the standard script prologue. Thanks to Stuart Cassoff. 2010-11-23 Andreas Kupries * apps/dtplite.man: Extended with new option -exclude to specify * apps/dtplite: exclusion patterns (glob matching). Further fixed issues with file paths causing resolution of include file paths to break. This uses the new option -ibase of doctools 1.4.11 to keep include resolution and HTML cross-link generation apart from each other. Bumped version to 1.0.3. 2010-10-26 Andreas Kupries * support/installation/modules.tcl: [Bug 3085417]: Added the nano nameservice applications to the installation. 2010-10-22 Kevin Kenny * support/installation/modules.tcl: Corrected installation of grammar::aycock. 2010-10-18 Kevin Kenny * modules/grammar_aycock: New module, Aycock-Earley-Horspool parser generator. 2010-10-08 Andreas Kupries * modules/pki: New module, public key infrastructure. * support/installation/modules.tcl: 2010-07-09 Andreas Kupries * support/installation/modules.tcl: [Bug 3027371]. Fixed typo 'imap' -> 'imap4'. Thanks to Larry Virden for reporting. 2010-07-08 Andreas Kupries * modules/gpx: New module 'gpx'. * support/installation/modules.tcl: 2010-07-06 Andreas Kupries * support/installation/modules.tcl: Module 'imap4' activated. 2010-03-25 Andreas Kupries * New module 'pt', for ParserTools. Requires Tcl 8.5. Supercedes grammar_peg, grammar_me, and page. 2009-12-08 Andreas Kupries * support/devel/sak/test/run.tcl (CaptureFailureCollectBody, CaptureFailureCollectError): Fixed issue with test result capture on failure. We failed on the capture of failure due to unexpected return codes, because the output syntax is different for that compared to failure due to result differences. Code has been added to recognize and capture this other syntax. * support/devel/sak/test/run.tcl: Extended the test framework to * support/devel/all.tcl: record time per .test file, count of tests per file, enabling it to compute a speed (microseconds per test), as a rough and crude benchmark of where we may have performance problems with either packages or tests. 2009-12-07 Andreas Kupries * * Released and tagged Tcllib 1.12 ======================== * 2009-12-03 Andreas Kupries * support/devel/sak/readme/readme.tcl: Strip trailing whitespace from the table formatted parts of the generated readme. 2009-12-01 Andreas Kupries * New modules 'virtchannel_{core,base,transform}' with packages providing core services to reflected channels and transformations, and basic reflected channels, and transforms. This is in essence the example code for the paper I presented at Tcl'2009 in Portland (Reflected and Transformed Channels). * support/installation/modules.tcl: New modules 'virtchannel_*'. 2009-11-24 Andreas Kupries * New package 'json::write' in existing module 'json'. * support/devel/sak/note/cmd.tcl: Extended note command to show * support/devel/sak/note/note.tcl: saved hints when called without arguments. 2009-11-23 Andreas Kupries * support/installation/modules.tcl: Fix issue with examples for logger, * support/installation/actions.tcl: which did not fit the expectations of action _exa, which assumed the module name, which is 'log'. Instead of wrestling CVS into renaming the directory a new action is made which takes the actual name as argument. * support/devel/sak/note/cmd.tcl: New sak commands 'note' and 'readme' * support/devel/sak/note/help.txt: for semi-automatic generation of * support/devel/sak/note/note.tcl: the release README.txt from * support/devel/sak/note/pkgIndex.tcl: current and last package * support/devel/sak/note/topic.txt: versions, and note'd hints. * support/devel/sak/readme/cmd.tcl: * support/devel/sak/readme/help.txt: * support/devel/sak/readme/pkgIndex.tcl: * support/devel/sak/readme/readme.tcl: * support/devel/sak/readme/topic.txt: 2009-11-11 Andreas Kupries * apps/dtplite: Updated the requirements to force use of doctools v1, this app is not doctools v2 ready yet. 2009-11-10 Andreas Kupries * support/devel/sak/validate/cmd.tcl: Extended argument processing * support/devel/sak/validate/manpages.tcl: of the validation command * support/devel/sak/validate/syntax.tcl: to enable a user to specify * support/devel/sak/validate/testsuites.tcl: which version of Tcl * support/devel/sak/validate/validate.tcl: to check against. Plus * support/devel/sak/validate/versions.tcl: fix to handle modules without manpages. * modules/coroutine: New module 'coroutine' providing to coroutine utility packages for easier use of channel operations. These packages are for Tcl 8.6+. * support/installation/modules.tcl: New module 'coroutine'. 2009-09-28 Andreas Kupries * support/devel/sak/test/run.tcl (::sak::test::run::CaptureStack): Fix missing variable declaration, and tweak generated output a bit. * support/devel/sak/test/run.tcl (Do): Reworked a bit to save captured error stacks and failed tests (body, actual, expected) into separate log files for quick access. 2009-07-10 Andreas Kupries * README.releasemgr: Added links to important places in the SourceForge site for managing Tcllib releases and uploading files (WebDAV), to avoid the ever more byzantine link sequences needed to find them on their site. 2009-06-02 Andreas Kupries * README.developer: Extended with more information about the basic directory hierarchy and files to be found, testing and validating modules, writing of test cases, and documentation. 2009-02-06 Andreas Kupries * support/installation/modules.tcl (Module): Put 'exif' on the exclude list, deprecating it. Use 'jpeg' instead to access the exif information block in images. 2009-01-29 Andreas Kupries * examples/bibtex/bibtex.tcl: Modified examples to assume that * examples/htmlparse/webviewer.tcl: they are run by a tclsh found * examples/irc/irc_example.tcl: on the PATH, and that this shell * examples/mapproj/tkmap.tcl: has access to the packages of * examples/math/bigfloat.demo.tcl: Tcllib required by the example. * examples/ntp/rdate.tcl: Stuart Cassoff * examples/sasl/saslclient.tcl: provided by the patches as * examples/struct/diff.tcl: part of his work on making a Tcllib * examples/struct/diff2.tcl: OpenBSD port. * support/installation/modules.tcl: Added the examples for a number of modules to the installer. Patch by Stuart, see above. 2009-01-28 Andreas Kupries * apps/dtplite: Added missing EOL to last line of the generated .toc and .idx files. Bumped version to 1.0.1 * apps/*.man: Added category information to the majority of man * modules/*/*.man: pages. * support/devel/sak/doc/cmd.tcl: Moved the main code for the * support/devel/sak/doc/doc.tcl: imake/ishow commands into a * support/devel/sak/doc/pkgIndex.tcl: separate package. Added a * support/devel/sak/doc/doc_auto.tcl: new command 'doc index' * support/devel/sak/doc/manpages.txt: which not only updates * support/devel/sak/doc/kwic.txt: 'manpages.txt', but also * support/devel/sak/doc/toc.txt: generates a keyword index ('kwic.txt'), and a table of contents ('idx.txt'). The first result are committed as part of this change. The newly generated files are in docidx and doctoc formats, respectively. 2008-12-12 Andreas Kupries * * Released and tagged Tcllib 1.11.1 ======================== * 2008-11-25 Andreas Kupries * support/installation/modules.tcl: New module 'map' with packages 'map::slippy::*'. 2008-11-18 Andreas Kupries * support/installation/modules.tcl: New module 'cache' with package 'cache::async'. 2008-10-16 Andreas Kupries * * Released and tagged Tcllib 1.11 ======================== * 2008-09-03 Andreas Kupries * modules/devtools/testutilities.tcl (useTcllibC): Added code to print the location of the tcllibc used by the testsuite. * support/devel/sak/test/run.tcl (::sak::test::run::AbortCause): Tweaked to be more lenient and accept more error messages. 2008-07-08 Andreas Kupries * support/installation/modules.tcl: New module 'amazon-s3' with packages 'S3' and 'xsxp', by Darren New. Access to Amazon's Simple Storage Service. 2008-06-30 Andreas Kupries * support/installation/actions.tcl (_manfile): Tossed two of the three identical copies of this procedure. Thanks to Stuart Cassoff for noticing and reporting this. 2008-06-20 Andreas Kupries * support/installation/version.tcl: Added code integrated struct::stack's critcl implementation into the build. 2008-05-22 Andreas Kupries * support/installation/modules.tcl: Added 'yaml' to the list of official modules. 2008-03-26 Andreas Kupries * support/devel/sak/validate/syntax.tcl: Fix problem in pcx scan logic, have to handle unknown commands. Like is done for testsuites. 2008-03-25 Andreas Kupries * support/devel/sak/validate/syntax.tcl: Do not try to check TeX files for Tcl syntax. * support/devel/sak/validate/syntax.tcl: New code, syntax checking via tclchecker. * support/devel/sak/validate/validate.tcl: Activated new validation module. * support/devel/sak/validate/manpages.tcl: Skip tcllibc. * support/devel/sak/validate/testsuites.tcl: Skip tcllibc. * support/devel/sak/util/feedback.tcl: Flush log lines. * sak.tcl (ppackages): Added code to recognize a pragma '@sak notprovided' which we can use to mark the packages which have provide statements yet are not really visible and thus not indexed. * modules/sha1/sha256c.tcl: Added notprovided pragmas to the * modules/sha1/sha1c.tcl: critcl based package implementations * modules/md5/md5c.tcl: and the pseudo-packages declared by * modules/struct/graph_c.tcl: plugin management code. * modules/struct/tree_c.tcl: * modules/struct/sets_c.tcl: * modules/dns/ipMoreC.tcl: * modules/md5crypt/md5cryptc.tcl: * modules/rc4/rc4c.tcl: * modules/crc/crcc.tcl: * modules/base64/base64c.tcl: * modules/md4/md4c.tcl: * modules/page/peg_grammar.tcl: * modules/page/pluginmgr.tcl: 2008-03-24 Andreas Kupries * support/installation/modules.tcl: Added 'simulation' to the list of official modules. * support/devel/sak/validate/versions.tcl: New code for the comparison of indexed versus provides packages. * support/devel/sak/validate/validate.tcl: Activated new validation module. * support/devel/sak/validate/testsuites.tcl: Reworked log format. * support/devel/sak/validate/manpages.tcl: Reworked log format. 2008-03-22 Andreas Kupries * support/devel/sak/validate/help.txt: Clarified that testsuite validation is not testsuite execution. * support/devel/sak/validate/validate.tcl: Added testsuite * support/devel/sak/validate/cmd.tcl: validation, using the new entrypoints to move summaries after the checking phases, and updated to the feedback api changes. * support/devel/sak/validate/testsuites.tcl: New code, validation of testsuites (= checking which packages are without). * support/devel/sak/validate/manpages.tcl: Reworked for changed feedback module, split summary generation from main body, and set up proper multiple entry points. * support/devel/sak/util/feedback.tcl: Reworked for easier use when used from multiple packages which can be run separately and together. Added support for summary generation. 2008-03-18 Andreas Kupries * support/devel/sak/old/help.txt: Renamed old validation command. * sak.tcl: Renamed old validation command. * support/devel/sak/validate/cmd.tcl: New validation code, currently * support/devel/sak/validate/help.txt: only checking documentation. * support/devel/sak/validate/manpages.tcl: * support/devel/sak/validate/pkgIndex.tcl: * support/devel/sak/validate/topic.txt: * support/devel/sak/validate/validate.tcl: * support/devel/sak/doc/cmd.tcl: Fixed a typo. * support/devel/sak/doc/topic.txt: Deeper indentation. * support/devel/sak/help/topic.txt: Deeper indentation. * support/devel/sak/old/topic.txt: Deeper indentation. * support/devel/sak/test/run.tcl: Replaced custom color code with use of the new package sak::color. * support/devel/sak/test/cmd.tcl: Fixed a typo. * support/devel/sak/test/topic.txt: Deeper indentation. * support/devel/sak/util/pkgIndex.tcl: Added two new sak support * support/devel/sak/util/color.tcl: packages to handle colorization * support/devel/sak/util/feedback.tcl: and common feedback ops (on top of the animation). * support/devel/sak/util/anim.tcl: Exported the public commands. 2008-03-07 Andreas Kupries * support/devel/sak/test/run.tcl (::sak::test::run::Summary): Fixed [Bug 1909367]. Error information is now passed from the file summary code to the counters for the whole test run. 2008-01-29 Pat Thoyts * modules/stringprep: New module 'stringprep'. * support/installation/modules.tcl: 2007-09-12 Andreas Kupries * * Released and tagged Tcllib 1.10 ======================== * 2007-09-07 Andreas Kupries * support/releases/history/README-1.10.txt: Updated for modified math package. 2007-08-30 Andreas Kupries * devdoc/critcl-tcllib.txt: Fixed [SF Tcllib Bug 1784843], applied * devdoc/dirlayout_install.txt: Larry Virden's patches fixing typos, * devdoc/indexing.txt: and doing other editorial changes. * devdoc/installation.txt: * devdoc/devguide.html: * README.developer: Fixed [SF Tcllib Bug 1784836], applied Larry * README: Virden's patches fixing typos, and doing other editorial changes. 2007-08-29 Andreas Kupries * modules/tcllibc.tcl: Version of package bumped to 0.3.2 for the bugfix in the C implementation of struct::set (v 2.2.1). 2007-08-28 Andreas Kupries * support/releases/history/README-1.10.txt: Whitespace and formatting cleanup after various updates for modified packages. 2007-08-24 Kevin B. Kenny * support/installation/modules.tcl: New module 'mapproj' added. 2007-08-24 Andreas Kupries * README.developer: Added a section describing the basic steps of adding a new module. * support/releases/history/README-1.10.txt: Whitespace and formatting cleanup. 2007-08-22 Andreas Kupries * apps/tcldocstrip (::tcldocstrip::processCmdline): Fixed handling of arguments if there are none. The linsert construction broke for that case. Application version bumped to 1.0.1. 2007-08-21 Andreas Kupries * README.developer: Section about testing updated for the changes in the Makefile. * Makefile.in (install-applications): New target, complement to 'install-libraries', for applications only. * Makefile.in (test): The target now distinguishes interactive invokation and batch mode, and chooses its log mode accordingly (interactive: progress feedback, short log, batch: detailed log). The batch mode is invoked by redirecting the stdout to a file. Per a suggestion of Mikhail Teterin. The two modes are also directly acessible, via the new targets 'test_batch' and 'test_interactive'. 2007-08-21 Andreas Kupries * README.developer: Added a small introduction to the testing of modules via 'sak.tcl'. This fixes [SF Tcllib Bug 1750655] by Larry Virden. * support/devel/sak/test/run.tcl: Reworked the handling of setup errors and of the various failure states to ensure that they are properly reported as problems in the summary output instead of giving the appearance that everything is ok. Some trouble in the math testsuite was spotted only by reading the detailed log and would have been missed otherwise. 2007-08-20 Andreas Kupries * support/releases/history/README-1.10.txt: README listing the changes for the upcoming release. 2007-07-27 Andreas Kupries * support/installation/modules.tcl: New module 'wip' added. A mini interpreter for word lists based on ideas in 'treeql'. 2007-07-17 Andreas Kupries * support/installation/modules.tcl: New module 'uev' added, for the generation and handling of user events. 2007-05-04 Andreas Kupries * support/installation/modules.tcl: New module 'nns' added, a nano-sized name service based on and for 'comm'. Derived from the nserver code in the Pool_Net bundle of packages. 2007-05-03 Andreas Kupries * sak.tcl: Added stronger check for 'package provided' command to 'ppackages'. Code in critcl.tcl generated for tcllibc slips past the less strong filters. 2007-03-21 Andreas Kupries * Changed all documentation files (*.man). Replaced all deprecated commands and list types with their new canonical names, putting the Tcllib documentation back in line with the current definition of the doctools language and its companions. 2006-11-15 Andreas Kupries * support/installation/version.tcl: Added critcl implementation of struct::graph to the list of critcl supported packages. 2006-11-04 Pat Thoyts * modules/tcllibc.tcl: Silence critcl warnings. Files with no code raise a warning message. Add an empty critcl::ccode block to avoid. 2006-10-13 Andreas Kupries * modules/tcllibc.tcl: Bumped to version 0.3.1. I believe this has to be bumped whenever one of the contained packages changes, or more packages are added. Keep track of this. 2006-10-08 Andreas Kupries * support/devel/all.tcl: Small comments added to clarify the operation of the cleanup hook, and a tiny bit of code cleanup. 2006-10-03 Andreas Kupries * * Released and tagged Tcllib 1.9 ======================== * 2006-10-01 Andreas Kupries * Makefile.in (test): Changed to use an explicit -s TCLSH_PROG to avoid use of the Tcllib registry. * support/devel/sak/test/run.tcl: Flush all writes to logfiles, to ensure that they are uptodate in case an abort is needed. Added output of totals after the test run, and made exit status dependent on failures (1 = Ok, 0 = Had problems). 2006-09-27 Andreas Kupries * support/devel/all.tcl: Ensure that root is absolute across all versions of Tcl. Added code to recreate the auto_path in the slave interps and processes after it was smashed by older revisions of tcltest during their load. 2006-09-20 Andreas Kupries * support/releases/history/README-1.9.txt: New file. Readme file for the upcoming release, providing an overview of the changes. 2006-09-20 Andreas Kupries * support/devel/sak/test/run.tcl: Modified to not use echo and cat * support/devel/sak/test/help.txt: when starting a testsuite on windows. Eliminated the use of valgrind for that platform as well. Updated the documentation regarding the latter. 2006-09-19 Andreas Kupries * support/devel/sak/test/run.tcl: Extended testsuite logging. * support/devel/sak/test/help.txt: Standard user feedback and extended information (raw log, summaries) are written to a set of files. All required information in one run, instead of two. 2006-09-18 Andreas Kupries * installer.tcl: Accepted patch by Michael Schlenker for [Tcllib SF Bug 1559489] to divert error messages to a dialog box instead of stderr where possible, to avoid them being silently swallowed by windows. * support/devel/sak/test/run.tcl: Reworked output generated * support/devel/all.tcl: by testsuites, added processing of the modified output for progress reporting, condensed reporting, and in preparation of placing results into a database. * support/devel/sak/test/help.txt: Updated documentation. * support/devel/sak/test/shell.tcl: Fixed typo in name of method to call to remove shells from the database. 2006-09-06 Andreas Kupries * Makefile.in (test): Updated the target to the new syntax for running testsuites accepted by sak. 2006-09-05 Andreas Kupries * support/devel/sak/test/help.txt: Added reference to the file used to store the list of registered shells. * support/devel/all.tcl: Changed to terminate with 'exit' instead of 'return', to allow the testsuites to be driven by a 'wish' without having to deal with its event loop. * support/devel/sak/test/cmd.tcl: Replaced the existing * support/devel/sak/test/help.txt: implementation of 'test' with a dispatcher to an extensible set of packages. See below. * support/devel/sak/test/pkgIndex.tcl: New implementation of the * support/devel/sak/test/run.tcl: 'test' command and its sub- * support/devel/sak/test/shell.tcl: commands. The 'registry', see * support/devel/sak/test/shells.tcl: below, is used to store the * support/devel/sak/test/test.tcl: registered shells. * support/devel/sak/util/pkgIndex.tcl: Registered package. * support/devel/sak/util/registry.tcl: New file, wrapper around the pregistry, customized to SAK. * support/devel/sak/registry/pkgIndex.tcl: Package for a small tree- * support/devel/sak/registry/registry.man: based database similar to * support/devel/sak/registry/registry.tcl: the windows registry. For * support/devel/sak/registry/registry.test: now just an internal package to support 'sak', in the future it may move and become an official package. 2006-09-01 Pat Thoyts * support/installation/modules.tcl: New module 'otp'. 2006-08-30 Andreas Kupries * support/installation/modules.tcl: New module 'interp'. 2006-08-17 Jeff Hobbs * support/installation/modules.tcl: added json package 2006-08-15 Michael Schlenker * sak.tcl: Added support for nagelfar (nagelfar.berlios.de) to the static syntax checking options of sak.tcl while doing a validate or validate_all. Fixed a slight inconsistency between validate and validate all, tclchecker was not checked for validate. 2006-08-14 Andreas Kupries * Makefile.in (*-doc): Forgotten to update the Makefile targets for documentation when changing the sak syntax for invoking a doc conversion. See entry 2006-07-09. Thanks to wohnivec@dix.cz for noticing and provision of a patch. 2006-08-10 Andreas Kupries * support/devel/sak/doc/doc.tcl (::sak::doc::ps): Fixed bogus redirection argument 1>@, correct is >@. 2006-08-09 Andreas Kupries * support/devel/all.tcl: Fixed the loading of Tk into the slave interp, before Tk 8.4 we are not a real package. Using an explicit load for a Tk statically bound into the executable. 2006-07-27 Andreas Kupries * sak.tcl: Removed __test. Replaced with a single command * support/devel/sak/test: with an implementation found in the support tree. See below. * support/devel/sak/test/cmd.tcl: New. Implementation of 'test'. * support/devel/sak/test/help.txt: New. Help for 'test'. * support/devel/sak/test/topic.txt: New. Topic definition for 'test'. 2006-07-12 Andreas Kupries * support/installation/modules.tcl: Fixed registration of 'term', needs recursive install. 2006-07-10 Andreas Kupries * New module "term". Terminal control. * support/installation/modules.tcl: Registered 'term'. 2006-07-09 Andreas Kupries * sak.tcl: Removed __nroff and all other documentation commands. * support/devel/sak/old/help.txt: Replaced with a single command with an implementation found in the support tree. See below. * support/devel/sak/doc/cmd.tcl: New. Implementation of 'doc'. * support/devel/sak/doc/doc.tcl: New. Support package for 'doc'. * support/devel/sak/doc/pkgIndex.tcl: New. Index for support package. * support/devel/sak/doc/help.txt: New. Help for 'doc'. * support/devel/sak/doc/topic.txt: New. Topic definition for 'help'. * support/devel/sak/util/util.tcl: New. General support package, * support/devel/sak/util/pkgIndex.tcl: and index for it. 2006-07-05 Andreas Kupries * sak.tcl: Removed __help. Replaced with implementation found in the support tree. See below. * support/devel/sak/help/cmd.tcl: New. Implementation of 'help' * support/devel/sak/help/help.tcl: New. Support package for 'help'. * support/devel/sak/help/help.txt: New. Help for 'help'. * support/devel/sak/help/pkgIndex.tcl: New. Index for support package. * support/devel/sak/help/topic.txt: New. Topic definition for 'help'. * support/devel/sak/old/help.txt: New. Help for old commands. * support/devel/sak/old/topic.txt: New. Topic def. for old commands. * sak.tcl: Added code to locate command implementations in the support tree. This allows us to factor the commands out of the main script, making the internal structure of sak clearer (through the use of packages). 2006-06-30 Andreas Kupries * main.tcl: Moved, and new location * support/installation/main.tcl: of the file. * sak.tcl: Updated to the new location (has to be copied to the topdir now, when generating the starkit/pack distribution). * man.macros: Moved, and new location * support/installation/man.macros: of the file. * installer.tcl: Updated to the new location. * all.tcl: Moved, and new location * support/devel/all.tcl: of the file. Also updated to handle the new location of the distribution relative to all.tcl, to properly find the testsuites. * sak.tcl: Updated to the new location of all.tcl * package_rpm.tcl: Moved, and new location * support/releases/package_rpm.tcl: of the file. * package_yml.tcl: Moved, and new location * support/releases/package_yml.tcl: of the file. * package_tip55.tcl: Moved, and new location * support/releases/package_tip55.tcl: of the file. * sak.tcl: Updated to the new location of * installer.tcl: package_rpm.tcl, package_tip55.tcl, package_yml.tcl * package_version.tcl: Moved, and new location * support/installation/version.tcl: of the file. * sak.tcl: Updated to the new location of * installer.tcl: package_version.tcl * install_action.tcl: Moved, and new location * support/installation/actions.tcl: of the file. * installed_modules.tcl: Moved, and new location * support/installation/modules.tcl: of the file. * sak.tcl: Updated to the new location of * installer.tcl: install_action.tcl, installed_modules.tcl. * README.developer: New files to introduce new developers * README.releasemgr: and release managers to Tcllib, the tools available to support and ease their tasks, the procedures we have in place, etc. For now they are more or less placeholders, to be fleshed out with actual content over time. * installed_modules.tcl: Registered new module 'nmea'. * PACKAGES: Moved. * support/releases/PACKAGES: New location of PACKAGES. * sak.tcl: Updated to the new location of PACKAGES. 2006-06-30 Andreas Kupries * installed_modules.tcl: Changed to a declarative style (more amenable to automated processing). 2006-06-15 Andreas Kupries * sak.tcl: Extended to allow the specification of a module M as either M or modules/M. The latter is a path relative to the topdir and enables the entering of modules through tab-completion in the shell. 2006-05-27 Andreas Kupries * installed_modules.tcl: New module 'base32'. 2006-05-23 Andreas Kupries * installed_modules.tcl: New module 'transfer'. 2006-04-26 Andreas Kupries * sak.tcl (gd-gen-tap): modified to strip non-version characters out of version numbers. 2006-01-21 Andreas Kupries * all.tcl: Removed the definitions of the common test constraints, and the emulations of the 'wrongNumArgs' and 'tooManyArgs' commands. These have all moved into the new common test support code found in "devtools". 2005-11-02 Andreas Kupries * sak.tcl: Removed all functionality related to execution of .timing files. They are superceded by the benchmarks provided through .bench files. * modules/aes/aes.timing: Removed, superceded by .bench files. * modules/des/des.timing: * modules/rc4/rc4.timing: * modules/blowfish/blowfish.timing 2005-11-02 Andreas Kupries * sak.tcl (ppackages): Added hack to exclude the package @@ from the tap file. This is defined in template code in page/gen_peg_cpkg.tcl, i.e. a variable. 2005-10-27 Andreas Kupries * sak.tcl (bench_mod): Modified default interp to use in benchmarks from PATH to the interp executing SAK. 2005-10-21 Andreas Kupries * sak.tcl: Extended benchmark facility. New command for removal of columns from results. New option to explicitly specify a single interpreter to use. 2005-10-18 Andreas Kupries * sak.tcl: More benchmarking functionality, showing benchmark data after the fact, implicit merging, and changing interp information around. Now we need only some functionality to show the data graphically, and possibly compute statistical information. 2005-10-17 Andreas Kupries * installed_modules.tcl: New module "bench". Benchmarking support package. * sak.tcl: Added benchmarking functionality. 2005-10-06 Andreas Kupries * * Released and tagged Tcllib 1.8 ======================== * 2005-10-05 Pat Thoyts * sak.tcl: Added support for passing parameters to critcl. v04 will support -debug and -clean and v034 supports -keep. 2005-09-29 Andreas Kupries * README-1.8.txt: New file. Readme file for the upcoming release. * sak.tcl (pkg-compare): Modified the core of the 'rstatus' functionality to sort by module, then package, and show the module name before the packages. Easier for use in new release README file. * installed_modules.tcl: log module changed to use _msg for installation. * install_action.tcl (_msg): New action for modules having a message catalogs in a msgs subdirectory. * installer.tcl (xcopy): Fixed bug in the interaction of recursion and pattern argument. It is for files, but affected directories as well, causing page to ignore its plugin directory. 2005-09-28 Andreas Kupries * installed_modules.tcl: Using _tcr to install page and its plugins. * install_action.tcl (_tcr): New install action, recursive install of all .tcl files in the module. 2005-09-27 Andreas Kupries * installed_modules: New module: grammar_me. * installed_modules: New module: grammar_peg. * installed_modules: New module: page. * installed_modules: New application: page. 2005-09-26 Andreas Kupries * installed_modules.tcl: Added the 'tcldocstrip' application to the installer. 2005-09-20 Andreas Kupries * all.tcl: Added Tcl 8.5 specific code to '::tcltest::tooManyArgs'. 2005-09-05 Pat Thoyts * sak.tcl: Added a 'timing' subcommand to run *.timing scripts. 2005-08-29 Kevin Kenny * all.tcl (tcltest::wrongNumArgs): Revised to handle 8.5 error message. 2005-08-29 Pat Thoyts * modules/aes: NEW MODULE: aes * installed_modules.tcl: 2005-08-17 Bob Techentin * installed_modules.tcl: NEW MODULE: units * modules/units: 2005-07-26 Stephane Arnold * installed_modules.tcl : registered math example 2005-07-25 Andreas Kupries * config/config.guess: Updated to newer versions. * config/config.sub: * all.tcl: Small correction in wrongNumArgs for when the argument list is not empty (Added a space). * sak.tcl: Rewrite of critcl invokation on Windows, allow usage of critcl starpack, and for starkits a plain tclsh as interpreter. 2005-07-07 Andreas Kupries * modules/pluginmgr: New module for the management of plugins. 2005-04-28 Andreas Kupries * installer.tcl: Fixed installer, updated to the new file and API for package meta information. Fixed bug in app installation, forgot to skip actual copy operations when in simulate-mode. 2005-04-22 Andreas Kupries * sak.tcl: Should be bundle independent now, with (undocumented) API to the bundle specific information (package_* files). * sak.tcl: Moved existing name/version variables over to package neutral names. Moved meta data file to package neutral name. Changed the API between sak and meta data file, it is now command oriented. Replaced hardwired package labeling with variables. Moved the bundle specific release cleanup into the meta data file, and made the cleanup code generic. Ditto for the bundle specific critcl definitions. Modified package load to fall back to a regular 'require' if there is no local file containing the package implementation. * sak.tcl: Moved the bundle specific template data * package_rpm.txt: into separate file and rewrote the code * package_yml.txt: using them to be more regular. * package_tip55.txt: 2005-04-04 Andreas Kupries * sak.tcl: Extended to handle multiple versions of a package better when comparing and listing versions. * apps/tcldocstrip: New application, an implementation of * apps/tcldocstrip.man: docstrip in Tcl, for Tcl. Incl. documentation. 2005-03-31 Andreas Kupries * sak.tcl: Added code to regenerate sources of modules whose master sources are in one or more docstrip files. * sak.tcl: Extended the code for the extraction of version information from packages with a heuristic static analysis to cut down on the expense of executing package code. Also made the code more robust for packages importing other packages. * sak.tcl: Replaced all internal 'package require' statements with calls to an internal helper which always loads from the local directory tree, i.e. preventing use of an external installation (which may be incompatible). ... Removed triplicate definition of command 'write_out'. ... Extended help message a bit. ... Added code to help internal debugging through logging. 2005-03-25 Jeff Hobbs * Makefile.in (install-libraries): add -app-path arg (steffen) 2005-03-15 Andreas Kupries * modules/bibtex: NEW MODULE: Parser for BibTeX bibliographies. * installed_modules.tcl: Added to the list of installed modules. 2005-02-22 Andreas Kupries * modules/asn/asn.man: Used the new functionality in sak * modules/base64/base64.man: to look over the package descriptions. * modules/base64/uuencode.man: Tightened them a bit, consolidating * modules/base64/yencode.man: especially differing module descriptions. * modules/cmdline/cmdline.man: Added some missing descriptions. * modules/comm/comm.man: * modules/crc/cksum.man: * modules/crc/crc16.man: * modules/crc/crc32.man: * modules/crc/sum.man: * modules/dns/tcllib_dns.man: * modules/dns/tcllib_ip.man: * modules/fumagic/cfront.tcl * modules/grammar_fa/dacceptor.man: * modules/grammar_fa/dexec.man: * modules/grammar_fa/fa.man: * modules/grammar_fa/faop.man: * modules/jpeg/jpeg.man: * modules/ldap/ldap.man: * modules/math/bigfloat.man: * modules/math/bignum.man: * modules/math/calculus.man: * modules/math/constants.man: * modules/math/fourier.man: * modules/math/fuzzy.man: * modules/math/geometry.man: * modules/math/interpolate.man: * modules/math/linalg.man: * modules/math/optimize.man: * modules/math/polynomials.man: * modules/math/qcomplex.man: * modules/math/romberg.man: * modules/math/special.man: * modules/math/statistics.man: * modules/md4/md4.man: * modules/md5/md5.man: * modules/md5crypt/md5crypt.man: * modules/multiplexer/multiplexer.man: * modules/ntp/ntp_time.man: * modules/rc4/rc4.man: * modules/ripemd/ripemd128.man: * modules/ripemd/ripemd160.man: * modules/sha1/sha1.man: * modules/snit/snit.man: * modules/snit/snitfaq.man: * modules/textutil/expander.man: * modules/textutil/textutil.man: * sak.tcl: Extended with code to extract package descriptions from the module manpages. The association between packages and manpages is made through the manpage title and require statements. Added sub commands which format and print the found information. Extended the tap generator to insert such information into its result. * modules/doctools/fmt.desc: New format, used for the basic data extraction mentioned above. 2005-02-14 Andreas Kupries * modules/docstrip: NEW MODULE: docstrip. * installed_modules.tcl: Literate programming support. * apps/dtplite (::dtplite::processCmdline): Fixed the [SF Tcllib Bug 1111364]. The extension has to be set up before the creation of the filename (for a directory output path), otherwise the result will have no extension. 2005-02-10 Andreas Kupries * modules/fumagic: NEW MODULE: fileutil::magic. * installed_modules.tcl: Magic(5) based file recognizers and support code. Currently only one recognizer, for mime-types. 2005-01-31 Pat Thoyts * modules/sasl: NEW MODULE: sasl * installed_modules.tcl: 'Simple Authentication and Security Layer' 2005-01-28 Andreas Kupries * modules/rcs: NEW MODULE: rcs * installed_modules.tcl: Utilities to deal with 'diff -n' patches. 2005-01-10 Andreas Kupries * Makefile.in: Added -no-apps, and -app-path to the installer targets, to ensure that a configure --bin-path is handled correctly. Thanks to Gregor Leusch for both diagnosis and patch ([Tcllib SF Bug 1099727]). 2004-12-06 Pat Thoyts * modules/blowfish: NEW MODULE: blowfish * installed_modules.tcl: 2004-10-13 Pat Thoyts * examples/htmlparse/webviewer.tcl: Added a sample app to demonstrate the use of the htmlparse package. This also demos the use of the autoproxy package too. 2004-10-05 Andreas Kupries * * Released and tagged Tcllib 1.7 ======================== * 2004-09-30 Andreas Kupries * installed_modules.tcl: Added new module 'treeql' to the installer. Thanks to Colin McCormack for donating it. 2004-09-29 Andreas Kupries * installer.tcl (ainstall): Ensure existence of directory for the applications to install. 2004-09-23 Andreas Kupries * sak.tcl (tclfiles, docfiles): Added code to exclude files under SCCS directories from the validation. Required to prevent bogus output when run in my BitKeeper repository. Also fixed bug in docfiles, redefined the wrong command. 2004-09-19 Andreas Kupries * installed_modules.tcl: New module 'tie added to installer. Tcl files and documentation, no examples. 2004-08-25 Andreas Kupries * all.tcl: Added constraint 'tcl8.5plus'. 2004-08-23 Andreas Kupries * modules/tar: * installed_modules.tcl: New module: 'tar'. Tcl files and documentation, no examples. 2004-07-21 Andreas Kupries * apps/dtplite: New application, a lightweight doctools * apps/dtplite.man: processor, superceding mpexpand. * installer.tcl: Extended the installer with code to * install_action.tcl: handle the installation of the * installed_modules.tcl: applications provided by tcllib. 2004-07-17 Pat Thoyts * installed_modules.tcl: NEW MODULE: http The http module is intended to contain things for use with the http package. Now, this is the 'autoproxy' package. I plan to add an auto-cookie managing package too (if I can find it.) 2004-07-09 Andreas Kupries * sak.tcl: Fixed [Tcllib SF Bug 988123], which caused the doctools converter to fail if one run a module without documentation was followed by a module having documentation. Found by Reinhard Max . 2004-07-09 Reinhard Max * installed_modules.tcl: NEW MODULE: ident 2004-07-08 Pat Thoyts * installed_modules.tcl: NEW MODULE: uuid 2004-07-04 Pat Thoyts * sak.tcl: Support critcl implementation of rc4. * modules/tcllibc.tcl: Increment version to 0.2.0. 2004-07-02 Pat Thoyts * installed_modules.tcl: NEW MODULE: rc4 2004-06-22 Andreas Kupries * installed_modules.tcl: Added module 'bee'. * New module for de- and encoding data using the bittorrent serialization format. 2004-05-25 Pat Thoyts * installed_modules.tcl: remove struct1 module. 2004-05-23 Andreas Kupries * tcllib_version.tcl: Changed version in main line to distinguish it from the 1.6 branch and the release coming up in it. 2004-05-23 Andreas Kupries * * Released and tagged Tcllib 1.6.1 ======================== * 2004-05-23 Andreas Kupries * Bumped version in branch to 1.6.1 in preparation of upcoming bugfix release. 2004-05-07 Andreas Kupries * New module for querying JPEG images, and manipulating their comments. * New module: PNG querying and manipulation. 2004-05-04 Andreas Kupries * install_action.tcl: Fixed [SF Tcllib Bug 784519]. Loading the proper doctools directly, and not using the package system. The latter may get confused and try to load the wrong (old) package. 2004-04-27 Andreas Kupries * installed_modules.tcl: Added new module. * examples/ldap: * modules/ldap: New module: LDAP client. Provided to us by Joechen Loewer . 2004-04-16 Pat Thoyts * sak.tcl: Some mods to the critcl build code for use under Windows. If it cannot find critcl.kit, then use env(CRITCL) for the location of the kit file. 2004-03-09 Andreas Kupries * examples/csv/csv2html.orig: Unified the startup header of all * examples/csv/csvcut.orig: applications, using suggestions * examples/csv/csvdiff.orig: made by Stuart Cassoff . * examples/csv/csvjoin.orig: * examples/csv/csvsort.orig: * examples/csv/csvuniq.orig: * examples/ftp/ftpdemo.tcl.orig: * examples/ftp/ftpvalid.orig: * examples/ftp/hpupdate.tcl.orig: * examples/ftp/mirror.tcl.orig: * examples/ftp/newer.tcl.orig: * examples/ftpd/ftpd.orig: * examples/ftpd/ftpd.test.orig: * examples/ftpd/ftpd.unix.orig: * examples/irc/irc_example.tcl.orig: * examples/mime/mbot/README.html.orig: * examples/mime/mbot/README.txt.orig: * examples/mime/mbot/README.xml.orig: * examples/mime/mbot/impersonal.tcl.orig: * examples/mime/mbot/personal.tcl.orig: * examples/nntp/postnews.orig: * examples/oreilly-oscon2001/oscon.orig: * examples/smtpd/tcl_smtpd.orig: * examples/smtpd/tk_smtpd.orig: * examples/smtpd/tk_smtpdMIME.orig: * modules/des/des.tcl.orig: * modules/devtools/musub.tcl.orig: * modules/doctools/mpexpand.orig: * modules/doctools/mpexpand.all.orig: * modules/doctools/tocexpand.orig: * modules/fileutil/fileutil.test.orig: * modules/mime/performance.tcl.orig: * modules/pop3/clnt.tcl.orig: * modules/pop3/srv.tcl.orig: 2004-03-01 Andreas Kupries * installer.tcl: Requiring Tcl 8.2 when executing the installer, as anything below that version does not make any sense. This fixes [Tcllib SF Bug 899152]. * installer.tcl: Fixed [Tcllib SF Bug 899209] by deleting an existing file before trying to overwrite it. 2004-02-18 Andreas Kupries * tcllib_version.tcl: Moving mainline to 1.6.0.1 to distinguish development from the released version. 2004-02-16 Pat Thoyts * modules/ripemd: New module: RIPEMD message-digest implementation * installed_modules.tcl: Added new module. 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * 2004-02-14 Andreas Kupries * README-1.5.txt -> README-1.6.txt * INSTALL.txt * tcllib_version.tcl We have too many places which use the Tcllib CVS head under the designation Tcllib 1.5. Because of that the next officially released version is called Tcllib 1.6, skipping the number 1.5. This should differentiate cleanly between the various instances of Tcllib/CVS floating around and this release, and avoid any confusion about what is which. 2004-02-13 Andreas Kupries * sak.tcl (release): Made functional, added the code which extends all the ChangeLogs with the release notice. (gd-assemble): Extended to exclude SCCS and BitKeeper files from the distribution. (gd-gen-packages): Fixed problem with missing global variable. * all.tcl: 'getErrorMessage' and 'tooManyMessage' renamed to 'wrongNumArgs' anfd 'tooManyArg'. Also placed the common constraints (checking Tcl version: 8.3 only, 8.3+, 8.4+) in here, and removed their declaration from all test files using them. * README-1.5.txt: Updated logger version info to 0.3. 2004-01-24 Andreas Kupries * sak.tcl: Added a very primitive approval mechanism to suppress output from the package comparison in 'status'. Allows to work through a set of problems with repeated comparison, approving packages when done. * sak.tcl: Extended functionality for release engineering. Better comparison of current state against last release. Alerts for mismatches in version numbers of packages versus changes made to them. * PACKAGES: New file. Always carries the package information from the last release. Basis for the release status work above. 2003-12-01 Andreas Kupries * installed_modules.tcl: Added 'struct1', the v1.x version of the struct module. Kept for backward compatibility. 2003-10-21 Andreas Kupries * sak.tcl: Added -nonewline to a number of puts statements to work around a problem with Tcl 8.4 where additional ^M characters appear for Mac OS X. [Bug 784523]. * README: Updated to describe the new way of adding modules to tcllib. [Bug 784515]. * INSTALL.txt: Updated references to tcllib 1.4 to 1.5. [Bug 784516, incomplete]. * installed_modules.tcl: Changed doc action for snit from _null to _man (We have doctools manpages for snit for a while now). * all.tcl: Added code to try to load 'Tk'. This allows the execution of 'tk' constrained tests, if Tk is present (for example when this code is run run by 'wish'). An example of a module having such tests is 'snit'. 2003-07-26 Pat Thoyts * modules/md5crypt: New module: MD5-crypt implementation * installed_modules.tcl: Added new module. * sak.tcl: Added reference for critcl impl of md5crypt. 2003-07-24 Pat Thoyts * sak.tcl: Added a command for generating a YAML description file. This is much like the TIP55 format but used for FreePAN. * sak.tcl: Altered the finding of critcl under Windows. 2003-07-15 Andreas Kupries * modules/snit: New module, William Duquette's oo package 'snit' (aka Snit Is Not IncrTcl). * tcllib_version.tcl: Upped to 1.5 because of the new modules (snit, inifile). * installed_modules.tcl: Added 'snit' to list of modules. 2003-07-04 Andreas Kupries * installed_modules.tcl: Added the new module 'inifile' to the list of packages handled by 'sak'. 2003-07-04 Miguel Sofer * modules/ftpd.man: * modules/ftpd.tcl (::ftpd::server): the variable ::ftpd::port is now updated to reflect the port were the server was opened. This is only relevant when a server was requested at port 0 - ie, at a port determined by the OS. 2003-05-26 Andreas Kupries * sak.tcl: Updated rpm spec generator using the latest .spec by Jean-Luc as template. The spec now determiens the list of files on its own. Don't have to generate them. 2003-05-23 Andreas Kupries * sak.tcl (gd-gen-rpmspec): Added functions to generate a .spec file (RPM build specification). Added method 'rpmspec' to generate tcllib.spec. 2003-05-20 Andreas Kupries * installed_modules.tcl: Added 'multiplexer' to the list of installed modules. Tested and validqated module. Documentation looks ok for me. 2003-05-13 Pat Thoyts * sak.tcl: added a critcl command to sak to build any critcl tcllib submodules into a tcllibc library (or separate libraries). 2003-05-09 Jeff Hobbs * comm.man: updated comm to v4.1 * comm.tcl: rewrite of code to remove pseudo-object model. Clean up code, add send -command callback to allow for notification of results for asynchronous sends. 2003-05-09 Andreas Kupries * sak.tcl (modules_mod): Fixed incorrect check. Caused first module to be reported as bogus although it isn't. 2003-05-08 Andreas Kupries * installer.tcl: Fixed typo in the code loading the new 'install_action.tcl', had used '...._actions'; note the trailing 's'. Thanks to Larry for reporting this. 2003-05-07 Andreas Kupries * tcllib_version.tcl: Updated to 1.4.0.1 to distinguish the CVS from the official release. * install_action.tcl: * installer.tcl: * sak.tcl: Lots of changes to make a number of command module-ware. In the sense that they now work for individual modules and not only for all in one go. The most important is 'validate'. IOW, it is now possible to validate a single module, making this feature more convenient for a developer, as there is less noise in the output. This required more sharing of code with the installer. 2003-05-05 Andreas Kupries * * Released and tagged Tcllib 1.4 ======================== * 2003-05-02 Pat Thoyts * sak.tcl: Added a contributors command to list the contributors to the library. This is also used when generating the TIP55 description file. Names are extracted from the ChangeLog files. 2003-05-01 Pat Thoyts * modules/base64/base64.test: * modules/base64/uuencode.test: * modules/base64/yencode.test: Various fixes to fix the * modules/control/ChangeLog: testsuite for tcl versions * modules/control/do.test: from 8.2 to 8.5 * modules/csv/csv.test: * modules/dns/dns.test: * modules/fileutil/ChangeLog: * modules/fileutil/fileutil.man: * modules/fileutil/fileutil.tcl: * modules/fileutil/fileutil.test: * modules/math/combinatorics.test: * modules/math/math.test: * modules/mime/mime.test: * modules/ntp/time.test: * modules/pop3/pop3.test: * modules/pop3d/pop3d.test: * modules/pop3d/pop3d_dbox.test: * modules/pop3d/pop3d_udb.test: * modules/profiler/profiler.test: * modules/report/report.test: * modules/stooop/pkgIndex.tcl: * modules/stooop/stooop.test: * modules/struct/list.test: * modules/textutil/ChangeLog: * modules/textutil/expander.tcl: * modules/textutil/split.tcl: 2003-04-24 Andreas Kupries * installer.tcl: * installed_modules.tcl: Changed mechanism for exclusion so that installer is able to install even the excluded (i.e. unofficial) modules, if so chosen (cmdline only). 2003-04-30 Andreas Kupries * sak.tcl (gd-tip55): Bugfix, location of changeLog was not computed correctly. * README-1.4txt: New, overview of changes from 1.3 to 1.4. * installed_modules.tcl: Excluded 'calendar' form the list of installed modules/packages. Not yet ready. * sak.tcl (ppackages): Rewritten to use a sub-interpreter for retrieving package version information instead of regexes etc. Reverted all changes made to [package provide] commands on 2003-04-24, except for minor details, like the actual version numbers and typos. Fixes SF Tcllib FR #727694 2003-04-30 Pat Thoyts * sak.tcl: Various fixes to enable document generation under Windows. Gracefully avoid non-present archivers (tar or zip). Support for generating a TIP55 style metadata file (gentip55). Added a file mtime check to avoid unecessary document generation. 2003-04-24 Andreas Kupries * modules/base64/yencode.tcl: Modified the [package provide]'s * modules/base64/uuencode.tcl: of various packages to aid the * modules/crc/sum.tcl: automatic consistency checking at * modules/crc/cksum.tcl: the expense of slightly more * modules/crc/crc32.tcl: manual overhead for updating the * modules/crc/crc16.tcl: numbers. * modules/dns/dns.tcl: * modules/dns/resolv.tcl: Additionally cleanup of the found * modules/ftp/ftp.tcl: inconsistencies. * modules/ftp/ftp_geturl.tcl: * modules/pop3d/pop3d.tcl: * modules/pop3d/pop3d_udb.tcl: * modules/pop3d/pop3d_dbox.tcl: * modules/pop3d/pop3d_dbox.man: * modules/smtpd/smtpd.tcl: * modules/des/des.tcl: * modules/des/des.man: * modules/ntp/time.tcl: * modules/md4/md4.tcl: * sak.tcl: Changed provide heuristics a bit, more robust against whitespace in various places. 2003-04-24 Andreas Kupries * sak.tcl: New command 'provided' to list packages provided by tcl code. Extended the 'validate' command to compare the lists of provided and indexed packages. Note: A number of packages use variable in provide commands. These will show up as differences. They need higher attention to ensure version consistency. Modified some modules (calendar, exif, control, math) to reduce the number of reported false positives. * sak.tcl: Added 'vcompare' to compare the current list of packages against a list in a file. Marks new and unchanged packages for higher attention. Helper for release engineer. * modules/base64/uuencode.n: Removed old nroff documentation. All * modules/cmdline/cmdline.n: documentation is generated from the * modules/comm/comm.n: doctools manpages (.man). * modules/control/control.n: * modules/counter/counter.n: * modules/crc/cksum.n: * modules/crc/crc32.n: * modules/crc/sum.n: * modules/csv/csv.n: * modules/exif/exif.n: * modules/fileutil/fileutil.n: * modules/ftp/ftp.n: * modules/ftpd/ftpd.n: * modules/html/html.n: * modules/htmlparse/htmlparse.n: * modules/irc/irc.n: * modules/javascript/javascript.n: * modules/log/log.n: * modules/math/combinatorics.n: * modules/math/math.n: * modules/md5/md5.n: * modules/mime/mime.n: * modules/mime/smtp.n: * modules/ncgi/ncgi.n: * modules/nntp/nntp.n: * modules/pop3/pop3.n: * modules/profiler/profiler.n: * modules/report/report.n: * modules/sha1/sha1.n: * modules/smtpd/smtpd.n: * modules/stooop/stooop.n: * modules/struct/graph.n: * modules/struct/matrix.n: * modules/struct/queue.n: * modules/struct/record.n: * modules/struct/stack.n: * modules/struct/tree.n: * modules/textutil/expander.n: * modules/textutil/textutil.n: * modules/uri/uri.n: * Makefile.in (install): Merged the code for the partial install targets into one call for full normal install, and dropped the link between install and the partial install targets. * installed_modules.tcl: Moved the list of installed modules out * installer.tcl: of the installer proper into a separate * sak.tcl: file, so that the other tools have access to it too. Extended the SAK to check this information against the list of modules under development and print out all the discrepancies, i.e: modules which are not installed, or modules installed, but not existing. This is under 'validate'. * sak.tcl: Restricted the list of modules to subdirectories of 'modules' which contain a package index (pkgIndex.tcl). Added the subcommand 'lmodules' listing all modules one per line. The existing subcommand 'modules' in contrast prints everything on a single line. Added the subcommand 'packages' listing the packages in tcllib and their versions, one per line. Added subcommand 'text' to generate documentation as plain text. 2003-04-23 Andreas Kupries * modules/stats: Removed all files in the deprecated module 'stats' now. They there not provided in releases for over a year now. It is time to clean up the CVS too. 2003-04-22 Andreas Kupries * modules/dns/tcllib_dns.man: Cleaned up RFC references, usage * modules/ftp/ftp.man: of such in the keyword sections, * modules/ftpd/ftpd.man: and added links to the master RFC * modules/irc/irc.man: website at http://www.rfc-editor.org. * modules/md4/md4.man: * modules/mime/mime.man: * modules/mime/smtp.man: * modules/nntp/nntp.man: * modules/pop3/pop3.man: * modules/pop3d/pop3d.man: * modules/pop3d/pop3d_dbox.man: * modules/pop3d/pop3d_udb.man: * modules/smtpd/smtpd.man: * modules/struct/graph.man: * modules/uri/uri.man: 2003-04-21 Andreas Kupries * devdoc/indexing.txt: * installer.tcl: Extended [gen_main_index] to include the header of Don's generated package index. This makes the final chosen master index a combination of [i7/ad] and [i4/sd] as the fallback position. * installer.tcl: Made sure that all [file copy] operations use -force. Fix for #719616. 2003-04-19 Andreas Kupries * installer.tcl: Bug fix, the modules calendar, control, and math have a "tclIndex" file which has to be installed too. Also changed usage of 'tcl_pkgPath', as this variable does not exist on windows. 2003-04-17 Andreas Kupries * configure.in: Switched over from the original build system * configure: to one where configure/Makefile are optional * Makefile.in: and delegating all real work to 'sak.tcl'. * INSTALL.txt: Updated documentation, reduced configure macros. * aclocal.m4: * sak.tcl: * devdoc/releaseguide.html: 2003-04-17 Andreas Kupries * installer.tcl: Bug fixes in non-gui mode, added option to force cmdline mode. * sak.tcl: Added command to invoke the testsuite(s). * installer.tcl: Added GUI. * main.tcl: New file, entrypoint for *kit, *pack, redirects to 'installer.tcl'. * sak.tcl: Helper tool for tcllib development (Generate distribution, various forms of documentation, check the bundle of packages for problems. * Makefile.in: Added des to the list of modules. (That is the good thing which came out of the erroneous commit, we found this error.) * mkIndex.tcl: Reverting accidential commit of this file. The committed state works with a changed Makefile, but not with the current one. 2003-04-16 Andreas Kupries * installer.tcl: Added 'des' to list. Reworked according to feedback from Don. * tcllib_version.tcl: Added, for sharing with other scripts. * modules/stats/pkgIndex: Now throwing an error when trying to load 'stats'. * modules/struct/ChangeLog: Typo correction. 2003-04-15 Andreas Kupries * installer.tcl: Added 'md4' to installer.tcl 2003-04-15 Pat Thoyts * modules/md4: New module md4 created: MD4 hash algorithm. 2003-04-15 Andreas Kupries * installer.tcl: EXPERIMENTAL. New installer for tcllib. Currently only cmdline based. Use -help to get help. 2003-04-13 Andreas Kupries * Makefile.in (check-doc-markup): Fixed setting for DOC_FLAGS. The option '-visualwarn' does not exist anymore. Replaced by the option '-deprecated'. Thanks to Larry Virden for reporting the problem. 2003-04-11 Andreas Kupries * install.tcl: Changed to notify the user if the directory to install is not a source distribution but a CVS snapshot. Right now a direct installation of a CVS snapshot is not possible. * Fixed bug #614591 throughout. Numerous modules updated. Also first round of getting version number consistents, and updated for a 1.4 release of the whole. 2003-04-09 Andreas Kupries * New module: devtools. Internal use only for now. Does not contain true packages. 2003-04-01 Andreas Kupries * Makefile.in (MODULES): Added the soundex module. 2003-03-28 Andreas Kupries * README: Updated information about acceptable documentation formats, i.e. added doctools, made it the most prefered format. This fixes the [Bug #685270], reported by Larry Virden . 2003-03-24 Andreas Kupries * README: Updated to refer to the SF website for Tcllib. Thanks to Larry Virden for the report and fix. [Bug #707607]. 2003-03-17 Pat Thoyts * modules/ntp: New module ntp created for time related network protocol stuff. Added RFC868 (TIME) protocol client and example. 2003-03-13 Andreas Kupries * Makefile.in (install-libraries): Extended special code for doctools to install the new idx and toc engines. 2003-02-11 Pat Thoyts * modules/des: Imported and tcllib-ised the DES package from wiki page "DES in Tcl" by Jochen Loewer. NOT added to the main package list as it requires CBC/CFB/OFB modes for real use. 2003-01-18 Andreas Kupries * More doctools changes: Command [strong] is deprecated now. Added the command [copyright]. Went through all manpages to eliminate [strong]. Partial setting of copyright information, where known. 2003-01-13 Andreas Kupries * mkInstallScripts.tcl: * Makefile.in (install-libraries): Added module specific installation code. doctools: Install message catalogs and predefined formatting engines. textutil: Install hyphenation files. * Module doctools rewritten to make it a true package + application, instead of a pure application module. This means that this module now truly installs some functionality useable by other applications and packages. 2003-01-03 Pat Thoyts * smtpd: enhanced error handling for FR #655611 Handle some ESMTP options. 2002-11-24 Gerald Lester * html: Fixed bug #643337 (changes made though 2002-12-2) 2002-11-24 Gerald Lester * html: Fixed bug #596000 2002-10-16 Andreas Kupries * struct (graph): Implemented FR 603924 2002-10-14 Andreas Kupries * pop3: Fixed bug #620062. 2002-10-09 Andreas Kupries * Makefile.in (install-libraries): Added code to skip directories without .tcl files. Some shells do not like a for with nothing to iterate over. 2002-10-08 Pat Thoyts * smtpd: implemented feature request #531531 to use MIME tokens 2002-09-25 Jeff Hobbs * Makefile.in: better DESTDIR/libdir support (steffen) 2002-09-14 Andreas Kupries * mime: New field_decode, extended testsuite. 2002-09-04 Andreas Kupries * all.tcl (tcltest::tooManyMessage): Additional command to create different error messages for 8.3 and 8.4. Used in the testsuite of pop3. 2002-08-30 Andreas Kupries * cmdline: * counter: * dns: * ftpd: * html: * ncgi: * examples/ftp: Cleaned up nits ('info exist' --> 'info exists'). 2002-08-21 Andreas Kupries * examples/ftp: Fixed problem in ftpdemo.tcl. 2002-08-19 Andreas Kupries * nntp: Updated documentation, see Tcllib SF #597102. * Makefile.in (install-doc): Fixed problem noted by Elchonon Edelson. Code to inline man.macros appended to existing files. Multiple execution of 'make install-doc' thus extended the manpages of tcllib with multiples of their original content. Not anymore. 2002-08-16 Andreas Kupries * exif: Applied patch #582828. Partially applied #530970. 2002-08-15 Andreas Kupries * Makefile.in (DOC_EXP): Use the tclsh found during configuration to run mpexpand. This ensures that mpexpand does not pick something from the path on its own, possibly something too old to understand TCLLIBPATH. Problem noted by Elchonon Edelson . * mime: Accepted SF Tcllib FR #595240. This entails the donation of the personal mail filter mbot, as written and used by Marshall T. Rose, as an example of the usage of the mime and smtp packages. * mime (smtp): Followup to patch SF #557520/2 (See 2002-07-25). 2002-08-09 Andreas Kupries * Makefile.in (install-doc): Changed $$(basename) to `basename`. Portability problem. Works for Linux for example, but not everywhere else. See 2002-08-06 for the change which introduced this. 2002-08-08 Andreas Kupries * htmlparse: Fixed SF bug #579853. 2002-08-06 Andreas Kupries * Makefile.in (dist): Fixed SF Bug #567079, reported by Don Porter . No infinite recursion anymore for srcdir == builddir. * ftp: Fixed SF Bug #582668. * comm: Fixed SF Bug #589225. * Makefile.in (install-doc): Restored the code inlining the man.macros file into the generated nroff manpages. Got somehow deleted. Was still in the 'dist' target. Thanks to Reinhard Max for noticing this. * struct (pool): Fixed bug SF #585093. * struct (tree): Fixed bug SF #587533. 2002-07-25 Andreas Kupries * mime: Applied SF patch #585455. * mime (smtp): Applied patch SF #557520/2. 2002-07-08 Andreas Kupries * struct (tree): Fixed SF bug #578460. * doctools: Fixed bug #578465. 2002-07-02 Don Porter * all.tcl: Corrected name of tcltest hook procedure 2002-06-24 Andreas Kupries * csv: Fixed SF bug #565051. * mime: Fixed SF bug #548832. 2002-06-17 Andreas Kupries * Applied patch for bug #567428. Bug reported by Larry Virden , patch by him too. Correction of spelling mistakes in the documentation of various modules + correction of comment placements which interfere with solaris conventions for nroff output. 2002-06-10 Andreas Kupries * Released and tagged tcllib 1.3.0. ======================== 2002-06-07 Andreas Kupries * dns: Fixed SF bug #564670. 2002-06-05 Andreas Kupries * all.tcl: Updated to use a default value for -modules if that option is not present. * install.tcl: New file, alternate installer for unix and windows. Execute with any tclsh and tcllib 1.3 is installed in the parent directory of the tcl script library directory. Courtesy Gerald Lester . * Makefile.in (install-doc): Changed to use the doctools generated nroff and html files instead of the manually written .n files. * configure.in (MINOR_VERSION): Updated to version 1.3 * Makefile.in (doc): Removed tmml-doc from default set of documentation. * Makefile.in (dist, install): New target 'gen-main-index' encapsulates the generation of the package index for tcllib. This target is used by both the direct installation (install) and during the generation of a source distribution (dist). * mkIndex.tcl: Rewritten to make use of 'pkg_mkIndex' to get the list of all packages in tcllib. Added a message which deprecates [package require tcllib] if it is used. 2002-06-03 Andreas Kupries * math (calculus): Fixed SF Tcllib Bug #553773. * ftpd: * html: * htmlparse: * base64: * uuencode: Updated version information. 2002-05-29 Andreas Kupries * mime: Fixed SF Tcllib Bug #561416 2002-05-27 Andreas Kupries * base64: Fixed SF Tcllib Bug #548354. 2002-05-21 Andreas Kupries * doctools: Fixed bug #556509. * fileutil: Fixed bug #556504. 2002-05-15 Andreas Kupries * pop3d: Fixed bug #532216. All parts of pop3d now have a testsuite. 2002-05-14 Andreas Kupries * pop3d: Added testsuites for user database and simple mailbox storage. * fileutil: SF Bug #462015 closed. Proosed change rejected, added new commands to perform the desired operation instead. 2002-05-09 Andreas Kupries * doctools: Fixed bug #534334 (actually more a FR). * examples/csv/csvdiff: Applied patch associated with tcllib SF bug #551133. Bug reported by , patch by . Accepted FR #551127 and added code implementing the feature. 2002-05-08 Andreas Kupries * struct (tree): Accepted FR #552972. * mime: Fixed bugs #539952, #553784. 2002-05-08 Don Porter * all.tcl: Show full stack trace when an error occurs sourcing a test file. 2002-04-24 Andreas Kupries * cmdline: Accepted patch #540313 * examples/ftp/hpupdate.tcl: Accepted patch #548221 by Larry Virden . Fixed bug #548224 (Touch). * base64: Fixed bug #548112. 2002-04-23 Andreas Kupries * doctools: Fixed bug #527025. * smtp (mime): Fixed bug #547336. 2002-04-16 Andreas Kupries * Makefile.in (dist): Ensured that the deprecated module 'stats' is not distributed anymore. Use 'counter' instead. (*-force): Enforced generation of documentation, for developers. 2002-04-10 Andreas Kupries * Makefile.in (MODULES): Added irc module. 2002-04-04 Andreas Kupries * mime: Fixed bug #533025. 2002-04-01 Andreas Kupries * Makefile.in (doc_generate): Added 'touch' command to prevent multiple execution of target. * struct (matrix): Fixed bug #532791. * doctools: Fixed SF Bug #535382. 2002-03-25 Andreas Kupries * doctools: Implemented FR #530059 and FR #527029. * Fixed minor formatting errors in several existing doctools manpages. * struct (matrix): Fixed bug #532783. 2002-03-19 Andreas Kupries * ftpd: Fixed SF Bug #531799. * New module: pop3d. A POP3 server. * Makefile.in: Added pop3d. 2002-03-15 Andreas Kupries * math: Update of calculus. #528434 * report, struct (matrix): Fixed bug #530207. 2002-03-14 Andreas Kupries * textutil (expander): Fixed SF Bug #530056. 2002-03-13 Andreas Kupries * doctools: Fixed bug #528390. 2002-03-09 Andreas Kupries * struct (matrix): Accepted FR #524430 (-nocase). * doctools: FR #527716 accepted. Bug #527025 partially fixed. 2002-03-07 Andreas Kupries * Makefile.in (doc_generate): Added "TCLLIBPATH=$(srcdir)/modules" in front of the mpexpand invocation so that it is forced to use the "expander" package inside of the distribution. This fixes Tcllib Bug #525007 reported by Don Porter . 2002-03-02 Pat Thoyts * New module: dns * Makefile.in: updated for new module 2002-02-27 Andreas Kupries * doctools: Done FR #517599. FR #520269. * mime: Fixed bug #519623. * Makefile.in (install-doc): Changed code determining the files to install to handle missing files better (use 'ls', suppress error messages). 2002-02-18 Andreas Kupries * exif: New module. FR 517066 accepted. 2002-02-14 Andreas Kupries * Makefile.in (statcheck, frink, procheck): Added developer targets to invoke two static code checkers. * Ran frink over the package and corrected several minor problems. 2002-02-12 Andreas Kupries * Makefile.in: Added target for generation of documentation in various formats from .man pages 2002-02-01 Andreas Kupries * mime: Applied patch 511692. 2002-01-21 Andreas Kupries * Makefile.in (dist): Brought archive names and contents more in sync with earlier releases. This comes from work on release 1.2. 2002-01-18 Andreas Kupries * Bumped version to 1.2, new release. Summary of changes here. See the individual Changelogs to see the detailed changes in each module. New modules: calendar, crc, doctools, irc, smtpd, and stooop. calendar: Version is 0.1 crc: Version is 1.0 doctools: Version is 1.0 irc: Version is 0.1 smtpd: Version is 1.0 stooop: Version is 4.3 Changed modules: base64, comm, control, csv, fileutil, ftp, html, math, mime, ncgi, nntp, pop3, struct, textutil, and uri. base64: Version stays @ 2.2, but got new subpackage. comm: Version up to 3.7.1 control: Version up to 0.2 csv: Version up to 0.2 fileutil: Version up to 1.3 ftp: Version up to 2.3 html: Version up to 1.2 math: Version up to 1.2 mime: Version up to 1.3.1 ncgi: Version up to 1.2.1 nntp: Version up to 0.2 pop3: Version up to 1.5.1 struct: Version up to 1.2 textutil: Version up to 0.4 uri: Version up to 1.1 2002-01-18 Andreas Kupries * Makefile.in (dist): Fixed bug #495976. 2002-01-17 Pat Thoyts * crc module: added sum manual page * base64 module: added uuencode manual page 2002-01-17 Andreas Kupries * examples/csv/csvdiff: New example for csv module. FR #485717. * mime: Fixed bug #499242. 2002-01-16 Andreas Kupries * mime: Implemented FR #503336 * ftp: Fixed bug #503471. * nntp: Fixed bug #502250 2002-01-16 Pat Thoyts * base64 module: added uuencode package * crc module: added sum and cksum packages. 2002-01-11 Pat Thoyts * mkInstallScripts.tcl: * Makefile.in: Added crc and smtpd modules to the installation files. 2002-01-11 Kevin Kenny * mkInstallScripts.tcl: Changed the installation process for Windows to avoid the unimplemented [file permissions] in favor of [file attributes]. 2002-01-11 Kevin Kenny * New module: calendar. 2002-01-11 Pat Thoyts * New module: crc. From patch #501339 2002-01-11 Andreas Kupries * Makefile.in (install-doc): Fixed bug #500655. Using the code from the tcl "Makefile.in" as template equivalent code for tcllib was created and added to the file "Makefile.in". The modified makefile now includes the contents of "man.macros" into every installed manpage. * html: Applied patch #484117. 2001-12-14 Andreas Kupries * New module: doctools. FR #492234. 2001-12-13 Andreas Kupries * texturil: Applied patch #492156. 2001-12-11 Andreas Kupries * pop3: Bugfix for item #490151. * textutil: Bugfix for item #476988. 2001-12-10 Andreas Kupries * textutil: Update from William, 'evalcmd' callback. 2001-12-06 Andreas Kupries * fileutil: Bugfix for item #486572. 2001-11-28 Reinhard Max * split.tcl: Speed improvement. 2001-11-23 Andreas Kupries * struct.matrix: Implemented FR #481022. 2001-11-19 Andreas Kupries * irc: Added IRC example to examples section. Patch #481479. * struct/graph: Applied patch #483125 * smtpd: Example consolidation: Moved the smtpd example to 'examples' directory. * ftp: Implemented FR #481161. * ftpd: Added example ftp server used for testing the functionality of FR #481161. 2001-11-17 Pat Thoyts * smtpd: New module. 2001-11-16 Andreas Kupries * csv: Applied patch #482570. * comm: Fixed bug #480227. * ftp, uri: Implemented FR #476804. * ftp: Applied patch #428053. 2001-11-12 Andreas Kupries * irc: New module. Internet protocol handling. Internet Relay Chat (IRC). Author David N. Welton . * examples/nntp: Moved example applications out of the nntp module into the example space. * examples/ftpd: Moved example applications out of the ftpd module into the example space. * examples/ftp: Moved example applications out of the ftp module into the example space. * csv: Implemented FR #481023. * textutil: Added 'expander' code by William H. Duquette . Added option -strictlength to adjust. Code by Dan Kuchler . 2001-11-09 Joe English * comm: Replaced nroff macro trickery in comm.n manpage. 2001-11-07 Andreas Kupries * mime: Fixed bug #479174. * mkInstallScripts.tcl: Added code to install tclIndex files. * Makefile.in (install-libraries, dist): Added commands to copy 'tclIndex' files into installation and distribution. This fixes the remainder of #475846. (dist): Fixed error in generation of tar/zip files too. 2001-11-07 Andreas Kupries * examples/ftp/ftpvalid: New example, using ftp and uri modules. Validation of ftp urls. * fileutil: Accepted Patch #477805. * ftp: Accepted Patch #478478. 2001-11-07 Reinhard Max * control: added implementation for a 'do ... while/until' loop. 2001-11-04 Andreas Kupries * ftp: Fixed bug #476729. 2001-11-01 Andreas Kupries * mime: Fixed bugs #477088, #472009. 2001-10-21 Andreas Kupries * uri: Accepted patch #470211. 2001-10-20 Andreas Kupries * ncgi: Fixed bug #464560. * ftp: Fixed bug #466746. 2001-10-17 Andreas Kupries * ------------------ Tcllib 1.1 released ------------------ * tcllib moved to version 1.1 * cmdline: Version up to 1.1.1 * ftp: Version up to 2.2.1 * html: Version up to 1.1.1 * md5: Version up to 1.4.1 * mime/smtp: Version up to 1.3 * ncgi: Version up to 1.2 * pop3: Version up to 1.5 * report: Version up to 0.2 * sha1: Version up to 1.0.1 * struct: Version up to 1.1.1 * textutil: Version up to 0.3 2001-10-14 Jeff Hobbs * csv.tcl: moved to v0.2 2001-09-24 Joe English * modules/ftpd/ftpd.tcl: fix improperly-formatted multi-line replies. See SF tracker ID #424797 2001-08-24 Andreas Kupries * Makefile.in (check): Added target to report modules without testsuites and/or manpages. 2001-08-22 Andreas Kupries * examples/nntp: Added new example application 'postnews'. This is an example how to use the 'nntp'-client library provided by tcllib. * Makefile.in (MODULES): Added package 'comm'. 2001-08-21 Don Porter * Makefile.in (MODULES): Added package 'control'. 2001-08-20 Andreas Kupries * Makefile.in (mandir, libdir): Applied patch [447141] by Reinhard Max to virtualize mandir and libdir via ${INSTALL_ROOT}. * all.tcl: Added ::tcltest::getErrorMessage in preparation of fixing [440051], [440049] and [440046] reported by Larry Virden . 2001-07-17 Andreas Kupries * Bumped version to 1.0 2001-07-10 Andreas Kupries * Frink 2.2 run, fixed dubious code. 2001-07-06 Andreas Kupries * Fixed #438748, corrections of various misspellings in manpages accross all modules. 2001-06-21 Andreas Kupries * Ran frink and procheck over all modules and fixed the reported problems. As far as they actually were problems. 2001-06-21 Andreas Kupries * Makefile.in (MODULES): Added module 'sha1'. This is another message digest like 'md5'. 2001-05-01 Andreas Kupries * Makefile.in (MODULES): Added module 'report'. * all.tcl: Added code to propagate "::tcltest::testDirectory" into the slave actually doing the tests. This tripped some of the tests for the new CSV module as they use some external files and were thus unable to find them correctly without this setting. * Makefile.in (MODULES): Added module 'csv'. * Added directory 'examples' for future sample applications of tcllib and some example applications too. 2001-04-24 Andreas Kupries * Makefile.in: Added module 'md5'. 2001-03-26 Andreas Kupries * Makefile.in (install-libraries): [Bug #404917] Added 'smtp' explictly to the list of modules for the full package index. It is part of the 'mime' directory and thus not automatically found / part of the list. 2001-03-26 Andreas Kupries * Makefile.in: Added module 'htmlparse'. 2001-03-21 Andreas Kupries * Makefile.in: Added module 'log'. 2001-03-20 Andreas Kupries * all.tcl: [Bug #410100, Patch #410105] Squashed a subtle bug with package management for the tests. Changes: all.tcl now adds the module path to the auto_path (the tested modules did it themselves before) and also moved the setting of the auto_path in the slave before the first 'package require'. Why ? Assume the old code, an installed fileutil 1.0 and a new fileutil 1.1 under development. The initialization of the tests scans the package directories and finds fileutil 1.0. The module then adds itself to the auto_path and then requires fileutil (without version). Now fileutil 1.0 is found by the pkg management, it is acceptable according to the rules of require and thus used. The new version is not considered at all, as changing the auto_path does *not* enforce a rescan of package directories. It is possible to solve the problem by having the modules require themselves and request a specific version (1.1 in this case). But this would mean that in each module we have (at least) one more file containing the version number (all test files!) and we have to maintain this for every module. The change here however solves the problem without touching the modules at all. 2000-11-02 Brent Welch * configure.in: Bumped version number to 0.8 2000-11-01 Dan Kuchler * Makefile.in: Added javascript package to tcllib. 2000-10-27 Dan Kuchler * Makefile.in: Added ftpd package to tcllib. 2000-10-04 Brent Welch * Makefile.in: Nuked stats in favor of counter. 2000-09-19 Brent Welch * Makefile.in: Added the stats module. * configure.in: Increased version number to 0.7 * modules/stats/stats.tcl: * modules/stats/stats.n: * modules/stats/stats.test: * modules/stats/pkgIndex.tcl: Initial version of the stats package. 2000-08-23 Brent Welch * Makefile.in: fixed typo 2000-08-22 Brent Welch * configure.in: Bumped patchlevel to 0.6.1 * Makefile.in: Ignore errors when installing documentation, which only partly exists. You'll still see the error messages but it doesn't stop the install. Applied tcllib-0-6-1 tag 2000-07-19 Brent Welch * configure.in: Bumped patchlevel to 0.6 applied tcllib-0-6 tag 2000-06-15 Dan Kuchler * Makefile.in: Added nntp client package. * modules/nntp: Added nntp client package to tcllib. 2000-06-13 Eric Melski * Makefile.in: Added uri package. * modules/uri: Added uri package from Steve Ball, Andreas Kupries. 2000-06-09 Brent Welch * configure.in: Bumped patchlevel to 0.5 applied tcllib-0-5 tag 2000-06-02 Eric Melski * Makefile.in: Added ftp package. * modules/ftp: Added ftp package from Steffen Traeger to tcllib. 2000-04-28 Sandeep Tamhankar * mkInstallScripts.tcl: Fixed a bug in the UNIX shell script where it was checking if TCLINSTALL was non-null, but it was using ==, which isn't legal in /bin/sh. I found this out the hard way while trying to install tcllib0.4 in the default location (/usr/local/lib/tcllib0.4) and because of this bug, it ended up installing in /lib/tcllib0.4. 2000-04-26 Brent Welch * configure.in: Bumped patchlevel to 0.4 * Makefile.in: Fixed dist target to deal with missing manual pages and test files. * mkInstallScripts.tcl: Made install directory a parameter to the unix install.sh script 2000-04-25 Eric Melski * Makefile.in: Tweaked dist target to include README and license.terms in distributions. 2000-04-17 Brent Welch * modules/html: Added html generation module 2000-04-10 Brent Welch * Makefile.in: restored ncgi module 2000-04-07 Eric Melski * configure: * configure.in: Upped version to 0.3. 2000-03-29 Eric Melski * mkIndex.tcl: Added missing "== -1" to [lsearch] for package dir in generated pkgIndex.tcl. 2000-03-28 Eric Melski * Makefile.in: Added $(srcdir)/ prefix to mkIndex.tcl call in the install-libraries target, so that it would find the mkIndex.tcl script when run outside of the source tree. Same for man.macros in the install-doc target, so it would find the file. 2000-03-27 Eric Melski * Makefile.in: Added dist target for building distribution. * configure.in: Removed mkIndex.tcl from AC_OUTPUT call. * mkInstallScripts.tcl: First cut at script for autogenerating simple INSTALL.BAT and install.sh files for tcllib distributions. * mkIndex.tcl: * mkIndex.tcl.in: Replace mkIndex.tcl.in with mkIndex.tcl, which now takes more args to specify values. 2000-03-09 Eric Melski * Makefile.in: Added ncgi module, commented out until tests are done. 2000-03-09 Eric Melski * Makefile.in: Updated test target to call out to all.tcl. * all.tcl: First checkin of all.tcl, the magic that hides behind "make test". 2000-03-08 Eric Melski * Makefile.in: Commented out cgi module until it's ready for use. Added checks for bogus module names in install-libraries, but they're not foolproof. 2000-03-07 Brent Welch * modules/cgi: Preliminary version of a CGI module. Still needs some cookie functions, test suite, and docs... 2000-03-07 Eric Melski * modules/math: math library * Makefile.in: added math library to list of modules 2000-03-07 Scott Stanton * configure.in: * configure: * aclocal.m4: * Makefile.in: Changed to use shared config subdirectory. Also fixed problem on Windows builds where it would fail to identify the tclsh executable to use. Simplified configure.in to minimum number of macros. 2000-03-06 Eric Melski * man.macros: Moved from individual modules to toplevel tcllib dir, so that it is not repeated hundreds of times. * Makefile.in: * mkIndex.tcl.in: Added version number to installed tcllib dir. * license.terms: Adapted license from Tcl. * README: Added more information about file layout in module dirs. 2000-03-06 Scott Redman * Makefile.in: added pop3 module. 2000-03-02 Eric Melski * mkIndex.tcl.in: Instead of probing install dir for modules, changed to take module list on command line, so that users can change what goes into the pkgIndex.tcl from the Makefile. * Makefile.in: additional work on module list and pkgIndex.tcl generation. Now changing the module list changes what is installed and what is put in the pkgIndex.tcl. 2000-03-02 Eric Melski * Makefile.in: Work on install-libraries, install-doc; removed references to compiled bits. * mkIndex.tcl.in: Tweaked the generated pkgIndex.tcl to only append the dirname if it doesn't already exist in the auto_path, and to use \[file dirname \[info script\]\] instead of [pwd]. * configure: * configure.in: Removed checks for compiler, and all stuff related to compiling/linking (this is a tcl only extension). * tcl.m4: new tcl.m4 from sample extension. 2000-03-01 Eric Melski * Makefile.in: Added fileutil, cmdline, mime, base64 modules. 2000-02-24 Eric Melski * Makefile.in, et al: Preliminary Makefile and configure script, and supporting files tcllib-1.15/Makefile.in0000644000175000017500000000725312077663115014313 0ustar sergeisergei# Makefile.in -- # # This file is a Makefile for the tcllib 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.101 2007/08/21 22:04:14 andreas_kupries Exp $ #======================================================================== # Nothing of the variables below this line need to be changed. Please # check the TARGETS section below to make sure the make targets are # correct. #======================================================================== SHELL = @SHELL@ srcdir = @srcdir@ top_srcdir = @top_srcdir@ prefix = @prefix@ exec_prefix = @exec_prefix@ libdir = @libdir@ mandir = @mandir@ bindir = @bindir@ DESTDIR = pkglibdir = $(libdir)/@PACKAGE@@VERSION@ top_builddir = . PACKAGE = @PACKAGE@ VERSION = @VERSION@ CYGPATH = @CYGPATH@ TCLSH_PROG = @TCLSH_PROG@ CONFIG_CLEAN_FILES = #======================================================================== # Start of user-definable TARGETS section #======================================================================== all: doc: html-doc nroff-doc install: $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/installer.tcl` \ -no-examples -no-html \ -pkg-path $(DESTDIR)$(pkglibdir) \ -app-path $(DESTDIR)$(bindir) \ -nroff-path $(DESTDIR)$(mandir)/mann \ -no-wait -no-gui install-libraries: $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/installer.tcl` \ -pkg-path $(DESTDIR)$(pkglibdir) \ -no-examples -no-html -no-nroff \ -no-wait -no-gui -no-apps install-applications: $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/installer.tcl` \ -app-path $(DESTDIR)$(bindir) \ -no-examples -no-html -no-nroff \ -no-wait -no-gui -no-pkgs install-doc: $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/installer.tcl` \ -nroff-path $(DESTDIR)$(mandir)/mann \ -no-examples -no-pkgs -no-html \ -no-wait -no-gui -no-apps test: if test -t 1 ; \ then $(MAKE) test_interactive ; \ else $(MAKE) test_batch ; \ fi test_batch: $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` test run -v -s "$(TCLSH_PROG)" test_interactive: $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` test run -s "$(TCLSH_PROG)" depend: dist: $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` gendist critcl: $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` critcl 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 Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status cd $(top_builddir) \ && CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status uninstall-binaries: html-doc: $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` doc html nroff-doc: $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` doc nroff tmml-doc: $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` doc tmml wiki-doc: $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` doc wiki latex-doc: $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` doc ps list-doc: $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` doc list check: $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` validate sak-help: $(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` help .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. .NOEXPORT: tcllib-1.15/README0000644000175000017500000000724212077663115013124 0ustar sergeisergeiRCS: @(#) $Id: README,v 1.9 2007/08/30 17:24:13 andreas_kupries Exp $ Welcome to the Tcllib, the Tcl 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 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. The structure of the tcllib source hierarchy is: tcllib +- modules +- +- +- ... The install hierarchy is: .../lib/tcllib +- +- +- ... There are some base requirements that a module must meet before it will be added to tcllib: * 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 module must reside in a subdirectory of the modules directory in 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 tcllib source directory in the file license.terms * 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 preferred as it can be processed with tools provided by tcllib itself (See module doctools). The first two are preferred 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 tcllib, be sure to add it to the files listed below. * installed_modules.tcl 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. 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: * source code *.tcl * package index pkgIndex.tcl * tests *.test * documentation *.man, *.n, *.xml If you do not follow this directory structure, the tcllib Makefile will fail to locate the files from the new module. tcllib-1.15/modules/0000755000175000017500000000000012104363635013702 5ustar sergeisergeitcllib-1.15/modules/ftpd/0000755000175000017500000000000012104524717014637 5ustar sergeisergeitcllib-1.15/modules/ftpd/ftpd.man0000644000175000017500000002351712077663116016307 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin ftpd n 1.2.6] [moddesc {Tcl FTP Server Package}] [titledesc {Tcl FTP server implementation}] [category Networking] [require Tcl 8.3] [require ftpd [opt 1.2.6]] [description] The [package ftpd] package provides a simple Tcl-only server library for the FTP protocol as specified in RFC 959 ([uri http://www.rfc-editor.org/rfc/rfc959.txt]). It works by listening on the standard FTP socket. Most server errors are returned as error messages with the appropriate code attached to them. Since the server code for the ftp daemon is executed in the event loop, it is possible that a [cmd bgerror] will be thrown on the server if there are problems with the code in the module. [section COMMANDS] [list_begin definitions] [call [cmd ::ftpd::server] [opt [arg myaddr]]] Open a listening socket to listen to and accept ftp connections. myaddr is an optional argument. [arg myaddr] is the domain-style name or numerical IP address of the client-side network interface to use for the connection. [call [cmd ::ftpd::config] [opt [arg {option value}]] [opt [arg {option value ...}]]] The value is always the name of the command to call as the callback. The option specifies which callback should be configured. See section [sectref CALLBACKS] for descriptions of the arguments and return values for each of the callbacks. [list_begin definitions] [def "-authIpCmd [arg proc]"] Callback to authenticate new connections based on the ip-address of the peer. [def "-authUsrCmd [arg proc]"] Callback to authenticate new connections based on the user logging in (and the users password). [def "-authFileCmd [arg proc]"] Callback to accept or deny a users access to read and write to a specific path or file. [def "-logCmd [arg proc]"] Callback for log information generated by the FTP engine. [def "-fsCmd [arg proc]"] Callback to connect the engine to the filesystem it operates on. [def "-closeCmd [arg proc]"] Callback to be called when a connection is closed. This allows the embedding application to perform its own cleanup operations. [def "-xferDoneCmd [arg proc]"] Callback for transfer completion notification. In other words, it is called whenever a transfer of data to or from the client has completed. [list_end] [list_end] [section CALLBACKS] [list_begin definitions] [def "[cmd authIpCmd] callback"] The authIpCmd receives the ip-address of the peer attempting to connect to the ftp server as its argument. It returns a 1 to allow users from the specified IP to attempt to login and a 0 to reject the login attempt from the specified IP. [def "[cmd authUsrCmd] callback"] The authUsrCmd receives the username and password as its two arguments. It returns a 1 to accept the attempted login to the ftpd and a 0 to reject the attempted login. [def "[cmd authFileCmd] callback"] The authFileCmd receives the user (that is currently logged in), the path or filename that is about to be read or written, and [const read] or [const write] as its three arguments. It returns a 1 to allow the path or filename to be read or written, and a 0 to reject the attempted read or write with a permissions error code. [def "[cmd logCmd] callback"] The logCmd receives a severity and a message as its two arguments. The severities used within the ftpd package are [const note], [const debug], and [const error]. The logCmd doesn't return anything. [def "[cmd fsCmd] callback"] The fsCmd receives a subcommand, a filename or path, and optional additional arguments (depending on the subcommand). [para] The subcommands supported by the fsCmd are: [list_begin definitions] [call [arg fsCmd] [method append] [arg path]] The append subcommand receives the filename to append to as its argument. It returns a writable tcl channel as its return value. [call [arg fsCmd] [method delete] [arg path] [arg channel]] The delete subcommand receives the filename to delete, and a channel to write to as its two arguments. The file specified is deleted and the appropriate ftp message is written to the channel that is passed as the second argument. The delete subcommand returns nothing. [call [arg fsCmd] [method dlist] [arg path] [arg style] [arg channel]] The dlist subcommand receives the path that it should list the files that are in, the style in which the files should be listed which is either [const nlst] or [const list], and a channel to write to as its three arguments. The files in the specified path are printed to the specified channel one per line. If the style is [const nlst] only the name of the file is printed to the channel. If the style is [const list] then the file permissions, number of links to the file, the name of the user that owns the file, the name of the group that owns the file, the size (in bytes) of the file, the modify time of the file, and the filename are printed out to the channel in a formatted space separated format. The [method dlist] subcommand returns nothing. [call [arg fsCmd] [method exists] [arg path]] The exists subcommand receives the name of a file to check the existence of as its only argument. The exists subcommand returns a 1 if the path specified exists and the path is not a directory. [call [arg fsCmd] [method mkdir] [arg path] [arg channel]] The mkdir subcommand receives the path of a directory to create and a channel to write to as its two arguments. The mkdir subcommand creates the specified directory if necessary and possible. The mkdir subcommand then prints the appropriate success or failure message to the channel. The mkdir subcommand returns nothing. [call [arg fsCmd] [method mtime] [arg path] [arg channel]] The mtime subcommand receives the path of a file to check the modify time on and a channel as its two arguments. If the file exists the mtime is printed to the channel in the proper FTP format, otherwise an appropriate error message and code are printed to the channel. The mtime subcommand returns nothing. [call [arg fsCmd] [method permissions] [arg path]] The permissions subcommand receives the path of a file to retrieve the permissions of. The permissions subcommand returns the octal file permissions of the specified file. The file is expected to exist. [call [arg fsCmd] [method rename] [arg path] [arg newpath] [arg channel]] The rename subcommand receives the path of the current file, the new file path, and a channel to write to as its three arguments. The rename subcommand renames the current file to the new file path if the path to the new file exists, and then prints out the appropriate message to the channel. If the new file path doesn't exist the appropriate error message is printed to the channel. The rename subcommand returns nothing. [call [arg fsCmd] [method retr] [arg path]] The retr subcommand receives the path of a file to read as its only argument. The retr subcommand returns a readable channel that the specified file can be read from. [call [arg fsCmd] [method rmdir] [arg path] [arg channel]] The rmdir subcommand receives the path of a directory to remove and a channel to write to as its two arguments. The rmdir subcommand removes the specified directory (if possible) and prints the appropriate message to the channel (which may be an error if the specified directory does not exist or is not empty). The rmdir subcommand returns nothing. [call [arg fsCmd] [method size] [arg path] [arg channel]] The size subcommand receives the path of a file to get the size (in bytes) of and a channel to write to as its two arguments. The size subcommand prints the appropriate code and the size of the file if the specified path is a file, otherwise an appropriate error code and message are printed to the channel. The size subcommand returns nothing. [call [arg fsCmd] [method store] [arg path]] The store subcommand receives the path of a file to write as its only argument. The store subcommand returns a writable channel. [list_end] [def "[cmd closeCmd]"] The [cmd closeCmd] receives no arguments when it is invoked, and any return value it may generate is discarded. [def "[cmd xferDoneCmd] sock sock2 file bytes filename err"] The [cmd xferDoneCmd] receives six arguments when invoked. These are, in this order, the channel handle of the control socket for the connection, the channel handle of the data socket used for the transfer (already closed), the handle of the channel containing the transfered file, the number of bytes transfered, the path of the file which was transfered, and a (possibly empty) error message. Any return value it may generate is discarded. [list_end] [section VARIABLES] [list_begin definitions] [def [var ::ftpd::cwd]] The current working directory for a session when someone first connects to the FTPD or when the [cmd REIN] ftp command is received. [def [var ::ftpd::contact]] The e-mail address of the person that is the contact for the ftp server. This address is printed out as part of the response to the [cmd {FTP HELP}] command. [def [var ::ftpd::port]] The port that the ftp server should listen on. If port is specified as zero, the operating system will allocate an unused port for use as a server socket; afterwards, the variable will contain the port number that was allocated. [def [var ::ftpd::welcome]] The message that is printed out when the user first connects to the ftp server. [def [var ::ftpd::CurrentSocket]] Accessible to all callbacks and all filesystem commands (which are a special form of callback) and contains the handle of the socket channel which was active when the callback was invoked. [list_end] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph ftpd] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords ftpd ftp ftpserver services {rfc 959}] [manpage_end] tcllib-1.15/modules/ftpd/ChangeLog0000644000175000017500000001702112104363437016412 0ustar sergeisergei2013-02-01 Andreas Kupries * * Released and tagged Tcllib 1.15 ======================== * 2011-12-13 Andreas Kupries * * Released and tagged Tcllib 1.14 ======================== * 2011-08-09 Andreas Kupries * ftpd.man: Bumped version to 1.2.6. * ftpd.tcl: * pkgIndex.tcl: * ftpd.tcl (::ftpd::command::CWD): [Bug 3312900]: Accepted patch by Roy Keene, adding basic checks to the CWD command. * ftpd.tcl (::ftpd::command::RNTO, ::ftpd::command::RNFR): [Bug 3312880, 3325229]: Fixed issues with the rename command found by Roy Keene. * ftpd.tcl: [Bug 3357765]: Accepted patch by Roy Keene fixing issues with the handling of passive connections by the server, with modifications (Moved the replicated checking code into a procedure shared by the modified commands). 2011-01-24 Andreas Kupries * * Released and tagged Tcllib 1.13 ======================== * 2010-01-20 Andreas Kupries * ftpd.tcl (::ftpd::command::RNTO): [Bug 2928355]: Fixed the missing import of the server's state array, reported by Martin . * ftpd.tcl (::ftpd::config): [Bug 2935339] [Patch 2935347]: * ftpd.man: Applied the patch by Keith Vetter * pkgIndex.tcl: , fixing the non-idempotency of the config command. Bumped the package version to 1.2.5. 2009-12-07 Andreas Kupries * * Released and tagged Tcllib 1.12 ======================== * 2008-12-12 Andreas Kupries * * Released and tagged Tcllib 1.11.1 ======================== * 2008-10-16 Andreas Kupries * * Released and tagged Tcllib 1.11 ======================== * 2008-02-29 Andreas Kupries * ftpd.tcl: Renamed ::ftpd::read -> ftp::Read to prevent clash * ftpd.man: with Tcl's builtin command. Version bumped to 1.2.4. * pkgIndex.tcl: 2007-09-12 Andreas Kupries * * Released and tagged Tcllib 1.10 ======================== * 2007-08-20 Andreas Kupries * ftpd.tcl: Fix for [SF Tcllib Bug 1720144]. Version * ftpd.man: of the package bumped to 1.2.3. * pkgIndex.tcl: 2007-03-21 Andreas Kupries * ftpd.man: Fixed all warnings due to use of now deprecated commands. Added a section about how to give feedback. 2006-10-03 Andreas Kupries * * Released and tagged Tcllib 1.9 ======================== * 2005-10-06 Andreas Kupries * * Released and tagged Tcllib 1.8 ======================== * 2004-10-05 Andreas Kupries * * Released and tagged Tcllib 1.7 ======================== * 2004-10-05 Andreas Kupries * ftpd.tcl: Fixed [Tcllib SF Bug 1006157] reported by Stephen Huntley . Using fake user/group information when on Windows. 2004-05-23 Andreas Kupries * ftpd.tcl: Updated version number to sync with 1.6.1 * ftpd.man: release. * pkgIndex.tcl: 2004-05-23 Andreas Kupries * * Released and tagged Tcllib 1.6.1 ======================== * 2004-05-23 Andreas Kupries * ftpd.tcl: Rel. engineering. Updated version number * ftpd.man: of ftpd to reflect its changes, to 1.2.1. * pkgIndex.tcl: 2004-05-23 Andreas Kupries * Bugfixes by Gerald Lester. No details available. Gerald is asked to replace this entry with one describing his changes. 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * 2004-02-10 Andreas Kupries * ftpd.man: Updated documentation to explain the new features (Two additional callbacks, and the variable 'CurrentSocket'). * ftpd.tcl (Finish): Replaced string compare with canonical 'hasCallback'. (GetDone): Ditto for 'xferDoneCmd'. (command::REIN): Closing passive data server port, reinitializing to empty as well. (read): Reverted call of Finish to relative addressing of the command. 2004-02-08 Andreas Kupries * pkgIndex.tcl * ftpd.tcl: Imported changes made by "Gerald W. Lester" . Bugfixes, more callbacks (close, transfer done), and implementation of passive mode data connection. Version up to 1.2. 2003-07-04 Andreas Kupries * ftpd.tcl (Fs): Fixed SF tcllib bug [766112]. Copied code from style 'nslt' to exclude . and .. from the list. 2003-05-05 Andreas Kupries * * Released and tagged Tcllib 1.4 ======================== * 2003-04-11 Andreas Kupries * ftpd.tcl: * ftpd.man: * pkgIndex.tcl: Fixed bug #614591. Set version of the package to to 1.1.3. 2003-01-16 Andreas Kupries * ftpd.man: More semantic markup, less visual one. 2002-08-30 Andreas Kupries * ftpd.tcl: Updated 'info exist' to 'info exists'. 2002-06-03 Andreas Kupries * pkgIndex.tcl: * ftpd.tcl: * ftpd.n: * ftpd.man: Bumped to version 1.1.2. 2002-03-20 Andreas Kupries * ftpd.man: New, doctools manpage. 2002-03-19 Andreas Kupries * pkgIndex.tcl: * ftpd.n: Changed to require tcl version 8.3. Code uses -unique option of [lsort], introduced in that version. This fixes SF bug #531799. 2001-09-07 Andreas Kupries * ftpd.tcl: Applied patch [459197] from Hemang to fix more 'namespace export *'. Patch modified before application as some export command are actually private (Implementations of the ftp commands). 2001-09-05 Andreas Kupries * ftpd.tcl: Restricted export list to public API. [456255]. Patch by Hemang Lavana 2001-06-21 Andreas Kupries * ftpd.tcl: Fixed dubious code reported by frink. 2000-11-22 Eric Melski * Integrated patch from Mark O'Conner. Patch fixed file translation mode bug (ie, binary vs. ascii) that prevented proper retrieval of binary files. [SFBUG: 122664] 2000-11-01 Dan Kuchler * Integrated patch from Keith Vetter Patch fixed several bugs. Allowed users to log in as both 'anonymous' and 'ftp' by default instead of just anonymous. Fixed syntax error with the 'socket -server' line in ftpd::server when 'myaddr' is specified. Fixed the argument specifications for cmdline:getoptions in ftpd::config so that arguments are required for the -logCmd and the -fsCmd. 2000-10-30 Dan Kuchler * Made some fixes to better support windows. 2000-10-27 Dan Kuchler * Initial revision of tcllib ftpd. Based off of the ftpd in the stdtcl distribution. tcllib-1.15/modules/ftpd/pkgIndex.tcl0000644000175000017500000000020212077663116017114 0ustar sergeisergeiif {![package vsatisfies [package provide Tcl] 8.3]} {return} package ifneeded ftpd 1.2.6 [list source [file join $dir ftpd.tcl]] tcllib-1.15/modules/ftpd/ftpd.tcl0000644000175000017500000016513612077663116016322 0ustar sergeisergei# ftpd.tcl -- # # This file contains Tcl/Tk package to create a ftp daemon. # I believe it was originally written by Matt Newman (matt@sensus.org). # Modified by Dan Kuchler (kuchler@ajubasolutions.com) to handle # more ftp commands and to fix some bugs in the original implementation # that was found in the stdtcl module. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: ftpd.tcl,v 1.34 2011/08/09 20:55:38 andreas_kupries Exp $ # # Define the ftpd package version 1.2.5 package require Tcl 8.2 namespace eval ::ftpd { # The listening port. variable port 21 variable contact if {![info exists contact]} { global tcl_platform set contact "$tcl_platform(user)@[info hostname]" } variable cwd if {![info exists cwd]} { set cwd "" } variable welcome if {![info exists welcome]} { set welcome "[info hostname] FTP server ready." } # Global configuration. variable cfg if {![info exists cfg]} { array set cfg [list \ closeCmd {} \ authIpCmd {} \ authUsrCmd {::ftpd::anonAuth} \ authFileCmd {::ftpd::fileAuth} \ logCmd {::ftpd::logStderr} \ fsCmd {::ftpd::fsFile::fs} \ xferDoneCmd {}] } variable commands if {![info exists commands]} { array set commands [list \ ABOR {ABOR (abort operation)} \ ACCT {(specify account); unimplemented.} \ ALLO {(allocate storage - vacuously); unimplemented.} \ APPE {APPE file-name} \ CDUP {CDUP (change to parent directory)} \ CWD {CWD [ directory-name ]} \ DELE {DELE file-name} \ HELP {HELP [ ]} \ LIST {LIST [ path-name ]} \ NLST {NLST [ path-name ]} \ MAIL {(mail to user); unimplemented.} \ MDTM {MDTM path-name} \ MKD {MKD path-name} \ MLFL {(mail file); unimplemented.} \ MODE {(specify transfer mode); unimplemented.} \ MRCP {(mail recipient); unimplemented.} \ MRSQ {(mail recipient scheme question); unimplemented.} \ MSAM {(mail send to terminal and mailbox); unimplemented.} \ MSND {(mail send to terminal); unimplemented.} \ MSOM {(mail send to terminal or mailbox); unimplemented.} \ NOOP {NOOP} \ PASS {PASS password} \ PASV {(set server in passive mode); unimplemented.} \ PORT {PORT b0, b1, b2, b3, b4, b5} \ PWD {PWD (return current directory)} \ QUIT {QUIT (terminate service)} \ REIN {REIN (reinitialize server state)} \ REST {(restart command); unimplemented.} \ RETR {RETR file-name} \ RMD {RMD path-name} \ RNFR {RNFR file-name} \ RNTO {RNTO file-name} \ SIZE {SIZE path-name} \ SMNT {(structure mount); unimplemented.} \ STOR {STOR file-name} \ STOU {STOU file-name} \ STRU {(specify file structure); unimplemented.} \ SYST {SYST (get type of operating system)} \ TYPE {TYPE [ A | E | I | L ]} \ USER {USER username} \ XCUP {XCUP (change to parent directory)} \ XCWD {XCWD [ directory-name ]} \ XMKD {XMKD path-name} \ XPWD {XPWD (return current directory)} \ XRMD {XRMD path-name}] } variable passwords [list ] # Exported procedures namespace export config hasCallback logStderr namespace export fileAuth anonAuth unixAuth server accept read } # ::ftpd::config -- # # Configure the configurable parameters of the ftp daemon. # # Arguments: # options - -authIpCmd proc procedure that accepts or rejects an # incoming connection. A value of 0 or # an error causes the connection to be # rejected. There is no default. # -authUsrCmd proc procedure that accepts or rejects a # login. Defaults to ::ftpd::anonAuth # -authFileCmd proc procedure that accepts or rejects # access to read or write a certain # file or path. Defaults to # ::ftpd::userAuth # -logCmd proc procedure that logs information from # the ftp engine. Default is # ::ftpd::logStderr # -fsCmd proc procedure to connect the ftp engine # to the file system it operates on. # Default is ::ftpd::fsFile::fs # # Results: # None. # # Side Effects: # Changes the value of the specified configurables. proc ::ftpd::config {args} { # Processing of global configuration changes. package require cmdline variable cfg # Make default value be the current value so we can call this # command multiple times without resetting already set values array set cfg [cmdline::getoptions args [list \ [list closeCmd.arg $cfg(closeCmd) {Callback when a connection is closed.}] \ [list authIpCmd.arg $cfg(authIpCmd) {Callback to authenticate new connections based on the ip-address of the peer. Optional}] \ [list authUsrCmd.arg $cfg(authUsrCmd) {Callback to authenticate new connections based on the user logging in.}] \ [list authFileCmd.arg $cfg(authFileCmd) {Callback to accept or deny a users access to read and write to a specific path or file.}] \ [list logCmd.arg $cfg(logCmd) {Callback for log information generated by the FTP engine.}] \ [list xferDoneCmd.arg $cfg(xferDoneCmd) {Callback for transfer completion notification. Optional}] \ [list fsCmd.arg $cfg(fsCmd) {Callback to connect the engine to the filesystem it operates on.}]]] return } # ::ftpd::hasCallback -- # # Determines whether or not a non-NULL callback has been defined for one # of the callback types. # # Arguments: # callbackType - One of authIpCmd, authUsrCmd, logCmd, or fsCmd # # Results: # Returns 1 if a non-NULL callback has been specified for the # callbackType that is passed in. # # Side Effects: # None. proc ::ftpd::hasCallback {callbackType} { variable cfg return [expr {[info exists cfg($callbackType)] && [string length $cfg($callbackType)]}] } # ::ftpd::logStderr -- # # Outputs a message with the specified severity to stderr. The default # logCmd callback. # # Arguments: # severity - The severity of the error. One of debug, error, # or note. # text - The error message. # # Results: # None. # # Side Effects: # A message is written to the stderr channel. proc ::ftpd::logStderr {severity text} { # Standard log handler. Prints to stderr. puts stderr "\[$severity\] $text" return } # ::ftpd::Log -- # # Used for all ftpd logging. # # Arguments: # severity - The severity of the error. One of debug, error, # or note. # text - The error message. # # Results: # None. # # Side Effects: # The ftpd logCmd callback is called with the specified severity and # text if there is a non-NULL ftpCmd. proc ::ftpd::Log {severity text} { # Central call out to log handlers. variable cfg if {[hasCallback logCmd]} { set cmd $cfg(logCmd) lappend cmd $severity $text eval $cmd } return } # ::ftpd::fileAuth -- # # Given a username, path, and operation- decides whether or not to accept # the attempted read or write operation. # # Arguments: # user - The name of the user that is attempting to # connect to the ftpd. # path - The path or filename that the user is attempting # to read or write. # operation - read or write. # # Results: # Returns 0 if it rejects access and 1 if it accepts access. # # Side Effects: # None. proc ::ftpd::fileAuth {user path operation} { # Standard authentication handler if {(![Fs exists $path]) && ([string equal $operation "write"])} { if {[Fs exists [file dirname $path]]} { set path [file dirname $path] } } elseif {(![Fs exists $path]) && ([string equal $operation "read"])} { return 0 } if {[Fs exists $path]} { set mode [Fs permissions $path] if {([string equal $operation "read"] && (($mode & 00004) > 0)) || \ ([string equal $operation "write"] && (($mode & 00002) > 0))} { return 1 } } return 0 } # ::ftpd::anonAuth -- # # Given a username and password, decides whether or not to accept the # attempted login. This is the default ftpd authUsrCmd callback. By # default it accepts the annonymous user and does some basic checking # checking on the form of the password to see if it has the form of an # email address. # # Arguments: # user - The name of the user that is attempting to # connect to the ftpd. # pass - The password of the user that is attempting to # connect to the ftpd. # # Results: # Returns 0 if it rejects the login and 1 if it accepts the login. # # Side Effects: # None. proc ::ftpd::anonAuth {user pass} { # Standard authentication handler # # Accept user 'anonymous' if a password was # provided which is at least similar to an # fully qualified email address. if {(![string equal $user anonymous]) && (![string equal $user ftp])} { return 0 } set pass [split $pass @] if {[llength $pass] != 2} { return 0 } set domain [split [lindex $pass 1] .] if {[llength $domain] < 2} { return 0 } return 1 } # ::ftpd::unixAuth -- # # Given a username and password, decides whether or not to accept the # attempted login. This is an alternative to the default ftpd # authUsrCmd callback. By default it accepts the annonymous user and does # some basic checking checking on the form of the password to see if it # has the form of an email address. # # Arguments: # user - The name of the user that is attempting to # connect to the ftpd. # pass - The password of the user that is attempting to # connect to the ftpd. # # Results: # Returns 0 if it rejects the login and 1 if it accepts the login. # # Side Effects: # None. proc ::ftpd::unixAuth {user pass} { variable passwords array set password $passwords # Standard authentication handler # # Accept user 'anonymous' if a password was # provided which is at least similar to an # fully qualified email address. if {([llength $passwords] == 0) && (![catch {package require crypt}])} { foreach file [list /etc/passwd /etc/shadow] { if {([file exists $file]) && ([file readable $file])} { set fh [open $file r] set data [read $fh [file size $file]] foreach line [split $data \n] { foreach {username passwd uid gid dir sh} [split $line :] { if {[string length $passwd] > 2} { set password($username) $passwd } elseif {$passwd == ""} { set password($username) "" } break } } } } set passwords [array get password] } ::ftpd::Log debug $passwords if {[string equal $user anonymous] || [string equal $user ftp]} { set pass [split $pass @] if {[llength $pass] != 2} { return 0 } set domain [split [lindex $pass 1] .] if {[llength $domain] < 2} { return 0 } return 1 } if {[info exists password($user)]} { if {$password($user) == ""} { return 1 } if {[string equal $password($user) [::crypt $pass $password($user)]]} { return 1 } } return 0 } # ::ftpd::server -- # # Creates a server socket at the specified port. # # Arguments: # myaddr - The domain-style name or numerical IP address of # the client-side network interface to use for the # connection. The name of the user that is # attempting to connect to the ftpd. # # Results: # None. # # Side Effects: # A listener is setup on the specified port which will call # ::ftpd::accept when it is connected to. proc ::ftpd::server {{myaddr {}}} { variable port if {[string length $myaddr]} { set f [socket -server ::ftpd::accept -myaddr $myaddr $port] } else { set f [socket -server ::ftpd::accept $port] } set port [lindex [fconfigure $f -sockname] 2] return } # ::ftpd::accept -- # # Checks if the connecting IP is authorized to connect or not. If not # the socket is closed and failure is logged. Otherwise, a welcome is # printed out, and a ftpd::Read filevent is placed on the socket. # # Arguments: # sock - The channel for this connection to the ftpd. # ipaddr - The client's IP address. # client_port - The client's port number. # # Results: # None. # # Side Effects: # Sets up a ftpd::Read fileevent to trigger whenever the channel is # readable. Logs an error and closes the connection if the IP is # not authorized to connect. proc ::ftpd::accept {sock ipaddr client_port} { upvar #0 ::ftpd::$sock data variable welcome variable cfg variable cwd variable CurrentSocket set CurrentSocket $sock if {[info exists data]} { unset data } if {[hasCallback authIpCmd]} { # Call out to authenticate the peer. A return value of 0 or an # error causes the system to reject the connection. Everything # else (with 1 prefered) leads to acceptance. set cmd $cfg(authIpCmd) lappend cmd $ipaddr set fail [catch {eval $cmd} res] if {$fail} { Log error "AuthIp error: $res" } if {$fail || ($res == 0)} { Log note "AuthIp: Access denied to $ipaddr" # Now: Close the connection. (Is there a standard response # before closing down to signal the peer that we don't want # to talk to it ? -> read RFC). close $sock return } # Accept the connection (for now, 'authUsrCmd' may revoke this # decision). } array set data [list \ access 0 \ ip $ipaddr \ state command \ buffering line \ cwd "$cwd" \ mode binary \ sock2a "" \ sock2 ""] fconfigure $sock -buffering line fileevent $sock readable [list ::ftpd::Read $sock] puts $sock "220 $welcome" Log debug "Accept $ipaddr" return } # ::ftpd::Read -- # # Checks the state of a channel and then reads a command from the # channel if it is not at end of file yet. If there is a command named # ftpd::command::* where '*' is the all upper case name of the command, # then that proc is called to handle the command with the remaining parts # of the command that was read from the channel as arguments. # # Arguments: # sock - The channel for this connection to the ftpd. # # Results: # None. # # Side Effects: # Runs the appropriate command depending on the state in the state # machine, and the command that is specified. proc ::ftpd::Read {sock} { upvar #0 ::ftpd::$sock data variable CurrentSocket set CurrentSocket $sock if {[eof $sock]} { Finish $sock return } switch -exact -- $data(state) { command { gets $sock command set argument "" if {![regexp {^([^ ]+) (.*)$} $command -> cmd argument]} { if {![regexp {^([^ ]+)$} $command -> cmd]} { # Very bad command syntax. puts $sock "500 Command not understood." return } } set cmd [string toupper $cmd] auto_load ::ftpd::command::$cmd if {($data(access) == 0) && ((![info exists data(user)]) || \ ($data(user) == "")) && (![string equal $cmd "USER"])} { if {[string equal $cmd "PASS"]} { puts $sock "503 Login with USER first." } else { puts $sock "530 Please login with USER and PASS." } } elseif {($data(access) == 0) && (![string equal $cmd "PASS"]) \ && (![string equal $cmd "USER"]) \ && (![string equal $cmd "QUIT"])} { puts $sock "530 Please login with USER and PASS." } elseif {[info command ::ftpd::command::$cmd] != ""} { Log debug $command ::ftpd::command::$cmd $sock $argument catch {flush $sock} } else { Log error "Unknown command: $cmd" puts $sock "500 Unknown command $cmd" } } default { error "Unknown state \"$data(state)\"" } } return } # ::ftpd::Finish -- # # Closes the socket connection between the ftpd and client. # # Arguments: # sock - The channel for this connection to the ftpd. # # Results: # None. # # Side Effects: # The channel is closed. proc ::ftpd::Finish {sock} { upvar #0 ::ftpd::$sock data variable cfg if {[hasCallback closeCmd]} then { ## ## User specified a close command so invoke it ## uplevel #0 $cfg(closeCmd) } close $sock if {[info exists data]} { unset data } return } # ::ftpd::FinishData -- # # Closes the data socket connection that is created when the 'PORT' # command is recieved. # # Arguments: # sock - The channel for this connection to the ftpd. # # Results: # None. # # Side Effects: # The data channel is closed. proc ::ftpd::FinishData {sock} { upvar #0 ::ftpd::$sock data catch {close $data(sock2)} set data(sock2) {} return } # ::ftpd::Fs -- # # The general filesystem command. Used as an intermediary for filesystem # access to allow alternate (virtual, etc.) filesystems to be used. The # ::ftpd::Fs command will call out to the fsCmd callback with the # subcommand and arguments that are passed to it. # # The fsCmd callback is called in the following ways: # # append # delete # dlist

TreeQL documentation

What is Treeql?

TreeQL is an elegant tree query language inspired by Cost.

There is a Tcl Wiki Page for discussion of this package.

Current stable implementation: Download

API Documentation

TreeQL Interface
User level TreeQL interface
CostQ Interface
Cost-alike Query interface built over TreeQL
Low Level TreeQL API
Tree transformers and filters
Tree API
API required of an underlying tree
Internal TreeQL API
Colin McCormack
Last modified: Thu Sep 30 13:39:21 EST 2004 tcllib-1.15/modules/treeql/docs/api.css0000644000175000017500000000214712077663116017423 0ustar sergeisergei/* api.css */ api, p, header, group, method, function, desc, detail { display: block; } api { background: #F2F0F1; margin-left: 4em; margin-right: 4em; margin-top: 2em; margin-bottom: 2em; font-family: "Gill Sans MT", "Gill sans", "Trebuchet ms", Verdana, Geneva, Lucida, Arial, Helvetica, sans-serif; } title { font-weight: bold; font-size: 2em; } p { text-align: justify; margin-top: 0.5em; } group { padding-top: 1.5em; } group > name { display: block; color: gray; font-size: 1.5em; font-weight: bold; padding-bottom: 0.5em; } name[used]:after { content: attr(used); } object, args, arg { color: #9588EC; } arg:before { content: "$" } name { color: blue; } result:before { content: " -- " } result { display: inline; } group > header { display: block; padding-bottom: 2em; } function > detail { display: block; padding-left: 2em; padding-top: .125em; } method > detail { display: block; padding-left: 2em; padding-top: .125em; } method, function { padding-left: .25em; padding-top: .25em; padding-bottom: .25em; background: #CEDEF4; } tcllib-1.15/modules/treeql/docs/treeql-low.xml0000644000175000017500000001022412077663116020750 0ustar sergeisergei Treeql Low Level API

Treeql is a fairly thin query facility over Trees. It implements an ordered set of nodes which are generated and filtered by application of the treeql query language to each node in turn.

Tree Transformers
These are low level functional transformers which apply operations to the underlying tree via the node set, and generate a new node set.
query apply cmd args returns the list of results of application apply [tree $node {*}cmd {*}args] form to each node in node set query sapply cmd args returns the concatenated strings of results of application apply [tree $node {*}cmd {*}args] form to each node in node set query applyself cmd args returns the list of results of the application apply [query {*}cmd node {*}args] to each node, discarding null results query mapself cmd returns the list of results of the application apply [query {*}cmd node {*}args] to each node in node set, keeping null results Tree Filters
These are low level filters, which apply predicates to the underlying tree via the node set, and reduce the nodeset accordingly.
query filter cmd args returns the list of results of application when application is non nil filter nodes by [tree {*}cmd {*}args] query bool cmd args returns the list of results of application when application is true filter nodes by the predicate [tree {*}cmd {*}args] query stringP op attr returns the list of nodes for which predicate is true filter nodes by predicate [string {*}op] over attribute attr query stringNP op attr returns the list of nodes for which predicate is false filter nodes by negating the predicate [string {*}op] over attribute attr query exprP op attr returns the list of nodes for which predicate is true filter nodes by predicate [expr {*}op] over attribute attr query exprNP op attr returns the list of nodes for which predicate is false filter nodes by predicate ![expr {*}op] over attribute attr tcllib-1.15/modules/treeql/docs/treeql-int.xml0000644000175000017500000000410112077663116020736 0ustar sergeisergei Treeql Shims - Internal
Shims do_attr node op attr returns the result of functionally applying op to the node's attribute shim to perform operation {*}op on attribute attr of node do_getvals node pattern returns a list of string values of matching attributes shim to return string values of attributes matching pattern of a given node do_ancestors node shim to find node ancestors by repetitive [parent] do_previous* node do_next* node SubQueries subquery return result of new query $query, preserving current node set and and construct the set of nodes present in both $nodes and node set $and or or construct the set of nodes present in $nodes or node set $or not not construct the set of nodes present in $nodes but not node set $not tcllib-1.15/modules/treeql/pkgIndex.tcl0000644000175000017500000000024312077663116017460 0ustar sergeisergeiif {![package vsatisfies [package provide Tcl] 8.4]} { # PRAGMA: returnok return } package ifneeded treeql 1.3.1 [list source [file join $dir treeql.tcl]] tcllib-1.15/modules/treeql/treeql.man0000644000175000017500000006076212077663116017210 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [comment ===========================================] [manpage_begin treeql n 1.3.1] [copyright {2004 Colin McCormack }] [copyright {2004 Andreas Kupries }] [moddesc {Tree Query Language}] [titledesc {Query tree objects}] [category {Data structures}] [require Tcl 8.2] [require snit] [require struct::list] [require struct::set] [require treeql [opt 1.3.1]] [description] [para] This package provides objects which can be used to query and transform tree objects following the API of tree objects created by the package [package struct::tree]. [para] The tree query and manipulation language used here, TreeQL, is inspired by Cost (See section [sectref References] for more information). [para] [package treeql], the package, is a fairly thin query facility over tree-structured data types. It implements an ordered set of nodes (really a list) which are generated and filtered through the application of TreeQL operators to each node in turn. [comment ===========================================] [section API] [subsection {TreeQL CLASS API}] The command [cmd treeql] is a [package snit]::type which implements the Treeql Query Language. This means that it follows the API for class commands as specified by the package [package snit]. Its general syntax is [list_begin definitions] [call [cmd treeql] [arg objectname] [option -tree] [arg tree] \ [opt "[option -query] [arg query]"] \ [opt "[option -nodes] [arg nodes]"] \ [opt [arg args]...]] The command creates a new tree query object and returns the fully qualified name of the object command as its result. The API the returned command is following is described in the section [sectref {TreeQL OBJECT API}] [para] Each query object is associated with a single [arg tree] object. This is the object all queries will be run against. [para] If the option [option -nodes] was specified then its argument is treated as a list of nodes. This list is used to initialize the node set. It defaults to the empty list. [para] If the option [option -query] was specified then its argument will be interpreted as an object, the [term {parent query}] of this query. It defaults to the object itself. All queries will be interpreted in the environment of this object. [para] Any arguments coming after the options are treated as a query and run immediately, after the [term {node set}] has been initialized. This uses the same syntax for the query as the method [method query]. [para] The operations of the TreeQL available for this are explained in the section about [sectref {The Tree Query Language}]. This section also explains the term [term {node set}] used above. [list_end] [subsection {TreeQL OBJECT API}] As [package treeql] has been implemented in [package snit] all the standard methods of [package snit]-based classes are available to the user and therefore not listed here. Please read the documentation for [package snit] for what they are and what functionality they provide [para] The methods provided by the package [package treeql] itself are listed and explained below. [list_begin definitions] [call [arg qo] [method query] [arg args]...] This method interprets its arguments as a series of TreeQL operators and interpretes them from the left to right (i.e. first to last). Note that the first operator uses the [term {node set}] currently known to the object to perform its actions. In other words, the [term {node set}] is [emph not] cleared, or modified in other ways, before the query is run. This allows the user to run several queries one after the other and have each use the results of the last. Any initialization has to be done by any query itself, using TreeQL operators. The result of the method is the [term {node set}] after the last operator of the query has been executed. [para] [emph Note] that uncaught errors will leave the [term {node set}] of the object in an intermediate state, per the TreeQL operators which were executed successfully before the error occurred. [para] The above means in detail that: [list_begin enumerated] [enum] The first argument is interpreted as the name of a query operator, the number of arguments required by that operator is then determined, and taken from the immediately following arguments. [para] Because of this operators cannot have optional arguments, all arguments have to be present as defined. Failure to do this will, at least, confuse the query interpreter, but more likely cause errors. [enum] The operator is applied to the current node set, yielding a new node set, and/or manipulating the tree object the query object is connected to. [enum] The arguments used (i.e. operator name and arguments) are removed from the list of method arguments, and then the whole process is repeated from step [lb]1[rb], until the list of arguments is empty or an error occurred. [list_end] [para] [example { # q is the query object. q query root children get data # The above query # - Resets the node set to the root node - root # - Adds the children of root to the set - children # - Replaces the node set with the - get data # values for the attribute 'data', # for all nodes in the set which # have such an attribute. # - And returns this information. # Below we can see the same query, but rewritten # to show the structure as it is seen by the query # interpreter. q query \\ root \\ children \\ get data }] [para] The operators of the TreeQL language available for this are explained in the section about [sectref {The Tree Query Language}]. This section also explains the term [term {node set}] used above. [call [arg qo] [method result]] This method returns a list containing the current node set. [call [arg qo] [method discard]] This method returns the current node set (like method [method result]), but also destroys the query object ([arg qo]). This is useful when constructing and using sub-queries (%AUTO% objects immediately destroyed after use). [list_end] [comment ===========================================] [section {The Tree Query Language}] This and the following sections specify the Tree Query Language used by the query objects of this package in detail. [para] First we explain the general concepts underneath the language which are required to comprehend it. This is followed by the specifications for all the available query operators. They fall into eight categories, and each category has its own section. [para] [comment { Local table of contents just for this section. }] [list_begin enumerated] [enum] [sectref {TreeQL Concepts}] [enum] [sectref {Structural generators}] [enum] [sectref {Attribute Filters}] [enum] [sectref {Attribute Mutators}] [enum] [sectref {Attribute String Accessors}] [enum] [sectref Sub-queries] [enum] [sectref {Node Set Operators}] [enum] [sectref {Node Set Iterators}] [enum] [sectref {Typed node support}] [list_end] [para] [comment ===========================================] [subsection {TreeQL Concepts}] The main concept which has to be understood is that of the [term {node set}]. Each query object maintains exactly one such [term {node set}], and essentially all operators use it and input argument and for their result. This structure simply contains the handles of all nodes which are currently of interest to the query object. To name it a [term set] is a bit of a misnomer, because [list_begin enumerated] [enum] A node (handle) can occur in the structure more than once, and [enum] the order of nodes in the structure is important as well. Whenever an operator processes all nodes in the node set it will do so in the order they occur in the structure. [list_end] [para] Regarding the possible multiple occurrence of a node, consider a node set containing two nodes A and B, both having node P as their immediate parent. Application of the TreeQL operator "parent" will then add P to the new node set twice, once per node it was parent of. I.e. the new node set will then be {P P}. [comment ===========================================] [subsection {Structural generators}] All tree-structural operators locate nodes in the tree based on a structural relation ship to the nodes currently in the set and then replace the current node set with the set of nodes found Nodes which fulfill such a relationship multiple times are added to the result as often as they fulfill the relationship. [para] It is important to note that the found nodes are collected in a separate storage area while processing the node set, and are added to (or replacing) the current node set only after the current node set has been processed completely. In other words, the new nodes are [emph not] processed by the operator as well and do not affect the iteration. [para] When describing an operator the variable [var N] will be used to refer to any node in the node set. [list_begin definitions] [def [method ancestors]] Replaces the current node set with the ancestors for all nodes [var N] in the node set, should [var N] have a parent. In other words, nodes without a parent do not contribute to the new node set. In other words, uses all nodes on the path from node [var N] to root, in this order (root last), for all nodes [var N] in the node set. This includes the root, but not the node itself. [def [method rootpath]] Replaces the current node set with the ancestors for all nodes [var N] in the node set, should [var N] have a parent. In other words, nodes without a parent do not contribute to the new node set. In contrast to the operator [method ancestors] the nodes are added in reverse order however, i.e. the root node first. [def [method parent]] Replaces the current node set with the parent of node [var N], for all nodes [var N] in the node set, should [var N] have a parent. In other words, nodes without a parent do not contribute to the new node set. [def [method children]] Replaces the current node set with the immediate children of node [var N], for all nodes [var N] in the node set, should [var N] have children. In other words, nodes without children do not contribute to the new node set. [def [method left]] Replaces the current node set with the previous/left sibling for all nodes [var N] in the node set, should [var N] have siblings to the left. In other words, nodes without left siblings do not contribute to the new node set. [def [method right]] Replaces the current node set with the next/right sibling for all nodes [var N] in the node set, should [var N] have siblings to the right. In other words, nodes without right siblings do not contribute to the new node set. [def [method prev]] Replaces the current node set with all previous/left siblings of node [var N], for all nodes [var N] in the node set, should [var N] have siblings to the left. In other words, nodes without left siblings are ignored. The left sibling adjacent to the node is added first, and the leftmost sibling last (reverse tree order). [def [method esib]] Replaces the current node set with all previous/left siblings of node [var N], for all nodes [var N] in the node set, should [var N] have siblings to the left. In other words, nodes without left siblings are ignored. The leftmost sibling is added first, and the left sibling adjacent to the node last (tree order). [para] The method name is a shorthand for [term {Earlier SIBling}]. [def [method next]] Replaces the current node set with all next/right siblings of node [var N], for all nodes [var N] in the node set, should [var N] have siblings to the right. In other words, nodes without right siblings do not contribute to the new node set. The right sibling adjacent to the node is added first, and the rightmost sibling last (tree order). [def [method root]] Replaces the current node set with a node set containing a single node, the root of the tree. [def [method tree]] Replaces the current node set with a node set containing all nodes found in the tree. The nodes are added in pre-order (parent first, then children, the latter from left to right, first to last). [def [method descendants]] Replaces the current node set with the nodes in all subtrees rooted at node [var N], for all nodes [var N] in the node set, should [var N] have children. In other words, nodes without children do not contribute to the new node set. [para] This is like the operator [method children], but covers the children of children as well, i.e. all the [term {proper descendants}]. "Rooted at [var N]" means that [var N] itself is not added to the new set, which is also implied by [term {proper descendants}]. [def [method subtree]] Like operator [method descendants], but includes the node [var N]. In other words: [para] Replaces the current node set with the nodes of the subtree of node [var N], for all nodes [var N] in the node set, should [var N] have children. In other words, nodes without children do not contribute to the new node set. I.e this is like the operator [method children], but covers the children of children, etc. as well. "Of [var N]" means that [var N] itself is added to the new set. [def [method forward]] Replaces the current node set with the nodes in the subtrees rooted at the right siblings of node [var N], for all nodes [var N] in the node set, should [var N] have right siblings, and they children. In other words, nodes without right siblings, and them without children are ignored. [para] This is equivalent to the operator sequence [example {next descendants}] [def [method later]] This is an alias for the operator [method forward]. [def [method backward]] Replaces the current node set with the nodes in the flattened previous subtrees, in reverse tree order. [para] This is nearly equivalent to the operator sequence [example {prev descendants}] The only difference is that this uses the nodes in reverse order. [def [method earlier]] Replaces the current node set with the nodes in the flattened previous subtrees, in tree order. [para] This is equivalent to the operator sequence [example {prev subtree}] [list_end] [comment ===========================================] [subsection {Attribute Filters}] These operators filter the node set by reference to attributes of nodes and their properties. Filter means that all nodes not fulfilling the criteria are removed from the node set. In other words, the node set is replaced by the set of nodes fulfilling the filter criteria. [list_begin definitions] [def "[method hasatt] [arg attr]"] Reduces the node set to nodes which have an attribute named [arg attr]. [def "[method withatt] [arg attr] [arg value]"] Reduces the node set to nodes which have an attribute named [arg attr], and where the value of that attribute is equal to [arg value] (The "==" operator is [cmd {string equal -nocase}]). [def "[method withatt!] [arg attr] [arg val]"] This is the same as [method withatt], but all nodes in the node set have to have the attribute, and the "==" operator is [cmd {string equal}], i.e. no [option -nocase]. The operator will fail with an error if they don't have the attribute. [def "[method attof] [arg attr] [arg vals]"] Reduces the node set to nodes which which have an attribute named [arg attr] and where the value of that attribute is contained in the list [arg vals] of legal values. The contained-in operator used here does glob matching (using the attribute value as pattern) and ignores the case of the attribute value, [emph {but not}] for the elements of [arg vals]. [def "[method attmatch] [arg attr] [arg match]"] Same as [method withatt], but [cmd {string match}] is used as the "==" operator, and [arg match] is the pattern checked for. [para] [emph Note] that [arg match] is a interpreted as a partial argument [emph list] for [cmd {string match}]. This means that it is interpreted as a list containing the pattern, and the pattern element can be preceded by options understand by [cmd {string match}], like [option -nocase]. This is especially important should the pattern contain spaces. It has to be wrapped into a list for correct interpretation by this operator [list_end] [comment ===========================================] [subsection {Attribute Mutators}] These operators change node attributes within the underlying tree. In other words, all these operators have [term {side effects}]. [list_begin definitions] [def "[method set] [arg attr] [arg val]"] Sets the attribute [arg attr] to the value [arg val], for all nodes [var N] in the node set. The operator will fail if a node does not have an attribute named [arg attr]. The tree will be left in a partially modified state. [def "[method unset] [arg attr]"] Unsets the attribute [arg attr], for all nodes [var N] in the node set. The operator will fail if a node does not have an attribute named [arg attr]. The tree will be left in a partially modified state. [list_end] [comment ===========================================] [subsection {Attribute String Accessors}] These operators retrieve the values of node attributes from the underlying tree. The collected results are stored in the node set, but are not actually nodes. [para] In other words, they redefine the semantics of the node set stored by the query object to contain non-node data after their completion. [para] The query interpreter will terminate after it has finished processing one of these operators, silently discarding any later query elements. It also means that our talk about maintenance of a node set is not quite true. It is a node set while the interpreter is processing commands, but can be left as an attribute value set at the end of query processing. [list_begin definitions] [def "[method string] [arg op] [arg attr]"] Applies the string operator [arg op] to the attribute named [arg attr], for all nodes [var N] in the node set, collects the results of that application and places them into the node set. [para] The operator will fail if a node does not have an attribute named [arg attr]. [para] The argument [arg op] is interpreted as partial argument list for the builtin command [cmd string]. Its first word has to be any of the sub-commands understood by [cmd string]. This has to be followed by all arguments required for the subcommand, except the last. that last argument is supplied by the attribute value. [def "[method get] [arg pattern]"] For all nodes [var N] in the node set it determines all their attributes with names matching the glob [arg pattern], then the values of these attributes, at last it replaces the node set with the list of these attribute values. [def [method attlist]] This is a convenience definition for the operator [method {getvals *}]. In other words, it replaces the node set with a list of the attribute values for all attributes for all nodes [var N] in the node set. [def "[method attrs] [arg glob]"] Replaces the current node set with a list of attribute lists, one attribute list per for all nodes [var N] in the node set. [def "[method attval] [arg attname]"] Reduces the current node set with the operator [method hasatt], and then replaces it with a list containing the values of the attribute named [arg attname] for all nodes [var N] in the node set. [list_end] [comment ===========================================] [subsection Sub-queries] Sub-queries yield node sets which are then used to augment, reduce or replace the current node set. [list_begin definitions] [def "[method andq] [arg query]"] Replaces the node set with the set-intersection of the node set generated by the sub-query [arg query] and itself. [para] The execution of the sub-query uses the current node set as its own initial node set. [def "[method orq] [arg query]"] Replaces the node set with the set-union of the node set generated by the sub-query [arg query] and itself. Duplicate nodes are removed. [para] The execution of the sub-query uses the current node set as its own initial node set. [def "[method notq] [arg query]"] Replaces the node set with the set of nodes generated by the sub-query [arg query] which are also not in the current node set. In other word the set difference of itself and the node set generated by the sub-query. [para] The execution of the sub-query uses the current node set as its own initial node set. [list_end] [comment ===========================================] [subsection {Node Set Operators}] These operators change the node set directly, without referring to the tree. [comment { Should have a 'reverse' as well. }] [list_begin definitions] [def [method unique]] Removes duplicate nodes from the node set, preserving order. In other words, the earliest occurrence of a node handle is preserved, every other occurrence is removed. [def [method select]] Replaces the current node set with a node set containing only the first node from the current node set [def "[method transform] [arg query] [arg var] [arg body]"] First it interprets the sub-query [arg query], using the current node set as its initial node set. Then it iterates over the result of that query, binding the handle of each node to the variable named in [arg var], and executing the script [arg body]. The collected results of these executions is made the new node set, replacing the current one. [para] The script [arg body] is executed in the context of the caller. [def "[method map] [arg var] [arg body]"] Iterates over the current node set, binding the handle of each node to the variable named in [arg var], and executing the script [arg body]. The collected results of these executions is made the new node set, replacing the current one. [para] The script [arg body] is executed in the context of the caller. [def "[method quote] [arg val]"] Appends the literal value [arg val] to the current node set. [def "[method replace] [arg val]"] Replaces the current node set with the literal list value [arg val]. [list_end] [comment ===========================================] [subsection {Node Set Iterators}] [list_begin definitions] [def "[method foreach] [arg query] [arg var] [arg body]"] Interprets the sub-query [arg query], then performs the equivalent of operator [method over] on the nodes in the node set created by that query. The current node set is not changed, except through side effects from the script [arg body]. [para] The script [arg body] is executed in the context of the caller. [def "[method with] [arg query] [arg body]"] Interprets the [arg query], then runs the script [arg body] on the node set generated by the query. At last it restores the current node set as it was before the execution of the query. [para] The script [arg body] is executed in the context of the caller. [def "[method over] [arg var] [arg body]"] Executes the script [arg body] for each node in the node set, with the variable named by [arg var] bound to the name of the current node. The script [arg body] is executed in the context of the caller. [para] This is like the builtin [cmd foreach], with the node set as the source of the list to iterate over. [para] The results of executing the [arg body] are ignored. [def [method delete]] Deletes all the nodes contained in the current node set from the tree. [list_end] [comment ===========================================] [subsection {Typed node support}] These filters and accessors assume the existence of an attribute called [const @type], and are short-hand forms useful for cost-like tree query, html tree editing, and so on. [list_begin definitions] [def [method nodetype]] Returns the node type of nodes. Attribute string accessor. This is equivalent to [example {get @type}] [def "[method oftype] [arg t]"] Reduces the node set to nodes whose type is equal to [arg t], with letter case ignored. [def "[method nottype] [arg t]"] Reduces the node set to nodes whose type is not equal to [arg t], with letter case ignored. [def "[method oftypes] [arg attrs]"] Reduces set to nodes whose @type is an element in the list [arg attrs] of types. The value of @type is used as a glob pattern, and letter case is relevant. [list_end] [section Examples] ... TODO ... [section References] [list_begin enumerated] [enum] [uri http://wiki.tcl.tk/COST COST] on the Tcler's Wiki. [enum] [uri http://wiki.tcl.tk/treeql TreeQL] on the Tcler's Wiki. Discuss this package there. [list_end] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph treeql] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords {tree query language} {structured queries}] [keywords tree TreeQL Cost XPath DOM XSLT] [manpage_end] tcllib-1.15/modules/treeql/treeql.testsuite0000644000175000017500000002763212077663116020465 0ustar sergeisergei# -*- tcl -*- treeql.test # Actual tests, run by the testsuite manager selecting the # implementation of struct::tree # ------------------------------------------------------------------------- # generate a tree upon which to conduct the tests proc mknode {t where l} { foreach {node subnode} $l { set n [$t insert $where end $node] $t set $n data $node mknode $t $n $subnode } } tree t set flattened {1 {3 {7 {} 8 {}} 4 {9 {} 10 {}}} 2 {5 {11 {} 12 {}} 6 {13 {} 14 {}}}} mknode t root $flattened t set root data 0 treeql q -tree t # ------------------------------------------------------------------------- test treeql-${impl}-0.1 "root" {} { q query root get data } 0 test treeql-${impl}-0.2 "children" {} { q query root children get data } "1 2" test treeql-${impl}-0.3 "grandchildren" {} { q query reset root children children get data } "3 4 5 6" test treeql-${impl}-0.4 "parents" {} { q query reset root children children parent unique get data } "1 2" test treeql-${impl}-0.5 "great-grandchildren" {} { q query reset root children children children get data } "7 8 9 10 11 12 13 14" test treeql-${impl}-0.6 "whole tree" {} { q query reset tree get data } "0 1 3 7 8 4 9 10 2 5 11 12 6 13 14" test treeql-${impl}-0.7 "first child" {} { q query reset root children select get data } 1 test treeql-${impl}-0.8 "next of first is second" {} { q query reset root children select next get data } 2 test treeql-${impl}-0.9 "root has no next" {} { q query reset root next } "" test treeql-${impl}-1.0 "whole tree by subtree" {} { q query reset root subtree get data } "0 1 3 7 8 4 9 10 2 5 11 12 6 13 14" test treeql-${impl}-1.1 "whole tree except root by descendants" {} { q query reset root descendants get data } "1 3 7 8 4 9 10 2 5 11 12 6 13 14" test treeql-${impl}-1.2 "right half subtree" {} { q query reset root children select next subtree get data } "2 5 11 12 6 13 14" test treeql-${impl}-1.3 "all the odd numbers" {} { q query reset tree left get data } "7 3 9 1 11 5 13" test treeql-${impl}-1.4 "all the even numbers" {} { q query reset tree right get data } "2 4 8 10 6 12 14" test treeql-${impl}-1.5 "whole tree by subtree" {} { q query reset root subtree get data } "0 1 3 7 8 4 9 10 2 5 11 12 6 13 14" test treeql-${impl}-1.6 "whole tree by ancestors" {} { q query reset root children children children ancestors unique get data } "7 3 1 0 8 9 4 10 11 5 2 12 13 6 14" test treeql-${impl}-1.7 "three generations by ancestors" {} { q query reset root children children ancestors unique get data } "3 1 0 4 5 2 6" test treeql-${impl}-1.8 "grandchildren and below by subtree" {} { q query reset root children children children subtree get data } "7 8 9 10 11 12 13 14" test treeql-${impl}-2.0 "hasatt data" {} { q query reset tree hasatt data get data } "0 1 3 7 8 4 9 10 2 5 11 12 6 13 14" test treeql-${impl}-2.1 "hasatt noatt (none)" {} { q query reset tree hasatt noatt get data } "" test treeql-${impl}-2.2 "withatt 7" {} { q query reset tree withatt data 7 get data } 7 test treeql-${impl}-2.3 "withatt 999" {} { q query reset tree withatt data 999 get data } "" test treeql-${impl}-2.4 "attof {6 7 8 9 10}" {} { q query reset tree attof data {6 7 8 9 10} get data } "7 8 9 10 6" test treeql-${impl}-2.5 "attmatch 1*" {} { q query reset tree attmatch data 1* get data } "1 10 11 12 13 14" test treeql-${impl}-2.6 "set to even or odd" {} { q query reset root set @type even q query reset tree left set @type odd q query reset tree right set @type even q query reset tree get * } "{even 0} {odd 1} {odd 3} {odd 7} {even 8} {even 4} {odd 9} {even 10} {even 2} {odd 5} {odd 11} {even 12} {even 6} {odd 13} {even 14}" test treeql-${impl}-2.7 "oftype odd" {} { q query reset tree oftype odd get data } "1 3 7 9 5 11 13" test treeql-${impl}-2.8 "test unset" {} { q query reset tree set junk 1 q query reset tree unset junk q query reset tree get * } "{even 0} {odd 1} {odd 3} {odd 7} {even 8} {even 4} {odd 9} {even 10} {even 2} {odd 5} {odd 11} {even 12} {even 6} {odd 13} {even 14}" test treeql-${impl}-2.9 "attlist" {} { q query reset tree attlist } "{even 0} {odd 1} {odd 3} {odd 7} {even 8} {even 4} {odd 9} {even 10} {even 2} {odd 5} {odd 11} {even 12} {even 6} {odd 13} {even 14}" test treeql-${impl}-2.10 "attrs" {} { q query reset tree attrs * } "@type data @type data @type data @type data @type data @type data @type data @type data @type data @type data @type data @type data @type data @type data @type data" test treeql-${impl}-3.0 "capitalise attribute values" {} { q query reset tree string toupper @type } "EVEN ODD ODD ODD EVEN EVEN ODD EVEN EVEN ODD ODD EVEN EVEN ODD EVEN" test treeql-${impl}-3.1 "attribute string filter" {} { q query reset tree stringP {compare "odd"} @type get data } "0 8 4 10 2 12 6 14" test treeql-${impl}-3.2 "attribute string !filter" {} { q query reset tree stringNP {compare "odd"} @type get data } "1 3 7 9 5 11 13" test treeql-${impl}-3.3 "attribute expr filter" {} { q query reset tree exprP {7 <=} data get data } "7 8 9 10 11 12 13 14" test treeql-${impl}-3.4 "attribute expr !filter" {} { q query reset tree exprNP {7 <=} data get data } "0 1 3 4 2 5 6" test treeql-${impl}-4.0 "descendents of 2" {} { q query reset root children select next descendants get data } "5 11 12 6 13 14" test treeql-${impl}-4.1 "forward from 1" {} { q query reset root children select forward get data } "5 11 12 6 13 14" test treeql-${impl}-4.2 "earlier than 2" {} { q query reset root children next earlier get data } "3 7 8 4 9 10" test treeql-${impl}-4.3 "backward from 2" {} { q query reset root children next backward get data } "10 9 4 8 7 3 1" test treeql-${impl}-5.0 "<= 4 or odd" {} { # oftype - See test 2.6 for setting it. # exprP: attribute value is on the right: (4 >= x) lsort -integer [q query reset tree left orq {tree exprP {4 >=} data} get data] } {0 1 2 3 4 5 7 9 11 13} test treeql-${impl}-5.1 "> 4 and odd" {} { # oftype - See test 2.6 for setting it. # exprP: attribute value is on the right: (4 < x) lsort -integer [q query reset tree oftype odd andq {tree exprP {4 <} data} get data] } {5 7 9 11 13} test treeql-${impl}-5.2 "odd numbers by subtraction" {} { # oftype - See test 2.6 for setting it. lsort -integer [q query reset tree notq {tree oftype even} get data] } {1 3 5 7 9 11 13} test treeql-${impl}-5.3 "add a depth attribute to each node" {} { q foreach {tree} node { t set $node @depth [llength [q do_rootpath $node]] } q query tree get * } "{1 even 0} {2 odd 1} {3 odd 3} {4 odd 7} {4 even 8} {3 even 4} {4 odd 9} {4 even 10} {2 even 2} {3 odd 5} {4 odd 11} {4 even 12} {3 even 6} {4 odd 13} {4 even 14}" test treeql-${impl}-5.4 "square each odd number" {} { q foreach {tree oftype odd} node { set x [t get $node data] t set $node square [expr $x * $x] } q query reset tree get square } "{} 1 9 49 {} {} 81 {} {} 25 121 {} {} 169 {}" test treeql-${impl}-6.0 "delete all odd numbers" {} { q query reset tree oftype odd delete q query tree get data } "0 8 4 10 2 12 6 14" test treeql-${impl}-6.1 "delete all even numbers (except root)" {} { q query reset tree oftype even notq {root} delete q query tree get data } 0 test treeql-${impl}-6.2 "delete all (except root)" {} { q query reset tree notq {root} delete q query tree get data } 0 test treeql-${impl}-get.1 {attributes with special characters} { t insert root end n1 n2 n3 t set n1 title hello t set n2 title "hello there" t set n3 title {[hello]} q query root children get title } [list hello {hello there} {[hello]}] # ------------------------------------------------------------------------- test treeql-${impl}-over-1.0 {over} { set track {} set context 1 q query root over n {lappend track $n $context} set track } {root 1} test treeql-${impl}-over-1.1 {over} { set track {} set context 2 q query tree subquery root over n {lappend track $n $context} set track } {root 2} test treeql-${impl}-over-1.2 {over} { set track {} set context 2 q query tree andq {root over n {lappend track $n $context}} set track } {root 2} test treeql-${impl}-over-1.3 {over} { set track {} set context 2 q query tree orq {root over n {lappend track $n $context}} set track } {root 2} test treeql-${impl}-over-1.4 {over} { set track {} set context 2 q query tree notq {root over n {lappend track $n $context}} set track } {root 2} test treeql-${impl}-foreach-1.0 {foreach} { set track {} set context 1 q query tree foreach root n {lappend track $n $context} set track } {root 1} test treeql-${impl}-foreach-1.1 {foreach} { set track {} set context 2 q query tree subquery root foreach root n {lappend track $n $context} set track } {root 2} test treeql-${impl}-foreach-1.2 {foreach} { set track {} set context 2 q query tree andq {root foreach root n {lappend track $n $context}} set track } {root 2} test treeql-${impl}-foreach-1.3 {foreach} { set track {} set context 2 q query tree orq {root foreach root n {lappend track $n $context}} set track } {root 2} test treeql-${impl}-foreach-1.4 {foreach} { set track {} set context 2 q query tree notq {root foreach root n {lappend track $n $context}} set track } {root 2} test treeql-${impl}-with-1.0 {with} { set track {} set context 1 q query with root {lappend track $context} set track } 1 test treeql-${impl}-with-1.1 {with} { set track {} set context 2 q query root subquery with root {lappend track $context} set track } 2 test treeql-${impl}-with-1.2 {with} { set track {} set context 2 q query andq {with root {lappend track $context}} set track } 2 test treeql-${impl}-with-1.3 {with} { set track {} set context 2 q query orq {with root {lappend track $context}} set track } 2 test treeql-${impl}-with-1.4 {with} { set track {} set context 2 q query notq {with root {lappend track $context}} set track } 2 test treeql-${impl}-transform-1.0 {transform} { set track {} set context 1 q query transform root n { lappend track $n $context continue } set track } {root 1} test treeql-${impl}-transform-1.1 {transform} { set track {} set context 2 q query subquery transform root n { lappend track $n $context continue } set track } {root 2} test treeql-${impl}-transform-1.2 {transform} { set track {} set context 2 q query andq {transform root n { lappend track $n $context continue }} set track } {root 2} test treeql-${impl}-transform-1.3 {transform} { set track {} set context 2 q query orq {transform root n { lappend track $n $context continue }} set track } {root 2} test treeql-${impl}-transform-1.4 {transform} { set track {} set context 2 q query notq {transform root n { lappend track $n $context continue }} set track } {root 2} test treeql-${impl}-map-1.0 {map} { set track {} set context 1 q query root map n { lappend track $n $context continue } set track } {root 1} test treeql-${impl}-map-1.1 {map} { set track {} set context 2 q query subquery root map n { lappend track $n $context continue } set track } {root 2} test treeql-${impl}-map-1.2 {map} { set track {} set context 2 q query andq {root map n { lappend track $n $context continue }} set track } {root 2} test treeql-${impl}-map-1.3 {map} { set track {} set context 2 q query orq {root map n { lappend track $n $context continue }} set track } {root 2} test treeql-${impl}-map-1.4 {map} { set track {} set context 2 q query notq {root map n { lappend track $n $context continue }} set track } {root 2} # ------------------------------------------------------------------------- # Cleanup q destroy t destroy tcllib-1.15/modules/treeql/treeql85.tcl0000644000175000017500000004073012077663116017365 0ustar sergeisergei# treeql.tcl # A generic tree query language in snit # # Copyright 2004 Colin McCormack. # You are permitted to use this code under the same license as tcl. # # 20040930 Colin McCormack - initial release to tcllib # # RCS: @(#) $Id: treeql85.tcl,v 1.2 2007/05/01 17:00:25 andreas_kupries Exp $ package require Tcl 8.5 package require snit package require struct::list package require struct::set snit::type ::treeql { variable nodes ;# set of all nodes variable tree ;# tree over which nodes are defined variable query ;# full query - ie: 'parent' of this treeql object # low level accessor to tree method treeObj {} { return $tree } # apply the [$tree cmd {*}$args] form to each node # returns the list of results of application method apply {cmd args} { set result {} foreach node $nodes { if {[catch { $tree {*}$cmd $node {*}$args } application eo]} { puts stderr "apply ERROR: $tree $cmd $node $args -> $application - $eo" } else { #puts stderr "Apply: $tree $cmd $node $args -> $application" lappend result {*}$application } } return $result } # filter nodes by [$tree cmd {*}$args] # returns the list of results of application when application is non nil method filter {cmd args} { set result {} foreach node $nodes { if {[catch { $tree {*}$cmd $node {*}$args } application eo]} { puts stderr "filter ERROR: $tree $cmd $node $args -> $application - $eo" } else { #puts stderr "Filter: $tree $cmd $node $args -> $application" if {$application != {}} { lappend result $application } } } return $result } # filter nodes by the predicate [$tree cmd {*}$args] # returns the list of results of application when application is true method bool {cmd args} { #puts stderr "Bool: $tree $cmd - $args" #set result [::struct::list filter $nodes [list $tree $cmd {*}$args]] #puts stderr "Bool: $tree $cmd - $nodes - $args -> $result" #return $result # replaced by tcllib's list filter set result {} foreach node $nodes { if {[catch { $tree {*}$cmd $node {*}$args } application eo]} { puts stderr "bool ERROR: $tree $cmd $node $args -> $application - $eo" } else { #puts stderr "Bool: $tree $cmd $node $args -> $application - [$tree dump $node]" if {$application} { lappend result $node } } } return $result } # applyself - map cmd on $self to each node, discarding null results method applyself {cmd args} { set result {} foreach node $nodes { if {[catch { $query {*}$cmd $node {*}$args } application eo]} { puts stderr "applyself ERROR: $tree $cmd $node $args -> $application - $eo" } else { if {[llength $application]} { lappend result {*}$application } } } return $result } # mapself - map cmd on $self to each node method mapself {cmd args} { set result {} foreach node $nodes { if {[catch { $query {*}$cmd $node {*}$args } application eo]} { puts stderr "mapself ERROR: $tree $cmd $node $args -> $application - $eo" } else { #puts stderr "Mapself: $query $cmd $node $args -> $application" lappend result $application } } return $result } # shim to perform operation $op on attribute $attr of $node method do_attr {node op attr} { set attrv [$tree get $node $attr] #puts stderr "$self do_attr node:'$node' op:'$op' attr:'$attr' attrv:'$attrv'" return [{*}$op $attrv] } # filter nodes by predicate [string $op] over attribute $attr method stringP {op attr args} { set n {} set map [$self mapself do_attr [list string {*}$op] $attr] foreach result $map node $nodes { #puts stderr "$self stringP $op $attr -> $result - $node" if {$result} { lappend n $node } } set nodes $n return $args } # filter nodes by negated predicate [string $op] over attribute $attr method stringNP {op attr args} { set n {} set map [$self mapself do_attr [list string {*}$op] $attr] foreach result $map node $nodes { if {!$result} { lappend n $node } } set nodes $n return $args } # filter nodes by predicate [expr {*}$op] over attribute $attr method exprP {op attr args} { set n {} set map [$self mapself do_attr [list expr {*}$op] $attr] foreach result $map node $nodes { if {$result} { lappend n $node } } set nodes $n return $args } # filter nodes by predicate ![expr {*}$op] over attribute $attr method exprNP {op attr args} { set n {} set map [$self mapself do_attr [list expr {*}$op] $attr] foreach result $map node $nodes { if {!$result} { lappend n $node } } set nodes $n return $args } # shim to return string values of attributes matching $pattern of a given $node method do_get {node pattern} { set result {} foreach key [$tree keys $node $pattern] { set result [concat $result [$tree get $node $key]] } return $result } # Returns list of attribute values of attributes matching $pattern - method get {pattern} { set nodes [$self mapself do_get $pattern] return {} ;# terminate query } # Returns list of attribute values of the current node, in an unspecified order. method attlist {} { $self get * return {} ;# terminate query } # Returns list of lists of attributes of each node method attrs {glob} { set nodes [$self apply keys $glob] return {} ;# terminate query } # shim to find node ancestors by repetitive [parent] # as tcllib tree lacks this method do_ancestors {node} { set ancestors {} set rootname [$tree rootname] while {$node ne $rootname} { lappend ancestors $node set node [$tree parent $node] } lappend ancestors $rootname return $ancestors } # path from node to root method ancestors {args} { set nodes [$self applyself do_ancestors] return $args } # shim to find $node rootpath by repetitive [parent] # as tcllib tree lacks this method do_rootpath {node} { set ancestors {} set rootname [$tree rootname] while {$node ne $rootname} { lappend ancestors $node set node [$tree parent $node] } lappend ancestors $rootname return [::struct::list reverse $ancestors] } # path from root to node method rootpath {args} { set nodes [$self applyself do_rootpath] return $args } # node parent method parent {args} { set nodes [$self apply parent] return $args } # node children method children {args} { set nodes [$self apply children] return $args } # previous sibling method left {args} { set nodes [$self apply previous] return $args } # next sibling method right {args} { set nodes [$self apply next] return $args } # shim to find left siblings of node, in order of occurrence method do_previous* {node} { if {$node == [$tree rootname]} { set children $node } else { set children [$tree children [$tree parent $node]] } set index [expr {[lsearch $children $node] - 1}] return [lrange $children 0 $index] } # previous siblings in reverse order method prev {args} { set nodes [::struct::list reverse [$self applyself do_previous*]] return $args } # previous siblings in tree order method esib {args} { set nodes [$self applyself do_previous*] return $args } # shim to find next siblings in tree order method do_next* {node} { if {$node == [$tree rootname]} { set children $node } else { set children [$tree children [$tree parent $node]] } set index [expr {[lsearch $children $node] + 1}] return [lrange $children $index end] } # next siblings in tree order method next {args} { set nodes [$self applyself do_next*] return $args } # generates the tree root method root {args} { set nodes [$tree rootname] return $args } # shim to calculate descendants method do_subtree {node} { set nodeset $node set children [$tree children $node] foreach child $children { set descendants [$self do_subtree $child] lappend nodeset {*}$descendants } #puts stderr "do_subtree $node -> $nodeset" return $nodeset } # generates proper-descendants of nodes method descendants {args} { set desc {} set nodeset {} foreach node $nodes { set subtree [$self do_subtree $node] set descendants [lrange $subtree 1 end] lappend nodeset {*}$descendants } set nodes $nodeset return $args } # generates all subtrees rooted at node method subtree {args} { set nodeset {} foreach node $nodes { set descendants [$self do_subtree $node] lappend nodeset {*}$descendants } set nodes $nodeset return $args } # generates all nodes in the tree method tree {args} { set nodes [$self do_subtree [$tree rootname]] return $args } # generates all subtrees rooted at node #method descendants {args} { # set nodes [$tree apply descendants] # return $args #} # flattened next subtrees method forward {args} { set nodes [$self applyself do_next*] ;# next siblings $self descendants ;# their proper descendants return $args } # synonym for [forward] method later {args} { $self forward return $args } # flattened previous subtrees in tree order method earlier {args} { set nodes [$self applyself do_previous*] ;# all earlier siblings $self descendants ;# their proper descendants return $args } # flattened previous subtrees in reverse tree order # FIXME - this isn't going to return things in the correct order method backward {args} { set nodes [$self applyself do_previous*] ;# all earlier siblings $self subtree ;# their subtrees set nodes [::struct::list reverse $nodes] ;# reverse order return $args } # Returns the node type of nodes method nodetype {} { set nodes [$self apply get @type] return {} ;# terminate query } # Reduce to nodes of @type $t method oftype {t args} { return [$self stringP [list equal -nocase $t] @type {*}$args] } # Reduce to nodes not of @type $t method nottype {t args} { return [$self stringNP [list equal -nocase $t] @type {*}$args] } # Reduce to nodes whose @type is one of $attrs # @type values are assumed to be simple strings method oftypes {attrs args} { set n {} foreach result [$self mapself do_attr list @type] node $nodes { if {[lsearch $attrs $result] > -1} { #puts stderr "$self oftypes '$attrs' -> $result - $node" lappend n $node } } set nodes $n return $args } # Reduce to nodes with attribute $attr (can be a glob) method hasatt {attr args} { set nodes [$self bool keyexists $attr] return $args } # Returns values of attribute attname method attval {attname} { $self hasatt $attname ;# only nodes with attribute set nodes [$self apply get $attname] ;# get the attribute nodes return {} ;# terminate query } # Reduce to nodes with attribute $attr of $value method withatt {attr value args} { $self hasatt $attr ;# only nodes with attribute return [$self stringP [list equal -nocase $value] $attr {*}$args] } # Reduce to nodes with attribute $attr of $value method withatt! {attr val args} { return [$self stringP [list equal $val] $attr {*}$args] } # Reduce to nodes with attribute $attr value one of $vals method attof {attr vals args} { set result {} foreach node $nodes { set x [string tolower [[$self treeObj] get $node $attr]] if {[lsearch $vals $x] != -1} { lappend result $node } } set nodes $result return $args } # Reduce to nodes whose attribute $attr string matches $match method attmatch {attr match args} { $self stringP [list match {*}$match] $attr return $args } # Side Effect: set attribute $attr to $val method set {attr val args} { $self apply set $attr $val return $args } # Side Effect: unset attribute $attr method unset {attr args} { $self apply unset $attr return $args } # apply string operation $op to attribute $attr on each node method string {op attr} { set nodes [$self mapself do_attr [list string {*}$op] $attr] return {} ;# terminate query } # remove duplicate nodes, preserving order method unique {args} { set all {} array set keys {} foreach node $nodes { if {![info exists keys($node)]} { set keys($node) 1 lappend all $node } } set nodes $all return $args } # construct the set of nodes present in both $nodes and node set $and method and {and args} { set nodes [::struct::set intersect $and $nodes] return $args } # return result of new query $query, preserving current node set method subquery {args} { set org $nodes ;# save current node set set new [uplevel 1 [list $query query {*}$args]] set nodes $org ;# restore old node set return $new } # perform a subquery and and in the result method andq {q args} { $self and [uplevel 1 [list $self subquery {*}$q]] return $args } # construct the set of nodes present in $nodes or node set $or method or {or args} { set nodes [::struct::set union $nodes $or] $self unique return $args } # perform a subquery and or in the result method orq {q args} { $self or [uplevel 1 [list $self subquery {*}$q]] return $args } # construct the set of nodes present in $nodes but not node set $not method not {not args} { set nodes [::struct::set difference $nodes $not] return $args } # perform a subquery and return the set of nodes not in the result method notq {q args} { $self not [uplevel 1 [list $self subquery {*}$q]] return $args } # select the first of the nodes method select {args} { set nodes [lindex $nodes 0] return $args } # perform a subquery then replace the nodeset method transform {q var body args} { upvar 1 $var iter set new {} foreach n [uplevel 1 [list $self subquery {*}$q]] { set iter $n switch -exact -- [catch { uplevel 1 $body } result eo] { 0 { # ok lappend new $result } 1 { # pass errors up return -code error $result } 2 { # return set nodes $result return } 3 { # break break } 4 { # continue continue } } } set nodes $new return $args } # replace the nodeset method map {var body args} { upvar 1 $var iter set new {} foreach n $nodes { set iter $n switch -exact -- [catch { uplevel 1 $body } result eo] { 0 { # ok lappend new $result } 1 { # pass errors up return -code error $result } 2 { # return set nodes $result return } 3 { # break break } 4 { # continue continue } } } set nodes $new return $args } # perform a subquery $query then map $body over results method foreach {q var body args} { upvar 1 $var iter foreach n [uplevel 1 [list $self subquery {*}$q]] { set iter $n uplevel 1 $body } return $args } # perform a query, then evaluate $body method with {q body args} { # save current node set, implied reset set org $nodes; set nodes {} uplevel 1 [list $self query {*}$q] set result [uplevel 1 $body] # restore old node set set new $nodes; set nodes $org return $args } # map $body over $nodes method over {var body args} { upvar 1 $var iter set result {} foreach n $nodes { set iter $n uplevel 1 $body } return $args } # perform the query method query {args} { # iterate over the args, treating each as a method invocation while {$args != {}} { #puts stderr "query $self $args" set args [uplevel 1 [list $query {*}$args]] #puts stderr "-> $nodes" } return $nodes } # append the literal $val to node set method quote {val args} { lappend nodes $val return $args } # replace the node set with the literal method replace {val args} { set nodes $val return $args } # set nodeset to empty method reset {args} { set nodes {} return $args } # delete all nodes in node set method delete {args} { foreach node $nodes { $tree cut $node } set nodes {} return $args } # return the node set method result {} { return $nodes } constructor {args} { set query [from args -query ""] if {$query == ""} { set query $self } set nodes [from args -nodes {}] set tree [from args -tree ""] uplevel 1 [list $self query {*}$args] } # Return result, and destroy this query # useful in constructing a sub-query method discard {args} { return [K [$self result] [$self destroy]] } proc K {x y} { set x } } tcllib-1.15/modules/treeql/treeql84.tcl0000644000175000017500000004115412077663116017365 0ustar sergeisergei# treeql.tcl # A generic tree query language in snit # # Copyright 2004 Colin McCormack. # You are permitted to use this code under the same license as tcl. # # 20040930 Colin McCormack - initial release to tcllib # # RCS: @(#) $Id: treeql84.tcl,v 1.10 2007/06/23 03:39:34 andreas_kupries Exp $ package require Tcl 8.4 package require snit package require struct::list package require struct::set snit::type ::treeql { variable nodes ;# set of all nodes variable tree ;# tree over which nodes are defined variable query ;# full query - ie: 'parent' of this treeql object # low level accessor to tree method treeObj {} { return $tree } # apply the [$tree cmd {*}$args] form to each node # returns the list of results of application method apply {cmd args} { set result {} foreach node $nodes { if {[catch { eval [list $tree] $cmd [list $node] $args } application]} { upvar ::errorInfo eo puts stderr "apply: $tree $cmd $node $args -> $application - $eo" } else { #puts stderr "Apply: $tree $cmd $node $args -> $application" foreach a $application {lappend result $a} } } return $result } # filter nodes by [$tree cmd {*}$args] # returns the list of results of application when application is non nil method filter {cmd args} { set result {} foreach node $nodes { if {[catch { eval [list $tree] $cmd [list $node] $args } application]} { upvar ::errorInfo eo puts stderr "filter: $tree $cmd $node $args -> $application - $eo" } else { #puts stderr "Filter: $tree $cmd $node $args -> $application" if {$application != {}} { lappend result $application } } } return $result } # filter nodes by the predicate [$tree cmd {*}$args] # returns the list of results of application when application is true method bool {cmd args} { #puts stderr "Bool: $tree $cmd - $args" #set result [::struct::list filter $nodes [list $tree $cmd {*}$args]] #puts stderr "Bool: $tree $cmd - $nodes - $args -> $result" #return $result # replaced by tcllib's list filter set result {} foreach node $nodes { if {[catch { eval [list $tree] $cmd [list $node] $args } application]} { upvar ::errorInfo eo puts stderr "filter: $tree $cmd $node $args -> $application - $eo" } else { #puts stderr "bool: $tree $cmd $node $args -> $application - [$tree dump $node]" if {$application} { lappend result $node } } } return $result } # applyself - map cmd on $self to each node, discarding null results method applyself {cmd args} { set result {} foreach node $nodes { if {[catch { eval [list $query] $cmd [list $node] $args } application]} { upvar ::errorInfo eo puts stderr "applyself: $tree $cmd $node $args -> $application - $eo" } else { if {[llength $application]} { foreach a $application {lappend result $a} } } } return $result } # mapself - map cmd on $self to each node method mapself {cmd args} { set result {} foreach node $nodes { if {[catch { eval [list $query] $cmd [list $node] $args } application]} { upvar ::errorInfo eo puts stderr "mapself: $tree $cmd $node $args -> $application - $eo" } else { #puts stderr "Mapself: $query $cmd $node $args -> $application" lappend result $application } } return $result } # shim to perform operation $op on attribute $attr of $node method do_attr {node op attr} { set attrv [$tree get $node $attr] #puts stderr "$self do_attr node:'$node' op:'$op' attr:'$attr' attrv:'$attrv'" return [eval [linsert $op end $attrv]] } # filter nodes by predicate [string $op] over attribute $attr method stringP {op attr args} { set n {} set map [$self mapself do_attr [linsert $op 0 string] $attr] foreach result $map node $nodes { #puts stderr "$self stringP $op $attr -> $result - $node" if {$result} { lappend n $node } } set nodes $n return $args } # filter nodes by negated predicate [string $op] over attribute $attr method stringNP {op attr args} { set n {} set map [$self mapself do_attr [linsert $op 0 string] $attr] foreach result $map node $nodes { if {!$result} { lappend n $node } } set nodes $n return $args } # filter nodes by predicate [expr {*}$op] over attribute $attr method exprP {op attr args} { set n {} set map [$self mapself do_attr [linsert $op 0 expr] $attr] foreach result $map node $nodes { if {$result} { lappend n $node } } set nodes $n return $args } # filter nodes by predicate ![expr {*}$op] over attribute $attr method exprNP {op attr args} { set n {} set map [$self mapself do_attr [linsert $op 0 expr] $attr] foreach result $map node $nodes { if {!$result} { lappend n $node } } set nodes $n return $args } # shim to return string values of attributes matching $pattern of a given $node method do_get {node pattern} { set result {} foreach key [$tree keys $node $pattern] { set result [concat $result [$tree get $node $key]] } return $result } # Returns list of attribute values of attributes matching $pattern - method get {pattern} { set nodes [$self mapself do_get $pattern] return {} ;# terminate query } # Returns list of attribute values of the current node, in an unspecified order. method attlist {} { $self get * return {} ;# terminate query } # Returns list of lists of attributes of each node method attrs {glob} { set nodes [$self apply keys $glob] return {} ;# terminate query } # shim to find node ancestors by repetitive [parent] # as tcllib tree lacks this method do_ancestors {node} { set ancestors {} set rootname [$tree rootname] while {$node ne $rootname} { lappend ancestors $node set node [$tree parent $node] } lappend ancestors $rootname return $ancestors } # path from node to root method ancestors {args} { set nodes [$self applyself do_ancestors] return $args } # shim to find $node rootpath by repetitive [parent] # as tcllib tree lacks this method do_rootpath {node} { set ancestors {} set rootname [$tree rootname] while {$node ne $rootname} { lappend ancestors $node set node [$tree parent $node] } lappend ancestors $rootname return [::struct::list reverse $ancestors] } # path from root to node method rootpath {args} { set nodes [$self applyself do_rootpath] return $args } # node parent method parent {args} { set nodes [$self apply parent] return $args } # node children method children {args} { set nodes [$self apply children] return $args } # previous sibling method left {args} { set nodes [$self apply previous] return $args } # next sibling method right {args} { set nodes [$self apply next] return $args } # shim to find left siblings of node, in order of occurrence method do_previous* {node} { if {$node == [$tree rootname]} { set children $node } else { set children [$tree children [$tree parent $node]] } set index [expr {[lsearch $children $node] - 1}] return [lrange $children 0 $index] } # previous siblings in reverse order method prev {args} { set nodes [::struct::list reverse [$self applyself do_previous*]] return $args } # previous siblings in tree order method esib {args} { set nodes [$self applyself do_previous*] return $args } # shim to find next siblings in tree order method do_next* {node} { if {$node == [$tree rootname]} { set children $node } else { set children [$tree children [$tree parent $node]] } set index [expr {[lsearch $children $node] + 1}] return [lrange $children $index end] } # next siblings in tree order method next {args} { set nodes [$self applyself do_next*] return $args } # generates the tree root method root {args} { set nodes [$tree rootname] return $args } # shim to calculate descendants method do_subtree {node} { set nodeset $node set children [$tree children $node] foreach child $children { foreach d [$self do_subtree $child] {lappend nodeset $d} } #puts stderr "do_subtree $node -> $nodeset" return $nodeset } # generates proper-descendants of nodes method descendants {args} { set desc {} set nodeset {} foreach node $nodes { foreach d [lrange [$self do_subtree $node] 1 end] {lappend nodeset $d} } set nodes $nodeset return $args } # generates all subtrees rooted at node method subtree {args} { set nodeset {} foreach node $nodes { foreach d [$self do_subtree $node] {lappend nodeset $d} } set nodes $nodeset return $args } # generates all nodes in the tree method tree {args} { set nodes [$self do_subtree [$tree rootname]] return $args } # generates all subtrees rooted at node #method descendants {args} { # set nodes [$tree apply descendants] # return $args #} # flattened next subtrees method forward {args} { set nodes [$self applyself do_next*] ;# next siblings $self descendants ;# their proper descendants return $args } # synonym for [forward] method later {args} { $self forward return $args } # flattened previous subtrees in tree order method earlier {args} { set nodes [$self applyself do_previous*] ;# all earlier siblings $self descendants ;# their proper descendants return $args } # flattened previous subtrees in reverse tree order # FIXME - this isn't going to return things in the correct order method backward {args} { set nodes [$self applyself do_previous*] ;# all earlier siblings $self subtree ;# their subtrees set nodes [::struct::list reverse $nodes] ;# reverse order return $args } # Returns the node type of nodes method nodetype {} { set nodes [$self apply get @type] return {} ;# terminate query } # Reduce to nodes of @type $t method oftype {t args} { return [eval [linsert $args 0 $self stringP [list equal -nocase $t] @type]] } # Reduce to nodes not of @type $t method nottype {t args} { return [eval [linsert $args 0 $self stringNP [list equal -nocase $t] @type]] } # Reduce to nodes whose @type is one of $attrs # @type values are assumed to be simple strings method oftypes {attrs args} { set n {} foreach result [$self mapself do_attr list @type] node $nodes { if {[lsearch $attrs $result] > -1} { #puts stderr "$self oftypes '$attrs' -> $result - $node" lappend n $node } } set nodes $n return $args } # Reduce to nodes with attribute $attr (can be a glob) method hasatt {attr args} { set nodes [$self bool keyexists $attr] return $args } # Returns values of attribute attname method attval {attname} { $self hasatt $attname ;# only nodes with attribute set nodes [$self apply get $attname] ;# get the attribute nodes return {} ;# terminate query } # Reduce to nodes with attribute $attr of $value method withatt {attr value args} { $self hasatt $attr ;# only nodes with attribute return [eval [linsert $args 0 $self stringP [list equal -nocase $value] $attr]] } # Reduce to nodes with attribute $attr of $value method withatt! {attr val args} { return [eval [linsert $args 0 $self stringP [list equal $val] $attr]] } # Reduce to nodes with attribute $attr value one of $vals method attof {attr vals args} { set result {} foreach node $nodes { set x [string tolower [[$self treeObj] get $node $attr]] if {[lsearch $vals $x] != -1} { lappend result $node } } set nodes $result return $args } # Reduce to nodes whose attribute $attr string matches $match method attmatch {attr match args} { $self stringP [linsert $match 0 match] $attr return $args } # Side Effect: set attribute $attr to $val method set {attr val args} { $self apply set $attr $val return $args } # Side Effect: unset attribute $attr method unset {attr args} { $self apply unset $attr return $args } # apply string operation $op to attribute $attr on each node method string {op attr} { set nodes [$self mapself do_attr [linsert $op 0 string] $attr] return {} ;# terminate query } # remove duplicate nodes, preserving order method unique {args} { set all {} array set keys {} foreach node $nodes { if {![info exists keys($node)]} { set keys($node) 1 lappend all $node } } set nodes $all return $args } # construct the set of nodes present in both $nodes and node set $and method and {and args} { set nodes [::struct::set intersect $and $nodes] return $args } # return result of new query $query, preserving current node set method subquery {args} { set org $nodes ;# save current node set set new [uplevel 1 [linsert $args 0 $query query]] set nodes $org ;# restore old node set return $new } # perform a subquery and and in the result method andq {q args} { $self and [uplevel 1 [linsert $q 0 $self subquery]] return $args } # construct the set of nodes present in $nodes or node set $or method or {or args} { set nodes [::struct::set union $nodes $or] $self unique return $args } # perform a subquery and or in the result method orq {q args} { $self or [uplevel 1 [linsert $q 0 $self subquery]] return $args } # construct the set of nodes present in $nodes but not node set $not method not {not args} { set nodes [::struct::set difference $nodes $not] return $args } # perform a subquery and return the set of nodes not in the result method notq {q args} { $self not [uplevel 1 [linsert $q 0 $self subquery]] return $args } # select the first of the nodes method select {args} { set nodes [lindex $nodes 0] return $args } # perform a subquery then replace the nodeset method transform {q var body args} { upvar 1 $var iter set new {} foreach n [uplevel 1 [linsert $q 0 $self subquery]] { set iter $n switch -exact -- [catch {uplevel 1 $body} result] { 0 { # ok lappend new $result } 1 { # pass errors up return -code error $result } 2 { # return set nodes $result return } 3 { # break break } 4 { # continue continue } } } set nodes $new return $args } # replace the nodeset method map {var body args} { upvar 1 $var iter set new {} foreach n $nodes { set iter $n switch -exact -- [catch {uplevel 1 $body} result] { 0 { # ok lappend new $result } 1 { # pass errors up return -code error $result } 2 { # return set nodes $result return } 3 { # break break } 4 { # continue continue } } } set nodes $new return $args } # perform a subquery $query then map $body over results method foreach {q var body args} { upvar 1 $var iter foreach n [uplevel 1 [linsert $q 0 $self subquery]] { set iter $n uplevel 1 $body } return $args } # perform a query, then evaluate $body method with {q body args} { # save current node set, implied reset set org $nodes; set nodes {} uplevel 1 [linsert $q 0 $self query] set result [uplevel 1 $body] # restore old node set set new $nodes; set nodes $org return $args } # map $body over $nodes method over {var body args} { upvar 1 $var iter set result {} foreach n $nodes { set iter $n uplevel 1 $body } return $args } # perform the query method query {args} { # iterate over the args, treating each as a method invocation while {$args != {}} { #puts stderr "query $self $args" set args [uplevel 1 [linsert $args 0 $query]] #puts stderr "-> $nodes" } return $nodes } # append the literal $val to node set method quote {val args} { lappend nodes $val return $args } # replace the node set with the literal method replace {val args} { set nodes $val return $args } # set nodeset to empty method reset {args} { set nodes {} return $args } # delete all nodes in node set method delete {args} { foreach node $nodes { $tree cut $node } set nodes {} return $args } # return the node set method result {} { return $nodes } constructor {args} { set query [from args -query ""] if {$query == ""} { set query $self } set nodes [from args -nodes {}] set tree [from args -tree ""] uplevel 1 [linsert $args 0 $self query] } # Return result, and destroy this query # useful in constructing a sub-query method discard {args} { return [K [$self result] [$self destroy]] } proc K {x y} { set x } } tcllib-1.15/modules/treeql/treeql.tcl0000644000175000017500000000130712077663116017205 0ustar sergeisergei# treeql.tcl # A generic tree query language in snit # # Copyright 2004 Colin McCormack. # You are permitted to use this code under the same license as tcl. # # 20040930 Colin McCormack - initial release to tcllib # # RCS: @(#) $Id: treeql.tcl,v 1.10 2006/09/19 23:36:18 andreas_kupries Exp $ package require Tcl 8.4 # Select the implementation based on the version of the Tcl core # executing this code. For 8.5 we are using features like # word-expansion to simplify the various evaluations. set dir [file dirname [info script]] if {[package vsatisfies [package provide Tcl] 8.5]} { source [file join $dir treeql85.tcl] } else { source [file join $dir treeql84.tcl] } package provide treeql 1.3.1 tcllib-1.15/modules/treeql/treeql.test0000644000175000017500000000222112077663116017376 0ustar sergeisergei# -*- tcl -*- # treeql.test: tests for the tree query language # # Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.4 testsNeedTcltest 1.0 support { use snit/snit.tcl snit use struct/list.tcl struct::list # TODO: Add accel handling use struct/sets.tcl struct::set useAccel [useTcllibC] struct/tree.tcl struct::tree TestAccelInit struct::tree } testing { useLocal treeql.tcl treeql } # ------------------------------------------------------------------------- # The global variable 'impl' is part of the public API the testsuite # (in treeql.testsuite) can expect from the environment. TestAccelDo struct::tree impl { namespace import -force struct::tree source [localPath treeql.testsuite] } # ------------------------------------------------------------------------- TestAccelExit struct::tree testsuiteCleanup return tcllib-1.15/modules/fumagic/0000755000175000017500000000000012104363635015315 5ustar sergeisergeitcllib-1.15/modules/fumagic/tmc0000755000175000017500000001341012077663116016033 0ustar sergeisergei#! /bin/sh # -*- tcl -*- \ exec tclsh "$0" ${1+"$@"} # TMC - Trival Magic Compiler # === = ===================== # Use cases # --------- # (-) Compilation of one or more files in magic(5) syntax into a # single recognizer performing all the checks and mappings # encoded in them. # # Command syntax # -------------- # # Ad 1) tmc procname magic-file ?magic-file...? # # Compile all magic files into a recognizer, put it into the # named procedure, and write the result to stdout. # # Ad 2) tmc -merge tclfile procname magic-file ?magic-file...? # # Same as (1), but does not write to stdout. Instead the part of # the 'tclfile' delineated by marker lines containing "BEGIN # GENERATED CODE" and "END GENERATED CODE" is replaced with the # generated code. package require Tcl 8.4 lappend auto_path [file dirname [file normalize [info script]]] ; # This directory lappend auto_path [file dirname [lindex $auto_path end]] ; # and the one above #puts *\t[join $auto_path \n*\t] package require fileutil::magic::cfront # ### ### ### ######### ######### ######### ## Internal data and status namespace eval ::tmc { # Path to where the output goes to. An empty string signals that # the output is written to stdout. Otherwise it goes to the # specified file, which has to exist, and is merged into it. # # Specified through the optional option '-merge'. variable output "" # Name of the procedure to generate from the input files. variable proc "" # List of the input files to process. variable magic {} } # ### ### ### ######### ######### ######### ## External data and status # ## Only the file merge mode uses external data, which is explicitly ## specified via the command line. It is a template the generated ## recognizer is merged into, completely replacing an existing ## recognizer. # ### ### ### ######### ######### ######### ## Option processing. ## Validate command line. ## Full command line syntax. ## # tmc ?-merge iofile? procname magic ?magic...? ## proc ::tmc::processCmdline {} { global argv variable output variable magic variable proc set output "" set magic {} set proc "" # Process the options, perform basic validation. while {[llength $argv]} { set opt [lindex $argv 0] if {![string match "-*" $opt]} break if {$opt eq "-merge"} { if {[llength $argv] < 2} Usage set output [lindex $argv 1] set argv [lrange $argv 2 end] } else { Usage } } # Additional validation, and extraction of the non-option # arguments. if {[llength $argv] != 2} Usage set proc [lindex $argv 0] set magic [lrange $argv 1 end] # Final validation across the whole configuration. if {$proc eq ""} { ArgError "Illegal empty proc name" } foreach m $magic { CheckInput $m {Magic file} } if {$output ne ""} { CheckTheMerge } return } # ### ### ### ######### ######### ######### ## Option processing. ## Helpers: Generation of error messages. ## I. General usage/help message. ## II. Specific messages. # # Both write their messages to stderr and then # exit the application with status 1. ## proc ::tmc::Usage {} { global argv0 puts stderr "$argv0 wrong#args, expected:\ ?-merge iofile? procname magic magic..." exit 1 } proc ::tmc::ArgError {text} { global argv0 puts stderr "$argv0: $text" exit 1 } proc in {list item} { expr {([lsearch -exact $list $item] >= 0)} } # ### ### ### ######### ######### ######### ## Check existence and permissions of an input/output file or ## directory. proc ::tmc::CheckInput {f label} { if {![file exists $f]} { ArgError "Unable to find $label \"$f\"" } elseif {![file readable $f]} { ArgError "$label \"$f\" not readable (permission denied)" } return } proc ::tmc::CheckTheMerge {} { variable output if {$output eq ""} { ArgError "No merge file specified" } if {![file exists $output]} { ArgError "Merge file \"$output\" not found" } elseif {![file isfile $output]} { ArgError "Merge file \"$output\" is no such (is a directory)" } elseif {![file readable $output]} { ArgError "Merge file \"$output\" not readable (permission denied)" } elseif {![file writable $output]} { ArgError "Merge file \"$output\" not writable (permission denied)" } return } # ### ### ### ######### ######### ######### ## Helper commands. File reading and writing. proc ::tmc::Get {f} { return [read [set in [open $f r]]][close $in] } proc ::tmc::Write {f data} { puts -nonewline [set out [open $f w]] $data close $out return } # ### ### ### ######### ######### ######### ## Configuation phase, validate command line. ::tmc::processCmdline # ### ### ### ######### ######### ######### ## Helper command implementing the file merge functionality. proc ::tmc::Merge {f script} { set out {} set skip 0 foreach l [split [Get $f] \n] { if {$skip == 0} { lappend out $l if {[string match {*BEGIN GENERATED CODE*} $l]} { set skip 1 lappend out $script } } elseif {$skip == 1} { if {[string match {*END GENERATED CODE*} $l]} { lappend out $l set skip 2 } } else { # Skip == 2 lappend out $l } } Write $f [join $out \n] return } # ### ### ### ######### ######### ######### ## Invoking the functionality. if {[catch { # Read and process all input files. # Generate a single tcl procedure from them. # Write the result either to stdout, or merge # into the specified output file. set tcl [eval [linsert $tmc::magic 0 \ fileutil::magic::cfront::procdef \ $tmc::proc]] if {$tmc::output eq ""} { puts stdout $tcl } else { ::tmc::Merge $tmc::output \n${tcl}\n } } msg]} { puts $::errorInfo ::tmc::ArgError $msg } # ### ### ### ######### ######### ######### exit tcllib-1.15/modules/fumagic/filetypes.test0000644000175000017500000001274112077663116020235 0ustar sergeisergei# -*- tcl -*- # # Testing "fumagic" (FileUtil Magic). Filetype recognizer. # # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # # Copyright (c) 2005-2006 by Andreas Kupries # All rights reserved. # # RCS: @(#) $Id: filetypes.test,v 1.9 2006/10/09 21:41:40 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.4 testsNeedTcltest 1.0 catch {namespace delete ::fileutil::magic} support { useLocalFile fumagic.testsupport useLocal rtcore.tcl fileutil::magic::rt } testing { useLocal filetypes.tcl fileutil::magic::filetype } # ------------------------------------------------------------------------- # Now the package specific tests.... set path [makeFile {} bogus] removeFile bogus test fumagic.filetype-1.1 {test file non-existance} { set res [catch {fileutil::magic::filetype $path} msg] list $res $msg } [list 1 "file not found: \"$path\""] test fumagic.filetype-1.2 {test file directory} { set f [makeDirectory fileTypeTest] set res [catch {fileutil::magic::filetype $f} msg] regsub {file[0-9]+} $msg {fileXXX} msg removeDirectory fileTypeTest list $res $msg } {0 directory} test fumagic.filetype-1.3 {test file empty} { set f [makeEmptyFile] set res [catch {fileutil::magic::filetype $f} msg] removeEmptyFile list $res $msg } {0 {}} test fumagic.filetype-1.4 {test simple binary} { set f [makeBinFile] set res [catch {fileutil::magic::filetype $f} msg] removeBinFile list $res $msg } {0 {}} test fumagic.filetype-1.5 {test elf executable} { set f [makeElfFile] set res [catch {fileutil::magic::filetype $f} msg] removeElfFile list $res $msg } {0 {ELF 32-bit LSB AT&T WE32100 - invalid byte order, relocatable, \(\) \(SYSV\)}} test fumagic.filetype-1.6 {test simple text} { set f [makeTextFile] set res [catch {fileutil::magic::filetype $f} msg] removeTextFile list $res $msg } {0 {}} test fumagic.filetype-1.7 {test script file} { set f [makeScriptFile] set res [catch {fileutil::magic::filetype $f} msg] removeScriptFile list $res $msg } {0 {a /bin/tclsh script text executable}} test fumagic.filetype-1.8 {test html text} { set f [makeHtmlFile] set res [catch {fileutil::magic::filetype $f} msg] removeHtmlFile list $res $msg } {0 {HTML document text}} # 1.9/.10 possibly broken output. test fumagic.filetype-1.9 {test xml text} { set f [makeXmlFile] set res [catch {fileutil::magic::filetype $f} msg] removeXmlFile list $res $msg } {0 {XML document text \" XML XML %.3s document text broken XML document text}} test fumagic.filetype-1.10 {test xml with dtd text} { set f [makeXmlDTDFile] set res [catch {fileutil::magic::filetype $f} msg] removeXmlDTDFile list $res $msg } {0 {XML document text \" XML XML %.3s document text broken XML document text}} test fumagic.filetype-1.11 {test PGP message} { set f [makePGPFile] set res [catch {fileutil::magic::filetype $f} msg] removePGPFile list $res $msg } {0 {PGP armored data message}} test fumagic.filetype-1.12 {test binary graphic jpeg} { set f [makeJpegFile] set res [catch {fileutil::magic::filetype $f} msg] removeJpegFile list $res $msg } {0 {JPEG image data , JFIF standard 1. %02d , thumbnail 2x 2}} test fumagic.filetype-1.13 {test binary graphic gif} { set f [makeGifFile] set res [catch {fileutil::magic::filetype $f} msg] removeGifFile list $res $msg } {0 {GIF image data , version 89a,}} test fumagic.filetype-1.14 {test binary graphic png} { set f [makePngFile] set res [catch {fileutil::magic::filetype $f} msg] removePngFile list $res $msg } {0 {PNG image data, CORRUPTED, PNG image data, CORRUPTED}} test fumagic.filetype-1.15 {test binary graphic tiff} { set f [makeTiffFile] set res [catch {fileutil::magic::filetype $f} msg] removeTiffFile list $res $msg } {0 {TIFF image data, big-endian}} # 1.16 output possibly broken, missing substs. test fumagic.filetype-1.16 {test binary pdf} { set f [makePdfFile] set res [catch {fileutil::magic::filetype $f} msg] removePdfFile list $res $msg } {0 {PDF document , version %c .%c}} test fumagic.filetype-1.17 {test text ps} { set f [makePSFile] set res [catch {fileutil::magic::filetype $f} msg] removePSFile list $res $msg } {0 {PostScript document text}} test fumagic.filetype-1.18 {test text eps} { set f [makeEPSFile] set res [catch {fileutil::magic::filetype $f} msg] removeEPSFile list $res $msg } {0 {PostScript document text}} test fumagic.filetype-1.19 {test binary gravity_wave_data_frame} { set f [makeIgwdFile] set res [catch {fileutil::magic::filetype $f} msg] removeIgwdFile list $res $msg } {0 {}} test fumagic.filetype-1.20 {test binary compressed bzip} { set f [makeBzipFile] set res [catch {fileutil::magic::filetype $f} msg] removeBzipFile list $res $msg } {0 {bzip2 compressed data bzip compressed data , version: %c , compression block size 900k}} test fumagic.filetype-1.21 {test binary compressed gzip} { set f [makeGzipFile] set res [catch {fileutil::magic::filetype $f} msg] removeGzipFile list $res $msg } {0 {gzip compressed data , unknown method , ASCII , from MS-DOS}} testsuiteCleanup return tcllib-1.15/modules/fumagic/fumagic.testsupport0000644000175000017500000000363112077663116021277 0ustar sergeisergei# -*- tcl -*- # Testsuite support specific to 'fileutil::magic'. # ### ### ### ######### ######### ######### # This file can assume that the general testsupport (see # devtools/testutilities.tcl) is already loaded and active. # ### ### ### ######### ######### ######### ## Transient variables to hold more complex texts set xmlData { } set xmlDataWithDTD { } set pgpData {-----BEGIN PGP MESSAGE----- Version: PGP 6.5.8 abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz } # ### ### ### ######### ######### ######### ## Creates a series of commands for the creation of small data files ## for various file formats. foreach {name data} [list \ Empty {} \ Bin "\u0000" \ Elf [cat "\x7F" "ELF" "\x01\x01\x01\x00\x00"] \ Bzip "BZh91AY&SY\x01\x01\x01\x00\x00" \ Gzip "\x1f\x8b\x01\x01\x01\x00\x00" \ Jpeg [cat "\xFF\xD8\xFF\xE0\x00\x10JFIF" "\x00\x01\x02\x01\x01\x2c"] \ Gif "GIF89a\x2b\x00\x40\x00\xf7\xff\x00" \ Png "\x89PNG\x00\x01\x02\x01\x01\x2c" \ Tiff "MM\x00\*\x00\x01\x02\x01\x01\x2c" \ Pdf "%PDF-1.2 \x00\x01\x02\x01\x01\x2c" \ Igwd "IGWD\x00\x01\x02\x01\x01\x2c" ] { proc make${name}File {} [list makeBinaryFile $data $name] proc remove${name}File {} [list removeFile $name] } foreach {name data} [list \ PS "%!PS-ADOBO-123 EPSF-1.4" \ EPS "%!PS-ADOBO-123 EPSF-1.4" \ Text "simple text" \ Script "#!/bin/tclsh" \ Html "" \ Xml $xmlData \ XmlDTD $xmlDataWithDTD \ PGP $pgpData ] { proc make${name}File {} [list makeFile $data $name] proc remove${name}File {} [list removeFile $name] } # ### ### ### ######### ######### ######### ## Clean up the transient globals. unset xmlData unset xmlDataWithDTD unset pgpData # ### ### ### ######### ######### ######### tcllib-1.15/modules/fumagic/ChangeLog0000644000175000017500000002005612104363437017072 0ustar sergeisergei2013-02-01 Andreas Kupries * * Released and tagged Tcllib 1.15 ======================== * 2011-12-13 Andreas Kupries * * Released and tagged Tcllib 1.14 ======================== * 2011-01-24 Andreas Kupries * * Released and tagged Tcllib 1.13 ======================== * 2009-12-07 Andreas Kupries * * Released and tagged Tcllib 1.12 ======================== * 2008-12-12 Andreas Kupries * * Released and tagged Tcllib 1.11.1 ======================== * 2008-10-16 Andreas Kupries * * Released and tagged Tcllib 1.11 ======================== * 2008-06-12 Andreas Kupries * fileutil_magic_cfront.pcx: New file. Syntax definitions for the * fileutil_magic_cgen.pcx: public commands of the fileutil::magic * fileutil_magic_filetype.pcx: packages. * fileutil_magic_mimetype.pcx: * fileutil_magic_rt.pcx: 2008-03-24 Andreas Kupries * cfront.man: Fixed typo in the new documentation. 2008-03-21 Andreas Kupries * rtcore.man: Added documentation for the runtime package * cgen.man: 'fileutil::magic::rt', and the two compiler packages * cfront.man: 'fileutil::magic::cgen' and 'fileutil::magic::cfront'. * cfront.tcl: Fixed a typo in the export clause. 2007-09-12 Andreas Kupries * * Released and tagged Tcllib 1.10 ======================== * 2007-09-12 Andreas Kupries * filetypes.man: Fixed typos in the documentation, incomplete * mimetypes.man: command names. Fixes [SF Bug 1791379]. 2007-06-22 Andreas Kupries * cfront.tcl: Replaced deprecated {expand} syntax in comments with * cgen.tcl: {*}. 2007-03-21 Andreas Kupries * mimetypes.man: Fixed all warnings due to use of now deprecated * filetypes.man: commands. Added a section about how to give feedback. 2006-10-03 Andreas Kupries * * Released and tagged Tcllib 1.9 ======================== * 2006-09-27 Andreas Kupries * filetypes.tcl: [SF Tcllib Bug 1329207]. Extended commands with * mimetypes.tcl: hardwired check for directory as that cannot be * filetypes.man: done by the generated code. Bumped version to * mimetypes.man: 1.0.2. * filetypes.test: * mimetypes.test: * pkgIndex.tcl: 2006-09-19 Andreas Kupries * mimetypes.man: Bumped versions to 1.0.1 * mimetypes.tcl: * filetypes.man: * filetypes.tcl: * pkgIndex.tcl: 2006-01-28 Andreas Kupries * filetypes.test: Fixed usage of temp. files by the testsuites. * mimetypes.test: * fumagic.testsupport: New file, common definitions for the testsuite. 2006-01-22 Andreas Kupries * filestypes.test: More boilerplate simplified via use of test support. * mimetypes.test: * filetypes.tcl: Added proper set up of the package namespace, * mimetypes.tcl: paranoid code, 'rtcore' should have done it already. 2006-01-19 Andreas Kupries * filetypes.test: Hooked into the new common test support code. * mimetypes.test: 2005-12-09 Andreas Kupries * mimetypes.man: Corrected package names used in the * filetypes.man: manpage headings. 2005-10-06 Andreas Kupries * * Released and tagged Tcllib 1.8 ======================== * 2005-09-19 Andreas Kupries * filetypes.test (fumagic.filetype-1.2): Modified test result to * mimetypes.test (fumagic.mimetype-1.2): make it independent of the exact channel handle listed in the error message. Has changed with Tcl 8.5. 2005-03-16 Andreas Kupries * Fixed typos in the manpage headers. 2005-02-17 Andreas Kupries * tmc: Added basic magic compiler, and script to * regenerate.sh: regenerate the recognizers. * filetypes.tcl: Added general recognizer for file types, * filetypes.man: tests, and documentation for it. * filetypes.test: WARNING. This recognizer is LARGE. 2005-02-16 Andreas Kupries * rtcore.tcl: Added the Nvx, Nx, and Sx commands to handle the generation of location data for use by the R command for the handling of relative addressing. * cgen.tcl: * rtcore.tcl: Rewritten the intialization of the typemap, fixing bugs in the definition of the types using native byteorder instead of explicitly specified big/little endian. * mimetypes,man: Added REFERENCES section, and olisted url where Colin found the sources of file(1) and of the magic files used. 2005-02-15 Andreas Kupries * rtcore.tcl: Added commands I, R, and L to support indirect and relative adressing. * cgen.tcl: Rewrote the whole offset handling in the generator, to support all types of offsets, i.e relative, indirect and indirect relative ones. A new stage now parses all offsets into standard components. The treegen stage then assembles proper base handling using new rtcore commands (I, R). Also now saving indicators about which branches actually need saving of field locations for relative adressing, this is used to optimize usage of check commands with saving (Nx, Sx, Nvx), and when to regenerate the level information (L). The latter is an implicit variable in the generated recognizer procedure, accessed via 'upvar 1' from the runtime commands. 2005-02-14 Andreas Kupries * cfront.tcl: More fixes and 8.5 feature removal for the * cgen.tcl: compiler packages. 2005-02-10 Andreas Kupries * cgen.tcl: Removed usage of catch 8.5 feature. * cfront.tcl: Fixed bad reference to file/scope local command. Repaced usage 0f 8.5 feature 'lrepeat' with forward compatibility command provided by 'struct::list'. * cgen.tcl: Moved the 'provide' definition to the front, so that * cfront.tcl: sak recognizes it and registers the provision of a * mimetypes.tcl: package when validating the module. * mimetypes.man: Basic documentation for the main recognizer command. * mimetypes.test: Copied the filetype tests from fileutil over for use by the mimetype command, and adapted the results. Only four places where the result can be said to be bogus * mimetypes.tcl: Added code to remove duplicates from the output of the low-level recognizer. * rtcore.tcl: Added 'resultv' command which does not stop processing in the caller as well. Needed by our wrapper. * mimetypes.tcl: Moved code in 'magic.tcl' to * magic.tcl: 'mimetypes.tcl'. There is no need for a highlevel package loading all the different recognizers. Each recognizer is fully in its own package now. That makes the addition of more recognizers easier, without causing the wrapper to load more and more unneeded code. Things are large as they are, no need to make them larger. Deleted "magic.tcl". 2005-02-09 Andreas Kupries * New module 'fumagic'. file(1) magic(5) based file type recognition, in pure Tcl. Basic packages: runtime core, mime-type engine, and a command wrapping the functionality for easy access. The mime-type engine is not exactly so, it is possible for to produce non-mime strings. We keep it for now until the compiler has been put into this module as well. * rtcore.tcl: Runtime core. * magic-mime.tcl: Mime engine * magic.tcl: Wrapper. * Compiler packages now present as well * cgen.tcl: Backend, tree-based code generator * cfront.tcl: Frontend, parsing of magic(5) files. tcllib-1.15/modules/fumagic/fileutil_magic_cfront.pcx0000644000175000017500000000201312077663116022363 0ustar sergeisergei# -*- tcl -*- fileutil::magic::cfront.pcx # Syntax of the commands provided by package fileutil::magic::cfront. # # For use by TclDevKit's static syntax checker (v4.1+). # See http://www.activestate.com/solutions/tcl/ # See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api # for the specification of the format of the code in this file. # package require pcx pcx::register fileutil::magic::cfront pcx::tcldep 1.0 needs tcl 8.4 namespace eval ::fileutil::magic::cfront {} #pcx::message FOO {... text ...} type #pcx::scan pcx::check 1.0 std ::fileutil::magic::cfront::compile \ {checkSimpleArgs 1 -1 { checkFileName }} pcx::check 1.0 std ::fileutil::magic::cfront::install \ {checkSimpleArgs 1 -1 { checkFileName }} pcx::check 1.0 std ::fileutil::magic::cfront::procdef \ {checkSimpleArgs 2 -1 { checkWord checkFileName }} # Initialization via pcx::init. # Use a ::fileutil::magic::cfront::init procedure for non-standard initialization. pcx::complete tcllib-1.15/modules/fumagic/fileutil_magic_filetype.pcx0000644000175000017500000000146212077663116022720 0ustar sergeisergei# -*- tcl -*- fileutil::magic::filetype.pcx # Syntax of the commands provided by package fileutil::magic::filetype. # # For use by TclDevKit's static syntax checker (v4.1+). # See http://www.activestate.com/solutions/tcl/ # See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api # for the specification of the format of the code in this file. # package require pcx pcx::register fileutil::magic::filetype pcx::tcldep 1.0.2 needs tcl 8.4 namespace eval ::fileutil::magic::filetype {} #pcx::message FOO {... text ...} type #pcx::scan pcx::check 1.0.2 std ::fileutil::magic::filetype \ {checkSimpleArgs 1 1 { checkFileName }} # Initialization via pcx::init. # Use a ::fileutil::magic::filetype::init procedure for non-standard initialization. pcx::complete tcllib-1.15/modules/fumagic/fileutil_magic_rt.pcx0000644000175000017500000000577612077663116021540 0ustar sergeisergei# -*- tcl -*- fileutil::magic::rt.pcx # Syntax of the commands provided by package fileutil::magic::rt. # # For use by TclDevKit's static syntax checker (v4.1+). # See http://www.activestate.com/solutions/tcl/ # See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api # for the specification of the format of the code in this file. # package require pcx pcx::register fileutil::magic::rt pcx::tcldep 1.0 needs tcl 8.4 namespace eval ::fileutil::magic::rt {} #pcx::message FOO {... text ...} type #pcx::scan pcx::check 1.0 std ::fileutil::magic::rt::I \ {checkSimpleArgs 3 3 { checkWholeNum fileutil::magic::rt::checkType checkInt }} pcx::check 1.0 std ::fileutil::magic::rt::L \ {checkSimpleArgs 1 1 { checkWholeNum }} pcx::check 1.0 std ::fileutil::magic::rt::N \ {checkSimpleArgs 4 5 { fileutil::magic::rt::checkType checkWholeNum {checkKeyword 1 {x < > <= >= == !=}} checkInt checkWord }} # TODO: syntax of qualifiers. pcx::check 1.0 std ::fileutil::magic::rt::Nv \ {checkSimpleArgs 2 3 { fileutil::magic::rt::checkType checkWholeNum checkWord }} pcx::check 1.0 std ::fileutil::magic::rt::Nvx \ {checkSimpleArgs 3 4 { checkWholeNum fileutil::magic::rt::checkType checkWholeNum checkWord }} pcx::check 1.0 std ::fileutil::magic::rt::Nx \ {checkSimpleArgs 5 6 { checkWholeNum fileutil::magic::rt::checkType checkWholeNum {checkKeyword 1 {x < > <= >= == !=}} checkInt checkWord }} pcx::check 1.0 std ::fileutil::magic::rt::R \ {checkSimpleArgs 1 1 { checkWholeNum }} pcx::check 1.0 std ::fileutil::magic::rt::S \ {checkSimpleArgs 3 4 { checkWholeNum {checkKeyword 1 {x < > <= >= == !=}} checkInt checkWord }} pcx::check 1.0 std ::fileutil::magic::rt::Sx \ {checkSimpleArgs 4 -5 { checkWholeNum checkWholeNum {checkKeyword 1 {x < > <= >= == !=}} checkInt checkWord }} pcx::check 1.0 std ::fileutil::magic::rt::close \ {checkAtEnd} # TODO: check string for the special placeholders pcx::check 1.0 std ::fileutil::magic::rt::emit \ {checkSimpleArgs 1 1 { checkWord }} pcx::check 1.0 std ::fileutil::magic::rt::file_start \ {checkSimpleArgs 1 1 { checkWord }} # TODO: syntax of complex offsets. pcx::check 1.0 std ::fileutil::magic::rt::offset \ {checkSimpleArgs 1 1 { checkWord }} pcx::check 1.0 std ::fileutil::magic::rt::open \ {checkSimpleArgs 1 1 { checkFileName }} # TODO: check string for the special placeholders pcx::check 1.0 std ::fileutil::magic::rt::result \ {checkSimpleArgs 0 1 { checkWord }} pcx::check 1.0 std ::fileutil::magic::rt::resultv \ {checkSimpleArgs 0 1 { checkWord }} proc fileutil::magic::rt::checkType {t i} { return [checkKeyword 1 {c s S i I Q Y date bedate ledate ldatebeldate leldate byte short beshort leshort long belong lelong ubyte ushort ubeshort uleshort ulong ubelong ulelong} $t $i] } # Initialization via pcx::init. # Use a ::fileutil::magic::rt::init procedure for non-standard initialization. pcx::complete tcllib-1.15/modules/fumagic/pkgIndex.tcl0000644000175000017500000000105312077663116017577 0ustar sergeisergeiif {![package vsatisfies [package provide Tcl] 8.4]} {return} # Recognizers package ifneeded fileutil::magic::filetype 1.0.2 [list source [file join $dir filetypes.tcl]] package ifneeded fileutil::magic::mimetype 1.0.2 [list source [file join $dir mimetypes.tcl]] # Runtime package ifneeded fileutil::magic::rt 1.0 [list source [file join $dir rtcore.tcl]] # Compiler packages package ifneeded fileutil::magic::cgen 1.0 [list source [file join $dir cgen.tcl]] package ifneeded fileutil::magic::cfront 1.0 [list source [file join $dir cfront.tcl]] tcllib-1.15/modules/fumagic/cfront.man0000644000175000017500000000464712077663116017326 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin fileutil::magic::cfront n 1.0] [moddesc {file utilities}] [titledesc {Generator core for compiler of magic(5) files}] [category {Programming tools}] [require Tcl 8.4] [require fileutil::magic::cfront [opt 1.0]] [require fileutil::magic::cgen [opt 1.0]] [require fileutil::magic::rt [opt 1.0]] [require struct::list] [require fileutil] [description] [para] This package provides the frontend of a compiler of magic(5) files into recognizers based on the [package fileutil::magic::rt] recognizer runtime package. For the generator backed used by this compiler see the package [package fileutil::magic::cgen]. [section COMMANDS] [list_begin definitions] [call [cmd ::fileutil::magic::cfront::compile] [arg path]...] This command takes the paths of one or more files and directories and compiles all the files, and the files in all the directories into a single recognizer for all the file types specified in these files. [para] All the files have to be in the format specified by magic(5). [para] The result of the command is a Tcl script containing the generated recognizer. [call [cmd ::fileutil::magic::cfront::procdef] [arg procname] [arg path]...] This command behaves like [cmd ::fileutil::magic::cfront::compile] with regard to the specified path arguments, then wraps the resulting recognizer script into a procedure named [arg procname], puts code setting up the namespace of [arg procname] in front, and returns the resulting script. [call [cmd ::fileutil::magic::cfront::install] [arg path]...] This command uses [cmd ::fileutil::magic::cfront::procdef] to compile each of the paths into a recognizer procedure and installs the result in the current interpreter. [para] The name of each new procedure is derived from the name of the file/directory used in its creation, with file/directory [file FOO] causing the creation of procedure [const ::fileutil::magic::/FOO::run]. [list_end] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph {fileutil :: magic}] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [see_also fileutil file(1) magic(5)] [keywords type mime {file utilities} {file type} {file recognition}] [manpage_end] tcllib-1.15/modules/fumagic/cfront.tcl0000644000175000017500000002561712077663116017335 0ustar sergeisergei# cfront.tcl -- # # Generator frontend for compiler of magic(5) files into recognizers # based on the 'rtcore'. Parses magic(5) into a basic 'script'. # # Copyright (c) 2004-2005 Colin McCormack # Copyright (c) 2005 Andreas Kupries # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: cfront.tcl,v 1.7 2008/03/22 01:10:32 andreas_kupries Exp $ ##### # # "mime type recognition in pure tcl" # http://wiki.tcl.tk/12526 # # Tcl code harvested on: 10 Feb 2005, 04:06 GMT # Wiki page last updated: ??? # ##### # ### ### ### ######### ######### ######### ## Requirements package require Tcl 8.4 # file to compile the magic file from magic(5) into a tcl program package require fileutil ; # File processing (input) package require fileutil::magic::cgen ; # Code generator. package require fileutil::magic::rt ; # Runtime (typemap) package require struct::list ; # lrepeat. package provide fileutil::magic::cfront 1.0 # ### ### ### ######### ######### ######### ## Implementation namespace eval ::fileutil::magic::cfront { # Configuration flag. (De)activate debugging output. # This is done during initialization. # Changes at runtime have no effect. variable debug 0 # Constants variable hashprotection [list "\#" "\\#" \" \\\" \{ \\\{ \} \\\}] ;#" variable hashprotectionB [list "\#" "\\\#" \" \\\" \} \\\} ( \\( ) \\)] ;#" # Make backend functionality accessible namespace import ::fileutil::magic::cgen::* namespace export compile procdef install } # parse an individual line proc ::fileutil::magic::cfront::parseline {line {maxlevel 10000}} { # calculate the line's level set unlevel [string trimleft $line >] set level [expr {[string length $line] - [string length $unlevel]}] if {$level > $maxlevel} { return -code continue "Skip - too high a level" } # regexp parse line into (offset, type, value, command) set parse [regexp -expanded -inline {^(\S+)\s+(\S+)\s*((\S|(\B\s))*)\s*(.*)$} $unlevel] if {$parse == {}} { error "Can't parse: '$unlevel'" } # unpack parsed line set value "" set command "" foreach {junk offset type value junk1 junk2 command} $parse break # handle trailing spaces if {[string index $value end] eq "\\"} { append value " " } if {[string index $command end] eq "\\"} { append command " " } if {$value eq ""} { # badly formatted line return -code error "no value" } ::fileutil::magic::cfront::Debug { puts "level:$level offset:$offset type:$type value:'$value' command:'$command'" } # return the line's fields return [list $level $offset $type $value $command] } # process a magic file proc ::fileutil::magic::cfront::process {file {maxlevel 10000}} { variable hashprotection variable hashprotectionB variable level ;# level of line variable linenum ;# line number set level 0 set script {} set linenum 0 ::fileutil::foreachLine line $file { incr linenum set line [string trim $line " "] if {[string index $line 0] eq "#"} { continue ;# skip comments } elseif {$line == ""} { continue ;# skip blank lines } else { # parse line if {[catch {parseline $line $maxlevel} parsed]} { continue ;# skip erroring lines } # got a valid line foreach {level offset type value message} $parsed break # strip comparator out of value field, # (they are combined) set compare [string index $value 0] switch -glob -- $value { [<>]=* { set compare [string range $value 0 1] set value [string range $value 2 end] } <* - >* - &* - ^* { set value [string range $value 1 end] } =* { set compare "==" set value [string range $value 1 end] } !* { set compare "!=" set value [string range $value 1 end] } x { # this is the 'don't care' match # used for collecting values set value "" } default { # the default comparator is equals set compare "==" if {[string match {\\[=]*} $value]} { set value [string range $value 1 end] } } } # process type field set qual "" switch -glob -- $type { pstring* - string* { # String or Pascal string type # extract string match qualifiers foreach {type qual} [split $type /] break # convert pstring to string + qualifier if {$type eq "pstring"} { append qual "p" set type "string" } # protect hashes in output script value set value [string map $hashprotection $value] if {($value eq "\\0") && ($compare eq ">")} { # record 'any string' match set value "" set compare x } elseif {$compare eq "!="} { # string doesn't allow !match set value !$value set compare "==" } if {$type ne "string"} { # don't let any odd string types sneak in puts stderr "Reject String: ${file}:$linenum $type - $line" continue } } regex { # I am *not* going to handle regex puts stderr "Reject Regex: ${file}:$linenum $type - $line" continue } *byte* - *short* - *long* - *date* { # Numeric types # extract numeric match &qualifiers set type [split $type &] set qual [lindex $type 1] if {$qual ne ""} { # this is an &-qualifier set qual &$qual } else { # extract -qualifier from type set type [split $type -] set qual [lindex $type 1] if {$qual ne ""} { set qual -$qual } } set type [lindex $type 0] # perform value adjustments if {$compare ne "x"} { # trim redundant Long value qualifier set value [string trimright $value L] if {[catch {set value [expr $value]} x]} { upvar #0 errorInfo eo # check that value is representable in tcl puts stderr "Reject Value Error: ${file}:$linenum '$value' '$line' - $eo" continue; } # coerce numeric value into hex set value [format "0x%x" $value] } } default { # this is not a type we can handle puts stderr "Reject Unknown Type: ${file}:$linenum $type - $line" continue } } } # collect some summaries ::fileutil::magic::cfront::Debug { variable types set types($type) $type variable quals set quals($qual) $qual } #puts $linenum level:$level offset:$offset type:$type #puts qual:$qual compare:$compare value:'$value' message:'$message' # protect hashes in output script message set message [string map $hashprotectionB $message] if {![string match "(*)" $offset]} { catch {set offset [expr $offset]} } # record is the complete match command, # encoded for tcl code generation set record [list $linenum $type $qual $compare $offset $value $message] if {$script == {}} { # the original script has level 0, # regardless of what the script says set level 0 } if {$level == 0} { # add a new 0-level record lappend script $record } else { # find the growing edge of the script set depth [::struct::list repeat [expr $level] end] while {[catch { # get the insertion point set insertion [eval [linsert $depth 0 lindex $script]] # 8.5 # set insertion [lindex $script {*}$depth] }]} { # handle scripts which jump levels, # reduce depth to current-depth+1 set depth [lreplace $depth end end] } # add the record at the insertion point lappend insertion $record # re-insert the record into its correct position eval [linsert [linsert $depth 0 lset script] end $insertion] # 8.5 # lset script {*}$depth $insertion } } #puts "Script: $script" return $script } # compile up magic files or directories of magic files into a single recognizer. proc ::fileutil::magic::cfront::compile {args} { set tcl "" set script {} foreach arg $args { if {[file type $arg] == "directory"} { foreach file [glob [file join $arg *]] { set script1 [process $file] eval [linsert $script1 0 lappend script [list file $file]] # 8.5 # lappend script [list file $file] {*}$script1 #append tcl "magic::file_start $file" \n #append tcl [run $script1] \n } } else { set file $arg set script1 [process $file] eval [linsert $script1 0 lappend script [list file $file]] # 8.5 # lappend script [list file $file] {*}$script1 #append tcl "magic::file_start $file" \n #append tcl [run $script1] \n } } #puts stderr $script ::fileutil::magic::cfront::Debug {puts "\# $args"} set t [2tree $script] set tcl [treegen $t root] append tcl "\nreturn \{\}" ::fileutil::magic::cfront::Debug {puts [treedump $t]} #set tcl [run $script] return $tcl } proc ::fileutil::magic::cfront::procdef {procname args} { set pspace [namespace qualifiers $procname] if {$pspace eq ""} { return -code error "Cannot generate recognizer in the global namespace" } set script {} lappend script "package require fileutil::magic::rt" lappend script "namespace eval [list ${pspace}] \{" lappend script " namespace import ::fileutil::magic::rt::*" lappend script "\}" lappend script "" lappend script [list proc ${procname} {} \n[eval [linsert $args 0 compile]]\n] return [join $script \n] } proc ::fileutil::magic::cfront::install {args} { foreach arg $args { set path [file tail $arg] eval [procdef ::fileutil::magic::/${path}::run $arg] } return } # ### ### ### ######### ######### ######### ## Internal, debugging. if {!$::fileutil::magic::cfront::debug} { # This procedure definition is optimized out of using code by the # core bcc. It knows that neither argument checks are required, # nor is anything done. So neither results, nor errors are # possible, a true no-operation. proc ::fileutil::magic::cfront::Debug {args} {} } else { proc ::fileutil::magic::cfront::Debug {script} { # Run the commands in the debug script. This usually generates # some output. The uplevel is required to ensure the proper # resolution of all variables found in the script. uplevel 1 $script return } } #set script [magic::compile {} /usr/share/misc/file/magic] #puts "\# types:[array names magic::types]" #puts "\# quals:[array names magic::quals]" #puts "Script: $script" # ### ### ### ######### ######### ######### ## Ready for use. # EOF tcllib-1.15/modules/fumagic/mimetypes.tcl0000644000175000017500000013017412077663116020051 0ustar sergeisergei# mimetypes.tcl -- # # Tcl based file type recognizer using the runtime core and # generated from /usr/share/misc/magic.mime. Limited output, # but only mime-types, i.e. standardized. # # Copyright (c) 2004-2005 Colin McCormack # Copyright (c) 2005-2006 Andreas Kupries # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: mimetypes.tcl,v 1.8 2006/09/27 21:19:35 andreas_kupries Exp $ ##### # # "mime type discriminator" # http://wiki.tcl.tk/12537 # # Tcl code harvested on: 10 Feb 2005, 04:16 GMT # Wiki page last updated: ??? # ##### # ### ### ### ######### ######### ######### ## Requirements. package require Tcl 8.4 package require fileutil::magic::rt ; # We need the runtime core. # ### ### ### ######### ######### ######### ## Implementation namespace eval ::fileutil::magic {} proc ::fileutil::magic::mimetype {file} { if {![file exists $file]} { return -code error "file not found: \"$file\"" } if {[file isdirectory $file]} { return application/x-directory } rt::open $file mimetype::run rt::close set types [rt::resultv] if {[llength $types]} { # We postprocess the data if needed, as the low-level # recognizer can return duplicate information. array set _ {} set utypes {} foreach t $types { if {[info exists _($t)]} continue lappend utypes $t set _($t) . set types $utypes } } return $types } package provide fileutil::magic::mimetype 1.0.2 # The actual recognizer is the command below. ## ## -- Do not edit after this line ! ## -- ** BEGIN GENERATED CODE ** -- package require fileutil::magic::rt namespace eval ::fileutil::magic::mimetype { namespace import ::fileutil::magic::rt::* } proc ::fileutil::magic::mimetype::run {} { switch -- [Nv s 0 ] 1538 {emit application/x-alan-adventure-game} 387 {emit application/x-executable-file} -147 {emit application/data} -155 {emit application/data} -5536 {emit application/x-arj} -138 {emit application/data} -394 {emit application/data} -650 {emit application/x-lzh} 387 {emit application/x-executable-file} 392 {emit application/x-executable-file} 399 {emit application/x-object-file} -13230 {emit {RLE image data,}} 322 {emit {basic-16 executable}} 323 {emit {basic-16 executable \(TV\)}} 328 {emit application/x-executable-file} 329 {emit application/x-executable-file} 330 {emit application/x-executable-file} 338 {emit application/x-executable-file} 332 {emit application/x-executable-file} 1078 {emit font/linux-psf} 387 {emit {ECOFF alpha}} 332 {emit {MS Windows COFF Intel 80386 object file}} 358 {emit {MS Windows COFF MIPS R4000 object file}} 388 {emit {MS Windows COFF Alpha object file}} 616 {emit {MS Windows COFF Motorola 68000 object file}} 496 {emit {MS Windows COFF PowerPC object file}} 656 {emit {MS Windows COFF PA-RISC object file}} 263 {emit {PDP-11 executable}} 257 {emit {PDP-11 UNIX/RT ldp}} 261 {emit {PDP-11 old overlay}} 264 {emit {PDP-11 pure executable}} 265 {emit {PDP-11 separate I&D executable}} 287 {emit {PDP-11 kernel overlay}} 4843 {emit {SYMMETRY i386 .o}} 8939 {emit {SYMMETRY i386 executable \(0 @ 0\)}} 13035 {emit {SYMMETRY i386 executable \(invalid @ 0\)}} 17131 {emit {SYMMETRY i386 standalone executable}} 376 {emit {VAX COFF executable}} 381 {emit {VAX COFF pure executable}} -155 {emit x.out} 518 {emit {Microsoft a.out}} 320 {emit {old Microsoft 8086 x.out}} 1408 {emit {XENIX 8086 relocatable or 80286 small model}} if {[S 0 == TADS ]} {emit application/x-tads-game} switch -- [Nv S 0 ] 272 {emit application/x-executable-file} 273 {emit application/x-executable-file} 29127 {emit application/x-cpio} -14479 {emit application/x-bcpio} -147 {emit application/data} -155 {emit application/data} 368 {emit application/x-executable-file} 369 {emit application/x-executable-file} 1793 {emit application/x-executable-file} 262 {emit application/x-executable-file} 1537 {emit application/x-executable-file} 381 {emit application/x-executable-file} 383 {emit application/x-executable-file} 7967 {emit application/data} 8191 {emit application/data} -13563 {emit application/data} 1281 {emit application/x-locale} 340 {emit application/data} 341 {emit application/x-executable-file} 286 {emit font/x-vfont} 7681 {emit font/x-vfont} 407 {emit application/x-executable-file} 404 {emit application/x-executable-file} 200 {emit {hp200 \(68010\) BSD}} 300 {emit {hp300 \(68020+68881\) BSD}} 351 {emit {370 XA sysV executable}} 346 {emit {370 XA sysV pure executable}} 22529 {emit {370 sysV pure executable}} 23041 {emit {370 XA sysV pure executable}} 23809 {emit {370 sysV executable}} 24321 {emit {370 XA sysV executable}} 345 {emit {SVR2 executable \(Amdahl-UTS\)}} 348 {emit {SVR2 pure executable \(Amdahl-UTS\)}} 344 {emit {SVR2 pure executable \(USS/370\)}} 349 {emit {SVR2 executable \(USS/370\)}} 479 {emit {executable \(RISC System/6000 V3.1\) or obj module}} 260 {emit {shared library}} 261 {emit {ctab data}} -508 {emit {structured file}} 12320 {emit {character Computer Graphics Metafile}} -40 {emit image/jpeg} 474 {emit x/x-image-sgi} 4112 {emit {PEX Binary Archive}} -21267 {emit {Java serialization data}} -32768 {emit {lif file}} 256 {emit {raw G3 data, byte-padded}} 5120 {emit {raw G3 data}} 336 {emit {mc68k COFF}} 337 {emit {mc68k executable \(shared\)}} 338 {emit {mc68k executable \(shared demand paged\)}} 364 {emit {68K BCS executable}} 365 {emit {88K BCS executable}} 392 {emit {Tower/XP rel 2 object}} 397 {emit {Tower/XP rel 2 object}} 400 {emit {Tower/XP rel 3 object}} 405 {emit {Tower/XP rel 3 object}} 408 {emit {Tower32/600/400 68020 object}} 416 {emit {Tower32/800 68020}} 421 {emit {Tower32/800 68010}} -30771 {emit {OS9/6809 module:}} 19196 {emit {OS9/68K module:}} 373 {emit {i386 COFF object}} 10775 {emit {\"compact bitmap\" format \(Poskanzer\)}} -26368 {emit {PGP key public ring}} -27391 {emit {PGP key security ring}} -27392 {emit {PGP key security ring}} -23040 {emit {PGP encrypted data}} 601 {emit {mumps avl global}} 602 {emit {mumps blt global}} -4693 {emit {}} 10012 {emit {Sendmail frozen configuration}} -30875 {emit {disk quotas file}} 1286 {emit {IRIS Showcase file}} 550 {emit {IRIS Showcase template}} 352 {emit {MIPSEB COFF executable}} 354 {emit {MIPSEL COFF executable}} 24577 {emit {MIPSEB-LE COFF executable}} 25089 {emit {MIPSEL-LE COFF executable}} 355 {emit {MIPSEB MIPS-II COFF executable}} 358 {emit {MIPSEL MIPS-II COFF executable}} 25345 {emit {MIPSEB-LE MIPS-II COFF executable}} 26113 {emit {MIPSEL-LE MIPS-II COFF executable}} 320 {emit {MIPSEB MIPS-III COFF executable}} 322 {emit {MIPSEL MIPS-III COFF executable}} 16385 {emit {MIPSEB-LE MIPS-III COFF executable}} 16897 {emit {MIPSEL-LE MIPS-III COFF executable}} 384 {emit {MIPSEB Ucode}} 386 {emit {MIPSEL Ucode}} -16162 {emit {Compiled PSI \(v1\) data}} -16166 {emit {Compiled PSI \(v2\) data}} -21846 {emit {SoftQuad DESC or font file binary}} 283 {emit {Curses screen image}} 284 {emit {Curses screen image}} 263 {emit {unknown machine executable}} 264 {emit {unknown pure executable}} 265 {emit {PDP-11 separate I&D}} 267 {emit {unknown pure executable}} 392 {emit {Perkin-Elmer executable}} 378 {emit {amd 29k coff noprebar executable}} 890 {emit {amd 29k coff prebar executable}} -8185 {emit {amd 29k coff archive}} 21845 {emit {VISX image file}} if {[S 0 == {Core\001} ]} {emit application/x-executable-file} if {[S 0 == {AMANDA:\ TAPESTART\ DATE} ]} {emit application/x-amanda-header} switch -- [Nv I 0 ] 1011 {emit application/x-executable-file} 999 {emit application/x-library-file} 435 {emit video/mpeg} 442 {emit video/mpeg} 33132 {emit application/x-apl-workspace} 333312 {emit application/data} 333319 {emit application/data} 65389 {emit application/x-ar} 65381 {emit application/data} 33132 {emit application/x-apl-workspace} 1711210496 {emit application/x-ar} 1013019198 {emit application/x-ar} 557605234 {emit application/x-ar} 1314148939 {emit audio/x-multitrack} 779248125 {emit audio/x-pn-realaudio} 262 {emit application/x-executable-file} 327 {emit application/x-object-file} 331 {emit application/x-executable-file} 333 {emit application/x-executable-file} 335 {emit application/x-executable-file} 70231 {emit application/core} 385 {emit application/x-object-file} 391 {emit application/data} 324508366 {emit application/x-gdbm} 398689 {emit application/x-db} 340322 {emit application/x-db} 1234567 {emit image/x11} 4 {emit font/x-snf} 335698201 {emit font/x-libgrx} -12169394 {emit font/x-dos} 168757262 {emit application/data} 252317192 {emit application/data} 135137807 {emit application/data} 235409162 {emit application/data} 34603270 {emit application/x-object-file} 34603271 {emit application/x-executable-file} 34603272 {emit application/x-executable-file} 34603275 {emit application/x-executable-file} 34603278 {emit application/x-library-file} 34603277 {emit application/x-library-file} 34865414 {emit application/x-object-file} 34865415 {emit application/x-executable-file} 34865416 {emit application/x-executable-file} 34865419 {emit application/x-executable-file} 34865422 {emit application/x-library-file} 34865421 {emit application/x-object-file} 34275590 {emit application/x-object-file} 34275591 {emit application/x-executable-file} 34275592 {emit application/x-executable-file} 34275595 {emit application/x-executable-file} 34275598 {emit application/x-library-file} 34275597 {emit application/x-library-file} 557605234 {emit application/x-ar} 34078982 {emit application/x-executable-file} 34078983 {emit application/x-executable-file} 34078984 {emit application/x-executable-file} 34341128 {emit application/x-executable-file} 34341127 {emit application/x-executable-file} 34341131 {emit application/x-executable-file} 34341126 {emit application/x-executable-file} 34210056 {emit application/x-executable-file} 34210055 {emit application/x-executable-file} 34341134 {emit application/x-library-file} 34341133 {emit application/x-library-file} 65381 {emit application/x-library-file} 34275173 {emit application/x-library-file} 34406245 {emit application/x-library-file} 34144101 {emit application/x-library-file} 22552998 {emit application/core} 1302851304 {emit font/x-hp-windows} 34341132 {emit application/x-lisp} 505 {emit {AIX compiled message catalog}} 1123028772 {emit {Artisan image data}} 1504078485 {emit x/x-image-sun-raster} -889275714 {emit {compiled Java class data,}} -1195374706 {emit {Linux kernel}} 1886817234 {emit {CLISP memory image data}} -762612112 {emit {CLISP memory image data, other endian}} -569244523 {emit {GNU-format message catalog data}} -1794895138 {emit {GNU-format message catalog data}} -889275714 {emit {mach-o fat file}} -17958194 {emit mach-o} 31415 {emit {Mirage Assembler m.out executable}} 834535424 {emit text/vnd.ms-word} 6656 {emit {Lotus 1-2-3}} 512 {emit {Lotus 1-2-3}} 263 {emit {NetBSD big-endian object file}} 326773060 {emit font/x-sunos-news} 326773063 {emit font/x-sunos-news} 326773072 {emit font/x-sunos-news} 326773073 {emit font/x-sunos-news} 61374 {emit {OSF/Rose object}} -976170042 {emit {DOS EPS Binary File}} 1351614727 {emit {Pyramid 90x family executable}} 1351614728 {emit {Pyramid 90x family pure executable}} 1351614731 {emit {Pyramid 90x family demand paged pure executable}} 263 {emit {old SGI 68020 executable}} 264 {emit {old SGI 68020 pure executable}} 1396917837 {emit {IRIS Showcase file}} 1413695053 {emit {IRIS Showcase template}} -559039810 {emit {IRIX Parallel Arena}} -559043152 {emit {IRIX core dump}} -559043264 {emit {IRIX 64-bit core dump}} -1161903941 {emit {IRIX N32 core dump}} -1582119980 {emit {tcpdump capture file \(big-endian\)}} 263 {emit {old sun-2 executable}} 264 {emit {old sun-2 pure executable}} 267 {emit {old sun-2 demand paged executable}} 525398 {emit {SunOS core file}} -97271666 {emit {SunPC 4.0 Hard Disk}} 268 {emit {unknown demand paged pure executable}} 269 {emit {unknown demand paged pure executable}} 270 {emit {unknown readable demand paged pure executable}} 50331648 {emit {VMS Alpha executable}} 59399 {emit {object file \(z8000 a.out\)}} 59400 {emit {pure object file \(z8000 a.out\)}} 59401 {emit {separate object file \(z8000 a.out\)}} 59397 {emit {overlay object file \(z8000 a.out\)}} if {[N S 0 == 0xfff0 &0xfff0]} {emit audio/mpeg} switch -- [Nv s 4 ] -20719 {emit video/fli} -20718 {emit video/flc} if {[S 8 == {AVI\ } ]} {emit video/x-msvideo} if {[S 0 == MOVI ]} {emit video/x-sgi-movie} if {[S 4 == moov ]} {emit video/quicktime} if {[S 4 == mdat ]} {emit video/quicktime} if {[S 0 == FiLeStArTfIlEsTaRt ]} {emit text/x-apple-binscii} if {[S 0 == {\x0aGL} ]} {emit application/data} if {[S 0 == {\x76\xff} ]} {emit application/data} if {[S 0 == NuFile ]} {emit application/data} if {[S 0 == {N\xf5F\xe9l\xe5} ]} {emit application/data} if {[S 257 == {ustar\0} ]} {emit application/x-tar} if {[S 257 == {ustar\040\040\0} ]} {emit application/x-gtar} if {[S 0 == 070707 ]} {emit application/x-cpio} if {[S 0 == 070701 ]} {emit application/x-cpio} if {[S 0 == 070702 ]} {emit application/x-cpio} if {[S 0 == {!\ndebian} ]} {emit application/x-dpkg} if {[S 0 == ]} {emit application/x-ar} if {[S 0 == {!\n__________E} ]} {emit application/x-ar} if {[S 0 == -h- ]} {emit application/data} if {[S 0 == ! ]} {emit application/x-ar} if {[S 0 == ]} {emit application/x-ar} if {[S 0 == ]} {emit application/x-ar} switch -- [Nv i 0 ] 65389 {emit application/data} 65381 {emit application/data} 236525 {emit application/data} 236526 {emit application/data} 6583086 {emit audio/basic} 204 {emit application/x-executable-file} 324508366 {emit application/x-gdbm} 453186358 {emit application/x-bootable} 4 {emit font/x-snf} 1279543401 {emit application/data} 6553863 {emit {Linux/i386 impure executable \(OMAGIC\)}} 6553864 {emit {Linux/i386 pure executable \(NMAGIC\)}} 6553867 {emit {Linux/i386 demand-paged executable \(ZMAGIC\)}} 6553804 {emit {Linux/i386 demand-paged executable \(QMAGIC\)}} 263 {emit {NetBSD little-endian object file}} 459141 {emit {ECOFF NetBSD/alpha binary}} 33645 {emit {PDP-11 single precision APL workspace}} 33644 {emit {PDP-11 double precision APL workspace}} 234 {emit {BALANCE NS32000 .o}} 4330 {emit {BALANCE NS32000 executable \(0 @ 0\)}} 8426 {emit {BALANCE NS32000 executable \(invalid @ 0\)}} 12522 {emit {BALANCE NS32000 standalone executable}} -1582119980 {emit {tcpdump capture file \(little-endian\)}} 33647 {emit {VAX single precision APL workspace}} 33646 {emit {VAX double precision APL workspace}} 263 {emit {VAX executable}} 264 {emit {VAX pure executable}} 267 {emit {VAX demand paged pure executable}} 518 {emit b.out} switch -- [Nv i 0 &0x8080ffff] 2074 {emit application/x-arc} 2330 {emit application/x-arc} 538 {emit application/x-arc} 794 {emit application/x-arc} 1050 {emit application/x-arc} 1562 {emit application/x-arc} if {[S 0 == {\032archive} ]} {emit application/data} if {[S 0 == HPAK ]} {emit application/data} if {[S 0 == {\351,\001JAM\ } ]} {emit application/data} if {[S 2 == -lh0- ]} {emit application/x-lha} if {[S 2 == -lh1- ]} {emit application/x-lha} if {[S 2 == -lz4- ]} {emit application/x-lha} if {[S 2 == -lz5- ]} {emit application/x-lha} if {[S 2 == -lzs- ]} {emit application/x-lha} if {[S 2 == {-lh\40-} ]} {emit application/x-lha} if {[S 2 == -lhd- ]} {emit application/x-lha} if {[S 2 == -lh2- ]} {emit application/x-lha} if {[S 2 == -lh3- ]} {emit application/x-lha} if {[S 2 == -lh4- ]} {emit application/x-lha} if {[S 2 == -lh5- ]} {emit application/x-lha} if {[S 0 == Rar! ]} {emit application/x-rar} if {[S 0 == SQSH ]} {emit application/data} if {[S 0 == {UC2\x1a} ]} {emit application/data} if {[S 0 == {PK\003\004} ]} {emit application/zip} if {[N i 20 == 0xfdc4a7dc ]} {emit application/x-zoo} if {[S 10 == {\#\ This\ is\ a\ shell\ archive} ]} {emit application/x-shar} if {[S 0 == *STA ]} {emit application/data} if {[S 0 == 2278 ]} {emit application/data} if {[S 0 == {\000\004\036\212\200} ]} {emit application/core} if {[S 0 == .snd ]} {emit audio/basic} if {[S 0 == MThd ]} {emit audio/midi} if {[S 0 == CTMF ]} {emit audio/x-cmf} if {[S 0 == SBI ]} {emit audio/x-sbi} if {[S 0 == {Creative\ Voice\ File} ]} {emit audio/x-voc} if {[S 0 == RIFF ]} {emit audio/x-wav} if {[S 8 == AIFC ]} {emit audio/x-aifc} if {[S 8 == AIFF ]} {emit audio/x-aiff} if {[S 0 == {.ra\375} ]} {emit audio/x-real-audio} if {[S 8 == WAVE ]} {emit audio/x-wav} if {[S 8 == {WAV\ } ]} {emit audio/x-wav} if {[S 0 == RIFF ]} {emit audio/x-riff} if {[S 0 == EMOD ]} {emit audio/x-emod} if {[S 0 == MTM ]} {emit audio/x-multitrack} if {[S 0 == if ]} {emit audio/x-669-mod} if {[S 0 == FAR ]} {emit audio/mod} if {[S 0 == MAS_U ]} {emit audio/x-multimate-mod} if {[S 44 == SCRM ]} {emit audio/x-st3-mod} if {[S 0 == {GF1PATCH110\0ID\#000002\0} ]} {emit audio/x-gus-patch} if {[S 0 == {GF1PATCH100\0ID\#000002\0} ]} {emit audio/x-gus-patch} if {[S 0 == JN ]} {emit audio/x-669-mod} if {[S 0 == UN05 ]} {emit audio/x-mikmod-uni} if {[S 0 == {Extended\ Module:} ]} {emit audio/x-ft2-mod} if {[S 21 == !SCREAM! ]} {emit audio/x-st2-mod} if {[S 1080 == M.K. ]} {emit audio/x-protracker-mod} if {[S 1080 == M!K! ]} {emit audio/x-protracker-mod} if {[S 1080 == FLT4 ]} {emit audio/x-startracker-mod} if {[S 1080 == 4CHN ]} {emit audio/x-fasttracker-mod} if {[S 1080 == 6CHN ]} {emit audio/x-fasttracker-mod} if {[S 1080 == 8CHN ]} {emit audio/x-fasttracker-mod} if {[S 1080 == CD81 ]} {emit audio/x-oktalyzer-mod} if {[S 1080 == OKTA ]} {emit audio/x-oktalyzer-mod} if {[S 1080 == 16CN ]} {emit audio/x-taketracker-mod} if {[S 1080 == 32CN ]} {emit audio/x-taketracker-mod} if {[S 0 == TOC ]} {emit audio/x-toc} if {[S 0 == // ]} {emit text/cpp} if {[S 0 == {\\1cw\ } ]} {emit application/data} if {[S 0 == {\\1cw} ]} {emit application/data} switch -- [Nv I 0 &0xffffff00] -2063526912 {emit application/data} -2063480064 {emit application/data} if {[S 4 == pipe ]} {emit application/data} if {[S 4 == prof ]} {emit application/data} if {[S 0 == {:\ shell} ]} {emit application/data} if {[S 0 == {\#!/bin/sh} ]} {emit application/x-sh} if {[S 0 == {\#!\ /bin/sh} ]} {emit application/x-sh} if {[S 0 == {\#!\ /bin/sh} ]} {emit application/x-sh} if {[S 0 == {\#!/bin/csh} ]} {emit application/x-csh} if {[S 0 == {\#!\ /bin/csh} ]} {emit application/x-csh} if {[S 0 == {\#!\ /bin/csh} ]} {emit application/x-csh} if {[S 0 == {\#!/bin/ksh} ]} {emit application/x-ksh} if {[S 0 == {\#!\ /bin/ksh} ]} {emit application/x-ksh} if {[S 0 == {\#!\ /bin/ksh} ]} {emit application/x-ksh} if {[S 0 == {\#!/bin/tcsh} ]} {emit application/x-csh} if {[S 0 == {\#!\ /bin/tcsh} ]} {emit application/x-csh} if {[S 0 == {\#!\ /bin/tcsh} ]} {emit application/x-csh} if {[S 0 == {\#!/usr/local/tcsh} ]} {emit application/x-csh} if {[S 0 == {\#!\ /usr/local/tcsh} ]} {emit application/x-csh} if {[S 0 == {\#!/usr/local/bin/tcsh} ]} {emit application/x-csh} if {[S 0 == {\#!\ /usr/local/bin/tcsh} ]} {emit application/x-csh} if {[S 0 == {\#!\ /usr/local/bin/tcsh} ]} {emit application/x-csh} if {[S 0 == {\#!/usr/local/bin/zsh} ]} {emit application/x-zsh} if {[S 0 == {\#!\ /usr/local/bin/zsh} ]} {emit application/x-zsh} if {[S 0 == {\#!\ /usr/local/bin/zsh} ]} {emit application/x-zsh} if {[S 0 == {\#!/usr/local/bin/ash} ]} {emit application/x-sh} if {[S 0 == {\#!\ /usr/local/bin/ash} ]} {emit application/x-zsh} if {[S 0 == {\#!\ /usr/local/bin/ash} ]} {emit application/x-zsh} if {[S 0 == {\#!/usr/local/bin/ae} ]} {emit text/script} if {[S 0 == {\#!\ /usr/local/bin/ae} ]} {emit text/script} if {[S 0 == {\#!\ /usr/local/bin/ae} ]} {emit text/script} if {[S 0 == {\#!/bin/nawk} ]} {emit application/x-awk} if {[S 0 == {\#!\ /bin/nawk} ]} {emit application/x-awk} if {[S 0 == {\#!\ /bin/nawk} ]} {emit application/x-awk} if {[S 0 == {\#!/usr/bin/nawk} ]} {emit application/x-awk} if {[S 0 == {\#!\ /usr/bin/nawk} ]} {emit application/x-awk} if {[S 0 == {\#!\ /usr/bin/nawk} ]} {emit application/x-awk} if {[S 0 == {\#!/usr/local/bin/nawk} ]} {emit application/x-awk} if {[S 0 == {\#!\ /usr/local/bin/nawk} ]} {emit application/x-awk} if {[S 0 == {\#!\ /usr/local/bin/nawk} ]} {emit application/x-awk} if {[S 0 == {\#!/bin/gawk} ]} {emit application/x-awk} if {[S 0 == {\#!\ /bin/gawk} ]} {emit application/x-awk} if {[S 0 == {\#!\ /bin/gawk} ]} {emit application/x-awk} if {[S 0 == {\#!/usr/bin/gawk} ]} {emit application/x-awk} if {[S 0 == {\#!\ /usr/bin/gawk} ]} {emit application/x-awk} if {[S 0 == {\#!\ /usr/bin/gawk} ]} {emit application/x-awk} if {[S 0 == {\#!/usr/local/bin/gawk} ]} {emit application/x-awk} if {[S 0 == {\#!\ /usr/local/bin/gawk} ]} {emit application/x-awk} if {[S 0 == {\#!\ /usr/local/bin/gawk} ]} {emit application/x-awk} if {[S 0 == {\#!/bin/awk} ]} {emit application/x-awk} if {[S 0 == {\#!\ /bin/awk} ]} {emit application/x-awk} if {[S 0 == {\#!\ /bin/awk} ]} {emit application/x-awk} if {[S 0 == {\#!/usr/bin/awk} ]} {emit application/x-awk} if {[S 0 == {\#!\ /usr/bin/awk} ]} {emit application/x-awk} if {[S 0 == {\#!\ /usr/bin/awk} ]} {emit application/x-awk} if {[S 0 == BEGIN ]} {emit application/x-awk} if {[S 0 == {\#!/bin/perl} ]} {emit application/x-perl} if {[S 0 == {\#!\ /bin/perl} ]} {emit application/x-perl} if {[S 0 == {\#!\ /bin/perl} ]} {emit application/x-perl} if {[S 0 == {eval\ \"exec\ /bin/perl} ]} {emit application/x-perl} if {[S 0 == {\#!/usr/bin/perl} ]} {emit application/x-perl} if {[S 0 == {\#!\ /usr/bin/perl} ]} {emit application/x-perl} if {[S 0 == {\#!\ /usr/bin/perl} ]} {emit application/x-perl} if {[S 0 == {eval\ \"exec\ /usr/bin/perl} ]} {emit application/x-perl} if {[S 0 == {\#!/usr/local/bin/perl} ]} {emit application/x-perl} if {[S 0 == {\#!\ /usr/local/bin/perl} ]} {emit application/x-perl} if {[S 0 == {\#!\ /usr/local/bin/perl} ]} {emit application/x-perl} if {[S 0 == {eval\ \"exec\ /usr/local/bin/perl} ]} {emit application/x-perl} if {[S 0 == {\#!/bin/rc} ]} {emit text/script} if {[S 0 == {\#!\ /bin/rc} ]} {emit text/script} if {[S 0 == {\#!\ /bin/rc} ]} {emit text/script} if {[S 0 == {\#!/bin/bash} ]} {emit application/x-sh} if {[S 0 == {\#!\ /bin/bash} ]} {emit application/x-sh} if {[S 0 == {\#!\ /bin/bash} ]} {emit application/x-sh} if {[S 0 == {\#!/usr/local/bin/bash} ]} {emit application/x-sh} if {[S 0 == {\#!\ /usr/local/bin/bash} ]} {emit application/x-sh} if {[S 0 == {\#!\ /usr/local/bin/bash} ]} {emit application/x-sh} if {[S 0 == {\#!\ /} ]} {emit text/script} if {[S 0 == {\#!\ /} ]} {emit text/script} if {[S 0 == {\#!/} ]} {emit text/script} if {[S 0 == {\#!\ } ]} {emit text/script} if {[S 0 == {\037\235} ]} {emit application/compress} if {[S 0 == {\037\213} ]} {emit application/x-gzip} if {[S 0 == {\037\036} ]} {emit application/data} if {[S 0 == {\377\037} ]} {emit application/data} if {[S 0 == BZh ]} {emit application/x-bzip2} if {[S 0 == {\037\237} ]} {emit application/data} if {[S 0 == {\037\236} ]} {emit application/data} if {[S 0 == {\037\240} ]} {emit application/data} if {[S 0 == BZ ]} {emit application/x-bzip} if {[S 0 == {\x89\x4c\x5a\x4f\x00\x0d\x0a\x1a\x0a} ]} {emit application/data} switch -- [Nv I 24 ] 60011 {emit application/data} 60012 {emit application/data} 60013 {emit application/data} 60014 {emit application/data} 60012 {emit application/x-dump} 60011 {emit application/x-dump} if {[S 0 == GDBM ]} {emit application/x-gdbm} if {[S 0 == {\n\n________64E} ]} {emit application/data} if {[S 0 == {\377\377\177} ]} {emit application/data} if {[S 0 == {\377\377\174} ]} {emit application/data} if {[S 0 == {\377\377\176} ]} {emit application/data} if {[S 0 == {\033c\033} ]} {emit application/data} if {[S 0 == {!!\n} ]} {emit application/x-prof} switch -- [Nv i 24 ] 60012 {emit application/x-dump} 60011 {emit application/x-dump} if {[S 0 == {\177ELF} ]} {emit application/x-executable-file} if {[N s 1080 == 0xef53 ]} {emit application/x-linux-ext2fs} if {[S 0 == {\366\366\366\366} ]} {emit application/x-pc-floppy} if {[N S 508 == 0xdabe ]} {emit application/data} if {[N s 510 == 0xaa55 ]} {emit application/data} switch -- [Nv s 1040 ] 4991 {emit application/x-filesystem} 5007 {emit application/x-filesystem} 9320 {emit application/x-filesystem} 9336 {emit application/x-filesystem} if {[S 0 == {-rom1fs-\0} ]} {emit application/x-filesystem} if {[S 395 == OS/2 ]} {emit application/x-bootable} if {[S 0 == FONT ]} {emit font/x-vfont} if {[S 0 == %!PS-AdobeFont-1.0 ]} {emit font/type1} if {[S 6 == %!PS-AdobeFont-1.0 ]} {emit font/type1} if {[S 0 == {STARTFONT\040} ]} {emit font/x-bdf} if {[S 0 == {\001fcp} ]} {emit font/x-pcf} if {[S 0 == {D1.0\015} ]} {emit font/x-speedo} if {[S 0 == flf ]} {emit font/x-figlet} if {[S 0 == flc ]} {emit application/x-font} switch -- [Nv I 7 ] 4540225 {emit font/x-dos} 5654852 {emit font/x-dos} if {[S 4098 == DOSFONT ]} {emit font/x-dos} if {[S 0 == ]} {emit archive} if {[S 0 == FORM ]} {emit {IFF data}} if {[S 0 == P1 ]} {emit image/x-portable-bitmap} if {[S 0 == P2 ]} {emit image/x-portable-graymap} if {[S 0 == P3 ]} {emit image/x-portable-pixmap} if {[S 0 == P4 ]} {emit image/x-portable-bitmap} if {[S 0 == P5 ]} {emit image/x-portable-graymap} if {[S 0 == P6 ]} {emit image/x-portable-pixmap} if {[S 0 == IIN1 ]} {emit image/tiff} if {[S 0 == {MM\x00\x2a} ]} {emit image/tiff} if {[S 0 == {II\x2a\x00} ]} {emit image/tiff} if {[S 0 == {\x89PNG} ]} {emit image/x-png} if {[S 1 == PNG ]} {emit image/x-png} if {[S 0 == GIF8 ]} {emit image/gif} if {[S 0 == {\361\0\100\273} ]} {emit image/x-cmu-raster} if {[S 0 == id=ImageMagick ]} {emit {MIFF image data}} if {[S 0 == {\#FIG} ]} {emit {FIG image text}} if {[S 0 == ARF_BEGARF ]} {emit {PHIGS clear text archive}} if {[S 0 == {@(\#)SunPHIGS} ]} {emit SunPHIGS} if {[S 0 == GKSM ]} {emit {GKS Metafile}} if {[S 0 == BEGMF ]} {emit {clear text Computer Graphics Metafile}} if {[N S 0 == 0x20 &0xffe0]} {emit {binary Computer Graphics Metafile}} if {[S 0 == yz ]} {emit {MGR bitmap, modern format, 8-bit aligned}} if {[S 0 == zz ]} {emit {MGR bitmap, old format, 1-bit deep, 16-bit aligned}} if {[S 0 == xz ]} {emit {MGR bitmap, old format, 1-bit deep, 32-bit aligned}} if {[S 0 == yx ]} {emit {MGR bitmap, modern format, squeezed}} if {[S 0 == {%bitmap\0} ]} {emit {FBM image data}} if {[S 1 == {PC\ Research,\ Inc} ]} {emit {group 3 fax data}} if {[S 0 == hsi1 ]} {emit image/x-jpeg-proprietary} if {[S 0 == BM ]} {emit image/x-bmp} if {[S 0 == IC ]} {emit image/x-ico} if {[S 0 == PI ]} {emit {PC pointer image data}} if {[S 0 == CI ]} {emit {PC color icon data}} if {[S 0 == CP ]} {emit {PC color pointer image data}} if {[S 0 == {/*\ XPM\ */} ]} {emit {X pixmap image text}} if {[S 0 == {Imagefile\ version-} ]} {emit {iff image data}} if {[S 0 == IT01 ]} {emit {FIT image data}} if {[S 0 == IT02 ]} {emit {FIT image data}} if {[S 2048 == PCD_IPI ]} {emit x/x-photo-cd-pack-file} if {[S 0 == PCD_OPA ]} {emit x/x-photo-cd-overfiew-file} if {[S 0 == {SIMPLE\ \ =} ]} {emit {FITS image data}} if {[S 0 == {This\ is\ a\ BitMap\ file} ]} {emit {Lisp Machine bit-array-file}} if {[S 0 == !! ]} {emit {Bennet Yee's \"face\" format}} if {[S 1536 == {Visio\ (TM)\ Drawing} ]} {emit %s} if {[S 0 == {\210OPS} ]} {emit {Interleaf saved data}} if {[S 0 == } ]} {emit {Compiled SGML rules file}} if {[S 0 == {} ]} {emit {A/E SGML Document binary}} if {[S 0 == {} ]} {emit {A/E SGML binary styles file}} if {[S 0 == {SQ\ BITMAP1} ]} {emit {SoftQuad Raster Format text}} if {[S 0 == {X\ } ]} {emit {SoftQuad troff Context intermediate}} switch -- [Nv I 0 &077777777] 196875 {emit {sparc demand paged}} 196872 {emit {sparc pure}} 196871 {emit sparc} 131339 {emit {mc68020 demand paged}} 131336 {emit {mc68020 pure}} 131335 {emit mc68020} 65803 {emit {mc68010 demand paged}} 65800 {emit {mc68010 pure}} 65799 {emit mc68010} if {[S 0 == {\#SUNPC_CONFIG} ]} {emit {SunPC 4.0 Properties Values}} if {[S 0 == snoop ]} {emit {Snoop capture file}} if {[S 36 == acsp ]} {emit {Kodak Color Management System, ICC Profile}} if {[S 0 == {\#!teapot\012xdr} ]} {emit {teapot work sheet \(XDR format\)}} if {[S 0 == {\032\001} ]} {emit {Compiled terminfo entry}} if {[S 0 == {\367\002} ]} {emit {TeX DVI file}} if {[S 0 == {\367\203} ]} {emit font/x-tex} if {[S 0 == {\367\131} ]} {emit font/x-tex} if {[S 0 == {\367\312} ]} {emit font/x-tex} if {[S 0 == {This\ is\ TeX,} ]} {emit {TeX transcript text}} if {[S 0 == {This\ is\ METAFONT,} ]} {emit {METAFONT transcript text}} if {[S 2 == {\000\021} ]} {emit font/x-tex-tfm} if {[S 2 == {\000\022} ]} {emit font/x-tex-tfm} if {[S 0 == {\\input\ texinfo} ]} {emit {Texinfo source text}} if {[S 0 == {This\ is\ Info\ file} ]} {emit {GNU Info text}} if {[S 0 == {\\input} ]} {emit {TeX document text}} if {[S 0 == {\\section} ]} {emit {LaTeX document text}} if {[S 0 == {\\setlength} ]} {emit {LaTeX document text}} if {[S 0 == {\\documentstyle} ]} {emit {LaTeX document text}} if {[S 0 == {\\chapter} ]} {emit {LaTeX document text}} if {[S 0 == {\\documentclass} ]} {emit {LaTeX 2e document text}} if {[S 0 == {\\relax} ]} {emit {LaTeX auxiliary file}} if {[S 0 == {\\contentsline} ]} {emit {LaTeX table of contents}} if {[S 0 == {\\indexentry} ]} {emit {LaTeX raw index file}} if {[S 0 == {\\begin\{theindex\}} ]} {emit {LaTeX sorted index}} if {[S 0 == {\\glossaryentry} ]} {emit {LaTeX raw glossary}} if {[S 0 == {\\begin\{theglossary\}} ]} {emit {LaTeX sorted glossary}} if {[S 0 == {This\ is\ makeindex} ]} {emit {Makeindex log file}} if {[S 0 == **TI82** ]} {emit {TI-82 Graphing Calculator}} if {[S 0 == **TI83** ]} {emit {TI-83 Graphing Calculator}} if {[S 0 == **TI85** ]} {emit {TI-85 Graphing Calculator}} if {[S 0 == **TI92** ]} {emit {TI-92 Graphing Calculator}} if {[S 0 == **TI80** ]} {emit {TI-80 Graphing Calculator File.}} if {[S 0 == **TI81** ]} {emit {TI-81 Graphing Calculator File.}} if {[S 0 == TZif ]} {emit {timezone data}} if {[S 0 == {\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\1\0} ]} {emit {old timezone data}} if {[S 0 == {\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\2\0} ]} {emit {old timezone data}} if {[S 0 == {\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\3\0} ]} {emit {old timezone data}} if {[S 0 == {\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\4\0} ]} {emit {old timezone data}} if {[S 0 == {\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\5\0} ]} {emit {old timezone data}} if {[S 0 == {\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\6\0} ]} {emit {old timezone data}} if {[S 0 == {.\\\"} ]} {emit {troff or preprocessor input text}} if {[S 0 == {'\\\"} ]} {emit {troff or preprocessor input text}} if {[S 0 == {'.\\\"} ]} {emit {troff or preprocessor input text}} if {[S 0 == {\\\"} ]} {emit {troff or preprocessor input text}} if {[S 0 == {x\ T} ]} {emit {ditroff text}} if {[S 0 == {\100\357} ]} {emit {very old \(C/A/T\) troff output data}} if {[S 0 == Interpress/Xerox ]} {emit {Xerox InterPress data}} if {[S 0 == {begin\040} ]} {emit {uuencoded or xxencoded text}} if {[S 0 == {xbtoa\ Begin} ]} {emit {btoa'd text}} if {[S 0 == {$\012ship} ]} {emit {ship'd binary text}} if {[S 0 == {Decode\ the\ following\ with\ bdeco} ]} {emit {bencoded News text}} if {[S 11 == {must\ be\ converted\ with\ BinHex} ]} {emit {BinHex binary text}} if {[N S 6 == 0x107 ]} {emit {unicos \(cray\) executable}} if {[S 596 == {\130\337\377\377} ]} {emit {Ultrix core file}} if {[S 0 == Joy!peffpwpc ]} {emit {header for PowerPC PEF executable}} if {[S 0 == LBLSIZE= ]} {emit {VICAR image data}} if {[S 43 == SFDU_LABEL ]} {emit {VICAR label file}} if {[S 0 == {\xb0\0\x30\0} ]} {emit {VMS VAX executable}} if {[S 1 == WPC ]} {emit {\(Corel/WP\)}} if {[S 0 == core ]} {emit {core file \(Xenix\)}} if {[S 0 == {ZyXEL\002} ]} {emit {ZyXEL voice data}} result return {} } ## -- ** END GENERATED CODE ** -- ## -- Do not edit before this line ! ## # ### ### ### ######### ######### ######### ## Ready for use. # EOF tcllib-1.15/modules/fumagic/fileutil_magic_mimetype.pcx0000644000175000017500000000146212077663116022730 0ustar sergeisergei# -*- tcl -*- fileutil::magic::mimetype.pcx # Syntax of the commands provided by package fileutil::magic::mimetype. # # For use by TclDevKit's static syntax checker (v4.1+). # See http://www.activestate.com/solutions/tcl/ # See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api # for the specification of the format of the code in this file. # package require pcx pcx::register fileutil::magic::mimetype pcx::tcldep 1.0.2 needs tcl 8.4 namespace eval ::fileutil::magic::mimetype {} #pcx::message FOO {... text ...} type #pcx::scan pcx::check 1.0.2 std ::fileutil::magic::mimetype \ {checkSimpleArgs 1 1 { checkFileName }} # Initialization via pcx::init. # Use a ::fileutil::magic::mimetype::init procedure for non-standard initialization. pcx::complete tcllib-1.15/modules/fumagic/mimetypes.man0000644000175000017500000000335412077663116020041 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin fileutil::magic::mimetype n 1.0.2] [moddesc {file utilities}] [titledesc {Procedures implementing mime-type recognition}] [category {Programming tools}] [require Tcl 8.4] [require fileutil::magic::mimetype [opt 1.0.2]] [description] [para] This package provides a command for the recognition of file types in pure Tcl. The output is standardized to mime-types. [para] The core part of the recognizer was generated from a "magic(5)" file containing the checks to perform to recognize files, and associated mime-types. [list_begin definitions] [call [cmd ::fileutil::magic::mimetype] [arg filename]] This command is similar to the command [cmd fileutil::fileType]. [para] The output of the command for the specified file is not a list of attributes describing the type of the file, but a list of standard mime-types the file may have. [para] This list will be empty if the type of the file is not recognized. [list_end] [section REFERENCES] [list_begin enumerated] [enum] [uri ftp://ftp.astron.com/pub/file/ {File(1) sources}] This site contains the current sources for the file command, including the magic definitions used by it. The latter were used by us to generate this recognizer. [list_end] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph {fileutil :: magic}] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [see_also fileutil file(1) magic(5)] [keywords type mime {file utilities} {file type} {file recognition}] [manpage_end] tcllib-1.15/modules/fumagic/cgen.man0000644000175000017500000000417312077663116016741 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin fileutil::magic::cgen n 1.0] [moddesc {file utilities}] [titledesc {Generator core for compiler of magic(5) files}] [category {Programming tools}] [require Tcl 8.4] [require fileutil::magic::cgen [opt 1.0]] [require fileutil::magic::rt [opt 1.0]] [require struct::tree] [require struct::list] [description] [para] This package provides the generator backend for a compiler of magic(5) files into recognizers based on the [package fileutil::magic::rt] recognizer runtime package. For the compiler frontend using this generator see the package [package fileutil::magic::cfront]. [section COMMANDS] [list_begin definitions] [call [cmd ::fileutil::magic::cgen::2tree] [arg script]] This command converts the recognizer specified by the [arg script] into a tree and returns the object command of that tree as its result. It uses the package [package struct::tree] for the tree. [para] The [arg script] is in the format specified by magic(5). [call [cmd ::fileutil::magic::cgen::treedump] [arg tree]] This command takes a [arg tree] as generated by [cmd ::fileutil::magic::cgen::2tree] and returns a string encoding the tree for human consumption, to aid in debugging. [call [cmd ::fileutil::magic::cgen::treegen] [arg tree] [arg node]] This command takes a [arg tree] as generated by [cmd ::fileutil::magic::cgen::2tree] and returns a Tcl script, the recognizer for the file types represented by the sub-tree rooted at the [arg node]. The generated script makes extensive use of the commands provided by the recognizer runtime package [package fileutil::magic::rt] to perform its duties. [list_end] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph {fileutil :: magic}] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [see_also fileutil file(1) magic(5)] [keywords type mime {file utilities} {file type} {file recognition}] [manpage_end] tcllib-1.15/modules/fumagic/mimetypes.test0000644000175000017500000001205612077663116020244 0ustar sergeisergei# -*- tcl -*- # # Testing "fumagic" (FileUtil Magic). Mimetype recognizer. # # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # # Copyright (c) 2005-2006 by Andreas Kupries # All rights reserved. # # RCS: @(#) $Id: mimetypes.test,v 1.10 2006/10/09 21:41:40 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.4 testsNeedTcltest 1.0 catch {namespace delete ::fileutil::magic} support { useLocalFile fumagic.testsupport useLocal rtcore.tcl fileutil::magic::rt } testing { useLocal mimetypes.tcl fileutil::magic::mimetype } # ------------------------------------------------------------------------- # Now the package specific tests.... set path [makeFile {} bogus] removeFile bogus test fumagic.mimetype-1.1 {test file non-existance} { set res [catch {fileutil::magic::mimetype $path} msg] list $res $msg } [list 1 "file not found: \"$path\""] test fumagic.mimetype-1.2 {test file directory} { set f [makeDirectory fileTypeTest] set res [catch {fileutil::magic::mimetype $f} msg] regsub {file[0-9]+} $msg {fileXXX} msg removeDirectory fileTypeTest list $res $msg } {0 application/x-directory} test fumagic.mimetype-1.3 {test file empty} { set f [makeEmptyFile] set res [catch {fileutil::magic::mimetype $f} msg] removeEmptyFile list $res $msg } {0 {}} test fumagic.mimetype-1.4 {test simple binary} { set f [makeBinFile] set res [catch {fileutil::magic::mimetype $f} msg] removeBinFile list $res $msg } {0 {}} test fumagic.mimetype-1.5 {test elf executable} { set f [makeElfFile] set res [catch {fileutil::magic::mimetype $f} msg] removeElfFile list $res $msg } {0 application/x-executable-file} test fumagic.mimetype-1.6 {test simple text} { set f [makeTextFile] set res [catch {fileutil::magic::mimetype $f} msg] removeTextFile list $res $msg } {0 {}} test fumagic.mimetype-1.7 {test script file} { set f [makeScriptFile] set res [catch {fileutil::magic::mimetype $f} msg] removeScriptFile list $res $msg } {0 text/script} test fumagic.mimetype-1.8 {test html text} { set f [makeHtmlFile] set res [catch {fileutil::magic::mimetype $f} msg] removeHtmlFile list $res $msg } {0 text/html} test fumagic.mimetype-1.9 {test xml text} {knownBug} { set f [makeXmlFile] set res [catch {fileutil::magic::mimetype $f} msg] removeXmlFile list $res $msg } {0 text/xml} test fumagic.mimetype-1.10 {test xml with dtd text} {knownBug} { set f [makeXmlDTDFile] set res [catch {fileutil::magic::mimetype $f} msg] removeXmlDTDFile list $res $msg } {0 text/xml} test fumagic.mimetype-1.11 {test PGP message} {knownBug} { set f [makePgpFile] set res [catch {fileutil::magic::mimetype $f} msg] removePgpFile list $res $msg } {0 {PGP armored data}} ; # Result is not a mime type. test fumagic.mimetype-1.12 {test binary graphic jpeg} { set f [makeJpegFile] set res [catch {fileutil::magic::mimetype $f} msg] removeJpegFile list $res $msg } {0 image/jpeg} test fumagic.mimetype-1.13 {test binary graphic gif} { set f [makeGifFile] set res [catch {fileutil::magic::mimetype $f} msg] removeGifFile list $res $msg } {0 image/gif} test fumagic.mimetype-1.14 {test binary graphic png} { set f [makePngFile] set res [catch {fileutil::magic::mimetype $f} msg] removePngFile list $res $msg } {0 image/x-png} test fumagic.mimetype-1.15 {test binary graphic tiff} { set f [makeTiffFile] set res [catch {fileutil::magic::mimetype $f} msg] removeTiffFile list $res $msg } {0 image/tiff} test fumagic.mimetype-1.16 {test binary pdf} {knownBug} { set f [makePdfFile] set res [catch {fileutil::magic::mimetype $f} msg] removePdfFile list $res $msg } {0 {PDF document}} ; # Result is not a mime type test fumagic.mimetype-1.17 {test text ps} { set f [makePSFile] set res [catch {fileutil::magic::mimetype $f} msg] removePSFile list $res $msg } {0 application/postscript} test fumagic.mimetype-1.18 {test text eps} { set f [makeEPSFile] set res [catch {fileutil::magic::mimetype $f} msg] removeEPSFile list $res $msg } {0 application/postscript} test fumagic.mimetype-1.19 {test binary gravity_wave_data_frame} { set f [makeIgwdFile] set res [catch {fileutil::magic::mimetype $f} msg] removeIgwdFile list $res $msg } {0 {}} test fumagic.mimetype-1.20 {test binary compressed bzip} { set f [makeBzipFile] set res [catch {fileutil::magic::mimetype $f} msg] removeBzipFile list $res $msg } {0 {application/x-bzip2 application/x-bzip}} test fumagic.mimetype-1.21 {test binary compressed gzip} { set f [makeGzipFile] set res [catch {fileutil::magic::mimetype $f} msg] removeGzipFile list $res $msg } {0 application/x-gzip} testsuiteCleanup return tcllib-1.15/modules/fumagic/fileutil_magic_cgen.pcx0000644000175000017500000000175312077663116022016 0ustar sergeisergei# -*- tcl -*- fileutil::magic::cgen.pcx # Syntax of the commands provided by package fileutil::magic::cgen. # # For use by TclDevKit's static syntax checker (v4.1+). # See http://www.activestate.com/solutions/tcl/ # See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api # for the specification of the format of the code in this file. # package require pcx pcx::register fileutil::magic::cgen pcx::tcldep 1.0 needs tcl 8.4 namespace eval ::fileutil::magic::cgen {} #pcx::message FOO {... text ...} type #pcx::scan pcx::check 1.0 std ::fileutil::magic::cgen::2tree \ {checkSimpleArgs 1 1 { checkWord }} pcx::check 1.0 std ::fileutil::magic::cgen::treedump \ {checkSimpleArgs 1 1 { checkWord }} pcx::check 1.0 std ::fileutil::magic::cgen::treegen \ {checkSimpleArgs 2 2 { checkWord checkWord }} # Initialization via pcx::init. # Use a ::fileutil::magic::cgen::init procedure for non-standard initialization. pcx::complete tcllib-1.15/modules/fumagic/cgen.tcl0000644000175000017500000004354712077663116016760 0ustar sergeisergei# cgen.tcl -- # # Generator core for compiler of magic(5) files into recognizers # based on the 'rtcore'. # # Copyright (c) 2004-2005 Colin McCormack # Copyright (c) 2005 Andreas Kupries # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: cgen.tcl,v 1.7 2007/06/23 03:39:34 andreas_kupries Exp $ ##### # # "mime type recognition in pure tcl" # http://wiki.tcl.tk/12526 # # Tcl code harvested on: 10 Feb 2005, 04:06 GMT # Wiki page last updated: ??? # ##### # ### ### ### ######### ######### ######### ## Requirements package require Tcl 8.4 package require fileutil::magic::rt ; # Runtime core, for Access to the typemap package require struct::list ; # Our data structures. package require struct::tree ; # package provide fileutil::magic::cgen 1.0 # ### ### ### ######### ######### ######### ## Implementation namespace eval ::fileutil::magic::cgen { # Import the runtime typemap into our scope. variable ::fileutil::magic::rt::typemap # The tree most operations use for their work. variable tree {} # Generator data structure. variable regions # Type mapping for indirect offsets. # empty -> long/Q, because this uses native byteorder. array set otmap { .b c .B c .s s .S S .l i .L I {} Q } # Export the API namespace export 2tree treedump treegen } # Optimisations: # reorder tests according to expected or observed frequency this # conflicts with reduction in strength optimisations. # Rewriting within a level will require pulling apart the list of # tests at that level and reordering them. There is an inconsistency # between handling at 0-level and deeper level - this has to be # removed or justified. # Hypothetically, every test at the same level should be mutually # exclusive, but this is not given, and should be detected. If true, # this allows reduction in strength to switch on Numeric tests # reduce Numeric tests at the same level to switches # # - first pass through clauses at same level to categorise as # variant values over same test (type and offset). # work out some way to cache String comparisons # Reduce seek/reads for String comparisons at same level: # # - first pass through clauses at same level to determine string ranges. # # - String tests at same level over overlapping ranges can be # written as sub-string comparisons over the maximum range # this saves re-reading the same string from file. # # - common prefix strings will have to be guarded against, by # sorting string values, then sorting the tests in reverse length order. proc ::fileutil::magic::cgen::path {tree} { # Annotates the tree. In each node we store the path from the root # to this node, as list of nodes, with the current node the last # element. The root node is never stored in the path. $tree set root path {} foreach child [$tree children root] { $tree walk $child -type dfs node { set path [$tree get [$tree parent $node] path] lappend path [$tree index $node] $tree set $node path $path } } return } proc ::fileutil::magic::cgen::tree_el {tree parent file line type qual comp offset val message args} { # Recursively creates and annotates a node for the specified # tests, and its sub-tests (args). set node [$tree insert $parent end] set path [$tree get $parent path] lappend path [$tree index $node] $tree set $node path $path # generate a proc call type for the type, Numeric or String variable ::fileutil::magic::rt::typemap switch -glob -- $type { *byte* - *short* - *long* - *date* { set otype N set type [lindex $typemap($type) 1] } *string { set otype S } default { puts stderr "Unknown type: '$type'" } } # Stores the type determined above, and the arguments into # attributes of the new node. foreach key {line type qual comp offset val message file otype} { if {[catch { $tree set $node $key [set $key] } result]} { upvar ::errorInfo eo puts "Tree: $eo - $file $line $type" } } # now add children foreach el $args { eval [linsert $el 0 tree_el $tree $node $file] # 8.5 # tree_el $tree $node $file {*}$el } return $node } proc ::fileutil::magic::cgen::2tree {script} { # Converts a recognizer which is in a simple script form into a # tree. variable tree set tree [::struct::tree] $tree set root path "" $tree set root otype Root $tree set root type root $tree set root message "unknown" # generate a test for each match set file "unknown" foreach el $script { #puts "EL: $el" if {[lindex $el 0] eq "file"} { set file [lindex $el 1] } else { set node [eval [linsert $el 0 tree_el $tree root $file]] # 8.5 # set more [tree_el $tree root $file {*}$el] append result $node } } optNum $tree root #optStr $tree root puts stderr "Script contains [llength [$tree children root]] discriminators" path $tree # Decoding the offsets, determination if we have to handle # relative offsets, and where. The less, the better. Offsets $tree return $tree } proc ::fileutil::magic::cgen::isStr {tree node} { return [expr {"S" eq [$tree get $node otype]}] } proc ::fileutil::magic::cgen::sortRegion {r1 r2} { set cmp 0 if {[catch { if {[string match (*) $r1] || [string match (*) $r2]} { set cmp [string compare $r1 $r2] } else { set cmp [expr {[lindex $r1 0] - [lindex $r2 0]}] if {!$cmp} { set cmp 0 set cmp [expr {[lindex $r1 1] - [lindex $r2 1]}] } } } result]} { set cmp [string compare $r1 $r2] } return $cmp } proc ::fileutil::magic::cgen::optStr {tree node} { variable regions catch {unset regions} array set regions {} optStr1 $tree $node puts stderr "Regions [array statistics regions]" foreach region [lsort \ -index 0 \ -command ::fileutil::magic::cgen::sortRegion \ [array name regions]] { puts "$region - $regions($region)" } } proc ::fileutil::magic::cgen::optStr1 {tree node} { variable regions # traverse each numeric element of this node's children, # categorising them set kids [$tree children $node] foreach child $kids { optStr1 $tree $child } set strings [$tree children $node filter ::fileutil::magic::cgen::isStr] #puts stderr "optstr: $node: $strings" foreach el $strings { #if {[$tree get $el otype] eq "String"} {puts "[$tree getall $el] - [string length [$tree get $el val]]"} if {[$tree get $el comp] eq "x"} { continue } set offset [$tree get $el offset] set len [string length [$tree get $el val]] lappend regions([list $offset $len]) $el } } proc ::fileutil::magic::cgen::isNum {tree node} { return [expr {"N" eq [$tree get $node otype]}] } proc ::fileutil::magic::cgen::switchNSort {tree n1 n2} { return [expr {[$tree get $n1 val] - [$tree get $n1 val]}] } proc ::fileutil::magic::cgen::optNum {tree node} { array set offsets {} # traverse each numeric element of this node's children, # categorising them set kids [$tree children $node] foreach child $kids { optNum $tree $child } set numerics [$tree children $node filter ::fileutil::magic::cgen::isNum] #puts stderr "optNum: $node: $numerics" if {[llength $numerics] < 2} { return } foreach el $numerics { if {[$tree get $el comp] ne "=="} { continue } lappend offsets([$tree get $el type],[$tree get $el offset],[$tree get $el qual]) $el } #puts "Offset: stderr [array get offsets]" foreach {match nodes} [array get offsets] { if {[llength $nodes] < 2} { continue } catch {unset matcher} foreach n $nodes { set nv [expr [$tree get $n val]] if {[info exists matcher($nv)]} { puts stderr "*=====================================" puts stderr "* Node <[$tree getall $n]>" puts stderr "* clashes with <[$tree getall $matcher($nv)]>" puts stderr "*=====================================" } else { set matcher($nv) $n } } foreach {type offset qual} [split $match ,] break set switch [$tree insert $node [$tree index [lindex $nodes 0]]] $tree set $switch otype Switch $tree set $switch message $match $tree set $switch offset $offset $tree set $switch type $type $tree set $switch qual $qual set nodes [lsort -command [list ::fileutil::magic::cgen::switchNSort $tree] $nodes] eval [linsert $nodes 0 $tree move $switch end] # 8.5 # $tree move $switch end {*}$nodes set path [$tree get [$tree parent $switch] path] lappend path [$tree index $switch] $tree set $switch path $path } } proc ::fileutil::magic::cgen::Offsets {tree} { # Indicator if a node has to save field location information for # relative addressing. The 'kill' attribute is an accumulated # 'save' over the whole subtree. It will be used to determine when # level information was destroyed by subnodes and has to be # regenerated at the current level. $tree walk root -type dfs node { $tree set $node save 0 $tree set $node kill 0 } # We walk from the leafs up to the root, synthesizing the data # needed, as we go. $tree walk root -type dfs -order post node { if {$node eq "root"} continue DecodeOffset $tree $node [$tree get $node offset] # If the current node's parent is a switch, and the node has # to save, then the switch has to save. Because the current # node is not relevant during code generation anymore, the # switch is. if {[$tree get $node save]} { # We save, therefore we kill. $tree set $node kill 1 if {[$tree get [$tree parent $node] otype] eq "Switch"} { $tree set [$tree parent $node] save 1 } } else { # We don't save i.e. kill, but we may inherit it from # children which kill. foreach c [$tree children $node] { if {[$tree get $c kill]} { $tree set $node kill 1 break } } } } } proc ::fileutil::magic::cgen::DecodeOffset {tree node offset} { if {[string match "(*)" $offset]} { # Indirection offset. (Decoding is non-trivial, therefore # packed into a proc). set ind 1 ; # Indirect location foreach {rel base itype idelta} [DecodeIndirectOffset $offset] break } elseif {[string match "&*" $offset]} { # Direct relative offset. (Decoding is trivial) set ind 0 ; # Direct location set rel 1 ; # Relative set base [string range $offset 1 end] ; # Base Delta set itype {} ; # No data for indirect set idelta {} ; # s.a. } else { set ind 0 ; # Direct location set rel 0 ; # Absolute set base $offset ; # Here! set itype {} ; # No data for indirect set idelta {} ; # s.a. } # Store the expanded data back into the tree. foreach v {ind rel base itype idelta} { $tree set $node $v [set $v] } # For nodes with adressing relative to last field above the latter # has to save this information. if {$rel} { $tree set [$tree parent $node] save 1 } return } proc ::fileutil::magic::cgen::DecodeIndirectOffset {offset} { variable otmap ; # Offset typemap. # Offset parser. # Syntax: # ( ?&? number ?.[bslBSL]? ?[+-]? ?number? ) set n {(([0-9]+)|(0x[0-9A-Fa-f]+))} set o "\\((&?)(${n})((\\.\[bslBSL])?)(\[+-]?)(${n}?)\\)" # | | ||| || | | ||| # 1 2 345 67 8 9 012 # ^ ^ ^ ^ ^ # rel base type sign index # # 1 2 3 4 5 6 7 8 9 0 1 2 set ok [regexp $o $offset -> rel base _ _ _ type _ sign idx _ _ _] if {!$ok} { return -code error "Bad offset \"$offset\"" } # rel is in {"", &}, map to 0|1 if {$rel eq ""} {set rel 0} else {set rel 1} # base is a number, enforce decimal. Not optional. set base [expr $base] # Type is in .b .s .l .B .S .L, and "". Map to a regular magic # type code. set type $otmap($type) # sign is in {+,-,""}. Map to -|"" (Becomes sign of index) if {$sign eq "+"} {set sign ""} # Index is optional number. Enforce decimal, empty is zero. Add in # the sign as well for a proper signed index. if {$idx eq ""} {set idx 0} set idx $sign[expr $idx] return [list $rel $base $type $idx] } proc ::fileutil::magic::cgen::treedump {tree} { set result "" $tree walk root -type dfs node { set path [$tree get $node path] set depth [llength $path] append result [string repeat " " $depth] [list $path] ": " [$tree get $node type]: if {[$tree keyexists $node offset]} { append result " ,O|[$tree get $node offset]|" set x {} foreach v {ind rel base itype idelta} {lappend x [$tree get $node $v]} append result "=<[join $x !]>" } if {[$tree keyexists $node qual]} { set q [$tree get $node qual] if {$q ne ""} { append result " ,q/$q/" } } if {[$tree keyexists $node comp]} { append result " " C([$tree get $node comp]) } if {[$tree keyexists $node val]} { append result " " V([$tree get $node val]) } if {[$tree keyexists $node otype]} { append result " " [$tree get $node otype]/[$tree get $node save] } if {$depth == 1} { set msg [$tree get $node message] set n $node while {($n != {}) && ($msg == "")} { set n [lindex [$tree children $n] 0] if {$n != {}} { set msg [$tree get $n message] } } append result " " ( $msg ) if {[$tree keyexists $node file]} { append result " - " [$tree get $node file] } } #append result " <" [$tree getall $node] > append result \n } return $result } proc ::fileutil::magic::cgen::treegen {tree node} { return "[treegen1 $tree $node]\nresult\n" } proc ::fileutil::magic::cgen::treegen1 {tree node} { variable ::fileutil::magic::rt::typemap set result "" foreach k {otype type offset comp val qual message save path} { if {[$tree keyexists $node $k]} { set $k [$tree get $node $k] } } set level [llength $path] # Generate code for each node per its type. switch $otype { N - S { if {$save} { # We have to save field data for relative adressing under this # leaf. if {$otype eq "N"} { set type [list Nx $level $type] } elseif {$otype eq "S"} { set type [list Sx $level] } } else { # Regular fetching of information. if {$otype eq "N"} { set type [list N $type] } elseif {$otype eq "S"} { set type S } } set offset [GenerateOffset $tree $node] if {$qual eq ""} { append result "if \{\[$type $offset $comp [list $val]\]\} \{" } else { append result "if \{\[$type $offset $comp [list $val] $qual\]\} \{" } if {[$tree isleaf $node]} { if {$message ne ""} { append result "emit [list $message]" } else { append result "emit [$tree get $node path]" } } else { # If we saved data the child branches may destroy # level information. We regenerate it if needed. if {$message ne ""} { append result "emit [list $message]\n" } set killed 0 foreach child [$tree children $node] { if {$save && $killed && [$tree get $child rel]} { # This location already does not regenerate if # the killing subnode was last. We also do not # need to regenerate if the current subnode # does not use relative adressing. append result "L $level;" set killed 0 } append result [treegen1 $tree $child] set killed [expr {$killed || [$tree get $child kill]}] } #append result "\nreturn \$result" } append result "\}\n" } Root { foreach child [$tree children $node] { append result [treegen1 $tree $child] } } Switch { set offset [GenerateOffset $tree $node] if {$save} { set fetch "Nvx $level" } else { set fetch Nv } append fetch " " $type " " $offset if {$qual ne ""} { append fetch " " $qual } append result "switch -- \[$fetch\] " set scan [lindex $typemap($type) 1] set ckilled 0 foreach child [$tree children $node] { binary scan [binary format $scan [$tree get $child val]] $scan val append result "$val \{" if {$save && $ckilled} { # This location already does not regenerate if # the killing subnode was last. We also do not # need to regenerate if the current subnode # does not use relative adressing. append result "L $level;" set ckilled 0 } if {[$tree isleaf $child]} { append result "emit [list [$tree get $child message]]" } else { set killed 0 append result "emit [list [$tree get $child message]]\n" foreach grandchild [$tree children $child] { if {$save && $killed && [$tree get $grandchild rel]} { # This location already does not regenerate if # the killing subnode was last. We also do not # need to regenerate if the current subnode # does not use relative adressing. append result "L $level;" set killed 0 } append result [treegen1 $tree $grandchild] set killed [expr {$killed || [$tree get $grandchild kill]}] } } set ckilled [expr {$ckilled || [$tree get $child kill]}] append result "\} " } append result "\n" } } return $result } proc ::fileutil::magic::cgen::GenerateOffset {tree node} { # Examples: # direct absolute: 45 -> 45 # direct relative: &45 -> [R 45] # indirect absolute: (45.s+1) -> [I 45 s 1] # indirect relative: (&45.s+1) -> [I [R 45] s 1] foreach v {ind rel base itype idelta} { set $v [$tree get $node $v] } if {$rel} {set base "\[R $base\]"} if {$ind} {set base "\[I $base $itype $idelta\]"} return $base } # ### ### ### ######### ######### ######### ## Ready for use. # EOF tcllib-1.15/modules/fumagic/filetypes.tcl0000644000175000017500000103620712077663116020044 0ustar sergeisergei# filetypes.tcl -- # # Tcl based file type recognizer using the runtime core and # generated from /usr/share/misc/magic.mime. Limited output, # but only mime-types, i.e. standardized. # # Copyright (c) 2004-2005 Colin McCormack # Copyright (c) 2005-2006 Andreas Kupries # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: filetypes.tcl,v 1.6 2006/09/27 21:19:35 andreas_kupries Exp $ ##### # # "mime type discriminator" # http://wiki.tcl.tk/12537 # # Tcl code harvested on: 10 Feb 2005, 04:16 GMT # Wiki page last updated: ??? # ##### # ### ### ### ######### ######### ######### ## Requirements. package require Tcl 8.4 package require fileutil::magic::rt ; # We need the runtime core. # ### ### ### ######### ######### ######### ## Implementation namespace eval ::fileutil::magic {} proc ::fileutil::magic::filetype {file} { if {![file exists $file]} { return -code error "file not found: \"$file\"" } if {[file isdirectory $file]} { return directory } rt::open $file filetype::run rt::close set types [rt::resultv] if {[llength $types]} { # We postprocess the data if needed, as the low-level # recognizer can return duplicate information. array set _ {} set utypes {} foreach t $types { if {[info exists _($t)]} continue lappend utypes $t set _($t) . set types $utypes } } return [join $types] } package provide fileutil::magic::filetype 1.0.2 # The actual recognizer is the command below. ## ## -- Do not edit after this line ! ## -- ** BEGIN GENERATED CODE ** -- package require fileutil::magic::rt namespace eval ::fileutil::magic::filetype { namespace import ::fileutil::magic::rt::* } proc ::fileutil::magic::filetype::run {} { switch -- [Nv S 0] 518 {emit {ALAN game data} if {[N c 2 < 0xa]} {emit {version 2.6%d}} } -7408 {emit {Amiga Workbench} if {[N S 2 == 0x1]} {switch -- [Nv c 48] 1 {emit {disk icon}} 2 {emit {drawer icon}} 3 {emit {tool icon}} 4 {emit {project icon}} 5 {emit {garbage icon}} 6 {emit {device icon}} 7 {emit {kickstart icon}} 8 {emit {workbench application icon}} } if {[N S 2 > 0x1]} {emit {icon, vers. %d}} } 3840 {emit {AmigaOS bitmap font}} 3843 {emit {AmigaOS outline font}} 19937 {emit {MPEG-4 LO-EP audio stream}} 3599 {emit {Atari MSA archive data} if {[N S 2 x {}]} {emit {\b, %d sectors per track}} switch -- [Nv S 4] 0 {emit {\b, 1 sided}} 1 {emit {\b, 2 sided}} if {[N S 6 x {}]} {emit {\b, starting track: %d}} if {[N S 8 x {}]} {emit {\b, ending track: %d}} } 368 {emit {WE32000 COFF} if {[N S 18 ^ 0x10]} {emit object} if {[N S 18 & 0x10]} {emit executable} if {[N I 12 > 0x0]} {emit {not stripped}} if {[N S 18 ^ 0x1000]} {emit {N/A on 3b2/300 w/paging}} if {[N S 18 & 0x2000]} {emit {32100 required}} if {[N S 18 & 0x4000]} {emit {and MAU hardware required}} switch -- [Nv S 20] 263 {emit {\(impure\)}} 264 {emit {\(pure\)}} 267 {emit {\(demand paged\)}} 291 {emit {\(target shared library\)}} if {[N S 22 > 0x0]} {emit {- version %ld}} } 369 {emit {WE32000 COFF executable \(TV\)} if {[N I 12 > 0x0]} {emit {not stripped}} } 14541 {emit {C64 PCLink Image}} 30463 {emit {squeezed data,} if {[S 4 x {}]} {emit {original name %s}} } 30462 {emit {crunched data,} if {[S 2 x {}]} {emit {original name %s}} } 30461 {emit {LZH compressed data,} if {[S 2 x {}]} {emit {original name %s}} } -32760 {emit {Lynx cartridge,} if {[N S 2 x {}]} {emit {RAM start $%04x}} if {[S 6 == BS93]} {emit 0 12 1} if {[N I 16 == 0x3030 &0xfe00f0f0]} {emit {Infocom game data}} if {[N c 0 == 0x0]} {emit {\(false match\)}} if {[N c 0 > 0x0]} {emit {\(Z-machine %d,} if {[N S 2 x {}]} {emit {Release %d /}} if {[S 18 x {}]} {emit {Serial %.6s\)}} } } 2935 {emit {ATSC A/52 aka AC-3 aka Dolby Digital stream,} switch -- [Nv c 4 &0xc0] 0 {emit {48 kHz,}} 64 {emit {44.1 kHz,}} -128 {emit {32 kHz,}} -64 {emit {reserved frequency,}} switch -- [Nv c 6 &0xe0] 0 {emit {1+1 front,}} 32 {emit {1 front/0 rear,}} 64 {emit {2 front/0 rear,}} 96 {emit {3 front/0 rear,}} -128 {emit {2 front/1 rear,}} -96 {emit {3 front/1 rear,}} -64 {emit {2 front/2 rear,}} -32 {emit {3 front/2 rear,}} switch -- [Nv c 7 &0x40] 0 {emit {LFE off,}} 64 {emit {LFE on,}} switch -- [Nv S 6 &0x0180] 0 {emit {Dolby Surround not indicated}} 128 {emit {not Dolby Surround encoded}} 256 {emit {Dolby Surround encoded}} 384 {emit {reserved Dolby Surround mode}} } 5493 {emit {fsav \(linux\) macro virus} if {[N s 8 > 0x0]} {emit {\(%d-}} if {[N c 11 > 0x0]} {emit {\b%02d-}} if {[N c 10 > 0x0]} {emit {\b%02d\)}} } -26367 {emit {GPG key public ring}} 1280 {emit {Hitachi SH big-endian COFF} switch -- [Nv S 18 &0x0002] 0 {emit object} 2 {emit executable} switch -- [Nv S 18 &0x0008] 8 {emit {\b, stripped}} 0 {emit {\b, not stripped}} } 351 {emit {370 XA sysV executable} if {[N I 12 > 0x0]} {emit {not stripped}} if {[N S 22 > 0x0]} {emit {- version %d}} if {[N I 30 > 0x0]} {emit {- 5.2 format}} } 346 {emit {370 XA sysV pure executable} if {[N I 12 > 0x0]} {emit {not stripped}} if {[N S 22 > 0x0]} {emit {- version %d}} if {[N I 30 > 0x0]} {emit {- 5.2 format}} } 22529 {emit {370 sysV pure executable} if {[N I 12 > 0x0]} {emit {not stripped}} } 23041 {emit {370 XA sysV pure executable} if {[N I 12 > 0x0]} {emit {not stripped}} } 23809 {emit {370 sysV executable} if {[N I 12 > 0x0]} {emit {not stripped}} } 24321 {emit {370 XA sysV executable} if {[N I 12 > 0x0]} {emit {not stripped}} } 345 {emit {SVR2 executable \(Amdahl-UTS\)} if {[N I 12 > 0x0]} {emit {not stripped}} if {[N I 24 > 0x0]} {emit {- version %ld}} } 348 {emit {SVR2 pure executable \(Amdahl-UTS\)} if {[N I 12 > 0x0]} {emit {not stripped}} if {[N I 24 > 0x0]} {emit {- version %ld}} } 344 {emit {SVR2 pure executable \(USS/370\)} if {[N I 12 > 0x0]} {emit {not stripped}} if {[N I 24 > 0x0]} {emit {- version %ld}} } 349 {emit {SVR2 executable \(USS/370\)} if {[N I 12 > 0x0]} {emit {not stripped}} if {[N I 24 > 0x0]} {emit {- version %ld}} } 407 {emit {Apollo m68k COFF executable} if {[N S 18 ^ 0x4000]} {emit {not stripped}} if {[N S 22 > 0x0]} {emit {- version %ld}} } 404 {emit {apollo a88k COFF executable} if {[N S 18 ^ 0x4000]} {emit {not stripped}} if {[N S 22 > 0x0]} {emit {- version %ld}} } 200 {emit {hp200 \(68010\) BSD} switch -- [Nv S 2] 263 {emit {impure binary}} 264 {emit {read-only binary}} 267 {emit {demand paged binary}} } 300 {emit {hp300 \(68020+68881\) BSD} switch -- [Nv S 2] 263 {emit {impure binary}} 264 {emit {read-only binary}} 267 {emit {demand paged binary}} } 479 {emit {executable \(RISC System/6000 V3.1\) or obj module} if {[N I 12 > 0x0]} {emit {not stripped}} } 260 {emit {shared library}} 261 {emit {ctab data}} -508 {emit {structured file}} 12320 {emit {character Computer Graphics Metafile}} 474 {emit {SGI image data} if {[N c 2 == 0x1]} {emit {\b, RLE}} if {[N c 3 == 0x2]} {emit {\b, high precision}} if {[N S 4 x {}]} {emit {\b, %d-D}} if {[N S 6 x {}]} {emit {\b, %d x}} if {[N S 8 x {}]} {emit %d} if {[N S 10 x {}]} {emit {\b, %d channel}} if {[N S 10 != 0x1]} {emit {\bs}} if {[S 80 > 0]} {emit {\b, \"%s\"}} } 4112 {emit {PEX Binary Archive}} 2560 {emit {PCX ver. 2.5 image data}} 2562 {emit {PCX ver. 2.8 image data, with palette}} 2563 {emit {PCX ver. 2.8 image data, without palette}} 2564 {emit {PCX for Windows image data}} 2565 {emit {PCX ver. 3.0 image data} if {[N s 4 x {}]} {emit {bounding box [%hd,}} if {[N s 6 x {}]} {emit {%hd] -}} if {[N s 8 x {}]} {emit {[%hd,}} if {[N s 10 x {}]} {emit %hd\],} if {[N c 65 > 0x1]} {emit {%d planes each of}} if {[N c 3 x {}]} {emit %hhd-bit} switch -- [Nv c 68] 0 {emit image,} 1 {emit colour,} 2 {emit grayscale,} if {[N c 68 > 0x2]} {emit image,} if {[N c 68 < 0x0]} {emit image,} if {[N s 12 > 0x0]} {emit {%hd x} if {[N s 14 x {}]} {emit {%hd dpi,}} } switch -- [Nv c 2] 0 {emit uncompressed} 1 {emit {RLE compressed}} } 12320 {emit {character Computer Graphics Metafile}} 21930 {emit {BIOS \(ia32\) ROM Ext.} if {[S 5 == USB]} {emit USB} if {[S 7 == LDR]} {emit {UNDI image}} if {[S 30 == IBM]} {emit {IBM comp. Video}} if {[S 26 == Adaptec]} {emit Adaptec} if {[S 28 == Adaptec]} {emit Adaptec} if {[S 42 == PROMISE]} {emit Promise} if {[N c 2 x {}]} {emit {\(%d*512\)}} } -21267 {emit {Java serialization data} if {[N S 2 > 0x4]} {emit {\b, version %d}} } -40 {emit {JPEG image data} if {[S 6 == JFIF]} {emit {\b, JFIF standard} if {[N c 11 x {}]} {emit {\b %d.}} if {[N c 12 x {}]} {emit {\b%02d}} if {[N c 18 != 0x0]} {emit {\b, thumbnail %dx} if {[N c 19 x {}]} {emit {\b%d}} } } if {[S 6 == Exif]} {emit {\b, EXIF standard} if {[S 12 == II]} {if {[N s 70 == 0x8769]} {if {[N s [I 78 i 14] == 0x9000]} {if {[N c [I 78 i 23] x {}]} {emit %c} if {[N c [I 78 i 24] x {}]} {emit {\b.%c}} if {[N c [I 78 i 25] != 0x30]} {emit {\b%c}} } } if {[N s 118 == 0x8769]} {if {[N s [I 126 i 38] == 0x9000]} {if {[N c [I 126 i 47] x {}]} {emit %c} if {[N c [I 126 i 48] x {}]} {emit {\b.%c}} if {[N c [I 126 i 49] != 0x30]} {emit {\b%c}} } } if {[N s 130 == 0x8769]} {if {[N s [I 138 i 38] == 0x9000]} {if {[N c [I 138 i 47] x {}]} {emit %c} if {[N c [I 138 i 48] x {}]} {emit {\b.%c}} if {[N c [I 138 i 49] != 0x30]} {emit {\b%c}} } if {[N s [I 138 i 50] == 0x9000]} {if {[N c [I 138 i 59] x {}]} {emit %c} if {[N c [I 138 i 60] x {}]} {emit {\b.%c}} if {[N c [I 138 i 61] != 0x30]} {emit {\b%c}} } if {[N s [I 138 i 62] == 0x9000]} {if {[N c [I 138 i 71] x {}]} {emit %c} if {[N c [I 138 i 72] x {}]} {emit {\b.%c}} if {[N c [I 138 i 73] != 0x30]} {emit {\b%c}} } } if {[N s 142 == 0x8769]} {if {[N s [I 150 i 38] == 0x9000]} {if {[N c [I 150 i 47] x {}]} {emit %c} if {[N c [I 150 i 48] x {}]} {emit {\b.%c}} if {[N c [I 150 i 49] != 0x30]} {emit {\b%c}} } if {[N s [I 150 i 50] == 0x9000]} {if {[N c [I 150 i 59] x {}]} {emit %c} if {[N c [I 150 i 60] x {}]} {emit {\b.%c}} if {[N c [I 150 i 61] != 0x30]} {emit {\b%c}} } if {[N s [I 150 i 62] == 0x9000]} {if {[N c [I 150 i 71] x {}]} {emit %c} if {[N c [I 150 i 72] x {}]} {emit {\b.%c}} if {[N c [I 150 i 73] != 0x30]} {emit {\b%c}} } } } if {[S 12 == MM]} {if {[N S 118 == 0x8769]} {if {[N S [I 126 I 14] == 0x9000]} {if {[N c [I 126 I 23] x {}]} {emit %c} if {[N c [I 126 I 24] x {}]} {emit {\b.%c}} if {[N c [I 126 I 25] != 0x30]} {emit {\b%c}} } if {[N S [I 126 I 38] == 0x9000]} {if {[N c [I 126 I 47] x {}]} {emit %c} if {[N c [I 126 I 48] x {}]} {emit {\b.%c}} if {[N c [I 126 I 49] != 0x30]} {emit {\b%c}} } } if {[N S 130 == 0x8769]} {if {[N S [I 138 I 38] == 0x9000]} {if {[N c [I 138 I 47] x {}]} {emit %c} if {[N c [I 138 I 48] x {}]} {emit {\b.%c}} if {[N c [I 138 I 49] != 0x30]} {emit {\b%c}} } if {[N S [I 138 I 62] == 0x9000]} {if {[N c [I 138 I 71] x {}]} {emit %c} if {[N c [I 138 I 72] x {}]} {emit {\b.%c}} if {[N c [I 138 I 73] != 0x30]} {emit {\b%c}} } } if {[N S 142 == 0x8769]} {if {[N S [I 150 I 50] == 0x9000]} {if {[N c [I 150 I 59] x {}]} {emit %c} if {[N c [I 150 I 60] x {}]} {emit {\b.%c}} if {[N c [I 150 I 61] != 0x30]} {emit {\b%c}} } } } } switch -- [Nv c [I 4 S 5]] -2 {emit {} if {[S [I 4 S 8] x {}]} {emit {\b, comment: \"%s\"}} } -64 {emit {\b, baseline} if {[N c [I 4 S 6] x {}]} {emit {\b, precision %d}} if {[N S [I 4 S 7] x {}]} {emit {\b, %dx}} if {[N S [I 4 S 9] x {}]} {emit {\b%d}} } -63 {emit {\b, extended sequential} if {[N c [I 4 S 6] x {}]} {emit {\b, precision %d}} if {[N S [I 4 S 7] x {}]} {emit {\b, %dx}} if {[N S [I 4 S 9] x {}]} {emit {\b%d}} } -62 {emit {\b, progressive} if {[N c [I 4 S 6] x {}]} {emit {\b, precision %d}} if {[N S [I 4 S 7] x {}]} {emit {\b, %dx}} if {[N S [I 4 S 9] x {}]} {emit {\b%d}} } } -32768 {emit {lif file}} -30875 {emit {disk quotas file}} 1286 {emit {IRIS Showcase file} if {[N c 2 == 0x49]} {emit -} if {[N c 3 x {}]} {emit {- version %ld}} } 550 {emit {IRIS Showcase template} if {[N c 2 == 0x63]} {emit -} if {[N c 3 x {}]} {emit {- version %ld}} } 352 {emit {MIPSEB ECOFF executable} switch -- [Nv S 20] 263 {emit {\(impure\)}} 264 {emit {\(swapped\)}} 267 {emit {\(paged\)}} if {[N I 8 > 0x0]} {emit {not stripped}} if {[N I 8 == 0x0]} {emit stripped} if {[N c 22 x {}]} {emit {- version %ld}} if {[N c 23 x {}]} {emit .%ld} } 354 {emit {MIPSEL-BE ECOFF executable} switch -- [Nv S 20] 263 {emit {\(impure\)}} 264 {emit {\(swapped\)}} 267 {emit {\(paged\)}} if {[N I 8 > 0x0]} {emit {not stripped}} if {[N I 8 == 0x0]} {emit stripped} if {[N c 23 x {}]} {emit {- version %d}} if {[N c 22 x {}]} {emit .%ld} } 24577 {emit {MIPSEB-LE ECOFF executable} switch -- [Nv S 20] 1793 {emit {\(impure\)}} 2049 {emit {\(swapped\)}} 2817 {emit {\(paged\)}} if {[N I 8 > 0x0]} {emit {not stripped}} if {[N I 8 == 0x0]} {emit stripped} if {[N c 23 x {}]} {emit {- version %d}} if {[N c 22 x {}]} {emit .%ld} } 25089 {emit {MIPSEL ECOFF executable} switch -- [Nv S 20] 1793 {emit {\(impure\)}} 2049 {emit {\(swapped\)}} 2817 {emit {\(paged\)}} if {[N I 8 > 0x0]} {emit {not stripped}} if {[N I 8 == 0x0]} {emit stripped} if {[N c 23 x {}]} {emit {- version %ld}} if {[N c 22 x {}]} {emit .%ld} } 355 {emit {MIPSEB MIPS-II ECOFF executable} switch -- [Nv S 20] 263 {emit {\(impure\)}} 264 {emit {\(swapped\)}} 267 {emit {\(paged\)}} if {[N I 8 > 0x0]} {emit {not stripped}} if {[N I 8 == 0x0]} {emit stripped} if {[N c 22 x {}]} {emit {- version %ld}} if {[N c 23 x {}]} {emit .%ld} } 358 {emit {MIPSEL-BE MIPS-II ECOFF executable} switch -- [Nv S 20] 263 {emit {\(impure\)}} 264 {emit {\(swapped\)}} 267 {emit {\(paged\)}} if {[N I 8 > 0x0]} {emit {not stripped}} if {[N I 8 == 0x0]} {emit stripped} if {[N c 22 x {}]} {emit {- version %ld}} if {[N c 23 x {}]} {emit .%ld} } 25345 {emit {MIPSEB-LE MIPS-II ECOFF executable} switch -- [Nv S 20] 1793 {emit {\(impure\)}} 2049 {emit {\(swapped\)}} 2817 {emit {\(paged\)}} if {[N I 8 > 0x0]} {emit {not stripped}} if {[N I 8 == 0x0]} {emit stripped} if {[N c 23 x {}]} {emit {- version %ld}} if {[N c 22 x {}]} {emit .%ld} } 26113 {emit {MIPSEL MIPS-II ECOFF executable} switch -- [Nv S 20] 1793 {emit {\(impure\)}} 2049 {emit {\(swapped\)}} 2817 {emit {\(paged\)}} if {[N I 8 > 0x0]} {emit {not stripped}} if {[N I 8 == 0x0]} {emit stripped} if {[N c 23 x {}]} {emit {- version %ld}} if {[N c 22 x {}]} {emit .%ld} } 320 {emit {MIPSEB MIPS-III ECOFF executable} switch -- [Nv S 20] 263 {emit {\(impure\)}} 264 {emit {\(swapped\)}} 267 {emit {\(paged\)}} if {[N I 8 > 0x0]} {emit {not stripped}} if {[N I 8 == 0x0]} {emit stripped} if {[N c 22 x {}]} {emit {- version %ld}} if {[N c 23 x {}]} {emit .%ld} } 322 {emit {MIPSEL-BE MIPS-III ECOFF executable} switch -- [Nv S 20] 263 {emit {\(impure\)}} 264 {emit {\(swapped\)}} 267 {emit {\(paged\)}} if {[N I 8 > 0x0]} {emit {not stripped}} if {[N I 8 == 0x0]} {emit stripped} if {[N c 22 x {}]} {emit {- version %ld}} if {[N c 23 x {}]} {emit .%ld} } 16385 {emit {MIPSEB-LE MIPS-III ECOFF executable} switch -- [Nv S 20] 1793 {emit {\(impure\)}} 2049 {emit {\(swapped\)}} 2817 {emit {\(paged\)}} if {[N I 8 > 0x0]} {emit {not stripped}} if {[N I 8 == 0x0]} {emit stripped} if {[N c 23 x {}]} {emit {- version %ld}} if {[N c 22 x {}]} {emit .%ld} } 16897 {emit {MIPSEL MIPS-III ECOFF executable} switch -- [Nv S 20] 1793 {emit {\(impure\)}} 2049 {emit {\(swapped\)}} 2817 {emit {\(paged\)}} if {[N I 8 > 0x0]} {emit {not stripped}} if {[N I 8 == 0x0]} {emit stripped} if {[N c 23 x {}]} {emit {- version %ld}} if {[N c 22 x {}]} {emit .%ld} } 384 {emit {MIPSEB Ucode}} 386 {emit {MIPSEL-BE Ucode}} 336 {emit {mc68k COFF} if {[N S 18 ^ 0x10]} {emit object} if {[N S 18 & 0x10]} {emit executable} if {[N I 12 > 0x0]} {emit {not stripped}} if {[S 168 == .lowmem]} {emit {Apple toolbox}} switch -- [Nv S 20] 263 {emit {\(impure\)}} 264 {emit {\(pure\)}} 267 {emit {\(demand paged\)}} 273 {emit {\(standalone\)}} } 337 {emit {mc68k executable \(shared\)} if {[N I 12 > 0x0]} {emit {not stripped}} } 338 {emit {mc68k executable \(shared demand paged\)} if {[N I 12 > 0x0]} {emit {not stripped}} } 364 {emit {68K BCS executable}} 365 {emit {88K BCS executable}} 24602 {emit {Atari 68xxx executable,} if {[N I 2 x {}]} {emit {text len %lu,}} if {[N I 6 x {}]} {emit {data len %lu,}} if {[N I 10 x {}]} {emit {BSS len %lu,}} if {[N I 14 x {}]} {emit {symboltab len %lu,}} if {[N I 18 == 0x0]} {emit 0 70 4} if {[N I 22 & 0x1]} {emit {fastload flag,}} if {[N I 22 & 0x2]} {emit {may be loaded to alternate RAM,}} if {[N I 22 & 0x4]} {emit {malloc may be from alternate RAM,}} if {[N I 22 x {}]} {emit {flags: 0x%lX,}} if {[N S 26 == 0x0]} {emit {no relocation tab}} if {[N S 26 != 0x0]} {emit {+ relocation tab}} if {[S 30 == SFX]} {emit {[Self-Extracting LZH SFX archive]}} if {[S 38 == SFX]} {emit {[Self-Extracting LZH SFX archive]}} if {[S 44 == ZIP!]} {emit {[Self-Extracting ZIP SFX archive]}} } 100 {emit {Atari 68xxx CPX file} if {[N S 8 x {}]} {emit {\(version %04lx\)}} } 392 {emit {Tower/XP rel 2 object} if {[N I 12 > 0x0]} {emit {not stripped}} switch -- [Nv S 20] 263 {emit executable} 264 {emit {pure executable}} if {[N S 22 > 0x0]} {emit {- version %ld}} } 397 {emit {Tower/XP rel 2 object} if {[N I 12 > 0x0]} {emit {not stripped}} switch -- [Nv S 20] 263 {emit executable} 264 {emit {pure executable}} if {[N S 22 > 0x0]} {emit {- version %ld}} } 400 {emit {Tower/XP rel 3 object} if {[N I 12 > 0x0]} {emit {not stripped}} switch -- [Nv S 20] 263 {emit executable} 264 {emit {pure executable}} if {[N S 22 > 0x0]} {emit {- version %ld}} } 405 {emit {Tower/XP rel 3 object} if {[N I 12 > 0x0]} {emit {not stripped}} switch -- [Nv S 20] 263 {emit executable} 264 {emit {pure executable}} if {[N S 22 > 0x0]} {emit {- version %ld}} } 408 {emit {Tower32/600/400 68020 object} if {[N I 12 > 0x0]} {emit {not stripped}} switch -- [Nv S 20] 263 {emit executable} 264 {emit {pure executable}} if {[N S 22 > 0x0]} {emit {- version %ld}} } 416 {emit {Tower32/800 68020} if {[N S 18 & 0x2000]} {emit {w/68881 object}} if {[N S 18 & 0x4000]} {emit {compatible object}} if {[N S 18 & 0xffff9fff]} {emit object} switch -- [Nv S 20] 263 {emit executable} 267 {emit {pure executable}} if {[N I 12 > 0x0]} {emit {not stripped}} if {[N S 22 > 0x0]} {emit {- version %ld}} } 421 {emit {Tower32/800 68010} if {[N S 18 & 0x4000]} {emit {compatible object}} if {[N S 18 & 0xffff9fff]} {emit object} switch -- [Nv S 20] 263 {emit executable} 267 {emit {pure executable}} if {[N I 12 > 0x0]} {emit {not stripped}} if {[N S 22 > 0x0]} {emit {- version %ld}} } -30771 {emit {OS9/6809 module:} switch -- [Nv c 6 &0x0f] 0 {emit non-executable} 1 {emit {machine language}} 2 {emit {BASIC I-code}} 3 {emit {Pascal P-code}} 4 {emit {C I-code}} 5 {emit {COBOL I-code}} 6 {emit {Fortran I-code}} switch -- [Nv c 6 &0xf0] 16 {emit {program executable}} 32 {emit subroutine} 48 {emit multi-module} 64 {emit {data module}} -64 {emit {system module}} -48 {emit {file manager}} -32 {emit {device driver}} -16 {emit {device descriptor}} } 19196 {emit {OS9/68K module:} if {[N c 20 == 0x80 &0x80]} {emit re-entrant} if {[N c 20 == 0x40 &0x40]} {emit ghost} if {[N c 20 == 0x20 &0x20]} {emit system-state} switch -- [Nv c 19] 1 {emit {machine language}} 2 {emit {BASIC I-code}} 3 {emit {Pascal P-code}} 4 {emit {C I-code}} 5 {emit {COBOL I-code}} 6 {emit {Fortran I-code}} switch -- [Nv c 18] 1 {emit {program executable}} 2 {emit subroutine} 3 {emit multi-module} 4 {emit {data module}} 11 {emit {trap library}} 12 {emit {system module}} 13 {emit {file manager}} 14 {emit {device driver}} 15 {emit {device descriptor}} } -26368 {emit {PGP key public ring}} -27391 {emit {PGP key security ring}} -27392 {emit {PGP key security ring}} -23040 {emit {PGP encrypted data}} -4693 {emit {} if {[N S 2 == 0xeedb]} {emit RPM if {[N c 4 x {}]} {emit v%d} switch -- [Nv S 6] 0 {emit bin} 1 {emit src} switch -- [Nv S 8] 1 {emit i386} 2 {emit Alpha} 3 {emit Sparc} 4 {emit MIPS} 5 {emit PowerPC} 6 {emit 68000} 7 {emit SGI} 8 {emit RS6000} 9 {emit IA64} 10 {emit Sparc64} 11 {emit MIPSel} 12 {emit ARM} if {[S 10 x {}]} {emit %s} } } -1279 {emit {QDOS object} if {[S 2 x {} p]} {emit '%s'} } -511 {emit {MySQL table definition file} if {[N c 2 x {}]} {emit {Version %d}} } 378 {emit {amd 29k coff noprebar executable}} 890 {emit {amd 29k coff prebar executable}} -8185 {emit {amd 29k coff archive}} if {[S 0 == {TADS2\ bin}]} {emit TADS if {[N I 9 != 0xa0d1a00]} {emit {game data, CORRUPTED}} if {[N I 9 == 0xa0d1a00]} {if {[S 13 x {}]} {emit {%s game data}} } } if {[S 0 == {TADS2\ rsc}]} {emit TADS if {[N I 9 != 0xa0d1a00]} {emit {resource data, CORRUPTED}} if {[N I 9 == 0xa0d1a00]} {if {[S 13 x {}]} {emit {%s resource data}} } } if {[S 0 == {TADS2\ save/g}]} {emit TADS if {[N I 12 != 0xa0d1a00]} {emit {saved game data, CORRUPTED}} if {[N I 12 == 0xa0d1a00]} {if {[S [I 16 s 32] x {}]} {emit {%s saved game data}} } } if {[S 0 == {TADS2\ save}]} {emit TADS if {[N I 10 != 0xa0d1a00]} {emit {saved game data, CORRUPTED}} if {[N I 10 == 0xa0d1a00]} {if {[S 14 x {}]} {emit {%s saved game data}} } } switch -- [Nv i 0] -1010055483 {emit {RISC OS Chunk data} if {[S 12 == OBJ_]} {emit {\b, AOF object}} if {[S 12 == LIB_]} {emit {\b, ALF library}} } 65389 {emit {very old VAX archive}} 65381 {emit {old VAX archive} if {[S 8 == __.SYMDEF]} {emit {random library}} } 236525 {emit {PDP-11 old archive}} 236526 {emit {PDP-11 4.0 archive}} 6583086 {emit {DEC audio data:} switch -- [Nv i 12] 1 {emit {8-bit ISDN mu-law,}} 2 {emit {8-bit linear PCM [REF-PCM],}} 3 {emit {16-bit linear PCM,}} 4 {emit {24-bit linear PCM,}} 5 {emit {32-bit linear PCM,}} 6 {emit {32-bit IEEE floating point,}} 7 {emit {64-bit IEEE floating point,}} 23 {emit {8-bit ISDN mu-law compressed \(CCITT G.721 ADPCM voice data encoding\),}} switch -- [Nv I 12] 8 {emit {Fragmented sample data,}} 10 {emit {DSP program,}} 11 {emit {8-bit fixed point,}} 12 {emit {16-bit fixed point,}} 13 {emit {24-bit fixed point,}} 14 {emit {32-bit fixed point,}} 18 {emit {16-bit linear with emphasis,}} 19 {emit {16-bit linear compressed,}} 20 {emit {16-bit linear with emphasis and compression,}} 21 {emit {Music kit DSP commands,}} 24 {emit {compressed \(8-bit CCITT G.722 ADPCM\)}} 25 {emit {compressed \(3-bit CCITT G.723.3 ADPCM\),}} 26 {emit {compressed \(5-bit CCITT G.723.5 ADPCM\),}} 27 {emit {8-bit A-law \(CCITT G.711\),}} switch -- [Nv i 20] 1 {emit mono,} 2 {emit stereo,} 4 {emit quad,} if {[N i 16 > 0x0]} {emit {%d Hz}} } 204 {emit {386 compact demand paged pure executable} if {[N i 16 > 0x0]} {emit {not stripped}} if {[N c 32 == 0x6a]} {emit {\(uses shared libs\)}} } 263 {emit {386 executable} if {[N i 16 > 0x0]} {emit {not stripped}} if {[N c 32 == 0x6a]} {emit {\(uses shared libs\)}} } 264 {emit {386 pure executable} if {[N i 16 > 0x0]} {emit {not stripped}} if {[N c 32 == 0x6a]} {emit {\(uses shared libs\)}} } 267 {emit {386 demand paged pure executable} if {[N i 16 > 0x0]} {emit {not stripped}} if {[N c 32 == 0x6a]} {emit {\(uses shared libs\)}} } 324508366 {emit {GNU dbm 1.x or ndbm database, little endian}} 340322 {emit {Berkeley DB 1.85/1.86} if {[N i 4 > 0x0]} {emit {\(Btree, version %d, little-endian\)}} } -109248628 {emit {SE Linux policy} if {[N i 16 x {}]} {emit v%d} if {[N i 20 == 0x1]} {emit MLS} if {[N i 24 x {}]} {emit {%d symbols}} if {[N i 28 x {}]} {emit {%d ocons}} } 453186358 {emit {Netboot image,} if {[N i 4 == 0x0 &0xFFFFFF00]} {switch -- [Nv i 4 &0x100] 0 {emit {mode 2}} 256 {emit {mode 3}} } if {[N i 4 != 0x0 &0xFFFFFF00]} {emit {unknown mode}} } 684539205 {emit {Linux Compressed ROM File System data, little endian} if {[N i 4 x {}]} {emit {size %d}} if {[N i 8 & 0x1]} {emit {version \#2}} if {[N i 8 & 0x2]} {emit sorted_dirs} if {[N i 8 & 0x4]} {emit hole_support} if {[N i 32 x {}]} {emit {CRC 0x%x,}} if {[N i 36 x {}]} {emit {edition %d,}} if {[N i 40 x {}]} {emit {%d blocks,}} if {[N i 44 x {}]} {emit {%d files}} } 876099889 {emit {Linux Journalled Flash File system, little endian}} -536798843 {emit {Linux jffs2 filesystem data little endian}} 4 {emit {X11 SNF font data, LSB first}} 1279543401 {emit {ld.so hints file \(Little Endian} if {[N i 4 > 0x0]} {emit {\b, version %d\)}} if {[N I 4 <= 0x0]} {emit {\b\)}} } 1638399 {emit {GEM Metafile data} if {[N s 4 x {}]} {emit {version %d}} } 987654321 {emit {DCX multi-page PCX image data}} -681629056 {emit {Cineon image data} if {[N I 200 > 0x0]} {emit {\b, %ld x}} if {[N I 204 > 0x0]} {emit %ld} } 20000630 {emit {OpenEXR image data}} 6553863 {emit {Linux/i386 impure executable \(OMAGIC\)} if {[N i 16 == 0x0]} {emit {\b, stripped}} } 6553864 {emit {Linux/i386 pure executable \(NMAGIC\)} if {[N i 16 == 0x0]} {emit {\b, stripped}} } 6553867 {emit {Linux/i386 demand-paged executable \(ZMAGIC\)} if {[N i 16 == 0x0]} {emit {\b, stripped}} } 6553804 {emit {Linux/i386 demand-paged executable \(QMAGIC\)} if {[N i 16 == 0x0]} {emit {\b, stripped}} } 336851773 {emit {SYSLINUX' LSS16 image data} if {[N s 4 x {}]} {emit {\b, width %d}} if {[N s 6 x {}]} {emit {\b, height %d}} } -249691108 {emit {magic binary file for file\(1\) cmd} if {[N i 4 x {}]} {emit {\(version %d\) \(little endian\)}} } 574529400 {emit {Transport Neutral Encapsulation Format}} -21555 {emit {MLSSA datafile,} if {[N s 4 x {}]} {emit {algorithm %d,}} if {[N i 10 x {}]} {emit {%d samples}} } 134769520 {emit {TurboC BGI file}} 134761296 {emit {TurboC Font file}} 76 {emit {} if {[N i 4 == 0x21401]} {emit {Windows shortcut file}} } 1313096225 {emit {Microsoft Outlook binary email folder}} 220991 {emit {Windows 3.x help file}} 263 {emit {a.out NetBSD little-endian object file} if {[N i 16 > 0x0]} {emit {not stripped}} } 459141 {emit {ECOFF NetBSD/alpha binary} switch -- [Nv s 10] 1 {emit {not stripped}} 0 {emit stripped} } 33645 {emit {PDP-11 single precision APL workspace}} 33644 {emit {PDP-11 double precision APL workspace}} 268435511 {emit {Psion Series 5} switch -- [Nv i 4] 268435513 {emit {font file}} 268435514 {emit {printer driver}} 268435515 {emit clipboard} 268435522 {emit {multi-bitmap image}} 268435562 {emit {application infomation file}} 268435565 {emit {} switch -- [Nv i 8] 268435581 {emit {sketch image}} 268435582 {emit {voice note}} 268435583 {emit {word file}} 268435589 {emit {OPL program}} 268435592 {emit {sheet file}} 268435908 {emit {EasyFax initialisation file}} } 268435571 {emit {OPO module}} 268435572 {emit {OPL application}} 268435594 {emit {exported multi-bitmap image}} } 268435521 {emit {Psion Series 5 ROM multi-bitmap image}} 268435536 {emit {Psion Series 5} switch -- [Nv i 4] 268435565 {emit database} 268435684 {emit {ini file}} } 268435577 {emit {Psion Series 5 binary:} switch -- [Nv i 4] 0 {emit DLL} 268435529 {emit {comms hardware library}} 268435530 {emit {comms protocol library}} 268435549 {emit OPX} 268435564 {emit application} 268435597 {emit DLL} 268435628 {emit {logical device driver}} 268435629 {emit {physical device driver}} 268435685 {emit {file transfer protocol}} 268435685 {emit {file transfer protocol}} 268435776 {emit {printer defintion}} 268435777 {emit {printer defintion}} } 268435578 {emit {Psion Series 5 executable}} 234 {emit {BALANCE NS32000 .o} if {[N i 16 > 0x0]} {emit {not stripped}} if {[N i 124 > 0x0]} {emit {version %ld}} } 4330 {emit {BALANCE NS32000 executable \(0 @ 0\)} if {[N i 16 > 0x0]} {emit {not stripped}} if {[N i 124 > 0x0]} {emit {version %ld}} } 8426 {emit {BALANCE NS32000 executable \(invalid @ 0\)} if {[N i 16 > 0x0]} {emit {not stripped}} if {[N i 124 > 0x0]} {emit {version %ld}} } 12522 {emit {BALANCE NS32000 standalone executable} if {[N i 16 > 0x0]} {emit {not stripped}} if {[N i 124 > 0x0]} {emit {version %ld}} } 320013059 {emit {SpeedShop data file}} 16922978 {emit {mdbm file, version 0 \(obsolete\)}} -1582119980 {emit {tcpdump capture file \(little-endian\)} if {[N s 4 x {}]} {emit {- version %d}} if {[N s 6 x {}]} {emit {\b.%d}} switch -- [Nv i 20] 0 {emit {\(No link-layer encapsulation}} 1 {emit {\(Ethernet}} 2 {emit {\(3Mb Ethernet}} 3 {emit {\(AX.25}} 4 {emit {\(ProNET}} 5 {emit {\(CHAOS}} 6 {emit {\(Token Ring}} 7 {emit {\(ARCNET}} 8 {emit {\(SLIP}} 9 {emit {\(PPP}} 10 {emit {\(FDDI}} 11 {emit {\(RFC 1483 ATM}} 12 {emit {\(raw IP}} 13 {emit {\(BSD/OS SLIP}} 14 {emit {\(BSD/OS PPP}} 19 {emit {\(Linux ATM Classical IP}} 50 {emit {\(PPP or Cisco HDLC}} 51 {emit {\(PPP-over-Ethernet}} 99 {emit {\(Symantec Enterprise Firewall}} 100 {emit {\(RFC 1483 ATM}} 101 {emit {\(raw IP}} 102 {emit {\(BSD/OS SLIP}} 103 {emit {\(BSD/OS PPP}} 104 {emit {\(BSD/OS Cisco HDLC}} 105 {emit {\(802.11}} 106 {emit {\(Linux Classical IP over ATM}} 107 {emit {\(Frame Relay}} 108 {emit {\(OpenBSD loopback}} 109 {emit {\(OpenBSD IPsec encrypted}} 112 {emit {\(Cisco HDLC}} 113 {emit {\(Linux \"cooked\"}} 114 {emit {\(LocalTalk}} 117 {emit {\(OpenBSD PFLOG}} 119 {emit {\(802.11 with Prism header}} 122 {emit {\(RFC 2625 IP over Fibre Channel}} 123 {emit {\(SunATM}} 127 {emit {\(802.11 with radiotap header}} 129 {emit {\(Linux ARCNET}} 138 {emit {\(Apple IP over IEEE 1394}} 140 {emit {\(MTP2}} 141 {emit {\(MTP3}} 143 {emit {\(DOCSIS}} 144 {emit {\(IrDA}} 147 {emit {\(Private use 0}} 148 {emit {\(Private use 1}} 149 {emit {\(Private use 2}} 150 {emit {\(Private use 3}} 151 {emit {\(Private use 4}} 152 {emit {\(Private use 5}} 153 {emit {\(Private use 6}} 154 {emit {\(Private use 7}} 155 {emit {\(Private use 8}} 156 {emit {\(Private use 9}} 157 {emit {\(Private use 10}} 158 {emit {\(Private use 11}} 159 {emit {\(Private use 12}} 160 {emit {\(Private use 13}} 161 {emit {\(Private use 14}} 162 {emit {\(Private use 15}} 163 {emit {\(802.11 with AVS header}} if {[N i 16 x {}]} {emit {\b, capture length %d\)}} } -1582117580 {emit {extended tcpdump capture file \(little-endian\)} if {[N s 4 x {}]} {emit {- version %d}} if {[N s 6 x {}]} {emit {\b.%d}} switch -- [Nv i 20] 0 {emit {\(No link-layer encapsulation}} 1 {emit {\(Ethernet}} 2 {emit {\(3Mb Ethernet}} 3 {emit {\(AX.25}} 4 {emit {\(ProNET}} 5 {emit {\(CHAOS}} 6 {emit {\(Token Ring}} 7 {emit {\(ARCNET}} 8 {emit {\(SLIP}} 9 {emit {\(PPP}} 10 {emit {\(FDDI}} 11 {emit {\(RFC 1483 ATM}} 12 {emit {\(raw IP}} 13 {emit {\(BSD/OS SLIP}} 14 {emit {\(BSD/OS PPP}} if {[N i 16 x {}]} {emit {\b, capture length %d\)}} } 33647 {emit {VAX single precision APL workspace}} 33646 {emit {VAX double precision APL workspace}} 263 {emit {VAX executable} if {[N i 16 > 0x0]} {emit {not stripped}} } 264 {emit {VAX pure executable} if {[N i 16 > 0x0]} {emit {not stripped}} } 267 {emit {VAX demand paged pure executable} if {[N i 16 > 0x0]} {emit {not stripped}} } 272 {emit {VAX demand paged \(first page unmapped\) pure executable} if {[N i 16 > 0x0]} {emit {not stripped}} } 518 {emit b.out if {[N s 30 & 0x10]} {emit overlay} if {[N s 30 & 0x2]} {emit separate} if {[N s 30 & 0x4]} {emit pure} if {[N s 30 & 0x800]} {emit segmented} if {[N s 30 & 0x400]} {emit standalone} if {[N s 30 & 0x1]} {emit executable} if {[N s 30 ^ 0x1]} {emit {object file}} if {[N s 30 & 0x4000]} {emit V2.3} if {[N s 30 & 0x8000]} {emit V3.0} if {[N c 28 & 0x4]} {emit 86} if {[N c 28 & 0xb]} {emit 186} if {[N c 28 & 0x9]} {emit 286} if {[N c 28 & 0x29]} {emit 286} if {[N c 28 & 0xa]} {emit 386} if {[N s 30 & 0x4]} {emit {Large Text}} if {[N s 30 & 0x2]} {emit {Large Data}} if {[N s 30 & 0x102]} {emit {Huge Objects Enabled}} } if {[N i 16 == 0xef000011]} {emit {RISC OS AIF executable}} if {[S 0 == Draw]} {emit {RISC OS Draw file data}} if {[S 0 == {FONT\0}]} {emit {RISC OS outline font data,} if {[N c 5 x {}]} {emit {version %d}} } if {[S 0 == {FONT\1}]} {emit {RISC OS 1bpp font data,} if {[N c 5 x {}]} {emit {version %d}} } if {[S 0 == {FONT\4}]} {emit {RISC OS 4bpp font data} if {[N c 5 x {}]} {emit {version %d}} } if {[S 0 == {Maestro\r}]} {emit {RISC OS music file} if {[N c 8 x {}]} {emit {version %d}} } switch -- [Nv s 0] 21020 {emit {COFF DSP21k} if {[N i 18 & 0x2]} {emit executable,} if {[N i 18 ^ 0x2]} {if {[N i 18 & 0x1]} {emit {static object,}} if {[N i 18 ^ 0x1]} {emit {relocatable object,}} } if {[N i 18 & 0x8]} {emit stripped} if {[N i 18 ^ 0x8]} {emit {not stripped}} } 387 {emit {COFF format alpha} if {[N s 22 != 0x2000 &030000]} {emit executable} switch -- [Nv s 24] 264 {emit pure} 267 {emit paged} 263 {emit object} if {[N s 22 != 0x0 &020000]} {emit {dynamically linked}} if {[N i 16 != 0x0]} {emit {not stripped}} if {[N i 16 == 0x0]} {emit stripped} if {[N s 22 == 0x2000 &030000]} {emit {shared library}} if {[N c 27 x {}]} {emit {- version %d}} if {[N c 26 x {}]} {emit .%d} if {[N c 28 x {}]} {emit -%d} } -147 {emit {very old PDP-11 archive}} -155 {emit {old PDP-11 archive} if {[S 8 == __.SYMDEF]} {emit {random library}} } -5536 {emit {ARJ archive data} if {[N c 5 x {}]} {emit {\b, v%d,}} if {[N c 8 & 0x4]} {emit multi-volume,} if {[N c 8 & 0x10]} {emit slash-switched,} if {[N c 8 & 0x20]} {emit backup,} if {[S 34 x {}]} {emit {original name: %s,}} switch -- [Nv c 7] 0 {emit {os: MS-DOS}} 1 {emit {os: PRIMOS}} 2 {emit {os: Unix}} 3 {emit {os: Amiga}} 4 {emit {os: Macintosh}} 5 {emit {os: OS/2}} 6 {emit {os: Apple ][ GS}} 7 {emit {os: Atari ST}} 8 {emit {os: NeXT}} 9 {emit {os: VAX/VMS}} if {[N c 3 > 0x0]} {emit %d\]} } -5247 {emit {PRCS packaged project}} 387 {emit {COFF format alpha} if {[N s 22 & 0x1000 &020000]} {emit {sharable library,}} if {[N s 22 ^ 0x1000 &020000]} {emit {dynamically linked,}} switch -- [Nv s 24] 264 {emit pure} 267 {emit {demand paged}} if {[N i 8 > 0x0]} {emit {executable or object module, not stripped}} if {[N i 8 == 0x0]} {if {[N i 12 == 0x0]} {emit {executable or object module, stripped}} if {[N i 12 > 0x0]} {emit {executable or object module, not stripped}} } if {[N c 27 > 0x0]} {emit {- version %d.}} if {[N c 26 > 0x0]} {emit %d-} if {[N s 28 > 0x0]} {emit %d} } 392 {emit {Alpha compressed COFF}} 399 {emit {Alpha u-code object}} 6532 {emit {Linux old jffs2 filesystem data little endian}} 1360 {emit {Hitachi SH little-endian COFF} switch -- [Nv s 18 &0x0002] 0 {emit object} 2 {emit executable} switch -- [Nv s 18 &0x0008] 8 {emit {\b, stripped}} 0 {emit {\b, not stripped}} } -13230 {emit {RLE image data,} if {[N s 6 x {}]} {emit {%d x}} if {[N s 8 x {}]} {emit %d} if {[N s 2 > 0x0]} {emit {\b, lower left corner: %d}} if {[N s 4 > 0x0]} {emit {\b, lower right corner: %d}} if {[N c 10 == 0x1 &0x1]} {emit {\b, clear first}} if {[N c 10 == 0x2 &0x2]} {emit {\b, no background}} if {[N c 10 == 0x4 &0x4]} {emit {\b, alpha channel}} if {[N c 10 == 0x8 &0x8]} {emit {\b, comment}} if {[N c 11 > 0x0]} {emit {\b, %d color channels}} if {[N c 12 > 0x0]} {emit {\b, %d bits per pixel}} if {[N c 13 > 0x0]} {emit {\b, %d color map channels}} } 322 {emit {basic-16 executable} if {[N i 12 > 0x0]} {emit {not stripped}} } 323 {emit {basic-16 executable \(TV\)} if {[N i 12 > 0x0]} {emit {not stripped}} } 328 {emit {x86 executable} if {[N i 12 > 0x0]} {emit {not stripped}} } 329 {emit {x86 executable \(TV\)} if {[N i 12 > 0x0]} {emit {not stripped}} } 330 {emit {iAPX 286 executable small model \(COFF\)} if {[N i 12 > 0x0]} {emit {not stripped}} } 338 {emit {iAPX 286 executable large model \(COFF\)} if {[N i 12 > 0x0]} {emit {not stripped}} } 332 {emit {80386 COFF executable} if {[N i 12 > 0x0]} {emit {not stripped}} if {[N s 22 > 0x0]} {emit {- version %ld}} } 1078 {emit {Linux/i386 PC Screen Font data,} switch -- [Nv c 2] 0 {emit {256 characters, no directory,}} 1 {emit {512 characters, no directory,}} 2 {emit {256 characters, Unicode directory,}} 3 {emit {512 characters, Unicode directory,}} if {[N c 3 > 0x0]} {emit 8x%d} } 387 {emit {ECOFF alpha} switch -- [Nv s 24] 263 {emit executable} 264 {emit pure} 267 {emit {demand paged}} if {[N Q 8 > 0x0]} {emit {not stripped}} if {[N Q 8 == 0x0]} {emit stripped} if {[N s 23 > 0x0]} {emit {- version %ld.}} } 332 {emit {MS Windows COFF Intel 80386 object file}} 358 {emit {MS Windows COFF MIPS R4000 object file}} 388 {emit {MS Windows COFF Alpha object file}} 616 {emit {MS Windows COFF Motorola 68000 object file}} 496 {emit {MS Windows COFF PowerPC object file}} 656 {emit {MS Windows COFF PA-RISC object file}} 6 {emit {DBase 3 index file}} -24712 {emit TNEF} 263 {emit {PDP-11 executable} if {[N s 8 > 0x0]} {emit {not stripped}} if {[N c 15 > 0x0]} {emit {- version %ld}} } 257 {emit {PDP-11 UNIX/RT ldp}} 261 {emit {PDP-11 old overlay}} 264 {emit {PDP-11 pure executable} if {[N s 8 > 0x0]} {emit {not stripped}} if {[N c 15 > 0x0]} {emit {- version %ld}} } 265 {emit {PDP-11 separate I&D executable} if {[N s 8 > 0x0]} {emit {not stripped}} if {[N c 15 > 0x0]} {emit {- version %ld}} } 287 {emit {PDP-11 kernel overlay}} 267 {emit {PDP-11 demand-paged pure executable} if {[N s 8 > 0x0]} {emit {not stripped}} } 280 {emit {PDP-11 overlaid pure executable} if {[N s 8 > 0x0]} {emit {not stripped}} } 281 {emit {PDP-11 overlaid separate executable} if {[N s 8 > 0x0]} {emit {not stripped}} } 4843 {emit {SYMMETRY i386 .o} if {[N i 16 > 0x0]} {emit {not stripped}} if {[N i 124 > 0x0]} {emit {version %ld}} } 8939 {emit {SYMMETRY i386 executable \(0 @ 0\)} if {[N i 16 > 0x0]} {emit {not stripped}} if {[N i 124 > 0x0]} {emit {version %ld}} } 13035 {emit {SYMMETRY i386 executable \(invalid @ 0\)} if {[N i 16 > 0x0]} {emit {not stripped}} if {[N i 124 > 0x0]} {emit {version %ld}} } 17131 {emit {SYMMETRY i386 standalone executable} if {[N i 16 > 0x0]} {emit {not stripped}} if {[N i 124 > 0x0]} {emit {version %ld}} } 21020 {emit {SHARC COFF binary} if {[N s 2 > 0x1]} {emit {, %hd sections} if {[N i 12 > 0x0]} {emit {, not stripped}} } } 4097 {emit {LANalyzer capture file}} 4103 {emit {LANalyzer capture file}} 376 {emit {VAX COFF executable} if {[N i 12 > 0x0]} {emit {not stripped}} if {[N s 22 > 0x0]} {emit {- version %ld}} } 381 {emit {VAX COFF pure executable} if {[N i 12 > 0x0]} {emit {not stripped}} if {[N s 22 > 0x0]} {emit {- version %ld}} } -155 {emit x.out if {[S 2 == __.SYMDEF]} {emit randomized} if {[N c 0 x {}]} {emit archive} } 518 {emit {Microsoft a.out} if {[N s 8 == 0x1]} {emit {Middle model}} if {[N s 30 & 0x10]} {emit overlay} if {[N s 30 & 0x2]} {emit separate} if {[N s 30 & 0x4]} {emit pure} if {[N s 30 & 0x800]} {emit segmented} if {[N s 30 & 0x400]} {emit standalone} if {[N s 30 & 0x8]} {emit fixed-stack} if {[N c 28 & 0x80]} {emit byte-swapped} if {[N c 28 & 0x40]} {emit word-swapped} if {[N i 16 > 0x0]} {emit not-stripped} if {[N s 30 ^ 0xc000]} {emit pre-SysV} if {[N s 30 & 0x4000]} {emit V2.3} if {[N s 30 & 0x8000]} {emit V3.0} if {[N c 28 & 0x4]} {emit 86} if {[N c 28 & 0xb]} {emit 186} if {[N c 28 & 0x9]} {emit 286} if {[N c 28 & 0xa]} {emit 386} if {[N c 31 < 0x40]} {emit {small model}} switch -- [Nv c 31] 72 {emit {large model }} 73 {emit {huge model}} if {[N s 30 & 0x1]} {emit executable} if {[N s 30 ^ 0x1]} {emit {object file}} if {[N s 30 & 0x40]} {emit {Large Text}} if {[N s 30 & 0x20]} {emit {Large Data}} if {[N s 30 & 0x120]} {emit {Huge Objects Enabled}} if {[N i 16 > 0x0]} {emit {not stripped}} } 320 {emit {old Microsoft 8086 x.out} if {[N c 3 & 0x4]} {emit separate} if {[N c 3 & 0x2]} {emit pure} if {[N c 0 & 0x1]} {emit executable} if {[N c 0 ^ 0x1]} {emit relocatable} if {[N i 20 > 0x0]} {emit {not stripped}} } 1408 {emit {XENIX 8086 relocatable or 80286 small model}} switch -- [Nv Y 0] 381 {emit {CLIPPER COFF executable \(VAX \#\)} switch -- [Nv Y 20] 263 {emit {\(impure\)}} 264 {emit {\(5.2 compatible\)}} 265 {emit {\(pure\)}} 267 {emit {\(demand paged\)}} 291 {emit {\(target shared library\)}} if {[N Q 12 > 0x0]} {emit {not stripped}} if {[N Y 22 > 0x0]} {emit {- version %ld}} } 383 {emit {CLIPPER COFF executable} switch -- [Nv Y 18 &074000] 0 {emit {C1 R1}} 2048 {emit {C2 R1}} 4096 {emit {C3 R1}} 30720 {emit TEST} switch -- [Nv Y 20] 263 {emit {\(impure\)}} 264 {emit {\(pure\)}} 265 {emit {\(separate I&D\)}} 267 {emit {\(paged\)}} 291 {emit {\(target shared library\)}} if {[N Q 12 > 0x0]} {emit {not stripped}} if {[N Y 22 > 0x0]} {emit {- version %ld}} if {[N Q 48 == 0x1 &01]} {emit {alignment trap enabled}} switch -- [Nv c 52] 1 {emit -Ctnc} 2 {emit -Ctsw} 3 {emit -Ctpw} 4 {emit -Ctcb} switch -- [Nv c 53] 1 {emit -Cdnc} 2 {emit -Cdsw} 3 {emit -Cdpw} 4 {emit -Cdcb} switch -- [Nv c 54] 1 {emit -Csnc} 2 {emit -Cssw} 3 {emit -Cspw} 4 {emit -Cscb} } 272 {emit {0420 Alliant virtual executable} if {[N Y 2 & 0x20]} {emit {common library}} if {[N Q 16 > 0x0]} {emit {not stripped}} } 273 {emit {0421 Alliant compact executable} if {[N Y 2 & 0x20]} {emit {common library}} if {[N Q 16 > 0x0]} {emit {not stripped}} } 29127 {emit {cpio archive}} -14479 {emit {byte-swapped cpio archive}} -147 {emit {very old PDP-11 archive}} -155 {emit {old PDP-11 archive}} 1793 {emit {VAX-order 68K Blit \(standalone\) executable}} 262 {emit {VAX-order2 68k Blit mpx/mux executable}} 1537 {emit {VAX-order 68k Blit mpx/mux executable}} 7967 {emit {old packed data}} 8191 {emit {compacted data}} -13563 {emit {huf output}} 1281 {emit {locale data table} switch -- [Nv Y 6] 36 {emit {for MIPS}} 64 {emit {for Alpha}} } 340 {emit Encore switch -- [Nv Y 20] 263 {emit executable} 264 {emit {pure executable}} 267 {emit {demand-paged executable}} 271 {emit {unsupported executable}} if {[N Q 12 > 0x0]} {emit {not stripped}} if {[N Y 22 > 0x0]} {emit {- version %ld}} if {[N Y 22 == 0x0]} {emit -} } 341 {emit {Encore unsupported executable} if {[N Q 12 > 0x0]} {emit {not stripped}} if {[N Y 22 > 0x0]} {emit {- version %ld}} if {[N Y 22 == 0x0]} {emit -} } 286 {emit {Berkeley vfont data}} 7681 {emit {byte-swapped Berkeley vfont data}} 256 {emit {raw G3 data, byte-padded}} 5120 {emit {raw G3 data}} 373 {emit {i386 COFF object}} 10775 {emit {\"compact bitmap\" format \(Poskanzer\)}} 601 {emit {mumps avl global} if {[N c 2 > 0x0]} {emit {\(V%d\)}} if {[N c 6 > 0x0]} {emit {with %d byte name}} if {[N c 7 > 0x0]} {emit {and %d byte data cells}} } 602 {emit {mumps blt global} if {[N c 2 > 0x0]} {emit {\(V%d\)}} if {[N Y 8 > 0x0]} {emit {- %d byte blocks}} switch -- [Nv c 15] 0 {emit {- P/D format}} 1 {emit {- P/K/D format}} 2 {emit {- K/D format}} if {[N c 15 > 0x2]} {emit {- Bad Flags}} } 10012 {emit {Sendmail frozen configuration} if {[S 16 x {}]} {emit {- version %s}} } -16162 {emit {Compiled PSI \(v1\) data}} -16166 {emit {Compiled PSI \(v2\) data} if {[S 3 x {}]} {emit {\(%s\)}} } -21846 {emit {SoftQuad DESC or font file binary} if {[N Y 2 > 0x0]} {emit {- version %d}} } 283 {emit {Curses screen image}} 284 {emit {Curses screen image}} 263 {emit {unknown machine executable} if {[N Y 8 > 0x0]} {emit {not stripped}} if {[N c 15 > 0x0]} {emit {- version %ld}} } 264 {emit {unknown pure executable} if {[N Y 8 > 0x0]} {emit {not stripped}} if {[N c 15 > 0x0]} {emit {- version %ld}} } 265 {emit {PDP-11 separate I&D} if {[N Y 8 > 0x0]} {emit {not stripped}} if {[N c 15 > 0x0]} {emit {- version %ld}} } 267 {emit {unknown pure executable} if {[N Y 8 > 0x0]} {emit {not stripped}} if {[N c 15 > 0x0]} {emit {- version %ld}} } 392 {emit {Perkin-Elmer executable}} 21845 {emit {VISX image file} switch -- [Nv c 2] 0 {emit {\(zero\)}} 1 {emit {\(unsigned char\)}} 2 {emit {\(short integer\)}} 3 {emit {\(float 32\)}} 4 {emit {\(float 64\)}} 5 {emit {\(signed char\)}} 6 {emit {\(bit-plane\)}} 7 {emit {\(classes\)}} 8 {emit {\(statistics\)}} 10 {emit {\(ascii text\)}} 15 {emit {\(image segments\)}} 100 {emit {\(image set\)}} 101 {emit {\(unsigned char vector\)}} 102 {emit {\(short integer vector\)}} 103 {emit {\(float 32 vector\)}} 104 {emit {\(float 64 vector\)}} 105 {emit {\(signed char vector\)}} 106 {emit {\(bit plane vector\)}} 121 {emit {\(feature vector\)}} 122 {emit {\(feature vector library\)}} 124 {emit {\(chain code\)}} 126 {emit {\(bit vector\)}} -126 {emit {\(graph\)}} -125 {emit {\(adjacency graph\)}} -124 {emit {\(adjacency graph library\)}} if {[S 2 == .VISIX]} {emit {\(ascii text\)}} } if {[S 4 == pipe]} {emit {CLIPPER instruction trace}} if {[S 4 == prof]} {emit {CLIPPER instruction profile}} switch -- [Nv I 0] 1936484385 {emit {Allegro datafile \(packed\)}} 1936484398 {emit {Allegro datafile \(not packed/autodetect\)}} 1936484395 {emit {Allegro datafile \(appended exe data\)}} 1018 {emit {AmigaOS shared library}} 1011 {emit {AmigaOS loadseg\(\)ble executable/binary}} 999 {emit {AmigaOS object/library data}} -2147479551 {emit {AmigaOS outline tag}} 1 {emit {JVT NAL sequence} if {[N c 4 == 0x7 &0x1F]} {emit {\b, H.264 video} switch -- [Nv c 5] 66 {emit {\b, baseline}} 77 {emit {\b, main}} 88 {emit {\b, extended}} if {[N c 7 x {}]} {emit {\b @ L %u}} } } 807842421 {emit {Microsoft ASF}} 333312 {emit {AppleSingle encoded Macintosh file}} 333319 {emit {AppleDouble encoded Macintosh file}} 1711210496 {emit {VAX 3.0 archive}} 1013019198 {emit {VAX 5.0 archive}} 1314148939 {emit {MultiTrack sound data} if {[N I 4 x {}]} {emit {- version %ld}} } 779248125 {emit {RealAudio sound file}} 1688404224 {emit {IRCAM file \(VAX\)}} 1688404480 {emit {IRCAM file \(Sun\)}} 1688404736 {emit {IRCAM file \(MIPS little-endian\)}} 1688404992 {emit {IRCAM file \(NeXT\)}} 1125466468 {emit {X64 Image}} -12432129 {emit {WRAptor packer \(c64\)}} 554074152 {emit {Sega Dreamcast VMU game image}} 931151890 {emit {V64 Nintendo 64 ROM dump}} 327 {emit {Convex old-style object} if {[N I 16 > 0x0]} {emit {not stripped}} } 331 {emit {Convex old-style demand paged executable} if {[N I 16 > 0x0]} {emit {not stripped}} } 333 {emit {Convex old-style pre-paged executable} if {[N I 16 > 0x0]} {emit {not stripped}} } 335 {emit {Convex old-style pre-paged, non-swapped executable} if {[N I 16 > 0x0]} {emit {not stripped}} } 70231 {emit {Core file}} 385 {emit {Convex SOFF} if {[N I 88 == 0x0 &0x000f0000]} {emit c1} if {[N I 88 & 0x10000]} {emit c2} if {[N I 88 & 0x20000]} {emit c2mp} if {[N I 88 & 0x40000]} {emit parallel} if {[N I 88 & 0x80000]} {emit intrinsic} if {[N I 88 & 0x1]} {emit {demand paged}} if {[N I 88 & 0x2]} {emit pre-paged} if {[N I 88 & 0x4]} {emit non-swapped} if {[N I 88 & 0x8]} {emit POSIX} if {[N I 84 & 0x80000000]} {emit executable} if {[N I 84 & 0x40000000]} {emit object} if {[N I 84 == 0x0 &0x20000000]} {emit {not stripped}} switch -- [Nv I 84 &0x18000000] 0 {emit {native fpmode}} 268435456 {emit {ieee fpmode}} 402653184 {emit {undefined fpmode}} } 389 {emit {Convex SOFF core}} 391 {emit {Convex SOFF checkpoint} if {[N I 88 == 0x0 &0x000f0000]} {emit c1} if {[N I 88 & 0x10000]} {emit c2} if {[N I 88 & 0x20000]} {emit c2mp} if {[N I 88 & 0x40000]} {emit parallel} if {[N I 88 & 0x80000]} {emit intrinsic} if {[N I 88 & 0x8]} {emit POSIX} switch -- [Nv I 84 &0x18000000] 0 {emit {native fpmode}} 268435456 {emit {ieee fpmode}} 402653184 {emit {undefined fpmode}} } 324508366 {emit {GNU dbm 1.x or ndbm database, big endian}} 398689 {emit {Berkeley DB} switch -- [Nv I 8] 4321 {emit {} if {[N I 4 > 0x2]} {emit 1.86} if {[N I 4 < 0x3]} {emit 1.85} if {[N I 4 > 0x0]} {emit {\(Hash, version %d, big-endian\)}} } 1234 {emit {} if {[N I 4 > 0x2]} {emit 1.86} if {[N I 4 < 0x3]} {emit 1.85} if {[N I 4 > 0x0]} {emit {\(Hash, version %d, native byte-order\)}} } } 340322 {emit {Berkeley DB 1.85/1.86} if {[N I 4 > 0x0]} {emit {\(Btree, version %d, big-endian\)}} } 9994 {emit {ESRI Shapefile} if {[N I 4 == 0x0]} {emit 16 34 0} if {[N I 8 == 0x0]} {emit 16 34 1} if {[N I 12 == 0x0]} {emit 16 34 2} if {[N I 16 == 0x0]} {emit 16 34 3} if {[N I 20 == 0x0]} {emit 16 34 4} if {[N i 28 x {}]} {emit {version %d}} if {[N I 24 x {}]} {emit {length %d}} switch -- [Nv i 32] 0 {emit {type Null Shape}} 1 {emit {type Point}} 3 {emit {type PolyLine}} 5 {emit {type Polygon}} 8 {emit {type MultiPoint}} 11 {emit {type PointZ}} 13 {emit {type PolyLineZ}} 15 {emit {type PolygonZ}} 18 {emit {type MultiPointZ}} 21 {emit {type PointM}} 23 {emit {type PolyLineM}} 25 {emit {type PolygonM}} 28 {emit {type MultiPointM}} 31 {emit {type MultiPatch}} } 199600449 {emit {SGI disk label \(volume header\)}} 1481003842 {emit {SGI XFS filesystem data} if {[N I 4 x {}]} {emit {\(blksz %d,}} if {[N S 104 x {}]} {emit {inosz %d,}} if {[N S 100 ^ 0x2004]} {emit {v1 dirs\)}} if {[N S 100 & 0x2004]} {emit {v2 dirs\)}} } 684539205 {emit {Linux Compressed ROM File System data, big endian} if {[N I 4 x {}]} {emit {size %d}} if {[N I 8 & 0x1]} {emit {version \#2}} if {[N I 8 & 0x2]} {emit sorted_dirs} if {[N I 8 & 0x4]} {emit hole_support} if {[N I 32 x {}]} {emit {CRC 0x%x,}} if {[N I 36 x {}]} {emit {edition %d,}} if {[N I 40 x {}]} {emit {%d blocks,}} if {[N I 44 x {}]} {emit {%d files}} } 876099889 {emit {Linux Journalled Flash File system, big endian}} 654645590 {emit {PPCBoot image} if {[S 4 == PPCBoot]} {if {[S 12 x {}]} {emit {version %s}} } } 4 {emit {X11 SNF font data, MSB first}} 335698201 {emit {libGrx font data,} if {[N s 8 x {}]} {emit %dx} if {[N s 10 x {}]} {emit {\b%d}} if {[S 40 x {}]} {emit %s} } -12169394 {emit {DOS code page font data collection}} 1279543401 {emit {ld.so hints file \(Big Endian} if {[N I 4 > 0x0]} {emit {\b, version %d\)}} if {[N I 4 <= 0x0]} {emit {\b\)}} } -951729837 {emit GEOS switch -- [Nv c 40] 1 {emit executable} 2 {emit VMFile} 3 {emit binary} 4 {emit {directory label}} if {[N c 40 < 0x1]} {emit unknown} if {[N c 40 > 0x4]} {emit unknown} if {[S 4 x {}]} {emit {\b, name \"%s\"}} } 235082497 {emit {Hierarchical Data Format \(version 4\) data}} 34603270 {emit {PA-RISC1.1 relocatable object}} 34603271 {emit {PA-RISC1.1 executable} if {[N I 168 & 0x4]} {emit {dynamically linked}} if {[N I [I 144 Q 0] == 0x54ef630]} {emit {dynamically linked}} if {[N I 96 > 0x0]} {emit {- not stripped}} } 34603272 {emit {PA-RISC1.1 shared executable} if {[N I 168 == 0x4 &0x4]} {emit {dynamically linked}} if {[N I [I 144 Q 0] == 0x54ef630]} {emit {dynamically linked}} if {[N I 96 > 0x0]} {emit {- not stripped}} } 34603275 {emit {PA-RISC1.1 demand-load executable} if {[N I 168 == 0x4 &0x4]} {emit {dynamically linked}} if {[N I [I 144 Q 0] == 0x54ef630]} {emit {dynamically linked}} if {[N I 96 > 0x0]} {emit {- not stripped}} } 34603278 {emit {PA-RISC1.1 shared library} if {[N I 96 > 0x0]} {emit {- not stripped}} } 34603277 {emit {PA-RISC1.1 dynamic load library} if {[N I 96 > 0x0]} {emit {- not stripped}} } 34865414 {emit {PA-RISC2.0 relocatable object}} 34865415 {emit {PA-RISC2.0 executable} if {[N I 168 & 0x4]} {emit {dynamically linked}} if {[N I [I 144 Q 0] == 0x54ef630]} {emit {dynamically linked}} if {[N I 96 > 0x0]} {emit {- not stripped}} } 34865416 {emit {PA-RISC2.0 shared executable} if {[N I 168 & 0x4]} {emit {dynamically linked}} if {[N I [I 144 Q 0] == 0x54ef630]} {emit {dynamically linked}} if {[N I 96 > 0x0]} {emit {- not stripped}} } 34865419 {emit {PA-RISC2.0 demand-load executable} if {[N I 168 & 0x4]} {emit {dynamically linked}} if {[N I [I 144 Q 0] == 0x54ef630]} {emit {dynamically linked}} if {[N I 96 > 0x0]} {emit {- not stripped}} } 34865422 {emit {PA-RISC2.0 shared library} if {[N I 96 > 0x0]} {emit {- not stripped}} } 34865421 {emit {PA-RISC2.0 dynamic load library} if {[N I 96 > 0x0]} {emit {- not stripped}} } 34275590 {emit {PA-RISC1.0 relocatable object}} 34275591 {emit {PA-RISC1.0 executable} if {[N I 168 == 0x4 &0x4]} {emit {dynamically linked}} if {[N I [I 144 Q 0] == 0x54ef630]} {emit {dynamically linked}} if {[N I 96 > 0x0]} {emit {- not stripped}} } 34275592 {emit {PA-RISC1.0 shared executable} if {[N I 168 == 0x4 &0x4]} {emit {dynamically linked}} if {[N I [I 144 Q 0] == 0x54ef630]} {emit {dynamically linked}} if {[N I 96 > 0x0]} {emit {- not stripped}} } 34275595 {emit {PA-RISC1.0 demand-load executable} if {[N I 168 == 0x4 &0x4]} {emit {dynamically linked}} if {[N I [I 144 Q 0] == 0x54ef630]} {emit {dynamically linked}} if {[N I 96 > 0x0]} {emit {- not stripped}} } 34275598 {emit {PA-RISC1.0 shared library} if {[N I 96 > 0x0]} {emit {- not stripped}} } 34275597 {emit {PA-RISC1.0 dynamic load library} if {[N I 96 > 0x0]} {emit {- not stripped}} } 557605234 {emit {archive file} switch -- [Nv I 68] 34276889 {emit {- PA-RISC1.0 relocatable library}} 34604569 {emit {- PA-RISC1.1 relocatable library}} 34670105 {emit {- PA-RISC1.2 relocatable library}} 34866713 {emit {- PA-RISC2.0 relocatable library}} } 34341128 {emit {HP s200 pure executable} if {[N S 4 > 0x0]} {emit {- version %ld}} if {[N I 8 & 0x80000000]} {emit {save fp regs}} if {[N I 8 & 0x40000000]} {emit {dynamically linked}} if {[N I 8 & 0x20000000]} {emit debuggable} if {[N I 36 > 0x0]} {emit {not stripped}} } 34341127 {emit {HP s200 executable} if {[N S 4 > 0x0]} {emit {- version %ld}} if {[N I 8 & 0x80000000]} {emit {save fp regs}} if {[N I 8 & 0x40000000]} {emit {dynamically linked}} if {[N I 8 & 0x20000000]} {emit debuggable} if {[N I 36 > 0x0]} {emit {not stripped}} } 34341131 {emit {HP s200 demand-load executable} if {[N S 4 > 0x0]} {emit {- version %ld}} if {[N I 8 & 0x80000000]} {emit {save fp regs}} if {[N I 8 & 0x40000000]} {emit {dynamically linked}} if {[N I 8 & 0x20000000]} {emit debuggable} if {[N I 36 > 0x0]} {emit {not stripped}} } 34341126 {emit {HP s200 relocatable executable} if {[N S 4 > 0x0]} {emit {- version %ld}} if {[N S 6 > 0x0]} {emit {- highwater %d}} if {[N I 8 & 0x80000000]} {emit {save fp regs}} if {[N I 8 & 0x20000000]} {emit debuggable} if {[N I 8 & 0x10000000]} {emit PIC} } 34210056 {emit {HP s200 \(2.x release\) pure executable} if {[N S 4 > 0x0]} {emit {- version %ld}} if {[N I 36 > 0x0]} {emit {not stripped}} } 34210055 {emit {HP s200 \(2.x release\) executable} if {[N S 4 > 0x0]} {emit {- version %ld}} if {[N I 36 > 0x0]} {emit {not stripped}} } 34341134 {emit {HP s200 shared library} if {[N S 4 > 0x0]} {emit {- version %ld}} if {[N S 6 > 0x0]} {emit {- highwater %d}} if {[N I 36 > 0x0]} {emit {not stripped}} } 34341133 {emit {HP s200 dynamic load library} if {[N S 4 > 0x0]} {emit {- version %ld}} if {[N S 6 > 0x0]} {emit {- highwater %d}} if {[N I 36 > 0x0]} {emit {not stripped}} } 505 {emit {AIX compiled message catalog}} 1504078485 {emit {Sun raster image data} if {[N I 4 > 0x0]} {emit {\b, %d x}} if {[N I 8 > 0x0]} {emit %d,} if {[N I 12 > 0x0]} {emit %d-bit,} switch -- [Nv I 20] 0 {emit {old format,}} 2 {emit compressed,} 3 {emit RGB,} 4 {emit TIFF,} 5 {emit IFF,} 65535 {emit {reserved for testing,}} switch -- [Nv I 24] 0 {emit {no colormap}} 1 {emit {RGB colormap}} 2 {emit {raw colormap}} } 65544 {emit {GEM Image data} if {[N S 12 x {}]} {emit {%d x}} if {[N S 14 x {}]} {emit %d,} if {[N S 4 x {}]} {emit {%d planes,}} if {[N S 8 x {}]} {emit {%d x}} if {[N S 10 x {}]} {emit {%d pixelsize}} } 235082497 {emit {Hierarchical Data Format \(version 4\) data}} -889275714 {emit {compiled Java class data,} if {[N S 6 x {}]} {emit {version %d.}} if {[N S 4 x {}]} {emit {\b%d}} } -1195374706 {emit {Linux kernel} if {[S 483 == Loading]} {emit {version 1.3.79 or older}} if {[S 489 == Loading]} {emit {from prehistoric times}} } 1330597709 {emit {User-mode Linux COW file} if {[N I 4 x {}]} {emit {\b, version %d}} if {[S 8 x {}]} {emit {\b, backing file %s}} } -1195374706 {emit Linux if {[N I 486 == 0x454c4b53]} {emit {ELKS Kernel}} if {[N I 486 != 0x454c4b53]} {emit {style boot sector}} } -889275714 {emit {Mach-O fat file} if {[N I 4 == 0x1]} {emit {with 1 architecture}} if {[N I 4 > 0x1]} {if {[N I 4 x {}]} {emit {with %ld architectures }} } } -17958194 {emit Mach-O switch -- [Nv I 12] 1 {emit object} 2 {emit executable} 3 {emit {shared library}} 4 {emit core} 5 {emit {preload executable}} 6 {emit {dynamically linked shared library}} 7 {emit {dynamic linker}} 8 {emit bundle} if {[N I 12 > 0x8]} {if {[N I 12 x {}]} {emit filetype=%ld} } if {[N I 4 < 0x0]} {if {[N I 4 x {}]} {emit architecture=%ld} } switch -- [Nv I 4] 1 {emit vax} 2 {emit romp} 3 {emit architecture=3} 4 {emit ns32032} 5 {emit ns32332} 6 {emit {for m68k architecture} switch -- [Nv I 8] 2 {emit {\(mc68040\)}} 3 {emit {\(mc68030 only\)}} } 7 {emit i386} 8 {emit mips} 9 {emit ns32532} 10 {emit architecture=10} 11 {emit {hp pa-risc}} 12 {emit acorn} 13 {emit m88k} 14 {emit sparc} 15 {emit i860-big} 16 {emit i860} 17 {emit rs6000} 18 {emit ppc} if {[N I 4 > 0x12]} {if {[N I 4 x {}]} {emit architecture=%ld} } } -249691108 {emit {magic binary file for file\(1\) cmd} if {[N I 4 x {}]} {emit {\(version %d\) \(big endian\)}} } 440786851 {emit {} if {[N S 5 == 0x4282]} {if {[S 8 == matroska]} {emit {Matroska data}} } } 263 {emit {old SGI 68020 executable}} 264 {emit {old SGI 68020 pure executable}} 1396917837 {emit {IRIS Showcase file} if {[N c 4 x {}]} {emit {- version %ld}} } 1413695053 {emit {IRIS Showcase template} if {[N c 4 x {}]} {emit {- version %ld}} } -559039810 {emit {IRIX Parallel Arena} if {[N I 8 > 0x0]} {emit {- version %ld}} } -559043152 {emit {IRIX core dump} if {[N I 4 == 0x1]} {emit of} if {[S 16 x {}]} {emit '%s'} } -559043264 {emit {IRIX 64-bit core dump} if {[N I 4 == 0x1]} {emit of} if {[S 16 x {}]} {emit '%s'} } -1161903941 {emit {IRIX N32 core dump} if {[N I 4 == 0x1]} {emit of} if {[S 16 x {}]} {emit '%s'} } 834535424 {emit {Microsoft Word Document}} 6656 {emit {Lotus 1-2-3} switch -- [Nv I 4] 1049600 {emit {wk3 document data}} 34604032 {emit {wk4 document data}} 125829376 {emit {fm3 or fmb document data}} 125829120 {emit {fm3 or fmb document data}} } 512 {emit {Lotus 1-2-3} switch -- [Nv I 4] 100926976 {emit {wk1 document data}} 109052416 {emit {fmt document data}} } -976170042 {emit {DOS EPS Binary File} if {[N Q 4 > 0x0]} {emit {Postscript starts at byte %d} if {[N Q 8 > 0x0]} {emit {length %d} if {[N Q 12 > 0x0]} {emit {Metafile starts at byte %d} if {[N Q 16 > 0x0]} {emit {length %d}} } if {[N Q 20 > 0x0]} {emit {TIFF starts at byte %d} if {[N Q 24 > 0x0]} {emit {length %d}} } } } } 263 {emit {a.out NetBSD big-endian object file} if {[N I 16 > 0x0]} {emit {not stripped}} } 326773060 {emit {NeWS bitmap font}} 326773063 {emit {NeWS font family}} 326773072 {emit {scalable OpenFont binary}} 326773073 {emit {encrypted scalable OpenFont binary}} 263 {emit {Plan 9 executable, Motorola 68k}} 491 {emit {Plan 9 executable, Intel 386}} 583 {emit {Plan 9 executable, Intel 960}} 683 {emit {Plan 9 executable, SPARC}} 1031 {emit {Plan 9 executable, MIPS R3000}} 1163 {emit {Plan 9 executable, AT&T DSP 3210}} 1303 {emit {Plan 9 executable, MIPS R4000 BE}} 1451 {emit {Plan 9 executable, AMD 29000}} 1607 {emit {Plan 9 executable, ARM 7-something}} 1771 {emit {Plan 9 executable, PowerPC}} 1943 {emit {Plan 9 executable, MIPS R4000 LE}} 2123 {emit {Plan 9 executable, DEC Alpha}} -976170042 {emit {DOS EPS Binary File} if {[N Q 4 > 0x0]} {emit {Postscript starts at byte %d} if {[N Q 8 > 0x0]} {emit {length %d} if {[N Q 12 > 0x0]} {emit {Metafile starts at byte %d} if {[N Q 16 > 0x0]} {emit {length %d}} } if {[N Q 20 > 0x0]} {emit {TIFF starts at byte %d} if {[N Q 24 > 0x0]} {emit {length %d}} } } } } 518517022 {emit {Pulsar POP3 daemon mailbox cache file.} if {[N I 4 x {}]} {emit {Version: %d.}} if {[N I 8 x {}]} {emit {\b%d}} } -1722938102 {emit {python 1.5/1.6 byte-compiled}} -2017063670 {emit {python 2.0 byte-compiled}} 720047370 {emit {python 2.1 byte-compiled}} 770510090 {emit {python 2.2 byte-compiled}} 1005718794 {emit {python 2.3 byte-compiled}} 1257963521 {emit {QL plugin-ROM data,} if {[S 9 == {\0} p]} {emit un-named} if {[S 9 x {} p]} {emit {named: %s}} } -1582119980 {emit {tcpdump capture file \(big-endian\)} if {[N S 4 x {}]} {emit {- version %d}} if {[N S 6 x {}]} {emit {\b.%d}} switch -- [Nv I 20] 0 {emit {\(No link-layer encapsulation}} 1 {emit {\(Ethernet}} 2 {emit {\(3Mb Ethernet}} 3 {emit {\(AX.25}} 4 {emit {\(ProNET}} 5 {emit {\(CHAOS}} 6 {emit {\(Token Ring}} 7 {emit {\(BSD ARCNET}} 8 {emit {\(SLIP}} 9 {emit {\(PPP}} 10 {emit {\(FDDI}} 11 {emit {\(RFC 1483 ATM}} 12 {emit {\(raw IP}} 13 {emit {\(BSD/OS SLIP}} 14 {emit {\(BSD/OS PPP}} 19 {emit {\(Linux ATM Classical IP}} 50 {emit {\(PPP or Cisco HDLC}} 51 {emit {\(PPP-over-Ethernet}} 99 {emit {\(Symantec Enterprise Firewall}} 100 {emit {\(RFC 1483 ATM}} 101 {emit {\(raw IP}} 102 {emit {\(BSD/OS SLIP}} 103 {emit {\(BSD/OS PPP}} 104 {emit {\(BSD/OS Cisco HDLC}} 105 {emit {\(802.11}} 106 {emit {\(Linux Classical IP over ATM}} 107 {emit {\(Frame Relay}} 108 {emit {\(OpenBSD loopback}} 109 {emit {\(OpenBSD IPsec encrypted}} 112 {emit {\(Cisco HDLC}} 113 {emit {\(Linux \"cooked\"}} 114 {emit {\(LocalTalk}} 117 {emit {\(OpenBSD PFLOG}} 119 {emit {\(802.11 with Prism header}} 122 {emit {\(RFC 2625 IP over Fibre Channel}} 123 {emit {\(SunATM}} 127 {emit {\(802.11 with radiotap header}} 129 {emit {\(Linux ARCNET}} 138 {emit {\(Apple IP over IEEE 1394}} 140 {emit {\(MTP2}} 141 {emit {\(MTP3}} 143 {emit {\(DOCSIS}} 144 {emit {\(IrDA}} 147 {emit {\(Private use 0}} 148 {emit {\(Private use 1}} 149 {emit {\(Private use 2}} 150 {emit {\(Private use 3}} 151 {emit {\(Private use 4}} 152 {emit {\(Private use 5}} 153 {emit {\(Private use 6}} 154 {emit {\(Private use 7}} 155 {emit {\(Private use 8}} 156 {emit {\(Private use 9}} 157 {emit {\(Private use 10}} 158 {emit {\(Private use 11}} 159 {emit {\(Private use 12}} 160 {emit {\(Private use 13}} 161 {emit {\(Private use 14}} 162 {emit {\(Private use 15}} 163 {emit {\(802.11 with AVS header}} if {[N I 16 x {}]} {emit {\b, capture length %d\)}} } -1582117580 {emit {extended tcpdump capture file \(big-endian\)} if {[N S 4 x {}]} {emit {- version %d}} if {[N S 6 x {}]} {emit {\b.%d}} switch -- [Nv I 20] 0 {emit {\(No link-layer encapsulation}} 1 {emit {\(Ethernet}} 2 {emit {\(3Mb Ethernet}} 3 {emit {\(AX.25}} 4 {emit {\(ProNET}} 5 {emit {\(CHAOS}} 6 {emit {\(Token Ring}} 7 {emit {\(ARCNET}} 8 {emit {\(SLIP}} 9 {emit {\(PPP}} 10 {emit {\(FDDI}} 11 {emit {\(RFC 1483 ATM}} 12 {emit {\(raw IP}} 13 {emit {\(BSD/OS SLIP}} 14 {emit {\(BSD/OS PPP}} if {[N I 16 x {}]} {emit {\b, capture length %d\)}} } 263 {emit {old sun-2 executable} if {[N I 16 > 0x0]} {emit {not stripped}} } 264 {emit {old sun-2 pure executable} if {[N I 16 > 0x0]} {emit {not stripped}} } 267 {emit {old sun-2 demand paged executable} if {[N I 16 > 0x0]} {emit {not stripped}} } 525398 {emit {SunOS core file} switch -- [Nv I 4] 432 {emit {\(SPARC\)} if {[S 132 x {}]} {emit {from '%s'}} switch -- [Nv I 116] 3 {emit {\(quit\)}} 4 {emit {\(illegal instruction\)}} 5 {emit {\(trace trap\)}} 6 {emit {\(abort\)}} 7 {emit {\(emulator trap\)}} 8 {emit {\(arithmetic exception\)}} 9 {emit {\(kill\)}} 10 {emit {\(bus error\)}} 11 {emit {\(segmentation violation\)}} 12 {emit {\(bad argument to system call\)}} 29 {emit {\(resource lost\)}} if {[N I 120 x {}]} {emit {\(T=%dK,}} if {[N I 124 x {}]} {emit D=%dK,} if {[N I 128 x {}]} {emit {S=%dK\)}} } 826 {emit {\(68K\)} if {[S 128 x {}]} {emit {from '%s'}} } 456 {emit {\(SPARC 4.x BCP\)} if {[S 152 x {}]} {emit {from '%s'}} } } 50331648 {emit {VMS Alpha executable} if {[S 75264 == {PK\003\004}]} {emit {\b, Info-ZIP SFX archive v5.12 w/decryption}} } 1297241678 {emit {VMware nvram}} 1129273156 {emit VMware switch -- [Nv c 4] 3 {emit {virtual disk} if {[N i 32 x {}]} {emit {\(%d/}} if {[N i 36 x {}]} {emit {\b%d/}} if {[N i 40 x {}]} {emit {\b%d\)}} } 2 {emit {undoable disk} if {[S 32 x {}]} {emit {\(%s\)}} } } if {[S 0 == {Core\001}]} {emit {Alpha COFF format core dump \(Digital UNIX\)} if {[S 24 x {}]} {emit {\b, from '%s'}} } if {[S 0 == {Core\002}]} {emit {Alpha COFF format core dump \(Digital UNIX\)} if {[S 24 x {}]} {emit {\b, from '%s'}} } if {[S 0 == {AMANDA:\ }]} {emit AMANDA if {[S 8 == {TAPESTART\ DATE}]} {emit {tape header file,} if {[S 23 == X]} {if {[S 25 > {\ }]} {emit {Unused %s}} } if {[S 23 > {\ }]} {emit {DATE %s}} } if {[S 8 == {FILE\ }]} {emit {dump file,} if {[S 13 > {\ }]} {emit {DATE %s}} } } if {[S 0 == FC14]} {emit {Future Composer 1.4 Module sound file}} if {[S 0 == SMOD]} {emit {Future Composer 1.3 Module sound file}} if {[S 0 == AON4artofnoise]} {emit {Art Of Noise Module sound file}} if {[S 1 == MUGICIAN/SOFTEYES]} {emit {Mugician Module sound file}} if {[S 58 == {SIDMON\ II\ -\ THE}]} {emit {Sidmon 2.0 Module sound file}} if {[S 0 == Synth4.0]} {emit {Synthesis Module sound file}} if {[S 0 == ARP.]} {emit {The Holy Noise Module sound file}} if {[S 0 == {BeEp\0}]} {emit {JamCracker Module sound file}} if {[S 0 == {COSO\0}]} {emit {Hippel-COSO Module sound file}} if {[S 0 == {\#\#\ version}]} {emit {catalog translation}} if {[S 0 == RDSK]} {emit {Rigid Disk Block} if {[S 160 x {}]} {emit {on %.24s}} } if {[S 0 == {DOS\0}]} {emit {Amiga DOS disk}} if {[S 0 == {DOS\1}]} {emit {Amiga FFS disk}} if {[S 0 == {DOS\2}]} {emit {Amiga Inter DOS disk}} if {[S 0 == {DOS\3}]} {emit {Amiga Inter FFS disk}} if {[S 0 == {DOS\4}]} {emit {Amiga Fastdir DOS disk}} if {[S 0 == {DOS\5}]} {emit {Amiga Fastdir FFS disk}} if {[S 0 == KICK]} {emit {Kickstart disk}} if {[S 0 == MOVI]} {emit {Silicon Graphics movie file}} if {[S 4 == moov]} {emit {Apple QuickTime} if {[S 12 == mvhd]} {emit {\b movie \(fast start\)}} if {[S 12 == mdra]} {emit {\b URL}} if {[S 12 == cmov]} {emit {\b movie \(fast start, compressed header\)}} if {[S 12 == rmra]} {emit {\b multiple URLs}} } if {[S 4 == mdat]} {emit {Apple QuickTime movie \(unoptimized\)}} if {[S 4 == wide]} {emit {Apple QuickTime movie \(unoptimized\)}} if {[S 4 == skip]} {emit {Apple QuickTime movie \(modified\)}} if {[S 4 == free]} {emit {Apple QuickTime movie \(modified\)}} if {[S 4 == idsc]} {emit {Apple QuickTime image \(fast start\)}} if {[S 4 == idat]} {emit {Apple QuickTime image \(unoptimized\)}} if {[S 4 == pckg]} {emit {Apple QuickTime compressed archive}} if {[S 4 == jP B]} {emit {JPEG 2000 image}} if {[S 4 == ftyp]} {emit {ISO Media} if {[S 8 == isom]} {emit {\b, MPEG v4 system, version 1}} if {[S 8 == iso2]} {emit {\b, MPEG v4 system, part 12 revision}} if {[S 8 == mp41]} {emit {\b, MPEG v4 system, version 1}} if {[S 8 == mp42]} {emit {\b, MPEG v4 system, version 2}} if {[S 8 == mp7t]} {emit {\b, MPEG v4 system, MPEG v7 XML}} if {[S 8 == mp7b]} {emit {\b, MPEG v4 system, MPEG v7 binary XML}} if {[S 8 == jp2 B]} {emit {\b, JPEG 2000}} if {[S 8 == 3gp]} {emit {\b, MPEG v4 system, 3GPP} switch -- [Nv c 11] 4 {emit {\b v4 \(H.263/AMR GSM 6.10\)}} 5 {emit {\b v5 \(H.263/AMR GSM 6.10\)}} 6 {emit {\b v6 \(ITU H.264/AMR GSM 6.10\)}} } if {[S 8 == mmp4]} {emit {\b, MPEG v4 system, 3GPP Mobile}} if {[S 8 == avc1]} {emit {\b, MPEG v4 system, 3GPP JVT AVC}} if {[S 8 == M4A B]} {emit {\b, MPEG v4 system, iTunes AAC-LC}} if {[S 8 == M4P B]} {emit {\b, MPEG v4 system, iTunes AES encrypted}} if {[S 8 == M4B B]} {emit {\b, MPEG v4 system, iTunes bookmarked}} if {[S 8 == qt B]} {emit {\b, Apple QuickTime movie}} } if {[N I 0 == 0x100 &0xFFFFFF00]} {emit {MPEG sequence} switch -- [Nv c 3] -70 {emit {} if {[N c 4 & 0x40]} {emit {\b, v2, program multiplex}} if {[N c 4 ^ 0x40]} {emit {\b, v1, system multiplex}} } -69 {emit {\b, v1/2, multiplex \(missing pack header\)}} -80 {emit {\b, v4} if {[N I 5 == 0x1b5]} {if {[N c 9 & 0x80]} {switch -- [Nv c 10 &0xF0] 16 {emit {\b, video}} 32 {emit {\b, still texture}} 48 {emit {\b, mesh}} 64 {emit {\b, face}} } switch -- [Nv c 9 &0xF8] 8 {emit {\b, video}} 16 {emit {\b, still texture}} 24 {emit {\b, mesh}} 32 {emit {\b, face}} } switch -- [Nv c 4] 1 {emit {\b, simple @ L1}} 2 {emit {\b, simple @ L2}} 3 {emit {\b, simple @ L3}} 4 {emit {\b, simple @ L0}} 17 {emit {\b, simple scalable @ L1}} 18 {emit {\b, simple scalable @ L2}} 33 {emit {\b, core @ L1}} 34 {emit {\b, core @ L2}} 50 {emit {\b, main @ L2}} 51 {emit {\b, main @ L3}} 53 {emit {\b, main @ L4}} 66 {emit {\b, n-bit @ L2}} 81 {emit {\b, scalable texture @ L1}} 97 {emit {\b, simple face animation @ L1}} 98 {emit {\b, simple face animation @ L2}} 99 {emit {\b, simple face basic animation @ L1}} 100 {emit {\b, simple face basic animation @ L2}} 113 {emit {\b, basic animation text @ L1}} 114 {emit {\b, basic animation text @ L2}} -127 {emit {\b, hybrid @ L1}} -126 {emit {\b, hybrid @ L2}} -111 {emit {\b, advanced RT simple @ L!}} -110 {emit {\b, advanced RT simple @ L2}} -109 {emit {\b, advanced RT simple @ L3}} -108 {emit {\b, advanced RT simple @ L4}} -95 {emit {\b, core scalable @ L1}} -94 {emit {\b, core scalable @ L2}} -93 {emit {\b, core scalable @ L3}} -79 {emit {\b, advanced coding efficiency @ L1}} -78 {emit {\b, advanced coding efficiency @ L2}} -77 {emit {\b, advanced coding efficiency @ L3}} -76 {emit {\b, advanced coding efficiency @ L4}} -63 {emit {\b, advanced core @ L1}} -62 {emit {\b, advanced core @ L2}} -47 {emit {\b, advanced scalable texture @ L1}} -46 {emit {\b, advanced scalable texture @ L2}} -45 {emit {\b, advanced scalable texture @ L3}} -31 {emit {\b, simple studio @ L1}} -30 {emit {\b, simple studio @ L2}} -29 {emit {\b, simple studio @ L3}} -28 {emit {\b, simple studio @ L4}} -27 {emit {\b, core studio @ L1}} -26 {emit {\b, core studio @ L2}} -25 {emit {\b, core studio @ L3}} -24 {emit {\b, core studio @ L4}} -16 {emit {\b, advanced simple @ L0}} -15 {emit {\b, advanced simple @ L1}} -14 {emit {\b, advanced simple @ L2}} -13 {emit {\b, advanced simple @ L3}} -12 {emit {\b, advanced simple @ L4}} -11 {emit {\b, advanced simple @ L5}} -9 {emit {\b, advanced simple @ L3b}} -8 {emit {\b, FGS @ L0}} -7 {emit {\b, FGS @ L1}} -6 {emit {\b, FGS @ L2}} -5 {emit {\b, FGS @ L3}} -4 {emit {\b, FGS @ L4}} -3 {emit {\b, FGS @ L5}} } -75 {emit {\b, v4} if {[N c 4 & 0x80]} {switch -- [Nv c 5 &0xF0] 16 {emit {\b, video \(missing profile header\)}} 32 {emit {\b, still texture \(missing profile header\)}} 48 {emit {\b, mesh \(missing profile header\)}} 64 {emit {\b, face \(missing profile header\)}} } switch -- [Nv c 4 &0xF8] 8 {emit {\b, video \(missing profile header\)}} 16 {emit {\b, still texture \(missing profile header\)}} 24 {emit {\b, mesh \(missing profile header\)}} 32 {emit {\b, face \(missing profile header\)}} } -77 {emit {} switch -- [Nv I 12] 440 {emit {\b, v1, progressive Y'CbCr 4:2:0 video}} 434 {emit {\b, v1, progressive Y'CbCr 4:2:0 video}} 437 {emit {\b, v2,} switch -- [Nv c 16 &0x0F] 1 {emit {\b HP}} 2 {emit {\b Spt}} 3 {emit {\b SNR}} 4 {emit {\b MP}} 5 {emit {\b SP}} switch -- [Nv c 17 &0xF0] 64 {emit {\b@HL}} 96 {emit {\b@H-14}} -128 {emit {\b@ML}} -96 {emit {\b@LL}} if {[N c 17 & 0x8]} {emit {\b progressive}} if {[N c 17 ^ 0x8]} {emit {\b interlaced}} switch -- [Nv c 17 &0x06] 2 {emit {\b Y'CbCr 4:2:0 video}} 4 {emit {\b Y'CbCr 4:2:2 video}} 6 {emit {\b Y'CbCr 4:4:4 video}} } if {[N c 11 & 0x2]} {if {[N c 75 & 0x1]} {switch -- [Nv I 140] 440 {emit {\b, v1, progressive Y'CbCr 4:2:0 video}} 434 {emit {\b, v1, progressive Y'CbCr 4:2:0 video}} 437 {emit {\b, v2,} switch -- [Nv c 144 &0x0F] 1 {emit {\b HP}} 2 {emit {\b Spt}} 3 {emit {\b SNR}} 4 {emit {\b MP}} 5 {emit {\b SP}} switch -- [Nv c 145 &0xF0] 64 {emit {\b@HL}} 96 {emit {\b@H-14}} -128 {emit {\b@ML}} -96 {emit {\b@LL}} if {[N c 145 & 0x8]} {emit {\b progressive}} if {[N c 145 ^ 0x8]} {emit {\b interlaced}} switch -- [Nv c 145 &0x06] 2 {emit {\b Y'CbCr 4:2:0 video}} 4 {emit {\b Y'CbCr 4:2:2 video}} 6 {emit {\b Y'CbCr 4:4:4 video}} } } } switch -- [Nv I 76] 440 {emit {\b, v1, progressive Y'CbCr 4:2:0 video}} 434 {emit {\b, v1, progressive Y'CbCr 4:2:0 video}} 437 {emit {\b, v2,} switch -- [Nv c 80 &0x0F] 1 {emit {\b HP}} 2 {emit {\b Spt}} 3 {emit {\b SNR}} 4 {emit {\b MP}} 5 {emit {\b SP}} switch -- [Nv c 81 &0xF0] 64 {emit {\b@HL}} 96 {emit {\b@H-14}} -128 {emit {\b@ML}} -96 {emit {\b@LL}} if {[N c 81 & 0x8]} {emit {\b progressive}} if {[N c 81 ^ 0x8]} {emit {\b interlaced}} switch -- [Nv c 81 &0x06] 2 {emit {\b Y'CbCr 4:2:0 video}} 4 {emit {\b Y'CbCr 4:2:2 video}} 6 {emit {\b Y'CbCr 4:4:4 video}} } switch -- [Nv I 4 &0xFFFFFF00] 2013542400 {emit {\b, HD-TV 1920P} if {[N c 7 == 0x10 &0xF0]} {emit {\b, 16:9}} } 1342188800 {emit {\b, SD-TV 1280I} if {[N c 7 == 0x10 &0xF0]} {emit {\b, 16:9}} } 805453824 {emit {\b, PAL Capture} if {[N c 7 == 0x10 &0xF0]} {emit {\b, 4:3}} } 671211520 {emit {\b, LD-TV 640P} if {[N c 7 == 0x10 &0xF0]} {emit {\b, 4:3}} } 335605760 {emit {\b, 320x240} if {[N c 7 == 0x10 &0xF0]} {emit {\b, 4:3}} } 251699200 {emit {\b, 240x160} if {[N c 7 == 0x10 &0xF0]} {emit {\b, 4:3}} } 167802880 {emit {\b, 160x120} if {[N c 7 == 0x10 &0xF0]} {emit {\b, 4:3}} } switch -- [Nv S 4 &0xFFF0] 11264 {emit {\b, 4CIF} switch -- [Nv S 5 &0x0FFF] 480 {emit {\b NTSC}} 576 {emit {\b PAL}} switch -- [Nv c 7 &0xF0] 32 {emit {\b, 4:3}} 48 {emit {\b, 16:9}} 64 {emit {\b, 11:5}} -128 {emit {\b, PAL 4:3}} -64 {emit {\b, NTSC 4:3}} } 5632 {emit {\b, CIF} switch -- [Nv S 5 &0x0FFF] 240 {emit {\b NTSC}} 288 {emit {\b PAL}} 576 {emit {\b PAL 625} switch -- [Nv c 7 &0xF0] 32 {emit {\b, 4:3}} 48 {emit {\b, 16:9}} 64 {emit {\b, 11:5}} } switch -- [Nv c 7 &0xF0] 32 {emit {\b, 4:3}} 48 {emit {\b, 16:9}} 64 {emit {\b, 11:5}} -128 {emit {\b, PAL 4:3}} -64 {emit {\b, NTSC 4:3}} } 11520 {emit {\b, CCIR/ITU} switch -- [Nv S 5 &0x0FFF] 480 {emit {\b NTSC 525}} 576 {emit {\b PAL 625}} switch -- [Nv c 7 &0xF0] 32 {emit {\b, 4:3}} 48 {emit {\b, 16:9}} 64 {emit {\b, 11:5}} } 7680 {emit {\b, SVCD} switch -- [Nv S 5 &0x0FFF] 480 {emit {\b NTSC 525}} 576 {emit {\b PAL 625}} switch -- [Nv c 7 &0xF0] 32 {emit {\b, 4:3}} 48 {emit {\b, 16:9}} 64 {emit {\b, 11:5}} } switch -- [Nv c 7 &0x0F] 1 {emit {\b, 23.976 fps}} 2 {emit {\b, 24 fps}} 3 {emit {\b, 25 fps}} 4 {emit {\b, 29.97 fps}} 5 {emit {\b, 30 fps}} 6 {emit {\b, 50 fps}} 7 {emit {\b, 59.94 fps}} 8 {emit {\b, 60 fps}} if {[N c 11 & 0x4]} {emit {\b, Constrained}} } if {[N c 3 == 0x7 &0x1F]} {emit {\b, H.264 video} switch -- [Nv c 4] 66 {emit {\b, baseline}} 77 {emit {\b, main}} 88 {emit {\b, extended}} if {[N c 6 x {}]} {emit {\b @ L %u}} } } switch -- [Nv S 0 &0xFFFE] -6 {emit {MPEG ADTS, layer III, v1} switch -- [Nv c 2 &0xF0] 16 {emit {\b, 32 kBits}} 32 {emit {\b, 40 kBits}} 48 {emit {\b, 48 kBits}} 64 {emit {\b, 56 kBits}} 80 {emit {\b, 64 kBits}} 96 {emit {\b, 80 kBits}} 112 {emit {\b, 96 kBits}} -128 {emit {\b, 112 kBits}} -112 {emit {\b, 128 kBits}} -96 {emit {\b, 160 kBits}} -80 {emit {\b, 192 kBits}} -64 {emit {\b, 224 kBits}} -48 {emit {\b, 256 kBits}} -32 {emit {\b, 320 kBits}} switch -- [Nv c 2 &0x0C] 0 {emit {\b, 44.1 kHz}} 4 {emit {\b, 48 kHz}} 8 {emit {\b, 32 kHz}} switch -- [Nv c 3 &0xC0] 0 {emit {\b, Stereo}} 64 {emit {\b, JntStereo}} -128 {emit {\b, 2x Monaural}} -64 {emit {\b, Monaural}} } -4 {emit {MPEG ADTS, layer II, v1} switch -- [Nv c 2 &0xF0] 16 {emit {\b, 32 kBits}} 32 {emit {\b, 48 kBits}} 48 {emit {\b, 56 kBits}} 64 {emit {\b, 64 kBits}} 80 {emit {\b, 80 kBits}} 96 {emit {\b, 96 kBits}} 112 {emit {\b, 112 kBits}} -128 {emit {\b, 128 kBits}} -112 {emit {\b, 160 kBits}} -96 {emit {\b, 192 kBits}} -80 {emit {\b, 224 kBits}} -64 {emit {\b, 256 kBits}} -48 {emit {\b, 320 kBits}} -32 {emit {\b, 384 kBits}} switch -- [Nv c 2 &0x0C] 0 {emit {\b, 44.1 kHz}} 4 {emit {\b, 48 kHz}} 8 {emit {\b, 32 kHz}} switch -- [Nv c 3 &0xC0] 0 {emit {\b, Stereo}} 64 {emit {\b, JntStereo}} -128 {emit {\b, 2x Monaural}} -64 {emit {\b, Monaural}} } -2 {emit {MPEG ADTS, layer I, v1} switch -- [Nv c 2 &0xF0] 16 {emit {\b, 32 kBits}} 32 {emit {\b, 64 kBits}} 48 {emit {\b, 96 kBits}} 64 {emit {\b, 128 kBits}} 80 {emit {\b, 160 kBits}} 96 {emit {\b, 192 kBits}} 112 {emit {\b, 224 kBits}} -128 {emit {\b, 256 kBits}} -112 {emit {\b, 288 kBits}} -96 {emit {\b, 320 kBits}} -80 {emit {\b, 352 kBits}} -64 {emit {\b, 384 kBits}} -48 {emit {\b, 416 kBits}} -32 {emit {\b, 448 kBits}} switch -- [Nv c 2 &0x0C] 0 {emit {\b, 44.1 kHz}} 4 {emit {\b, 48 kHz}} 8 {emit {\b, 32 kHz}} switch -- [Nv c 3 &0xC0] 0 {emit {\b, Stereo}} 64 {emit {\b, JntStereo}} -128 {emit {\b, 2x Monaural}} -64 {emit {\b, Monaural}} } -14 {emit {MPEG ADTS, layer III, v2} switch -- [Nv c 2 &0xF0] 16 {emit {\b, 8 kBits}} 32 {emit {\b, 16 kBits}} 48 {emit {\b, 24 kBits}} 64 {emit {\b, 32 kBits}} 80 {emit {\b, 40 kBits}} 96 {emit {\b, 48 kBits}} 112 {emit {\b, 56 kBits}} -128 {emit {\b, 64 kBits}} -112 {emit {\b, 80 kBits}} -96 {emit {\b, 96 kBits}} -80 {emit {\b, 112 kBits}} -64 {emit {\b, 128 kBits}} -48 {emit {\b, 144 kBits}} -32 {emit {\b, 160 kBits}} switch -- [Nv c 2 &0x0C] 0 {emit {\b, 22.05 kHz}} 4 {emit {\b, 24 kHz}} 8 {emit {\b, 16 kHz}} switch -- [Nv c 3 &0xC0] 0 {emit {\b, Stereo}} 64 {emit {\b, JntStereo}} -128 {emit {\b, 2x Monaural}} -64 {emit {\b, Monaural}} } -12 {emit {MPEG ADTS, layer II, v2} switch -- [Nv c 2 &0xF0] 16 {emit {\b, 8 kBits}} 32 {emit {\b, 16 kBits}} 48 {emit {\b, 24 kBits}} 64 {emit {\b, 32 kBits}} 80 {emit {\b, 40 kBits}} 96 {emit {\b, 48 kBits}} 112 {emit {\b, 56 kBits}} -128 {emit {\b, 64 kBits}} -112 {emit {\b, 80 kBits}} -96 {emit {\b, 96 kBits}} -80 {emit {\b, 112 kBits}} -64 {emit {\b, 128 kBits}} -48 {emit {\b, 144 kBits}} -32 {emit {\b, 160 kBits}} switch -- [Nv c 2 &0x0C] 0 {emit {\b, 22.05 kHz}} 4 {emit {\b, 24 kHz}} 8 {emit {\b, 16 kHz}} switch -- [Nv c 3 &0xC0] 0 {emit {\b, Stereo}} 64 {emit {\b, JntStereo}} -128 {emit {\b, 2x Monaural}} -64 {emit {\b, Monaural}} } -10 {emit {MPEG ADTS, layer I, v2} switch -- [Nv c 2 &0xF0] 16 {emit {\b, 32 kBits}} 32 {emit {\b, 48 kBits}} 48 {emit {\b, 56 kBits}} 64 {emit {\b, 64 kBits}} 80 {emit {\b, 80 kBits}} 96 {emit {\b, 96 kBits}} 112 {emit {\b, 112 kBits}} -128 {emit {\b, 128 kBits}} -112 {emit {\b, 144 kBits}} -96 {emit {\b, 160 kBits}} -80 {emit {\b, 176 kBits}} -64 {emit {\b, 192 kBits}} -48 {emit {\b, 224 kBits}} -32 {emit {\b, 256 kBits}} switch -- [Nv c 2 &0x0C] 0 {emit {\b, 22.05 kHz}} 4 {emit {\b, 24 kHz}} 8 {emit {\b, 16 kHz}} switch -- [Nv c 3 &0xC0] 0 {emit {\b, Stereo}} 64 {emit {\b, JntStereo}} -128 {emit {\b, 2x Monaural}} -64 {emit {\b, Monaural}} } -30 {emit {MPEG ADTS, layer III, v2.5} switch -- [Nv c 2 &0xF0] 16 {emit {\b, 8 kBits}} 32 {emit {\b, 16 kBits}} 48 {emit {\b, 24 kBits}} 64 {emit {\b, 32 kBits}} 80 {emit {\b, 40 kBits}} 96 {emit {\b, 48 kBits}} 112 {emit {\b, 56 kBits}} -128 {emit {\b, 64 kBits}} -112 {emit {\b, 80 kBits}} -96 {emit {\b, 96 kBits}} -80 {emit {\b, 112 kBits}} -64 {emit {\b, 128 kBits}} -48 {emit {\b, 144 kBits}} -32 {emit {\b, 160 kBits}} switch -- [Nv c 2 &0x0C] 0 {emit {\b, 11.025 kHz}} 4 {emit {\b, 12 kHz}} 8 {emit {\b, 8 kHz}} switch -- [Nv c 3 &0xC0] 0 {emit {\b, Stereo}} 64 {emit {\b, JntStereo}} -128 {emit {\b, 2x Monaural}} -64 {emit {\b, Monaural}} } if {[S 0 == ADIF]} {emit {MPEG ADIF, AAC} if {[N c 4 & 0x80]} {if {[N c 13 & 0x10]} {emit {\b, VBR}} if {[N c 13 ^ 0x10]} {emit {\b, CBR}} switch -- [Nv c 16 &0x1E] 2 {emit {\b, single stream}} 4 {emit {\b, 2 streams}} 6 {emit {\b, 3 streams}} if {[N c 16 & 0x8]} {emit {\b, 4 or more streams}} if {[N c 16 & 0x10]} {emit {\b, 8 or more streams}} if {[N c 4 & 0x80]} {emit {\b, Copyrighted}} if {[N c 13 & 0x40]} {emit {\b, Original Source}} if {[N c 13 & 0x20]} {emit {\b, Home Flag}} } if {[N c 4 ^ 0x80]} {if {[N c 4 & 0x10]} {emit {\b, VBR}} if {[N c 4 ^ 0x10]} {emit {\b, CBR}} switch -- [Nv c 7 &0x1E] 2 {emit {\b, single stream}} 4 {emit {\b, 2 streams}} 6 {emit {\b, 3 streams}} if {[N c 7 & 0x8]} {emit {\b, 4 or more streams}} if {[N c 7 & 0x10]} {emit {\b, 8 or more streams}} if {[N c 4 & 0x40]} {emit {\b, Original Stream\(s\)}} if {[N c 4 & 0x20]} {emit {\b, Home Source}} } } if {[N S 0 == 0xfff0 &0xFFF6]} {emit {MPEG ADTS, AAC} if {[N c 1 & 0x8]} {emit {\b, v2}} if {[N c 1 ^ 0x8]} {emit {\b, v4} if {[N c 2 & 0xc0]} {emit {\b LTP}} } switch -- [Nv c 2 &0xc0] 0 {emit {\b Main}} 64 {emit {\b LC}} -128 {emit {\b SSR}} switch -- [Nv c 2 &0x3c] 0 {emit {\b, 96 kHz}} 4 {emit {\b, 88.2 kHz}} 8 {emit {\b, 64 kHz}} 12 {emit {\b, 48 kHz}} 16 {emit {\b, 44.1 kHz}} 20 {emit {\b, 32 kHz}} 24 {emit {\b, 24 kHz}} 28 {emit {\b, 22.05 kHz}} 32 {emit {\b, 16 kHz}} 36 {emit {\b, 12 kHz}} 40 {emit {\b, 11.025 kHz}} 44 {emit {\b, 8 kHz}} switch -- [Nv S 2 &0x01c0] 64 {emit {\b, monaural}} 128 {emit {\b, stereo}} 192 {emit {\b, stereo + center}} 256 {emit {\b, stereo+center+LFE}} 320 {emit {\b, surround}} 384 {emit {\b, surround + LFE}} if {[N S 2 & 0x1c0]} {emit {\b, surround + side}} } if {[N S 0 == 0x56e0 &0xFFE0]} {emit {MPEG-4 LOAS} if {[N c 3 == 0x40 &0xE0]} {switch -- [Nv c 4 &0x3C] 4 {emit {\b, single stream}} 8 {emit {\b, 2 streams}} 12 {emit {\b, 3 streams}} if {[N c 4 & 0x8]} {emit {\b, 4 or more streams}} if {[N c 4 & 0x20]} {emit {\b, 8 or more streams}} } if {[N c 3 == 0x0 &0xC0]} {switch -- [Nv c 4 &0x78] 8 {emit {\b, single stream}} 16 {emit {\b, 2 streams}} 24 {emit {\b, 3 streams}} if {[N c 4 & 0x20]} {emit {\b, 4 or more streams}} if {[N c 4 & 0x40]} {emit {\b, 8 or more streams}} } } switch -- [Nv s 4] -20719 {emit {FLI file} if {[N s 6 x {}]} {emit {- %d frames,}} if {[N s 8 x {}]} {emit {width=%d pixels,}} if {[N s 10 x {}]} {emit {height=%d pixels,}} if {[N s 12 x {}]} {emit depth=%d,} if {[N s 16 x {}]} {emit ticks/frame=%d} } -20718 {emit {FLC file} if {[N s 6 x {}]} {emit {- %d frames}} if {[N s 8 x {}]} {emit {width=%d pixels,}} if {[N s 10 x {}]} {emit {height=%d pixels,}} if {[N s 12 x {}]} {emit depth=%d,} if {[N s 16 x {}]} {emit ticks/frame=%d} } if {[N I 0 == 0x47400010 &0xFF5FFF1F]} {emit {MPEG transport stream data} if {[N c 188 != 0x47]} {emit CORRUPTED} } switch -- [Nv I 0 &0xffffff00] 520552448 {emit DIF if {[N c 4 & 0x1]} {emit {\(DVCPRO\) movie file}} if {[N c 4 ^ 0x1]} {emit {\(DV\) movie file}} if {[N c 3 & 0x80]} {emit {\(PAL\)}} if {[N c 3 ^ 0x80]} {emit {\(NTSC\)}} } -2063526912 {emit {cisco IOS microcode} if {[S 7 x {}]} {emit {for '%s'}} } -2063480064 {emit {cisco IOS experimental microcode} if {[S 7 x {}]} {emit {for '%s'}} } -16907520 {emit {MySQL MISAM index file} if {[N c 3 x {}]} {emit {Version %d}} } -16906496 {emit {MySQL MISAM compressed data file} if {[N c 3 x {}]} {emit {Version %d}} } -16907008 {emit {MySQL ISAM index file} if {[N c 3 x {}]} {emit {Version %d}} } -16906752 {emit {MySQL ISAM compressed data file} if {[N c 3 x {}]} {emit {Version %d}} } if {[S 0 == {\x8aMNG}]} {emit {MNG video data,} if {[N I 4 != 0xd0a1a0a]} {emit CORRUPTED,} if {[N I 4 == 0xd0a1a0a]} {if {[N I 16 x {}]} {emit {%ld x}} if {[N I 20 x {}]} {emit %ld} } } if {[S 0 == {\x8bJNG}]} {emit {JNG video data,} if {[N I 4 != 0xd0a1a0a]} {emit CORRUPTED,} if {[N I 4 == 0xd0a1a0a]} {if {[N I 16 x {}]} {emit {%ld x}} if {[N I 20 x {}]} {emit %ld} } } if {[S 3 == {\x0D\x0AVersion:Vivo}]} {emit {Vivo video data}} if {[S 0 == {\#VRML\ V1.0\ ascii} b]} {emit {VRML 1 file}} if {[S 0 == {\#VRML\ V2.0\ utf8} b]} {emit {ISO/IEC 14772 VRML 97 file}} if {[S 0 == HVQM4]} {emit %s if {[S 6 x {}]} {emit v%s} if {[N c 0 x {}]} {emit {GameCube movie,}} if {[N S 52 x {}]} {emit {%d x}} if {[N S 54 x {}]} {emit %d,} if {[N S 38 x {}]} {emit %dµs,} if {[N S 66 == 0x0]} {emit {no audio}} if {[N S 66 > 0x0]} {emit {%dHz audio}} } if {[S 0 == DVDVIDEO-VTS]} {emit {Video title set,} if {[N c 33 x {}]} {emit v%x} } if {[S 0 == DVDVIDEO-VMG]} {emit {Video manager,} if {[N c 33 x {}]} {emit v%x} } switch -- [Nv Q 0] 33132 {emit {APL workspace \(Ken's original?\)}} 65389 {emit {very old archive}} 65381 {emit {old archive}} 33132 {emit {apl workspace}} 557605234 {emit {archive file}} 262 {emit {68k Blit mpx/mux executable}} 269 {emit {i960 b.out relocatable object} if {[N Q 16 > 0x0]} {emit {not stripped}} } 1145263299 {emit {DACT compressed data} if {[N c 4 > 0xffffffff]} {emit {\(version %i.}} if {[N c 5 > 0xffffffff]} {emit {$BS%i.}} if {[N c 6 > 0xffffffff]} {emit {$BS%i\)}} if {[N Q 7 > 0x0]} {emit {$BS, original size: %i bytes}} if {[N Q 15 > 0x1e]} {emit {$BS, block size: %i bytes}} } 398689 {emit {Berkeley DB} switch -- [Nv I 8] 4321 {emit {} if {[N I 4 > 0x2]} {emit 1.86} if {[N I 4 < 0x3]} {emit 1.85} if {[N I 4 > 0x0]} {emit {\(Hash, version %d, native byte-order\)}} } 1234 {emit {} if {[N I 4 > 0x2]} {emit 1.86} if {[N I 4 < 0x3]} {emit 1.85} if {[N I 4 > 0x0]} {emit {\(Hash, version %d, little-endian\)}} } } 340322 {emit {Berkeley DB 1.85/1.86} if {[N Q 4 > 0x0]} {emit {\(Btree, version %d, native byte-order\)}} } 1234567 {emit {X image}} 168757262 {emit {TML 0123 byte-order format}} 252317192 {emit {TML 1032 byte-order format}} 135137807 {emit {TML 2301 byte-order format}} 235409162 {emit {TML 3210 byte-order format}} 34078982 {emit {HP s500 relocatable executable} if {[N Q 16 > 0x0]} {emit {- version %ld}} } 34078983 {emit {HP s500 executable} if {[N Q 16 > 0x0]} {emit {- version %ld}} } 34078984 {emit {HP s500 pure executable} if {[N Q 16 > 0x0]} {emit {- version %ld}} } 65381 {emit {HP old archive}} 34275173 {emit {HP s200 old archive}} 34406245 {emit {HP s200 old archive}} 34144101 {emit {HP s500 old archive}} 22552998 {emit {HP core file}} 1302851304 {emit {HP-WINDOWS font} if {[N c 8 > 0x0]} {emit {- version %ld}} } 34341132 {emit {compiled Lisp}} 1123028772 {emit {Artisan image data} switch -- [Nv Q 4] 1 {emit {\b, rectangular 24-bit}} 2 {emit {\b, rectangular 8-bit with colormap}} 3 {emit {\b, rectangular 32-bit \(24-bit with matte\)}} } 1886817234 {emit {CLISP memory image data}} -762612112 {emit {CLISP memory image data, other endian}} -569244523 {emit {GNU-format message catalog data}} -1794895138 {emit {GNU-format message catalog data}} -1042103351 {emit {SPSS Portable File} if {[S 40 x {}]} {emit %s} } 31415 {emit {Mirage Assembler m.out executable}} 61374 {emit {OSF/Rose object}} 1351614727 {emit {Pyramid 90x family executable}} 1351614728 {emit {Pyramid 90x family pure executable} if {[N Q 16 > 0x0]} {emit {not stripped}} } 1351614731 {emit {Pyramid 90x family demand paged pure executable} if {[N Q 16 > 0x0]} {emit {not stripped}} } -97271666 {emit {SunPC 4.0 Hard Disk}} 268 {emit {unknown demand paged pure executable} if {[N Q 16 > 0x0]} {emit {not stripped}} } 270 {emit {unknown readable demand paged pure executable}} 395726 {emit {Jaleo XFS file} if {[N Q 4 x {}]} {emit {- version %ld}} if {[N Q 8 x {}]} {emit {- [%ld -}} if {[N Q 20 x {}]} {emit %ldx} if {[N Q 24 x {}]} {emit %ldx} switch -- [Nv Q 28] 1008 {emit YUV422\]} 1000 {emit RGB24\]} } 59399 {emit {object file \(z8000 a.out\)}} 59400 {emit {pure object file \(z8000 a.out\)}} 59401 {emit {separate object file \(z8000 a.out\)}} 59397 {emit {overlay object file \(z8000 a.out\)}} if {[S 0 == FiLeStArTfIlEsTaRt]} {emit {binscii \(apple ][\) text}} if {[S 0 == {\x0aGL}]} {emit {Binary II \(apple ][\) data}} if {[S 0 == {\x76\xff}]} {emit {Squeezed \(apple ][\) data}} if {[S 0 == NuFile]} {emit {NuFile archive \(apple ][\) data}} if {[S 0 == {N\xf5F\xe9l\xe5}]} {emit {NuFile archive \(apple ][\) data}} if {[S 0 == package0]} {emit {Newton package, NOS 1.x,} if {[N I 12 & 0x80000000]} {emit AutoRemove,} if {[N I 12 & 0x40000000]} {emit CopyProtect,} if {[N I 12 & 0x10000000]} {emit NoCompression,} if {[N I 12 & 0x4000000]} {emit Relocation,} if {[N I 12 & 0x2000000]} {emit UseFasterCompression,} if {[N I 16 x {}]} {emit {version %d}} } if {[S 0 == package1]} {emit {Newton package, NOS 2.x,} if {[N I 12 & 0x80000000]} {emit AutoRemove,} if {[N I 12 & 0x40000000]} {emit CopyProtect,} if {[N I 12 & 0x10000000]} {emit NoCompression,} if {[N I 12 & 0x4000000]} {emit Relocation,} if {[N I 12 & 0x2000000]} {emit UseFasterCompression,} if {[N I 16 x {}]} {emit {version %d}} } if {[S 0 == package4]} {emit {Newton package,} switch -- [Nv c 8] 8 {emit {NOS 1.x,}} 9 {emit {NOS 2.x,}} if {[N I 12 & 0x80000000]} {emit AutoRemove,} if {[N I 12 & 0x40000000]} {emit CopyProtect,} if {[N I 12 & 0x10000000]} {emit NoCompression,} } if {[S 4 == O====]} {emit {AppleWorks word processor data} if {[N c 85 > 0x0 &0x01]} {emit {\b, zoomed}} if {[N c 90 > 0x0 &0x01]} {emit {\b, paginated}} if {[N c 92 > 0x0 &0x01]} {emit {\b, with mail merge}} } if {[N I 0 == 0x80000 &0xff00ff]} {emit {Applesoft BASIC program data}} if {[S 8144 == {\x7F\x7F\x7F\x7F\x7F\x7F\x7F\x7F}]} {emit {Apple II image with white background}} if {[S 8144 == {\x55\x2A\x55\x2A\x55\x2A\x55\x2A}]} {emit {Apple II image with purple background}} if {[S 8144 == {\x2A\x55\x2A\x55\x2A\x55\x2A\x55}]} {emit {Apple II image with green background}} if {[S 8144 == {\xD5\xAA\xD5\xAA\xD5\xAA\xD5\xAA}]} {emit {Apple II image with blue background}} if {[S 8144 == {\xAA\xD5\xAA\xD5\xAA\xD5\xAA\xD5}]} {emit {Apple II image with orange background}} if {[N I 0 == 0x6400d000 &0xFF00FFFF]} {emit {Apple Mechanic font}} if {[S 0 == *BEGIN]} {emit Applixware if {[S 7 == WORDS]} {emit {Words Document}} if {[S 7 == GRAPHICS]} {emit Graphic} if {[S 7 == RASTER]} {emit Bitmap} if {[S 7 == SPREADSHEETS]} {emit Spreadsheet} if {[S 7 == MACRO]} {emit Macro} if {[S 7 == BUILDER]} {emit {Builder Object}} } if {[S 257 == {ustar\0}]} {emit {POSIX tar archive}} if {[S 257 == {ustar\040\040\0}]} {emit {GNU tar archive}} if {[S 0 == 070707]} {emit {ASCII cpio archive \(pre-SVR4 or odc\)}} if {[S 0 == 070701]} {emit {ASCII cpio archive \(SVR4 with no CRC\)}} if {[S 0 == 070702]} {emit {ASCII cpio archive \(SVR4 with CRC\)}} if {[S 0 == {!\ndebian}]} {if {[S 8 == debian-split]} {emit {part of multipart Debian package}} if {[S 8 == debian-binary]} {emit {Debian binary package}} if {[S 68 x {}]} {emit {\(format %s\)}} if {[S 81 == bz2]} {emit {\b, uses bzip2 compression}} if {[S 84 == gz]} {emit {\b, uses gzip compression}} } if {[S 0 == ]} {emit archive} if {[S 0 == {!\n__________E}]} {emit {MIPS archive} if {[S 20 == U]} {emit {with MIPS Ucode members}} if {[S 21 == L]} {emit {with MIPSEL members}} if {[S 21 == B]} {emit {with MIPSEB members}} if {[S 19 == L]} {emit {and an EL hash table}} if {[S 19 == B]} {emit {and an EB hash table}} if {[S 22 == X]} {emit {-- out of date}} } if {[S 0 == -h-]} {emit {Software Tools format archive text}} if {[S 0 == !]} {emit {current ar archive} if {[S 8 == __.SYMDEF]} {emit {random library}} switch -- [Nv I 0] 65538 {emit {- pre SR9.5}} 65539 {emit {- post SR9.5}} switch -- [Nv S 0] 2 {emit {- object archive}} 3 {emit {- shared library module}} 4 {emit {- debug break-pointed module}} 5 {emit {- absolute code program module}} } if {[S 0 == ]} {emit {System V Release 1 ar archive}} if {[S 0 == ]} {emit archive} switch -- [Nv i 0 &0x8080ffff] 2074 {emit {ARC archive data, dynamic LZW}} 2330 {emit {ARC archive data, squashed}} 538 {emit {ARC archive data, uncompressed}} 794 {emit {ARC archive data, packed}} 1050 {emit {ARC archive data, squeezed}} 1562 {emit {ARC archive data, crunched}} if {[S 0 == {\032}]} {emit {RISC OS archive \(spark format\)}} if {[S 0 == {Archive\000}]} {emit {RISC OS archive \(ArcFS format\)}} if {[S 0 == HPAK]} {emit {HPACK archive data}} if {[S 0 == {\351,\001JAM\ }]} {emit {JAM archive,} if {[S 7 x {}]} {emit {version %.4s}} if {[N c 38 == 0x27]} {emit - if {[S 43 x {}]} {emit {label %.11s,}} if {[N i 39 x {}]} {emit {serial %08x,}} if {[S 54 x {}]} {emit {fstype %.8s}} } } if {[S 2 == -lh0-]} {emit {LHarc 1.x archive data [lh0]}} if {[S 2 == -lh1-]} {emit {LHarc 1.x archive data [lh1]}} if {[S 2 == -lz4-]} {emit {LHarc 1.x archive data [lz4]}} if {[S 2 == -lz5-]} {emit {LHarc 1.x archive data [lz5]}} if {[S 2 == -lzs-]} {emit {LHa 2.x? archive data [lzs]}} if {[S 2 == {-lh\40-}]} {emit {LHa 2.x? archive data [lh ]}} if {[S 2 == -lhd-]} {emit {LHa 2.x? archive data [lhd]}} if {[S 2 == -lh2-]} {emit {LHa 2.x? archive data [lh2]}} if {[S 2 == -lh3-]} {emit {LHa 2.x? archive data [lh3]}} if {[S 2 == -lh4-]} {emit {LHa \(2.x\) archive data [lh4]}} if {[S 2 == -lh5-]} {emit {LHa \(2.x\) archive data [lh5]}} if {[S 2 == -lh6-]} {emit {LHa \(2.x\) archive data [lh6]}} if {[S 2 == -lh7-]} {emit {LHa \(2.x\) archive data [lh7]} if {[N c 20 x {}]} {emit {- header level %d}} } if {[S 0 == Rar!]} {emit {RAR archive data,} if {[N c 44 x {}]} {emit v%0x,} switch -- [Nv c 35] 0 {emit {os: MS-DOS}} 1 {emit {os: OS/2}} 2 {emit {os: Win32}} 3 {emit {os: Unix}} } if {[S 0 == SQSH]} {emit {squished archive data \(Acorn RISCOS\)}} if {[S 0 == {UC2\x1a}]} {emit {UC2 archive data}} if {[S 0 == {PK\003\004}]} {emit {Zip archive data} switch -- [Nv c 4] 9 {emit {\b, at least v0.9 to extract}} 10 {emit {\b, at least v1.0 to extract}} 11 {emit {\b, at least v1.1 to extract}} 20 {emit {\b, at least v2.0 to extract}} } if {[N i 20 == 0xfdc4a7dc]} {emit {Zoo archive data} if {[N c 4 > 0x30]} {emit {\b, v%c.} if {[N c 6 > 0x2f]} {emit {\b%c} if {[N c 7 > 0x2f]} {emit {\b%c}} } } if {[N c 32 > 0x0]} {emit {\b, modify: v%d} if {[N c 33 x {}]} {emit {\b.%d+}} } if {[N i 42 == 0xfdc4a7dc]} {emit {\b,} if {[N c 70 > 0x0]} {emit {extract: v%d} if {[N c 71 x {}]} {emit {\b.%d+}} } } } if {[S 10 == {\#\ This\ is\ a\ shell\ archive}]} {emit {shell archive text}} if {[S 0 == {\0\ \ \ \ \ \ \ \ \ \ \ \0\0}]} {emit {LBR archive data}} if {[S 2 == -pm0-]} {emit {PMarc archive data [pm0]}} if {[S 2 == -pm1-]} {emit {PMarc archive data [pm1]}} if {[S 2 == -pm2-]} {emit {PMarc archive data [pm2]}} if {[S 2 == -pms-]} {emit {PMarc SFX archive \(CP/M, DOS\)}} if {[S 5 == -pc1-]} {emit {PopCom compressed executable \(CP/M\)}} if {[S 4 == {gtktalog\ }]} {emit {GTKtalog catalog data,} if {[S 13 == 3]} {emit {version 3} if {[N S 14 == 0x677a]} {emit {\(gzipped\)}} if {[N S 14 != 0x677a]} {emit {\(not gzipped\)}} } if {[S 13 > 3]} {emit {version %s}} } if {[S 0 == {PAR\0}]} {emit {PARity archive data} if {[N s 48 == 0x0]} {emit {- Index file}} if {[N s 48 > 0x0]} {emit {- file number %d}} } if {[S 0 == d8:announce]} {emit {BitTorrent file}} if {[S 0 == {PK00PK\003\004}]} {emit {Zip archive data}} if {[S 7 == **ACE**]} {emit {ACE compressed archive} if {[N c 15 > 0x0]} {emit {version %d}} switch -- [Nv c 16] 0 {emit {\b, from MS-DOS}} 1 {emit {\b, from OS/2}} 2 {emit {\b, from Win/32}} 3 {emit {\b, from Unix}} 4 {emit {\b, from MacOS}} 5 {emit {\b, from WinNT}} 6 {emit {\b, from Primos}} 7 {emit {\b, from AppleGS}} 8 {emit {\b, from Atari}} 9 {emit {\b, from Vax/VMS}} 10 {emit {\b, from Amiga}} 11 {emit {\b, from Next}} if {[N c 14 x {}]} {emit {\b, version %d to extract}} if {[N s 5 & 0x80]} {emit {\b, multiple volumes,} if {[N c 17 x {}]} {emit {\b \(part %d\),}} } if {[N s 5 & 0x2]} {emit {\b, contains comment}} if {[N s 5 & 0x200]} {emit {\b, sfx}} if {[N s 5 & 0x400]} {emit {\b, small dictionary}} if {[N s 5 & 0x800]} {emit {\b, multi-volume}} if {[N s 5 & 0x1000]} {emit {\b, contains AV-String}} if {[N s 5 & 0x2000]} {emit {\b, with recovery record}} if {[N s 5 & 0x4000]} {emit {\b, locked}} if {[N s 5 & 0x8000]} {emit {\b, solid}} } if {[S 26 == sfArk]} {emit {sfArk compressed Soundfont} if {[S 21 == 2]} {if {[S 1 x {}]} {emit {Version %s}} if {[S 42 x {}]} {emit {: %s}} } } if {[S 0 == {Packed\ File\ }]} {emit {Personal NetWare Packed File} if {[S 12 x {}]} {emit {\b, was \"%.12s\"}} } if {[S 0 == *STA]} {emit Aster*x if {[S 7 == WORD]} {emit {Words Document}} if {[S 7 == GRAP]} {emit Graphic} if {[S 7 == SPRE]} {emit Spreadsheet} if {[S 7 == MACR]} {emit Macro} } if {[S 0 == 2278]} {emit {Aster*x Version 2} switch -- [Nv c 29] 54 {emit {Words Document}} 53 {emit Graphic} 50 {emit Spreadsheet} 56 {emit Macro} } if {[S 0 == {\000\004\036\212\200}]} {emit {3b2 core file} if {[S 364 x {}]} {emit {of '%s'}} } if {[S 0 == .snd]} {emit {Sun/NeXT audio data:} switch -- [Nv I 12] 1 {emit {8-bit ISDN mu-law,}} 2 {emit {8-bit linear PCM [REF-PCM],}} 3 {emit {16-bit linear PCM,}} 4 {emit {24-bit linear PCM,}} 5 {emit {32-bit linear PCM,}} 6 {emit {32-bit IEEE floating point,}} 7 {emit {64-bit IEEE floating point,}} 8 {emit {Fragmented sample data,}} 10 {emit {DSP program,}} 11 {emit {8-bit fixed point,}} 12 {emit {16-bit fixed point,}} 13 {emit {24-bit fixed point,}} 14 {emit {32-bit fixed point,}} 18 {emit {16-bit linear with emphasis,}} 19 {emit {16-bit linear compressed,}} 20 {emit {16-bit linear with emphasis and compression,}} 21 {emit {Music kit DSP commands,}} 23 {emit {8-bit ISDN mu-law compressed \(CCITT G.721 ADPCM voice data encoding\),}} 24 {emit {compressed \(8-bit CCITT G.722 ADPCM\)}} 25 {emit {compressed \(3-bit CCITT G.723.3 ADPCM\),}} 26 {emit {compressed \(5-bit CCITT G.723.5 ADPCM\),}} 27 {emit {8-bit A-law \(CCITT G.711\),}} switch -- [Nv I 20] 1 {emit mono,} 2 {emit stereo,} 4 {emit quad,} if {[N I 16 > 0x0]} {emit {%d Hz}} } if {[S 0 == MThd]} {emit {Standard MIDI data} if {[N S 8 x {}]} {emit {\(format %d\)}} if {[N S 10 x {}]} {emit {using %d track}} if {[N S 10 > 0x1]} {emit {\bs}} if {[N S 12 x {} &0x7fff]} {emit {at 1/%d}} if {[N S 12 > 0x0 &0x8000]} {emit SMPTE} } if {[S 0 == CTMF]} {emit {Creative Music \(CMF\) data}} if {[S 0 == SBI]} {emit {SoundBlaster instrument data}} if {[S 0 == {Creative\ Voice\ File}]} {emit {Creative Labs voice data} if {[N c 19 == 0x1a]} {emit 139 0} if {[N c 23 > 0x0]} {emit {- version %d}} if {[N c 22 > 0x0]} {emit {\b.%d}} } if {[S 0 == EMOD]} {emit {Extended MOD sound data,} if {[N c 4 x {} &0xf0]} {emit {version %d}} if {[N c 4 x {} &0x0f]} {emit {\b.%d,}} if {[N c 45 x {}]} {emit {%d instruments}} switch -- [Nv c 83] 0 {emit {\(module\)}} 1 {emit {\(song\)}} } if {[S 0 == .RMF]} {emit {RealMedia file}} if {[S 0 == MAS_U]} {emit {ULT\(imate\) Module sound data}} if {[S 44 == SCRM]} {emit {ScreamTracker III Module sound data} if {[S 0 x {}]} {emit {Title: \"%s\"}} } if {[S 0 == {GF1PATCH110\0ID\#000002\0}]} {emit {GUS patch}} if {[S 0 == {GF1PATCH100\0ID\#000002\0}]} {emit {Old GUS patch}} if {[S 0 == MAS_UTrack_V00]} {if {[S 14 > /0]} {emit {ultratracker V1.%.1s module sound data}} } if {[S 0 == UN05]} {emit {MikMod UNI format module sound data}} if {[S 0 == {Extended\ Module:}]} {emit {Fasttracker II module sound data} if {[S 17 x {}]} {emit {Title: \"%s\"}} } if {[S 21 == !SCREAM! c]} {emit {Screamtracker 2 module sound data}} if {[S 21 == BMOD2STM]} {emit {Screamtracker 2 module sound data}} if {[S 1080 == M.K.]} {emit {4-channel Protracker module sound data} if {[S 0 x {}]} {emit {Title: \"%s\"}} } if {[S 1080 == M!K!]} {emit {4-channel Protracker module sound data} if {[S 0 x {}]} {emit {Title: \"%s\"}} } if {[S 1080 == FLT4]} {emit {4-channel Startracker module sound data} if {[S 0 x {}]} {emit {Title: \"%s\"}} } if {[S 1080 == FLT8]} {emit {8-channel Startracker module sound data} if {[S 0 x {}]} {emit {Title: \"%s\"}} } if {[S 1080 == 4CHN]} {emit {4-channel Fasttracker module sound data} if {[S 0 x {}]} {emit {Title: \"%s\"}} } if {[S 1080 == 6CHN]} {emit {6-channel Fasttracker module sound data} if {[S 0 x {}]} {emit {Title: \"%s\"}} } if {[S 1080 == 8CHN]} {emit {8-channel Fasttracker module sound data} if {[S 0 x {}]} {emit {Title: \"%s\"}} } if {[S 1080 == CD81]} {emit {8-channel Octalyser module sound data} if {[S 0 x {}]} {emit {Title: \"%s\"}} } if {[S 1080 == OKTA]} {emit {8-channel Oktalyzer module sound data} if {[S 0 x {}]} {emit {Title: \"%s\"}} } if {[S 1080 == 16CN]} {emit {16-channel Taketracker module sound data} if {[S 0 x {}]} {emit {Title: \"%s\"}} } if {[S 1080 == 32CN]} {emit {32-channel Taketracker module sound data} if {[S 0 x {}]} {emit {Title: \"%s\"}} } if {[S 0 == TOC]} {emit {TOC sound file}} if {[S 0 == {SIDPLAY\ INFOFILE}]} {emit {Sidplay info file}} if {[S 0 == PSID]} {emit {PlaySID v2.2+ \(AMIGA\) sidtune} if {[N S 4 > 0x0]} {emit {w/ header v%d,}} if {[N S 14 == 0x1]} {emit {single song,}} if {[N S 14 > 0x1]} {emit {%d songs,}} if {[N S 16 > 0x0]} {emit {default song: %d}} if {[S 22 x {}]} {emit {name: \"%s\"}} if {[S 54 x {}]} {emit {author: \"%s\"}} if {[S 86 x {}]} {emit {copyright: \"%s\"}} } if {[S 0 == RSID]} {emit {RSID sidtune PlaySID compatible} if {[N S 4 > 0x0]} {emit {w/ header v%d,}} if {[N S 14 == 0x1]} {emit {single song,}} if {[N S 14 > 0x1]} {emit {%d songs,}} if {[N S 16 > 0x0]} {emit {default song: %d}} if {[S 22 x {}]} {emit {name: \"%s\"}} if {[S 54 x {}]} {emit {author: \"%s\"}} if {[S 86 x {}]} {emit {copyright: \"%s\"}} } if {[S 0 == {NIST_1A\n\ \ \ 1024\n}]} {emit {NIST SPHERE file}} if {[S 0 == {SOUND\ SAMPLE\ DATA\ }]} {emit {Sample Vision file}} if {[S 0 == 2BIT]} {emit {Audio Visual Research file,} switch -- [Nv S 12] 0 {emit mono,} -1 {emit stereo,} if {[N S 14 x {}]} {emit {%d bits}} switch -- [Nv S 16] 0 {emit unsigned,} -1 {emit signed,} if {[N I 22 x {} &0x00ffffff]} {emit {%d Hz,}} switch -- [Nv S 18] 0 {emit {no loop,}} -1 {emit loop,} if {[N c 21 <= 0x7f]} {emit {note %d,}} switch -- [Nv c 22] 0 {emit {replay 5.485 KHz}} 1 {emit {replay 8.084 KHz}} 2 {emit {replay 10.971 Khz}} 3 {emit {replay 16.168 Khz}} 4 {emit {replay 21.942 KHz}} 5 {emit {replay 32.336 KHz}} 6 {emit {replay 43.885 KHz}} 7 {emit {replay 47.261 KHz}} } if {[S 0 == _SGI_SoundTrack]} {emit {SGI SoundTrack project file}} if {[S 0 == ID3]} {emit {MP3 file with ID3 version 2.} if {[N c 3 < 0xff]} {emit {\b%d.}} if {[N c 4 < 0xff]} {emit {\b%d tag}} } if {[S 0 == {NESM\x1a}]} {emit {NES Sound File} if {[S 14 x {}]} {emit {\(\"%s\" by}} if {[S 46 x {}]} {emit {%s, copyright}} if {[S 78 x {}]} {emit {%s\),}} if {[N c 5 x {}]} {emit {version %d,}} if {[N c 6 x {}]} {emit {%d tracks,}} if {[N c 122 == 0x1 &0x2]} {emit {dual PAL/NTSC}} switch -- [Nv c 122 &0x1] 1 {emit PAL} 0 {emit NTSC} } if {[S 0 == IMPM]} {emit {Impulse Tracker module sound data -} if {[S 4 x {}]} {emit {\"%s\"}} if {[N s 40 != 0x0]} {emit {compatible w/ITv%x}} if {[N s 42 != 0x0]} {emit {created w/ITv%x}} } if {[S 60 == IM10]} {emit {Imago Orpheus module sound data -} if {[S 0 x {}]} {emit {\"%s\"}} } if {[S 0 == IMPS]} {emit {Impulse Tracker Sample} if {[N c 18 & 0x2]} {emit {16 bit}} if {[N c 18 ^ 0x2]} {emit {8 bit}} if {[N c 18 & 0x4]} {emit stereo} if {[N c 18 ^ 0x4]} {emit mono} } if {[S 0 == IMPI]} {emit {Impulse Tracker Instrument} if {[N s 28 != 0x0]} {emit ITv%x} if {[N c 30 != 0x0]} {emit {%d samples}} } if {[S 0 == LM8953]} {emit {Yamaha TX Wave} switch -- [Nv c 22] 73 {emit looped} -55 {emit non-looped} switch -- [Nv c 23] 1 {emit 33kHz} 2 {emit 50kHz} 3 {emit 16kHz} } if {[S 76 == SCRS]} {emit {Scream Tracker Sample} switch -- [Nv c 0] 1 {emit sample} 2 {emit {adlib melody}} if {[N c 0 > 0x2]} {emit {adlib drum}} if {[N c 31 & 0x2]} {emit stereo} if {[N c 31 ^ 0x2]} {emit mono} if {[N c 31 & 0x4]} {emit {16bit little endian}} if {[N c 31 ^ 0x4]} {emit 8bit} switch -- [Nv c 30] 0 {emit unpacked} 1 {emit packed} } if {[S 0 == MMD0]} {emit {MED music file, version 0}} if {[S 0 == MMD1]} {emit {OctaMED Pro music file, version 1}} if {[S 0 == MMD3]} {emit {OctaMED Soundstudio music file, version 3}} if {[S 0 == OctaMEDCmpr]} {emit {OctaMED Soundstudio compressed file}} if {[S 0 == MED]} {emit MED_Song} if {[S 0 == SymM]} {emit {Symphonie SymMOD music file}} if {[S 0 == THX]} {emit {AHX version} switch -- [Nv c 3] 0 {emit {1 module data}} 1 {emit {2 module data}} } if {[S 0 == OKTASONG]} {emit {Oktalyzer module data}} if {[S 0 == {DIGI\ Booster\ module\0}]} {emit %s if {[N c 20 > 0x0]} {emit %c if {[N c 21 > 0x0]} {emit {\b%c} if {[N c 22 > 0x0]} {emit {\b%c} if {[N c 23 > 0x0]} {emit {\b%c}} } } } if {[S 610 x {}]} {emit {\b, \"%s\"}} } if {[S 0 == DBM0]} {emit {DIGI Booster Pro Module} if {[N c 4 > 0x0]} {emit V%X. if {[N c 5 x {}]} {emit {\b%02X}} } if {[S 16 x {}]} {emit {\b, \"%s\"}} } if {[S 0 == FTMN]} {emit {FaceTheMusic module} if {[S 16 > {\0d}]} {emit {\b, \"%s\"}} } if {[S 0 == {AMShdr\32}]} {emit {Velvet Studio AMS Module v2.2}} if {[S 0 == Extreme]} {emit {Extreme Tracker AMS Module v1.3}} if {[S 0 == DDMF]} {emit {Xtracker DMF Module} if {[N c 4 x {}]} {emit v%i} if {[S 13 x {}]} {emit {Title: \"%s\"}} if {[S 43 x {}]} {emit {Composer: \"%s\"}} } if {[S 0 == {DSM\32}]} {emit {Dynamic Studio Module DSM}} if {[S 0 == SONG]} {emit {DigiTrekker DTM Module}} if {[S 0 == DMDL]} {emit {DigiTrakker MDL Module}} if {[S 0 == {PSM\32}]} {emit {Protracker Studio PSM Module}} if {[S 44 == PTMF]} {emit {Poly Tracker PTM Module} if {[S 0 > {\32}]} {emit {Title: \"%s\"}} } if {[S 0 == MT20]} {emit {MadTracker 2.0 Module MT2}} if {[S 0 == {RAD\40by\40REALiTY!!}]} {emit {RAD Adlib Tracker Module RAD}} if {[S 0 == RTMM]} {emit {RTM Module}} if {[S 1062 == MaDoKaN96]} {emit {XMS Adlib Module} if {[S 0 x {}]} {emit {Composer: \"%s\"}} } if {[S 0 == AMF]} {emit {AMF Module} if {[S 4 x {}]} {emit {Title: \"%s\"}} } if {[S 0 == MODINFO1]} {emit {Open Cubic Player Module Inforation MDZ}} if {[S 0 == {Extended\40Instrument:}]} {emit {Fast Tracker II Instrument}} if {[S 0 == {\210NOA\015\012\032}]} {emit {NOA Nancy Codec Movie file}} if {[S 0 == MMMD]} {emit {Yamaha SMAF file}} if {[S 0 == {\001Sharp\040JisakuMelody}]} {emit {SHARP Cell-Phone ringing Melody} if {[S 20 == Ver01.00]} {emit {Ver. 1.00} if {[N c 32 x {}]} {emit {, %d tracks}} } } if {[S 0 == fLaC]} {emit {FLAC audio bitstream data} if {[N c 4 > 0x0 &0x7f]} {emit {\b, unknown version}} if {[N c 4 == 0x0 &0x7f]} {emit {\b} switch -- [Nv S 20 &0x1f0] 48 {emit {\b, 4 bit}} 80 {emit {\b, 6 bit}} 112 {emit {\b, 8 bit}} 176 {emit {\b, 12 bit}} 240 {emit {\b, 16 bit}} 368 {emit {\b, 24 bit}} switch -- [Nv c 20 &0xe] 0 {emit {\b, mono}} 2 {emit {\b, stereo}} 4 {emit {\b, 3 channels}} 6 {emit {\b, 4 channels}} 8 {emit {\b, 5 channels}} 10 {emit {\b, 6 channels}} 12 {emit {\b, 7 channels}} 14 {emit {\b, 8 channels}} switch -- [Nv I 17 &0xfffff0] 705600 {emit {\b, 44.1 kHz}} 768000 {emit {\b, 48 kHz}} 512000 {emit {\b, 32 kHz}} 352800 {emit {\b, 22.05 kHz}} 384000 {emit {\b, 24 kHz}} 256000 {emit {\b, 16 kHz}} 176400 {emit {\b, 11.025 kHz}} 192000 {emit {\b, 12 kHz}} 128000 {emit {\b, 8 kHz}} 1536000 {emit {\b, 96 kHz}} 1024000 {emit {\b, 64 kHz}} if {[N c 21 > 0x0 &0xf]} {emit {\b, >4G samples}} if {[N c 21 == 0x0 &0xf]} {emit {\b} if {[N I 22 > 0x0]} {emit {\b, %u samples}} if {[N I 22 == 0x0]} {emit {\b, length unknown}} } } } if {[S 0 == VBOX]} {emit {VBOX voice message data}} if {[S 8 == RB40]} {emit {RBS Song file} if {[S 29 == ReBorn]} {emit {created by ReBorn}} if {[S 37 == Propellerhead]} {emit {created by ReBirth}} } if {[S 0 == {A\#S\#C\#S\#S\#L\#V\#3}]} {emit {Synthesizer Generator or Kimwitu data}} if {[S 0 == {A\#S\#C\#S\#S\#L\#HUB}]} {emit {Kimwitu++ data}} if {[S 0 == TFMX-SONG]} {emit {TFMX module sound data}} if {[S 0 == {MAC\ X/Monkey}]} {emit audio, if {[N s 4 > 0x0]} {emit {version %d,}} if {[N s 6 > 0x0]} {emit {compression level %d,}} if {[N s 8 > 0x0]} {emit {flags %x,}} if {[N s 10 > 0x0]} {emit {channels %d,}} if {[N i 12 > 0x0]} {emit {samplerate %d,}} if {[N i 24 > 0x0]} {emit {frames %d}} } if {[S 0 == bFLT]} {emit {BFLT executable} if {[N I 4 x {}]} {emit {- version %ld}} if {[N I 4 == 0x4]} {if {[N I 36 == 0x1 &0x1]} {emit ram} if {[N I 36 == 0x2 &0x2]} {emit gotpic} if {[N I 36 == 0x4 &0x4]} {emit gzip} if {[N I 36 == 0x8 &0x8]} {emit gzdata} } } if {[S 0 == BLENDER]} {emit Blender3D, if {[S 7 == _]} {emit {saved as 32-bits}} if {[S 7 == -]} {emit {saved as 64-bits}} if {[S 8 == v]} {emit {little endian}} if {[S 8 == V]} {emit {big endian}} if {[N c 9 x {}]} {emit {with version %c.}} if {[N c 10 x {}]} {emit {\b%c}} if {[N c 11 x {}]} {emit {\b%c}} } if {[S 0 == !]} {emit {b.out archive} if {[S 8 == __.SYMDEF]} {emit {random library}} } switch -- [Nv I 0 &077777777] 196875 {emit {sparc demand paged} if {[N c 0 & 0x80]} {if {[N I 20 < 0x1000]} {emit {shared library}} if {[N I 20 == 0x1000]} {emit {dynamically linked executable}} if {[N I 20 > 0x1000]} {emit {dynamically linked executable}} } if {[N c 0 ^ 0x80]} {emit executable} if {[N I 16 > 0x0]} {emit {not stripped}} if {[N I 36 == 0xb4100001]} {emit {\(uses shared libs\)}} } 196872 {emit {sparc pure} if {[N c 0 & 0x80]} {emit {dynamically linked executable}} if {[N c 0 ^ 0x80]} {emit executable} if {[N I 16 > 0x0]} {emit {not stripped}} if {[N I 36 == 0xb4100001]} {emit {\(uses shared libs\)}} } 196871 {emit sparc if {[N c 0 & 0x80]} {emit {dynamically linked executable}} if {[N c 0 ^ 0x80]} {emit executable} if {[N I 16 > 0x0]} {emit {not stripped}} if {[N I 36 == 0xb4100001]} {emit {\(uses shared libs\)}} } 196875 {emit {sparc demand paged} if {[N c 0 & 0x80]} {if {[N I 20 < 0x1000]} {emit {shared library}} if {[N I 20 == 0x1000]} {emit {dynamically linked executable}} if {[N I 20 > 0x1000]} {emit {dynamically linked executable}} } if {[N c 0 ^ 0x80]} {emit executable} if {[N I 16 > 0x0]} {emit {not stripped}} } 196872 {emit {sparc pure} if {[N c 0 & 0x80]} {emit {dynamically linked executable}} if {[N c 0 ^ 0x80]} {emit executable} if {[N I 16 > 0x0]} {emit {not stripped}} } 196871 {emit sparc if {[N c 0 & 0x80]} {emit {dynamically linked executable}} if {[N c 0 ^ 0x80]} {emit executable} if {[N I 16 > 0x0]} {emit {not stripped}} } 131339 {emit {mc68020 demand paged} if {[N c 0 & 0x80]} {if {[N I 20 < 0x1000]} {emit {shared library}} if {[N I 20 == 0x1000]} {emit {dynamically linked executable}} if {[N I 20 > 0x1000]} {emit {dynamically linked executable}} } if {[N I 16 > 0x0]} {emit {not stripped}} } 131336 {emit {mc68020 pure} if {[N c 0 & 0x80]} {emit {dynamically linked executable}} if {[N c 0 ^ 0x80]} {emit executable} if {[N I 16 > 0x0]} {emit {not stripped}} } 131335 {emit mc68020 if {[N c 0 & 0x80]} {emit {dynamically linked executable}} if {[N c 0 ^ 0x80]} {emit executable} if {[N I 16 > 0x0]} {emit {not stripped}} } 65803 {emit {mc68010 demand paged} if {[N c 0 & 0x80]} {if {[N I 20 < 0x1000]} {emit {shared library}} if {[N I 20 == 0x1000]} {emit {dynamically linked executable}} if {[N I 20 > 0x1000]} {emit {dynamically linked executable}} } if {[N I 16 > 0x0]} {emit {not stripped}} } 65800 {emit {mc68010 pure} if {[N c 0 & 0x80]} {emit {dynamically linked executable}} if {[N c 0 ^ 0x80]} {emit executable} if {[N I 16 > 0x0]} {emit {not stripped}} } 65799 {emit mc68010 if {[N c 0 & 0x80]} {emit {dynamically linked executable}} if {[N c 0 ^ 0x80]} {emit executable} if {[N I 16 > 0x0]} {emit {not stripped}} } if {[S 0 == cscope]} {emit {cscope reference data} if {[S 7 x {}]} {emit {version %.2s}} if {[S 7 > 14]} {emit 218 1} } switch -- [Nv I 91392] 302072064 {emit {D64 Image}} 302072192 {emit {D71 Image}} if {[N I 399360 == 0x28034400]} {emit {D81 Image}} if {[S 0 == {C64\40CARTRIDGE}]} {emit {CCS C64 Emultar Cartridge Image}} if {[S 0 == GCR-1541]} {emit {GCR Image} if {[N c 8 x {}]} {emit {version: $i}} if {[N c 9 x {}]} {emit {tracks: %i}} } if {[S 9 == PSUR]} {emit {ARC archive \(c64\)}} if {[S 2 == -LH1-]} {emit {LHA archive \(c64\)}} if {[S 0 == C64File]} {emit {PC64 Emulator file} if {[S 8 x {}]} {emit {\"%s\"}} } if {[S 0 == C64Image]} {emit {PC64 Freezer Image}} if {[S 0 == {CBM\144\0\0}]} {emit {Power 64 C64 Emulator Snapshot}} if {[S 0 == {\101\103\061\060\061}]} {emit AutoCAD if {[S 5 == {\062\000\000\000\000}]} {emit {DWG ver. R13}} if {[S 5 == {\064\000\000\000\000}]} {emit {DWG ver. R14}} } if {[S 0 == {\010\011\376}]} {emit Microstation if {[S 3 == {\002}]} {if {[S 30 == {\372\104}]} {emit {DGN File}} if {[S 30 == {\172\104}]} {emit {DGN File}} if {[S 30 == {\026\105}]} {emit {DGN File}} } if {[S 4 == {\030\000\000}]} {emit {CIT File}} } if {[S 0 == AC1012]} {emit {AutoCad \(release 12\)}} if {[S 0 == AC1014]} {emit {AutoCad \(release 14\)}} if {[S 0 == {\#\040xmcd} b]} {emit {CDDB\(tm\) format CD text data}} if {[S 0 == {\\1cw\ }]} {emit {ChiWriter file} if {[S 5 x {}]} {emit {version %s}} } if {[S 0 == {\\1cw}]} {emit {ChiWriter file}} if {[S 0 == {\{title}]} {emit {Chord text file}} if {[S 0 == RuneCT]} {emit {Citrus locale declaration for LC_CTYPE}} if {[S 514 == {\377\377\377\377\000}]} {emit {Claris clip art?} if {[S 0 == {\0\0\0\0\0\0\0\0\0\0\0\0\0}]} {emit yes.} } if {[S 514 == {\377\377\377\377\001}]} {emit {Claris clip art?} if {[S 0 == {\0\0\0\0\0\0\0\0\0\0\0\0\0}]} {emit yes.} } if {[S 0 == {\002\000\210\003\102\117\102\117\000\001\206}]} {emit {Claris works document}} if {[S 0 == {\020\341\000\000\010\010}]} {emit {Claris Works pallete files .plt}} if {[S 0 == {\002\271\262\000\040\002\000\164}]} {emit {Claris works dictionary}} if {[S 0 == GRG]} {emit {Gringotts data file} if {[S 3 == 1]} {emit {v.1, MCRYPT S2K, SERPENT crypt, SHA-256 hash, ZLib lvl.9}} if {[S 3 == 2]} {emit {v.2, MCRYPT S2K,} switch -- [Nv c 8 &0x70] 0 {emit {RIJNDAEL-128 crypt,}} 16 {emit {SERPENT crypt,}} 32 {emit {TWOFISH crypt,}} 48 {emit {CAST-256 crypt,}} 64 {emit {SAFER+ crypt,}} 80 {emit {LOKI97 crypt,}} 96 {emit {3DES crypt,}} 112 {emit {RIJNDAEL-256 crypt,}} switch -- [Nv c 8 &0x08] 0 {emit {SHA1 hash,}} 8 {emit {RIPEMD-160 hash,}} switch -- [Nv c 8 &0x04] 0 {emit ZLib} 4 {emit BZip2} switch -- [Nv c 8 &0x03] 0 {emit lvl.0} 1 {emit lvl.3} 2 {emit lvl.6} 3 {emit lvl.9} } if {[S 3 == 3]} {emit {v.3, OpenPGP S2K,} switch -- [Nv c 8 &0x70] 0 {emit {RIJNDAEL-128 crypt,}} 16 {emit {SERPENT crypt,}} 32 {emit {TWOFISH crypt,}} 48 {emit {CAST-256 crypt,}} 64 {emit {SAFER+ crypt,}} 80 {emit {LOKI97 crypt,}} 96 {emit {3DES crypt,}} 112 {emit {RIJNDAEL-256 crypt,}} switch -- [Nv c 8 &0x08] 0 {emit {SHA1 hash,}} 8 {emit {RIPEMD-160 hash,}} switch -- [Nv c 8 &0x04] 0 {emit ZLib} 4 {emit BZip2} switch -- [Nv c 8 &0x03] 0 {emit lvl.0} 1 {emit lvl.3} 2 {emit lvl.6} 3 {emit lvl.9} } if {[S 3 > 3]} {emit {v.%.1s \(unknown details\)}} } if {[S 0 == :]} {emit {shell archive or script for antique kernel text}} if {[S 0 == {\#!\ /bin/sh} b]} {emit {Bourne shell script text executable}} if {[S 0 == {\#!\ /bin/csh} b]} {emit {C shell script text executable}} if {[S 0 == {\#!\ /bin/ksh} b]} {emit {Korn shell script text executable}} if {[S 0 == {\#!\ /bin/tcsh} b]} {emit {Tenex C shell script text executable}} if {[S 0 == {\#!\ /usr/local/tcsh} b]} {emit {Tenex C shell script text executable}} if {[S 0 == {\#!\ /usr/local/bin/tcsh} b]} {emit {Tenex C shell script text executable}} if {[S 0 == {\#!\ /bin/zsh} b]} {emit {Paul Falstad's zsh script text executable}} if {[S 0 == {\#!\ /usr/bin/zsh} b]} {emit {Paul Falstad's zsh script text executable}} if {[S 0 == {\#!\ /usr/local/bin/zsh} b]} {emit {Paul Falstad's zsh script text executable}} if {[S 0 == {\#!\ /usr/local/bin/ash} b]} {emit {Neil Brown's ash script text executable}} if {[S 0 == {\#!\ /usr/local/bin/ae} b]} {emit {Neil Brown's ae script text executable}} if {[S 0 == {\#!\ /bin/nawk} b]} {emit {new awk script text executable}} if {[S 0 == {\#!\ /usr/bin/nawk} b]} {emit {new awk script text executable}} if {[S 0 == {\#!\ /usr/local/bin/nawk} b]} {emit {new awk script text executable}} if {[S 0 == {\#!\ /bin/gawk} b]} {emit {GNU awk script text executable}} if {[S 0 == {\#!\ /usr/bin/gawk} b]} {emit {GNU awk script text executable}} if {[S 0 == {\#!\ /usr/local/bin/gawk} b]} {emit {GNU awk script text executable}} if {[S 0 == {\#!\ /bin/awk} b]} {emit {awk script text executable}} if {[S 0 == {\#!\ /usr/bin/awk} b]} {emit {awk script text executable}} if {[S 0 == BEGIN]} {emit {awk script text}} if {[S 0 == {\#!\ /bin/rc} b]} {emit {Plan 9 rc shell script text executable}} if {[S 0 == {\#!\ /bin/bash} b]} {emit {Bourne-Again shell script text executable}} if {[S 0 == {\#!\ /usr/local/bin/bash} b]} {emit {Bourne-Again shell script text executable}} if {[S 0 == {\#!/usr/bin/env}]} {emit a if {[S 15 x {}]} {emit {%s script text executable}} } if {[S 0 == {\#!\ /usr/bin/env}]} {emit a if {[S 16 x {}]} {emit {%s script text executable}} } if {[S 0 == {\n}]} {emit %s} } L 1;if {[Sx 2 [R 2] == {$SuiteId}]} {if {[S [R 1] > {\n}]} {emit %s} } L 1;if {[Sx 2 [R 3] == {$SuiteId}]} {if {[S [R 1] > {\n}]} {emit %s} } } if {[S 0 == mscdocument]} {emit {Message Sequence Chart \(document\)}} if {[S 0 == msc]} {emit {Message Sequence Chart \(chart\)}} if {[S 0 == submsc]} {emit {Message Sequence Chart \(subchart\)}} if {[S 0 == {\037\235}]} {emit {compress'd data} if {[N c 2 > 0x0 &0x80]} {emit {block compressed}} if {[N c 2 x {} &0x1f]} {emit {%d bits}} } if {[S 0 == {\037\213}]} {emit {gzip compressed data} if {[N c 2 < 0x8]} {emit {\b, reserved method}} if {[N c 2 > 0x8]} {emit {\b, unknown method}} if {[N c 3 & 0x1]} {emit {\b, ASCII}} if {[N c 3 & 0x2]} {emit {\b, continuation}} if {[N c 3 & 0x4]} {emit {\b, extra field}} if {[N c 3 == 0x8 &0xC]} {if {[S 10 x {}]} {emit {\b, was \"%s\"}} } switch -- [Nv c 9] 0 {emit {\b, from MS-DOS}} 1 {emit {\b, from Amiga}} 2 {emit {\b, from VMS}} 3 {emit {\b, from Unix}} 5 {emit {\b, from Atari}} 6 {emit {\b, from OS/2}} 7 {emit {\b, from MacOS}} 10 {emit {\b, from Tops/20}} 11 {emit {\b, from Win/32}} if {[N c 3 & 0x10]} {emit {\b, comment}} if {[N c 3 & 0x20]} {emit {\b, encrypted}} switch -- [Nv c 8] 2 {emit {\b, max compression}} 4 {emit {\b, max speed}} } if {[S 0 == {\037\036}]} {emit {packed data} if {[N I 2 > 0x1]} {emit {\b, %d characters originally}} if {[N I 2 == 0x1]} {emit {\b, %d character originally}} } if {[S 0 == {\377\037}]} {emit {compacted data}} if {[S 0 == BZh]} {emit {bzip2 compressed data} if {[N c 3 > 0x2f]} {emit {\b, block size = %c00k}} } if {[S 0 == {\037\237}]} {emit {frozen file 2.1}} if {[S 0 == {\037\236}]} {emit {frozen file 1.0 \(or gzip 0.5\)}} if {[S 0 == {\037\240}]} {emit {SCO compress -H \(LZH\) data}} if {[S 0 == BZ]} {emit {bzip compressed data} if {[N c 2 x {}]} {emit {\b, version: %c}} if {[S 3 == 1]} {emit {\b, compression block size 100k}} if {[S 3 == 2]} {emit {\b, compression block size 200k}} if {[S 3 == 3]} {emit {\b, compression block size 300k}} if {[S 3 == 4]} {emit {\b, compression block size 400k}} if {[S 3 == 5]} {emit {\b, compression block size 500k}} if {[S 3 == 6]} {emit {\b, compression block size 600k}} if {[S 3 == 7]} {emit {\b, compression block size 700k}} if {[S 3 == 8]} {emit {\b, compression block size 800k}} if {[S 3 == 9]} {emit {\b, compression block size 900k}} } if {[S 0 == {\x89\x4c\x5a\x4f\x00\x0d\x0a\x1a\x0a}]} {emit {lzop compressed data} if {[N S 9 < 0x940]} {if {[N c 9 == 0x0 &0xf0]} {emit {- version 0.}} if {[N S 9 x {} &0x0fff]} {emit {\b%03x,}} switch -- [Nv c 13] 1 {emit LZO1X-1,} 2 {emit {LZO1X-1\(15\),}} 3 {emit LZO1X-999,} switch -- [Nv c 14] 0 {emit {os: MS-DOS}} 1 {emit {os: Amiga}} 2 {emit {os: VMS}} 3 {emit {os: Unix}} 5 {emit {os: Atari}} 6 {emit {os: OS/2}} 7 {emit {os: MacOS}} 10 {emit {os: Tops/20}} 11 {emit {os: WinNT}} 14 {emit {os: Win32}} } if {[N S 9 > 0x939]} {switch -- [Nv c 9 &0xf0] 0 {emit {- version 0.}} 16 {emit {- version 1.}} 32 {emit {- version 2.}} if {[N S 9 x {} &0x0fff]} {emit {\b%03x,}} switch -- [Nv c 15] 1 {emit LZO1X-1,} 2 {emit {LZO1X-1\(15\),}} 3 {emit LZO1X-999,} switch -- [Nv c 17] 0 {emit {os: MS-DOS}} 1 {emit {os: Amiga}} 2 {emit {os: VMS}} 3 {emit {os: Unix}} 5 {emit {os: Atari}} 6 {emit {os: OS/2}} 7 {emit {os: MacOS}} 10 {emit {os: Tops/20}} 11 {emit {os: WinNT}} 14 {emit {os: Win32}} } } if {[S 0 == {\037\241}]} {emit {Quasijarus strong compressed data}} if {[S 0 == XPKF]} {emit {Amiga xpkf.library compressed data}} if {[S 0 == PP11]} {emit {Power Packer 1.1 compressed data}} if {[S 0 == PP20]} {emit {Power Packer 2.0 compressed data,} switch -- [Nv I 4] 151587081 {emit {fast compression}} 151652874 {emit {mediocre compression}} 151653131 {emit {good compression}} 151653388 {emit {very good compression}} 151653389 {emit {best compression}} } if {[S 0 == {7z\274\257\047\034}]} {emit {7z archive data,} if {[N c 6 x {}]} {emit {version %d}} if {[N c 7 x {}]} {emit {\b.%d}} } if {[S 2 == -afx-]} {emit {AFX compressed file data}} if {[S 0 == {NES\032}]} {emit {iNES ROM dump,} if {[N c 4 x {}]} {emit {%dx16k PRG}} if {[N c 5 x {}]} {emit {\b, %dx8k CHR}} switch -- [Nv c 6 &0x01] 1 {emit {\b, [Vert.]}} 0 {emit {\b, [Horiz.]}} if {[N c 6 == 0x2 &0x02]} {emit {\b, [SRAM]}} switch -- [Nv c 6 &0x04] 4 {emit {\b, [Trainer]}} 8 {emit {\b, [4-Scr]}} } if {[N I 260 == 0xceed6666]} {emit {Gameboy ROM:} if {[S 308 x {}]} {emit {\"%.16s\"}} if {[N c 326 == 0x3]} {emit {\b,[SGB]}} switch -- [Nv c 327] 0 {emit {\b, [ROM ONLY]}} 1 {emit {\b, [ROM+MBC1]}} 2 {emit {\b, [ROM+MBC1+RAM]}} 3 {emit {\b, [ROM+MBC1+RAM+BATT]}} 5 {emit {\b, [ROM+MBC2]}} 6 {emit {\b, [ROM+MBC2+BATTERY]}} 8 {emit {\b, [ROM+RAM]}} 9 {emit {\b, [ROM+RAM+BATTERY]}} 11 {emit {\b, [ROM+MMM01]}} 12 {emit {\b, [ROM+MMM01+SRAM]}} 13 {emit {\b, [ROM+MMM01+SRAM+BATT]}} 15 {emit {\b, [ROM+MBC3+TIMER+BATT]}} 16 {emit {\b, [ROM+MBC3+TIMER+RAM+BATT]}} 17 {emit {\b, [ROM+MBC3]}} 18 {emit {\b, [ROM+MBC3+RAM]}} 19 {emit {\b, [ROM+MBC3+RAM+BATT]}} 25 {emit {\b, [ROM+MBC5]}} 26 {emit {\b, [ROM+MBC5+RAM]}} 27 {emit {\b, [ROM+MBC5+RAM+BATT]}} 28 {emit {\b, [ROM+MBC5+RUMBLE]}} 29 {emit {\b, [ROM+MBC5+RUMBLE+SRAM]}} 30 {emit {\b, [ROM+MBC5+RUMBLE+SRAM+BATT]}} 31 {emit {\b, [Pocket Camera]}} -3 {emit {\b, [Bandai TAMA5]}} -2 {emit {\b, [Hudson HuC-3]}} -1 {emit {\b, [Hudson HuC-1]}} switch -- [Nv c 328] 0 {emit {\b, ROM: 256Kbit}} 1 {emit {\b, ROM: 512Kbit}} 2 {emit {\b, ROM: 1Mbit}} 3 {emit {\b, ROM: 2Mbit}} 4 {emit {\b, ROM: 4Mbit}} 5 {emit {\b, ROM: 8Mbit}} 6 {emit {\b, ROM: 16Mbit}} 82 {emit {\b, ROM: 9Mbit}} 83 {emit {\b, ROM: 10Mbit}} 84 {emit {\b, ROM: 12Mbit}} switch -- [Nv c 329] 1 {emit {\b, RAM: 16Kbit}} 2 {emit {\b, RAM: 64Kbit}} 3 {emit {\b, RAM: 128Kbit}} 4 {emit {\b, RAM: 1Mbit}} } if {[S 256 == SEGA]} {emit {Sega MegaDrive/Genesis raw ROM dump} if {[S 288 x {}]} {emit {Name: \"%.16s\"}} if {[S 272 x {}]} {emit %.16s} if {[S 432 == RA]} {emit {with SRAM}} } if {[S 640 == EAGN]} {emit {Super MagicDrive ROM dump} if {[N c 0 x {}]} {emit {%dx16k blocks}} if {[N c 2 == 0x0]} {emit {\b, last in series or standalone}} if {[N c 2 > 0x0]} {emit {\b, split ROM}} if {[N c 8 == 0xaa]} {emit 298 3} if {[N c 9 == 0xbb]} {emit 298 4} } if {[S 640 == EAMG]} {emit {Super MagicDrive ROM dump} if {[N c 0 x {}]} {emit {%dx16k blocks}} if {[N c 2 x {}]} {emit {\b, last in series or standalone}} if {[N c 8 == 0xaa]} {emit 299 2} if {[N c 9 == 0xbb]} {emit 299 3} } if {[S 0 == LCDi]} {emit {Dream Animator file}} if {[S 0 == {PS-X\ EXE}]} {emit {Sony Playstation executable} if {[S 113 x {}]} {emit {\(%s\)}} } if {[S 0 == XBEH]} {emit {XBE, Microsoft Xbox executable} if {[Nx 2 i 4 == 0x0]} {if {[Nx 3 i [R 2] == 0x0]} {if {[N i [R 2] == 0x0]} {emit {\b, not signed}} } } if {[Nx 2 i 4 > 0x0]} {if {[Nx 3 i [R 2] > 0x0]} {if {[N i [R 2] > 0x0]} {emit {\b, signed}} } } if {[N i 260 == 0x10000]} {if {[N i [I 280 Q -65376] == 0x80000007 &0x80000007]} {emit {\b, all regions}} if {[N i [I 280 Q -65376] != 0x80000007 &0x80000007]} {if {[N i [I 280 Q -65376] > 0x0]} {emit {\(regions:} if {[N i [I 280 Q -65376] & 0x1]} {emit NA} if {[N i [I 280 Q -65376] & 0x2]} {emit Japan} if {[N i [I 280 Q -65376] & 0x4]} {emit Rest_of_World} if {[N i [I 280 Q -65376] & 0x80000000]} {emit Manufacturer} } if {[N i [I 280 Q -65376] > 0x0]} {emit {\b\)}} } } } if {[S 0 == XIP0]} {emit {XIP, Microsoft Xbox data}} if {[S 0 == XTF0]} {emit {XTF, Microsoft Xbox data}} if {[S 0 == Glul]} {emit {Glulx game data} if {[S 8 == IFRS]} {emit {\b, Blorb Interactive Fiction} if {[S 24 == Exec]} {emit {with executable chunk}} } if {[S 8 == IFZS]} {emit {\b, Z-machine or Glulx saved game file \(Quetzal\)}} } switch -- [Nv I 24] 60011 {emit {dump format, 4.1 BSD or earlier}} 60012 {emit {dump format, 4.2 or 4.3 BSD without IDC}} 60013 {emit {dump format, 4.2 or 4.3 BSD \(IDC compatible\)}} 60014 {emit {dump format, Convex Storage Manager by-reference dump}} 60012 {emit {new-fs dump file \(big endian\),} if {[N S 4 x {}]} {emit {Previous dump %s,}} if {[N S 8 x {}]} {emit {This dump %s,}} if {[N I 12 > 0x0]} {emit {Volume %ld,}} if {[N I 692 == 0x0]} {emit {Level zero, type:}} if {[N I 692 > 0x0]} {emit {Level %d, type:}} switch -- [Nv I 0] 1 {emit {tape header,}} 2 {emit {beginning of file record,}} 3 {emit {map of inodes on tape,}} 4 {emit {continuation of file record,}} 5 {emit {end of volume,}} 6 {emit {map of inodes deleted,}} 7 {emit {end of medium \(for floppy\),}} if {[S 676 x {}]} {emit {Label %s,}} if {[S 696 x {}]} {emit {Filesystem %s,}} if {[S 760 x {}]} {emit {Device %s,}} if {[S 824 x {}]} {emit {Host %s,}} if {[N I 888 > 0x0]} {emit {Flags %x}} } 60011 {emit {old-fs dump file \(big endian\),} if {[N I 12 > 0x0]} {emit {Volume %ld,}} if {[N I 692 == 0x0]} {emit {Level zero, type:}} if {[N I 692 > 0x0]} {emit {Level %d, type:}} switch -- [Nv I 0] 1 {emit {tape header,}} 2 {emit {beginning of file record,}} 3 {emit {map of inodes on tape,}} 4 {emit {continuation of file record,}} 5 {emit {end of volume,}} 6 {emit {map of inodes deleted,}} 7 {emit {end of medium \(for floppy\),}} if {[S 676 x {}]} {emit {Label %s,}} if {[S 696 x {}]} {emit {Filesystem %s,}} if {[S 760 x {}]} {emit {Device %s,}} if {[S 824 x {}]} {emit {Host %s,}} if {[N I 888 > 0x0]} {emit {Flags %x}} } if {[S 0 == !_TAG]} {emit {Exuberant Ctags tag file text}} if {[S 0 == GDBM]} {emit {GNU dbm 2.x database}} switch -- [Nv Q 12] 398689 {emit {Berkeley DB} if {[N Q 16 > 0x0]} {emit {\(Hash, version %d, native byte-order\)}} } 340322 {emit {Berkeley DB} if {[N Q 16 > 0x0]} {emit {\(Btree, version %d, native byte-order\)}} } 270931 {emit {Berkeley DB} if {[N Q 16 > 0x0]} {emit {\(Queue, version %d, native byte-order\)}} } 264584 {emit {Berkeley DB} if {[N Q 16 > 0x0]} {emit {\(Log, version %d, native byte-order\)}} } switch -- [Nv I 12] 398689 {emit {Berkeley DB} if {[N I 16 > 0x0]} {emit {\(Hash, version %d, big-endian\)}} } 340322 {emit {Berkeley DB} if {[N I 16 > 0x0]} {emit {\(Btree, version %d, big-endian\)}} } 270931 {emit {Berkeley DB} if {[N I 16 > 0x0]} {emit {\(Queue, version %d, big-endian\)}} } 264584 {emit {Berkeley DB} if {[N I 16 > 0x0]} {emit {\(Log, version %d, big-endian\)}} } switch -- [Nv i 12] 398689 {emit {Berkeley DB} if {[N i 16 > 0x0]} {emit {\(Hash, version %d, little-endian\)}} } 340322 {emit {Berkeley DB} if {[N i 16 > 0x0]} {emit {\(Btree, version %d, little-endian\)}} } 270931 {emit {Berkeley DB} if {[N i 16 > 0x0]} {emit {\(Queue, version %d, little-endian\)}} } 264584 {emit {Berkeley DB} if {[N i 16 > 0x0]} {emit {\(Log, version %d, little-endian\)}} } if {[S 0 == RRD]} {emit {RRDTool DB} if {[S 4 x {}]} {emit {version %s}} } if {[S 0 == {root\0}]} {emit {ROOT file} if {[N I 4 x {}]} {emit {Version %d}} if {[N I 33 x {}]} {emit {\(Compression: %d\)}} } if {[S 4 == {Standard\ Jet\ DB}]} {emit {Microsoft Access Database}} if {[S 0 == {TDB\ file}]} {emit {TDB database} if {[N i 32 == 0x2601196d]} {emit {version 6, little-endian} if {[N i 36 x {}]} {emit {hash size %d bytes}} } } if {[S 2 == ICE]} {emit {ICE authority data}} if {[S 10 == MIT-MAGIC-COOKIE-1]} {emit {X11 Xauthority data}} if {[S 11 == MIT-MAGIC-COOKIE-1]} {emit {X11 Xauthority data}} if {[S 12 == MIT-MAGIC-COOKIE-1]} {emit {X11 Xauthority data}} if {[S 13 == MIT-MAGIC-COOKIE-1]} {emit {X11 Xauthority data}} if {[S 14 == MIT-MAGIC-COOKIE-1]} {emit {X11 Xauthority data}} if {[S 15 == MIT-MAGIC-COOKIE-1]} {emit {X11 Xauthority data}} if {[S 16 == MIT-MAGIC-COOKIE-1]} {emit {X11 Xauthority data}} if {[S 17 == MIT-MAGIC-COOKIE-1]} {emit {X11 Xauthority data}} if {[S 18 == MIT-MAGIC-COOKIE-1]} {emit {X11 Xauthority data}} if {[S 0 == {\n\n________64E}]} {emit {Alpha archive} if {[S 22 == X]} {emit {-- out of date}} } if {[S 0 == {\377\377\177}]} {emit ddis/ddif} if {[S 0 == {\377\377\174}]} {emit {ddis/dots archive}} if {[S 0 == {\377\377\176}]} {emit {ddis/dtif table data}} if {[S 0 == {\033c\033}]} {emit {LN03 output}} if {[S 0 == {!!\n}]} {emit {profiling data file}} switch -- [Nv i 24] 60012 {emit {new-fs dump file \(little endian\),} if {[N s 4 x {}]} {emit {This dump %s,}} if {[N s 8 x {}]} {emit {Previous dump %s,}} if {[N i 12 > 0x0]} {emit {Volume %ld,}} if {[N i 692 == 0x0]} {emit {Level zero, type:}} if {[N i 692 > 0x0]} {emit {Level %d, type:}} switch -- [Nv i 0] 1 {emit {tape header,}} 2 {emit {beginning of file record,}} 3 {emit {map of inodes on tape,}} 4 {emit {continuation of file record,}} 5 {emit {end of volume,}} 6 {emit {map of inodes deleted,}} 7 {emit {end of medium \(for floppy\),}} if {[S 676 x {}]} {emit {Label %s,}} if {[S 696 x {}]} {emit {Filesystem %s,}} if {[S 760 x {}]} {emit {Device %s,}} if {[S 824 x {}]} {emit {Host %s,}} if {[N i 888 > 0x0]} {emit {Flags %x}} } 60011 {emit {old-fs dump file \(little endian\),} if {[N i 12 > 0x0]} {emit {Volume %ld,}} if {[N i 692 == 0x0]} {emit {Level zero, type:}} if {[N i 692 > 0x0]} {emit {Level %d, type:}} switch -- [Nv i 0] 1 {emit {tape header,}} 2 {emit {beginning of file record,}} 3 {emit {map of inodes on tape,}} 4 {emit {continuation of file record,}} 5 {emit {end of volume,}} 6 {emit {map of inodes deleted,}} 7 {emit {end of medium \(for floppy\),}} if {[S 676 x {}]} {emit {Label %s,}} if {[S 696 x {}]} {emit {Filesystem %s,}} if {[S 760 x {}]} {emit {Device %s,}} if {[S 824 x {}]} {emit {Host %s,}} if {[N i 888 > 0x0]} {emit {Flags %x}} } switch -- [Nv c 0] -86 {emit {} if {[N c 1 < 0x4]} {emit {Dyalog APL} switch -- [Nv c 1] 0 {emit {incomplete workspace}} 1 {emit {component file}} 2 {emit {external variable}} 3 {emit workspace} if {[N c 2 x {}]} {emit {version %d}} if {[N c 3 x {}]} {emit .%d} } } 3 {emit {DBase 3 data file} if {[N i 4 == 0x0]} {emit {\(no records\)}} if {[N i 4 > 0x0]} {emit {\(%ld records\)}} } -125 {emit {DBase 3 data file with memo\(s\)} if {[N i 4 == 0x0]} {emit {\(no records\)}} if {[N i 4 > 0x0]} {emit {\(%ld records\)}} } 38 {emit {Sendmail frozen configuration} if {[S 16 x {}]} {emit {- version %s}} } -16 {emit {SysEx File -} switch -- [Nv c 1] 1 {emit Sequential} 2 {emit IDP} 3 {emit OctavePlateau} 4 {emit Moog} 5 {emit Passport} 6 {emit Lexicon} 7 {emit Kurzweil} 8 {emit Fender} 9 {emit Gulbransen} 10 {emit AKG} 11 {emit Voyce} 12 {emit Waveframe} 13 {emit ADA} 14 {emit Garfield} 15 {emit Ensoniq} 16 {emit Oberheim} 17 {emit Apple} 18 {emit GreyMatter} 20 {emit PalmTree} 21 {emit JLCooper} 22 {emit Lowrey} 23 {emit AdamsSmith} 24 {emit E-mu} 25 {emit Harmony} 26 {emit ART} 27 {emit Baldwin} 28 {emit Eventide} 29 {emit Inventronics} 31 {emit Clarity} 33 {emit SIEL} 34 {emit Synthaxe} 36 {emit Hohner} 37 {emit Twister} 38 {emit Solton} 39 {emit Jellinghaus} 40 {emit Southworth} 41 {emit PPG} 42 {emit JEN} 43 {emit SSL} 44 {emit AudioVertrieb} 47 {emit ELKA if {[N c 3 == 0x9]} {emit EK-44} } 48 {emit Dynacord} 51 {emit Clavia} 57 {emit Soundcraft} 62 {emit Waldorf if {[N c 3 == 0x7f]} {emit {Microwave I}} } 64 {emit Kawai switch -- [Nv c 3] 32 {emit K1} 34 {emit K4} } 65 {emit Roland switch -- [Nv c 3] 20 {emit D-50} 43 {emit U-220} 2 {emit TR-707} } 66 {emit Korg if {[N c 3 == 0x19]} {emit M1} } 67 {emit Yamaha} 68 {emit Casio} 70 {emit Kamiya} 71 {emit Akai} 72 {emit Victor} 73 {emit Mesosha} 75 {emit Fujitsu} 76 {emit Sony} 78 {emit Teac} 80 {emit Matsushita} 81 {emit Fostex} 82 {emit Zoom} 84 {emit Matsushita} 87 {emit {Acoustic tech. lab.}} switch -- [Nv I 1 &0xffffff00] 29696 {emit {Ta Horng}} 29952 {emit e-Tek} 30208 {emit E-Voice} 30464 {emit Midisoft} 30720 {emit Q-Sound} 30976 {emit Westrex} 31232 {emit Nvidia*} 31488 {emit ESS} 31744 {emit Mediatrix} 32000 {emit Brooktree} 32256 {emit Otari} 32512 {emit {Key Electronics}} 65536 {emit Shure} 65792 {emit AuraSound} 66048 {emit Crystal} 66304 {emit Rockwell} 66560 {emit {Silicon Graphics}} 66816 {emit Midiman} 67072 {emit PreSonus} 67584 {emit Topaz} 67840 {emit {Cast Lightning}} 68096 {emit Microsoft} 68352 {emit {Sonic Foundry}} 68608 {emit {Line 6}} 68864 {emit {Beatnik Inc.}} 69120 {emit {Van Koerving}} 69376 {emit {Altech Systems}} 69632 {emit {S & S Research}} 69888 {emit {VLSI Technology}} 70144 {emit Chromatic} 70400 {emit Sapphire} 70656 {emit IDRC} 70912 {emit {Justonic Tuning}} 71168 {emit TorComp} 71424 {emit {Newtek Inc.}} 71680 {emit {Sound Sculpture}} 71936 {emit {Walker Technical}} 72192 {emit {Digital Harmony}} 72448 {emit InVision} 72704 {emit T-Square} 72960 {emit Nemesys} 73216 {emit DBX} 73472 {emit Syndyne} 73728 {emit {Bitheadz }} 73984 {emit Cakewalk} 74240 {emit Staccato} 74496 {emit {National Semicon.}} 74752 {emit {Boom Theory}} 75008 {emit {Virtual DSP Corp}} 75264 {emit Antares} 75520 {emit {Angel Software}} 75776 {emit {St Louis Music}} 76032 {emit {Lyrrus dba G-VOX}} 76288 {emit {Ashley Audio}} 76544 {emit Vari-Lite} 76800 {emit {Summit Audio}} 77056 {emit {Aureal Semicon.}} 77312 {emit SeaSound} 77568 {emit {U.S. Robotics}} 77824 {emit Aurisis} 78080 {emit {Nearfield Multimedia}} 78336 {emit {FM7 Inc.}} 78592 {emit {Swivel Systems}} 78848 {emit Hyperactive} 79104 {emit MidiLite} 79360 {emit Radical} 79616 {emit {Roger Linn}} 79872 {emit Helicon} 80128 {emit Event} 80384 {emit {Sonic Network}} 80640 {emit {Realtime Music}} 80896 {emit {Apogee Digital}} 2108160 {emit {Medeli Electronics}} 2108416 {emit {Charlie Lab}} 2108672 {emit {Blue Chip Music}} 2108928 {emit {BEE OH Corp}} 2109184 {emit {LG Semicon America}} 2109440 {emit TESI} 2109696 {emit EMAGIC} 2109952 {emit Behringer} 2110208 {emit {Access Music}} 2110464 {emit Synoptic} 2110720 {emit {Hanmesoft Corp}} 2110976 {emit Terratec} 2111232 {emit {Proel SpA}} 2111488 {emit {IBK MIDI}} 2111744 {emit IRCAM} 2112000 {emit {Propellerhead Software}} 2112256 {emit {Red Sound Systems}} 2112512 {emit {Electron ESI AB}} 2112768 {emit {Sintefex Audio}} 2113024 {emit {Music and More}} 2113280 {emit Amsaro} 2113536 {emit {CDS Advanced Technology}} 2113792 {emit {Touched by Sound}} 2114048 {emit {DSP Arts}} 2114304 {emit {Phil Rees Music}} 2114560 {emit {Stamer Musikanlagen GmbH}} 2114816 {emit Soundart} 2115072 {emit {C-Mexx Software}} 2115328 {emit {Klavis Tech.}} 2115584 {emit {Noteheads AB}} } -128 {emit {8086 relocatable \(Microsoft\)}} if {[S 0 == {@CT\ }]} {emit {T602 document data,} if {[S 4 == 0]} {emit Kamenicky} if {[S 4 == 1]} {emit {CP 852}} if {[S 4 == 2]} {emit KOI8-CS} if {[S 4 > 2]} {emit {unknown encoding}} } if {[S 0 == VimCrypt~]} {emit {Vim encrypted file data}} if {[S 0 == {\177ELF}]} {emit ELF switch -- [Nv c 4] 0 {emit {invalid class}} 1 {emit 32-bit switch -- [Nv s 18] 8 {emit {} if {[N i 36 & 0x20]} {emit N32} } 10 {emit {} if {[N i 36 & 0x20]} {emit N32} } switch -- [Nv S 18] 8 {emit {} if {[N I 36 & 0x20]} {emit N32} } 10 {emit {} if {[N I 36 & 0x20]} {emit N32} } } 2 {emit 64-bit} switch -- [Nv c 5] 0 {emit {invalid byte order}} 1 {emit LSB switch -- [Nv s 18] 8 {emit {} switch -- [Nv c 4] 1 {emit {} switch -- [Nv i 36 &0xf0000000] 0 {emit MIPS-I} 268435456 {emit MIPS-II} 536870912 {emit MIPS-III} 805306368 {emit MIPS-IV} 1073741824 {emit MIPS-V} 1610612736 {emit MIPS32} 1879048192 {emit MIPS64} -2147483648 {emit {MIPS32 rel2}} -1879048192 {emit {MIPS64 rel2}} } 2 {emit {} switch -- [Nv i 48 &0xf0000000] 0 {emit MIPS-I} 268435456 {emit MIPS-II} 536870912 {emit MIPS-III} 805306368 {emit MIPS-IV} 1073741824 {emit MIPS-V} 1610612736 {emit MIPS32} 1879048192 {emit MIPS64} -2147483648 {emit {MIPS32 rel2}} -1879048192 {emit {MIPS64 rel2}} } } 0 {emit {no machine,}} 1 {emit {AT&T WE32100 - invalid byte order,}} 2 {emit {SPARC - invalid byte order,}} 3 {emit {Intel 80386,}} 4 {emit Motorola if {[N i 36 & 0x1000000]} {emit {68000 - invalid byte order,}} if {[N i 36 & 0x810000]} {emit {CPU32 - invalid byte order,}} if {[N i 36 == 0x0]} {emit {68020 - invalid byte order,}} } 5 {emit {Motorola 88000 - invalid byte order,}} 6 {emit {Intel 80486,}} 7 {emit {Intel 80860,}} 8 {emit MIPS,} 9 {emit {Amdahl - invalid byte order,}} 10 {emit {MIPS \(deprecated\),}} 11 {emit {RS6000 - invalid byte order,}} 15 {emit {PA-RISC - invalid byte order,} if {[N s 50 == 0x214]} {emit 2.0} if {[N s 48 & 0x8]} {emit {\(LP64\),}} } 16 {emit nCUBE,} 17 {emit {Fujitsu VPP500,}} 18 {emit SPARC32PLUS,} 20 {emit PowerPC,} 22 {emit {IBM S/390,}} 36 {emit {NEC V800,}} 37 {emit {Fujitsu FR20,}} 38 {emit {TRW RH-32,}} 39 {emit {Motorola RCE,}} 40 {emit ARM,} 41 {emit Alpha,} -23664 {emit {IBM S/390 \(obsolete\),}} 42 {emit {Hitachi SH,}} 43 {emit {SPARC V9 - invalid byte order,}} 44 {emit {Siemens Tricore Embedded Processor,}} 45 {emit {Argonaut RISC Core, Argonaut Technologies Inc.,}} 46 {emit {Hitachi H8/300,}} 47 {emit {Hitachi H8/300H,}} 48 {emit {Hitachi H8S,}} 49 {emit {Hitachi H8/500,}} 50 {emit {IA-64 \(Intel 64 bit architecture\)}} 51 {emit {Stanford MIPS-X,}} 52 {emit {Motorola Coldfire,}} 53 {emit {Motorola M68HC12,}} 62 {emit {AMD x86-64,}} 75 {emit {Digital VAX,}} 88 {emit {Renesas M32R,}} 97 {emit {NatSemi 32k,}} -28634 {emit {Alpha \(unofficial\),}} switch -- [Nv s 16] 0 {emit {no file type,}} 1 {emit relocatable,} 2 {emit executable,} 3 {emit {shared object,}} 4 {emit {core file}} if {[N s 16 & 0xff00]} {emit processor-specific,} switch -- [Nv i 20] 0 {emit {invalid version}} 1 {emit {version 1}} if {[N i 36 == 0x1]} {emit {MathCoPro/FPU/MAU Required}} } 2 {emit MSB switch -- [Nv S 18] 8 {emit {} switch -- [Nv c 4] 1 {emit {} switch -- [Nv I 36 &0xf0000000] 0 {emit MIPS-I} 268435456 {emit MIPS-II} 536870912 {emit MIPS-III} 805306368 {emit MIPS-IV} 1073741824 {emit MIPS-V} 1610612736 {emit MIPS32} 1879048192 {emit MIPS64} -2147483648 {emit {MIPS32 rel2}} -1879048192 {emit {MIPS64 rel2}} } 2 {emit {} switch -- [Nv I 48 &0xf0000000] 0 {emit MIPS-I} 268435456 {emit MIPS-II} 536870912 {emit MIPS-III} 805306368 {emit MIPS-IV} 1073741824 {emit MIPS-V} 1610612736 {emit MIPS32} 1879048192 {emit MIPS64} -2147483648 {emit {MIPS32 rel2}} -1879048192 {emit {MIPS64 rel2}} } } 0 {emit {no machine,}} 1 {emit {AT&T WE32100,}} 2 {emit SPARC,} 3 {emit {Intel 80386 - invalid byte order,}} 4 {emit Motorola if {[N I 36 & 0x1000000]} {emit 68000,} if {[N I 36 & 0x810000]} {emit CPU32,} if {[N I 36 == 0x0]} {emit 68020,} } 5 {emit {Motorola 88000,}} 6 {emit {Intel 80486 - invalid byte order,}} 7 {emit {Intel 80860,}} 8 {emit MIPS,} 9 {emit Amdahl,} 10 {emit {MIPS \(deprecated\),}} 11 {emit RS6000,} 15 {emit PA-RISC if {[N S 50 == 0x214]} {emit 2.0} if {[N S 48 & 0x8]} {emit {\(LP64\)}} } 16 {emit nCUBE,} 17 {emit {Fujitsu VPP500,}} 18 {emit SPARC32PLUS, if {[N I 36 & 0x100 &0xffff00]} {emit {V8+ Required,}} if {[N I 36 & 0x200 &0xffff00]} {emit {Sun UltraSPARC1 Extensions Required,}} if {[N I 36 & 0x400 &0xffff00]} {emit {HaL R1 Extensions Required,}} if {[N I 36 & 0x800 &0xffff00]} {emit {Sun UltraSPARC3 Extensions Required,}} } 20 {emit {PowerPC or cisco 4500,}} 21 {emit {cisco 7500,}} 22 {emit {IBM S/390,}} 24 {emit {cisco SVIP,}} 25 {emit {cisco 7200,}} 36 {emit {NEC V800 or cisco 12000,}} 37 {emit {Fujitsu FR20,}} 38 {emit {TRW RH-32,}} 39 {emit {Motorola RCE,}} 40 {emit ARM,} 41 {emit Alpha,} 42 {emit {Hitachi SH,}} 43 {emit {SPARC V9,}} 44 {emit {Siemens Tricore Embedded Processor,}} 45 {emit {Argonaut RISC Core, Argonaut Technologies Inc.,}} 46 {emit {Hitachi H8/300,}} 47 {emit {Hitachi H8/300H,}} 48 {emit {Hitachi H8S,}} 49 {emit {Hitachi H8/500,}} 50 {emit {Intel Merced Processor,}} 51 {emit {Stanford MIPS-X,}} 52 {emit {Motorola Coldfire,}} 53 {emit {Motorola M68HC12,}} 73 {emit {Cray NV1,}} 75 {emit {Digital VAX,}} 88 {emit {Renesas M32R,}} 97 {emit {NatSemi 32k,}} -28634 {emit {Alpha \(unofficial\),}} -23664 {emit {IBM S/390 \(obsolete\),}} switch -- [Nv S 16] 0 {emit {no file type,}} 1 {emit relocatable,} 2 {emit executable,} 3 {emit {shared object,}} 4 {emit {core file,}} if {[N S 16 & 0xff00]} {emit processor-specific,} switch -- [Nv I 20] 0 {emit {invalid version}} 1 {emit {version 1}} if {[N I 36 == 0x1]} {emit {MathCoPro/FPU/MAU Required}} } if {[N c 4 < 0x80]} {if {[S 8 x {}]} {emit {\(%s\)}} } if {[S 8 == {\0}]} {switch -- [Nv c 7] 0 {emit {\(SYSV\)}} 1 {emit {\(HP-UX\)}} 2 {emit {\(NetBSD\)}} 3 {emit {\(GNU/Linux\)}} 4 {emit {\(GNU/Hurd\)}} 5 {emit {\(86Open\)}} 6 {emit {\(Solaris\)}} 7 {emit {\(Monterey\)}} 8 {emit {\(IRIX\)}} 9 {emit {\(FreeBSD\)}} 10 {emit {\(Tru64\)}} 11 {emit {\(Novell Modesto\)}} 12 {emit {\(OpenBSD\)}} 97 {emit {\(ARM\)}} -1 {emit {\(embedded\)}} } } if {[N i 4 == 0x1000006d]} {emit {{7 lelong {} == 8 0x1000007f Word} {8 lelong {} == 8 0x10000088 Sheet} {9 lelong {} == 8 0x1000007d Sketch} {10 lelong {} == 8 0x10000085 TextEd}}} if {[S 0 == FCS1.0]} {emit {Flow Cytometry Standard \(FCS\) data, version 1.0}} if {[S 0 == FCS2.0]} {emit {Flow Cytometry Standard \(FCS\) data, version 2.0}} if {[S 0 == FCS3.0]} {emit {Flow Cytometry Standard \(FCS\) data, version 3.0}} if {[S 0 == {\366\366\366\366}]} {emit {PC formatted floppy with no filesystem}} if {[N S 508 == 0xdabe]} {emit {Sun disk label} if {[S 0 x {}]} {emit '%s if {[S 31 x {}]} {emit {\b%s} if {[S 63 x {}]} {emit {\b%s} if {[S 95 x {}]} {emit {\b%s}} } } } if {[S 0 x {}]} {emit {\b'}} if {[N Y 476 > 0x0]} {emit {%d rpm,}} if {[N Y 478 > 0x0]} {emit {%d phys cys,}} if {[N Y 480 > 0x0]} {emit {%d alts/cyl,}} if {[N Y 486 > 0x0]} {emit {%d interleave,}} if {[N Y 488 > 0x0]} {emit {%d data cyls,}} if {[N Y 490 > 0x0]} {emit {%d alt cyls,}} if {[N Y 492 > 0x0]} {emit {%d heads/partition,}} if {[N Y 494 > 0x0]} {emit {%d sectors/track,}} if {[N Q 500 > 0x0]} {emit {start cyl %ld,}} if {[N Q 504 x {}]} {emit {%ld blocks}} if {[N I 512 == 0x30107 &077777777]} {emit {\b, boot block present}} } if {[S 0 == {DOSEMU\0}]} {if {[N s 638 == 0xaa55]} {emit {DOS Emulator image}} } if {[N s 510 == 0xaa55]} {emit {x86 boot sector} if {[S 2 == OSBS]} {emit {\b, OS/BS MBR}} if {[S 140 == {Invalid\ partition\ table}]} {emit {\b, MS-DOS MBR}} if {[S 157 == {Invalid\ partition\ table$}]} {if {[S 181 == {No\ Operating\ System$}]} {if {[S 201 == {Operating\ System\ load\ error$}]} {emit {\b, DR-DOS MBR, Version 7.01 to 7.03}} } } if {[S 157 == {Invalid\ partition\ table$}]} {if {[S 181 == {No\ operating\ system$}]} {if {[S 201 == {Operating\ system\ load\ error$}]} {emit {\b, DR-DOS MBR, Version 7.01 to 7.03}} } } if {[S 342 == {Invalid\ partition\ table$}]} {if {[S 366 == {No\ operating\ system$}]} {if {[S 386 == {Operating\ system\ load\ error$}]} {emit {\b, DR-DOS MBR, version 7.01 to 7.03}} } } if {[S 295 == {NEWLDR\0}]} {if {[S 302 == {Bad\ PT\ $}]} {if {[S 310 == {No\ OS\ $}]} {if {[S 317 == {OS\ load\ err$}]} {if {[S 329 == {Moved\ or\ missing\ IBMBIO.LDR\n\r}]} {if {[S 358 == {Press\ any\ key\ to\ continue.\n\r$}]} {if {[S 387 == {Copyright\ (c)\ 1984,1998}]} {if {[S 411 == {Caldera\ Inc.\0}]} {emit {\b, DR-DOS MBR \(IBMBIO.LDR\)}} } } } } } } } if {[S 271 == {Ung\201ltige\ Partitionstabelle}]} {emit {\b, MS-DOS MBR, german version 4.10.1998, 4.10.2222}} if {[S 139 == {Ung\201ltige\ Partitionstabelle}]} {emit {\b, MS-DOS MBR, german version 5.00 to 4.00.950}} if {[S 300 == {Invalid\ partition\ table\0}]} {if {[S 324 == {Error\ loading\ operating\ system\0}]} {if {[S 355 == {Missing\ operating\ system\0}]} {emit {\b, Microsoft Windows XP MBR}} } } if {[S 300 == {Ung\201ltige\ Partitionstabelle}]} {if {[S 328 == {Fehler\ beim\ Laden\ }]} {if {[S 346 == {des\ Betriebssystems}]} {if {[S 366 == {Betriebssystem\ nicht\ vorhanden}]} {emit {\b, Microsoft Windows XP MBR \(german\)}} } } } if {[S 325 == {Default:\ F}]} {emit {\b, FREE-DOS MBR}} if {[S 64 == {no\ active\ partition\ found}]} {if {[S 96 == {read\ error\ while\ reading\ drive}]} {emit {\b, FREE-DOS Beta9 MBR}} } if {[S 43 == {SMART\ BTMGRFAT12\ \ \ }]} {if {[S 430 == {SBMK\ Bad!\r}]} {if {[S 3 == SBM]} {emit {\b, Smart Boot Manager} if {[S 6 x {}]} {emit {\b, version %s}} } } } if {[S 382 == XOSLLOADXCF]} {emit {\b, EXtended Operating System Loader}} if {[S 6 == LILO]} {emit {\b, LInux i386 boot LOader} if {[S 120 == LILO]} {emit {\b, version 22.3.4 SuSe}} if {[S 172 == LILO]} {emit {\b, version 22.5.8 Debian}} } if {[S 402 == {Geom\0Hard\ Disk\0Read\0\ Error\0}]} {if {[S 394 == stage1]} {emit {\b, GRand Unified Bootloader \(0.5.95\)}} } if {[S 380 == {Geom\0Hard\ Disk\0Read\0\ Error\0}]} {if {[S 374 == {GRUB\ \0}]} {emit {\b, GRand Unified Bootloader}} } if {[S 382 == {Geom\0Hard\ Disk\0Read\0\ Error\0}]} {if {[S 376 == {GRUB\ \0}]} {emit {\b, GRand Unified Bootloader \(0.93\)}} } if {[S 383 == {Geom\0Hard\ Disk\0Read\0\ Error\0}]} {if {[S 377 == {GRUB\ \0}]} {emit {\b, GRand Unified Bootloader \(0.94\)}} } if {[S 480 == {Boot\ failed\r}]} {if {[S 495 == {LDLINUX\ SYS}]} {emit {\b, SYSLINUX bootloader \(2.06\)}} } if {[S 395 == {chksum\0\ ERROR!\0}]} {emit {\b, Gujin bootloader}} if {[S 185 == {FDBOOT\ Version\ }]} {if {[S 204 == {\rNo\ Systemdisk.\ }]} {if {[S 220 == {Booting\ from\ harddisk.\n\r}]} {emit 349 21 0 0} if {[S 245 == {Cannot\ load\ from\ harddisk.\n\r}]} {if {[S 273 == {Insert\ Systemdisk\ }]} {if {[S 291 == {and\ press\ any\ key.\n\r}]} {emit {\b, FDBOOT harddisk Bootloader} if {[S 200 x {}]} {emit {\b, version %-3s}} } } } } } if {[S 242 == {Bootsector\ from\ C.H.\ Hochst\204}]} {if {[S 278 == {No\ Systemdisk.\ }]} {if {[S 293 == {Booting\ from\ harddisk.\n\r}]} {emit 349 22 0 0} if {[S 441 == {Cannot\ load\ from\ harddisk.\n\r}]} {if {[S 469 == {Insert\ Systemdisk\ }]} {if {[S 487 == {and\ press\ any\ key.\n\r}]} {emit {\b, WinImage harddisk Bootloader} if {[S 209 x {}]} {emit {\b, version %-4.4s}} } } } } } if {[N c [I 1 c 2] == 0xe]} {if {[N c [I 1 c 3] == 0x1f]} {if {[N c [I 1 c 4] == 0xbe]} {if {[N c [I 1 c 5] == 0x77]} {emit 349 23 0 0 0} if {[N c [I 1 c 6] == 0x7c]} {if {[N c [I 1 c 7] == 0xac]} {if {[N c [I 1 c 8] == 0x22]} {if {[N c [I 1 c 9] == 0xc0]} {if {[N c [I 1 c 10] == 0x74]} {if {[N c [I 1 c 11] == 0xb]} {if {[N c [I 1 c 12] == 0x56]} {emit 349 23 0 0 1 0 0 0 0 0 0} if {[N c [I 1 c 13] == 0xb4]} {emit {\b, mkdosfs boot message display}} } } } } } } } } } if {[S 430 == {NTLDR\ is\ missing\xFF\r\n}]} {if {[S 449 == {Disk\ error\xFF\r\n}]} {if {[S 462 == {Press\ any\ key\ to\ restart\r}]} {emit {\b, Microsoft Windows XP Bootloader} if {[N c 417 < 0x7e]} {if {[S 417 > {\ }]} {emit %-.5s if {[N c 422 < 0x7e]} {if {[S 422 > {\ }]} {emit {\b%-.3s}} } if {[S 425 > {\ }]} {emit {\b.%-.3s}} } } if {[N c 368 < 0x7e]} {if {[S 368 > {\ }]} {emit %-.5s if {[N c 373 < 0x7e]} {if {[S 373 > {\ }]} {emit {\b%-.3s}} } if {[S 376 > {\ }]} {emit {\b.%-.3s}} } } } } } if {[S 430 == {NTLDR\ nicht\ gefunden\xFF\r\n}]} {if {[S 453 == {Datentr\204gerfehler\xFF\r\n}]} {if {[S 473 == {Neustart\ mit\ beliebiger\ Taste\r}]} {emit {\b, Microsoft Windows XP Bootloader \(german\)} if {[N c 417 < 0x7e]} {if {[S 417 > {\ }]} {emit %-.5s if {[N c 422 < 0x7e]} {if {[S 422 > {\ }]} {emit {\b%-.3s}} } if {[S 425 > {\ }]} {emit {\b.%-.3s}} } } if {[N c 368 < 0x7e]} {if {[S 368 > {\ }]} {emit %-.5s if {[N c 373 < 0x7e]} {if {[S 373 > {\ }]} {emit {\b%-.3s}} } if {[S 376 > {\ }]} {emit {\b.%-.3s}} } } } } } if {[S 430 == {NTLDR\ fehlt\xFF\r\n}]} {if {[S 444 == {Datentr\204gerfehler\xFF\r\n}]} {if {[S 464 == {Neustart\ mit\ beliebiger\ Taste\r}]} {emit {\b, Microsoft Windows XP Bootloader \(2.german\)} if {[N c 417 < 0x7e]} {if {[S 417 > {\ }]} {emit %-.5s if {[N c 422 < 0x7e]} {if {[S 422 > {\ }]} {emit {\b%-.3s}} } if {[S 425 > {\ }]} {emit {\b.%-.3s}} } } } } } if {[S 430 == {NTLDR\ fehlt\xFF\r\n}]} {if {[S 444 == {Medienfehler\xFF\r\n}]} {if {[S 459 == {Neustart:\ Taste\ dr\201cken\r}]} {emit {\b, Microsoft Windows XP Bootloader \(3.german\)} if {[N c 368 < 0x7e]} {if {[S 368 > {\ }]} {emit %-.5s if {[N c 373 < 0x7e]} {if {[S 373 > {\ }]} {emit {\b%-.3s}} } if {[S 376 > {\ }]} {emit {\b.%-.3s}} } } if {[N c 417 < 0x7e]} {if {[S 417 > {\ }]} {emit %-.5s if {[N c 422 < 0x7e]} {if {[S 422 > {\ }]} {emit {\b%-.3s}} } if {[S 425 > {\ }]} {emit {\b.%-.3s}} } } } } } if {[S 430 == {Datentr\204ger\ entfernen\xFF\r\n}]} {if {[S 454 == {Medienfehler\xFF\r\n}]} {if {[S 469 == {Neustart:\ Taste\ dr\201cken\r}]} {emit {\b, Microsoft Windows XP Bootloader \(4.german\)} if {[N c 368 < 0x7e]} {if {[S 368 > {\ }]} {emit %-.5s if {[N c 373 < 0x7e]} {if {[S 373 > {\ }]} {emit {\b%-.3s}} } if {[S 376 > {\ }]} {emit {\b.%-.3s}} } } } } } if {[S 389 == {Fehler\ beim\ Lesen\ }]} {if {[S 407 == {des\ Datentr\204gers}]} {if {[S 426 == {NTLDR\ fehlt}]} {if {[S 440 == {NTLDR\ ist\ komprimiert}]} {if {[S 464 == {Neustart\ mit\ Strg+Alt+Entf\r}]} {emit {\b, Microsoft Windows XP Bootloader NTFS \(german\)}} } } } } if {[S 313 == {A\ disk\ read\ error\ occurred.\r}]} {if {[S 345 == {A\ kernel\ file\ is\ missing\ }]} {if {[S 370 == {from\ the\ disk.\r}]} {if {[S 484 == {NTLDR\ is\ compressed}]} {if {[S 429 == {Insert\ a\ system\ diskette\ }]} {if {[S 454 == {and\ restart\r\nthe\ system.\r}]} {emit {\b, Microsoft Windows XP Bootloader NTFS}} } } } } } if {[S 472 == {IO\ \ \ \ \ \ SYSMSDOS\ \ \ SYS}]} {if {[S 497 == {WINBOOT\ SYS}]} {emit 349 31 0} if {[S 389 == {Invalid\ system\ disk\xFF\r\n}]} {if {[S 411 == {Disk\ I/O\ error}]} {if {[S 428 == {Replace\ the\ disk,\ and\ }]} {if {[S 455 == {press\ any\ key}]} {emit {\b, Microsoft Windows 98 Bootloader}} } } } if {[S 390 == {Invalid\ system\ disk\xFF\r\n}]} {if {[S 412 == {Disk\ I/O\ error\xFF\r\n}]} {if {[S 429 == {Replace\ the\ disk,\ and\ }]} {if {[S 451 == {then\ press\ any\ key\r}]} {emit {\b, Microsoft Windows 98 Bootloader}} } } } if {[S 388 == {Ungueltiges\ System\ \xFF\r\n}]} {if {[S 410 == {E/A-Fehler\ \ \ \ \xFF\r\n}]} {if {[S 427 == {Datentraeger\ wechseln\ und\ }]} {if {[S 453 == {Taste\ druecken\r}]} {emit {\b, Microsoft Windows 95/98/ME Bootloader \(german\)}} } } } if {[S 390 == {Ungueltiges\ System\ \xFF\r\n}]} {if {[S 412 == {E/A-Fehler\ \ \ \ \xFF\r\n}]} {if {[S 429 == {Datentraeger\ wechseln\ und\ }]} {if {[S 455 == {Taste\ druecken\r}]} {emit {\b, Microsoft Windows 95/98/ME Bootloader \(German\)}} } } } if {[S 389 == {Ungueltiges\ System\ \xFF\r\n}]} {if {[S 411 == {E/A-Fehler\ \ \ \ \xFF\r\n}]} {if {[S 428 == {Datentraeger\ wechseln\ und\ }]} {if {[S 454 == {Taste\ druecken\r}]} {emit {\b, Microsoft Windows 95/98/ME Bootloader \(GERMAN\)}} } } } } if {[S 479 == {IO\ \ \ \ \ \ SYSMSDOS\ \ \ SYS}]} {if {[S 416 == {Kein\ System\ oder\ }]} {if {[S 433 == Laufwerksfehler]} {if {[S 450 == {Wechseln\ und\ Taste\ dr\201cken}]} {emit {\b, Microsoft DOS Bootloader \(german\)}} } } } if {[S 486 == {IO\ \ \ \ \ \ SYSMSDOS\ \ \ SYS}]} {if {[S 416 == {Non-System\ disk\ or\ }]} {if {[S 435 == {disk\ error\r}]} {if {[S 447 == {Replace\ and\ press\ any\ key\ }]} {if {[S 473 == {when\ ready\r}]} {emit {\b, Microsoft DOS Bootloader}} } } } } if {[S 480 == {IO\ \ \ \ \ \ SYSMSDOS\ \ \ SYS}]} {if {[S 393 == {Non-System\ disk\ or\ }]} {if {[S 412 == {disk\ error\r}]} {if {[S 424 == {Replace\ and\ press\ any\ key\ }]} {if {[S 450 == {when\ ready\r}]} {emit {\b, Microsoft DOS bootloader}} } } } } if {[S 54 == SYS]} {if {[S 324 == VASKK]} {if {[S 495 == {NEWLDR\0}]} {emit {\b, DR-DOS Bootloader \(LOADER.SYS\)}} } } if {[S 70 == {IBMBIO\ \ COM}]} {if {[S 472 == {Cannot\ load\ DOS!\ }]} {if {[S 489 == {Any\ key\ to\ retry}]} {emit {\b, DR-DOS Bootloader}} } if {[S 471 == {Cannot\ load\ DOS\ }]} {emit 349 36 1} if {[S 487 == {press\ key\ to\ retry}]} {emit {\b, Open-DOS Bootloader}} } if {[S 444 == {KERNEL\ \ SYS}]} {if {[S 314 == {BOOT\ error!}]} {emit {\b, FREE-DOS Bootloader}} } if {[S 499 == {KERNEL\ \ SYS}]} {if {[S 305 == {BOOT\ err!\0}]} {emit {\b, Free-DOS Bootloader}} } if {[S 449 == {KERNEL\ \ SYS}]} {if {[S 319 == {BOOT\ error!}]} {emit {\b, FREE-DOS 5.0 Bootloader}} } if {[S 124 == {FreeDOS\0}]} {if {[S 331 == {\ err\0}]} {emit {\b, FREE-DOS BETa 9 Bootloader} if {[S 497 > {\ }]} {emit %-.6s if {[S 503 > {\ }]} {emit {\b%-.1s}} if {[S 504 > {\ }]} {emit {\b%-.1s}} } if {[S 505 > {\ }]} {emit {\b.%-.3s}} } if {[S 333 == {\ err\0}]} {emit {\b, FREE-DOS BEta 9 Bootloader} if {[S 497 > {\ }]} {emit %-.6s if {[S 503 > {\ }]} {emit {\b%-.1s}} if {[S 504 > {\ }]} {emit {\b%-.1s}} } if {[S 505 > {\ }]} {emit {\b.%-.3s}} } if {[S 334 == {\ err\0}]} {emit {\b, FREE-DOS Beta 9 Bootloader} if {[S 497 > {\ }]} {emit %-.6s if {[S 503 > {\ }]} {emit {\b%-.1s}} if {[S 504 > {\ }]} {emit {\b%-.1s}} } if {[S 505 > {\ }]} {emit {\b.%-.3s}} } } if {[S 0 == {\0\0\0\0}]} {emit {\b, extended partition table}} if {[N i 0 == 0x9000eb &0x009000EB]} {emit 349 42} if {[N i 0 == 0xe9 &0x000000E9]} {if {[N c 1 > 0x25]} {emit {\b, code offset 0x%x} if {[N s 11 < 0x801]} {if {[N s 11 > 0x1f]} {if {[S 3 x {}]} {emit {\b, OEM-ID \"%8.8s\"}} if {[N s 11 > 0x200]} {emit {\b, Bytes/sector %u}} if {[N s 11 < 0x200]} {emit {\b, Bytes/sector %u}} if {[N c 13 > 0x1]} {emit {\b, sectors/cluster %u}} if {[N s 14 > 0x20]} {emit {\b, reserved sectors %u}} if {[N s 14 < 0x1]} {emit {\b, reserved sectors %u}} if {[N c 16 > 0x2]} {emit {\b, FATs %u}} if {[N c 16 == 0x1]} {emit {\b, FAT %u}} if {[N c 16 > 0x0]} {emit 349 43 0 0 0 8} if {[N s 17 > 0x0]} {emit {\b, root entries %u}} if {[N s 19 > 0x0]} {emit {\b, sectors %u \(volumes <=32 MB\)}} if {[N c 21 > 0xf0]} {emit {\b, Media descriptor 0x%x}} if {[N c 21 < 0xf0]} {emit {\b, Media descriptor 0x%x}} if {[N s 22 > 0x0]} {emit {\b, sectors/FAT %u}} if {[N c 26 > 0x2]} {emit {\b, heads %u}} if {[N c 26 == 0x1]} {emit {\b, heads %u}} if {[N i 28 > 0x0]} {emit {\b, hidden sectors %u}} if {[N i 32 > 0x0]} {emit {\b, sectors %u \(volumes > 32 MB\)}} if {[N i 82 > 0x0 &0xCCABBEB9]} {if {[N c 36 > 0x80]} {emit {\b, physical drive 0x%x}} if {[N c 36 > 0x0 &0x7F]} {emit {\b, physical drive 0x%x}} if {[N c 37 > 0x0]} {emit {\b, reserved 0x%x}} if {[N c 38 > 0x29]} {emit {\b, dos < 4.0 BootSector \(0x%x\)}} if {[N c 38 < 0x29]} {emit {\b, dos < 4.0 BootSector \(0x%x\)}} if {[N c 38 == 0x29]} {if {[N i 39 x {}]} {emit {\b, serial number 0x%x}} if {[S 43 < {NO\ NAME}]} {emit {\b, label: \"%11.11s\"}} if {[S 43 > {NO\ NAME}]} {emit {\b, label: \"%11.11s\"}} if {[S 43 == {NO\ NAME}]} {emit {\b, unlabeled}} } if {[S 54 == FAT1]} {emit {\b, FAT} if {[S 54 == FAT12]} {emit {\b \(12 bit\)}} if {[S 54 == FAT16]} {emit {\b \(16 bit\)}} } } if {[S 82 == FAT32]} {emit {\b, FAT \(32 bit\)} if {[N i 36 x {}]} {emit {\b, sectors/FAT %u}} if {[N s 40 > 0x0]} {emit {\b, extension flags %u}} if {[N s 42 > 0x0]} {emit {\b, fsVersion %u}} if {[N i 44 > 0x2]} {emit {\b, rootdir cluster %u}} if {[N s 48 > 0x1]} {emit {\b, infoSector %u}} if {[N s 48 < 0x1]} {emit {\b, infoSector %u}} if {[N s 50 > 0x6]} {emit {\b, Backup boot sector %u}} if {[N s 50 < 0x6]} {emit {\b, Backup boot sector %u}} if {[N i 54 > 0x0]} {emit {\b, reserved1 0x%x}} if {[N i 58 > 0x0]} {emit {\b, reserved2 0x%x}} if {[N i 62 > 0x0]} {emit {\b, reserved3 0x%x}} if {[N c 64 > 0x80]} {emit {\b, physical drive 0x%x}} if {[N c 64 > 0x0 &0x7F]} {emit {\b, physical drive 0x%x}} if {[N c 65 > 0x0]} {emit {\b, reserved 0x%x}} if {[N c 66 > 0x29]} {emit {\b, dos < 4.0 BootSector \(0x%x\)}} if {[N c 66 < 0x29]} {emit {\b, dos < 4.0 BootSector \(0x%x\)}} if {[N c 66 == 0x29]} {if {[N i 67 x {}]} {emit {\b, serial number 0x%x}} if {[S 71 < {NO\ NAME}]} {emit {\b, label: \"%11.11s\"}} } if {[S 71 > {NO\ NAME}]} {emit {\b, label: \"%11.11s\"}} if {[S 71 == {NO\ NAME}]} {emit {\b, unlabeled}} } } } } } if {[N i 512 == 0x82564557]} {emit {\b, BSD disklabel}} } if {[S 0 == FATX]} {emit {FATX filesystem data}} switch -- [Nv s 1040] 4991 {emit {Minix filesystem}} 5007 {emit {Minix filesystem, 30 char names}} 9320 {emit {Minix filesystem, version 2}} 9336 {emit {Minix filesystem, version 2, 30 char names}} if {[N S 1040 == 0x137f]} {emit {Minix filesystem \(big endian\),} if {[N S 1026 != 0x0]} {emit {\b, %d zones}} if {[S 30 == minix]} {emit {\b, bootable}} } if {[S 0 == {-rom1fs-\0}]} {emit {romfs filesystem, version 1} if {[N I 8 x {}]} {emit {%d bytes,}} if {[S 16 x {}]} {emit {named %s.}} } if {[S 395 == OS/2]} {emit {OS/2 Boot Manager}} if {[N i 9564 == 0x11954]} {emit {Unix Fast File system \(little-endian\),} if {[S 8404 x {}]} {emit {last mounted on %s,}} if {[N s 8224 x {}]} {emit {last written at %s,}} if {[N c 8401 x {}]} {emit {clean flag %d,}} if {[N i 8228 x {}]} {emit {number of blocks %d,}} if {[N i 8232 x {}]} {emit {number of data blocks %d,}} if {[N i 8236 x {}]} {emit {number of cylinder groups %d,}} if {[N i 8240 x {}]} {emit {block size %d,}} if {[N i 8244 x {}]} {emit {fragment size %d,}} if {[N i 8252 x {}]} {emit {minimum percentage of free blocks %d,}} if {[N i 8256 x {}]} {emit {rotational delay %dms,}} if {[N i 8260 x {}]} {emit {disk rotational speed %drps,}} switch -- [Nv i 8320] 0 {emit {TIME optimization}} 1 {emit {SPACE optimization}} } if {[N I 9564 == 0x11954]} {emit {Unix Fast File system \(big-endian\),} if {[N Q 7168 == 0x4c41424c]} {emit {Apple UFS Volume} if {[S 7186 x {}]} {emit {named %s,}} if {[N I 7176 x {}]} {emit {volume label version %d,}} if {[N S 7180 x {}]} {emit {created on %s,}} } if {[S 8404 x {}]} {emit {last mounted on %s,}} if {[N S 8224 x {}]} {emit {last written at %s,}} if {[N c 8401 x {}]} {emit {clean flag %d,}} if {[N I 8228 x {}]} {emit {number of blocks %d,}} if {[N I 8232 x {}]} {emit {number of data blocks %d,}} if {[N I 8236 x {}]} {emit {number of cylinder groups %d,}} if {[N I 8240 x {}]} {emit {block size %d,}} if {[N I 8244 x {}]} {emit {fragment size %d,}} if {[N I 8252 x {}]} {emit {minimum percentage of free blocks %d,}} if {[N I 8256 x {}]} {emit {rotational delay %dms,}} if {[N I 8260 x {}]} {emit {disk rotational speed %drps,}} switch -- [Nv I 8320] 0 {emit {TIME optimization}} 1 {emit {SPACE optimization}} } if {[N s 1080 == 0xef53]} {emit Linux if {[N i 1100 x {}]} {emit {rev %d}} if {[N s 1086 x {}]} {emit {\b.%d}} if {[N i 1116 ^ 0x4]} {emit {ext2 filesystem data} if {[N s 1082 ^ 0x1]} {emit {\(mounted or unclean\)}} } if {[N i 1116 & 0x4]} {emit {ext3 filesystem data} if {[N i 1120 & 0x4]} {emit {\(needs journal recovery\)}} } if {[N s 1082 & 0x2]} {emit {\(errors\)}} if {[N i 1120 & 0x1]} {emit {\(compressed\)}} if {[N i 1124 & 0x2]} {emit {\(large files\)}} } if {[N I 2048 == 0x46fc2700]} {emit {Atari-ST Minix kernel image} if {[S 19 == {\240\5\371\5\0\011\0\2\0}]} {emit {\b, 720k floppy}} if {[S 19 == {\320\2\370\5\0\011\0\1\0}]} {emit {\b, 360k floppy}} } if {[S 19 == {\320\2\360\3\0\011\0\1\0}]} {emit {DOS floppy 360k} if {[N s 510 == 0xaa55]} {emit {\b, x86 hard disk boot sector}} } if {[S 19 == {\240\5\371\3\0\011\0\2\0}]} {emit {DOS floppy 720k} if {[N s 510 == 0xaa55]} {emit {\b, x86 hard disk boot sector}} } if {[S 19 == {\100\013\360\011\0\022\0\2\0}]} {emit {DOS floppy 1440k} if {[N s 510 == 0xaa55]} {emit {\b, x86 hard disk boot sector}} } if {[S 19 == {\240\5\371\5\0\011\0\2\0}]} {emit {DOS floppy 720k, IBM} if {[N s 510 == 0xaa55]} {emit {\b, x86 hard disk boot sector}} } if {[S 19 == {\100\013\371\5\0\011\0\2\0}]} {emit {DOS floppy 1440k, mkdosfs} if {[N s 510 == 0xaa55]} {emit {\b, x86 hard disk boot sector}} } if {[S 19 == {\320\2\370\5\0\011\0\1\0}]} {emit {Atari-ST floppy 360k}} if {[S 19 == {\240\5\371\5\0\011\0\2\0}]} {emit {Atari-ST floppy 720k}} if {[S 32769 == CD001]} {emit {ISO 9660 CD-ROM filesystem data} if {[S 32808 x {}]} {emit '%s'} if {[S 34816 == {\000CD001\001EL\ TORITO\ SPECIFICATION}]} {emit {\(bootable\)}} } if {[S 37633 == CD001]} {emit {ISO 9660 CD-ROM filesystem data \(raw 2352 byte sectors\)}} if {[S 32776 == CDROM]} {emit {High Sierra CD-ROM filesystem data}} if {[S 65588 == ReIsErFs]} {emit {ReiserFS V3.5}} if {[S 65588 == ReIsEr2Fs]} {emit {ReiserFS V3.6} if {[N s 65580 x {}]} {emit {block size %d}} if {[N s 65586 & 0x2]} {emit {\(mounted or unclean\)}} if {[N i 65536 x {}]} {emit {num blocks %d}} switch -- [Nv i 65600] 1 {emit {tea hash}} 2 {emit {yura hash}} 3 {emit {r5 hash}} } if {[S 0 == ESTFBINR]} {emit {EST flat binary}} if {[S 0 == {VoIP\ Startup\ and}]} {emit {Aculab VoIP firmware} if {[S 35 x {}]} {emit {format %s}} } if {[S 0 == sqsh]} {emit {Squashfs filesystem, big endian,} if {[N S 28 x {}]} {emit {version %d.}} if {[N S 30 x {}]} {emit {\b%d,}} if {[N I 8 x {}]} {emit {%d bytes,}} if {[N I 4 x {}]} {emit {%d inodes,}} if {[N S 28 < 0x2]} {if {[N S 32 x {}]} {emit {blocksize: %d bytes,}} } if {[N S 28 > 0x1]} {if {[N I 51 x {}]} {emit {blocksize: %d bytes,}} } if {[N S 39 x {}]} {emit {created: %s}} } if {[S 0 == hsqs]} {emit {Squashfs filesystem, little endian,} if {[N s 28 x {}]} {emit {version %d.}} if {[N s 30 x {}]} {emit {\b%d,}} if {[N i 8 x {}]} {emit {%d bytes,}} if {[N i 4 x {}]} {emit {%d inodes,}} if {[N s 28 < 0x2]} {if {[N s 32 x {}]} {emit {blocksize: %d bytes,}} } if {[N s 28 > 0x1]} {if {[N i 51 x {}]} {emit {blocksize: %d bytes,}} } if {[N s 39 x {}]} {emit {created: %s}} } if {[S 0 == FWS]} {emit {Macromedia Flash data,} if {[N c 3 x {}]} {emit {version %d}} } if {[S 0 == CWS]} {emit {Macromedia Flash data \(compressed\),} if {[N c 3 x {}]} {emit {version %d}} } if {[S 0 == {AGD4\xbe\xb8\xbb\xcb\x00}]} {emit {Macromedia Freehand 9 Document}} if {[S 0 == FONT]} {emit {ASCII vfont text}} if {[S 0 == %!PS-AdobeFont-1.]} {emit {PostScript Type 1 font text} if {[S 20 x {}]} {emit {\(%s\)}} } if {[S 6 == %!PS-AdobeFont-1.]} {emit {PostScript Type 1 font program data}} if {[S 0 == {STARTFONT\040}]} {emit {X11 BDF font text}} if {[S 0 == {\001fcp}]} {emit {X11 Portable Compiled Font data} switch -- [Nv c 12] 2 {emit {\b, LSB first}} 10 {emit {\b, MSB first}} } if {[S 0 == {D1.0\015}]} {emit {X11 Speedo font data}} if {[S 0 == flf]} {emit {FIGlet font} if {[S 3 > 2a]} {emit {version %-2.2s}} } if {[S 0 == flc]} {emit {FIGlet controlfile} if {[S 3 > 2a]} {emit {version %-2.2s}} } switch -- [Nv I 7] 4540225 {emit {DOS code page font data}} 5654852 {emit {DOS code page font data \(from Linux?\)}} if {[S 4098 == DOSFONT]} {emit {DOSFONT2 encrypted font data}} if {[S 0 == PFR1]} {emit {PFR1 font} if {[S 102 > 0]} {emit {\b: %s}} } if {[S 0 == {\000\001\000\000\000}]} {emit {TrueType font data}} if {[S 0 == {\007\001\001\000Copyright\ (c)\ 199}]} {emit {Adobe Multiple Master font}} if {[S 0 == {\012\001\001\000Copyright\ (c)\ 199}]} {emit {Adobe Multiple Master font}} if {[S 0 == OTTO]} {emit {OpenType font data}} if {[S 0 == 0xfff]} {switch -- [Nv c 3 &0x80] -128 {emit {dynamically linked executable}} 0 {emit executable} } if {[N i 16 > 0x0]} {emit {not stripped}} } 8782088 {emit {FreeBSD/i386 pure} if {[N i 20 < 0x1000]} {if {[N c 3 & 0x80 &0xC0]} {emit {shared library}} switch -- [Nv c 3 &0xC0] 64 {emit {PIC object}} 0 {emit object} } if {[N i 20 > 0xfff]} {switch -- [Nv c 3 &0x80] -128 {emit {dynamically linked executable}} 0 {emit executable} } if {[N i 16 > 0x0]} {emit {not stripped}} } 8782091 {emit {FreeBSD/i386 demand paged} if {[N i 20 < 0x1000]} {if {[N c 3 & 0x80 &0xC0]} {emit {shared library}} switch -- [Nv c 3 &0xC0] 64 {emit {PIC object}} 0 {emit object} } if {[N i 20 > 0xfff]} {switch -- [Nv c 3 &0x80] -128 {emit {dynamically linked executable}} 0 {emit executable} } if {[N i 16 > 0x0]} {emit {not stripped}} } 8782028 {emit {FreeBSD/i386 compact demand paged} if {[N i 20 < 0x1000]} {if {[N c 3 & 0x80 &0xC0]} {emit {shared library}} switch -- [Nv c 3 &0xC0] 64 {emit {PIC object}} 0 {emit object} } if {[N i 20 > 0xfff]} {switch -- [Nv c 3 &0x80] -128 {emit {dynamically linked executable}} 0 {emit executable} } if {[N i 16 > 0x0]} {emit {not stripped}} } if {[S 7 == {\357\020\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0}]} {emit {FreeBSD/i386 a.out core file} if {[S 1039 x {}]} {emit {from '%s'}} } if {[S 0 == SCRSHOT_]} {emit {scrshot\(1\) screenshot,} if {[N c 8 x {}]} {emit {version %d,}} if {[N c 9 == 0x2]} {emit {%d bytes in header,} if {[N c 10 x {}]} {emit {%d chars wide by}} if {[N c 11 x {}]} {emit {%d chars high}} } } if {[S 1 == WAD]} {emit {DOOM data,} if {[S 0 == I]} {emit {main wad}} if {[S 0 == P]} {emit {patch wad}} if {[N c 0 x {}]} {emit {unknown junk}} } if {[S 0 == IDP2]} {emit {Quake II 3D Model file,} if {[N Q 20 x {}]} {emit {%lu skin\(s\),}} if {[N Q 8 x {}]} {emit {\(%lu x}} if {[N Q 12 x {}]} {emit {%lu\),}} if {[N Q 40 x {}]} {emit {%lu frame\(s\),}} if {[N Q 16 x {}]} {emit {Frame size %lu bytes,}} if {[N Q 24 x {}]} {emit {%lu vertices/frame,}} if {[N Q 28 x {}]} {emit {%lu texture coordinates,}} if {[N Q 32 x {}]} {emit {%lu triangles/frame}} } if {[S 0 == IBSP]} {emit Quake switch -- [Nv Q 4] 38 {emit {II Map file \(BSP\)}} 46 {emit {III Map file \(BSP\)}} } if {[S 0 == IDS2]} {emit {Quake II SP2 sprite file}} if {[S 0 == IWAD]} {emit {DOOM or DOOM ][ world}} if {[S 0 == PWAD]} {emit {DOOM or DOOM ][ extension world}} if {[S 0 == {\xcb\x1dBoom\xe6\xff\x03\x01}]} {emit {Boom or linuxdoom demo}} if {[S 24 == {LxD\ 203}]} {emit {Linuxdoom save} if {[S 0 x {}]} {emit {, name=%s}} if {[S 44 x {}]} {emit {, world=%s}} } if {[S 0 == PACK]} {emit {Quake I or II world or extension}} if {[S 0 == {5\x0aIntroduction}]} {emit {Quake I save: start Introduction}} if {[S 0 == {5\x0athe_Slipgate_Complex}]} {emit {Quake I save: e1m1 The slipgate complex}} if {[S 0 == {5\x0aCastle_of_the_Damned}]} {emit {Quake I save: e1m2 Castle of the damned}} if {[S 0 == {5\x0athe_Necropolis}]} {emit {Quake I save: e1m3 The necropolis}} if {[S 0 == {5\x0athe_Grisly_Grotto}]} {emit {Quake I save: e1m4 The grisly grotto}} if {[S 0 == {5\x0aZiggurat_Vertigo}]} {emit {Quake I save: e1m8 Ziggurat vertigo \(secret\)}} if {[S 0 == {5\x0aGloom_Keep}]} {emit {Quake I save: e1m5 Gloom keep}} if {[S 0 == {5\x0aThe_Door_To_Chthon}]} {emit {Quake I save: e1m6 The door to Chthon}} if {[S 0 == {5\x0aThe_House_of_Chthon}]} {emit {Quake I save: e1m7 The house of Chthon}} if {[S 0 == {5\x0athe_Installation}]} {emit {Quake I save: e2m1 The installation}} if {[S 0 == {5\x0athe_Ogre_Citadel}]} {emit {Quake I save: e2m2 The ogre citadel}} if {[S 0 == {5\x0athe_Crypt_of_Decay}]} {emit {Quake I save: e2m3 The crypt of decay \(dopefish lives!\)}} if {[S 0 == {5\x0aUnderearth}]} {emit {Quake I save: e2m7 Underearth \(secret\)}} if {[S 0 == {5\x0athe_Ebon_Fortress}]} {emit {Quake I save: e2m4 The ebon fortress}} if {[S 0 == {5\x0athe_Wizard's_Manse}]} {emit {Quake I save: e2m5 The wizard's manse}} if {[S 0 == {5\x0athe_Dismal_Oubliette}]} {emit {Quake I save: e2m6 The dismal oubliette}} if {[S 0 == {5\x0aTermination_Central}]} {emit {Quake I save: e3m1 Termination central}} if {[S 0 == {5\x0aVaults_of_Zin}]} {emit {Quake I save: e3m2 Vaults of Zin}} if {[S 0 == {5\x0athe_Tomb_of_Terror}]} {emit {Quake I save: e3m3 The tomb of terror}} if {[S 0 == {5\x0aSatan's_Dark_Delight}]} {emit {Quake I save: e3m4 Satan's dark delight}} if {[S 0 == {5\x0athe_Haunted_Halls}]} {emit {Quake I save: e3m7 The haunted halls \(secret\)}} if {[S 0 == {5\x0aWind_Tunnels}]} {emit {Quake I save: e3m5 Wind tunnels}} if {[S 0 == {5\x0aChambers_of_Torment}]} {emit {Quake I save: e3m6 Chambers of torment}} if {[S 0 == {5\x0athe_Sewage_System}]} {emit {Quake I save: e4m1 The sewage system}} if {[S 0 == {5\x0aThe_Tower_of_Despair}]} {emit {Quake I save: e4m2 The tower of despair}} if {[S 0 == {5\x0aThe_Elder_God_Shrine}]} {emit {Quake I save: e4m3 The elder god shrine}} if {[S 0 == {5\x0athe_Palace_of_Hate}]} {emit {Quake I save: e4m4 The palace of hate}} if {[S 0 == {5\x0aHell's_Atrium}]} {emit {Quake I save: e4m5 Hell's atrium}} if {[S 0 == {5\x0athe_Nameless_City}]} {emit {Quake I save: e4m8 The nameless city \(secret\)}} if {[S 0 == {5\x0aThe_Pain_Maze}]} {emit {Quake I save: e4m6 The pain maze}} if {[S 0 == {5\x0aAzure_Agony}]} {emit {Quake I save: e4m7 Azure agony}} if {[S 0 == {5\x0aShub-Niggurath's_Pit}]} {emit {Quake I save: end Shub-Niggurath's pit}} if {[S 0 == {5\x0aPlace_of_Two_Deaths}]} {emit {Quake I save: dm1 Place of two deaths}} if {[S 0 == {5\x0aClaustrophobopolis}]} {emit {Quake I save: dm2 Claustrophobopolis}} if {[S 0 == {5\x0aThe_Abandoned_Base}]} {emit {Quake I save: dm3 The abandoned base}} if {[S 0 == {5\x0aThe_Bad_Place}]} {emit {Quake I save: dm4 The bad place}} if {[S 0 == {5\x0aThe_Cistern}]} {emit {Quake I save: dm5 The cistern}} if {[S 0 == {5\x0aThe_Dark_Zone}]} {emit {Quake I save: dm6 The dark zone}} if {[S 0 == {5\x0aCommand_HQ}]} {emit {Quake I save: start Command HQ}} if {[S 0 == {5\x0aThe_Pumping_Station}]} {emit {Quake I save: hip1m1 The pumping station}} if {[S 0 == {5\x0aStorage_Facility}]} {emit {Quake I save: hip1m2 Storage facility}} if {[S 0 == {5\x0aMilitary_Complex}]} {emit {Quake I save: hip1m5 Military complex \(secret\)}} if {[S 0 == {5\x0athe_Lost_Mine}]} {emit {Quake I save: hip1m3 The lost mine}} if {[S 0 == {5\x0aResearch_Facility}]} {emit {Quake I save: hip1m4 Research facility}} if {[S 0 == {5\x0aAncient_Realms}]} {emit {Quake I save: hip2m1 Ancient realms}} if {[S 0 == {5\x0aThe_Gremlin's_Domain}]} {emit {Quake I save: hip2m6 The gremlin's domain \(secret\)}} if {[S 0 == {5\x0aThe_Black_Cathedral}]} {emit {Quake I save: hip2m2 The black cathedral}} if {[S 0 == {5\x0aThe_Catacombs}]} {emit {Quake I save: hip2m3 The catacombs}} if {[S 0 == {5\x0athe_Crypt__}]} {emit {Quake I save: hip2m4 The crypt}} if {[S 0 == {5\x0aMortum's_Keep}]} {emit {Quake I save: hip2m5 Mortum's keep}} if {[S 0 == {5\x0aTur_Torment}]} {emit {Quake I save: hip3m1 Tur torment}} if {[S 0 == {5\x0aPandemonium}]} {emit {Quake I save: hip3m2 Pandemonium}} if {[S 0 == {5\x0aLimbo}]} {emit {Quake I save: hip3m3 Limbo}} if {[S 0 == {5\x0athe_Edge_of_Oblivion}]} {emit {Quake I save: hipdm1 The edge of oblivion \(secret\)}} if {[S 0 == {5\x0aThe_Gauntlet}]} {emit {Quake I save: hip3m4 The gauntlet}} if {[S 0 == {5\x0aArmagon's_Lair}]} {emit {Quake I save: hipend Armagon's lair}} if {[S 0 == {5\x0aThe_Academy}]} {emit {Quake I save: start The academy}} if {[S 0 == {5\x0aThe_Lab}]} {emit {Quake I save: d1 The lab}} if {[S 0 == {5\x0aArea_33}]} {emit {Quake I save: d1b Area 33}} if {[S 0 == {5\x0aSECRET_MISSIONS}]} {emit {Quake I save: d3b Secret missions}} if {[S 0 == {5\x0aThe_Hospital}]} {emit {Quake I save: d10 The hospital \(secret\)}} if {[S 0 == {5\x0aThe_Genetics_Lab}]} {emit {Quake I save: d11 The genetics lab \(secret\)}} if {[S 0 == {5\x0aBACK_2_MALICE}]} {emit {Quake I save: d4b Back to Malice}} if {[S 0 == {5\x0aArea44}]} {emit {Quake I save: d1c Area 44}} if {[S 0 == {5\x0aTakahiro_Towers}]} {emit {Quake I save: d2 Takahiro towers}} if {[S 0 == {5\x0aA_Rat's_Life}]} {emit {Quake I save: d3 A rat's life}} if {[S 0 == {5\x0aInto_The_Flood}]} {emit {Quake I save: d4 Into the flood}} if {[S 0 == {5\x0aThe_Flood}]} {emit {Quake I save: d5 The flood}} if {[S 0 == {5\x0aNuclear_Plant}]} {emit {Quake I save: d6 Nuclear plant}} if {[S 0 == {5\x0aThe_Incinerator_Plant}]} {emit {Quake I save: d7 The incinerator plant}} if {[S 0 == {5\x0aThe_Foundry}]} {emit {Quake I save: d7b The foundry}} if {[S 0 == {5\x0aThe_Underwater_Base}]} {emit {Quake I save: d8 The underwater base}} if {[S 0 == {5\x0aTakahiro_Base}]} {emit {Quake I save: d9 Takahiro base}} if {[S 0 == {5\x0aTakahiro_Laboratories}]} {emit {Quake I save: d12 Takahiro laboratories}} if {[S 0 == {5\x0aStayin'_Alive}]} {emit {Quake I save: d13 Stayin' alive}} if {[S 0 == {5\x0aB.O.S.S._HQ}]} {emit {Quake I save: d14 B.O.S.S. HQ}} if {[S 0 == {5\x0aSHOWDOWN!}]} {emit {Quake I save: d15 Showdown!}} if {[S 0 == {5\x0aThe_Seventh_Precinct}]} {emit {Quake I save: ddm1 The seventh precinct}} if {[S 0 == {5\x0aSub_Station}]} {emit {Quake I save: ddm2 Sub station}} if {[S 0 == {5\x0aCrazy_Eights!}]} {emit {Quake I save: ddm3 Crazy eights!}} if {[S 0 == {5\x0aEast_Side_Invertationa}]} {emit {Quake I save: ddm4 East side invertationa}} if {[S 0 == {5\x0aSlaughterhouse}]} {emit {Quake I save: ddm5 Slaughterhouse}} if {[S 0 == {5\x0aDOMINO}]} {emit {Quake I save: ddm6 Domino}} if {[S 0 == {5\x0aSANDRA'S_LADDER}]} {emit {Quake I save: ddm7 Sandra's ladder}} if {[S 0 == MComprHD]} {emit {MAME CHD compressed hard disk image,} if {[N I 12 x {}]} {emit {version %lu}} } if {[S 0 == gpch]} {emit {GCC precompiled header} if {[N c 5 x {}]} {emit {\(version %c}} if {[N c 6 x {}]} {emit {\b%c}} if {[N c 7 x {}]} {emit {\b%c\)}} switch -- [Nv c 4] 67 {emit {for C}} 111 {emit {for Objective C}} 43 {emit {for C++}} 79 {emit {for Objective C++}} } if {[S 0 == {GIMP\ Gradient}]} {emit {GIMP gradient data}} if {[S 0 == {gimp\ xcf}]} {emit {GIMP XCF image data,} if {[S 9 == file]} {emit {version 0,}} if {[S 9 == v]} {emit version if {[S 10 x {}]} {emit %s,} } if {[N I 14 x {}]} {emit {%lu x}} if {[N I 18 x {}]} {emit %lu,} switch -- [Nv I 22] 0 {emit {RGB Color}} 1 {emit Greyscale} 2 {emit {Indexed Color}} if {[N I 22 > 0x2]} {emit {Unknown Image Type.}} } if {[S 20 == GPAT]} {emit {GIMP pattern data,} if {[S 24 x {}]} {emit %s} } if {[S 20 == GIMP]} {emit {GIMP brush data}} if {[S 0 == {\336\22\4\225}]} {emit {GNU message catalog \(little endian\),} if {[N i 4 x {}]} {emit {revision %d,}} if {[N i 8 x {}]} {emit {%d messages}} } if {[S 0 == {\225\4\22\336}]} {emit {GNU message catalog \(big endian\),} if {[N I 4 x {}]} {emit {revision %d,}} if {[N I 8 x {}]} {emit {%d messages}} } if {[S 0 == *nazgul*]} {emit {Nazgul style compiled message catalog} if {[N i 8 > 0x0]} {emit {\b, version %ld}} } if {[S 0 == {\001gpg}]} {emit {GPG key trust database} if {[N c 4 x {}]} {emit {version %d}} } if {[S 39 == 0x0]} {emit {- version %c}} } if {[S 0 == {\#\ xvgr\ parameter\ file}]} {emit {ACE/gr ascii file}} if {[S 0 == {\#\ xmgr\ parameter\ file}]} {emit {ACE/gr ascii file}} if {[S 0 == {\#\ ACE/gr\ parameter\ file}]} {emit {ACE/gr ascii file}} if {[S 0 == {\#\ Grace\ project\ file}]} {emit {Grace project file} if {[S 23 == {@version\ }]} {emit {\(version} if {[N c 32 > 0x0]} {emit %c} if {[S 33 x {}]} {emit {\b.%.2s}} if {[S 35 x {}]} {emit {\b.%.2s\)}} } } if {[S 0 == {\#\ ACE/gr\ fit\ description\ }]} {emit {ACE/gr fit description file}} if {[S 0 == {\211HDF\r\n\032}]} {emit {Hierarchical Data Format \(version 5\) data}} if {[S 0 == Bitmapfile]} {emit {HP Bitmapfile}} if {[S 0 == IMGfile]} {emit {CIS compimg HP Bitmapfile}} if {[S 0 == msgcat01]} {emit {HP NLS message catalog,} if {[N Q 8 > 0x0]} {emit {%d messages}} } if {[S 0 == HPHP48-]} {emit {HP48 binary} if {[N c 7 > 0x0]} {emit {- Rev %c}} switch -- [Nv S 8] 4393 {emit {\(ADR\)}} 13097 {emit {\(REAL\)}} 21801 {emit {\(LREAL\)}} 30505 {emit {\(COMPLX\)}} -25303 {emit {\(LCOMPLX\)}} -16599 {emit {\(CHAR\)}} -6103 {emit {\(ARRAY\)}} 2602 {emit {\(LNKARRAY\)}} 11306 {emit {\(STRING\)}} 20010 {emit {\(HXS\)}} 29738 {emit {\(LIST\)}} -27094 {emit {\(DIR\)}} -18390 {emit {\(ALG\)}} -9686 {emit {\(UNIT\)}} -982 {emit {\(TAGGED\)}} 7723 {emit {\(GROB\)}} 16427 {emit {\(LIB\)}} 25131 {emit {\(BACKUP\)}} -30677 {emit {\(LIBDATA\)}} -25299 {emit {\(PROG\)}} -13267 {emit {\(CODE\)}} 18478 {emit {\(GNAME\)}} 27950 {emit {\(LNAME\)}} -28114 {emit {\(XLIB\)}} } if {[S 0 == %%HP:]} {emit {HP48 text} if {[S 6 == T(0)]} {emit {- T\(0\)}} if {[S 6 == T(1)]} {emit {- T\(1\)}} if {[S 6 == T(2)]} {emit {- T\(2\)}} if {[S 6 == T(3)]} {emit {- T\(3\)}} if {[S 10 == A(D)]} {emit {A\(D\)}} if {[S 10 == A(R)]} {emit {A\(R\)}} if {[S 10 == A(G)]} {emit {A\(G\)}} if {[S 14 == F(.)]} {emit {F\(.\);}} if {[S 14 == F(,)]} {emit {F\(,\);}} } if {[S 16 == HP-UX]} {if {[N I 0 == 0x2]} {if {[N I 12 == 0x3c]} {switch -- [Nv I 76] 256 {emit {} if {[N I 88 == 0x44]} {if {[N I 160 == 0x1]} {if {[N I 172 == 0x4]} {if {[N I 176 == 0x1]} {if {[N I 180 == 0x4]} {emit {core file} if {[S 144 x {}]} {emit {from '%s'}} switch -- [Nv I 196] 3 {emit {- received SIGQUIT}} 4 {emit {- received SIGILL}} 5 {emit {- received SIGTRAP}} 6 {emit {- received SIGABRT}} 7 {emit {- received SIGEMT}} 8 {emit {- received SIGFPE}} 10 {emit {- received SIGBUS}} 11 {emit {- received SIGSEGV}} 12 {emit {- received SIGSYS}} 33 {emit {- received SIGXCPU}} 34 {emit {- received SIGXFSZ}} } } } } } } 1 {emit {} if {[N I 88 == 0x4]} {if {[N I 92 == 0x1]} {if {[N I 96 == 0x100]} {if {[N I 108 == 0x44]} {if {[N I 180 == 0x4]} {emit {core file} if {[S 164 x {}]} {emit {from '%s'}} switch -- [Nv I 196] 3 {emit {- received SIGQUIT}} 4 {emit {- received SIGILL}} 5 {emit {- received SIGTRAP}} 6 {emit {- received SIGABRT}} 7 {emit {- received SIGEMT}} 8 {emit {- received SIGFPE}} 10 {emit {- received SIGBUS}} 11 {emit {- received SIGSEGV}} 12 {emit {- received SIGSYS}} 33 {emit {- received SIGXCPU}} 34 {emit {- received SIGXFSZ}} } } } } } } } } } if {[S 36 == HP-UX]} {if {[N I 0 == 0x1]} {if {[N I 12 == 0x4]} {if {[N I 16 == 0x1]} {if {[N I 20 == 0x2]} {if {[N I 32 == 0x3c]} {if {[N I 96 == 0x100]} {if {[N I 108 == 0x44]} {if {[N I 180 == 0x4]} {emit {core file} if {[S 164 x {}]} {emit {from '%s'}} switch -- [Nv I 196] 3 {emit {- received SIGQUIT}} 4 {emit {- received SIGILL}} 5 {emit {- received SIGTRAP}} 6 {emit {- received SIGABRT}} 7 {emit {- received SIGEMT}} 8 {emit {- received SIGFPE}} 10 {emit {- received SIGBUS}} 11 {emit {- received SIGSEGV}} 12 {emit {- received SIGSYS}} 33 {emit {- received SIGXCPU}} 34 {emit {- received SIGXFSZ}} } } } } } } } } } if {[S 100 == HP-UX]} {if {[N I 0 == 0x100]} {if {[N I 12 == 0x44]} {if {[N I 84 == 0x2]} {if {[N I 96 == 0x3c]} {if {[N I 160 == 0x1]} {if {[N I 172 == 0x4]} {if {[N I 176 == 0x1]} {if {[N I 180 == 0x4]} {emit {core file} if {[S 68 x {}]} {emit {from '%s'}} switch -- [Nv I 196] 3 {emit {- received SIGQUIT}} 4 {emit {- received SIGILL}} 5 {emit {- received SIGTRAP}} 6 {emit {- received SIGABRT}} 7 {emit {- received SIGEMT}} 8 {emit {- received SIGFPE}} 10 {emit {- received SIGBUS}} 11 {emit {- received SIGSEGV}} 12 {emit {- received SIGSYS}} 33 {emit {- received SIGXCPU}} 34 {emit {- received SIGXFSZ}} } } } } } } } } } if {[S 120 == HP-UX]} {switch -- [Nv I 0] 1 {emit {} if {[N I 12 == 0x4]} {if {[N I 16 == 0x1]} {if {[N I 20 == 0x100]} {if {[N I 32 == 0x44]} {if {[N I 104 == 0x2]} {if {[N I 116 == 0x3c]} {if {[N I 180 == 0x4]} {emit {core file} if {[S 88 x {}]} {emit {from '%s'}} switch -- [Nv I 196] 3 {emit {- received SIGQUIT}} 4 {emit {- received SIGILL}} 5 {emit {- received SIGTRAP}} 6 {emit {- received SIGABRT}} 7 {emit {- received SIGEMT}} 8 {emit {- received SIGFPE}} 10 {emit {- received SIGBUS}} 11 {emit {- received SIGSEGV}} 12 {emit {- received SIGSYS}} 33 {emit {- received SIGXCPU}} 34 {emit {- received SIGXFSZ}} } } } } } } } } 256 {emit {} if {[N I 12 == 0x44]} {if {[N I 84 == 0x1]} {if {[N I 96 == 0x4]} {if {[N I 100 == 0x1]} {if {[N I 104 == 0x2]} {if {[N I 116 == 0x2c]} {if {[N I 180 == 0x4]} {emit {core file} if {[S 68 x {}]} {emit {from '%s'}} switch -- [Nv I 196] 3 {emit {- received SIGQUIT}} 4 {emit {- received SIGILL}} 5 {emit {- received SIGTRAP}} 6 {emit {- received SIGABRT}} 7 {emit {- received SIGEMT}} 8 {emit {- received SIGFPE}} 10 {emit {- received SIGBUS}} 11 {emit {- received SIGSEGV}} 12 {emit {- received SIGSYS}} 33 {emit {- received SIGXCPU}} 34 {emit {- received SIGXFSZ}} } } } } } } } } } if {[S 0 == HPHP49-]} {emit {HP49 binary}} if {[S 0 == 0xabcdef]} {emit {AIX message catalog}} if {[S 0 == ]} {emit archive} if {[S 0 == ]} {emit {archive \(big format\)}} if {[S 0 == FORM]} {emit {IFF data} if {[S 8 == AIFF]} {emit {\b, AIFF audio}} if {[S 8 == AIFC]} {emit {\b, AIFF-C compressed audio}} if {[S 8 == 8SVX]} {emit {\b, 8SVX 8-bit sampled sound voice}} if {[S 8 == SAMP]} {emit {\b, SAMP sampled audio}} if {[S 8 == DTYP]} {emit {\b, DTYP datatype description}} if {[S 8 == PTCH]} {emit {\b, PTCH binary patch}} if {[S 8 == ILBMBMHD]} {emit {\b, ILBM interleaved image} if {[N S 20 x {}]} {emit {\b, %d x}} if {[N S 22 x {}]} {emit %d} } if {[S 8 == RGBN]} {emit {\b, RGBN 12-bit RGB image}} if {[S 8 == RGB8]} {emit {\b, RGB8 24-bit RGB image}} if {[S 8 == DR2D]} {emit {\b, DR2D 2-D object}} if {[S 8 == TDDD]} {emit {\b, TDDD 3-D rendering}} if {[S 8 == FTXT]} {emit {\b, FTXT formatted text}} if {[S 8 == CTLG]} {emit {\b, CTLG message catalog}} if {[S 8 == PREF]} {emit {\b, PREF preferences}} } switch -- [Nv I 1 &0xfff7ffff] 16842752 {emit {Targa image data - Map} if {[N c 2 == 0x8 &8]} {emit {- RLE}} if {[N s 12 > 0x0]} {emit {%hd x}} if {[N s 14 > 0x0]} {emit %hd} } 131072 {emit {Targa image data - RGB} if {[N c 2 == 0x8 &8]} {emit {- RLE}} if {[N s 12 > 0x0]} {emit {%hd x}} if {[N s 14 > 0x0]} {emit %hd} } 196608 {emit {Targa image data - Mono} if {[N c 2 == 0x8 &8]} {emit {- RLE}} if {[N s 12 > 0x0]} {emit {%hd x}} if {[N s 14 > 0x0]} {emit %hd} } if {[S 0 == P1]} {emit {Netpbm PBM image text}} if {[S 0 == P2]} {emit {Netpbm PGM image text}} if {[S 0 == P3]} {emit {Netpbm PPM image text}} if {[S 0 == P4]} {emit {Netpbm PBM \"rawbits\" image data}} if {[S 0 == P5]} {emit {Netpbm PGM \"rawbits\" image data}} if {[S 0 == P6]} {emit {Netpbm PPM \"rawbits\" image data}} if {[S 0 == P7]} {emit {Netpbm PAM image file}} if {[S 0 == {\117\072}]} {emit {Solitaire Image Recorder format} if {[S 4 == {\013}]} {emit {MGI Type 11}} if {[S 4 == {\021}]} {emit {MGI Type 17}} } if {[S 0 == .MDA]} {emit {MicroDesign data} switch -- [Nv c 21] 48 {emit {version 2}} 51 {emit {version 3}} } if {[S 0 == .MDP]} {emit {MicroDesign page data} switch -- [Nv c 21] 48 {emit {version 2}} 51 {emit {version 3}} } if {[S 0 == IIN1]} {emit {NIFF image data}} if {[S 0 == {MM\x00\x2a}]} {emit {TIFF image data, big-endian}} if {[S 0 == {II\x2a\x00}]} {emit {TIFF image data, little-endian}} if {[S 0 == {\x89PNG}]} {emit {PNG image data,} if {[N I 4 != 0xd0a1a0a]} {emit CORRUPTED,} if {[N I 4 == 0xd0a1a0a]} {if {[N I 16 x {}]} {emit {%ld x}} if {[N I 20 x {}]} {emit %ld,} if {[N c 24 x {}]} {emit %d-bit} switch -- [Nv c 25] 0 {emit grayscale,} 2 {emit {\b/color RGB,}} 3 {emit colormap,} 4 {emit gray+alpha,} 6 {emit {\b/color RGBA,}} switch -- [Nv c 28] 0 {emit non-interlaced} 1 {emit interlaced} } } if {[S 1 == PNG]} {emit {PNG image data, CORRUPTED}} if {[S 0 == GIF8]} {emit {GIF image data} if {[S 4 == 7a]} {emit {\b, version 8%s,}} if {[S 4 == 9a]} {emit {\b, version 8%s,}} if {[N s 6 > 0x0]} {emit {%hd x}} if {[N s 8 > 0x0]} {emit %hd} } if {[S 0 == {\361\0\100\273}]} {emit {CMU window manager raster image data} if {[N i 4 > 0x0]} {emit {%d x}} if {[N i 8 > 0x0]} {emit %d,} if {[N i 12 > 0x0]} {emit %d-bit} } if {[S 0 == id=ImageMagick]} {emit {MIFF image data}} if {[S 0 == {\#FIG}]} {emit {FIG image text} if {[S 5 x {}]} {emit {\b, version %.3s}} } if {[S 0 == ARF_BEGARF]} {emit {PHIGS clear text archive}} if {[S 0 == {@(\#)SunPHIGS}]} {emit SunPHIGS if {[S 40 == SunBin]} {emit binary} if {[S 32 == archive]} {emit archive} } if {[S 0 == GKSM]} {emit {GKS Metafile} if {[S 24 == SunGKS]} {emit {\b, SunGKS}} } if {[S 0 == BEGMF]} {emit {clear text Computer Graphics Metafile}} if {[N S 0 == 0x20 &0xffe0]} {emit {binary Computer Graphics Metafile}} if {[S 0 == yz]} {emit {MGR bitmap, modern format, 8-bit aligned}} if {[S 0 == zz]} {emit {MGR bitmap, old format, 1-bit deep, 16-bit aligned}} if {[S 0 == xz]} {emit {MGR bitmap, old format, 1-bit deep, 32-bit aligned}} if {[S 0 == yx]} {emit {MGR bitmap, modern format, squeezed}} if {[S 0 == {%bitmap\0}]} {emit {FBM image data} switch -- [Nv Q 30] 49 {emit {\b, mono}} 51 {emit {\b, color}} } if {[S 1 == {PC\ Research,\ Inc}]} {emit {group 3 fax data} switch -- [Nv c 29] 0 {emit {\b, normal resolution \(204x98 DPI\)}} 1 {emit {\b, fine resolution \(204x196 DPI\)}} } if {[S 0 == Sfff]} {emit {structured fax file}} if {[S 0 == BM]} {emit {PC bitmap data} switch -- [Nv s 14] 12 {emit {\b, OS/2 1.x format} if {[N s 18 x {}]} {emit {\b, %d x}} if {[N s 20 x {}]} {emit %d} } 64 {emit {\b, OS/2 2.x format} if {[N s 18 x {}]} {emit {\b, %d x}} if {[N s 20 x {}]} {emit %d} } 40 {emit {\b, Windows 3.x format} if {[N i 18 x {}]} {emit {\b, %d x}} if {[N i 22 x {}]} {emit {%d x}} if {[N s 28 x {}]} {emit %d} } } if {[S 0 == {/*\ XPM\ */}]} {emit {X pixmap image text}} if {[S 0 == {Imagefile\ version-}]} {emit {iff image data} if {[S 10 x {}]} {emit %s} } if {[S 0 == IT01]} {emit {FIT image data} if {[N I 4 x {}]} {emit {\b, %d x}} if {[N I 8 x {}]} {emit {%d x}} if {[N I 12 x {}]} {emit %d} } if {[S 0 == IT02]} {emit {FIT image data} if {[N I 4 x {}]} {emit {\b, %d x}} if {[N I 8 x {}]} {emit {%d x}} if {[N I 12 x {}]} {emit %d} } if {[S 2048 == PCD_IPI]} {emit {Kodak Photo CD image pack file} switch -- [Nv c 3586 &0x03] 0 {emit {, landscape mode}} 1 {emit {, portrait mode}} 2 {emit {, landscape mode}} 3 {emit {, portrait mode}} } if {[S 0 == PCD_OPA]} {emit {Kodak Photo CD overview pack file}} if {[S 0 == {SIMPLE\ \ =}]} {emit {FITS image data} if {[S 109 == 8]} {emit {\b, 8-bit, character or unsigned binary integer}} if {[S 108 == 16]} {emit {\b, 16-bit, two's complement binary integer}} if {[S 107 == {\ 32}]} {emit {\b, 32-bit, two's complement binary integer}} if {[S 107 == -32]} {emit {\b, 32-bit, floating point, single precision}} if {[S 107 == -64]} {emit {\b, 64-bit, floating point, double precision}} } if {[S 0 == {This\ is\ a\ BitMap\ file}]} {emit {Lisp Machine bit-array-file}} if {[S 0 == !!]} {emit {Bennet Yee's \"face\" format}} if {[S 1536 == {Visio\ (TM)\ Drawing}]} {emit %s} if {[S 0 == {\%TGIF\ x}]} {emit {Tgif file version %s}} if {[S 128 == DICM]} {emit {DICOM medical imaging data}} switch -- [Nv I 4] 7 {emit {XWD X Window Dump image data} if {[S 100 x {}]} {emit {\b, \"%s\"}} if {[N I 16 x {}]} {emit {\b, %dx}} if {[N I 20 x {}]} {emit {\b%dx}} if {[N I 12 x {}]} {emit {\b%d}} } 2097152000 {emit GLF_BINARY_LSB_FIRST} 125 {emit GLF_BINARY_MSB_FIRST} 268435456 {emit GLS_BINARY_LSB_FIRST} 16 {emit GLS_BINARY_MSB_FIRST} 19195 {emit {QDOS executable} if {[S 9 x {} p]} {emit '%s'} } if {[S 0 == NJPL1I00]} {emit {PDS \(JPL\) image data}} if {[S 2 == NJPL1I]} {emit {PDS \(JPL\) image data}} if {[S 0 == CCSD3ZF]} {emit {PDS \(CCSD\) image data}} if {[S 2 == CCSD3Z]} {emit {PDS \(CCSD\) image data}} if {[S 0 == PDS_]} {emit {PDS image data}} if {[S 0 == LBLSIZE=]} {emit {PDS \(VICAR\) image data}} if {[S 0 == pM85]} {emit {Atari ST STAD bitmap image data \(hor\)} switch -- [Nv c 5] 0 {emit {\(white background\)}} -1 {emit {\(black background\)}} } if {[S 0 == pM86]} {emit {Atari ST STAD bitmap image data \(vert\)} switch -- [Nv c 5] 0 {emit {\(white background\)}} -1 {emit {\(black background\)}} } if {[S 0 == {\x37\x00\x00\x10\x42\x00\x00\x10\x00\x00\x00\x00\x39\x64\x39\x47}]} {emit {EPOC MBM image file}} if {[S 0 == 8BPS]} {emit {Adobe Photoshop Image}} if {[S 0 == {P7\ 332}]} {emit {XV thumbnail image data}} if {[S 0 == NITF]} {emit {National Imagery Transmission Format} if {[S 25 x {}]} {emit {dated %.14s}} } if {[S 0 == {\0\nSMJPEG}]} {emit SMJPEG if {[N I 8 x {}]} {emit {%d.x data}} if {[S 16 == _SND]} {emit {\b,} if {[N S 24 > 0x0]} {emit {%d Hz}} switch -- [Nv c 26] 8 {emit 8-bit} 16 {emit 16-bit} if {[S 28 == NONE]} {emit uncompressed} if {[N c 27 == 0x1]} {emit mono} if {[N c 28 == 0x2]} {emit stereo} if {[S 32 == _VID]} {emit {\b,} if {[N I 40 > 0x0]} {emit {%d frames}} if {[N S 44 > 0x0]} {emit {\(%d x}} if {[N S 46 > 0x0]} {emit {%d\)}} } } if {[S 16 == _VID]} {emit {\b,} if {[N I 24 > 0x0]} {emit {%d frames}} if {[N S 28 > 0x0]} {emit {\(%d x}} if {[N S 30 > 0x0]} {emit {%d\)}} } } if {[S 0 == {Paint\ Shop\ Pro\ Image\ File}]} {emit {Paint Shop Pro Image File}} if {[S 0 == {P7\ 332}]} {emit {XV \"thumbnail file\" \(icon\) data}} if {[S 0 == KiSS]} {emit KISS/GS switch -- [Nv c 4] 16 {emit color if {[N c 5 x {}]} {emit {%d bit}} if {[N s 8 x {}]} {emit {%d colors}} if {[N s 10 x {}]} {emit {%d groups}} } 32 {emit cell if {[N c 5 x {}]} {emit {%d bit}} if {[N s 8 x {}]} {emit {%d x}} if {[N s 10 x {}]} {emit %d} if {[N s 12 x {}]} {emit +%d} if {[N s 14 x {}]} {emit +%d} } } if {[S 0 == {C\253\221g\230\0\0\0}]} {emit {Webshots Desktop .wbz file}} if {[S 0 == CKD_P370]} {emit {Hercules CKD DASD image file} if {[N Q 8 x {}]} {emit {\b, %d heads per cylinder}} if {[N Q 12 x {}]} {emit {\b, track size %d bytes}} if {[N c 16 x {}]} {emit {\b, device type 33%2.2X}} } if {[S 0 == CKD_C370]} {emit {Hercules compressed CKD DASD image file} if {[N Q 8 x {}]} {emit {\b, %d heads per cylinder}} if {[N Q 12 x {}]} {emit {\b, track size %d bytes}} if {[N c 16 x {}]} {emit {\b, device type 33%2.2X}} } if {[S 0 == CKD_S370]} {emit {Hercules CKD DASD shadow file} if {[N Q 8 x {}]} {emit {\b, %d heads per cylinder}} if {[N Q 12 x {}]} {emit {\b, track size %d bytes}} if {[N c 16 x {}]} {emit {\b, device type 33%2.2X}} } if {[S 0 == {\146\031\0\0}]} {emit {Squeak image data}} if {[S 0 == {'From\040Squeak}]} {emit {Squeak program text}} if {[S 0 == PaRtImAgE-VoLuMe]} {emit PartImage if {[S 32 == 0.6.1]} {emit {file version %s} if {[N i 96 > 0xffffffff]} {emit {volume %ld}} if {[S 512 x {}]} {emit {type %s}} if {[S 5120 x {}]} {emit {device %s,}} if {[S 5632 x {}]} {emit {original filename %s,}} switch -- [Nv i 10052] 0 {emit {not compressed}} 1 {emit {gzip compressed}} 2 {emit {bzip2 compressed}} if {[N i 10052 > 0x2]} {emit {compressed with unknown algorithm}} } if {[S 32 > 0.6.1]} {emit {file version %s}} if {[S 32 < 0.6.1]} {emit {file version %s}} } if {[N s 54 == 0x3039]} {emit {Bio-Rad .PIC Image File} if {[N s 0 > 0x0]} {emit {%hd x}} if {[N s 2 > 0x0]} {emit %hd,} if {[N s 4 == 0x1]} {emit {1 image in file}} if {[N s 4 > 0x1]} {emit {%hd images in file}} } if {[S 0 == {\000MRM}]} {emit {Minolta Dimage camera raw image data}} if {[S 0 == AT&TFORM]} {emit {DjVu Image file}} if {[S 0 == {CDF\001}]} {emit {NetCDF Data Format data}} if {[S 0 == {\211HDF\r\n\032}]} {emit {Hierarchical Data Format \(version 5\) data}} if {[S 0 == {\210OPS}]} {emit {Interleaf saved data}} if {[S 0 == 0x0]} {emit {and %d string characters}} } if {[N S 0 == 0x9600 &0xFFFC]} {emit {big endian ispell} switch -- [Nv c 1] 0 {emit {hash file \(?\),}} 1 {emit {3.0 hash file,}} 2 {emit {3.1 hash file,}} 3 {emit {hash file \(?\),}} switch -- [Nv S 2] 0 {emit {8-bit, no capitalization, 26 flags}} 1 {emit {7-bit, no capitalization, 26 flags}} 2 {emit {8-bit, capitalization, 26 flags}} 3 {emit {7-bit, capitalization, 26 flags}} 4 {emit {8-bit, no capitalization, 52 flags}} 5 {emit {7-bit, no capitalization, 52 flags}} 6 {emit {8-bit, capitalization, 52 flags}} 7 {emit {7-bit, capitalization, 52 flags}} 8 {emit {8-bit, no capitalization, 128 flags}} 9 {emit {7-bit, no capitalization, 128 flags}} 10 {emit {8-bit, capitalization, 128 flags}} 11 {emit {7-bit, capitalization, 128 flags}} 12 {emit {8-bit, no capitalization, 256 flags}} 13 {emit {7-bit, no capitalization, 256 flags}} 14 {emit {8-bit, capitalization, 256 flags}} 15 {emit {7-bit, capitalization, 256 flags}} if {[N S 4 > 0x0]} {emit {and %d string characters}} } if {[S 0 == ISPL]} {emit ispell if {[N Q 4 x {}]} {emit {hash file version %d,}} if {[N Q 8 x {}]} {emit {lexletters %d,}} if {[N Q 12 x {}]} {emit {lexsize %d,}} if {[N Q 16 x {}]} {emit {hashsize %d,}} if {[N Q 20 x {}]} {emit {stblsize %d}} } if {[S 0 == hsi1]} {emit {JPEG image data, HSI proprietary}} if {[S 0 == {\x00\x00\x00\x0C\x6A\x50\x20\x20\x0D\x0A\x87\x0A}]} {emit {JPEG 2000 image data}} if {[S 0 == KarmaRHD]} {emit {Version Karma Data Structure Version} if {[N I 16 x {}]} {emit %lu} } if {[S 0 == lect]} {emit {DEC SRC Virtual Paper Lectern file}} if {[S 53 == yyprevious]} {emit {C program text \(from lex\)} if {[S 3 x {}]} {emit {for %s}} } if {[S 21 == {generated\ by\ flex}]} {emit {C program text \(from flex\)}} if {[S 0 == {%\{}]} {emit {lex description text}} if {[S 0 == {\007\001\000}]} {emit {Linux/i386 object file} if {[N i 20 > 0x1020]} {emit {\b, DLL library}} } if {[S 0 == {\01\03\020\04}]} {emit {Linux-8086 impure executable} if {[N Q 28 != 0x0]} {emit {not stripped}} } if {[S 0 == {\01\03\040\04}]} {emit {Linux-8086 executable} if {[N Q 28 != 0x0]} {emit {not stripped}} } if {[S 0 == {\243\206\001\0}]} {emit {Linux-8086 object file}} if {[S 0 == {\01\03\020\20}]} {emit {Minix-386 impure executable} if {[N Q 28 != 0x0]} {emit {not stripped}} } if {[S 0 == {\01\03\040\20}]} {emit {Minix-386 executable} if {[N Q 28 != 0x0]} {emit {not stripped}} } if {[N i 216 == 0x111]} {emit {Linux/i386 core file} if {[S 220 x {}]} {emit {of '%s'}} if {[N i 200 > 0x0]} {emit {\(signal %d\)}} } if {[S 2 == LILO]} {emit {Linux/i386 LILO boot/chain loader}} if {[S 4086 == SWAP-SPACE]} {emit {Linux/i386 swap file}} if {[S 4086 == SWAPSPACE2]} {emit {Linux/i386 swap file \(new style\)} if {[N Q 1024 x {}]} {emit {%d \(4K pages\)}} if {[N Q 1028 x {}]} {emit {size %d pages}} } if {[S 514 == HdrS]} {emit {Linux kernel} if {[N s 510 == 0xaa55]} {emit {x86 boot executable} if {[N c 529 == 0x0]} {emit zImage, if {[N c 529 == 0x1]} {emit bzImage,} if {[S [I 526 s 512] x {}]} {emit {version %s,}} } switch -- [Nv s 498] 1 {emit RO-rootFS,} 0 {emit RW-rootFS,} if {[N s 508 > 0x0]} {emit {root_dev 0x%X,}} if {[N s 502 > 0x0]} {emit {swap_dev 0x%X,}} if {[N s 504 > 0x0]} {emit {RAMdisksize %u KB,}} switch -- [Nv s 506] -1 {emit {Normal VGA}} -2 {emit {Extended VGA}} -3 {emit {Prompt for Videomode}} if {[N s 506 > 0x0]} {emit {Video mode %d}} } } if {[S 8 == {\ A\ _text}]} {emit {Linux kernel symbol map text}} if {[S 0 == Begin3]} {emit {Linux Software Map entry text}} if {[S 0 == Begin4]} {emit {Linux Software Map entry text \(new format\)}} if {[S 0 == {\xb8\xc0\x07\x8e\xd8\xb8\x00\x90}]} {emit Linux if {[N s 497 == 0x0]} {emit {x86 boot sector} switch -- [Nv I 514] 142 {emit {of a kernel from the dawn of time!}} -1869686604 {emit {version 0.99-1.1.42}} -1869686600 {emit {for memtest86}} } if {[N s 497 != 0x0]} {emit {x86 kernel} if {[N s 504 > 0x0]} {emit {RAMdisksize=%u KB}} if {[N s 502 > 0x0]} {emit swap=0x%X} if {[N s 508 > 0x0]} {emit root=0x%X switch -- [Nv s 498] 1 {emit {\b-ro}} 0 {emit {\b-rw}} } switch -- [Nv s 506] -1 {emit vga=normal} -2 {emit vga=extended} -3 {emit vga=ask} if {[N s 506 > 0x0]} {emit vga=%d} switch -- [Nv I 514] -1869686655 {emit {version 1.1.43-1.1.45}} 364020173 {emit {} if {[N I 2702 == 0x55aa5a5a]} {emit {version 1.1.46-1.2.13,1.3.0}} if {[N I 2713 == 0x55aa5a5a]} {emit {version 1.3.1,2}} if {[N I 2723 == 0x55aa5a5a]} {emit {version 1.3.3-1.3.30}} if {[N I 2726 == 0x55aa5a5a]} {emit {version 1.3.31-1.3.41}} if {[N I 2859 == 0x55aa5a5a]} {emit {version 1.3.42-1.3.45}} if {[N I 2807 == 0x55aa5a5a]} {emit {version 1.3.46-1.3.72}} } if {[S 514 == HdrS]} {if {[N s 518 > 0x1ff]} {switch -- [Nv c 529] 0 {emit {\b, zImage}} 1 {emit {\b, bzImage}} if {[S [I 526 s 512] x {}]} {emit {\b, version %s}} } } } } if {[N i 0 == 0xc30000e9 &0xFF0000FF]} {emit {Linux-Dev86 executable, headerless} if {[S 5 == .]} {if {[S 4 x {}]} {emit {\b, libc version %s}} } } if {[N i 0 == 0x4000301 &0xFF00FFFF]} {emit {Linux-8086 executable} if {[N c 2 != 0x0 &0x01]} {emit {\b, unmapped zero page}} if {[N c 2 == 0x0 &0x20]} {emit {\b, impure}} if {[N c 2 != 0x0 &0x20]} {if {[N c 2 != 0x0 &0x10]} {emit {\b, A_EXEC}} } if {[N c 2 != 0x0 &0x02]} {emit {\b, A_PAL}} if {[N c 2 != 0x0 &0x04]} {emit {\b, A_NSYM}} if {[N c 2 != 0x0 &0x08]} {emit {\b, A_STAND}} if {[N c 2 != 0x0 &0x40]} {emit {\b, A_PURE}} if {[N c 2 != 0x0 &0x80]} {emit {\b, A_TOVLY}} if {[N Q 28 != 0x0]} {emit {\b, not stripped}} if {[S 37 == .]} {if {[S 36 x {}]} {emit {\b, libc version %s}} } } if {[S 0 == {;;}]} {emit {Lisp/Scheme program text}} if {[S 0 == {\012(}]} {emit {Emacs v18 byte-compiled Lisp data}} if {[S 0 == {;ELC}]} {if {[N c 4 > 0x13]} {emit 636 0} if {[N c 4 < 0x20]} {emit {Emacs/XEmacs v%d byte-compiled Lisp data}} } if {[S 0 == {(SYSTEM::VERSION\040'}]} {emit {CLISP byte-compiled Lisp program text}} if {[S 0 == {\372\372\372\372}]} {emit {MIT scheme \(library?\)}} if {[S 0 == 0x0 -0x7C25B080]} {emit {last backup: %s,}} if {[N I 1044 x {}]} {emit {block size: %d,}} if {[N S 1042 x {}]} {emit {number of blocks: %d,}} if {[S 1060 x {} p]} {emit {volume name: %s}} } 18475 {emit {Macintosh HFS Extended} if {[N S [R 0] x {}]} {emit {version %d data}} if {[N S 0 == 0x4c4b]} {emit {\(bootable\)}} if {[N I 1028 ^ 0x100]} {emit {\(mounted\)}} if {[N I [R 2] & 0x200]} {emit {\(spared blocks\)}} if {[N I [R 2] & 0x800]} {emit {\(unclean\)}} if {[N I [R 2] & 0x8000]} {emit {\(locked\)}} if {[S [R 6] x {}]} {emit {last mounted by: '%.4s',}} if {[N I [R 14] x {} -0x7C25B080]} {emit {created: %s,}} if {[N S [R 18] x {} -0x7C25B080]} {emit {last modified: %s,}} if {[N S [R 22] > 0x0 -0x7C25B080]} {emit {last backup: %s,}} if {[N S [R 26] > 0x0 -0x7C25B080]} {emit {last checked: %s,}} if {[N I [R 38] x {}]} {emit {block size: %d,}} if {[N I [R 42] x {}]} {emit {number of blocks: %d,}} if {[N I [R 46] x {}]} {emit {free blocks: %d}} } switch -- [Nv S 512] 20557 {emit {Apple Partition data} if {[N S 2 x {}]} {emit {block size: %d,}} if {[S 560 x {}]} {emit {first type: %s,}} if {[S 528 x {}]} {emit {name: %s,}} if {[N I 596 x {}]} {emit {number of blocks: %d,}} if {[N S 1024 == 0x504d]} {if {[S 1072 x {}]} {emit {second type: %s,}} if {[S 1040 x {}]} {emit {name: %s,}} if {[N I 1108 x {}]} {emit {number of blocks: %d,}} if {[N S 2048 == 0x504d]} {if {[S 2096 x {}]} {emit {third type: %s,}} if {[S 2064 x {}]} {emit {name: %s,}} if {[N I 2132 x {}]} {emit {number of blocks: %d,}} if {[N S 2560 == 0x504d]} {if {[S 2608 x {}]} {emit {fourth type: %s,}} if {[S 2576 x {}]} {emit {name: %s,}} if {[N I 2644 x {}]} {emit {number of blocks: %d}} } } } } 21587 {emit {Apple Old Partition data} if {[N S 2 x {}]} {emit {block size: %d,}} if {[S 560 x {}]} {emit {first type: %s,}} if {[S 528 x {}]} {emit {name: %s,}} if {[N I 596 x {}]} {emit {number of blocks: %d,}} if {[N S 1024 == 0x504d]} {if {[S 1072 x {}]} {emit {second type: %s,}} if {[S 1040 x {}]} {emit {name: %s,}} if {[N I 1108 x {}]} {emit {number of blocks: %d,}} if {[N S 2048 == 0x504d]} {if {[S 2096 x {}]} {emit {third type: %s,}} if {[S 2064 x {}]} {emit {name: %s,}} if {[N I 2132 x {}]} {emit {number of blocks: %d,}} if {[N S 2560 == 0x504d]} {if {[S 2608 x {}]} {emit {fourth type: %s,}} if {[S 2576 x {}]} {emit {name: %s,}} if {[N I 2644 x {}]} {emit {number of blocks: %d}} } } } } if {[S 0 == BOMStore]} {emit {Mac OS X bill of materials \(BOM\) fil}} if {[S 0 == {\#\ Magic}]} {emit {magic text file for file\(1\) cmd}} if {[S 0 == Relay-Version:]} {emit {old news text}} if {[S 0 == {\#!\ rnews}]} {emit {batched news text}} if {[S 0 == {N\#!\ rnews}]} {emit {mailed, batched news text}} if {[S 0 == {Forward\ to}]} {emit {mail forwarding text}} if {[S 0 == {Pipe\ to}]} {emit {mail piping text}} if {[S 0 == Return-Path:]} {emit {smtp mail text}} if {[S 0 == Path:]} {emit {news text}} if {[S 0 == Xref:]} {emit {news text}} if {[S 0 == From:]} {emit {news or mail text}} if {[S 0 == Article]} {emit {saved news text}} if {[S 0 == BABYL]} {emit {Emacs RMAIL text}} if {[S 0 == Received:]} {emit {RFC 822 mail text}} if {[S 0 == MIME-Version:]} {emit {MIME entity text}} if {[S 0 == *mbx*]} {emit {MBX mail folder}} if {[S 0 == {\241\002\213\015skiplist\ file\0\0\0}]} {emit {Cyrus skiplist DB}} if {[S 0 == {JAM\0}]} {emit {JAM message area header file} if {[N s 12 > 0x0]} {emit {\(%d messages\)}} } if {[S 0 == {\000MVR4\nI}]} {emit {MapleVr4 library}} if {[S 0 == {\000\004\000\000}]} {emit {Maple help database}} if {[S 0 == }]} {emit {Maple something anomalous.}} if {[S 0 == {\064\024\012\000\035\000\000\000}]} {emit {Mathematica version 2 notebook}} if {[S 0 == {\064\024\011\000\035\000\000\000}]} {emit {Mathematica version 2 notebook}} if {[S 0 == {(*^\n\n::[\011frontEndVersion\ =\ }]} {emit {Mathematica notebook}} if {[S 0 == {(*^\r\r::[\011}]} {emit {Mathematica notebook version 2.x}} if {[S 0 == {\(\*\^\r\n\r\n\:\:\[\011}]} {emit {Mathematica notebook version 2.x}} if {[S 0 == {(*^\015}]} {emit {Mathematica notebook version 2.x}} if {[S 0 == {(*^\n\r\n\r::[\011}]} {emit {Mathematica notebook version 2.x}} if {[S 0 == {(*^\r::[\011}]} {emit {Mathematica notebook version 2.x}} if {[S 0 == {(*^\r\n::[\011}]} {emit {Mathematica notebook version 2.x}} if {[S 0 == {(*^\n\n::[\011}]} {emit {Mathematica notebook version 2.x}} if {[S 0 == {(*^\n::[\011}]} {emit {Mathematica notebook version 2.x}} if {[S 0 == {(*This\ is\ a\ Mathematica\ binary\ }]} {emit {Mathematica binary file} if {[S 88 x {}]} {emit {from %s}} } if {[S 0 == {MMAPBF\000\001\000\000\000\203\000\001\000}]} {emit {Mathematica PBF \(fonts I think\)}} if {[S 4 == {\ A~}]} {emit {MAthematica .ml file}} if {[S 0 == (***********************]} {emit {Mathematica 3.0 notebook}} if {[S 0 == (*]} {emit {Mathematica, or Pascal, Modula-2 or 3 code text}} if {[S 0 == MATLAB]} {emit {Matlab v5 mat-file} switch -- [Nv Y 126] 18765 {emit {\(big endian\)} if {[N S 124 x {}]} {emit {version 0x%04x}} } 19785 {emit {\(little endian\)} if {[N s 124 x {}]} {emit {version 0x%04x}} } } if {[S 0 == {\0m\3}]} {emit {mcrypt 2.5 encrypted data,} if {[Sx 2 4 x {}]} {emit {algorithm: %s,} if {[Nx 3 s [R 1] > 0x0]} {emit {keysize: %d bytes,} if {[S [R 0] x {}]} {emit {mode: %s,}} } } } if {[S 0 == {\0m\2}]} {emit {mcrypt 2.2 encrypted data,} switch -- [Nv c 3] 0 {emit {algorithm: blowfish-448,}} 1 {emit {algorithm: DES,}} 2 {emit {algorithm: 3DES,}} 3 {emit {algorithm: 3-WAY,}} 4 {emit {algorithm: GOST,}} 6 {emit {algorithm: SAFER-SK64,}} 7 {emit {algorithm: SAFER-SK128,}} 8 {emit {algorithm: CAST-128,}} 9 {emit {algorithm: xTEA,}} 10 {emit {algorithm: TWOFISH-128,}} 11 {emit {algorithm: RC2,}} 12 {emit {algorithm: TWOFISH-192,}} 13 {emit {algorithm: TWOFISH-256,}} 14 {emit {algorithm: blowfish-128,}} 15 {emit {algorithm: blowfish-192,}} 16 {emit {algorithm: blowfish-256,}} 100 {emit {algorithm: RC6,}} 101 {emit {algorithm: IDEA,}} switch -- [Nv c 4] 0 {emit {mode: CBC,}} 1 {emit {mode: ECB,}} 2 {emit {mode: CFB,}} 3 {emit {mode: OFB,}} 4 {emit {mode: nOFB,}} switch -- [Nv c 5] 0 {emit {keymode: 8bit}} 1 {emit {keymode: 4bit}} 2 {emit {keymode: SHA-1 hash}} 3 {emit {keymode: MD5 hash}} } if {[S 0 == {Content-Type:\ }]} {if {[S 14 x {}]} {emit %s} } if {[S 0 == Content-Type:]} {if {[S 13 x {}]} {emit %s} } if {[S 0 == kbd!map]} {emit {kbd map file} if {[N c 8 > 0x0]} {emit {Ver %d:}} if {[N Y 10 > 0x0]} {emit {with %d table\(s\)}} } if {[S 0 == {\x43\x72\x73\x68\x44\x75\x6d\x70}]} {emit {IRIX vmcore dump of} if {[S 36 x {}]} {emit '%s'} } if {[S 0 == SGIAUDIT]} {emit {SGI Audit file} if {[N c 8 x {}]} {emit {- version %d}} if {[N c 9 x {}]} {emit .%ld} } if {[S 0 == WNGZWZSC]} {emit {Wingz compiled script}} if {[S 0 == WNGZWZSS]} {emit {Wingz spreadsheet}} if {[S 0 == WNGZWZHP]} {emit {Wingz help file}} if {[S 0 == {\\#Inventor}]} {emit {V IRIS Inventor 1.0 file}} if {[S 0 == {\\#Inventor}]} {emit {V2 Open Inventor 2.0 file}} if {[S 0 == {glfHeadMagic();}]} {emit GLF_TEXT} if {[S 0 == glsBeginGLS(]} {emit GLS_TEXT} if {[S 0 == %%!!]} {emit {X-Post-It-Note text}} if {[S 0 == BEGIN:VCALENDAR]} {emit {vCalendar calendar file}} if {[S 0 == {\311\304}]} {emit {ID tags data} if {[N Y 2 > 0x0]} {emit {version %d}} } if {[S 0 == {\001\001\001\001}]} {emit {MMDF mailbox}} if {[S 4 == Research,]} {emit Digifax-G3-File switch -- [Nv c 29] 1 {emit {, fine resolution}} 0 {emit {, normal resolution}} } if {[S 0 == RMD1]} {emit {raw modem data} if {[S 4 x {}]} {emit {\(%s /}} if {[N Y 20 > 0x0]} {emit {compression type 0x%04x\)}} } if {[S 0 == {PVF1\n}]} {emit {portable voice format} if {[S 5 x {}]} {emit {\(binary %s\)}} } if {[S 0 == {PVF2\n}]} {emit {portable voice format} if {[S 5 x {}]} {emit {\(ascii %s\)}} } if {[S 0 == S0]} {emit {Motorola S-Record; binary data in text format}} switch -- [Nv I 0 &0xFFFFFFF0] 1612316672 {emit {Atari ST M68K contiguous executable} if {[N I 2 x {}]} {emit {\(txt=%ld,}} if {[N I 6 x {}]} {emit dat=%ld,} if {[N I 10 x {}]} {emit bss=%ld,} if {[N I 14 x {}]} {emit {sym=%ld\)}} } 1612382208 {emit {Atari ST M68K non-contig executable} if {[N I 2 x {}]} {emit {\(txt=%ld,}} if {[N I 6 x {}]} {emit dat=%ld,} if {[N I 10 x {}]} {emit bss=%ld,} if {[N I 14 x {}]} {emit {sym=%ld\)}} } if {[S 0 == {@echo\ off} c]} {emit {MS-DOS batch file text}} if {[S 128 == {PE\0\0}]} {emit {MS Windows PE} if {[N s 150 > 0x0 &0x0100]} {emit 32-bit} switch -- [Nv s 132] 0 {emit {unknown processor}} 332 {emit {Intel 80386}} 358 {emit {MIPS R4000}} 388 {emit Alpha} 616 {emit {Motorola 68000}} 496 {emit PowerPC} 656 {emit PA-RISC} if {[N s 148 > 0x1b]} {switch -- [Nv s 220] 0 {emit {unknown subsystem}} 1 {emit native} 2 {emit GUI} 3 {emit console} 7 {emit POSIX} } if {[N s 150 == 0x0 &0x2000]} {emit executable if {[N s 150 > 0x0 &0x0001]} {emit {not relocatable}} if {[N s 150 > 0x0 &0x1000]} {emit {system file}} } if {[N s 150 > 0x0 &0x2000]} {emit DLL if {[N s 150 > 0x0 &0x0001]} {emit {not relocatable}} if {[N s 150 > 0x0 &0x1000]} {emit {system file}} } } if {[S 0 == MZ]} {emit {MS-DOS executable \(EXE\)} if {[S 24 == @]} {emit {\b, OS/2 or MS Windows} if {[S 231 == {LH/2\ Self-Extract}]} {emit {\b, %s}} if {[S 233 == PKSFX2]} {emit {\b, %s}} if {[S 122 == {Windows\ self-extracting\ ZIP}]} {emit {\b, %s}} } if {[S 28 == {RJSX\xff\xff}]} {emit {\b, ARJ SFX}} if {[S 28 == {diet\xf9\x9c}]} {emit {\b, diet compressed}} if {[S 28 == LZ09]} {emit {\b, LZEXE v0.90 compressed}} if {[S 28 == LZ91]} {emit {\b, LZEXE v0.91 compressed}} if {[S 30 == {Copyright\ 1989-1990\ PKWARE\ Inc.}]} {emit {\b, PKSFX}} if {[S 30 == {PKLITE\ Copr.}]} {emit {\b, %.6s compressed}} if {[S 36 == {LHa's\ SFX}]} {emit {\b, %.15s}} if {[S 36 == {LHA's\ SFX}]} {emit {\b, %.15s}} if {[S 1638 == -lh5-]} {emit {\b, LHa SFX archive v2.13S}} if {[S 7195 == Rar!]} {emit {\b, RAR self-extracting archive}} if {[S 11696 == {PK\003\004}]} {emit {\b, PKZIP SFX archive v1.1}} if {[S 13297 == {PK\003\004}]} {emit {\b, PKZIP SFX archive v1.93a}} if {[S 15588 == {PK\003\004}]} {emit {\b, PKZIP2 SFX archive v1.09}} if {[S 15770 == {PK\003\004}]} {emit {\b, PKZIP SFX archive v2.04g}} if {[S 28374 == {PK\003\004}]} {emit {\b, PKZIP2 SFX archive v1.02}} if {[S 25115 == {PK\003\004}]} {emit {\b, Info-ZIP SFX archive v5.12}} if {[S 26331 == {PK\003\004}]} {emit {\b, Info-ZIP SFX archive v5.12 w/decryption}} if {[S 47031 == {PK\003\004}]} {emit {\b, Info-ZIP SFX archive v5.12}} if {[S 49845 == {PK\003\004}]} {emit {\b, Info-ZIP SFX archive v5.12 w/decryption}} if {[S 69120 == {PK\003\004}]} {emit {\b, Info-ZIP NT SFX archive v5.12 w/decryption}} if {[S 49801 == {\x79\xff\x80\xff\x76\xff}]} {emit {\b, CODEC archive v3.21} if {[N s 49824 == 0x1]} {emit {\b, 1 file}} if {[N s 49824 > 0x1]} {emit {\b, %u files}} } } if {[S 0 == LZ]} {emit {MS-DOS executable \(built-in\)}} if {[S 0 == regf]} {emit {Windows NT registry file}} if {[S 0 == CREG]} {emit {Windows 95 registry file}} if {[S 0 == {\320\317\021\340\241\261\032\341AAFB\015\000OM\006\016\053\064\001\001\001\377}]} {emit {AAF legacy file using MS Structured Storage} switch -- [Nv c 30] 9 {emit {\(512B sectors\)}} 12 {emit {\(4kB sectors\)}} } if {[S 0 == {\320\317\021\340\241\261\032\341\001\002\001\015\000\002\000\000\006\016\053\064\003\002\001\001}]} {emit {AAF file using MS Structured Storage} switch -- [Nv c 30] 9 {emit {\(512B sectors\)}} 12 {emit {\(4kB sectors\)}} } if {[S 2080 == {Microsoft\ Word\ 6.0\ Document}]} {emit %s} if {[S 2080 == {Documento\ Microsoft\ Word\ 6}]} {emit {Spanish Microsoft Word 6 document data}} if {[S 2112 == MSWordDoc]} {emit {Microsoft Word document data}} if {[S 0 == PO^Q`]} {emit {Microsoft Word 6.0 Document}} if {[S 0 == {\376\067\0\043}]} {emit {Microsoft Office Document}} if {[S 0 == {\320\317\021\340\241\261\032\341}]} {emit {Microsoft Office Document}} if {[S 0 == {\333\245-\0\0\0}]} {emit {Microsoft Office Document}} if {[S 2080 == {Microsoft\ Excel\ 5.0\ Worksheet}]} {emit %s} if {[S 2080 == {Foglio\ di\ lavoro\ Microsoft\ Exce}]} {emit %s} if {[S 2114 == Biff5]} {emit {Microsoft Excel 5.0 Worksheet}} if {[S 2121 == Biff5]} {emit {Microsoft Excel 5.0 Worksheet}} if {[S 0 == {\x09\x04\x06\x00\x00\x00\x10\x00}]} {emit {Microsoft Excel Worksheet}} if {[S 0 == {?_\3\0}]} {emit {MS Windows Help Data}} if {[S 0 == {\161\250\000\000\001\002}]} {emit {DeIsL1.isu whatever that is}} if {[S 0 == {Nullsoft\ AVS\ Preset\ }]} {emit {Winamp plug in}} if {[S 0 == {HyperTerminal\ }]} {emit hyperterm if {[S 15 == {1.0\ --\ HyperTerminal\ data\ file}]} {emit {MS-windows Hyperterminal}} } if {[S 0 == {\327\315\306\232\000\000\000\000\000\000}]} {emit {ms-windows metafont .wmf}} if {[S 0 == {\003\001\001\004\070\001\000\000}]} {emit {tz3 ms-works file}} if {[S 0 == {\003\002\001\004\070\001\000\000}]} {emit {tz3 ms-works file}} if {[S 0 == {\003\003\001\004\070\001\000\000}]} {emit {tz3 ms-works file}} if {[S 0 == {\211\000\077\003\005\000\063\237\127\065\027\266\151\064\005\045\101\233\021\002}]} {emit {PGP sig}} if {[S 0 == {\211\000\077\003\005\000\063\237\127\066\027\266\151\064\005\045\101\233\021\002}]} {emit {PGP sig}} if {[S 0 == {\211\000\077\003\005\000\063\237\127\067\027\266\151\064\005\045\101\233\021\002}]} {emit {PGP sig}} if {[S 0 == {\211\000\077\003\005\000\063\237\127\070\027\266\151\064\005\045\101\233\021\002}]} {emit {PGP sig}} if {[S 0 == {\211\000\077\003\005\000\063\237\127\071\027\266\151\064\005\045\101\233\021\002}]} {emit {PGP sig}} if {[S 0 == {\211\000\225\003\005\000\062\122\207\304\100\345\042}]} {emit {PGP sig}} if {[S 0 == {MDIF\032\000\010\000\000\000\372\046\100\175\001\000\001\036\001\000}]} {emit {Ms-windows special zipped file}} if {[S 0 == {\164\146\115\122\012\000\000\000\001\000\000\000}]} {emit {ms-windows help cache}} if {[S 0 == {\120\115\103\103}]} {emit {Ms-windows 3.1 group files}} if {[S 0 == {\114\000\000\000\001\024\002\000\000\000\000\000\300\000\000\000\000\000\000\106}]} {emit {ms-Windows shortcut}} if {[S 0 == {\102\101\050\000\000\000\056\000\000\000\000\000\000\000}]} {emit {Icon for ms-windows}} if {[S 0 == {\000\000\001\000}]} {emit {ms-windows icon resource} if {[N c 4 == 0x1]} {emit {- 1 icon}} if {[N c 4 > 0x1]} {emit {- %d icons} if {[N c 6 > 0x0]} {emit {\b, %dx} if {[N c 7 > 0x0]} {emit {\b%d}} } if {[N c 8 == 0x0]} {emit {\b, 256-colors}} if {[N c 8 > 0x0]} {emit {\b, %d-colors}} } } if {[S 0 == {PK\010\010BGI}]} {emit {Borland font} if {[S 4 x {}]} {emit %s} } if {[S 0 == {pk\010\010BGI}]} {emit {Borland device} if {[S 4 x {}]} {emit %s} } if {[S 9 == {\000\000\000\030\001\000\000\000}]} {emit {ms-windows recycled bin info}} if {[S 9 == GERBILDOC]} {emit {First Choice document}} if {[S 9 == GERBILDB]} {emit {First Choice database}} if {[S 9 == GERBILCLIP]} {emit {First Choice database}} if {[S 0 == GERBIL]} {emit {First Choice device file}} if {[S 9 == RABBITGRAPH]} {emit {RabbitGraph file}} if {[S 0 == DCU1]} {emit {Borland Delphi .DCU file}} if {[S 0 == !]} {emit {MKS Spell hash list \(old format\)}} if {[S 0 == !]} {emit {MKS Spell hash list}} if {[S 0 == PMCC]} {emit {Windows 3.x .GRP file}} if {[S 1 == RDC-meg]} {emit MegaDots if {[N c 8 > 0x2f]} {emit {version %c}} if {[N c 9 > 0x2f]} {emit {\b.%c file}} } if {[S 0 == {ITSF\003\000\000\000\x60\000\000\000\001\000\000\000}]} {emit {MS Windows HtmlHelp Data}} if {[S 2 == GFA-BASIC3]} {emit {GFA-BASIC 3 data}} if {[S 512 == go32stub]} {emit {DOS-executable compiled w/DJGPP} if {[S 524 > 0]} {emit {\(stub v%.4s\)} if {[Sx 3 2226 == djp]} {emit {[compressed w/%s} if {[S [R 1] x {}]} {emit %.4s\]} } if {[Sx 3 2221 == UPX]} {emit {[compressed w/%s} if {[S [R 1] x {}]} {emit %.4s\]} } if {[S 28 == pmodedj]} {emit {stubbed with %s}} } } if {[S 0 == {MSCF\0\0\0\0}]} {emit {Microsoft Cabinet file} if {[N i 8 x {}]} {emit {\b, %u bytes}} if {[N s 28 == 0x1]} {emit {\b, 1 file}} if {[N s 28 > 0x1]} {emit {\b, %u files}} } if {[S 0 == ISc(]} {emit {InstallShield Cabinet file} if {[N c 5 == 0x60 &0xf0]} {emit {version 6,}} if {[N c 5 != 0x60 &0xf0]} {emit {version 4/5,}} if {[N i [I 12 i 40] x {}]} {emit {%u files}} } if {[S 0 == {MSCE\0\0\0\0}]} {emit {Microsoft WinCE install header} switch -- [Nv i 20] 0 {emit {\b, architecture-independent}} 103 {emit {\b, Hitachi SH3}} 104 {emit {\b, Hitachi SH4}} 2577 {emit {\b, StrongARM}} 4000 {emit {\b, MIPS R4000}} 10003 {emit {\b, Hitachi SH3}} 10004 {emit {\b, Hitachi SH3E}} 10005 {emit {\b, Hitachi SH4}} 70001 {emit {\b, ARM 7TDMI}} if {[N s 52 == 0x1]} {emit {\b, 1 file}} if {[N s 52 > 0x1]} {emit {\b, %u files}} if {[N s 56 == 0x1]} {emit {\b, 1 registry entry}} if {[N s 56 > 0x1]} {emit {\b, %u registry entries}} } if {[S 0 == {Client\ UrlCache\ MMF}]} {emit {Microsoft Internet Explorer Cache File} if {[S 20 x {}]} {emit {Version %s}} } if {[S 0 == {\xCF\xAD\x12\xFE}]} {emit {Microsoft Outlook Express DBX File} switch -- [Nv c 4] -59 {emit {Message database}} -58 {emit {Folder database}} -57 {emit {Accounts informations}} 48 {emit {Offline database}} } if {[N i 40 == 0x464d4520]} {emit {Windows Enhanced Metafile \(EMF\) image data} if {[N i 44 x {}]} {emit {version 0x%x.}} if {[N i 64 > 0x0]} {emit {Description available at offset 0x%x} if {[N i 60 > 0x0]} {emit {\(length 0x%x\)}} } } if {[S 0 == {HWB\000\377\001\000\000\000}]} {emit {Microsoft Visual C .APS file}} if {[S 0 == {\102\157\162\154\141\156\144\040\103\053\053\040\120\162\157}]} {emit {MSVC .ide}} if {[S 0 == {\000\000\000\000\040\000\000\000\377}]} {emit {MSVC .res}} if {[S 0 == {\377\003\000\377\001\000\020\020\350}]} {emit {MSVC .res}} if {[S 0 == {\377\003\000\377\001\000\060\020\350}]} {emit {MSVC .res}} if {[S 0 == {\360\015\000\000}]} {emit {Microsoft Visual C library}} if {[S 0 == {\360\075\000\000}]} {emit {Microsoft Visual C library}} if {[S 0 == {\360\175\000\000}]} {emit {Microsoft Visual C library}} if {[S 0 == {DTJPCH0\000\022\103\006\200}]} {emit {Microsoft Visual C .pch}} if {[S 0 == {Microsoft\ C/C++\ }]} {emit {MSVC program database} if {[S 18 == {program\ database\ }]} {emit 810 0} if {[S 33 x {}]} {emit {ver %s}} } if {[S 0 == {\000\002\000\007\000}]} {emit {MSVC .sbr} if {[S 5 x {}]} {emit %s} } if {[S 0 == {\002\000\002\001}]} {emit {MSVC .bsc}} if {[S 0 == {1.00\ .0000.0000\000\003}]} {emit {MSVC .wsp version 1.0000.0000}} if {[S 0 == RSRC]} {emit {National Instruments,} if {[S 8 == LV]} {emit {LabVIEW File,} if {[S 10 == SB]} {emit {Code Resource File, data}} if {[S 10 == IN]} {emit {Virtual Instrument Program, data}} if {[S 10 == AR]} {emit {VI Library, data}} } if {[S 8 == LMNULBVW]} {emit {Portable File Names, data}} if {[S 8 == rsc]} {emit {Resources File, data}} } if {[S 0 == VMAP]} {emit {National Instruments, VXI File, data}} switch -- [Nv I 0 &0377777777] 8782091 {emit {a.out NetBSD/i386 demand paged} if {[N c 0 & 0x80]} {if {[N i 20 < 0x1000]} {emit {shared library}} if {[N i 20 == 0x1000]} {emit {dynamically linked executable}} if {[N i 20 > 0x1000]} {emit {dynamically linked executable}} } if {[N c 0 ^ 0x80]} {emit executable} if {[N i 16 > 0x0]} {emit {not stripped}} } 8782088 {emit {a.out NetBSD/i386 pure} if {[N c 0 & 0x80]} {emit {dynamically linked executable}} if {[N c 0 ^ 0x80]} {emit executable} if {[N i 16 > 0x0]} {emit {not stripped}} } 8782087 {emit {a.out NetBSD/i386} if {[N c 0 & 0x80]} {emit {dynamically linked executable}} if {[N c 0 ^ 0x80]} {if {[N c 0 & 0x40]} {emit {position independent}} if {[N i 20 != 0x0]} {emit executable} if {[N i 20 == 0x0]} {emit {object file}} } if {[N i 16 > 0x0]} {emit {not stripped}} } 8782151 {emit {a.out NetBSD/i386 core} if {[S 12 x {}]} {emit {from '%s'}} if {[N i 32 != 0x0]} {emit {\(signal %d\)}} } 8847627 {emit {a.out NetBSD/m68k demand paged} if {[N c 0 & 0x80]} {if {[N I 20 < 0x2000]} {emit {shared library}} if {[N I 20 == 0x2000]} {emit {dynamically linked executable}} if {[N I 20 > 0x2000]} {emit {dynamically linked executable}} } if {[N c 0 ^ 0x80]} {emit executable} if {[N I 16 > 0x0]} {emit {not stripped}} } 8847624 {emit {a.out NetBSD/m68k pure} if {[N c 0 & 0x80]} {emit {dynamically linked executable}} if {[N c 0 ^ 0x80]} {emit executable} if {[N I 16 > 0x0]} {emit {not stripped}} } 8847623 {emit {a.out NetBSD/m68k} if {[N c 0 & 0x80]} {emit {dynamically linked executable}} if {[N c 0 ^ 0x80]} {if {[N c 0 & 0x40]} {emit {position independent}} if {[N I 20 != 0x0]} {emit executable} if {[N I 20 == 0x0]} {emit {object file}} } if {[N I 16 > 0x0]} {emit {not stripped}} } 8847687 {emit {a.out NetBSD/m68k core} if {[S 12 x {}]} {emit {from '%s'}} if {[N I 32 != 0x0]} {emit {\(signal %d\)}} } 8913163 {emit {a.out NetBSD/m68k4k demand paged} if {[N c 0 & 0x80]} {if {[N I 20 < 0x1000]} {emit {shared library}} if {[N I 20 == 0x1000]} {emit {dynamically linked executable}} if {[N I 20 > 0x1000]} {emit {dynamically linked executable}} } if {[N c 0 ^ 0x80]} {emit executable} if {[N I 16 > 0x0]} {emit {not stripped}} } 8913160 {emit {a.out NetBSD/m68k4k pure} if {[N c 0 & 0x80]} {emit {dynamically linked executable}} if {[N c 0 ^ 0x80]} {emit executable} if {[N I 16 > 0x0]} {emit {not stripped}} } 8913159 {emit {a.out NetBSD/m68k4k} if {[N c 0 & 0x80]} {emit {dynamically linked executable}} if {[N c 0 ^ 0x80]} {if {[N c 0 & 0x40]} {emit {position independent}} if {[N I 20 != 0x0]} {emit executable} if {[N I 20 == 0x0]} {emit {object file}} } if {[N I 16 > 0x0]} {emit {not stripped}} } 8913223 {emit {a.out NetBSD/m68k4k core} if {[S 12 x {}]} {emit {from '%s'}} if {[N I 32 != 0x0]} {emit {\(signal %d\)}} } 8978699 {emit {a.out NetBSD/ns32532 demand paged} if {[N c 0 & 0x80]} {if {[N i 20 < 0x1000]} {emit {shared library}} if {[N i 20 == 0x1000]} {emit {dynamically linked executable}} if {[N i 20 > 0x1000]} {emit {dynamically linked executable}} } if {[N c 0 ^ 0x80]} {emit executable} if {[N i 16 > 0x0]} {emit {not stripped}} } 8978696 {emit {a.out NetBSD/ns32532 pure} if {[N c 0 & 0x80]} {emit {dynamically linked executable}} if {[N c 0 ^ 0x80]} {emit executable} if {[N i 16 > 0x0]} {emit {not stripped}} } 8978695 {emit {a.out NetBSD/ns32532} if {[N c 0 & 0x80]} {emit {dynamically linked executable}} if {[N c 0 ^ 0x80]} {if {[N c 0 & 0x40]} {emit {position independent}} if {[N i 20 != 0x0]} {emit executable} if {[N i 20 == 0x0]} {emit {object file}} } if {[N i 16 > 0x0]} {emit {not stripped}} } 8978759 {emit {a.out NetBSD/ns32532 core} if {[S 12 x {}]} {emit {from '%s'}} if {[N i 32 != 0x0]} {emit {\(signal %d\)}} } 9765191 {emit {a.out NetBSD/powerpc core} if {[S 12 x {}]} {emit {from '%s'}} } 9044235 {emit {a.out NetBSD/sparc demand paged} if {[N c 0 & 0x80]} {if {[N I 20 < 0x2000]} {emit {shared library}} if {[N I 20 == 0x2000]} {emit {dynamically linked executable}} if {[N I 20 > 0x2000]} {emit {dynamically linked executable}} } if {[N c 0 ^ 0x80]} {emit executable} if {[N I 16 > 0x0]} {emit {not stripped}} } 9044232 {emit {a.out NetBSD/sparc pure} if {[N c 0 & 0x80]} {emit {dynamically linked executable}} if {[N c 0 ^ 0x80]} {emit executable} if {[N I 16 > 0x0]} {emit {not stripped}} } 9044231 {emit {a.out NetBSD/sparc} if {[N c 0 & 0x80]} {emit {dynamically linked executable}} if {[N c 0 ^ 0x80]} {if {[N c 0 & 0x40]} {emit {position independent}} if {[N I 20 != 0x0]} {emit executable} if {[N I 20 == 0x0]} {emit {object file}} } if {[N I 16 > 0x0]} {emit {not stripped}} } 9044295 {emit {a.out NetBSD/sparc core} if {[S 12 x {}]} {emit {from '%s'}} if {[N I 32 != 0x0]} {emit {\(signal %d\)}} } 9109771 {emit {a.out NetBSD/pmax demand paged} if {[N c 0 & 0x80]} {if {[N i 20 < 0x1000]} {emit {shared library}} if {[N i 20 == 0x1000]} {emit {dynamically linked executable}} if {[N i 20 > 0x1000]} {emit {dynamically linked executable}} } if {[N c 0 ^ 0x80]} {emit executable} if {[N i 16 > 0x0]} {emit {not stripped}} } 9109768 {emit {a.out NetBSD/pmax pure} if {[N c 0 & 0x80]} {emit {dynamically linked executable}} if {[N c 0 ^ 0x80]} {emit executable} if {[N i 16 > 0x0]} {emit {not stripped}} } 9109767 {emit {a.out NetBSD/pmax} if {[N c 0 & 0x80]} {emit {dynamically linked executable}} if {[N c 0 ^ 0x80]} {if {[N c 0 & 0x40]} {emit {position independent}} if {[N i 20 != 0x0]} {emit executable} if {[N i 20 == 0x0]} {emit {object file}} } if {[N i 16 > 0x0]} {emit {not stripped}} } 9109831 {emit {a.out NetBSD/pmax core} if {[S 12 x {}]} {emit {from '%s'}} if {[N i 32 != 0x0]} {emit {\(signal %d\)}} } 9175307 {emit {a.out NetBSD/vax 1k demand paged} if {[N c 0 & 0x80]} {if {[N i 20 < 0x1000]} {emit {shared library}} if {[N i 20 == 0x1000]} {emit {dynamically linked executable}} if {[N i 20 > 0x1000]} {emit {dynamically linked executable}} } if {[N c 0 ^ 0x80]} {emit executable} if {[N i 16 > 0x0]} {emit {not stripped}} } 9175304 {emit {a.out NetBSD/vax 1k pure} if {[N c 0 & 0x80]} {emit {dynamically linked executable}} if {[N c 0 ^ 0x80]} {emit executable} if {[N i 16 > 0x0]} {emit {not stripped}} } 9175303 {emit {a.out NetBSD/vax 1k} if {[N c 0 & 0x80]} {emit {dynamically linked executable}} if {[N c 0 ^ 0x80]} {if {[N c 0 & 0x40]} {emit {position independent}} if {[N i 20 != 0x0]} {emit executable} if {[N i 20 == 0x0]} {emit {object file}} } if {[N i 16 > 0x0]} {emit {not stripped}} } 9175367 {emit {a.out NetBSD/vax 1k core} if {[S 12 x {}]} {emit {from '%s'}} if {[N i 32 != 0x0]} {emit {\(signal %d\)}} } 9830667 {emit {a.out NetBSD/vax 4k demand paged} if {[N c 0 & 0x80]} {if {[N i 20 < 0x1000]} {emit {shared library}} if {[N i 20 == 0x1000]} {emit {dynamically linked executable}} if {[N i 20 > 0x1000]} {emit {dynamically linked executable}} } if {[N c 0 ^ 0x80]} {emit executable} if {[N i 16 > 0x0]} {emit {not stripped}} } 9830664 {emit {a.out NetBSD/vax 4k pure} if {[N c 0 & 0x80]} {emit {dynamically linked executable}} if {[N c 0 ^ 0x80]} {emit executable} if {[N i 16 > 0x0]} {emit {not stripped}} } 9830663 {emit {a.out NetBSD/vax 4k} if {[N c 0 & 0x80]} {emit {dynamically linked executable}} if {[N c 0 ^ 0x80]} {if {[N c 0 & 0x40]} {emit {position independent}} if {[N i 20 != 0x0]} {emit executable} if {[N i 20 == 0x0]} {emit {object file}} } if {[N i 16 > 0x0]} {emit {not stripped}} } 9830727 {emit {a.out NetBSD/vax 4k core} if {[S 12 x {}]} {emit {from '%s'}} if {[N i 32 != 0x0]} {emit {\(signal %d\)}} } 9240903 {emit {a.out NetBSD/alpha core} if {[S 12 x {}]} {emit {from '%s'}} if {[N i 32 != 0x0]} {emit {\(signal %d\)}} } 9306379 {emit {a.out NetBSD/mips demand paged} if {[N c 0 & 0x80]} {if {[N I 20 < 0x2000]} {emit {shared library}} if {[N I 20 == 0x2000]} {emit {dynamically linked executable}} if {[N I 20 > 0x2000]} {emit {dynamically linked executable}} } if {[N c 0 ^ 0x80]} {emit executable} if {[N I 16 > 0x0]} {emit {not stripped}} } 9306376 {emit {a.out NetBSD/mips pure} if {[N c 0 & 0x80]} {emit {dynamically linked executable}} if {[N c 0 ^ 0x80]} {emit executable} if {[N I 16 > 0x0]} {emit {not stripped}} } 9306375 {emit {a.out NetBSD/mips} if {[N c 0 & 0x80]} {emit {dynamically linked executable}} if {[N c 0 ^ 0x80]} {if {[N c 0 & 0x40]} {emit {position independent}} if {[N I 20 != 0x0]} {emit executable} if {[N I 20 == 0x0]} {emit {object file}} } if {[N I 16 > 0x0]} {emit {not stripped}} } 9306439 {emit {a.out NetBSD/mips core} if {[S 12 x {}]} {emit {from '%s'}} if {[N I 32 != 0x0]} {emit {\(signal %d\)}} } 9371915 {emit {a.out NetBSD/arm32 demand paged} if {[N c 0 & 0x80]} {if {[N i 20 < 0x1000]} {emit {shared library}} if {[N i 20 == 0x1000]} {emit {dynamically linked executable}} if {[N i 20 > 0x1000]} {emit {dynamically linked executable}} } if {[N c 0 ^ 0x80]} {emit executable} if {[N i 16 > 0x0]} {emit {not stripped}} } 9371912 {emit {a.out NetBSD/arm32 pure} if {[N c 0 & 0x80]} {emit {dynamically linked executable}} if {[N c 0 ^ 0x80]} {emit executable} if {[N i 16 > 0x0]} {emit {not stripped}} } 9371911 {emit {a.out NetBSD/arm32} if {[N c 0 & 0x80]} {emit {dynamically linked executable}} if {[N c 0 ^ 0x80]} {if {[N c 0 & 0x40]} {emit {position independent}} if {[N i 20 != 0x0]} {emit executable} if {[N i 20 == 0x0]} {emit {object file}} } if {[N i 16 > 0x0]} {emit {not stripped}} } 9371975 {emit {a.out NetBSD/arm core} if {[S 12 x {}]} {emit {from '%s'}} if {[N i 32 != 0x0]} {emit {\(signal %d\)}} } if {[S 0 == {\000\017\102\104\000\000\000\000\000\000\001\000\000\000\000\002\000\000\000\002\000\000\004\000}]} {emit {Netscape Address book}} if {[S 0 == {\000\017\102\111}]} {emit {Netscape Communicator address book}} if {[S 0 == {\#\ Netscape\ folder\ cache}]} {emit {Netscape folder cache}} if {[S 0 == {\000\036\204\220\000}]} {emit {Netscape folder cache}} if {[S 0 == SX961999]} {emit Net2phone} if {[S 0 == {JG\004\016\0\0\0\0}]} {emit ART} if {[S 0 == StartFontMetrics]} {emit {ASCII font metrics}} if {[S 0 == StartFont]} {emit {ASCII font bits}} switch -- [Nv I 8] 326773573 {emit {X11/NeWS bitmap font}} 326773576 {emit {X11/NeWS font family}} if {[S 0 == NPFF]} {emit {NItpicker Flow File} if {[N c 4 x {}]} {emit V%d.} if {[N c 5 x {}]} {emit %d} if {[N S 6 x {}]} {emit {started: %s}} if {[N S 10 x {}]} {emit {stopped: %s}} if {[N I 14 x {}]} {emit {Bytes: %u}} if {[N I 18 x {}]} {emit {Bytes1: %u}} if {[N I 22 x {}]} {emit {Flows: %u}} if {[N I 26 x {}]} {emit {Pkts: %u}} } if {[S 0 == Caml1999]} {emit {Objective caml} if {[S 8 == X]} {emit {exec file}} if {[S 8 == I]} {emit {interface file \(.cmi\)}} if {[S 8 == O]} {emit {object file \(.cmo\)}} if {[S 8 == A]} {emit {library file \(.cma\)}} if {[S 8 == Y]} {emit {native object file \(.cmx\)}} if {[S 8 == Z]} {emit {native library file \(.cmxa\)}} if {[S 8 == M]} {emit {abstract syntax tree implementation file}} if {[S 8 == N]} {emit {abstract syntax tree interface file}} if {[S 9 x {}]} {emit {\(Version %3.3s\).}} } if {[S 0 == Octave-1-L]} {emit {Octave binary data \(little endian\)}} if {[S 0 == Octave-1-B]} {emit {Octave binary data \(big endian\)}} if {[S 0 == {\177OLF}]} {emit OLF switch -- [Nv c 4] 0 {emit {invalid class}} 1 {emit 32-bit} 2 {emit 64-bit} switch -- [Nv c 7] 0 {emit {invalid os}} 1 {emit OpenBSD} 2 {emit NetBSD} 3 {emit FreeBSD} 4 {emit 4.4BSD} 5 {emit Linux} 6 {emit SVR4} 7 {emit esix} 8 {emit Solaris} 9 {emit Irix} 10 {emit SCO} 11 {emit Dell} 12 {emit NCR} switch -- [Nv c 5] 0 {emit {invalid byte order}} 1 {emit LSB switch -- [Nv s 16] 0 {emit {no file type,}} 1 {emit relocatable,} 2 {emit executable,} 3 {emit {shared object,}} 4 {emit {core file} if {[S [I 56 Q 204] x {}]} {emit {of '%s'}} if {[N i [I 56 Q 16] > 0x0]} {emit {\(signal %d\),}} } if {[N s 16 & 0xff00]} {emit processor-specific,} switch -- [Nv s 18] 0 {emit {no machine,}} 1 {emit {AT&T WE32100 - invalid byte order,}} 2 {emit {SPARC - invalid byte order,}} 3 {emit {Intel 80386,}} 4 {emit {Motorola 68000 - invalid byte order,}} 5 {emit {Motorola 88000 - invalid byte order,}} 6 {emit {Intel 80486,}} 7 {emit {Intel 80860,}} 8 {emit {MIPS R3000_BE - invalid byte order,}} 9 {emit {Amdahl - invalid byte order,}} 10 {emit {MIPS R3000_LE,}} 11 {emit {RS6000 - invalid byte order,}} 15 {emit {PA-RISC - invalid byte order,}} 16 {emit nCUBE,} 17 {emit VPP500,} 18 {emit SPARC32PLUS,} 20 {emit PowerPC,} -28634 {emit Alpha,} switch -- [Nv i 20] 0 {emit {invalid version}} 1 {emit {version 1}} if {[N i 36 == 0x1]} {emit {MathCoPro/FPU/MAU Required}} } 2 {emit MSB switch -- [Nv S 16] 0 {emit {no file type,}} 1 {emit relocatable,} 2 {emit executable,} 3 {emit {shared object,}} 4 {emit {core file,} if {[S [I 56 Q 204] x {}]} {emit {of '%s'}} if {[N I [I 56 Q 16] > 0x0]} {emit {\(signal %d\),}} } if {[N S 16 & 0xff00]} {emit processor-specific,} switch -- [Nv S 18] 0 {emit {no machine,}} 1 {emit {AT&T WE32100,}} 2 {emit SPARC,} 3 {emit {Intel 80386 - invalid byte order,}} 4 {emit {Motorola 68000,}} 5 {emit {Motorola 88000,}} 6 {emit {Intel 80486 - invalid byte order,}} 7 {emit {Intel 80860,}} 8 {emit {MIPS R3000_BE,}} 9 {emit Amdahl,} 10 {emit {MIPS R3000_LE - invalid byte order,}} 11 {emit RS6000,} 15 {emit PA-RISC,} 16 {emit nCUBE,} 17 {emit VPP500,} 18 {emit SPARC32PLUS,} 20 {emit {PowerPC or cisco 4500,}} 21 {emit {cisco 7500,}} 24 {emit {cisco SVIP,}} 25 {emit {cisco 7200,}} 36 {emit {cisco 12000,}} -28634 {emit Alpha,} switch -- [Nv I 20] 0 {emit {invalid version}} 1 {emit {version 1}} if {[N I 36 == 0x1]} {emit {MathCoPro/FPU/MAU Required}} } if {[S 8 x {}]} {emit {\(%s\)}} } if {[S 1 == InternetShortcut]} {emit {MS Windows 95 Internet shortcut text} if {[S 24 > {\ }]} {emit {\(URL=<%s>\)}} } if {[S 0 == {HSP\x01\x9b\x00}]} {emit {OS/2 INF} if {[S 107 > 0]} {emit {\(%s\)}} } if {[S 0 == {HSP\x10\x9b\x00}]} {emit {OS/2 HLP} if {[S 107 > 0]} {emit {\(%s\)}} } if {[S 0 == {\xff\xff\xff\xff\x14\0\0\0}]} {emit {OS/2 INI}} switch -- [Nv I 60] 1634758764 {emit {PalmOS application} if {[S 0 x {}]} {emit {\"%s\"}} } 1413830772 {emit {AportisDoc file} if {[S 0 x {}]} {emit {\"%s\"}} } 1212236619 {emit {HackMaster hack} if {[S 0 x {}]} {emit {\"%s\"}} } if {[S 60 == BVokBDIC]} {emit {BDicty PalmOS document} if {[S 0 x {}]} {emit {\"%s\"}} } if {[S 60 == DB99DBOS]} {emit {DB PalmOS document} if {[S 0 x {}]} {emit {\"%s\"}} } if {[S 60 == vIMGView]} {emit {FireViewer/ImageViewer PalmOS document} if {[S 0 x {}]} {emit {\"%s\"}} } if {[S 60 == PmDBPmDB]} {emit {HanDBase PalmOS document} if {[S 0 x {}]} {emit {\"%s\"}} } if {[S 60 == InfoINDB]} {emit {InfoView PalmOS document} if {[S 0 x {}]} {emit {\"%s\"}} } if {[S 60 == ToGoToGo]} {emit {iSilo PalmOS document} if {[S 0 x {}]} {emit {\"%s\"}} } if {[S 60 == JfDbJBas]} {emit {JFile PalmOS document} if {[S 0 x {}]} {emit {\"%s\"}} } if {[S 60 == JfDbJFil]} {emit {JFile Pro PalmOS document} if {[S 0 x {}]} {emit {\"%s\"}} } if {[S 60 == DATALSdb]} {emit {List PalmOS document} if {[S 0 x {}]} {emit {\"%s\"}} } if {[S 60 == Mdb1Mdb1]} {emit {MobileDB PalmOS document} if {[S 0 x {}]} {emit {\"%s\"}} } if {[S 60 == PNRdPPrs]} {emit {PeanutPress PalmOS document} if {[S 0 x {}]} {emit {\"%s\"}} } if {[S 60 == DataPlkr]} {emit {Plucker PalmOS document} if {[S 0 x {}]} {emit {\"%s\"}} } if {[S 60 == DataSprd]} {emit {QuickSheet PalmOS document} if {[S 0 x {}]} {emit {\"%s\"}} } if {[S 60 == SM01SMem]} {emit {SuperMemo PalmOS document} if {[S 0 x {}]} {emit {\"%s\"}} } if {[S 60 == DataTlPt]} {emit {TealDoc PalmOS document} if {[S 0 x {}]} {emit {\"%s\"}} } if {[S 60 == InfoTlIf]} {emit {TealInfo PalmOS document} if {[S 0 x {}]} {emit {\"%s\"}} } if {[S 60 == DataTlMl]} {emit {TealMeal PalmOS document} if {[S 0 x {}]} {emit {\"%s\"}} } if {[S 60 == DataTlPt]} {emit {TealPaint PalmOS document} if {[S 0 x {}]} {emit {\"%s\"}} } if {[S 60 == dataTDBP]} {emit {ThinkDB PalmOS document} if {[S 0 x {}]} {emit {\"%s\"}} } if {[S 60 == TdatTide]} {emit {Tides PalmOS document} if {[S 0 x {}]} {emit {\"%s\"}} } if {[S 60 == ToRaTRPW]} {emit {TomeRaider PalmOS document} if {[S 0 x {}]} {emit {\"%s\"}} } if {[S 60 == zTXT]} {emit {A GutenPalm zTXT e-book} if {[S 0 x {}]} {emit {\"%s\"}} switch -- [Nv c [I 78 I 0]] 0 {emit {} if {[N c [I 78 I 1] x {}]} {emit {\(v0.%02d\)}} } 1 {emit {} if {[N c [I 78 I 1] x {}]} {emit {\(v1.%02d\)} if {[N S [I 78 I 10] > 0x0]} {if {[N S [I 78 I 10] < 0x2]} {emit {- 1 bookmark}} if {[N S [I 78 I 10] > 0x1]} {emit {- %d bookmarks}} } if {[N S [I 78 I 14] > 0x0]} {if {[N S [I 78 I 14] < 0x2]} {emit {- 1 annotation}} if {[N S [I 78 I 14] > 0x1]} {emit {- %d annotations}} } } } if {[N c [I 78 I 0] > 0x1]} {emit {\(v%d.} if {[N c [I 78 I 1] x {}]} {emit {%02d\)}} } } if {[S 60 == libr]} {emit {Palm OS dynamic library data} if {[S 0 x {}]} {emit {\"%s\"}} } if {[S 60 == ptch]} {emit {Palm OS operating system patch data} if {[S 0 x {}]} {emit {\"%s\"}} } if {[S 60 == BOOKMOBI]} {emit {Mobipocket E-book} if {[S 0 x {}]} {emit {\"%s\"}} } if {[N S 0 == 0xace &0xfff]} {emit PARIX switch -- [Nv c 0 &0xf0] -128 {emit T800} -112 {emit T9000} switch -- [Nv c 19 &0x02] 2 {emit executable} 0 {emit object} if {[N c 19 == 0x0 &0x0c]} {emit {not stripped}} } if {[S 0 == %PDF-]} {emit {PDF document} if {[N c 5 x {}]} {emit {\b, version %c}} if {[N c 7 x {}]} {emit {\b.%c}} } if {[S 0 == {\#!\ /bin/perl} b]} {emit {perl script text executable}} if {[S 0 == {eval\ \"exec\ /bin/perl}]} {emit {perl script text}} if {[S 0 == {\#!\ /usr/bin/perl} b]} {emit {perl script text executable}} if {[S 0 == {eval\ \"exec\ /usr/bin/perl}]} {emit {perl script text}} if {[S 0 == {\#!\ /usr/local/bin/perl} b]} {emit {perl script text}} if {[S 0 == {eval\ \"exec\ /usr/local/bin/perl}]} {emit {perl script text executable}} if {[S 0 == {eval\ '(exit\ $?0)'\ &&\ eval\ 'exec}]} {emit {perl script text}} if {[S 0 == package]} {emit {Perl5 module source text}} if {[S 0 == perl-store]} {emit {perl Storable\(v0.6\) data} if {[N c 4 > 0x0]} {emit {\(net-order %d\)} if {[N c 4 & 0x1]} {emit {\(network-ordered\)}} switch -- [Nv c 4] 3 {emit {\(major 1\)}} 2 {emit {\(major 1\)}} } } if {[S 0 == pst0]} {emit {perl Storable\(v0.7\) data} if {[N c 4 > 0x0]} {if {[N c 4 & 0x1]} {emit {\(network-ordered\)}} switch -- [Nv c 4] 5 {emit {\(major 2\)}} 4 {emit {\(major 2\)}} if {[N c 5 > 0x0]} {emit {\(minor %d\)}} } } if {[S 0 == {-----BEGIN\040PGP}]} {emit {PGP armored data} if {[S 15 == {PUBLIC\040KEY\040BLOCK-}]} {emit {public key block}} if {[S 15 == MESSAGE-]} {emit message} if {[S 15 == {SIGNED\040MESSAGE-}]} {emit {signed message}} if {[S 15 == {PGP\040SIGNATURE-}]} {emit signature} } if {[S 0 == {\#\ PaCkAgE\ DaTaStReAm}]} {emit {pkg Datastream \(SVR4\)}} if {[S 0 == %!]} {emit {PostScript document text} if {[S 2 == PS-Adobe-]} {emit conforming if {[S 11 x {}]} {emit {at level %.3s} if {[S 15 == EPS]} {emit {- type %s}} if {[S 15 == Query]} {emit {- type %s}} if {[S 15 == ExitServer]} {emit {- type %s}} } } } if {[S 0 == {\004%!}]} {emit {PostScript document text} if {[S 3 == PS-Adobe-]} {emit conforming if {[S 12 x {}]} {emit {at level %.3s} if {[S 16 == EPS]} {emit {- type %s}} if {[S 16 == Query]} {emit {- type %s}} if {[S 16 == ExitServer]} {emit {- type %s}} } } } if {[S 0 == {\033%-12345X%!PS}]} {emit {PostScript document}} if {[S 0 == *PPD-Adobe:]} {emit {PPD file} if {[S 13 x {}]} {emit {\b, ve}} } if {[S 0 == {\033%-12345X@PJL}]} {emit {HP Printer Job Language data}} if {[Sx 1 0 == {\033%-12345X@PJL}]} {emit {HP Printer Job Language data} if {[Sx 2 [R 0] x {}]} {emit {%s } if {[Sx 3 [R 0] x {}]} {emit {%s } if {[Sx 4 [R 0] x {}]} {emit {%s } if {[S [R 0] x {}]} {emit {%s }} } } } } if {[S 0 == {\033E\033}]} {emit {HP PCL printer data} if {[S 3 == {\&l0A}]} {emit {- default page size}} if {[S 3 == {\&l1A}]} {emit {- US executive page size}} if {[S 3 == {\&l2A}]} {emit {- US letter page size}} if {[S 3 == {\&l3A}]} {emit {- US legal page size}} if {[S 3 == {\&l26A}]} {emit {- A4 page size}} if {[S 3 == {\&l80A}]} {emit {- Monarch envelope size}} if {[S 3 == {\&l81A}]} {emit {- No. 10 envelope size}} if {[S 3 == {\&l90A}]} {emit {- Intl. DL envelope size}} if {[S 3 == {\&l91A}]} {emit {- Intl. C5 envelope size}} if {[S 3 == {\&l100A}]} {emit {- Intl. B5 envelope size}} if {[S 3 == {\&l-81A}]} {emit {- No. 10 envelope size \(landscape\)}} if {[S 3 == {\&l-90A}]} {emit {- Intl. DL envelope size \(landscape\)}} } if {[S 0 == @document(]} {emit {Imagen printer} if {[S 10 == {language\ impress}]} {emit {\(imPRESS data\)}} if {[S 10 == {language\ daisy}]} {emit {\(daisywheel text\)}} if {[S 10 == {language\ diablo}]} {emit {\(daisywheel text\)}} if {[S 10 == {language\ printer}]} {emit {\(line printer emulation\)}} if {[S 10 == {language\ tektronix}]} {emit {\(Tektronix 4014 emulation\)}} } if {[S 0 == Rast]} {emit {RST-format raster font data} if {[S 45 > 0]} {emit {face %s}} } if {[S 0 == {\033[K\002\0\0\017\033(a\001\0\001\033(g}]} {emit {Canon Bubble Jet BJC formatted data}} if {[S 0 == {\x1B\x40\x1B\x28\x52\x08\x00\x00REMOTE1P}]} {emit {Epson Stylus Color 460 data}} if {[S 0 == JZJZ]} {if {[S 18 == ZZ]} {emit {Zenographics ZjStream printer data \(big-endian\)}} } if {[S 0 == ZJZJ]} {if {[S 18 == ZZ]} {emit {Zenographics ZjStream printer data \(little-endian\)}} } if {[S 0 == OAK]} {if {[N c 7 == 0x0]} {emit 888 0} if {[N c 11 == 0x0]} {emit {Oak Technologies printer stream}} } if {[S 0 == %!VMF]} {emit {SunClock's Vector Map Format data}} if {[S 0 == {\xbe\xefABCDEFGH}]} {emit {HP LaserJet 1000 series downloadable firmware}} if {[S 0 == {\x1b\x01@EJL}]} {emit {Epson ESC/Page language printer data}} if {[S 0 == {FTNCHEK_\ P}]} {emit {project file for ftnchek} if {[S 10 == 1]} {emit {version 2.7}} if {[S 10 == 2]} {emit {version 2.8 to 2.10}} if {[S 10 == 3]} {emit {version 2.11 or later}} } if {[N I 0 == 0x56000000 &0xff00ffff]} {emit {ps database} if {[S 1 x {}]} {emit {version %s}} if {[S 4 x {}]} {emit {from kernel %s}} } if {[S 0 == {\"\"\"}]} {emit {a python script text executable}} if {[S 0 == {/1\ :pserver:}]} {emit {cvs password text file}} if {[S 0 == RIFF]} {emit {RIFF \(little-endian\) data} if {[S 8 == PAL]} {emit {\b, palette} if {[N s 16 x {}]} {emit {\b, version %d}} if {[N s 18 x {}]} {emit {\b, %d entries}} } if {[S 8 == RDIB]} {emit {\b, device-independent bitmap} if {[S 16 == BM]} {switch -- [Nv s 30] 12 {emit {\b, OS/2 1.x format} if {[N s 34 x {}]} {emit {\b, %d x}} if {[N s 36 x {}]} {emit %d} } 64 {emit {\b, OS/2 2.x format} if {[N s 34 x {}]} {emit {\b, %d x}} if {[N s 36 x {}]} {emit %d} } 40 {emit {\b, Windows 3.x format} if {[N i 34 x {}]} {emit {\b, %d x}} if {[N i 38 x {}]} {emit {%d x}} if {[N s 44 x {}]} {emit %d} } } } if {[S 8 == RMID]} {emit {\b, MIDI}} if {[S 8 == RMMP]} {emit {\b, multimedia movie}} if {[S 8 == WAVE]} {emit {\b, WAVE audio} switch -- [Nv s 20] 1 {emit {\b, Microsoft PCM} if {[N s 34 > 0x0]} {emit {\b, %d bit}} } 2 {emit {\b, Microsoft ADPCM}} 6 {emit {\b, ITU G.711 A-law}} 7 {emit {\b, ITU G.711 mu-law}} 17 {emit {\b, IMA ADPCM}} 20 {emit {\b, ITU G.723 ADPCM \(Yamaha\)}} 49 {emit {\b, GSM 6.10}} 64 {emit {\b, ITU G.721 ADPCM}} 80 {emit {\b, MPEG}} 85 {emit {\b, MPEG Layer 3}} switch -- [Nv s 22] 1 {emit {\b, mono}} 2 {emit {\b, stereo}} if {[N s 22 > 0x2]} {emit {\b, %d channels}} if {[N i 24 > 0x0]} {emit {%d Hz}} } if {[S 8 == CDRA]} {emit {\b, Corel Draw Picture}} if {[S 8 == {AVI\040}]} {emit {\b, AVI} if {[S 12 == LIST]} {if {[Sx 4 20 == hdrlavih]} {if {[N i [R 36] x {}]} {emit {\b, %lu x}} if {[N i [R 40] x {}]} {emit %lu,} if {[N i [R 4] > 0xf4240]} {emit {<1 fps,}} switch -- [Nvx 5 i [R 4]] 1000000 {emit {1.00 fps,}} 500000 {emit {2.00 fps,}} 333333 {emit {3.00 fps,}} 250000 {emit {4.00 fps,}} 200000 {emit {5.00 fps,}} 166667 {emit {6.00 fps,}} 142857 {emit {7.00 fps,}} 125000 {emit {8.00 fps,}} 111111 {emit {9.00 fps,}} 100000 {emit {10.00 fps,}} 83333 {emit {12.00 fps,}} 66667 {emit {15.00 fps,}} 50000 {emit {20.00 fps,}} 41708 {emit {23.98 fps,}} 41667 {emit {24.00 fps,}} 40000 {emit {25.00 fps,}} 33367 {emit {29.97 fps,}} 33333 {emit {30.00 fps,}} L 4;if {[Nx 5 i [R 4] < 0x18a92]} {if {[Nx 6 i [R -4] > 0x182c2]} {if {[N i [R -4] != 0x186a0]} {emit {~10 fps,}} } } L 4;if {[Nx 5 i [R 4] < 0x14842]} {if {[Nx 6 i [R -4] > 0x142d5]} {if {[N i [R -4] != 0x14585]} {emit {~12 fps,}} } } L 4;if {[Nx 5 i [R 4] < 0x1062a]} {if {[Nx 6 i [R -4] > 0x102b1]} {if {[N i [R -4] != 0x1046b]} {emit {~15 fps,}} } } L 4;if {[Nx 5 i [R 4] < 0xa371]} {if {[Nx 6 i [R -4] > 0xa216]} {if {[Nx 7 i [R -4] != 0xa2ec]} {if {[N i [R -4] != 0xa2c3]} {emit {~24 fps,}} } } } L 4;if {[Nx 5 i [R 4] < 0x9ce1]} {if {[Nx 6 i [R -4] > 0x9ba1]} {if {[N i [R -4] != 0x9c40]} {emit {~25 fps,}} } } L 4;if {[Nx 5 i [R 4] < 0x82a5]} {if {[Nx 6 i [R -4] > 0x81c7]} {if {[Nx 7 i [R -4] != 0x8257]} {if {[N i [R -4] != 0x8235]} {emit {~30 fps,}} } } } L 4;if {[N i [R 4] < 0x7de0]} {emit {>30 fps,}} } if {[S 88 == LIST]} {if {[S 96 == strlstrh]} {if {[Sx 6 108 == vids]} {emit video: if {[N i [R 0] == 0x0]} {emit uncompressed} if {[S [I 104 i 108] == strf]} {switch -- [Nv i [I 104 i 132]] 1 {emit {RLE 8bpp}} 0 {emit {}} if {[S [I 104 i 132] == cvid c]} {emit Cinepak} if {[S [I 104 i 132] == i263 c]} {emit {Intel I.263}} if {[S [I 104 i 132] == iv32 c]} {emit {Indeo 3.2}} if {[S [I 104 i 132] == iv41 c]} {emit {Indeo 4.1}} if {[S [I 104 i 132] == iv50 c]} {emit {Indeo 5.0}} if {[S [I 104 i 132] == mp42 c]} {emit {Microsoft MPEG-4 v2}} if {[S [I 104 i 132] == mp43 c]} {emit {Microsoft MPEG-4 v3}} if {[S [I 104 i 132] == mjpg c]} {emit {Motion JPEG}} if {[S [I 104 i 132] == div3 c]} {emit {DivX 3} if {[S 112 == div3 c]} {emit Low-Motion} if {[S 112 == div4 c]} {emit Fast-Motion} } if {[S [I 104 i 132] == divx c]} {emit {DivX 4}} if {[S [I 104 i 132] == dx50 c]} {emit {DivX 5}} if {[S [I 104 i 132] == xvid c]} {emit XviD} } } } if {[S [I 92 i 96] == LIST]} {if {[S [I 92 i 104] == strlstrh]} {if {[S [I 92 i 116] == auds]} {emit {\b, audio:} if {[S [I 92 i 172] == strf]} {switch -- [Nv s [I 92 i 180]] 1 {emit {uncompressed PCM}} 2 {emit ADPCM} 85 {emit {MPEG-1 Layer 3}} 8192 {emit {Dolby AC3}} 353 {emit DivX} switch -- [Nv s [I 92 i 182]] 1 {emit {\(mono,}} 2 {emit {\(stereo,}} if {[N s [I 92 i 182] > 0x2]} {emit {\(%d channels,}} if {[N i [I 92 i 184] x {}]} {emit {%d Hz\)}} } if {[S [I 92 i 180] == strf]} {switch -- [Nv s [I 92 i 188]] 1 {emit {uncompressed PCM}} 2 {emit ADPCM} 85 {emit {MPEG-1 Layer 3}} 8192 {emit {Dolby AC3}} 353 {emit DivX} switch -- [Nv s [I 92 i 190]] 1 {emit {\(mono,}} 2 {emit {\(stereo,}} if {[N s [I 92 i 190] > 0x2]} {emit {\(%d channels,}} if {[N i [I 92 i 192] x {}]} {emit {%d Hz\)}} } } } } } } } if {[S 8 == ACON]} {emit {\b, animated cursor}} if {[S 8 == sfbk]} {emit SoundFont/Bank} if {[S 8 == CDXA]} {emit {\b, wrapped MPEG-1 \(CDXA\)}} if {[S 8 == 4XMV]} {emit {\b, 4X Movie file}} } if {[S 0 == RIFX]} {emit {RIFF \(big-endian\) data} if {[S 8 == PAL]} {emit {\b, palette} if {[N S 16 x {}]} {emit {\b, version %d}} if {[N S 18 x {}]} {emit {\b, %d entries}} } if {[S 8 == RDIB]} {emit {\b, device-independent bitmap} if {[S 16 == BM]} {switch -- [Nv S 30] 12 {emit {\b, OS/2 1.x format} if {[N S 34 x {}]} {emit {\b, %d x}} if {[N S 36 x {}]} {emit %d} } 64 {emit {\b, OS/2 2.x format} if {[N S 34 x {}]} {emit {\b, %d x}} if {[N S 36 x {}]} {emit %d} } 40 {emit {\b, Windows 3.x format} if {[N I 34 x {}]} {emit {\b, %d x}} if {[N I 38 x {}]} {emit {%d x}} if {[N S 44 x {}]} {emit %d} } } } if {[S 8 == RMID]} {emit {\b, MIDI}} if {[S 8 == RMMP]} {emit {\b, multimedia movie}} if {[S 8 == WAVE]} {emit {\b, WAVE audio} if {[N s 20 == 0x1]} {emit {\b, Microsoft PCM} if {[N s 34 > 0x0]} {emit {\b, %d bit}} } switch -- [Nv S 22] 1 {emit {\b, mono}} 2 {emit {\b, stereo}} if {[N S 22 > 0x2]} {emit {\b, %d channels}} if {[N I 24 > 0x0]} {emit {%d Hz}} } if {[S 8 == CDRA]} {emit {\b, Corel Draw Picture}} if {[S 8 == {AVI\040}]} {emit {\b, AVI}} if {[S 8 == ACON]} {emit {\b, animated cursor}} if {[S 8 == NIFF]} {emit {\b, Notation Interchange File Format}} if {[S 8 == sfbk]} {emit SoundFont/Bank} } if {[S 0 == {\{\\rtf}]} {emit {Rich Text Format data,} if {[N c 5 x {}]} {emit {version %c,}} if {[S 6 == {\\ansi}]} {emit ANSI} if {[S 6 == {\\mac}]} {emit {Apple Macintosh}} if {[S 6 == {\\pc}]} {emit {IBM PC, code page 437}} if {[S 6 == {\\pca}]} {emit {IBM PS/2, code page 850}} } if {[S 38 == Spreadsheet]} {emit {sc spreadsheet file}} if {[S 8 == {\001s\ }]} {emit {SCCS archive data}} if {[S 0 == {divert(-1)\n}]} {emit {sendmail m4 text file}} if {[S 0 == PmNs]} {emit {PCP compiled namespace \(V.0\)}} if {[S 0 == PmN]} {emit {PCP compiled namespace} if {[S 3 x {}]} {emit {\(V.%1.1s\)}} } if {[N i 3 == 0x84500526]} {emit {PCP archive} if {[N c 7 x {}]} {emit {\(V.%d\)}} switch -- [Nv i 20] -2 {emit {temporal index}} -1 {emit metadata} 0 {emit {log volume \#0}} if {[N i 20 > 0x0]} {emit {log volume \#%ld}} if {[S 24 x {}]} {emit {host: %s}} } if {[S 0 == PCPFolio]} {emit PCP if {[S 9 == Version:]} {emit {Archive Folio}} if {[S 18 x {}]} {emit {\(V.%s\)}} } if {[S 0 == {\#pmchart}]} {emit {PCP pmchart view} if {[S 9 == Version]} {emit 906 0} if {[S 17 x {}]} {emit {\(V%-3.3s\)}} } if {[S 0 == pmview]} {emit {PCP pmview config} if {[S 7 == Version]} {emit 907 0} if {[S 15 x {}]} {emit {\(V%-3.3s\)}} } if {[S 0 == {\#pmlogger}]} {emit {PCP pmlogger config} if {[S 10 == Version]} {emit 908 0} if {[S 18 x {}]} {emit {\(V%1.1s\)}} } if {[S 0 == PcPh]} {emit {PCP Help} if {[S 4 == 1]} {emit Index} if {[S 4 == 2]} {emit Text} if {[S 5 x {}]} {emit {\(V.%1.1s\)}} } if {[S 0 == {\#pmieconf-rules}]} {emit {PCP pmieconf rules} if {[S 16 x {}]} {emit {\(V.%1.1s\)}} } if {[S 3 == pmieconf-pmie]} {emit {PCP pmie config} if {[S 17 x {}]} {emit {\(V.%1.1s\)}} } if {[S 0 == mdbm]} {emit {mdbm file,} if {[N c 5 x {}]} {emit {version %d,}} if {[N c 6 x {}]} {emit {2^%d pages,}} if {[N c 7 x {}]} {emit {pagesize 2^%d,}} if {[N c 17 x {}]} {emit {hash %d,}} if {[N c 11 x {}]} {emit {dataformat %d}} } if {[S 0 == //Maya]} {emit {ASCII Alias|Wavefront Maya Ascii File,} if {[S 13 x {}]} {emit {version %s}} } if {[S 8 == MAYAFOR4]} {emit {Alias|Wavefront Maya Binary File,} if {[S 32 x {}]} {emit {version %s scene}} } if {[S 8 == MayaFOR4]} {emit {Alias|Wavefront Maya Binary File,} if {[S 32 x {}]} {emit {version %s scene}} } if {[S 8 == CIMG]} {emit {Alias|Wavefront Maya Image File}} if {[S 8 == DEEP]} {emit {Alias|Wavefront Maya Image File}} if {[S 0 == {}]} {emit {Compiled SGML rules file} if {[S 9 x {}]} {emit {Type %s}} } if {[S 0 == {}]} {emit {A/E SGML Document binary} if {[S 9 x {}]} {emit {Type %s}} } if {[S 0 == {}]} {emit {A/E SGML binary styles file} if {[S 9 x {}]} {emit {Type %s}} } if {[S 0 == {SQ\ BITMAP1}]} {emit {SoftQuad Raster Format text}} if {[S 0 == {X\ }]} {emit {SoftQuad troff Context intermediate} if {[S 2 == 495]} {emit {for AT&T 495 laser printer}} if {[S 2 == hp]} {emit {for Hewlett-Packard LaserJet}} if {[S 2 == impr]} {emit {for IMAGEN imPRESS}} if {[S 2 == ps]} {emit {for PostScript}} } if {[S 0 == spec]} {emit SPEC if {[S 4 == .cpu]} {emit CPU if {[S 8 < :]} {emit {\b%.4s}} if {[S 12 == .]} {emit {raw result text}} } } if {[S 17 == version=SPECjbb]} {emit SPECjbb if {[S 32 < :]} {emit {\b%.4s} if {[S 37 < :]} {emit {v%.4s raw result text}} } } if {[S 0 == {BEGIN\040SPECWEB}]} {emit SPECweb if {[S 13 < :]} {emit {\b%.2s} if {[S 15 == _SSL]} {emit {\b_SSL} if {[S 20 < :]} {emit {v%.4s raw result text}} } if {[S 16 < :]} {emit {v%.4s raw result text}} } } if {[S 0 == {PLUS3DOS\032}]} {emit {Spectrum +3 data} switch -- [Nv c 15] 0 {emit {- BASIC program}} 1 {emit {- number array}} 2 {emit {- character array}} 3 {emit {- memory block} if {[N I 16 == 0x1b0040]} {emit {\(screen\)}} } 4 {emit {- Tasword document}} if {[S 15 == TAPEFILE]} {emit {- ZXT tapefile}} } if {[S 0 == {\023\000\000}]} {emit {Spectrum .TAP data} if {[S 4 x {}]} {emit {\"%-10.10s\"}} switch -- [Nv c 3] 0 {emit {- BASIC program}} 1 {emit {- number array}} 2 {emit {- character array}} 3 {emit {- memory block} if {[N I 14 == 0x1b0040]} {emit {\(screen\)}} } } if {[S 0 == {ZXTape!\x1a}]} {emit {Spectrum .TZX data} if {[N c 8 x {}]} {emit {version %d}} if {[N c 9 x {}]} {emit .%d} } if {[S 0 == RZX!]} {emit {Spectrum .RZX data} if {[N c 4 x {}]} {emit {version %d}} if {[N c 5 x {}]} {emit .%d} } if {[S 0 == {MV\ -\ CPCEMU\ Disk-Fil}]} {emit {Amstrad/Spectrum .DSK data}} if {[S 0 == {MV\ -\ CPC\ format\ Dis}]} {emit {Amstrad/Spectrum DU54 .DSK data}} if {[S 0 == {EXTENDED\ CPC\ DSK\ Fil}]} {emit {Amstrad/Spectrum Extended .DSK data}} if {[S 0 == {\376bin}]} {emit {MySQL replication log}} if {[S 0 == {\#SUNPC_CONFIG}]} {emit {SunPC 4.0 Properties Values}} if {[S 0 == snoop]} {emit {Snoop capture file} if {[N I 8 > 0x0]} {emit {- version %ld}} switch -- [Nv I 12] 0 {emit {\(IEEE 802.3\)}} 1 {emit {\(IEEE 802.4\)}} 2 {emit {\(IEEE 802.5\)}} 3 {emit {\(IEEE 802.6\)}} 4 {emit {\(Ethernet\)}} 5 {emit {\(HDLC\)}} 6 {emit {\(Character synchronous\)}} 7 {emit {\(IBM channel-to-channel adapter\)}} 8 {emit {\(FDDI\)}} 9 {emit {\(Unknown\)}} } if {[S 36 == acspMSFT]} {emit {Microsoft ICM Color Profile}} if {[S 36 == acsp]} {emit {Kodak Color Management System, ICC Profile}} if {[S 0 == {Cobalt\ Networks\ Inc.\nFirmware\ v}]} {emit {Paged COBALT boot rom} if {[S 38 x {}]} {emit V%.4s} } if {[S 0 == CRfs]} {emit {COBALT boot rom data \(Flat boot rom or file system\)}} if {[S 0 == T707]} {emit {Roland TR-707 Data}} if {[S 0 == {\#!teapot\012xdr}]} {emit {teapot work sheet \(XDR format\)}} if {[S 0 == {\032\001}]} {emit {Compiled terminfo entry}} if {[S 0 == {\367\002}]} {emit {TeX DVI file} if {[S 16 x {}]} {emit {\(%s\)}} } if {[S 0 == {\367\203}]} {emit {TeX generic font data}} if {[S 0 == {\367\131}]} {emit {TeX packed font data} if {[S 3 x {}]} {emit {\(%s\)}} } if {[S 0 == {\367\312}]} {emit {TeX virtual font data}} if {[S 0 == {This\ is\ TeX,}]} {emit {TeX transcript text}} if {[S 0 == {This\ is\ METAFONT,}]} {emit {METAFONT transcript text}} if {[S 2 == {\000\021}]} {emit {TeX font metric data} if {[S 33 x {}]} {emit {\(%s\)}} } if {[S 2 == {\000\022}]} {emit {TeX font metric data} if {[S 33 x {}]} {emit {\(%s\)}} } if {[S 0 == {\\input\ texinfo}]} {emit {Texinfo source text}} if {[S 0 == {This\ is\ Info\ file}]} {emit {GNU Info text}} if {[S 0 == {\\input}]} {emit {TeX document text}} if {[S 0 == {\\section}]} {emit {LaTeX document text}} if {[S 0 == {\\setlength}]} {emit {LaTeX document text}} if {[S 0 == {\\documentstyle}]} {emit {LaTeX document text}} if {[S 0 == {\\chapter}]} {emit {LaTeX document text}} if {[S 0 == {\\documentclass}]} {emit {LaTeX 2e document text}} if {[S 0 == {\\relax}]} {emit {LaTeX auxiliary file}} if {[S 0 == {\\contentsline}]} {emit {LaTeX table of contents}} if {[S 0 == {%\ -*-latex-*-}]} {emit {LaTeX document text}} if {[S 0 == {\\ifx}]} {emit {TeX document text}} if {[S 0 == {\\indexentry}]} {emit {LaTeX raw index file}} if {[S 0 == {\\begin\{theindex\}}]} {emit {LaTeX sorted index}} if {[S 0 == {\\glossaryentry}]} {emit {LaTeX raw glossary}} if {[S 0 == {\\begin\{theglossary\}}]} {emit {LaTeX sorted glossary}} if {[S 0 == {This\ is\ makeindex}]} {emit {Makeindex log file}} if {[S 0 == {@article\{} c]} {emit {BibTeX text file}} if {[S 0 == {@book\{} c]} {emit {BibTeX text file}} if {[S 0 == {@inbook\{} c]} {emit {BibTeX text file}} if {[S 0 == {@incollection\{} c]} {emit {BibTeX text file}} if {[S 0 == {@inproceedings\{} c]} {emit {BibTeX text file}} if {[S 0 == {@manual\{} c]} {emit {BibTeX text file}} if {[S 0 == {@misc\{} c]} {emit {BibTeX text file}} if {[S 0 == {@preamble\{} c]} {emit {BibTeX text file}} if {[S 0 == {@phdthesis\{} c]} {emit {BibTeX text file}} if {[S 0 == {@techreport\{} c]} {emit {BibTeX text file}} if {[S 0 == {@unpublished\{} c]} {emit {BibTeX text file}} if {[S 73 == {%%%\ \ BibTeX-file\{}]} {emit {BibTex text file \(with full header\)}} if {[S 73 == {%%%\ \ @BibTeX-style-file\{}]} {emit {BibTeX style text file \(with full header\)}} if {[S 0 == {%\ BibTeX\ standard\ bibliography\ }]} {emit {BibTeX standard bibliography style text file}} if {[S 0 == {%\ BibTeX\ `}]} {emit {BibTeX custom bibliography style text file}} if {[S 0 == {@c\ @mapfile\{}]} {emit {TeX font aliases text file}} if {[S 0 == {%TGIF\ 4}]} {emit {tgif version 4 object file}} if {[S 0 == **TI80**]} {emit {TI-80 Graphing Calculator File.}} if {[S 0 == **TI81**]} {emit {TI-81 Graphing Calculator File.}} if {[S 0 == **TI73**]} {emit {TI-73 Graphing Calculator} switch -- [Nv c 59] 0 {emit {\(real number\)}} 1 {emit {\(list\)}} 2 {emit {\(matrix\)}} 3 {emit {\(equation\)}} 4 {emit {\(string\)}} 5 {emit {\(program\)}} 6 {emit {\(assembly program\)}} 7 {emit {\(picture\)}} 8 {emit {\(gdb\)}} 12 {emit {\(complex number\)}} 15 {emit {\(window settings\)}} 16 {emit {\(zoom\)}} 17 {emit {\(table setup\)}} 19 {emit {\(backup\)}} } if {[S 0 == **TI82**]} {emit {TI-82 Graphing Calculator} switch -- [Nv c 59] 0 {emit {\(real\)}} 1 {emit {\(list\)}} 2 {emit {\(matrix\)}} 3 {emit {\(Y-variable\)}} 5 {emit {\(program\)}} 6 {emit {\(protected prgm\)}} 7 {emit {\(picture\)}} 8 {emit {\(gdb\)}} 11 {emit {\(window settings\)}} 12 {emit {\(window settings\)}} 13 {emit {\(table setup\)}} 14 {emit {\(screenshot\)}} 15 {emit {\(backup\)}} } if {[S 0 == **TI83**]} {emit {TI-83 Graphing Calculator} switch -- [Nv c 59] 0 {emit {\(real\)}} 1 {emit {\(list\)}} 2 {emit {\(matrix\)}} 3 {emit {\(Y-variable\)}} 4 {emit {\(string\)}} 5 {emit {\(program\)}} 6 {emit {\(protected prgm\)}} 7 {emit {\(picture\)}} 8 {emit {\(gdb\)}} 11 {emit {\(window settings\)}} 12 {emit {\(window settings\)}} 13 {emit {\(table setup\)}} 14 {emit {\(screenshot\)}} 19 {emit {\(backup\)}} } if {[S 0 == **TI83F*]} {emit {TI-83+ Graphing Calculator} switch -- [Nv c 59] 0 {emit {\(real number\)}} 1 {emit {\(list\)}} 2 {emit {\(matrix\)}} 3 {emit {\(equation\)}} 4 {emit {\(string\)}} 5 {emit {\(program\)}} 6 {emit {\(assembly program\)}} 7 {emit {\(picture\)}} 8 {emit {\(gdb\)}} 12 {emit {\(complex number\)}} 15 {emit {\(window settings\)}} 16 {emit {\(zoom\)}} 17 {emit {\(table setup\)}} 19 {emit {\(backup\)}} 21 {emit {\(application variable\)}} 23 {emit {\(group of variable\)}} } if {[S 0 == **TI85**]} {emit {TI-85 Graphing Calculator} switch -- [Nv c 59] 0 {emit {\(real number\)}} 1 {emit {\(complex number\)}} 2 {emit {\(real vector\)}} 3 {emit {\(complex vector\)}} 4 {emit {\(real list\)}} 5 {emit {\(complex list\)}} 6 {emit {\(real matrix\)}} 7 {emit {\(complex matrix\)}} 8 {emit {\(real constant\)}} 9 {emit {\(complex constant\)}} 10 {emit {\(equation\)}} 12 {emit {\(string\)}} 13 {emit {\(function GDB\)}} 14 {emit {\(polar GDB\)}} 15 {emit {\(parametric GDB\)}} 16 {emit {\(diffeq GDB\)}} 17 {emit {\(picture\)}} 18 {emit {\(program\)}} 19 {emit {\(range\)}} 23 {emit {\(window settings\)}} 24 {emit {\(window settings\)}} 25 {emit {\(window settings\)}} 26 {emit {\(window settings\)}} 27 {emit {\(zoom\)}} 29 {emit {\(backup\)}} 30 {emit {\(unknown\)}} 42 {emit {\(equation\)}} if {[S 50 == ZS4]} {emit {- ZShell Version 4 File.}} if {[S 50 == ZS3]} {emit {- ZShell Version 3 File.}} } if {[S 0 == **TI86**]} {emit {TI-86 Graphing Calculator} switch -- [Nv c 59] 0 {emit {\(real number\)}} 1 {emit {\(complex number\)}} 2 {emit {\(real vector\)}} 3 {emit {\(complex vector\)}} 4 {emit {\(real list\)}} 5 {emit {\(complex list\)}} 6 {emit {\(real matrix\)}} 7 {emit {\(complex matrix\)}} 8 {emit {\(real constant\)}} 9 {emit {\(complex constant\)}} 10 {emit {\(equation\)}} 12 {emit {\(string\)}} 13 {emit {\(function GDB\)}} 14 {emit {\(polar GDB\)}} 15 {emit {\(parametric GDB\)}} 16 {emit {\(diffeq GDB\)}} 17 {emit {\(picture\)}} 18 {emit {\(program\)}} 19 {emit {\(range\)}} 23 {emit {\(window settings\)}} 24 {emit {\(window settings\)}} 25 {emit {\(window settings\)}} 26 {emit {\(window settings\)}} 27 {emit {\(zoom\)}} 29 {emit {\(backup\)}} 30 {emit {\(unknown\)}} 42 {emit {\(equation\)}} } if {[S 0 == **TI89**]} {emit {TI-89 Graphing Calculator} switch -- [Nv c 72] 0 {emit {\(expression\)}} 4 {emit {\(list\)}} 6 {emit {\(matrix\)}} 10 {emit {\(data\)}} 11 {emit {\(text\)}} 12 {emit {\(string\)}} 13 {emit {\(graphic data base\)}} 14 {emit {\(figure\)}} 16 {emit {\(picture\)}} 18 {emit {\(program\)}} 19 {emit {\(function\)}} 20 {emit {\(macro\)}} 28 {emit {\(zipped\)}} 33 {emit {\(assembler\)}} } if {[S 0 == **TI92**]} {emit {TI-92 Graphing Calculator} switch -- [Nv c 72] 0 {emit {\(expression\)}} 4 {emit {\(list\)}} 6 {emit {\(matrix\)}} 10 {emit {\(data\)}} 11 {emit {\(text\)}} 12 {emit {\(string\)}} 13 {emit {\(graphic data base\)}} 14 {emit {\(figure\)}} 16 {emit {\(picture\)}} 18 {emit {\(program\)}} 19 {emit {\(function\)}} 20 {emit {\(macro\)}} 29 {emit {\(backup\)}} } if {[S 0 == **TI92P*]} {emit {TI-92+/V200 Graphing Calculator} switch -- [Nv c 72] 0 {emit {\(expression\)}} 4 {emit {\(list\)}} 6 {emit {\(matrix\)}} 10 {emit {\(data\)}} 11 {emit {\(text\)}} 12 {emit {\(string\)}} 13 {emit {\(graphic data base\)}} 14 {emit {\(figure\)}} 16 {emit {\(picture\)}} 18 {emit {\(program\)}} 19 {emit {\(function\)}} 20 {emit {\(macro\)}} 28 {emit {\(zipped\)}} 33 {emit {\(assembler\)}} } if {[S 22 == Advanced]} {emit {TI-XX Graphing Calculator \(FLASH\)}} if {[S 0 == **TIFL**]} {emit {TI-XX Graphing Calculator \(FLASH\)} if {[N c 8 > 0x0]} {emit {- Revision %d} if {[N c 9 x {}]} {emit {\b.%d,}} } if {[N c 12 > 0x0]} {emit {Revision date %02x} if {[N c 13 x {}]} {emit {\b/%02x}} if {[N S 14 x {}]} {emit {\b/%04x,}} } if {[S 17 > /0]} {emit {name: '%s',}} switch -- [Nv c 48] 116 {emit {device: TI-73,}} 115 {emit {device: TI-83+,}} -104 {emit {device: TI-89,}} -120 {emit {device: TI-92+,}} switch -- [Nv c 49] 35 {emit {type: OS upgrade,}} 36 {emit {type: application,}} 37 {emit {type: certificate,}} 62 {emit {type: license,}} if {[N i 74 > 0x0]} {emit {size: %ld bytes}} } if {[S 0 == VTI]} {emit {Virtual TI skin} if {[S 3 == v]} {emit {- Version} if {[N c 4 > 0x0]} {emit {\b %c}} if {[N c 6 x {}]} {emit {\b.%c}} } } if {[S 0 == TiEmu]} {emit {TiEmu skin} if {[S 6 == v]} {emit {- Version} if {[N c 7 > 0x0]} {emit {\b %c}} if {[N c 9 x {}]} {emit {\b.%c}} if {[N c 10 x {}]} {emit {\b%c}} } } if {[S 0 == TZif]} {emit {timezone data}} if {[S 0 == {\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\1\0}]} {emit {old timezone data}} if {[S 0 == {\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\2\0}]} {emit {old timezone data}} if {[S 0 == {\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\3\0}]} {emit {old timezone data}} if {[S 0 == {\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\4\0}]} {emit {old timezone data}} if {[S 0 == {\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\5\0}]} {emit {old timezone data}} if {[S 0 == {\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\6\0}]} {emit {old timezone data}} if {[S 0 == {.\\\"}]} {emit {troff or preprocessor input text}} if {[S 0 == {'\\\"}]} {emit {troff or preprocessor input text}} if {[S 0 == {'.\\\"}]} {emit {troff or preprocessor input text}} if {[S 0 == {\\\"}]} {emit {troff or preprocessor input text}} if {[S 0 == ''']} {emit {troff or preprocessor input text}} if {[S 0 == {x\ T}]} {emit {ditroff output text} if {[S 4 == cat]} {emit {for the C/A/T phototypesetter}} if {[S 4 == ps]} {emit {for PostScript}} if {[S 4 == dvi]} {emit {for DVI}} if {[S 4 == ascii]} {emit {for ASCII}} if {[S 4 == lj4]} {emit {for LaserJet 4}} if {[S 4 == latin1]} {emit {for ISO 8859-1 \(Latin 1\)}} if {[S 4 == X75]} {emit {for xditview at 75dpi} if {[S 7 == -12]} {emit {\(12pt\)}} } if {[S 4 == X100]} {emit {for xditview at 100dpi} if {[S 8 == -12]} {emit {\(12pt\)}} } } if {[S 0 == {\100\357}]} {emit {very old \(C/A/T\) troff output data}} if {[S 0 == {\0\0\1\236\0\0\0\0\0\0\0\0\0\0\0\0}]} {emit {BEA TUXEDO DES mask data}} if {[S 0 == Interpress/Xerox]} {emit {Xerox InterPress data} if {[S 16 == /]} {emit {\(version} if {[S 17 x {}]} {emit {%s\)}} } } if {[S 0 == {begin\040}]} {emit {uuencoded or xxencoded text}} if {[S 0 == {xbtoa\ Begin}]} {emit {btoa'd text}} if {[S 0 == {$\012ship}]} {emit {ship'd binary text}} if {[S 0 == {Decode\ the\ following\ with\ bdeco}]} {emit {bencoded News text}} if {[S 11 == {must\ be\ converted\ with\ BinHex}]} {emit {BinHex binary text} if {[S 41 x {}]} {emit {\b, version %.3s}} } if {[N S 6 == 0x107]} {emit {unicos \(cray\) executable}} if {[S 596 == {\130\337\377\377}]} {emit {Ultrix core file} if {[S 600 x {}]} {emit {from '%s'}} } if {[S 0 == Joy!peffpwpc]} {emit {header for PowerPC PEF executable}} if {[S 0 == avaobj]} {emit {AVR assembler object code} if {[S 7 x {}]} {emit {version '%s'}} } if {[S 0 == gmon]} {emit {GNU prof performance data} if {[N Q 4 x {}]} {emit {- version %ld}} } if {[S 0 == {\xc0HRB}]} {emit {Harbour HRB file} if {[N Y 4 x {}]} {emit {version %d}} } if {[S 0 == {\#!\ /}]} {emit a if {[S 3 x {}]} {emit {%s script text executable}} } if {[S 0 == {\#!\ /}]} {emit a if {[S 3 x {}]} {emit {%s script text executable}} } if {[S 0 == {\#!/}]} {emit a if {[S 2 x {}]} {emit {%s script text executable}} } if {[S 0 == {\#!\ }]} {emit {script text executable} if {[S 3 x {}]} {emit {for %s}} } if {[S 0 == LBLSIZE=]} {emit {VICAR image data} if {[S 32 == BYTE]} {emit {\b, 8 bits = VAX byte}} if {[S 32 == HALF]} {emit {\b, 16 bits = VAX word = Fortran INTEGER*2}} if {[S 32 == FULL]} {emit {\b, 32 bits = VAX longword = Fortran INTEGER*4}} if {[S 32 == REAL]} {emit {\b, 32 bits = VAX longword = Fortran REAL*4}} if {[S 32 == DOUB]} {emit {\b, 64 bits = VAX quadword = Fortran REAL*8}} if {[S 32 == COMPLEX]} {emit {\b, 64 bits = VAX quadword = Fortran COMPLEX*8}} } if {[S 43 == SFDU_LABEL]} {emit {VICAR label file}} if {[S 0 == {\211\277\036\203}]} {emit {Virtutech CRAFF} if {[N I 4 x {}]} {emit v%d} switch -- [Nv I 20] 0 {emit uncompressed} 1 {emit bzipp2ed} 2 {emit gzipped} if {[N I 24 == 0x0]} {emit {not clean}} } if {[S 0 == {\xb0\0\x30\0}]} {emit {VMS VAX executable} if {[S 44032 == {PK\003\004}]} {emit {\b, Info-ZIP SFX archive v5.12 w/decryption}} } if {[S 0 == OggS]} {emit {Ogg data} if {[N c 4 != 0x0]} {emit {UNKNOWN REVISION %u}} if {[N c 4 == 0x0]} {if {[S 28 == fLaC]} {emit {\b, FLAC audio}} if {[S 28 == {\x80theora}]} {emit {\b, Theora video}} if {[S 28 == {Speex\ \ \ }]} {emit {\b, Speex audio}} if {[S 28 == {\x01video\0\0\0}]} {emit {\b, OGM video} if {[S 37 == div3 c]} {emit {\(DivX 3\)}} if {[S 37 == divx c]} {emit {\(DivX 4\)}} if {[S 37 == dx50 c]} {emit {\(DivX 5\)}} if {[S 37 == xvid c]} {emit {\(XviD\)}} } if {[S 28 == {\x01vorbis}]} {emit {\b, Vorbis audio,} if {[N i 35 != 0x0]} {emit {UNKNOWN VERSION %lu,}} if {[N i 35 == 0x0]} {switch -- [Nv c 39] 1 {emit mono,} 2 {emit stereo,} if {[N c 39 > 0x2]} {emit {%u channels,}} if {[N i 40 x {}]} {emit {%lu Hz}} if {[S 48 < {\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff}]} {emit {\b,} if {[N i 52 != 0xffffffff]} {if {[N i 52 != 0x0]} {if {[N i 52 != 0xfffffc18]} {if {[N i 52 x {}]} {emit <%lu} } } } if {[N i 48 != 0xffffffff]} {if {[N i 48 x {}]} {emit ~%lu} } if {[N i 44 != 0xffffffff]} {if {[N i 44 != 0xfffffc18]} {if {[N i 44 != 0x0]} {if {[N i 44 x {}]} {emit >%lu} } } } if {[S 48 < {\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff}]} {emit bps} } } if {[S [I 84 c 85] == {\x03vorbis}]} {if {[S [I 84 c 96] == {Xiphophorus\ libVorbis\ I} c]} {emit {\b, created by: Xiphophorus libVorbis I} if {[S [I 84 c 120] > 00000000]} {if {[S [I 84 c 120] < 20000508]} {emit {\( 20000508]} {if {[S [I 84 c 120] < 20001031]} {emit {\(beta2-3\)}} } if {[S [I 84 c 120] == 20001031]} {emit {\(1.0 beta 3\)}} if {[S [I 84 c 120] > 20001031]} {if {[S [I 84 c 120] < 20010225]} {emit {\(beta3-4\)}} } if {[S [I 84 c 120] == 20010225]} {emit {\(1.0 beta 4\)}} if {[S [I 84 c 120] > 20010225]} {if {[S [I 84 c 120] < 20010615]} {emit {\(beta4-RC1\)}} } if {[S [I 84 c 120] == 20010615]} {emit {\(1.0 RC1\)}} if {[S [I 84 c 120] == 20010813]} {emit {\(1.0 RC2\)}} if {[S [I 84 c 120] == 20010816]} {emit {\(RC2 - Garf tuned v1\)}} if {[S [I 84 c 120] == 20011014]} {emit {\(RC2 - Garf tuned v2\)}} if {[S [I 84 c 120] == 20011217]} {emit {\(1.0 RC3\)}} if {[S [I 84 c 120] == 20011231]} {emit {\(1.0 RC3\)}} if {[S [I 84 c 120] > 20011231]} {emit {\(pre-1.0 CVS\)}} } } if {[S [I 84 c 96] == {Xiph.Org\ libVorbis\ I} c]} {emit {\b, created by: Xiph.Org libVorbis I} if {[S [I 84 c 117] > 00000000]} {if {[S [I 84 c 117] < 20020717]} {emit {\(pre-1.0 CVS\)}} if {[S [I 84 c 117] == 20020717]} {emit {\(1.0\)}} if {[S [I 84 c 117] == 20030909]} {emit {\(1.0.1\)}} if {[S [I 84 c 117] == 20040629]} {emit {\(1.1.0 RC1\)}} } } } } } } if {[N i 2 == 0x472b2c4e]} {emit {VXL data file,} if {[N s 0 > 0x0]} {emit {schema version no %d}} } if {[S 2 == {\040\040\040\040\040\040\040\040\040\040\040ML4D\040\'92}]} {emit {Smith Corona PWP} switch -- [Nv c 24] 2 {emit {\b, single spaced}} 3 {emit {\b, 1.5 spaced}} 4 {emit {\b, double spaced}} switch -- [Nv c 25] 66 {emit {\b, letter}} 84 {emit {\b, legal}} if {[N c 26 == 0x46]} {emit {\b, A4}} } if {[S 0 == {\377WPC\020\000\000\000\022\012\001\001\000\000\000\000}]} {emit {\(WP\) loadable text} switch -- [Nv c 15] 0 {emit {Optimized for Intel}} 1 {emit {Optimized for Non-Intel}} } if {[S 1 == WPC]} {emit {\(Corel/WP\)} switch -- [Nv Y 8] 257 {emit {WordPerfect macro}} 258 {emit {WordPerfect help file}} 259 {emit {WordPerfect keyboard file}} 266 {emit {WordPerfect document}} 267 {emit {WordPerfect dictionary}} 268 {emit {WordPerfect thesaurus}} 269 {emit {WordPerfect block}} 270 {emit {WordPerfect rectangular block}} 271 {emit {WordPerfect column block}} 272 {emit {WordPerfect printer data}} 275 {emit {WordPerfect printer data}} 276 {emit {WordPerfect driver resource data}} 279 {emit {WordPerfect hyphenation code}} 280 {emit {WordPerfect hyphenation data}} 281 {emit {WordPerfect macro resource data}} 283 {emit {WordPerfect hyphenation lex}} 285 {emit {WordPerfect wordlist}} 286 {emit {WordPerfect equation resource data}} 289 {emit {WordPerfect spell rules}} 290 {emit {WordPerfect dictionary rules}} 295 {emit {WordPerfect spell rules \(Microlytics\)}} 299 {emit {WordPerfect settings file}} 301 {emit {WordPerfect 4.2 document}} 325 {emit {WordPerfect dialog file}} 332 {emit {WordPerfect button bar}} 513 {emit {Shell macro}} 522 {emit {Shell definition}} 769 {emit {Notebook macro}} 770 {emit {Notebook help file}} 771 {emit {Notebook keyboard file}} 778 {emit {Notebook definition}} 1026 {emit {Calculator help file}} 1538 {emit {Calendar help file}} 1546 {emit {Calendar data file}} 1793 {emit {Editor macro}} 1794 {emit {Editor help file}} 1795 {emit {Editor keyboard file}} 1817 {emit {Editor macro resource file}} 2049 {emit {Macro editor macro}} 2050 {emit {Macro editor help file}} 2051 {emit {Macro editor keyboard file}} 2305 {emit {PlanPerfect macro}} 2306 {emit {PlanPerfect help file}} 2307 {emit {PlanPerfect keyboard file}} 2314 {emit {PlanPerfect worksheet}} 2319 {emit {PlanPerfect printer definition}} 2322 {emit {PlanPerfect graphic definition}} 2323 {emit {PlanPerfect data}} 2324 {emit {PlanPerfect temporary printer}} 2329 {emit {PlanPerfect macro resource data}} 2818 {emit {help file}} 2821 {emit {distribution list}} 2826 {emit {out box}} 2827 {emit {in box}} 2836 {emit {users archived mailbox}} 2837 {emit {archived message database}} 2838 {emit {archived attachments}} 3083 {emit {Printer temporary file}} 3330 {emit {Scheduler help file}} 3338 {emit {Scheduler in file}} 3339 {emit {Scheduler out file}} 3594 {emit {GroupWise settings file}} 3601 {emit {GroupWise directory services}} 3627 {emit {GroupWise settings file}} 4362 {emit {Terminal resource data}} 4363 {emit {Terminal resource data}} 4395 {emit {Terminal resource data}} 4619 {emit {GUI loadable text}} 4620 {emit {graphics resource data}} 4621 {emit {printer settings file}} 4622 {emit {port definition file}} 4623 {emit {print queue parameters}} 4624 {emit {compressed file}} 5130 {emit {Network service msg file}} 5131 {emit {Network service msg file}} 5132 {emit {Async gateway login msg}} 5134 {emit {GroupWise message file}} 7956 {emit {GroupWise admin domain database}} 7957 {emit {GroupWise admin host database}} 7959 {emit {GroupWise admin remote host database}} 7960 {emit {GroupWise admin ADS deferment data file}} 8458 {emit {IntelliTAG \(SGML\) compiled DTD}} if {[N c 8 == 0xb]} {emit Mail} switch -- [Nv Q 8] 18219264 {emit {WordPerfect graphic image \(1.0\)}} 18219520 {emit {WordPerfect graphic image \(2.0\)}} } if {[S 0 == {HWP\ Document\ File}]} {emit {Hangul \(Korean\) Word Processor File}} if {[S 0 == CSBK]} {emit {Ted Neslson's CosmicBook hypertext file}} if {[S 0 == %XDELTA%]} {emit {XDelta binary patch file 0.14}} if {[S 0 == %XDZ000%]} {emit {XDelta binary patch file 0.18}} if {[S 0 == %XDZ001%]} {emit {XDelta binary patch file 0.20}} if {[S 0 == %XDZ002%]} {emit {XDelta binary patch file 1.0}} if {[S 0 == %XDZ003%]} {emit {XDelta binary patch file 1.0.4}} if {[S 0 == %XDZ004%]} {emit {XDelta binary patch file 1.1}} if {[S 0 == core]} {emit {core file \(Xenix\)}} if {[S 0 == {\x55\x7A\x6E\x61}]} {emit {xo65 object,} if {[N s 4 x {}]} {emit {version %d,}} switch -- [Nv s 6 &0x0001] 1 {emit {with debug info}} 0 {emit {no debug info}} } if {[S 0 == {\x6E\x61\x55\x7A}]} {emit {xo65 library,} if {[N s 4 x {}]} {emit {version %d}} } if {[S 0 == {\x01\x00\x6F\x36\x35}]} {emit o65 switch -- [Nv s 6 &0x1000] 0 {emit executable,} 4096 {emit object,} if {[N c 5 x {}]} {emit {version %d,}} switch -- [Nv s 6 &0x8000] -32768 {emit 65816,} 0 {emit 6502,} switch -- [Nv s 6 &0x2000] 8192 {emit {32 bit,}} 0 {emit {16 bit,}} switch -- [Nv s 6 &0x4000] 16384 {emit {page reloc,}} 0 {emit {byte reloc,}} switch -- [Nv s 6 &0x0003] 0 {emit {alignment 1}} 1 {emit {alignment 2}} 2 {emit {alignment 4}} 3 {emit {alignment 256}} } if {[S 1 == mkx]} {emit {Compiled XKB Keymap: lsb,} if {[N c 0 > 0x0]} {emit {version %d}} if {[N c 0 == 0x0]} {emit obsolete} } if {[S 0 == xkm]} {emit {Compiled XKB Keymap: msb,} if {[N c 3 > 0x0]} {emit {version %d}} if {[N c 0 == 0x0]} {emit obsolete} } if {[S 0 == xFSdump0]} {emit {xfsdump archive} if {[N Q 8 x {}]} {emit {\(version %d\)}} } if {[S 0 == {ZyXEL\002}]} {emit {ZyXEL voice data} if {[N c 10 == 0x0]} {emit {- CELP encoding}} switch -- [Nv c 10 &0x0B] 1 {emit {- ADPCM2 encoding}} 2 {emit {- ADPCM3 encoding}} 3 {emit {- ADPCM4 encoding}} 8 {emit {- New ADPCM3 encoding}} if {[N c 10 == 0x4 &0x04]} {emit {with resync}} } result return {} } ## -- ** END GENERATED CODE ** -- ## -- Do not edit before this line ! ## # ### ### ### ######### ######### ######### ## Ready for use. # EOF tcllib-1.15/modules/fumagic/regenerate.sh0000644000175000017500000000054612077663116020005 0ustar sergeisergei#!/bin/sh # Point this to an unpacked source distribution of file(1) to # regenerate the recognizers. filesrc="$1" mime="${filesrc}/magic/magic.mime" type="${filesrc}/magic/Magdir" `dirname $0`/tmc -merge mimetypes.tcl '::fileutil::magic::mimetype::run' "${mime}" `dirname $0`/tmc -merge filetypes.tcl '::fileutil::magic::filetype::run' "${type}" exit 0 tcllib-1.15/modules/fumagic/rtcore.man0000644000175000017500000001756712077663116017336 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin fileutil::magic::rt n 1.0] [moddesc {file utilities}] [titledesc {Runtime core for file type recognition engines written in pure Tcl}] [category {Programming tools}] [require Tcl 8.4] [require fileutil::magic::rt [opt 1.0]] [description] [para] This package provides the runtime core for file type recognition engines written in pure Tcl and is thus used by all other packages in this module, i.e. the two frontend packages [package fileutil::magic::mimetypes] and [package fileutil::magic::filetypes], and the two engine compiler packages [package fileutil::magic::cgen] and [package fileutil::magic::cfront]. [section COMMANDS] [list_begin definitions] [call [cmd ::fileutil::magic::rt::open] [arg filename]] This command initializes the runtime and prepares the file [arg filename] for use by the system. This command has to be invoked first, before any other command of this package. [para] The command returns the channel handle of the opened file as its result. [call [cmd ::fileutil::magic::rt::close]] This command closes the last file opened via [cmd ::fileutil::magic::rt::open] and shuts the runtime down. This command has to be invoked last, after the file has been dealt with completely. Afterward another invokation of [cmd ::fileutil::magic::rt::open] is required to process another file. [para] This command returns the empty string as its result. [call [cmd ::fileutil::magic::rt::file_start] [arg name]] This command marks the start of a magic file when debugging. It returns the empty string as its result. [call [cmd ::fileutil::magic::rt::result] [opt [arg msg]]] This command returns the current result and stops processing. [para] If [arg msg] is specified its text is added to the result before it is returned. See [cmd ::fileutil::magic::rt::emit] for the allowed special character sequences. [call [cmd ::fileutil::magic::rt::resultv] [opt [arg msg]]] This command returns the current result. In contrast to [cmd ::fileutil::magic::rt::result] processing continues. [para] If [arg msg] is specified its text is added to the result before it is returned. See [cmd ::fileutil::magic::rt::emit] for the allowed special character sequences. [call [cmd ::fileutil::magic::rt::emit] [arg msg]] This command adds the text [arg msg] to the result buffer. The message may contain the following special character sequences. They will be replaced with buffered values before the message is added to the result. The command returns the empty string as its result. [list_begin definitions] [def [const \\b]] This sequence is removed [def [const %s]] Replaced with the last buffered string value. [def [const %ld]] Replaced with the last buffered numeric value. [def [const %d]] See above. [list_end] [comment [call [cmd ::fileutil::magic::rt::offset] [arg where]]] [comment { Handling of complex offsets. Currently not implemented. Always returns zero. }] [call [cmd ::fileutil::magic::rt::Nv] [arg type] [arg offset] [opt [arg qual]]] This command fetches the numeric value with [arg type] from the absolute location [arg offset] and returns it as its result. The fetched value is further stored in the numeric buffer. [para] If [arg qual] is specified it is considered to be a mask and applied to the fetched value before it is stored and returned. It has to have the form of a partial Tcl bit-wise expression, i.e. [example { & number }] For example: [example { Nv lelong 0 &0x8080ffff }] For the possible types see section [sectref {NUMERIC TYPES}]. [call [cmd ::fileutil::magic::rt::N] [arg type] [arg offset] [arg comp] [arg val] [opt [arg qual]]] This command behaves mostly like [cmd ::fileutil::magic::rt::Nv], except that it compares the fetched and masked value against [arg val] as specified with [arg comp] and returns the result of that comparison. [para] The argument [arg comp] has to contain one of Tcl's comparison operators, and the comparison made will be [example { }] [para] The special comparison operator [const x] signals that no comparison should be done, or, in other words, that the fetched value will always match [arg val]. [call [cmd ::fileutil::magic::rt::Nvx] [arg atlevel] [arg type] [arg offset] [opt [arg qual]]] This command behaves like [cmd ::fileutil::magic::rt::Nv], except that it additionally remembers the location in the file after the fetch in the calling context, for the level [arg atlevel], for later use by [cmd ::fileutil::magic::rt::R]. [call [cmd ::fileutil::magic::rt::Nx] [arg atlevel] [arg type] [arg offset] [arg comp] [arg val] [opt [arg qual]]] This command behaves like [cmd ::fileutil::magic::rt::N], except that it additionally remembers the location in the file after the fetch in the calling context, for the level [arg atlevel], for later use by [cmd ::fileutil::magic::rt::R]. [call [cmd ::fileutil::magic::rt::S] [arg offset] [arg comp] [arg val] [opt [arg qual]]] This command behaves like [cmd ::fileutil::magic::rt::N], except that it fetches and compares strings, not numeric data. The fetched value is also stored in the internal string buffer instead of the numeric buffer. [call [cmd ::fileutil::magic::rt::Sx] [arg atlevel] [arg offset] [arg comp] [arg val] [opt [arg qual]]] This command behaves like [cmd ::fileutil::magic::rt::S], except that it additionally remembers the location in the file after the fetch in the calling context, for the level [arg atlevel], for later use by [cmd ::fileutil::magic::rt::R]. [call [cmd ::fileutil::magic::rt::L] [arg newlevel]] This command sets the current level in the calling context to [arg newlevel]. The command returns the empty string as its result. [call [cmd ::fileutil::magic::rt::I] [arg base] [arg type] [arg delta]] This command handles base locations specified indirectly through the contents of the inspected file. It returns the sum of [arg delta] and the value of numeric [arg type] fetched from the absolute location [arg base]. [para] For the possible types see section [sectref {NUMERIC TYPES}]. [call [cmd ::fileutil::magic::rt::R] [arg offset]] This command handles base locations specified relative to the end of the last field one level above. [para] In other words, the command computes an absolute location in the file based on the relative [arg offset] and returns it as its result. The base the offset is added to is the last location remembered for the level in the calling context. [list_end] [section {NUMERIC TYPES}] [list_begin definitions] [def [const byte]] 8-bit integer [def [const short]] 16-bit integer, stored in native endianess [def [const beshort]] see above, stored in big endian [def [const leshort]] see above, stored in small/little endian [def [const long]] 32-bit integer, stored in native endianess [def [const belong]] see above, stored in big endian [def [const lelong]] see above, stored in small/little endian [list_end] All of the types above exit in an unsigned form as well. The type names are the same, with the character "u" added as prefix. [list_begin definitions] [def [const date]] 32-bit integer timestamp, stored in native endianess [def [const bedate]] see above, stored in big endian [def [const ledate]] see above, stored in small/little endian [def [const ldate]] 32-bit integer timestamp, stored in native endianess [def [const beldate]] see above, stored in big endian [def [const leldate]] see above, stored in small/little endian [list_end] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph {fileutil :: magic}] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [see_also fileutil file(1) magic(5)] [keywords type mime {file utilities} {file type} {file recognition}] [manpage_end] tcllib-1.15/modules/fumagic/rtcore.tcl0000644000175000017500000003105012077663116017324 0ustar sergeisergei# rtcore.tcl -- # # Runtime core for file type recognition engines written in pure Tcl. # # Copyright (c) 2004-2005 Colin McCormack # Copyright (c) 2005 Andreas Kupries # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: rtcore.tcl,v 1.5 2005/09/28 04:51:19 andreas_kupries Exp $ ##### # # "mime type recognition in pure tcl" # http://wiki.tcl.tk/12526 # # Tcl code harvested on: 10 Feb 2005, 04:06 GMT # Wiki page last updated: ??? # ##### # TODO - Required Functionality: # implement full offset language # implement pstring (pascal string, blerk) # implement regex form (blerk!) # implement string qualifiers # ### ### ### ######### ######### ######### ## Requirements package require Tcl 8.4 # ### ### ### ######### ######### ######### ## Implementation namespace eval ::fileutil::magic::rt { # Configuration flag. (De)activate debugging output. # This is done during initialization. # Changes at runtime have no effect. variable debug 0 # Runtime state. variable fd {} ; # Channel to file under scrutiny variable strbuf {} ; # Input cache [*]. variable cache ; # Cache of fetched and decoded numeric array set cache {} ; # values. variable result {} ; # Accumulated recognition result. variable string {} ; # Last recognized string | For substitution variable numeric -9999 ; # Last recognized number | into the message variable last ; # Behind last fetch locations, array set last {} ; # per nesting level. # [*] The vast majority of magic strings are in the first 4k of the file. # Export APIs (full public, recognizer public) namespace export open close file_start result namespace export emit offset Nv N S Nvx Nx Sx L R I } # ### ### ### ######### ######### ######### ## Public API, general use. # open the file to be scanned proc ::fileutil::magic::rt::open {file} { variable result {} variable string {} variable numeric -9999 variable strbuf variable fd variable cache set fd [::open $file] ::fconfigure $fd -translation binary # fill the string cache set strbuf [::read $fd 4096] # clear the fetch cache catch {unset cache} array set cache {} return $fd } proc ::fileutil::magic::rt::close {} { variable fd ::close $fd return } # mark the start of a magic file in debugging proc ::fileutil::magic::rt::file_start {name} { ::fileutil::magic::rt::Debug {puts stderr "File: $name"} } # return the emitted result proc ::fileutil::magic::rt::result {{msg ""}} { variable result if {$msg ne ""} {emit $msg} return -code return $result } proc ::fileutil::magic::rt::resultv {{msg ""}} { variable result if {$msg ne ""} {emit $msg} return $result } # ### ### ### ######### ######### ######### ## Public API, for use by a recognizer. # emit a message proc ::fileutil::magic::rt::emit {msg} { variable string variable numeric variable result set map [list \ \\b "" \ %s $string \ %ld $numeric \ %d $numeric \ ] lappend result [::string map $map $msg] return } # handle complex offsets - TODO proc ::fileutil::magic::rt::offset {where} { ::fileutil::magic::rt::Debug {puts stderr "OFFSET: $where"} return 0 } proc ::fileutil::magic::rt::Nv {type offset {qual ""}} { variable typemap variable numeric # unpack the type characteristics foreach {size scan} $typemap($type) break # fetch the numeric field from the file set numeric [Fetch $offset $size $scan] if {$qual ne ""} { # there's a mask to be applied set numeric [expr $numeric $qual] } ::fileutil::magic::rt::Debug {puts stderr "NV $type $offset $qual: $numeric"} return $numeric } # Numeric - get bytes of $type at $offset and $compare to $val # qual might be a mask proc ::fileutil::magic::rt::N {type offset comp val {qual ""}} { variable typemap variable numeric # unpack the type characteristics foreach {size scan} $typemap($type) break # fetch the numeric field set numeric [Fetch $offset $size $scan] # Would moving this before the fetch an optimisation ? The # tradeoff is that we give up filling the cache, and it is unclear # how often that value would be used. -- Profile! if {$comp eq "x"} { # anything matches - don't care return 1 } # get value in binary form, then back to numeric # this avoids problems with sign, as both values are # [binary scan]-converted identically binary scan [binary format $scan $val] $scan val if {$qual ne ""} { # there's a mask to be applied set numeric [expr $numeric $qual] } # perform comparison set c [expr $val $comp $numeric] ::fileutil::magic::rt::Debug {puts stderr "numeric $type: $val $comp $numeric / $qual - $c"} return $c } proc ::fileutil::magic::rt::S {offset comp val {qual ""}} { variable fd variable string # convert any backslashes set val [subst -nocommands -novariables $val] if {$comp eq "x"} { # match anything - don't care, just get the value set string "" # Query: Can we use GetString here ? # Or at least the strbuf cache ? # move to the offset ::seek $fd $offset while { ([::string length $string] < 100) && [::string is print [set c [::read $fd 1]]] } { if {[::string is space $c]} { break } append string $c } return 1 } # get the string and compare it set string [GetString $offset [::string length $val]] set cmp [::string compare $val $string] set c [expr $cmp $comp 0] ::fileutil::magic::rt::Debug { puts "String '$val' $comp '$string' - $c" if {$c} { puts "offset $offset - $string" } } return $c } proc ::fileutil::magic::rt::Nvx {atlevel type offset {qual ""}} { variable typemap variable numeric variable last upvar 1 level l set l $atlevel # unpack the type characteristics foreach {size scan} $typemap($type) break # fetch the numeric field from the file set numeric [Fetch $offset $size $scan] set last($atlevel) [expr {$offset + $size}] if {$qual ne ""} { # there's a mask to be applied set numeric [expr $numeric $qual] } ::fileutil::magic::rt::Debug {puts stderr "NV $type $offset $qual: $numeric"} return $numeric } # Numeric - get bytes of $type at $offset and $compare to $val # qual might be a mask proc ::fileutil::magic::rt::Nx {atlevel type offset comp val {qual ""}} { variable typemap variable numeric variable last upvar 1 level l set l $atlevel # unpack the type characteristics foreach {size scan} $typemap($type) break set last($atlevel) [expr {$offset + $size}] # fetch the numeric field set numeric [Fetch $offset $size $scan] if {$comp eq "x"} { # anything matches - don't care return 1 } # get value in binary form, then back to numeric # this avoids problems with sign, as both values are # [binary scan]-converted identically binary scan [binary format $scan $val] $scan val if {$qual ne ""} { # there's a mask to be applied set numeric [expr $numeric $qual] } # perform comparison set c [expr $val $comp $numeric] ::fileutil::magic::rt::Debug {puts stderr "numeric $type: $val $comp $numeric / $qual - $c"} return $c } proc ::fileutil::magic::rt::Sx {atlevel offset comp val {qual ""}} { variable fd variable string variable last upvar 1 level l set l $atlevel # convert any backslashes set val [subst -nocommands -novariables $val] if {$comp eq "x"} { # match anything - don't care, just get the value set string "" # Query: Can we use GetString here ? # Or at least the strbuf cache ? # move to the offset ::seek $fd $offset while { ([::string length $string] < 100) && [::string is print [set c [::read $fd 1]]] } { if {[::string is space $c]} { break } append string $c } set last($atlevel) [expr {$offset + [string length $string]}] return 1 } set len [::string length $val] set last($atlevel) [expr {$offset + $len}] # get the string and compare it set string [GetString $offset $len] set cmp [::string compare $val $string] set c [expr $cmp $comp 0] ::fileutil::magic::rt::Debug { puts "String '$val' $comp '$string' - $c" if {$c} { puts "offset $offset - $string" } } return $c } proc ::fileutil::magic::rt::L {newlevel} { # Regenerate level information in the calling context. upvar 1 level l ; set l $newlevel return } proc ::fileutil::magic::rt::I {base type delta} { # Handling of base locations specified indirectly through the # contents of the inspected file. variable typemap foreach {size scan} $typemap($type) break return [expr {[Fetch $base $size $scan] + $delta}] } proc ::fileutil::magic::rt::R {base} { # Handling of base locations specified relative to the end of the # last field one level above. variable last ; # Remembered locations. upvar 1 level l ; # The level to get data from. return [expr {$last($l) + $base}] } # ### ### ### ######### ######### ######### ## Internal. Retrieval of the data used in comparisons. # fetch and cache a numeric value from the file proc ::fileutil::magic::rt::Fetch {where what scan} { variable cache variable numeric variable fd if {![info exists cache($where,$what,$scan)]} { ::seek $fd $where binary scan [::read $fd $what] $scan numeric set cache($where,$what,$scan) $numeric # Optimization: If we got 4 bytes, i.e. long we implicitly # know the short and byte data as well. Should put them into # the cache. -- Profile: How often does such an overlap truly # happen ? } else { set numeric $cache($where,$what,$scan) } return $numeric } proc ::fileutil::magic::rt::GetString {offset len} { # We have the first 1k of the file cached variable string variable strbuf variable fd set end [expr {$offset + $len - 1}] if {$end < 4096} { # in the string cache, copy the requested part. set string [::string range $strbuf $offset $end] } else { # an unusual one, move to the offset and read directly from # the file. ::seek $fd $offset set string [::read $fd $len] } return $string } # ### ### ### ######### ######### ######### ## Internal, debugging. if {!$::fileutil::magic::rt::debug} { # This procedure definition is optimized out of using code by the # core bcc. It knows that neither argument checks are required, # nor is anything done. So neither results, nor errors are # possible, a true no-operation. proc ::fileutil::magic::rt::Debug {args} {} } else { proc ::fileutil::magic::rt::Debug {script} { # Run the commands in the debug script. This usually generates # some output. The uplevel is required to ensure the proper # resolution of all variables found in the script. uplevel 1 $script return } } # ### ### ### ######### ######### ######### ## Initialize constants namespace eval ::fileutil::magic::rt { # maps magic typenames to field characteristics: size (#byte), # binary scan format variable typemap } proc ::fileutil::magic::rt::Init {} { variable typemap global tcl_platform # Set the definitions for all types which have their endianess # explicitly specified n their name. array set typemap { byte {1 c} ubyte {1 c} beshort {2 S} ubeshort {2 S} leshort {2 s} uleshort {2 s} belong {4 I} ubelong {4 I} lelong {4 i} ulelong {4 i} bedate {4 S} ledate {4 s} beldate {4 I} leldate {4 i} long {4 Q} ulong {4 Q} date {4 Q} ldate {4 Q} short {2 Y} ushort {2 Y} } # Now set the definitions for the types without explicit # endianess. They assume/use 'native' byteorder. We also put in # special forms for the compiler, so that it can use short names # for the native-endian types as well. # generate short form names foreach {n v} [array get typemap] { foreach {len scan} $v break #puts stderr "Adding $scan - [list $len $scan]" set typemap($scan) [list $len $scan] } # The special Q and Y short forms are incorrect, correct now to # use the proper native endianess. if {$tcl_platform(byteOrder) eq "littleEndian"} { array set typemap {Q {4 i} Y {2 s}} } else { array set typemap {Q {4 I} Y {2 S}} } } ::fileutil::magic::rt::Init # ### ### ### ######### ######### ######### ## Ready for use. package provide fileutil::magic::rt 1.0 # EOF tcllib-1.15/modules/fumagic/filetypes.man0000644000175000017500000000332412077663116020026 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin fileutil::magic::filetype n 1.0.2] [moddesc {file utilities}] [titledesc {Procedures implementing file-type recognition}] [category {Programming tools}] [require Tcl 8.4] [require fileutil::magic::filetype [opt 1.0.2]] [description] [para] This package provides a command for the recognition of file types in pure Tcl. [para] The core part of the recognizer was generated from a "magic(5)" file containing the checks to perform to recognize files, and associated file-types. [para] [emph Beware!] This recognizer is large, about 276 Kilobyte of generated Tcl code. [list_begin definitions] [call [cmd ::fileutil::magic::filetype] [arg filename]] This command is similar to the command [cmd fileutil::fileType]. [para] The output of the command for the specified file is a string describing the type of the file. [para] This list will be empty if the type of the file is not recognized. [list_end] [section REFERENCES] [list_begin enumerated] [enum] [uri ftp://ftp.astron.com/pub/file/ {File(1) sources}] This site contains the current sources for the file command, including the magic definitions used by it. The latter were used by us to generate this recognizer. [list_end] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph {fileutil :: magic}] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [see_also fileutil file(1) magic(5)] [keywords type {file utilities} {file type} {file recognition}] [manpage_end] tcllib-1.15/modules/tar/0000755000175000017500000000000012104363635014470 5ustar sergeisergeitcllib-1.15/modules/tar/ChangeLog0000644000175000017500000001174512104363437016252 0ustar sergeisergei2013-02-01 Andreas Kupries * * Released and tagged Tcllib 1.15 ======================== * 2012-09-11 Andreas Kupries * tar.tcl (seekorskip): Fixed seekorskip which prevented its use * pkgIndex.tcl: from a non-seekable channel, like stdin. The issue was that the original attempt to seek before skipping not just failed, but apparently still moved the read pointer in some way which skipped over irreplacable input, breaking the next call of readHeader. Using [tell] to check seekability does not break in this manner. Bumped version to 0.7.1. 2011-12-13 Andreas Kupries * * Released and tagged Tcllib 1.14 ======================== * 2011-01-24 Andreas Kupries * * Released and tagged Tcllib 1.13 ======================== * 2011-01-20 Andreas Kupries * tar.tcl: [Bug 3162548]: Applied patch by Alexandre Ferrieux, * tar.man: extending various tar commands to be able to use * pkgIndex.tcl: the -chan option, and channels instead of files. Version bumped to 0.7 2009-12-07 Andreas Kupries * * Released and tagged Tcllib 1.12 ======================== * 2009-12-03 Andreas Kupries * tar.man: [Patch 2840147]. Applied. New options -prefix and * tar.tcl: -quick for tar::add. -prefix allows specifying a * tar.pcx: prefix for filenames in the archive, and -quick 1 * pkgIndex.tcl: changes back to the seek-from-end algorithm for finding the place where to add the new files. The new default scans from start (robust). Bumped version to 0.6. 2009-05-12 Aaron Faupell * tar.tcl: add support for reading pre-posix archives. if a file isnt writable when extracting, try deleting before giving up. 2008-12-12 Andreas Kupries * * Released and tagged Tcllib 1.11.1 ======================== * 2008-11-26 Aaron Faupell * tar.man: add and clarify documentation 2008-10-16 Andreas Kupries * * Released and tagged Tcllib 1.11 ======================== * 2008-06-14 Andreas Kupries * tar.pcx: New file. Syntax definitions for the public commands of the tar package. 2007-09-12 Andreas Kupries * * Released and tagged Tcllib 1.10 ======================== * 2007-03-21 Andreas Kupries * tar.man: Fixed all warnings due to use of now deprecated commands. Added a section about how to give feedback. 2007-02-08 Aaron Faupell * tar.tcl: bug fix in recursion algorithm that missed some files in deep subdirs. incremented version 2007-01-08 Andreas Kupries * tar.tcl: Bumped version to 0.3, for the bugfix described * tar.man: by the last entry. * pkgIndex.tcl: 2006-12-20 Aaron Faupell * tar.tcl: fix in parseOpts which affected -file and -glob arguments to tar::untar * tar.man: clarifications to add, create, and untar 2006-10-03 Andreas Kupries * * Released and tagged Tcllib 1.9 ======================== * 2006-29-06 Aaron Faupell * tar.tcl: fixed bug in parseOpts 2005-11-08 Andreas Kupries * pkgIndex.tcl: Corrected buggy commit, synchronized version * tar.man: numbers across all relevant files. 2005-11-08 Aaron Faupell * tar.tcl: bumped version to 0.2 because of new feature * tar.man: tar::remove 2005-11-07 Andreas Kupries * tar.man: Fixed error, incorrect placement of [call] markup outside of list. 2005-11-04 Aaron Faupell * tar.man: added tar::remove command and documentation for it * tar.tcl: 2005-10-06 Andreas Kupries * * Released and tagged Tcllib 1.8 ======================== * 2005-09-30 Andreas Kupries * tar.tcl: qualified all [open] calls with :: to ensure usag of the builtin. Apparently mitigates conflict between this package and the vfs::tar module. 2004-10-05 Andreas Kupries * * Released and tagged Tcllib 1.7 ======================== * 2004-10-02 Andreas Kupries * tar.man: Added keywords and title/module description to the documentation. 2004-09-10 Aaron Faupell * tar.tcl: Fixed typo bug in ::tar::add * tar.man: Added info for ::tar::stat 2004-08-23 Andreas Kupries * tar.man: Fixed problems in the documentation. tcllib-1.15/modules/tar/pkgIndex.tcl0000644000175000017500000000023512077663116016753 0ustar sergeisergeiif {![package vsatisfies [package provide Tcl] 8.2]} { # PRAGMA: returnok return } package ifneeded tar 0.7.1 [list source [file join $dir tar.tcl]] tcllib-1.15/modules/tar/tar.pcx0000644000175000017500000000367112077663116016007 0ustar sergeisergei# -*- tcl -*- tar.pcx # Syntax of the commands provided by package tar. # # For use by TclDevKit's static syntax checker (v4.1+). # See http://www.activestate.com/solutions/tcl/ # See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api # for the specification of the format of the code in this file. # package require pcx pcx::register tar pcx::tcldep 0.4 needs tcl 8.2 pcx::tcldep 0.5 needs tcl 8.2 pcx::tcldep 0.6 needs tcl 8.2 namespace eval ::tar {} #pcx::message FOO {... text ...} type #pcx::scan pcx::check 0.4 std ::tar::add \ {checkSimpleArgs 2 -1 { checkFileName {checkListValues 1 -1 checkFileName} {checkSwitches 1 { {-dereference checkBoolean} } {}} }} pcx::check 0.6 std ::tar::add \ {checkSimpleArgs 2 -1 { checkFileName {checkListValues 1 -1 checkFileName} {checkSwitches 1 { {-dereference checkBoolean} {-quick checkBoolean} {-prefix checkWord} } {}} }} pcx::check 0.4 std ::tar::contents \ {checkSimpleArgs 1 1 { checkFileName }} pcx::check 0.4 std ::tar::create \ {checkSimpleArgs 2 -1 { checkFileName {checkListValues 1 -1 checkFileName} {checkSwitches 1 { {-dereference checkBoolean} } {}} }} pcx::check 0.4 std ::tar::get \ {checkSimpleArgs 2 2 { checkFileName checkFileName }} pcx::check 0.4 std ::tar::remove \ {checkSimpleArgs 2 2 { checkFileName {checkListValues 1 -1 checkFileName} }} pcx::check 0.4 std ::tar::stat \ {checkSimpleArgs 1 2 { checkFileName checkFileName }} pcx::check 0.4 std ::tar::untar \ {checkSimpleArgs 1 -1 { checkFileName {checkSwitches 1 { {-dir checkFileName} {-file checkFileName} {-glob checkPattern} {-nooverwrite checkBoolean} {-nomtime checkBoolean} {-noperms checkBoolean} } {}} }} # Initialization via pcx::init. # Use a ::tar::init procedure for non-standard initialization. pcx::complete tcllib-1.15/modules/tar/tar.man0000644000175000017500000001375612077663116015775 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin tar n 0.7] [moddesc {Tar file handling}] [titledesc {Tar file creation, extraction & manipulation}] [category {File formats}] [require Tcl 8.4] [require tar [opt 0.7]] [description] [para] [list_begin definitions] [call [cmd ::tar::contents] [arg tarball] [opt [option -chan]]] Returns a list of the files contained in [arg tarball]. The order is not sorted and depends on the order files were stored in the archive. [para] If the option [option -chan] is present [arg tarball] is interpreted as an open channel. It is assumed that the channel was opened for reading, and configured for binary input. The command will [emph not] close the channel. [call [cmd ::tar::stat] [arg tarball] [opt file] [opt [option -chan]]] Returns a nested dict containing information on the named [opt file] in [arg tarball], or all files if none is specified. The top level are pairs of filename and info. The info is a dict with the keys "[const mode] [const uid] [const gid] [const size] [const mtime] [const type] [const linkname] [const uname] [const gname] [const devmajor] [const devminor]" [example { % ::tar::stat tarball.tar foo.jpg {mode 0644 uid 1000 gid 0 size 7580 mtime 811903867 type file linkname {} uname user gname wheel devmajor 0 devminor 0} }] [para] If the option [option -chan] is present [arg tarball] is interpreted as an open channel. It is assumed that the channel was opened for reading, and configured for binary input. The command will [emph not] close the channel. [call [cmd ::tar::untar] [arg tarball] [arg args]] Extracts [arg tarball]. [arg -file] and [arg -glob] limit the extraction to files which exactly match or pattern match the given argument. No error is thrown if no files match. Returns a list of filenames extracted and the file size. The size will be null for non regular files. Leading path seperators are stripped so paths will always be relative. [list_begin options] [opt_def -dir dirName] Directory to extract to. Uses [cmd pwd] if none is specified [opt_def -file fileName] Only extract the file with this name. The name is matched against the complete path stored in the archive including directories. [opt_def -glob pattern] Only extract files patching this glob style pattern. The pattern is matched against the complete path stored in the archive. [opt_def -nooverwrite] Dont overwrite files that already exist [opt_def -nomtime] Leave the file modification time as the current time instead of setting it to the value in the archive. [opt_def -noperms] In Unix, leave the file permissions as the current umask instead of setting them to the values in the archive. [opt_def -chan] If this option is present [arg tarball] is interpreted as an open channel. It is assumed that the channel was opened for reading, and configured for binary input. The command will [emph not] close the channel. [list_end] [para] [example { % foreach {file size} [::tar::untar tarball.tar -glob *.jpg] { puts "Extracted $file ($size bytes)" } }] [call [cmd ::tar::get] [arg tarball] [arg fileName] [opt [option -chan]]] Returns the contents of [arg fileName] from the [arg tarball] [para] [example { % set readme [::tar::get tarball.tar doc/README] { % puts $readme } }] [para] If the option [option -chan] is present [arg tarball] is interpreted as an open channel. It is assumed that the channel was opened for reading, and configured for binary input. The command will [emph not] close the channel. [call [cmd ::tar::create] [arg tarball] [arg files] [arg args]] Creates a new tar file containing the [arg files]. [arg files] must be specified as a single argument which is a proper list of filenames. [list_begin options] [opt_def -dereference] Normally [cmd create] will store links as an actual link pointing at a file that may or may not exist in the archive. Specifying this option will cause the actual file point to by the link to be stored instead. [opt_def -chan] If this option is present [arg tarball] is interpreted as an open channel. It is assumed that the channel was opened for writing, and configured for binary output. The command will [emph not] close the channel. [list_end] [para] [example { % ::tar::create new.tar [glob -nocomplain file*] % ::tar::contents new.tar file1 file2 file3 }] [call [cmd ::tar::add] [arg tarball] [arg files] [arg args]] Appends [arg files] to the end of the existing [arg tarball]. [arg files] must be specified as a single argument which is a proper list of filenames. [list_begin options] [opt_def -dereference] Normally [cmd add] will store links as an actual link pointing at a file that may or may not exist in the archive. Specifying this option will cause the actual file point to by the link to be stored instead. [opt_def -prefix string] Normally [cmd add] will store files under exactly the name specified as argument. Specifying a [opt -prefix] causes the [arg string] to be prepended to every name. [opt_def -quick] The only sure way to find the position in the [arg tarball] where new files can be added is to read it from start, but if [arg tarball] was written with a "blocksize" of 1 (as this package does) then one can alternatively find this position by seeking from the end. The [opt -quick] option tells [cmd add] to do the latter. [list_end] [para] [call [cmd ::tar::remove] [arg tarball] [arg files]] Removes [arg files] from the [arg tarball]. No error will result if the file does not exist in the tarball. Directory write permission and free disk space equivalent to at least the size of the tarball will be needed. [example { % ::tar::remove new.tar {file2 file3} % ::tar::contents new.tar file3 }] [list_end] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph tar] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords tar {tape archive} archive] [manpage_end] tcllib-1.15/modules/tar/tar.tcl0000644000175000017500000003370212077663116015775 0ustar sergeisergei# tar.tcl -- # # Creating, extracting, and listing posix tar archives # # Copyright (c) 2004 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: tar.tcl,v 1.17 2012/09/11 17:22:24 andreas_kupries Exp $ package provide tar 0.7.1 namespace eval ::tar {} proc ::tar::parseOpts {acc opts} { array set flags $acc foreach {x y} $acc {upvar $x $x} set len [llength $opts] set i 0 while {$i < $len} { set name [string trimleft [lindex $opts $i] -] if {![info exists flags($name)]} {return -code error "unknown option \"$name\""} if {$flags($name) == 1} { set $name [lindex $opts [expr {$i + 1}]] incr i $flags($name) } elseif {$flags($name) > 1} { set $name [lrange $opts [expr {$i + 1}] [expr {$i + $flags($name)}]] incr i $flags($name) } else { set $name 1 } incr i } } proc ::tar::pad {size} { set pad [expr {512 - ($size % 512)}] if {$pad == 512} {return 0} return $pad } proc ::tar::seekorskip {ch off wh} { if {[tell $ch] < 0} { if {$wh!="current"} { error "WHENCE=$wh not supported on non-seekable channel $ch" } skip $ch $off return } seek $ch $off $wh return } proc ::tar::skip {ch len} { while {$len>0} { set buf $len if {$buf>65536} {set buf 65536} set n [read $ch $buf] if {$n<$buf} break incr len -$buf } return } proc ::tar::readHeader {data} { binary scan $data a100a8a8a8a12a12a8a1a100a6a2a32a32a8a8a155 \ name mode uid gid size mtime cksum type \ linkname magic version uname gname devmajor devminor prefix foreach x {name type linkname} { set $x [string trim [set $x] "\x00"] } foreach x {uid gid size mtime cksum} { set $x [format %d 0[string trim [set $x] " \x00"]] } set mode [string trim $mode " \x00"] if {$magic == "ustar "} { # gnu tar # not fully supported foreach x {uname gname prefix} { set $x [string trim [set $x] "\x00"] } foreach x {devmajor devminor} { set $x [format %d 0[string trim [set $x] " \x00"]] } } elseif {$magic == "ustar\x00"} { # posix tar foreach x {uname gname prefix} { set $x [string trim [set $x] "\x00"] } foreach x {devmajor devminor} { set $x [format %d 0[string trim [set $x] " \x00"]] } } else { # old style tar foreach x {uname gname devmajor devminor prefix} { set $x {} } if {$type == ""} { if {[string match */ $name]} { set type 5 } else { set type 0 } } } return [list name $name mode $mode uid $uid gid $gid size $size mtime $mtime \ cksum $cksum type $type linkname $linkname magic $magic \ version $version uname $uname gname $gname devmajor $devmajor \ devminor $devminor prefix $prefix] } proc ::tar::contents {file args} { set chan 0 parseOpts {chan 0} $args if {$chan} { set fh $file } else { set fh [::open $file] fconfigure $fh -encoding binary -translation lf -eofchar {} } set ret {} while {![eof $fh]} { array set header [readHeader [read $fh 512]] if {$header(name) == ""} break lappend ret $header(prefix)$header(name) seekorskip $fh [expr {$header(size) + [pad $header(size)]}] current } if {!$chan} { close $fh } return $ret } proc ::tar::stat {tar {file {}} args} { set chan 0 parseOpts {chan 0} $args if {$chan} { set fh $tar } else { set fh [::open $tar] fconfigure $fh -encoding binary -translation lf -eofchar {} } set ret {} while {![eof $fh]} { array set header [readHeader [read $fh 512]] if {$header(name) == ""} break seekorskip $fh [expr {$header(size) + [pad $header(size)]}] current if {$file != "" && "$header(prefix)$header(name)" != $file} {continue} set header(type) [string map {0 file 5 directory 3 characterSpecial 4 blockSpecial 6 fifo 2 link} $header(type)] set header(mode) [string range $header(mode) 2 end] lappend ret $header(prefix)$header(name) [list mode $header(mode) uid $header(uid) gid $header(gid) \ size $header(size) mtime $header(mtime) type $header(type) linkname $header(linkname) \ uname $header(uname) gname $header(gname) devmajor $header(devmajor) devminor $header(devminor)] } if {!$chan} { close $fh } return $ret } proc ::tar::get {tar file args} { set chan 0 parseOpts {chan 0} $args if {$chan} { set fh $tar } else { set fh [::open $tar] fconfigure $fh -encoding binary -translation lf -eofchar {} } while {![eof $fh]} { array set header [readHeader [read $fh 512]] if {$header(name) == ""} break set name [string trimleft $header(prefix)$header(name) /] if {$name == $file} { set file [read $fh $header(size)] if {!$chan} { close $fh } return $file } seekorskip $fh [expr {$header(size) + [pad $header(size)]}] current } if {!$chan} { close $fh } return {} } proc ::tar::untar {tar args} { set nooverwrite 0 set data 0 set nomtime 0 set noperms 0 set chan 0 parseOpts {dir 1 file 1 glob 1 nooverwrite 0 nomtime 0 noperms 0 chan 0} $args if {![info exists dir]} {set dir [pwd]} set pattern * if {[info exists file]} { set pattern [string map {* \\* ? \\? \\ \\\\ \[ \\\[ \] \\\]} $file] } elseif {[info exists glob]} { set pattern $glob } set ret {} if {$chan} { set fh $tar } else { set fh [::open $tar] fconfigure $fh -encoding binary -translation lf -eofchar {} } while {![eof $fh]} { array set header [readHeader [read $fh 512]] if {$header(name) == ""} break set name [string trimleft $header(prefix)$header(name) /] if {![string match $pattern $name] || ($nooverwrite && [file exists $name])} { seekorskip $fh [expr {$header(size) + [pad $header(size)]}] current continue } set name [file join $dir $name] if {![file isdirectory [file dirname $name]]} { file mkdir [file dirname $name] lappend ret [file dirname $name] {} } if {[string match {[0346]} $header(type)]} { if {[catch {::open $name w+} new]} { # sometimes if we dont have write permission we can still delete catch {file delete -force $name} set new [::open $name w+] } fconfigure $new -encoding binary -translation lf -eofchar {} fcopy $fh $new -size $header(size) close $new lappend ret $name $header(size) } elseif {$header(type) == 5} { file mkdir $name lappend ret $name {} } elseif {[string match {[12]} $header(type)] && $::tcl_platform(platform) == "unix"} { catch {file delete $name} if {![catch {file link [string map {1 -hard 2 -symbolic} $header(type)] $name $header(linkname)}]} { lappend ret $name {} } } seekorskip $fh [pad $header(size)] current if {![file exists $name]} continue if {$::tcl_platform(platform) == "unix"} { if {!$noperms} { catch {file attributes $name -permissions 0[string range $header(mode) 2 end]} } catch {file attributes $name -owner $header(uid) -group $header(gid)} catch {file attributes $name -owner $header(uname) -group $header(gname)} } if {!$nomtime} { file mtime $name $header(mtime) } } if {!$chan} { close $fh } return $ret } ## # ::tar::statFile # # Returns stat info about a filesystem object, in the form of an info # dictionary like that returned by ::tar::readHeader. # # The mode, uid, gid, mtime, and type entries are always present. # The size and linkname entries are present if relevant for this type # of object. The uname and gname entries are present if the OS supports # them. No devmajor or devminor entry is present. ## proc ::tar::statFile {name followlinks} { if {$followlinks} { file stat $name stat } else { file lstat $name stat } set ret {} if {$::tcl_platform(platform) == "unix"} { lappend ret mode 1[file attributes $name -permissions] lappend ret uname [file attributes $name -owner] lappend ret gname [file attributes $name -group] if {$stat(type) == "link"} { lappend ret linkname [file link $name] } } else { lappend ret mode [lindex {100644 100755} [expr {$stat(type) == "directory"}]] } lappend ret uid $stat(uid) gid $stat(gid) mtime $stat(mtime) \ type $stat(type) if {$stat(type) == "file"} {lappend ret size $stat(size)} return $ret } ## # ::tar::formatHeader # # Opposite operation to ::tar::readHeader; takes a file name and info # dictionary as arguments, returns a corresponding (POSIX-tar) header. # # The following dictionary entries must be present: # mode # type # # The following dictionary entries are used if present, otherwise # the indicated default is used: # uid 0 # gid 0 # size 0 # mtime [clock seconds] # linkname {} # uname {} # gname {} # # All other dictionary entries, including devmajor and devminor, are # presently ignored. ## proc ::tar::formatHeader {name info} { array set A { linkname "" uname "" gname "" size 0 gid 0 uid 0 } set A(mtime) [clock seconds] array set A $info array set A {devmajor "" devminor ""} set type [string map {file 0 directory 5 characterSpecial 3 \ blockSpecial 4 fifo 6 link 2 socket A} $A(type)] set osize [format %o $A(size)] set ogid [format %o $A(gid)] set ouid [format %o $A(uid)] set omtime [format %o $A(mtime)] set name [string trimleft $name /] if {[string length $name] > 255} { return -code error "path name over 255 chars" } elseif {[string length $name] > 100} { set prefix [string range $name 0 end-100] set name [string range $name end-99 end] } else { set prefix "" } set header [binary format a100A8A8A8A12A12A8a1a100A6a2a32a32a8a8a155a12 \ $name $A(mode)\x00 $ouid\x00 $ogid\x00\ $osize\x00 $omtime\x00 {} $type \ $A(linkname) ustar\x00 00 $A(uname) $A(gname)\ $A(devmajor) $A(devminor) $prefix {}] binary scan $header c* tmp set cksum 0 foreach x $tmp {incr cksum $x} return [string replace $header 148 155 [binary format A8 [format %o $cksum]\x00]] } proc ::tar::recurseDirs {files followlinks} { foreach x $files { if {[file isdirectory $x] && ([file type $x] != "link" || $followlinks)} { if {[set more [glob -dir $x -nocomplain *]] != ""} { eval lappend files [recurseDirs $more $followlinks] } else { lappend files $x } } } return $files } proc ::tar::writefile {in out followlinks name} { puts -nonewline $out [formatHeader $name [statFile $in $followlinks]] set size 0 if {[file type $in] == "file" || ($followlinks && [file type $in] == "link")} { set in [::open $in] fconfigure $in -encoding binary -translation lf -eofchar {} set size [fcopy $in $out] close $in } puts -nonewline $out [string repeat \x00 [pad $size]] } proc ::tar::create {tar files args} { set dereference 0 set chan 0 parseOpts {dereference 0 chan 0} $args if {$chan} { set fh $tar } else { set fh [::open $tar w+] fconfigure $fh -encoding binary -translation lf -eofchar {} } foreach x [recurseDirs $files $dereference] { writefile $x $fh $dereference $x } puts -nonewline $fh [string repeat \x00 1024] if {!$chan} { close $fh } return $tar } proc ::tar::add {tar files args} { set dereference 0 set prefix "" set quick 0 parseOpts {dereference 0 prefix 1 quick 0} $args set fh [::open $tar r+] fconfigure $fh -encoding binary -translation lf -eofchar {} if {$quick} then { seek $fh -1024 end } else { set data [read $fh 512] while {[regexp {[^\0]} $data]} { array set header [readHeader $data] seek $fh [expr {$header(size) + [pad $header(size)]}] current set data [read $fh 512] } seek $fh -512 current } foreach x [recurseDirs $files $dereference] { writefile $x $fh $dereference $prefix$x } puts -nonewline $fh [string repeat \x00 1024] close $fh return $tar } proc ::tar::remove {tar files} { set n 0 while {[file exists $tar$n.tmp]} {incr n} set tfh [::open $tar$n.tmp w] set fh [::open $tar r] fconfigure $fh -encoding binary -translation lf -eofchar {} fconfigure $tfh -encoding binary -translation lf -eofchar {} while {![eof $fh]} { array set header [readHeader [read $fh 512]] if {$header(name) == ""} { puts -nonewline $tfh [string repeat \x00 1024] break } set name $header(prefix)$header(name) set len [expr {$header(size) + [pad $header(size)]}] if {[lsearch $files $name] > -1} { seek $fh $len current } else { seek $fh -512 current fcopy $fh $tfh -size [expr {$len + 512}] } } close $fh close $tfh file rename -force $tar$n.tmp $tar } tcllib-1.15/modules/stringprep/0000755000175000017500000000000012104363635016077 5ustar sergeisergeitcllib-1.15/modules/stringprep/unicode_data.tcl0000644000175000017500000031305212077663116021234 0ustar sergeisergei# unicode_data.tcl -- # # Declarations of Unicode character information tables. This file is # automatically generated by the gen_unicode_data.tcl script. Do not # modify this file by hand. # # Copyright (c) 1998 Scriptics Corporation. # Copyright (c) 2007 Alexey Shchepin # Copyright (c) 2007 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: unicode_data.tcl,v 1.1 2008/01/29 02:18:10 patthoyts Exp $ # # A 16-bit Unicode character is split into two parts in order to index # into the following tables. The lower CCLASS_OFFSET_BITS comprise an offset # into a page of characters. The upper bits comprise the page number. # package provide unicode::data 1.0.0 namespace eval ::unicode::data { set CCLASS_OFFSET_BITS 2 # # The cclassPageMap is indexed by page number and returns an alternate page number # that identifies a unique page of characters. Many Unicode characters map # to the same alternate page number. # array unset cclassPageMap array set cclassPageMap [list \ 192 1 193 1 194 1 195 1 196 1 197 2 198 3 199 4 200 5 201 6 202 7 203 4 \ 204 4 205 8 206 9 207 10 208 1 209 11 210 12 211 13 212 14 213 15 214 16 \ 215 17 216 18 217 1 218 1 219 1 288 19 289 20 356 21 357 22 358 23 359 1 \ 360 24 361 4 362 22 363 25 364 26 365 27 366 28 367 29 368 30 369 31 \ 388 1 389 32 402 33 403 34 404 35 405 36 406 1 407 37 412 38 437 39 \ 438 1 439 40 440 14 441 40 442 41 443 42 452 43 460 44 461 45 462 46 \ 463 47 464 22 465 47 466 37 506 19 507 1 508 22 591 48 595 49 596 50 \ 597 51 623 48 627 49 655 48 659 49 687 48 691 49 719 48 723 49 755 49 \ 787 49 789 52 815 48 819 49 851 49 882 53 910 54 914 55 942 56 946 57 \ 966 58 973 59 974 60 988 61 989 62 990 63 991 64 992 65 993 66 1009 67 \ 1037 68 1038 49 1239 19 1477 69 1485 69 1524 53 1527 70 1578 71 1614 72 \ 1669 19 1670 73 1741 48 1745 69 1754 19 1755 10 1756 1 1904 22 1905 1 \ 1906 74 1919 75 2100 76 2101 1 2102 77 2103 51 2104 70 2105 78 2106 79 \ 2107 4 3082 80 3083 81 3110 82 10753 53 16071 83 16264 1 17027 84 17038 85 \ 17039 86 29785 87 29786 88 29787 89 29788 90 29790 91 29791 4 29792 92 \ 29793 93 29794 24 29802 39 29803 32 29840 39 29841 51] set CCLASS_COMMON_PAGE_MAP 0 # # The cclassGroupMap is indexed by combining the alternate page number with # the page offset and returns a combining class number. # set cclassGroupMap [list \ 0 0 0 0 230 230 230 230 230 232 220 220 220 220 232 216 220 220 220 \ 220 220 202 202 220 220 220 220 202 202 220 220 220 1 1 1 1 1 220 220 \ 220 220 230 230 230 230 240 230 220 220 220 230 230 230 220 220 0 230 \ 230 230 220 220 220 220 230 232 220 220 230 233 234 234 233 234 234 \ 233 230 0 0 0 230 230 230 230 0 0 220 230 230 230 230 220 230 230 230 \ 222 220 230 230 220 220 230 222 228 230 10 11 12 13 14 15 16 17 18 \ 19 19 20 21 22 0 23 0 24 25 0 230 220 0 18 230 230 0 0 0 0 0 27 28 \ 29 30 31 32 33 34 230 230 220 220 230 220 230 230 0 35 0 0 0 0 0 230 \ 230 230 0 0 230 230 0 220 230 230 220 0 0 0 36 0 0 230 220 230 230 \ 220 230 230 220 220 220 230 220 220 230 220 230 7 0 0 0 0 9 0 0 0 230 \ 220 230 230 0 0 0 0 84 91 0 0 0 9 0 103 103 9 0 107 107 107 107 118 \ 118 0 0 122 122 122 122 220 220 0 0 0 220 0 220 0 216 0 0 0 129 130 \ 0 132 0 0 0 0 0 130 130 130 130 0 0 130 0 230 230 9 0 230 230 0 0 220 \ 0 0 0 0 7 9 0 0 0 0 230 0 0 0 228 0 0 0 222 230 220 220 0 0 0 230 230 \ 220 0 0 0 230 220 230 230 1 1 1 1 1 230 0 1 1 230 220 230 1 1 0 0 218 \ 228 232 222 224 224 0 8 8 0 0 0 26 0 0 220 0 230 230 1 220 0 0 0 0 \ 9 0 216 216 1 1 1 0 0 0 226 216 216 216 216 216 0 0 0 0 220 220 220 \ 220 0 0 230 230 230] proc GetUniCharCClass {uc} { variable CCLASS_OFFSET_BITS variable CCLASS_COMMON_PAGE_MAP variable cclassPageMap variable cclassGroupMap set page [expr {($uc & 0x1fffff) >> $CCLASS_OFFSET_BITS}] if {[info exists cclassPageMap($page)]} { set apage $cclassPageMap($page) } else { set apage $CCLASS_COMMON_PAGE_MAP } lindex $cclassGroupMap \ [expr {($apage << $CCLASS_OFFSET_BITS) | \ ($uc & ((1 << $CCLASS_OFFSET_BITS) - 1))}] } set DECOMP_OFFSET_BITS 3 # # The pageMap is indexed by page number and returns an alternate page number # that identifies a unique page of characters. Many Unicode characters map # to the same alternate page number. # array unset decompPageMap array set decompPageMap [list \ 20 1 21 2 22 3 23 4 24 5 25 6 26 7 27 8 28 9 29 10 30 11 31 12 32 13 \ 33 14 34 15 35 16 36 17 37 18 38 19 39 20 40 21 41 22 42 23 43 24 44 25 \ 45 26 46 27 47 28 52 29 53 30 54 31 56 32 57 33 58 34 59 35 60 36 61 37 \ 62 38 63 39 64 40 65 41 66 42 67 43 68 44 69 45 70 46 86 47 87 48 91 49 \ 92 50 104 51 110 52 111 53 112 54 113 55 114 56 117 57 118 58 121 59 \ 122 60 126 61 127 62 128 63 129 64 131 65 135 66 138 67 139 68 142 69 \ 152 70 154 71 155 72 156 73 157 74 158 75 159 76 176 77 196 78 206 79 \ 207 80 216 81 218 82 293 83 294 84 299 85 313 86 315 87 326 88 331 89 \ 361 90 363 91 370 92 377 93 393 94 408 95 409 96 425 97 443 98 454 99 \ 470 100 475 101 481 102 488 103 489 104 490 105 491 106 493 107 494 108 \ 495 109 496 110 498 111 499 112 500 113 501 114 503 115 516 116 543 117 \ 864 118 865 119 866 120 871 121 872 122 933 123 934 124 935 125 936 126 \ 937 127 938 128 939 129 940 130 941 131 943 132 947 133 948 134 949 135 \ 950 136 951 137 960 138 961 139 962 140 963 141 964 142 965 143 966 144 \ 967 145 968 146 969 147 970 148 971 149 972 150 973 151 974 152 975 153 \ 976 154 977 155 978 156 979 157 980 158 981 159 982 160 983 161 984 162 \ 985 163 986 164 987 165 988 166 989 167 990 168 991 169 992 170 993 171 \ 994 172 995 173 996 174 997 175 998 176 999 177 1000 178 1001 179 1002 180 \ 1003 181 1004 182 1005 183 1006 184 1007 185 1008 186 1009 187 1010 188 \ 1011 189 1012 190 1013 191 1014 192 1015 193 1016 194 1017 195 1018 196 \ 1019 197 1020 198 1021 199 1022 200 1023 201 1024 202 1025 203 1026 204 \ 1028 205 1029 206 1030 207 1031 208 1032 209 1033 210 1034 211 1035 206 \ 1038 212 1039 213 1040 214 1041 215 1042 216 1045 217 1056 218 1057 219 \ 1058 220 1059 221 1060 222 1061 223 1062 224 1063 225 1064 226 1065 227 \ 1066 228 1067 229 1068 230 1069 231 1070 232 1071 233 1075 234 1077 235 \ 1081 236 1088 237 1089 238 1092 239 1093 240 1094 241 1096 242 1097 243 \ 1100 244 1101 245 1102 246 1103 247 1104 248 1105 249 1109 250 1116 251 \ 1117 252 1125 253 1164 254 1165 255 1166 256 1167 257 1168 258 1169 259 \ 1170 260 1171 261 1172 262 1173 263 1174 264 1175 265 1176 266 1177 267 \ 1178 268 1179 269 1180 270 1181 271 1345 272 1358 273 1371 274 1453 275 \ 1491 276 1502 277 1504 278 1505 279 1506 280 1507 281 1508 282 1509 283 \ 1510 284 1511 285 1512 286 1513 287 1514 288 1515 289 1516 290 1517 291 \ 1518 292 1519 293 1520 294 1521 295 1522 296 1523 297 1524 298 1525 299 \ 1526 300 1527 301 1528 302 1529 303 1530 304 1536 1 1542 305 1543 306 \ 1545 307 1546 308 1547 309 1548 310 1549 311 1550 312 1551 313 1554 314 \ 1555 315 1557 316 1558 317 1559 318 1560 319 1561 320 1562 321 1563 322 \ 1566 323 1567 324 1574 325 1575 326 1576 327 1577 328 1578 329 1579 330 \ 1580 331 1581 332 1582 333 1583 334 1584 335 1585 336 1586 337 1587 338 \ 1600 339 1601 340 1602 341 1603 342 1604 343 1605 344 1606 345 1607 346 \ 1608 347 1610 348 1611 349 1612 350 1613 351 1614 352 1615 353 1616 354 \ 1617 355 1618 356 1619 357 1620 358 1621 359 1622 360 1623 361 1624 362 \ 1625 363 1626 364 1627 365 1628 366 1629 367 1630 368 1631 369 1632 370 \ 1633 371 1634 372 1635 373 1636 374 1637 375 1638 376 1639 377 1640 378 \ 1641 379 1642 380 1643 381 1644 382 1645 383 1646 384 1647 385 1648 386 \ 1649 387 1650 388 1651 389 1652 390 1653 391 1654 392 1655 393 1656 394 \ 1657 395 1658 396 1659 397 1660 398 1661 399 1662 400 1663 401 7968 402 \ 7969 403 7970 404 7971 405 7972 406 7973 407 7974 408 7975 409 7976 410 \ 7977 411 7978 412 7979 413 7980 414 7981 415 7982 416 7983 417 7984 418 \ 7985 419 7986 420 7987 421 7988 422 7989 423 7990 424 7991 425 7992 426 \ 7993 427 7994 428 7995 429 7996 430 7997 431 7998 432 7999 433 8000 434 \ 8001 435 8002 436 8003 437 8004 438 8005 439 8006 440 8007 441 8008 442 \ 8009 443 8010 444 8011 445 8012 446 8013 447 8014 448 8015 449 8016 450 \ 8017 451 8018 452 8019 453 8020 454 8021 455 8022 456 8023 457 8024 458 \ 8025 459 8026 460 8027 461 8032 462 8034 463 8035 464 8036 465 8037 466 \ 8038 467 8039 468 8040 469 8041 470 8042 471 8043 472 8044 473 8045 474 \ 8046 475 8047 476 8048 477 8049 478 8050 479 8051 480 8052 481 8053 482 \ 8054 483 8058 484 8059 485 8060 486 8061 487 8062 488 8063 489 8064 490 \ 8065 491 8066 492 8067 493 8068 494 8069 495 8070 496 8071 497 8072 498 \ 8073 499 8074 500 8075 501 8076 502 8077 503 8078 504 8079 505 8080 506 \ 8081 507 8082 508 8083 509 8084 510 8085 511 8086 512 8087 513 8088 514 \ 8089 515 8090 516 8091 517 8092 518 8093 519 8094 520 8095 521 8096 522 \ 8097 523 8098 524 8099 525 8100 526 8101 527 8102 528 8103 529 8106 530 \ 8107 531 8108 532 8109 533 8110 534 8111 535 8112 536 8113 537 8114 538 \ 8115 539 8116 540 8117 541 8118 542 8119 543 8120 544 8126 545 8127 546 \ 8130 547 8131 548 8134 549 8135 550 8136 551 8137 552 8138 553 8139 554 \ 8140 555 8141 556 8142 557 8143 558 8144 559 8145 560 8146 561 8147 562 \ 8148 563 8149 564 8150 565 8151 566 8152 567 8153 568 8154 569 8155 570 \ 8156 571 8157 572 8158 573 8159 574 8160 575 8161 576 8162 214 8163 577 \ 8164 578 8165 579 8166 580 8167 581 8168 582 8169 583 8170 584 8171 585 \ 8172 586 8173 587 8174 588 8175 589 8176 590 8177 591 8178 592 8179 593 \ 8180 594 8181 595 8182 596 8183 597 8184 598 8185 599 8186 600 8187 601 \ 8188 602 8189 603 14891 604 14892 605 14903 606 14904 607 14976 608 \ 14977 609 14978 610 14979 611 14980 612 14981 613 14982 614 14983 615 \ 14984 616 14985 617 14986 618 14987 619 14988 620 14989 608 14990 609 \ 14991 610 14992 611 14993 612 14994 613 14995 621 14996 622 14997 623 \ 14998 617 14999 624 15000 625 15001 620 15002 608 15003 609 15004 610 \ 15005 611 15006 612 15007 613 15008 626 15009 627 15010 628 15011 629 \ 15012 630 15013 619 15014 620 15015 631 15016 632 15017 633 15018 634 \ 15019 612 15020 613 15021 614 15022 615 15023 616 15024 617 15025 630 \ 15026 619 15027 620 15028 608 15029 609 15030 610 15031 611 15032 612 \ 15033 613 15034 614 15035 615 15036 616 15037 617 15038 630 15039 619 \ 15040 620 15041 608 15042 609 15043 610 15044 611 15045 612 15046 613 \ 15047 614 15048 615 15049 616 15050 617 15051 630 15052 619 15053 620 \ 15054 608 15055 609 15056 610 15057 611 15058 612 15059 613 15060 635 \ 15061 636 15062 637 15063 638 15064 639 15065 640 15066 641 15067 642 \ 15068 643 15069 644 15070 645 15071 646 15072 647 15073 648 15074 649 \ 15075 650 15076 651 15077 652 15078 653 15079 654 15080 655 15081 656 \ 15082 657 15083 658 15084 659 15085 660 15086 661 15087 662 15088 663 \ 15089 664 15090 636 15091 637 15092 638 15093 639 15094 640 15095 641 \ 15096 642 15097 665 15098 666 15099 214 15100 667 15101 668 15102 669 \ 15103 666 24320 670 24321 671 24322 672 24323 673 24324 674 24325 675 \ 24326 676 24327 677 24328 678 24329 679 24330 680 24331 681 24332 682 \ 24333 683 24334 684 24335 685 24336 686 24337 687 24338 688 24339 689 \ 24340 690 24341 691 24342 692 24343 693 24344 694 24345 695 24346 696 \ 24347 697 24348 698 24349 699 24350 700 24351 701 24352 702 24353 703 \ 24354 704 24355 705 24356 706 24357 707 24358 708 24359 709 24360 710 \ 24361 711 24362 712 24363 713 24364 714 24365 715 24366 716 24367 717 \ 24368 718 24369 719 24370 720 24371 721 24372 722 24373 723 24374 724 \ 24375 725 24376 726 24377 727 24378 728 24379 729 24380 730 24381 731 \ 24382 732 24383 733 24384 734 24385 735 24386 736 24387 737] set DECOMP_COMMON_PAGE_MAP 0 # # The decompGroupMap is indexed by combining the alternate page number with # the page offset and returns a group number that identifies a length and # shift of decomposition sequence in decompList # set decompGroupMap [list \ -1 -1 -1 -1 -1 -1 -1 -1 196608 -1 -1 -1 -1 -1 -1 -1 327681 -1 196611 \ -1 -1 -1 -1 327684 -1 -1 196614 196615 327688 196618 -1 -1 327691 196621 \ 196622 -1 458767 458770 458773 -1 262168 262170 262172 262174 262176 \ 262178 -1 262180 262182 262184 262186 262188 262190 262192 262194 262196 \ -1 262198 262200 262202 262204 262206 262208 -1 -1 262210 262212 262214 \ 262216 262218 -1 -1 262220 262222 262224 262226 262228 262230 -1 262232 \ 262234 262236 262238 262240 262242 262244 262246 262248 -1 262250 262252 \ 262254 262256 262258 262260 -1 -1 262262 262264 262266 262268 262270 \ -1 262272 262274 262276 262278 262280 262282 262284 262286 262288 262290 \ 262292 262294 262296 262298 262300 262302 262304 -1 -1 262306 262308 \ 262310 262312 262314 262316 262318 262320 262322 262324 262326 262328 \ 262330 262332 262334 262336 262338 262340 262342 262344 -1 -1 262346 \ 262348 262350 262352 262354 262356 262358 262360 262362 -1 327900 327902 \ 262368 262370 262372 262374 -1 262376 262378 262380 262382 262384 262386 \ 327924 327926 -1 -1 262392 262394 262396 262398 262400 262402 327940 \ -1 -1 262406 262408 262410 262412 262414 262416 -1 -1 262418 262420 \ 262422 262424 262426 262428 262430 262432 262434 262436 262438 262440 \ 262442 262444 262446 262448 262450 262452 -1 -1 262454 262456 262458 \ 262460 262462 262464 262466 262468 262470 262472 262474 262476 262478 \ 262480 262482 262484 262486 262488 262490 262492 262494 262496 262498 \ 196964 262501 262503 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 262505 \ 262507 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 328045 328047 328049 328051 \ 328053 328055 328057 328059 328061 262527 262529 262531 262533 262535 \ 262537 262539 262541 262543 262545 262547 262549 262551 262553 262555 \ 262557 -1 262559 262561 262563 262565 262567 262569 -1 -1 262571 262573 \ 262575 262577 262579 262581 262583 262585 262587 262589 262591 328129 \ 328131 328133 262599 262601 -1 -1 262603 262605 262607 262609 262611 \ 262613 262615 262617 262619 262621 262623 262625 262627 262629 262631 \ 262633 262635 262637 262639 262641 262643 262645 262647 262649 262651 \ 262653 262655 262657 262659 262661 262663 262665 262667 262669 262671 \ 262673 -1 -1 262675 262677 -1 -1 -1 -1 -1 -1 262679 262681 262683 262685 \ 262687 262689 262691 262693 262695 262697 262699 262701 262703 262705 \ -1 -1 -1 -1 197171 197172 197173 197174 197175 197176 197177 197178 \ 197179 -1 -1 -1 -1 -1 -1 -1 328252 328254 328256 328258 328260 328262 \ -1 -1 197192 197193 196964 197194 197195 -1 -1 -1 131660 131661 -1 \ 131662 262735 -1 -1 -1 -1 -1 -1 -1 131665 -1 -1 -1 -1 -1 328274 -1 \ -1 -1 131668 -1 -1 -1 -1 -1 327688 262741 262743 131673 262746 262748 \ 262750 -1 262752 -1 262754 262756 262758 -1 -1 -1 -1 -1 -1 -1 -1 -1 \ 262760 262762 262764 262766 262768 262770 262772 -1 -1 -1 -1 -1 -1 \ -1 -1 -1 262774 262776 262778 262780 262782 -1 197248 197249 197250 \ 262787 262789 197255 197256 -1 197257 197258 197259 -1 197260 197261 \ -1 -1 -1 197262 -1 -1 -1 -1 -1 -1 262799 262801 -1 262803 -1 -1 -1 \ 262805 -1 -1 -1 -1 262807 262809 262811 -1 -1 262813 -1 -1 -1 -1 -1 \ -1 -1 262815 -1 -1 -1 -1 -1 -1 262817 262819 -1 262821 -1 -1 -1 262823 \ -1 -1 -1 -1 262825 262827 262829 -1 -1 -1 -1 -1 -1 -1 262831 262833 \ -1 262835 262837 -1 -1 -1 -1 -1 262839 262841 262843 262845 -1 -1 262847 \ 262849 -1 -1 262851 262853 262855 262857 262859 262861 -1 -1 262863 \ 262865 262867 262869 262871 262873 -1 -1 262875 262877 262879 262881 \ 262883 262885 262887 262889 262891 262893 262895 262897 -1 -1 262899 \ 262901 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 328439 -1 -1 262905 262907 \ 262909 262911 262913 -1 -1 -1 -1 -1 -1 328451 328453 328455 328457 \ -1 -1 -1 -1 -1 -1 -1 262923 -1 262925 -1 -1 -1 -1 -1 -1 -1 -1 262927 \ -1 -1 -1 -1 -1 262929 -1 -1 -1 -1 -1 -1 -1 262931 -1 -1 262933 -1 -1 \ -1 262935 262937 262939 262941 262943 262945 262947 262949 -1 -1 -1 \ 262951 262953 -1 -1 -1 -1 -1 -1 -1 262955 262957 -1 262959 -1 -1 -1 \ 262961 -1 -1 262963 -1 -1 262965 262967 262969 -1 -1 262971 -1 262973 \ -1 -1 262975 262977 -1 -1 -1 -1 -1 -1 -1 262979 262981 -1 -1 -1 -1 \ -1 -1 262983 -1 -1 -1 -1 -1 262985 262987 262989 -1 -1 -1 262991 -1 \ -1 -1 -1 -1 -1 -1 262993 -1 -1 -1 -1 -1 -1 262995 262997 -1 262999 \ 263001 -1 -1 -1 -1 -1 -1 263003 263005 263007 -1 -1 -1 -1 -1 263009 \ -1 263011 263013 263015 -1 -1 -1 -1 328553 -1 -1 -1 -1 -1 -1 -1 328555 \ -1 -1 -1 -1 -1 -1 -1 -1 328557 328559 -1 -1 -1 -1 -1 -1 197489 -1 -1 \ -1 -1 -1 -1 263026 -1 -1 -1 -1 -1 -1 -1 -1 -1 263028 -1 -1 -1 -1 263030 \ -1 -1 -1 -1 263032 -1 -1 -1 -1 263034 -1 -1 -1 -1 263036 -1 -1 -1 -1 \ -1 -1 -1 -1 -1 263038 -1 263040 263042 328580 263046 328584 -1 -1 -1 \ -1 -1 -1 -1 263050 -1 -1 -1 -1 -1 -1 -1 -1 -1 263052 -1 -1 -1 -1 -1 \ -1 -1 -1 -1 263054 -1 -1 -1 -1 263056 -1 -1 -1 -1 263058 -1 -1 -1 -1 \ 263060 -1 -1 -1 -1 263062 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 263064 \ -1 -1 -1 -1 -1 197530 -1 -1 -1 -1 -1 -1 -1 -1 -1 263067 -1 263069 -1 \ 263071 -1 263073 -1 263075 -1 -1 -1 263077 -1 -1 -1 -1 -1 -1 -1 -1 \ 263079 -1 263081 -1 -1 263083 263085 -1 263087 -1 -1 -1 -1 -1 -1 -1 \ -1 197553 197554 197555 -1 197556 197557 197558 197559 197560 197561 \ 197562 197563 197564 197565 197566 -1 197567 197568 197569 197570 197571 \ 197572 197573 196611 197574 197575 197576 197577 197578 197579 197580 \ 197581 197582 197583 -1 197584 197585 197586 196622 197587 197588 197589 \ 197590 197591 197592 197593 197594 197595 197596 197248 197597 197598 \ 197255 197599 197600 197174 197592 197595 197248 197597 197258 197255 \ 197599 -1 -1 -1 -1 -1 197601 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 197602 197603 \ 197604 197605 197582 197606 197607 197608 197609 197610 197611 197612 \ 197613 197614 197615 197616 197617 197618 197619 197620 197621 197622 \ 197623 197624 197625 197626 197627 197628 197629 197630 197631 197632 \ 197633 197634 197635 197636 197249 263173 263175 263177 263179 263181 \ 263183 263185 263187 263189 263191 263193 263195 263197 263199 263201 \ 263203 263205 263207 263209 263211 263213 263215 263217 263219 263221 \ 263223 263225 263227 263229 263231 263233 263235 263237 263239 263241 \ 263243 263245 263247 263249 263251 263253 263255 263257 263259 263261 \ 263263 263265 263267 263269 263271 263273 263275 263277 263279 263281 \ 263283 263285 263287 263289 263291 263293 263295 263297 263299 263301 \ 263303 263305 263307 263309 263311 263313 263315 263317 263319 263321 \ 263323 263325 263327 263329 263331 263333 263335 263337 263339 263341 \ 263343 263345 263347 263349 263351 263353 263355 263357 263359 263361 \ 263363 263365 263367 263369 263371 263373 263375 263377 263379 263381 \ 263383 263385 263387 263389 263391 263393 263395 263397 263399 263401 \ 263403 263405 263407 263409 263411 263413 263415 263417 263419 263421 \ 263423 263425 263427 263429 263431 263433 263435 263437 263439 263441 \ 263443 263445 263447 263449 263451 263453 263455 263457 263459 263461 \ 263463 263465 263467 263469 263471 263473 263475 263477 263479 329017 \ 263483 -1 -1 -1 -1 263485 263487 263489 263491 263493 263495 263497 \ 263499 263501 263503 263505 263507 263509 263511 263513 263515 263517 \ 263519 263521 263523 263525 263527 263529 263531 263533 263535 263537 \ 263539 263541 263543 263545 263547 263549 263551 263553 263555 263557 \ 263559 263561 263563 263565 263567 263569 263571 263573 263575 263577 \ 263579 263581 263583 263585 263587 263589 263591 263593 263595 263597 \ 263599 263601 263603 263605 263607 263609 263611 263613 263615 263617 \ 263619 263621 263623 263625 263627 263629 263631 263633 263635 263637 \ 263639 263641 263643 263645 263647 263649 263651 263653 263655 263657 \ 263659 263661 263663 -1 -1 -1 -1 -1 -1 263665 263667 263669 263671 \ 263673 263675 263677 263679 263681 263683 263685 263687 263689 263691 \ 263693 263695 263697 263699 263701 263703 263705 263707 -1 -1 263709 \ 263711 263713 263715 263717 263719 -1 -1 263721 263723 263725 263727 \ 263729 263731 263733 263735 263737 263739 263741 263743 263745 263747 \ 263749 263751 263753 263755 263757 263759 263761 263763 263765 263767 \ 263769 263771 263773 263775 263777 263779 263781 263783 263785 263787 \ 263789 263791 263793 263795 -1 -1 263797 263799 263801 263803 263805 \ 263807 -1 -1 263809 263811 263813 263815 263817 263819 263821 263823 \ -1 263825 -1 263827 -1 263829 -1 263831 263833 263835 263837 263839 \ 263841 263843 263845 263847 263849 263851 263853 263855 263857 263859 \ 263861 263863 263865 132795 263868 132798 263871 132801 263874 132804 \ 263877 132807 263880 132810 263883 132813 -1 -1 263886 263888 263890 \ 263892 263894 263896 263898 263900 263902 263904 263906 263908 263910 \ 263912 263914 263916 263918 263920 263922 263924 263926 263928 263930 \ 263932 263934 263936 263938 263940 263942 263944 263946 263948 263950 \ 263952 263954 263956 263958 263960 263962 263964 263966 263968 263970 \ 263972 263974 263976 263978 263980 263982 263984 263986 263988 263990 \ -1 263992 263994 263996 263998 264000 132930 264003 329541 132935 329541 \ 329544 264010 264012 264014 264016 -1 264018 264020 264022 132952 264025 \ 132955 264028 264030 264032 264034 264036 264038 264040 132970 -1 -1 \ 264043 264045 264047 264049 264051 132981 -1 264054 264056 264058 264060 \ 264062 264064 132994 264067 264069 264071 264073 264075 264077 264079 \ 133009 264082 264084 133014 133015 -1 -1 264088 264090 264092 -1 264094 \ 264096 264098 133028 264101 133031 264104 133034 329643 -1 133037 133038 \ 196608 196608 196608 196608 196608 196608 196608 196608 196608 -1 -1 \ -1 -1 -1 -1 198575 -1 -1 -1 -1 -1 329648 -1 -1 -1 -1 198578 329651 \ 460725 -1 -1 -1 -1 -1 -1 -1 -1 196608 -1 -1 -1 329656 460730 -1 329661 \ 460735 -1 -1 -1 -1 329666 -1 329668 -1 -1 -1 -1 -1 -1 -1 -1 329670 \ 329672 329674 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 591820 198608 \ 197600 -1 -1 198609 198610 198611 198612 198613 198614 198615 198616 \ 198617 198618 198619 198620 198608 196621 196614 196615 198609 198610 \ 198611 198612 198613 198614 198615 198616 198617 198618 198619 -1 196611 \ 197579 196622 197194 197580 -1 -1 -1 329693 -1 -1 -1 -1 -1 -1 -1 460767 \ 460770 198629 329702 -1 460776 460779 198638 -1 329711 197583 197560 \ 197560 197560 197171 198641 197561 197561 197564 197193 -1 197566 329714 \ -1 -1 197569 198644 197570 197570 197570 -1 -1 329717 460791 329722 \ -1 198652 -1 133117 -1 198652 -1 132027 133118 197555 198629 -1 197579 \ 197557 198655 -1 197565 196622 198656 198657 198658 198659 197600 -1 \ 460804 197256 197597 198663 198664 198665 -1 -1 -1 -1 197556 197578 \ 197579 197600 197173 -1 -1 -1 -1 -1 -1 -1 -1 -1 460810 460813 460816 \ 460819 460822 460825 460828 460831 460834 460837 460840 460843 329774 \ 197561 329776 460850 329781 198711 329784 460858 591933 329793 198723 \ 329796 460870 197564 198629 197556 197565 197600 329801 460875 329806 \ 197595 329808 460882 591957 329817 197194 329819 460893 197193 197603 \ 197578 197585 -1 -1 264288 264290 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 264292 \ -1 -1 -1 -1 -1 -1 264294 264296 264298 -1 -1 -1 -1 264300 -1 -1 -1 \ -1 264302 -1 -1 264304 -1 -1 -1 -1 -1 -1 -1 264306 -1 264308 -1 -1 \ -1 -1 -1 329846 460920 -1 329851 460925 -1 -1 -1 -1 -1 -1 -1 -1 264320 \ -1 -1 264322 -1 -1 264324 -1 264326 -1 -1 -1 -1 -1 -1 264328 -1 264330 \ -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 264332 264334 264336 264338 264340 -1 \ -1 264342 264344 -1 -1 264346 264348 -1 -1 -1 -1 -1 -1 264350 264352 \ -1 -1 264354 264356 -1 -1 264358 264360 -1 -1 -1 -1 -1 -1 -1 -1 -1 \ -1 264362 264364 264366 264368 264370 264372 264374 264376 -1 -1 -1 \ -1 -1 -1 264378 264380 264382 264384 -1 -1 -1 133314 133315 -1 -1 -1 \ -1 -1 196621 196614 196615 198609 198610 198611 198612 198613 198614 \ 329924 329926 329928 329930 329932 329934 329936 329938 329940 329942 \ 329944 461018 461021 461024 461027 461030 461033 461036 461039 461042 \ 592117 592121 592125 592129 592133 592137 592141 592145 592149 592153 \ 592157 330017 330019 330021 330023 330025 330027 330029 330031 330033 \ 461107 461110 461113 461116 461119 461122 461125 461128 461131 461134 \ 461137 461140 461143 461146 461149 461152 461155 461158 461161 461164 \ 461167 461170 461173 461176 461179 461182 461185 461188 461191 461194 \ 461197 461200 461203 461206 461209 461212 461215 197553 197555 198629 \ 197556 197557 198655 197559 197560 197561 197562 197563 197564 197565 \ 197566 197567 197569 198644 197570 199074 197571 197572 198711 197573 \ 198723 199075 198652 196611 197577 197603 197578 197579 197606 197583 \ 197171 197600 197173 197584 197193 197585 198620 196622 197590 199076 \ 197174 196964 197591 197592 197595 197178 197194 197179 197633 198608 \ -1 -1 -1 -1 -1 -1 -1 -1 -1 592293 -1 -1 -1 -1 -1 -1 -1 461225 330156 \ 461230 -1 -1 -1 -1 -1 264625 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 199091 -1 \ -1 -1 -1 -1 -1 -1 199092 -1 -1 -1 199093 -1 -1 -1 -1 199094 199095 \ 199096 199097 199098 199099 199100 199101 199102 199103 199104 199105 \ 199106 199107 199108 199109 199110 199111 199112 199113 199114 199115 \ 199116 199117 199118 199119 199120 199121 199122 199123 199124 199125 \ 199126 199127 199128 199129 199130 199131 199132 199133 199134 199135 \ 199136 199137 199138 199139 199140 199141 199142 199143 199144 199145 \ 199146 199147 199148 199149 199150 199151 199152 199153 199154 199155 \ 199156 199157 199158 199159 199160 199161 199162 199163 199164 199165 \ 199166 199167 199168 199169 199170 199171 199172 199173 199174 199175 \ 199176 199177 199178 199179 199180 199181 199182 199183 199184 199185 \ 199186 199187 199188 199189 199190 199191 199192 199193 199194 199195 \ 199196 199197 199198 199199 199200 199201 199202 199203 199204 199205 \ 199206 199207 199208 199209 199210 199211 199212 199213 199214 199215 \ 199216 199217 199218 199219 199220 199221 199222 199223 199224 199225 \ 199226 199227 199228 199229 199230 199231 199232 199233 199234 199235 \ 199236 199237 199238 199239 199240 199241 199242 199243 199244 199245 \ 199246 199247 199248 199249 199250 199251 199252 199253 199254 199255 \ 199256 199257 199258 199259 199260 199261 199262 199263 199264 199265 \ 199266 199267 199268 199269 199270 199271 199272 199273 199274 199275 \ 199276 199277 199278 199279 199280 199281 199282 199283 199284 199285 \ 199286 199287 199288 199289 199290 199291 199292 199293 199294 199295 \ 199296 199297 199298 199299 199300 199301 199302 199303 199304 199305 \ 199306 199307 -1 -1 -1 -1 -1 -1 -1 -1 199308 -1 199117 199309 199310 \ -1 -1 -1 -1 -1 -1 -1 -1 -1 264847 -1 264849 -1 264851 -1 264853 -1 \ 264855 -1 264857 -1 264859 -1 264861 -1 264863 -1 264865 -1 264867 \ -1 264869 -1 -1 264871 -1 264873 -1 264875 -1 -1 -1 -1 -1 -1 264877 \ 264879 -1 264881 264883 -1 264885 264887 -1 264889 264891 -1 264893 \ 264895 -1 -1 -1 -1 -1 -1 264897 -1 -1 -1 -1 -1 -1 330435 330437 -1 \ 264903 330441 -1 -1 -1 -1 264907 -1 264909 -1 264911 -1 264913 -1 264915 \ -1 264917 -1 264919 -1 264921 -1 264923 -1 264925 -1 264927 -1 264929 \ -1 -1 264931 -1 264933 -1 264935 -1 -1 -1 -1 -1 -1 264937 264939 -1 \ 264941 264943 -1 264945 264947 -1 264949 264951 -1 264953 264955 -1 \ -1 -1 -1 -1 -1 264957 -1 -1 264959 264961 264963 264965 -1 -1 -1 264967 \ 330505 -1 199435 199436 199437 199438 199439 199440 199441 199442 199443 \ 199444 199445 199446 199447 199448 199449 199450 199451 199452 199453 \ 199454 199455 199456 199457 199458 199459 199460 199461 199462 199463 \ 199464 199465 199466 199467 199468 199469 199470 199471 199472 199473 \ 199474 199475 199476 199477 199478 199479 199480 199481 199482 199483 \ 199484 199485 199486 199487 199488 199489 199490 199491 199492 199493 \ 199494 199495 199496 199497 199498 199499 199500 199501 199502 199503 \ 199504 199505 199506 199507 199508 199509 199510 199511 199512 199513 \ 199514 199515 199516 199517 199518 199519 199520 199521 199522 199523 \ 199524 199525 199526 199527 199528 -1 -1 -1 199094 199100 199529 199530 \ 199531 199532 199533 199534 199098 199535 199536 199537 199538 199102 \ 461683 461686 461689 461692 461695 461698 461701 461704 461707 461710 \ 461713 461716 461719 461722 592797 592801 592805 592809 592813 592817 \ 592821 592825 592829 592833 592837 592841 592845 592849 592853 986073 \ 855008 -1 461798 461801 461804 461807 461810 461813 461816 461819 461822 \ 461825 461828 461831 461834 461837 461840 461843 461846 461849 461852 \ 461855 461858 461861 461864 461867 461870 461873 461876 461879 461882 \ 461885 461888 461891 461894 461897 461900 461903 -1 -1 -1 -1 461906 \ 330837 330839 330841 330843 330845 330847 330849 330851 330853 330855 \ 330857 330859 330861 330863 330865 199435 199438 199441 199443 199451 \ 199452 199455 199457 199458 199460 199461 199462 199463 199464 330867 \ 330869 330871 330873 330875 330877 330879 330881 330883 330885 330887 \ 330889 330891 330893 724111 593044 330904 -1 199094 199100 199529 199530 \ 199834 199835 199836 199105 199837 199117 199167 199179 199178 199168 \ 199260 199125 199165 199838 199839 199840 199841 199842 199843 199844 \ 199845 199846 199847 199131 199848 199849 199850 199851 199852 199853 \ 199854 199855 199531 199532 199533 199856 199857 199858 199859 199860 \ 199861 199862 199863 199864 199865 330938 330940 330942 330944 330946 \ 330948 330950 330952 330954 330956 330958 330960 330962 330964 330966 \ 330968 330970 330972 330974 330976 330978 330980 330982 330984 462058 \ 462061 462064 330995 462069 331000 462074 199933 199934 199935 199936 \ 199937 199938 199939 199940 199941 199942 199943 199944 199945 199946 \ 199947 199948 199949 199950 199951 199952 199953 199954 199955 199956 \ 199957 199958 199959 199960 199961 199962 199963 199964 199965 199966 \ 199967 199968 199969 199970 199971 199972 199973 199974 199975 199976 \ 199977 199978 199979 -1 593196 593200 593204 462136 593211 462143 462146 \ 724293 593226 462158 462161 462164 593239 593243 462175 462178 331109 \ 462183 593258 593262 331122 724340 855417 724351 462212 724359 724364 \ 593297 462229 462232 462235 593310 724386 593319 462251 462254 462257 \ 331188 331190 331192 331194 462268 462271 724418 462279 593354 724430 \ 462291 331222 331224 724442 593375 724451 462312 724459 331248 462322 \ 462325 462328 462331 462334 593409 462341 331272 462346 462349 462352 \ 593427 462359 462362 462365 724512 593445 331305 724523 331312 593458 \ 593462 462394 462397 462400 593475 331335 462409 593484 331344 724562 \ 462423 331354 331356 331358 331360 331362 331364 331366 331368 331370 \ 331372 462446 462449 462452 462455 462458 462461 462464 462467 462470 \ 462473 462476 462479 462482 462485 462488 462491 331422 331424 462498 \ 331429 331431 331433 462507 462510 331441 331443 331445 331447 331449 \ 593595 331455 331457 331459 331461 331463 331465 331467 331469 462543 \ 593618 331478 331480 331482 331484 331486 331488 331490 462564 462567 \ 462570 462573 331504 331506 331508 331510 331512 331514 331516 331518 \ 331520 331522 462596 462599 331530 462604 462607 462610 331541 462615 \ 462618 593693 331553 462627 462630 462633 462636 724783 855860 331578 \ 331580 331582 331584 331586 331588 331590 331592 331594 331596 331598 \ 331600 331602 331604 331606 331608 331610 331612 593758 331618 331620 \ 331622 593768 462700 331631 331633 331635 331637 331639 331641 331643 \ 331645 331647 331649 462723 331654 331656 462730 462733 331664 593810 \ 462742 331673 331675 331677 331679 462753 462756 331687 331689 331691 \ 331693 331695 331697 331699 331701 331703 462777 462780 462783 462786 \ 462789 462792 462795 462798 462801 462804 462807 462810 462813 462816 \ 462819 462822 462825 462828 462831 462834 462837 462840 462843 135166 \ 135167 133716 135168 135169 135170 135171 133770 133770 135172 133724 \ 135173 135174 135175 135176 135177 135178 135179 135180 135181 135182 \ 135183 135184 135185 135186 135187 135188 135189 135190 135191 135192 \ 135193 135194 135195 135196 135197 135198 135199 135200 135201 135202 \ 135203 135204 135205 135206 135207 135208 135209 135210 135211 135212 \ 135213 133682 135214 135215 135216 135217 135218 135219 135220 135221 \ 135222 135223 135224 133755 135225 135226 135227 135228 135229 135230 \ 135231 135232 135233 135234 135235 135236 135237 135238 135239 135240 \ 135241 135242 135243 135244 135245 135246 135247 135248 135249 135250 \ 135251 135182 135252 135253 135254 135255 135256 135257 135258 135259 \ 135260 135261 135262 135263 135264 135265 135266 135267 135268 135269 \ 135270 135271 133718 135272 135273 135274 135275 135276 135277 135278 \ 135279 135280 135281 135282 135283 135284 135285 135286 133595 135287 \ 135288 135289 135290 135291 135292 135293 135294 133576 135295 135296 \ 135297 135298 135299 135300 135301 135302 135303 135304 135305 135306 \ 135307 135308 135309 135310 135311 135312 135313 135314 135315 135316 \ 135270 135317 135318 135319 135320 135321 135322 135323 135324 135254 \ 135325 135326 135327 135328 135329 135330 135331 135332 135333 135334 \ 135335 135336 135337 135338 135339 135340 135341 135342 135343 135344 \ 135182 135345 135346 135347 135348 133769 135349 135350 135351 135352 \ 135353 135354 135355 135356 135357 135358 135359 135360 134299 135361 \ 135362 135363 135364 135365 135366 135367 135368 135369 135256 135370 \ 135371 135372 135373 135374 135375 135376 135377 135378 135379 135380 \ 135381 135382 133723 135383 135384 135385 135386 135387 135388 135389 \ 135390 135391 135392 135393 135394 135395 133674 135396 135397 135398 \ 135399 135400 135401 135402 135403 135404 135405 135406 135407 135408 \ 135409 135410 135411 133701 135412 133704 135413 135414 135415 -1 -1 \ 135416 -1 135417 -1 -1 135418 135419 135420 135421 135422 135423 135424 \ 135425 135426 133681 -1 135427 -1 135428 -1 -1 135429 135430 -1 -1 \ -1 135431 135432 135433 135434 -1 -1 135435 135436 135437 135438 135439 \ 135440 135441 135442 135443 135444 135445 135446 133602 135447 135448 \ 135449 135450 135451 135452 135453 135454 135455 135456 135457 135458 \ 135459 135460 135461 134304 135462 135463 135464 135465 134308 135466 \ 135467 135468 135469 135470 135306 135471 135472 135473 135474 135475 \ 135476 135476 135477 135478 135479 135480 135481 135482 135483 135484 \ 135429 135485 135486 135487 -1 -1 -1 -1 -1 135488 135489 135490 135491 \ 135492 135493 135494 135495 135441 135496 135497 135498 135416 135499 \ 135500 135501 135502 135503 135504 135505 135506 135507 135508 135509 \ 135510 135449 135511 135450 135512 135513 135514 135515 135516 135417 \ 135203 135517 135518 133635 135271 135354 135519 135520 135457 135521 \ 135458 135522 135523 135524 135419 135525 135526 135527 135528 135529 \ 135420 135530 135531 135532 135533 135534 135535 135470 135536 135537 \ 135306 135538 135474 135539 135540 135541 135542 135543 135479 135544 \ 135428 135545 135480 135252 135546 135481 135547 135483 135548 135549 \ 135550 135551 135552 135485 135425 135553 135486 135554 135487 135555 \ 133770 135556 135557 135558 135559 135560 135561 135562 135563 135564 \ 135565 135566 -1 -1 -1 -1 -1 -1 332175 332177 332179 463253 463256 \ 332187 332189 -1 -1 -1 -1 332191 332193 332195 332197 332199 -1 -1 \ -1 -1 -1 266665 -1 266667 201133 198656 198659 201134 201135 201136 \ 201137 201138 201139 198615 266676 266678 266680 266682 266684 266686 \ 266688 266690 266692 266694 266696 266698 266700 -1 266702 266704 266706 \ 266708 266710 -1 266712 -1 266714 266716 -1 266718 266720 -1 266722 \ 266724 266726 266728 266730 266732 266734 266736 266738 332276 201206 \ 201206 201207 201207 201207 201207 201208 201208 201208 201208 201209 \ 201209 201209 201209 201210 201210 201210 201210 201211 201211 201211 \ 201211 201212 201212 201212 201212 201213 201213 201213 201213 201214 \ 201214 201214 201214 201215 201215 201215 201215 201216 201216 201216 \ 201216 201217 201217 201217 201217 201218 201218 201218 201218 201219 \ 201219 201220 201220 201221 201221 201222 201222 201223 201223 201224 \ 201224 201225 201225 201225 201225 201226 201226 201226 201226 201227 \ 201227 201227 201227 201228 201228 201228 201228 201229 201229 201230 \ 201230 201230 201230 201231 201231 201232 201232 201232 201232 201233 \ 201233 201233 201233 201234 201234 201235 201235 -1 -1 -1 -1 -1 -1 \ -1 -1 -1 201236 201236 201236 201236 201237 201237 201238 201238 201239 \ 201239 201240 201241 201241 201242 201242 201243 201243 201244 201244 \ 201244 201244 201245 201245 332318 332318 332320 332320 332322 332322 \ 332324 332324 332326 332326 332328 332328 332330 332330 332330 332332 \ 332332 332332 201262 201262 201262 201262 332335 332337 332339 332332 \ 332341 332343 332345 332347 332349 332351 332353 332355 332357 332359 \ 332361 332363 332365 332367 332369 332371 332373 332375 332377 332379 \ 332381 332383 332385 332387 332389 332391 332393 332395 332397 332399 \ 332401 332403 332405 332407 332409 332411 332413 332415 332417 332419 \ 332421 332423 332425 332427 332429 332431 332433 332435 332437 332439 \ 332441 332443 332445 332447 332449 332451 332453 332455 332457 332459 \ 332461 332463 332465 332467 332469 332471 332473 332475 332477 332479 \ 332481 332483 332485 332487 332489 332491 332493 332495 332497 332499 \ 332501 332503 332505 332507 332509 332511 332513 332515 332517 332519 \ 463593 463596 463599 463602 463605 463608 332539 332541 332339 332543 \ 332332 332341 332545 332547 332349 332549 332351 332353 332551 332553 \ 332361 332555 332363 332365 332557 332559 332369 332561 332371 332373 \ 332431 332433 332439 332441 332443 332451 332453 332455 332457 332465 \ 332467 332469 332563 332477 332565 332567 332489 332569 332491 332493 \ 332519 332571 332573 332509 332575 332511 332513 332335 332337 332577 \ 332339 332579 332343 332345 332347 332349 332581 332355 332357 332359 \ 332361 332583 332369 332375 332377 332379 332381 332383 332387 332389 \ 332391 332393 332395 332397 332585 332399 332401 332403 332405 332407 \ 332409 332413 332415 332417 332419 332421 332423 332425 332427 332429 \ 332435 332437 332445 332447 332449 332451 332453 332459 332461 332463 \ 332465 332587 332471 332473 332475 332477 332483 332485 332487 332489 \ 332589 332495 332497 332591 332503 332505 332507 332509 332593 332339 \ 332579 332349 332581 332361 332583 332369 332595 332395 332597 332599 \ 332601 332451 332453 332465 332489 332589 332509 332593 463675 463678 \ 463681 332612 332614 332616 332618 332620 332622 332624 332626 332628 \ 332630 332632 332634 332636 332638 332640 332642 332644 332646 332648 \ 332650 332652 332654 332656 332599 332658 332660 332662 332664 332612 \ 332614 332616 332618 332620 332622 332624 332626 332628 332630 332632 \ 332634 332636 332638 332640 332642 332644 332646 332648 332650 332652 \ 332654 332656 332599 332658 332660 332662 332664 332652 332654 332656 \ 332599 332597 332601 332411 332389 332391 332393 332652 332654 332656 \ 332411 332413 332666 332666 -1 -1 463740 463743 463743 463746 463749 \ 463752 463755 463758 463761 463761 463764 463767 463770 463773 463776 \ 463779 463779 463782 463785 463785 463788 463788 463791 463794 463794 \ 463797 463800 463800 463803 463803 463806 463809 463809 463812 463812 \ 463815 463818 463821 463824 463824 463827 463830 463833 463836 463839 \ 463839 463842 463845 463848 463851 463854 463857 463857 463860 463860 \ 463863 463863 463866 463869 463872 463875 463878 463881 463884 -1 -1 \ 463887 463890 463893 463896 463899 463902 463902 463905 463908 463911 \ 463914 463914 463917 463920 463923 463926 463929 463932 463935 463938 \ 463941 463944 463947 463950 463953 463956 463959 463962 463965 463968 \ 463971 463974 463977 463980 463842 463848 463983 463986 463989 463992 \ 463995 463998 463995 463989 464001 464004 464007 464010 464013 463998 \ 463821 463791 464016 464019 464022 464025 595100 595104 595108 595112 \ 595116 595120 595124 464056 2430139 1119437 595157 -1 -1 -1 201945 \ 201946 201947 201948 197204 201949 201950 201951 201952 201953 -1 -1 \ -1 -1 -1 -1 201954 201955 201956 201957 201957 198618 198619 201958 \ 201959 201960 201961 201962 201963 201964 201965 198850 198851 201966 \ 201967 201968 201969 -1 -1 201970 201971 201972 201972 201972 201972 \ 201957 201957 201957 201945 201946 198578 -1 197204 201948 201950 201949 \ 201955 198618 198619 201958 201959 201960 201961 201973 201974 201975 \ 198615 201976 201977 201978 198617 -1 201979 201980 201981 201982 -1 \ -1 -1 -1 333055 333057 333059 -1 333061 -1 333063 333065 333067 333069 \ 333071 333073 333075 333077 333079 333081 202011 202012 202012 202013 \ 202013 202014 202014 202015 202015 202016 202016 202016 202016 202017 \ 202017 202018 202018 202018 202018 202019 202019 202020 202020 202020 \ 202020 202021 202021 202021 202021 202022 202022 202022 202022 202023 \ 202023 202023 202023 202024 202024 202024 202024 202025 202025 202026 \ 202026 202027 202027 202028 202028 202029 202029 202029 202029 202030 \ 202030 202030 202030 202031 202031 202031 202031 202032 202032 202032 \ 202032 202033 202033 202033 202033 202034 202034 202034 202034 202035 \ 202035 202035 202035 202036 202036 202036 202036 202037 202037 202037 \ 202037 202038 202038 202038 202038 202039 202039 202039 202039 202040 \ 202040 202040 202040 202041 202041 202041 202041 202042 202042 202042 \ 202042 202043 202043 202043 202043 202044 202044 201245 201245 202045 \ 202045 202045 202045 333118 333118 333120 333120 333122 333122 333124 \ 333124 -1 -1 -1 -1 201949 202054 201973 201980 201981 201974 202055 \ 198618 198619 201975 198615 201945 201976 198578 202056 198613 198614 \ 201948 197204 201977 198617 201978 201950 201982 197553 197555 198629 \ 197556 197557 198655 197559 197560 197561 197562 197563 197564 197565 \ 197566 197567 197569 198644 197570 199074 197571 197572 198711 197573 \ 198723 199075 198652 201970 201979 201971 202057 201957 198551 196611 \ 197577 197603 197578 197579 197606 197583 197171 197600 197173 197584 \ 197193 197585 198620 196622 197590 199076 197174 196964 197591 197592 \ 197595 197178 197194 197179 197633 201958 202058 201959 202059 202060 \ 202061 201947 201966 201967 201946 202062 199979 202063 202064 202065 \ 202066 202067 202068 202069 202070 202071 202072 199933 199934 199935 \ 199936 199937 199938 199939 199940 199941 199942 199943 199944 199945 \ 199946 199947 199948 199949 199950 199951 199952 199953 199954 199955 \ 199956 199957 199958 199959 199960 199961 199962 199963 199964 199965 \ 199966 199967 199968 199969 199970 199971 199972 199973 199974 199975 \ 199976 202073 202074 202075 202076 202077 202078 202079 202080 202081 \ 202082 202083 202084 202085 202086 202087 202088 202089 202090 202091 \ 202092 202093 202094 202095 202096 202097 202098 202099 202100 202101 \ 202102 202103 202104 202105 202106 -1 -1 -1 202107 202108 202109 202110 \ 202111 202112 -1 -1 202113 202114 202115 202116 202117 202118 -1 -1 \ 202119 202120 202121 202122 202123 202124 -1 -1 202125 202126 202127 \ -1 -1 -1 202128 202129 202130 202131 202132 202133 202134 -1 202135 \ 202136 202137 202138 202139 202140 202141 -1 -1 -1 -1 -1 -1 -1 267678 \ 267680 267682 267684 267686 267688 267690 -1 -1 -1 -1 -1 -1 267692 \ 267694 267696 267698 267700 267702 -1 -1 -1 -1 -1 -1 -1 197553 197555 \ 198629 197556 197557 198655 197559 197560 197561 197562 197563 197564 \ 197565 197566 197567 197569 198644 197570 199074 197571 197572 198711 \ 197573 198723 199075 198652 196611 197577 197603 197578 197579 197606 \ 197583 197171 197600 197173 197584 197193 197585 198620 196622 197590 \ 199076 197174 196964 197591 197592 197595 197178 197194 197179 197633 \ 197553 197555 198629 197556 197557 198655 197559 197560 197561 197562 \ 197563 197564 197565 197566 197567 197569 198644 197570 199074 197571 \ 197572 198711 197573 198723 199075 198652 196611 197577 197603 197578 \ 197579 197606 197583 -1 197600 197173 197584 197193 197585 198620 196622 \ 197590 199076 197174 196964 197591 197592 197595 197178 197194 197179 \ 197633 197178 197194 197179 197633 197553 -1 198629 197556 -1 -1 197559 \ -1 -1 197562 197563 -1 -1 197566 197567 197569 198644 -1 199074 197571 \ 197603 197578 -1 197606 -1 197171 197600 197173 197584 197193 197585 \ 198620 -1 197590 199076 197174 197178 197194 197179 197633 197553 197555 \ -1 197556 197557 198655 197559 -1 -1 197562 197563 197564 197565 197566 \ 197567 197569 198644 -1 199074 197571 197572 198711 197573 198723 199075 \ -1 196611 197577 197603 197578 197579 197606 197583 197171 197600 197173 \ 197553 197555 -1 197556 197557 198655 197559 -1 197561 197562 197563 \ 197564 197565 -1 197567 -1 -1 -1 199074 197571 197572 198711 197573 \ 198723 199075 -1 196611 197577 197603 197578 197579 197606 197178 197194 \ 197179 197633 202168 202169 -1 -1 202170 202171 198663 202172 202173 \ 202174 202175 197260 202176 202177 202178 202179 202180 202181 202182 \ 198664 202183 202184 197262 202185 197250 202186 202187 202188 198653 \ 202189 202190 197248 197597 197598 197261 202191 202192 197249 198471 \ 197257 202193 196618 202194 202195 202196 197256 197258 197259 202197 \ 202198 202199 197255 197599 202200 202201 202202 202203 202204 202205 \ 202206 202207 202208 202170 202171 198663 202172 202173 202174 202175 \ 197260 202176 202177 202178 202179 202180 202181 202182 198664 202183 \ 202184 197262 202185 197250 202186 202187 202188 198653 202189 202190 \ 197248 197597 197598 197261 202191 202192 197249 198471 197257 202193 \ 196618 202194 202195 202196 197256 197258 197259 202197 202198 202199 \ 197255 197599 202200 202201 202202 202203 202204 202205 202206 202207 \ 202208 202170 202171 198663 202172 202173 202174 202175 197260 202176 \ 202177 202178 202179 202180 202181 202182 198664 202183 202184 197262 \ 202185 197250 202186 202187 202188 198653 202189 202190 197248 197597 \ 197598 197261 202191 202192 197249 198471 197257 202193 196618 202194 \ 202195 202196 197256 197258 197259 202197 202198 202199 197255 197599 \ 202200 202201 202202 202203 202204 202205 202206 202207 202208 202170 \ 202171 198663 202172 202173 202174 202175 197260 202176 202177 202178 \ 202179 202180 202181 202182 198664 202183 202184 197262 202185 197250 \ 202186 202187 202188 198653 202189 202190 197248 197597 197598 197261 \ 202191 202192 197249 198471 197257 202193 196618 202194 202195 202196 \ 197256 197258 197259 202197 202198 202199 197255 197599 202200 202201 \ 202202 202203 202204 202205 202206 202207 202208 202207 202208 202209 \ 202210 -1 -1 198608 196621 196614 196615 198609 198610 198611 198612 \ 198613 198614 198613 198614 198608 196621 196614 196615 198609 198610 \ 198611 198612 198613 198614 198608 196621 196614 196615 198609 198610 \ 198611 198612 198613 198614 198608 196621 136675 136676 136677 136678 \ 136679 135435 136680 136681 136682 136683 135436 136684 136685 136686 \ 135437 136687 136688 136689 136690 136691 136692 136693 136694 136695 \ 136696 136697 136698 135489 136699 133574 136700 136701 136702 136703 \ 136704 136705 136706 135494 135438 135439 135495 136707 136708 135258 \ 136709 135440 136710 136711 136712 136713 136713 136713 136714 136715 \ 136716 136717 136718 136719 136720 136721 136722 136723 136724 136725 \ 136726 136727 136728 136729 136730 136731 136731 135497 136732 136733 \ 136734 136735 135442 136736 136737 136738 135404 136739 136740 136741 \ 136742 136743 136744 136745 136746 136747 136748 136749 136750 136751 \ 136752 136753 136754 136755 136756 136757 136758 136759 136760 136761 \ 136762 136763 136764 136764 136765 136766 136767 135254 136768 136769 \ 136770 136771 136772 133600 136773 136774 133602 136775 136776 136777 \ 136778 136779 136780 136781 136782 136783 136784 136785 136786 136787 \ 136788 136789 136790 136791 136792 136793 136794 136795 135202 136796 \ 133612 136797 136797 136798 136799 136799 136800 136801 136802 136803 \ 136804 136805 136806 136807 136808 136809 136810 136811 136812 135447 \ 136813 136814 136815 136816 135509 136816 136817 135449 136818 136819 \ 136820 136821 135450 135175 136822 136823 136824 136825 136826 136827 \ 136828 136829 136830 136831 136832 136833 136834 136835 136836 136837 \ 136838 136839 136840 136841 136842 136843 135451 136844 136845 136846 \ 136847 136848 136849 135453 136850 136851 136852 136853 136854 136855 \ 136856 136857 135203 135517 136858 136859 136860 136861 136862 136863 \ 136864 136865 135454 136866 136867 136868 136869 135559 136870 136871 \ 136872 136873 136874 136875 136876 136877 136878 136879 136880 136881 \ 136882 135271 136883 136884 136885 136886 136887 136888 136889 136890 \ 136891 136892 136893 135455 135354 136894 136895 136896 136897 136898 \ 136899 136900 136901 135520 136902 136903 136904 136905 136906 136907 \ 136908 136909 135521 136910 136911 136912 136913 136914 136915 136916 \ 136917 136918 136919 136920 136921 135523 136922 136923 136924 136925 \ 136926 136927 136928 136929 136930 136931 136932 136932 136933 136934 \ 135525 136935 136936 136937 136938 136939 136940 136941 135257 136942 \ 136943 136944 136945 136946 136947 136948 135531 136949 136950 136951 \ 136952 136953 136954 136954 135532 135561 136955 136956 136957 136958 \ 136959 135220 135534 136960 136961 135465 136962 136963 135424 136964 \ 136965 135468 136966 136967 136968 136969 136969 136970 136971 136972 \ 136973 136974 136975 136976 136977 136978 136979 136980 136981 136982 \ 136983 136984 136985 136986 136987 136988 136989 136990 136991 136992 \ 136993 136994 136995 136996 135474 136997 136998 136999 137000 137001 \ 137002 137003 137004 137005 137006 137007 137008 137009 137010 137011 \ 137012 136798 137013 137014 137015 137016 137017 137018 137019 137020 \ 137021 137022 137023 137024 135274 137025 137026 137027 137028 137029 \ 137030 135477 137031 137032 137033 137034 137035 137036 137037 137038 \ 137039 137040 137041 137042 137043 137044 137045 137046 137047 137048 \ 137049 137050 135215 137051 137052 137053 137054 137055 137056 135541 \ 137057 137058 137059 137060 137061 137062 137063 137064 133702 137065 \ 137066 137067 137068 137069 137070 137071 137072 137073 137074 137075 \ 135546 135547 133709 137076 137077 137078 137079 137080 137081 137082 \ 137083 137084 137085 137086 137087 135548 137088 137089 137090 137091 \ 137092 137093 137094 137095 137096 137097 137098 137099 137100 137101 \ 137102 137103 137104 137105 137106 137107 137108 137109 137110 137111 \ 137112 137113 137114 137115 137116 137117 135554 135554 137118 137119 \ 137120 137121 137122 137123 137124 137125 137126 137127 135555 137128 \ 137129 137130 137131 137132 137133 137134 137135 137136 137137 133757 \ 137138 133761 137139 137140 137141 137142 133766 137143 -1 -1] # # List of decomposition sequences # set decompList [list \ 32 32 776 97 32 772 50 51 32 769 956 32 807 49 111 49 8260 52 49 8260 \ 50 51 8260 52 65 768 65 769 65 770 65 771 65 776 65 778 67 807 69 768 \ 69 769 69 770 69 776 73 768 73 769 73 770 73 776 78 771 79 768 79 769 \ 79 770 79 771 79 776 85 768 85 769 85 770 85 776 89 769 97 768 97 769 \ 97 770 97 771 97 776 97 778 99 807 101 768 101 769 101 770 101 776 \ 105 768 105 769 105 770 105 776 110 771 111 768 111 769 111 770 111 \ 771 111 776 117 768 117 769 117 770 117 776 121 769 121 776 65 772 \ 97 772 65 774 97 774 65 808 97 808 67 769 99 769 67 770 99 770 67 775 \ 99 775 67 780 99 780 68 780 100 780 69 772 101 772 69 774 101 774 69 \ 775 101 775 69 808 101 808 69 780 101 780 71 770 103 770 71 774 103 \ 774 71 775 103 775 71 807 103 807 72 770 104 770 73 771 105 771 73 \ 772 105 772 73 774 105 774 73 808 105 808 73 775 73 74 105 106 74 770 \ 106 770 75 807 107 807 76 769 108 769 76 807 108 807 76 780 108 780 \ 76 183 108 183 78 769 110 769 78 807 110 807 78 780 110 780 700 110 \ 79 772 111 772 79 774 111 774 79 779 111 779 82 769 114 769 82 807 \ 114 807 82 780 114 780 83 769 115 769 83 770 115 770 83 807 115 807 \ 83 780 115 780 84 807 116 807 84 780 116 780 85 771 117 771 85 772 \ 117 772 85 774 117 774 85 778 117 778 85 779 117 779 85 808 117 808 \ 87 770 119 770 89 770 121 770 89 776 90 769 122 769 90 775 122 775 \ 90 780 122 780 115 79 795 111 795 85 795 117 795 68 381 68 382 100 \ 382 76 74 76 106 108 106 78 74 78 106 110 106 65 780 97 780 73 780 \ 105 780 79 780 111 780 85 780 117 780 220 772 252 772 220 769 252 769 \ 220 780 252 780 220 768 252 768 196 772 228 772 550 772 551 772 198 \ 772 230 772 71 780 103 780 75 780 107 780 79 808 111 808 490 772 491 \ 772 439 780 658 780 106 780 68 90 68 122 100 122 71 769 103 769 78 \ 768 110 768 197 769 229 769 198 769 230 769 216 769 248 769 65 783 \ 97 783 65 785 97 785 69 783 101 783 69 785 101 785 73 783 105 783 73 \ 785 105 785 79 783 111 783 79 785 111 785 82 783 114 783 82 785 114 \ 785 85 783 117 783 85 785 117 785 83 806 115 806 84 806 116 806 72 \ 780 104 780 65 775 97 775 69 807 101 807 214 772 246 772 213 772 245 \ 772 79 775 111 775 558 772 559 772 89 772 121 772 104 614 106 114 633 \ 635 641 119 121 32 774 32 775 32 778 32 808 32 771 32 779 611 108 120 \ 661 768 769 787 776 769 697 32 837 59 168 769 913 769 183 917 769 919 \ 769 921 769 927 769 933 769 937 769 970 769 921 776 933 776 945 769 \ 949 769 951 769 953 769 971 769 953 776 965 776 959 769 965 769 969 \ 769 946 952 933 978 769 978 776 966 960 954 961 962 920 949 931 1045 \ 768 1045 776 1043 769 1030 776 1050 769 1048 768 1059 774 1048 774 \ 1080 774 1077 768 1077 776 1075 769 1110 776 1082 769 1080 768 1091 \ 774 1140 783 1141 783 1046 774 1078 774 1040 774 1072 774 1040 776 \ 1072 776 1045 774 1077 774 1240 776 1241 776 1046 776 1078 776 1047 \ 776 1079 776 1048 772 1080 772 1048 776 1080 776 1054 776 1086 776 \ 1256 776 1257 776 1069 776 1101 776 1059 772 1091 772 1059 776 1091 \ 776 1059 779 1091 779 1063 776 1095 776 1067 776 1099 776 1381 1410 \ 1575 1619 1575 1620 1608 1620 1575 1621 1610 1620 1575 1652 1608 1652 \ 1735 1652 1610 1652 1749 1620 1729 1620 1746 1620 2344 2364 2352 2364 \ 2355 2364 2325 2364 2326 2364 2327 2364 2332 2364 2337 2364 2338 2364 \ 2347 2364 2351 2364 2503 2494 2503 2519 2465 2492 2466 2492 2479 2492 \ 2610 2620 2616 2620 2582 2620 2583 2620 2588 2620 2603 2620 2887 2902 \ 2887 2878 2887 2903 2849 2876 2850 2876 2962 3031 3014 3006 3015 3006 \ 3014 3031 3142 3158 3263 3285 3270 3285 3270 3286 3270 3266 3274 3285 \ 3398 3390 3399 3390 3398 3415 3545 3530 3545 3535 3548 3530 3545 3551 \ 3661 3634 3789 3762 3755 3737 3755 3745 3851 3906 4023 3916 4023 3921 \ 4023 3926 4023 3931 4023 3904 4021 3953 3954 3953 3956 4018 3968 4018 \ 3969 4019 3968 4019 3969 3953 3968 3986 4023 3996 4023 4001 4023 4006 \ 4023 4011 4023 3984 4021 4133 4142 4316 6917 6965 6919 6965 6921 6965 \ 6923 6965 6925 6965 6929 6965 6970 6965 6972 6965 6974 6965 6975 6965 \ 6978 6965 65 198 66 68 69 398 71 72 73 74 75 76 77 78 79 546 80 82 \ 84 85 87 592 593 7426 98 100 101 601 603 604 103 107 109 331 596 7446 \ 7447 112 116 117 7453 623 118 7461 947 948 967 105 1085 594 99 597 \ 240 102 607 609 613 616 617 618 7547 669 621 7557 671 625 624 626 627 \ 628 629 632 642 643 427 649 650 7452 651 652 122 656 657 658 65 805 \ 97 805 66 775 98 775 66 803 98 803 66 817 98 817 199 769 231 769 68 \ 775 100 775 68 803 100 803 68 817 100 817 68 807 100 807 68 813 100 \ 813 274 768 275 768 274 769 275 769 69 813 101 813 69 816 101 816 552 \ 774 553 774 70 775 102 775 71 772 103 772 72 775 104 775 72 803 104 \ 803 72 776 104 776 72 807 104 807 72 814 104 814 73 816 105 816 207 \ 769 239 769 75 769 107 769 75 803 107 803 75 817 107 817 76 803 108 \ 803 7734 772 7735 772 76 817 108 817 76 813 108 813 77 769 109 769 \ 77 775 109 775 77 803 109 803 78 775 110 775 78 803 110 803 78 817 \ 110 817 78 813 110 813 213 769 245 769 213 776 245 776 332 768 333 \ 768 332 769 333 769 80 769 112 769 80 775 112 775 82 775 114 775 82 \ 803 114 803 7770 772 7771 772 82 817 114 817 83 775 115 775 83 803 \ 115 803 346 775 347 775 352 775 353 775 7778 775 7779 775 84 775 116 \ 775 84 803 116 803 84 817 116 817 84 813 116 813 85 804 117 804 85 \ 816 117 816 85 813 117 813 360 769 361 769 362 776 363 776 86 771 118 \ 771 86 803 118 803 87 768 119 768 87 769 119 769 87 776 119 776 87 \ 775 119 775 87 803 119 803 88 775 120 775 88 776 120 776 89 775 121 \ 775 90 770 122 770 90 803 122 803 90 817 122 817 104 817 116 776 119 \ 778 121 778 97 702 383 775 65 803 97 803 65 777 97 777 194 769 226 \ 769 194 768 226 768 194 777 226 777 194 771 226 771 7840 770 7841 770 \ 258 769 259 769 258 768 259 768 258 777 259 777 258 771 259 771 7840 \ 774 7841 774 69 803 101 803 69 777 101 777 69 771 101 771 202 769 234 \ 769 202 768 234 768 202 777 234 777 202 771 234 771 7864 770 7865 770 \ 73 777 105 777 73 803 105 803 79 803 111 803 79 777 111 777 212 769 \ 244 769 212 768 244 768 212 777 244 777 212 771 244 771 7884 770 7885 \ 770 416 769 417 769 416 768 417 768 416 777 417 777 416 771 417 771 \ 416 803 417 803 85 803 117 803 85 777 117 777 431 769 432 769 431 768 \ 432 768 431 777 432 777 431 771 432 771 431 803 432 803 89 768 121 \ 768 89 803 121 803 89 777 121 777 89 771 121 771 945 787 945 788 7936 \ 768 7937 768 7936 769 7937 769 7936 834 7937 834 913 787 913 788 7944 \ 768 7945 768 7944 769 7945 769 7944 834 7945 834 949 787 949 788 7952 \ 768 7953 768 7952 769 7953 769 917 787 917 788 7960 768 7961 768 7960 \ 769 7961 769 951 787 951 788 7968 768 7969 768 7968 769 7969 769 7968 \ 834 7969 834 919 787 919 788 7976 768 7977 768 7976 769 7977 769 7976 \ 834 7977 834 953 787 953 788 7984 768 7985 768 7984 769 7985 769 7984 \ 834 7985 834 921 787 921 788 7992 768 7993 768 7992 769 7993 769 7992 \ 834 7993 834 959 787 959 788 8000 768 8001 768 8000 769 8001 769 927 \ 787 927 788 8008 768 8009 768 8008 769 8009 769 965 787 965 788 8016 \ 768 8017 768 8016 769 8017 769 8016 834 8017 834 933 788 8025 768 8025 \ 769 8025 834 969 787 969 788 8032 768 8033 768 8032 769 8033 769 8032 \ 834 8033 834 937 787 937 788 8040 768 8041 768 8040 769 8041 769 8040 \ 834 8041 834 945 768 940 949 768 941 951 768 942 953 768 943 959 768 \ 972 965 768 973 969 768 974 7936 837 7937 837 7938 837 7939 837 7940 \ 837 7941 837 7942 837 7943 837 7944 837 7945 837 7946 837 7947 837 \ 7948 837 7949 837 7950 837 7951 837 7968 837 7969 837 7970 837 7971 \ 837 7972 837 7973 837 7974 837 7975 837 7976 837 7977 837 7978 837 \ 7979 837 7980 837 7981 837 7982 837 7983 837 8032 837 8033 837 8034 \ 837 8035 837 8036 837 8037 837 8038 837 8039 837 8040 837 8041 837 \ 8042 837 8043 837 8044 837 8045 837 8046 837 8047 837 945 774 945 772 \ 8048 837 945 837 940 837 945 834 8118 837 913 774 913 772 913 768 902 \ 913 837 32 787 953 32 834 168 834 8052 837 951 837 942 837 951 834 \ 8134 837 917 768 904 919 768 905 919 837 8127 768 8127 769 8127 834 \ 953 774 953 772 970 768 912 953 834 970 834 921 774 921 772 921 768 \ 906 8190 768 8190 769 8190 834 965 774 965 772 971 768 944 961 787 \ 961 788 965 834 971 834 933 774 933 772 933 768 910 929 788 168 768 \ 901 96 8060 837 969 837 974 837 969 834 8182 837 927 768 908 937 768 \ 911 937 837 180 32 788 8194 8195 8208 32 819 46 46 46 46 46 46 8242 \ 8242 8242 8242 8242 8245 8245 8245 8245 8245 33 33 32 773 63 63 63 \ 33 33 63 8242 8242 8242 8242 48 52 53 54 55 56 57 43 8722 61 40 41 \ 110 82 115 97 47 99 97 47 115 67 176 67 99 47 111 99 47 117 400 176 \ 70 295 78 111 81 83 77 84 69 76 84 77 90 937 197 70 1488 1489 1490 \ 1491 70 65 88 915 928 8721 49 8260 51 50 8260 51 49 8260 53 50 8260 \ 53 51 8260 53 52 8260 53 49 8260 54 53 8260 54 49 8260 56 51 8260 56 \ 53 8260 56 55 8260 56 49 8260 73 73 73 73 73 73 86 86 86 73 86 73 73 \ 86 73 73 73 73 88 88 88 73 88 73 73 105 105 105 105 105 105 118 118 \ 105 118 105 105 118 105 105 105 105 120 120 105 120 105 105 8592 824 \ 8594 824 8596 824 8656 824 8660 824 8658 824 8707 824 8712 824 8715 \ 824 8739 824 8741 824 8747 8747 8747 8747 8747 8750 8750 8750 8750 \ 8750 8764 824 8771 824 8773 824 8776 824 61 824 8801 824 8781 824 60 \ 824 62 824 8804 824 8805 824 8818 824 8819 824 8822 824 8823 824 8826 \ 824 8827 824 8834 824 8835 824 8838 824 8839 824 8866 824 8872 824 \ 8873 824 8875 824 8828 824 8829 824 8849 824 8850 824 8882 824 8883 \ 824 8884 824 8885 824 12296 12297 49 48 49 49 49 50 49 51 49 52 49 \ 53 49 54 49 55 49 56 49 57 50 48 40 49 41 40 50 41 40 51 41 40 52 41 \ 40 53 41 40 54 41 40 55 41 40 56 41 40 57 41 40 49 48 41 40 49 49 41 \ 40 49 50 41 40 49 51 41 40 49 52 41 40 49 53 41 40 49 54 41 40 49 55 \ 41 40 49 56 41 40 49 57 41 40 50 48 41 49 46 50 46 51 46 52 46 53 46 \ 54 46 55 46 56 46 57 46 49 48 46 49 49 46 49 50 46 49 51 46 49 52 46 \ 49 53 46 49 54 46 49 55 46 49 56 46 49 57 46 50 48 46 40 97 41 40 98 \ 41 40 99 41 40 100 41 40 101 41 40 102 41 40 103 41 40 104 41 40 105 \ 41 40 106 41 40 107 41 40 108 41 40 109 41 40 110 41 40 111 41 40 112 \ 41 40 113 41 40 114 41 40 115 41 40 116 41 40 117 41 40 118 41 40 119 \ 41 40 120 41 40 121 41 40 122 41 83 89 113 8747 8747 8747 8747 58 58 \ 61 61 61 61 61 61 10973 824 11617 27597 40863 19968 20008 20022 20031 \ 20057 20101 20108 20128 20154 20799 20837 20843 20866 20886 20907 20960 \ 20981 20992 21147 21241 21269 21274 21304 21313 21340 21353 21378 21430 \ 21448 21475 22231 22303 22763 22786 22794 22805 22823 22899 23376 23424 \ 23544 23567 23586 23608 23662 23665 24027 24037 24049 24062 24178 24186 \ 24191 24308 24318 24331 24339 24400 24417 24435 24515 25096 25142 25163 \ 25903 25908 25991 26007 26020 26041 26080 26085 26352 26376 26408 27424 \ 27490 27513 27571 27595 27604 27611 27663 27668 27700 28779 29226 29238 \ 29243 29247 29255 29273 29275 29356 29572 29577 29916 29926 29976 29983 \ 29992 30000 30091 30098 30326 30333 30382 30399 30446 30683 30690 30707 \ 31034 31160 31166 31348 31435 31481 31859 31992 32566 32593 32650 32701 \ 32769 32780 32786 32819 32895 32905 33251 33258 33267 33276 33292 33307 \ 33311 33390 33394 33400 34381 34411 34880 34892 34915 35198 35211 35282 \ 35328 35895 35910 35925 35960 35997 36196 36208 36275 36523 36554 36763 \ 36784 36789 37009 37193 37318 37324 37329 38263 38272 38428 38582 38585 \ 38632 38737 38750 38754 38761 38859 38893 38899 38913 39080 39131 39135 \ 39318 39321 39340 39592 39640 39647 39717 39727 39730 39740 39770 40165 \ 40565 40575 40613 40635 40643 40653 40657 40697 40701 40718 40723 40736 \ 40763 40778 40786 40845 40860 40864 12306 21316 21317 12363 12441 12365 \ 12441 12367 12441 12369 12441 12371 12441 12373 12441 12375 12441 12377 \ 12441 12379 12441 12381 12441 12383 12441 12385 12441 12388 12441 12390 \ 12441 12392 12441 12399 12441 12399 12442 12402 12441 12402 12442 12405 \ 12441 12405 12442 12408 12441 12408 12442 12411 12441 12411 12442 12358 \ 12441 32 12441 32 12442 12445 12441 12424 12426 12459 12441 12461 12441 \ 12463 12441 12465 12441 12467 12441 12469 12441 12471 12441 12473 12441 \ 12475 12441 12477 12441 12479 12441 12481 12441 12484 12441 12486 12441 \ 12488 12441 12495 12441 12495 12442 12498 12441 12498 12442 12501 12441 \ 12501 12442 12504 12441 12504 12442 12507 12441 12507 12442 12454 12441 \ 12527 12441 12528 12441 12529 12441 12530 12441 12541 12441 12467 12488 \ 4352 4353 4522 4354 4524 4525 4355 4356 4357 4528 4529 4530 4531 4532 \ 4533 4378 4358 4359 4360 4385 4361 4362 4363 4364 4365 4366 4367 4368 \ 4369 4370 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 \ 4461 4462 4463 4464 4465 4466 4467 4468 4469 4448 4372 4373 4551 4552 \ 4556 4558 4563 4567 4569 4380 4573 4575 4381 4382 4384 4386 4387 4391 \ 4393 4395 4396 4397 4398 4399 4402 4406 4416 4423 4428 4593 4594 4439 \ 4440 4441 4484 4485 4488 4497 4498 4500 4510 4513 19977 22235 19978 \ 20013 19979 30002 19993 19969 22825 22320 40 4352 41 40 4354 41 40 \ 4355 41 40 4357 41 40 4358 41 40 4359 41 40 4361 41 40 4363 41 40 4364 \ 41 40 4366 41 40 4367 41 40 4368 41 40 4369 41 40 4370 41 40 4352 4449 \ 41 40 4354 4449 41 40 4355 4449 41 40 4357 4449 41 40 4358 4449 41 \ 40 4359 4449 41 40 4361 4449 41 40 4363 4449 41 40 4364 4449 41 40 \ 4366 4449 41 40 4367 4449 41 40 4368 4449 41 40 4369 4449 41 40 4370 \ 4449 41 40 4364 4462 41 40 4363 4457 4364 4453 4523 41 40 4363 4457 \ 4370 4462 41 40 19968 41 40 20108 41 40 19977 41 40 22235 41 40 20116 \ 41 40 20845 41 40 19971 41 40 20843 41 40 20061 41 40 21313 41 40 26376 \ 41 40 28779 41 40 27700 41 40 26408 41 40 37329 41 40 22303 41 40 26085 \ 41 40 26666 41 40 26377 41 40 31038 41 40 21517 41 40 29305 41 40 36001 \ 41 40 31069 41 40 21172 41 40 20195 41 40 21628 41 40 23398 41 40 30435 \ 41 40 20225 41 40 36039 41 40 21332 41 40 31085 41 40 20241 41 40 33258 \ 41 40 33267 41 80 84 69 50 49 50 50 50 51 50 52 50 53 50 54 50 55 50 \ 56 50 57 51 48 51 49 51 50 51 51 51 52 51 53 4352 4449 4354 4449 4355 \ 4449 4357 4449 4358 4449 4359 4449 4361 4449 4363 4449 4364 4449 4366 \ 4449 4367 4449 4368 4449 4369 4449 4370 4449 4366 4449 4535 4352 4457 \ 4364 4462 4363 4468 4363 4462 20116 20845 19971 20061 26666 26377 31038 \ 21517 29305 36001 31069 21172 31192 30007 36969 20778 21360 27880 38917 \ 20241 20889 27491 24038 21491 21307 23447 23398 30435 20225 36039 21332 \ 22812 51 54 51 55 51 56 51 57 52 48 52 49 52 50 52 51 52 52 52 53 52 \ 54 52 55 52 56 52 57 53 48 49 26376 50 26376 51 26376 52 26376 53 26376 \ 54 26376 55 26376 56 26376 57 26376 49 48 26376 49 49 26376 49 50 26376 \ 72 103 101 114 103 101 86 76 84 68 12450 12452 12454 12456 12458 12459 \ 12461 12463 12465 12467 12469 12471 12473 12475 12477 12479 12481 12484 \ 12486 12488 12490 12491 12492 12493 12494 12495 12498 12501 12504 12507 \ 12510 12511 12512 12513 12514 12516 12518 12520 12521 12522 12523 12524 \ 12525 12527 12528 12529 12530 12450 12497 12540 12488 12450 12523 12501 \ 12449 12450 12531 12506 12450 12450 12540 12523 12452 12491 12531 12464 \ 12452 12531 12481 12454 12457 12531 12456 12473 12463 12540 12489 12456 \ 12540 12459 12540 12458 12531 12473 12458 12540 12512 12459 12452 12522 \ 12459 12521 12483 12488 12459 12525 12522 12540 12460 12525 12531 12460 \ 12531 12510 12462 12460 12462 12491 12540 12461 12517 12522 12540 12462 \ 12523 12480 12540 12461 12525 12461 12525 12464 12521 12512 12461 12525 \ 12513 12540 12488 12523 12461 12525 12527 12483 12488 12464 12521 12512 \ 12464 12521 12512 12488 12531 12463 12523 12476 12452 12525 12463 12525 \ 12540 12493 12465 12540 12473 12467 12523 12490 12467 12540 12509 12469 \ 12452 12463 12523 12469 12531 12481 12540 12512 12471 12522 12531 12464 \ 12475 12531 12481 12475 12531 12488 12480 12540 12473 12487 12471 12489 \ 12523 12488 12531 12490 12494 12494 12483 12488 12495 12452 12484 12497 \ 12540 12475 12531 12488 12497 12540 12484 12496 12540 12524 12523 12500 \ 12450 12473 12488 12523 12500 12463 12523 12500 12467 12499 12523 12501 \ 12449 12521 12483 12489 12501 12451 12540 12488 12502 12483 12471 12455 \ 12523 12501 12521 12531 12504 12463 12479 12540 12523 12506 12477 12506 \ 12491 12498 12504 12523 12484 12506 12531 12473 12506 12540 12472 12505 \ 12540 12479 12509 12452 12531 12488 12508 12523 12488 12507 12531 12509 \ 12531 12489 12507 12540 12523 12507 12540 12531 12510 12452 12463 12525 \ 12510 12452 12523 12510 12483 12495 12510 12523 12463 12510 12531 12471 \ 12519 12531 12511 12463 12525 12531 12511 12522 12511 12522 12496 12540 \ 12523 12513 12460 12513 12460 12488 12531 12513 12540 12488 12523 12516 \ 12540 12489 12516 12540 12523 12518 12450 12531 12522 12483 12488 12523 \ 12522 12521 12523 12500 12540 12523 12540 12502 12523 12524 12512 12524 \ 12531 12488 12466 12531 12527 12483 12488 48 28857 49 28857 50 28857 \ 51 28857 52 28857 53 28857 54 28857 55 28857 56 28857 57 28857 49 48 \ 28857 49 49 28857 49 50 28857 49 51 28857 49 52 28857 49 53 28857 49 \ 54 28857 49 55 28857 49 56 28857 49 57 28857 50 48 28857 50 49 28857 \ 50 50 28857 50 51 28857 50 52 28857 104 80 97 100 97 65 85 98 97 114 \ 111 86 112 99 100 109 100 109 178 100 109 179 73 85 24179 25104 26157 \ 21644 22823 27491 26126 27835 26666 24335 20250 31038 112 65 110 65 \ 956 65 109 65 107 65 75 66 77 66 71 66 99 97 108 107 99 97 108 112 \ 70 110 70 956 70 956 103 109 103 107 103 72 122 107 72 122 77 72 122 \ 71 72 122 84 72 122 956 8467 109 8467 100 8467 107 8467 102 109 110 \ 109 956 109 109 109 99 109 107 109 109 109 178 99 109 178 109 178 107 \ 109 178 109 109 179 99 109 179 109 179 107 109 179 109 8725 115 109 \ 8725 115 178 80 97 107 80 97 77 80 97 71 80 97 114 97 100 114 97 100 \ 8725 115 114 97 100 8725 115 178 112 115 110 115 956 115 109 115 112 \ 86 110 86 956 86 109 86 107 86 77 86 112 87 110 87 956 87 109 87 107 \ 87 77 87 107 937 77 937 97 46 109 46 66 113 99 99 99 100 67 8725 107 \ 103 67 111 46 100 66 71 121 104 97 72 80 105 110 75 75 75 77 107 116 \ 108 109 108 110 108 111 103 108 120 109 98 109 105 108 109 111 108 \ 80 72 112 46 109 46 80 80 77 80 82 115 114 83 118 87 98 86 8725 109 \ 65 8725 109 49 26085 50 26085 51 26085 52 26085 53 26085 54 26085 55 \ 26085 56 26085 57 26085 49 48 26085 49 49 26085 49 50 26085 49 51 26085 \ 49 52 26085 49 53 26085 49 54 26085 49 55 26085 49 56 26085 49 57 26085 \ 50 48 26085 50 49 26085 50 50 26085 50 51 26085 50 52 26085 50 53 26085 \ 50 54 26085 50 55 26085 50 56 26085 50 57 26085 51 48 26085 51 49 26085 \ 103 97 108 35912 26356 36040 28369 20018 21477 22865 21895 22856 25078 \ 30313 32645 34367 34746 35064 37007 27138 27931 28889 29662 33853 37226 \ 39409 20098 21365 27396 29211 34349 40478 23888 28651 34253 35172 25289 \ 33240 34847 24266 26391 28010 29436 37070 20358 20919 21214 25796 27347 \ 29200 30439 34310 34396 36335 38706 39791 40442 30860 31103 32160 33737 \ 37636 35542 22751 24324 31840 32894 29282 30922 36034 38647 22744 23650 \ 27155 28122 28431 32047 32311 38475 21202 32907 20956 20940 31260 32190 \ 33777 38517 35712 25295 35582 20025 23527 24594 29575 30064 21271 30971 \ 20415 24489 19981 27852 25976 32034 21443 22622 30465 33865 35498 27578 \ 27784 25342 33509 25504 30053 20142 20841 20937 26753 31975 33391 35538 \ 37327 21237 21570 24300 26053 28670 31018 38317 39530 40599 40654 26310 \ 27511 36706 24180 24976 25088 25754 28451 29001 29833 31178 32244 32879 \ 36646 34030 36899 37706 21015 21155 21693 28872 35010 24265 24565 25467 \ 27566 31806 29557 20196 22265 23994 24604 29618 29801 32666 32838 37428 \ 38646 38728 38936 20363 31150 37300 38584 24801 20102 20698 23534 23615 \ 26009 29134 30274 34044 36988 26248 38446 21129 26491 26611 27969 28316 \ 29705 30041 30827 32016 39006 25134 38520 20523 23833 28138 36650 24459 \ 24900 26647 38534 21033 21519 23653 26131 26446 26792 27877 29702 30178 \ 32633 35023 35041 38626 21311 28346 21533 29136 29848 34298 38563 40023 \ 40607 26519 28107 33256 31520 31890 29376 28825 35672 20160 33590 21050 \ 20999 24230 25299 31958 23429 27934 26292 36667 38477 24275 20800 21952 \ 22618 26228 20958 29482 30410 31036 31070 31077 31119 38742 31934 34322 \ 35576 36920 37117 39151 39164 39208 40372 20398 20711 20813 21193 21220 \ 21329 21917 22022 22120 22592 22696 23652 24724 24936 24974 25074 25935 \ 26082 26257 26757 28023 28186 28450 29038 29227 29730 30865 31049 31048 \ 31056 31062 31117 31118 31296 31361 31680 32265 32321 32626 32773 33261 \ 33401 33879 35088 35222 35585 35641 36051 36104 36790 38627 38911 38971 \ 20006 20917 20840 20352 20805 20864 21191 21242 21845 21913 21986 22707 \ 22852 22868 23138 23336 24274 24281 24425 24493 24792 24910 24840 24928 \ 25140 25540 25628 25682 25942 26395 26454 28379 28363 28702 30631 29237 \ 29359 29809 29958 30011 30237 30239 30427 30452 30538 30528 30924 31409 \ 31867 32091 32574 33618 33775 34681 35137 35206 35519 35531 35565 35722 \ 36664 36978 37273 37494 38524 38875 38923 39698 141386 141380 144341 \ 15261 16408 16441 152137 154832 163539 40771 40846 102 102 102 105 \ 102 108 102 102 105 102 102 108 383 116 115 116 1396 1398 1396 1381 \ 1396 1387 1406 1398 1396 1389 1497 1460 1522 1463 1506 1492 1499 1500 \ 1501 1512 1514 1513 1473 1513 1474 64329 1473 64329 1474 1488 1463 \ 1488 1464 1488 1468 1489 1468 1490 1468 1491 1468 1492 1468 1493 1468 \ 1494 1468 1496 1468 1497 1468 1498 1468 1499 1468 1500 1468 1502 1468 \ 1504 1468 1505 1468 1507 1468 1508 1468 1510 1468 1511 1468 1512 1468 \ 1513 1468 1514 1468 1493 1465 1489 1471 1499 1471 1508 1471 1488 1500 \ 1649 1659 1662 1664 1658 1663 1657 1700 1702 1668 1667 1670 1671 1677 \ 1676 1678 1672 1688 1681 1705 1711 1715 1713 1722 1723 1728 1729 1726 \ 1746 1747 1709 1735 1734 1736 1655 1739 1733 1737 1744 1609 1574 1575 \ 1574 1749 1574 1608 1574 1735 1574 1734 1574 1736 1574 1744 1574 1609 \ 1740 1574 1580 1574 1581 1574 1605 1574 1610 1576 1580 1576 1581 1576 \ 1582 1576 1605 1576 1609 1576 1610 1578 1580 1578 1581 1578 1582 1578 \ 1605 1578 1609 1578 1610 1579 1580 1579 1605 1579 1609 1579 1610 1580 \ 1581 1580 1605 1581 1580 1581 1605 1582 1580 1582 1581 1582 1605 1587 \ 1580 1587 1581 1587 1582 1587 1605 1589 1581 1589 1605 1590 1580 1590 \ 1581 1590 1582 1590 1605 1591 1581 1591 1605 1592 1605 1593 1580 1593 \ 1605 1594 1580 1594 1605 1601 1580 1601 1581 1601 1582 1601 1605 1601 \ 1609 1601 1610 1602 1581 1602 1605 1602 1609 1602 1610 1603 1575 1603 \ 1580 1603 1581 1603 1582 1603 1604 1603 1605 1603 1609 1603 1610 1604 \ 1580 1604 1581 1604 1582 1604 1605 1604 1609 1604 1610 1605 1580 1605 \ 1581 1605 1582 1605 1605 1605 1609 1605 1610 1606 1580 1606 1581 1606 \ 1582 1606 1605 1606 1609 1606 1610 1607 1580 1607 1605 1607 1609 1607 \ 1610 1610 1580 1610 1581 1610 1582 1610 1605 1610 1609 1610 1610 1584 \ 1648 1585 1648 1609 1648 32 1612 1617 32 1613 1617 32 1614 1617 32 \ 1615 1617 32 1616 1617 32 1617 1648 1574 1585 1574 1586 1574 1606 1576 \ 1585 1576 1586 1576 1606 1578 1585 1578 1586 1578 1606 1579 1585 1579 \ 1586 1579 1606 1605 1575 1606 1585 1606 1586 1606 1606 1610 1585 1610 \ 1586 1610 1606 1574 1582 1574 1607 1576 1607 1578 1607 1589 1582 1604 \ 1607 1606 1607 1607 1648 1610 1607 1579 1607 1587 1607 1588 1605 1588 \ 1607 1600 1614 1617 1600 1615 1617 1600 1616 1617 1591 1609 1591 1610 \ 1593 1609 1593 1610 1594 1609 1594 1610 1587 1609 1587 1610 1588 1609 \ 1588 1610 1581 1609 1581 1610 1580 1609 1580 1610 1582 1609 1582 1610 \ 1589 1609 1589 1610 1590 1609 1590 1610 1588 1580 1588 1581 1588 1582 \ 1588 1585 1587 1585 1589 1585 1590 1585 1575 1611 1578 1580 1605 1578 \ 1581 1580 1578 1581 1605 1578 1582 1605 1578 1605 1580 1578 1605 1581 \ 1578 1605 1582 1580 1605 1581 1581 1605 1610 1581 1605 1609 1587 1581 \ 1580 1587 1580 1581 1587 1580 1609 1587 1605 1581 1587 1605 1580 1587 \ 1605 1605 1589 1581 1581 1589 1605 1605 1588 1581 1605 1588 1580 1610 \ 1588 1605 1582 1588 1605 1605 1590 1581 1609 1590 1582 1605 1591 1605 \ 1581 1591 1605 1605 1591 1605 1610 1593 1580 1605 1593 1605 1605 1593 \ 1605 1609 1594 1605 1605 1594 1605 1610 1594 1605 1609 1601 1582 1605 \ 1602 1605 1581 1602 1605 1605 1604 1581 1605 1604 1581 1610 1604 1581 \ 1609 1604 1580 1580 1604 1582 1605 1604 1605 1581 1605 1581 1580 1605 \ 1581 1605 1605 1581 1610 1605 1580 1581 1605 1580 1605 1605 1582 1580 \ 1605 1582 1605 1605 1580 1582 1607 1605 1580 1607 1605 1605 1606 1581 \ 1605 1606 1581 1609 1606 1580 1605 1606 1580 1609 1606 1605 1610 1606 \ 1605 1609 1610 1605 1605 1576 1582 1610 1578 1580 1610 1578 1580 1609 \ 1578 1582 1610 1578 1582 1609 1578 1605 1610 1578 1605 1609 1580 1605 \ 1610 1580 1581 1609 1580 1605 1609 1587 1582 1609 1589 1581 1610 1588 \ 1581 1610 1590 1581 1610 1604 1580 1610 1604 1605 1610 1610 1581 1610 \ 1610 1580 1610 1610 1605 1610 1605 1605 1610 1602 1605 1610 1606 1581 \ 1610 1593 1605 1610 1603 1605 1610 1606 1580 1581 1605 1582 1610 1604 \ 1580 1605 1603 1605 1605 1580 1581 1610 1581 1580 1610 1605 1580 1610 \ 1601 1605 1610 1576 1581 1610 1587 1582 1610 1606 1580 1610 1589 1604 \ 1746 1602 1604 1746 1575 1604 1604 1607 1575 1603 1576 1585 1605 1581 \ 1605 1583 1589 1604 1593 1605 1585 1587 1608 1604 1593 1604 1610 1607 \ 1608 1587 1604 1605 1589 1604 1609 1589 1604 1609 32 1575 1604 1604 \ 1607 32 1593 1604 1610 1607 32 1608 1587 1604 1605 1580 1604 32 1580 \ 1604 1575 1604 1607 1585 1740 1575 1604 44 12289 12290 58 33 63 12310 \ 12311 8230 8229 8212 8211 95 123 125 12308 12309 12304 12305 12298 \ 12299 12300 12301 12302 12303 91 93 8254 35 38 42 45 60 62 92 36 37 \ 64 32 1611 1600 1611 32 1612 32 1613 32 1614 1600 1614 32 1615 1600 \ 1615 32 1616 1600 1616 32 1617 1600 1617 32 1618 1600 1618 1569 1570 \ 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 \ 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1601 1602 1603 1604 \ 1605 1606 1607 1608 1610 1604 1570 1604 1571 1604 1573 1604 1575 34 \ 39 47 94 124 126 10629 10630 12539 12449 12451 12453 12455 12457 12515 \ 12517 12519 12483 12540 12531 12441 12442 12644 12593 12594 12595 12596 \ 12597 12598 12599 12600 12601 12602 12603 12604 12605 12606 12607 12608 \ 12609 12610 12611 12612 12613 12614 12615 12616 12617 12618 12619 12620 \ 12621 12622 12623 12624 12625 12626 12627 12628 12629 12630 12631 12632 \ 12633 12634 12635 12636 12637 12638 12639 12640 12641 12642 12643 162 \ 163 172 175 166 165 8361 9474 8592 8593 8594 8595 9632 9675 119127 \ 119141 119128 119141 119135 119150 119135 119151 119135 119152 119135 \ 119153 119135 119154 119225 119141 119226 119141 119227 119150 119228 \ 119150 119227 119151 119228 119151 305 567 913 914 916 917 918 919 \ 921 922 923 924 925 926 927 929 1012 932 934 935 936 8711 945 950 951 \ 955 957 958 959 963 964 965 968 969 8706 1013 977 1008 981 1009 982 \ 988 989 20029 20024 20033 131362 20320 20411 20482 20602 20633 20687 \ 13470 132666 20820 20836 20855 132380 13497 20839 20877 132427 20887 \ 20900 20172 20908 168415 20995 13535 21051 21062 21106 21111 13589 \ 21253 21254 21321 21338 21363 21373 21375 133676 28784 21450 21471 \ 133987 21483 21489 21510 21662 21560 21576 21608 21666 21750 21776 \ 21843 21859 21892 21931 21939 21954 22294 22295 22097 22132 22766 22478 \ 22516 22541 22411 22578 22577 22700 136420 22770 22775 22790 22810 \ 22818 22882 136872 136938 23020 23067 23079 23000 23142 14062 14076 \ 23304 23358 137672 23491 23512 23539 138008 23551 23558 24403 14209 \ 23648 23744 23693 138724 23875 138726 23918 23915 23932 24033 24034 \ 14383 24061 24104 24125 24169 14434 139651 14460 24240 24243 24246 \ 172946 140081 33281 24354 14535 144056 156122 24418 24427 14563 24474 \ 24525 24535 24569 24705 14650 14620 141012 24775 24904 24908 24954 \ 25010 24996 25007 25054 25104 25115 25181 25265 25300 25424 142092 \ 25405 25340 25448 25475 25572 142321 25634 25541 25513 14894 25705 \ 25726 25757 25719 14956 25964 143370 26083 26360 26185 15129 15112 \ 15076 20882 20885 26368 26268 32941 17369 26401 26462 26451 144323 \ 15177 26618 26501 26706 144493 26766 26655 26900 26946 27043 27114 \ 27304 145059 27355 15384 27425 145575 27476 15438 27506 27551 27579 \ 146061 138507 146170 27726 146620 27839 27853 27751 27926 27966 28009 \ 28024 28037 146718 27956 28207 28270 15667 28359 147153 28153 28526 \ 147294 147342 28614 28729 28699 15766 28746 28797 28791 28845 132389 \ 28997 148067 29084 148395 29224 29264 149000 29312 29333 149301 149524 \ 29562 29579 16044 29605 16056 29767 29788 29829 29898 16155 29988 150582 \ 30014 150674 139679 30224 151457 151480 151620 16380 16392 151795 151794 \ 151833 151859 30494 30495 30603 16454 16534 152605 30798 16611 153126 \ 153242 153285 31211 16687 31306 31311 153980 154279 31470 16898 154539 \ 31686 31689 16935 154752 31954 17056 31976 31971 32000 155526 32099 \ 17153 32199 32258 32325 17204 156200 156231 17241 156377 32634 156478 \ 32661 32762 156890 156963 32864 157096 32880 144223 17365 32946 33027 \ 17419 33086 23221 157607 157621 144275 144284 33284 36766 17515 33425 \ 33419 33437 21171 33457 33459 33469 33510 158524 33565 33635 33709 \ 33571 33725 33767 33619 33738 33740 33756 158774 159083 158933 17707 \ 34033 34035 34070 160714 34148 159532 17757 17761 159665 159954 17771 \ 34384 34407 34409 34473 34440 34574 34530 34600 34667 34694 17879 34785 \ 34817 17913 34912 161383 35031 35038 17973 35066 13499 161966 162150 \ 18110 18119 35488 162984 36011 36033 36123 36215 163631 133124 36299 \ 36284 36336 133342 36564 165330 165357 37012 37105 37137 165678 37147 \ 37432 37591 37592 37500 37881 37909 166906 38283 18837 38327 167287 \ 18918 38595 23986 38691 168261 168474 19054 19062 38880 168970 19122 \ 169110 38953 169398 39138 19251 39209 39335 39362 39422 19406 170800 \ 40000 40189 19662 19693 40295 172238 19704 172293 172558 172689 19798 \ 40702 40709 40719 40726 173568] set DECOMP_COMPAT_MASK 65536 set DECOMP_INFO_BITS 17 # # This macro extracts the information about a character from the # Unicode character tables. # proc GetUniCharDecompCompatInfo {uc} { variable DECOMP_OFFSET_BITS variable DECOMP_COMMON_PAGE_MAP variable decompPageMap variable decompGroupMap set page [expr {($uc & 0x1fffff) >> $DECOMP_OFFSET_BITS}] if {[info exists decompPageMap($page)]} { set apage $decompPageMap($page) } else { set apage $DECOMP_COMMON_PAGE_MAP } lindex $decompGroupMap \ [expr {($apage << $DECOMP_OFFSET_BITS) | \ ($uc & ((1 << $DECOMP_OFFSET_BITS) - 1))}] } proc GetUniCharDecompInfo {uc} { variable DECOMP_COMPAT_MASK set info [GetUniCharDecompCompatInfo $uc] if {$info & $DECOMP_COMPAT_MASK} { return -1 } else { return $info } } proc GetDecompList {info} { variable DECOMP_INFO_BITS variable decompList set decomp_len [expr {$info >> $DECOMP_INFO_BITS}] set decomp_shift [expr {$info & ((1 << ($DECOMP_INFO_BITS - 1)) - 1)}] lrange $decompList $decomp_shift [expr {$decomp_shift + $decomp_len - 1}] } set COMP_OFFSET_BITS 1 # # The pageMap is indexed by page number and returns an alternate page number # that identifies a unique page of characters. Many Unicode characters map # to the same alternate page number. # array unset compPageMap array set compPageMap [list \ 30 1 31 2 32 3 33 4 34 5 35 6 36 7 37 8 38 9 39 10 40 11 41 12 42 13 \ 43 14 44 15 45 16 48 17 49 18 50 19 51 20 52 21 53 22 54 23 55 24 56 25 \ 57 26 58 27 59 28 60 29 61 30 84 31 97 32 98 33 99 34 101 35 103 36 \ 106 37 107 38 108 39 110 40 113 41 114 42 115 43 117 44 119 45 122 46 \ 123 47 124 48 126 49 129 50 137 51 166 52 173 53 176 54 180 55 181 56 \ 191 57 208 58 215 59 216 60 219 61 245 62 275 63 276 64 279 65 329 66 \ 384 67 385 68 386 69 387 70 388 71 389 72 390 73 391 74 392 75 393 76 \ 394 77 397 78 401 79 402 80 403 81 404 82 406 83 407 84 408 85 417 86 \ 418 87 456 88 458 89 459 90 460 91 463 92 464 93 466 94 468 95 470 96 \ 471 97 472 98 474 99 475 100 476 101 479 102 480 103 482 104 484 105 \ 485 106 487 107 489 108 515 109 520 110 521 111 522 112 523 113 524 114 \ 525 115 527 116 529 117 531 118 533 119 534 120 536 121 537 122 538 123 \ 539 124 540 125 541 126 543 127 545 128 547 129 549 130 550 131 555 132 \ 570 133 620 134 628 135 787 136 804 137 805 138 809 139 810 140 864 141 \ 873 142 874 143 1172 144 1176 145 1177 146 1247 147 1259 148 1439 149 \ 1451 150 1481 151 1503 152 1507 153 1515 154 1571 155 1631 156 1633 157 \ 1635 158 1637 159 1642 160 1643 161 1695 162 1699 163 1707 164 1765 165 \ 1767 166 1772 167 1774 168 1775 169 2066 170 3458 171 3459 172 3460 173 \ 3461 174 3462 175 3464 176 3485 177 3486 178 3487 179 3489 180 3867 181 \ 3885 182 3889 183 3920 184 3932 185 3942 186 3968 187 3969 188 3970 189 \ 3971 190 3972 191 3973 192 3974 193 3975 194 3976 195 3980 196 3984 197 \ 3985 198 3986 199 3987 200 3988 201 3989 202 3990 203 3991 204 3992 205 \ 3996 206 4000 207 4004 208 4008 209 4012 210 4016 211 4017 212 4018 213 \ 4019 214 4020 215 4021 216 4022 217 4023 218 4024 219 4026 220 4030 221 \ 4059 222 4063 223 4067 224 4091 225 4095 226 4296 227 4297 228 4298 229 \ 4328 230 4329 231 4330 232 4353 233 4356 234 4357 235 4369 236 4370 237 \ 4382 238 4385 239 4386 240 4388 241 4390 242 4400 243 4402 244 4409 245 \ 4411 246 4413 247 4414 248 4417 249 4419 250 4424 251 4425 252 4433 253 \ 4436 254 4437 255 4441 256 4442 257 6179 258 6181 259 6182 260 6183 261 \ 6184 262 6185 263 6186 264 6187 265 6188 266 6189 267 6190 268 6191 269 \ 6192 270 6194 271 6195 272 6196 273 6199 274 6201 275 6202 276 6204 277 \ 6205 278 6220 279 6221 280 6222 281 6227 282 6229 283 6230 284 6231 285 \ 6232 286 6233 287 6234 288 6235 289 6236 290 6237 291 6238 292 6239 293 \ 6240 294 6242 295 6243 296 6244 297 6247 298 6249 299 6250 300 6252 301 \ 6253 302 6263 303 6264 304 6265 305 6270 306] set COMP_COMMON_PAGE_MAP 0 # # The groupMap is indexed by combining the alternate page number with # the page offset and returns a group number that identifies a unique # set of character attributes. # set compGroupMap [list \ -1 -1 65568 65648 65749 -1 -1 30 91 141 65 121 65712 38 94 1 65611 \ 124 44 100 12 76 77 -1 48 105 17 84 136 54 113 23 24 -1 -1 140 64 120 \ 71 123 65577 99 10 75 129 47 104 16 15 83 135 -1 110 22 86 137 59 117 \ 118 28 89 -1 102 -1 6 -1 65724 65579 101 65551 42 -1 -1 65580 130 50 \ 65686 -1 65636 -1 115 -1 32 -1 65753 65607 67 65715 5 -1 -1 65550 107 \ 20 65634 -1 65591 -1 87 -1 142 66 106 18 37 93 65632 65733 65640 65741 \ 65604 65709 65571 65657 -1 65739 81 131 -1 119 33 -1 -1 65546 65597 \ 65705 65683 65555 65633 65735 65742 65594 65740 -1 131073 131074 131075 \ 131077 131079 -1 131080 131082 131083 131084 131098 131102 131085 -1 \ -1 131086 -1 131087 -1 131076 131078 -1 -1 131103 -1 131088 131104 \ 131101 131097 131092 131089 -1 -1 131094 131093 -1 131091 131095 131090 \ -1 -1 131072 -1 34 -1 122 -1 96 -1 8 -1 80 -1 65590 -1 85 -1 26 65538 \ -1 65718 -1 -1 2 -1 95 -1 7 -1 125 -1 51 -1 111 -1 56 -1 0 138 62 65672 \ -1 39 -1 65747 -1 97 -1 -1 65725 -1 103 14 65630 132 -1 65585 -1 65738 \ -1 -1 139 -1 65570 -1 65717 -1 65671 72 -1 -1 65678 -1 79 133 65586 \ 52 -1 65558 -1 65696 -1 -1 63 -1 65755 -1 65667 -1 65601 65666 -1 65669 \ 65545 65659 65542 65691 65563 -1 143 65744 -1 65665 -1 -1 196618 131108 \ 196619 -1 65626 65619 -1 -1 65618 65745 -1 65664 -1 -1 65663 196611 \ -1 -1 196612 196613 -1 196614 196615 65581 -1 131105 -1 98 65588 -1 \ 131106 65582 -1 -1 65727 196616 -1 127 -1 65638 -1 -1 131107 196617 \ -1 131096 -1 19 65704 -1 196610 131081 -1 -1 196608 -1 3 65539 -1 -1 \ 196609 -1 65624 -1 65710 -1 65562 -1 65708 -1 65559 -1 65621 -1 65556 \ 65547 -1 65602 -1 65687 65600 65599 -1 65688 65560 65694 65565 65754 \ 65608 114 25 65681 65554 65540 65612 82 134 65595 65701 65702 65569 \ 65649 65750 58 116 65573 65661 65544 65616 65617 65721 36 92 9 73 53 \ 108 65699 65567 65647 65748 65605 65711 27 88 65541 65613 65614 65720 \ 65576 65675 11 69 126 45 13 78 55 112 29 90 -1 70 128 46 65692 65564 \ 65643 65743 65596 65703 109 21 65650 65751 65606 65713 65572 65660 \ 65543 -1 65578 -1 65553 -1 65537 -1 -1 40 65689 -1 65574 -1 4 -1 65716 \ -1 65668 -1 65622 -1 65707 -1 65652 -1 65752 -1 -1 65722 65627 -1 -1 \ 65684 -1 65676 -1 65549 65656 -1 -1 65548 -1 65726 65552 -1 -1 65690 \ -1 65603 65655 65536 65732 65587 65561 65639 65697 65566 65645 65746 \ 65654 65756 65575 65670 -1 65584 65583 -1 65609 -1 65620 65723 -1 65677 \ 65557 65637 65736 65592 65729 -1 -1 65719 -1 65714 -1 65706 -1 65695 \ -1 65693 -1 65685 -1 65679 -1 65673 -1 65658 -1 65653 -1 65646 -1 65641 \ 65631 -1 65628 -1 65623 -1 -1 60 74 -1 -1 68 61 -1 -1 57 -1 131099 \ 131100 -1 -1 65728 65700 -1 -1 65682 -1 65680 -1 65674 -1 65662 -1 \ 65651 -1 65644 -1 65642 -1 65635 -1 65629 -1 65625 -1 65615 -1 65610 \ 65598 -1 65593 -1 65589 -1 -1 41 31 -1 -1 49 43 -1 -1 35 -1 65737 65734 \ 65731 65730 -1 -1 65698] # # Lists of compositions for characters that appears only in one composition # set compFirstList [list \ {824 8817} {837 8119} {837 8116} {3530 3549} {770 7896} {837 8090} \ {776 1243} {837 8114} {837 8076} {783 1143} {780 494} {6965 6971} \ {824 8772} {824 8742} {769 7727} {769 7688} {824 8777} {837 8178} \ {770 7879} {772 481} {6965 6930} {824 8938} {769 1116} {6965 6924} \ {772 7737} {824 8824} {6965 6920} {776 1259} {837 8099} {772 7773} \ {824 8833} {837 8083} {824 8814} {837 8069} {776 1268} {776 7802} \ {837 8110} {837 8074} {837 8183} {824 8840} {837 8094} {775 7711} \ {837 8130} {769 506} {769 7726} {3031 2964} {3158 3144} {824 8931} \ {824 8930} {769 1036} {776 1247} {824 8821} {3006 3019} {12441 12489} \ {788 8172} {769 511} {824 8941} {12441 12487} {772 561} {837 8066} \ {837 8102} {772 492} {12441 12485} {6965 6979} {6965 6977} \ {776 1261} {6965 6973} {824 8802} {769 7800} {837 8086} {837 8108} \ {769 507} {775 7785} {824 8876} {12441 12482} {770 308} {770 7897} \ {837 8091} {837 8092} {12441 12480} {837 8077} {837 8078} \ {1620 1728} {1620 1747} {824 8877} {6965 6926} {824 8622} \ {12441 12393} {4142 4134} {12441 12478} {1620 1730} {824 8713} \ {12441 12391} {12441 12476} {776 1246} {12441 12389} {775 7780} \ {774 7708} {772 555} {12441 12474} {769 510} {824 8939} {3285 3275} \ {824 8825} {775 7782} {12441 12386} {12441 12472} {837 8100} \ {12441 12470} {824 8928} {12441 12384} {837 8084} {824 8800} \ {837 8070} {837 8106} {12441 12468} {824 8655} {12441 12382} \ {824 8836} {824 8816} {824 8769} {776 7803} {12441 12380} \ {776 1242} {837 8111} {837 8075} {12441 12466} {2364 2356} \ {2364 2353} {1620 1574} {776 1111} {776 1273} {824 8603} \ {783 1142} {824 8841} {776 1260} {837 8180} {12441 12378} \ {12441 12464} {837 8095} {824 8740} {824 8879} {769 1107} \ {12441 12376} {12441 12462} {770 7878} {12441 12460} {772 480} \ {824 8716} {12441 12374} {772 554} {6965 6976} {772 7736} \ {837 8135} {824 8813} {776 1258} {837 8098} {12441 12372} \ {772 7772} {12441 12370} {776 1255} {824 8832} {12441 12542} \ {837 8082} {12441 12532} {837 8067} {837 8068} {837 8103} \ {3390 3403} {772 493} {12441 12368} {824 8653} {6965 6922} \ {769 7801} {6965 6918} {837 8087} {775 7710} {837 8109} {12441 12366} \ {769 7689} {824 8602} {776 1272} {837 8132} {12441 12364} \ {837 8093} {837 8079} {824 8708} {824 8878} {772 478} {769 1027} \ {824 8775} {3285 3264} {12441 12446} {12441 12436} {12441 12538} \ {12441 12537} {824 8820} {775 7781} {12441 12536} {774 7709} \ {824 8940} {12441 12535} {776 1254} {775 7835} {780 495} \ {775 7783} {772 560} {837 8101} {1620 1572} {2364 2345} {824 8929} \ {776 1031} {837 8085} {824 8815} {837 8071} {837 8107} {824 8654} \ {772 479} {775 7784} {776 1269} {824 8837}] set compSecondList [list \ {3545 3548} {3545 3550} {3398 3404} {2503 2507} {2503 2508} \ {2887 2891} {2887 2888} {2887 2892} {3270 3274} {3270 3272} \ {1575 1570} {1575 1573}] # # Compositions matrix # array unset compBothMap array set compBothMap [list \ 0 8179 1 8060 2 974 4 8032 6 8033 18 8182 145 204 146 205 147 206 149 296 \ 151 298 152 300 154 304 155 207 156 7880 157 463 158 520 159 522 160 7882 \ 161 302 163 7724 288 8115 289 8048 290 940 292 7936 294 7937 295 8113 \ 296 8112 306 8118 441 3546 577 8157 578 8158 594 8159 721 7873 722 7871 \ 725 7877 732 7875 865 7846 866 7844 869 7850 876 7848 1008 8131 1009 8052 \ 1010 942 1012 7968 1014 7969 1026 8134 1153 8154 1154 906 1156 7992 \ 1158 7993 1159 8153 1160 8152 1163 938 1297 7962 1298 7964 1443 293 \ 1450 7715 1451 7719 1453 543 1456 7717 1460 7721 1461 7723 1463 7830 \ 1585 7986 1586 7988 1602 7990 1729 504 1730 323 1733 209 1738 7748 1741 327 \ 1744 7750 1748 325 1750 7754 1751 7752 1873 8002 1874 8004 2024 1217 \ 2027 1244 2161 505 2162 324 2165 241 2170 7749 2173 328 2176 7751 2180 326 \ 2182 7755 2183 7753 2306 7743 2314 7745 2320 7747 2458 7786 2461 356 \ 2464 7788 2468 354 2470 7792 2471 7790 2473 538 2593 7701 2594 7703 \ 2760 3402 2882 7757 2887 557 2891 7759 3024 8105 3025 8043 3026 8045 \ 3042 8047 3170 347 3171 349 3178 7777 3181 353 3184 7779 3188 351 3193 537 \ 3313 7922 3314 221 3315 374 3317 7928 3319 562 3322 7822 3323 376 3324 7926 \ 3328 7924 3458 377 3459 7824 3466 379 3469 381 3472 7826 3479 7828 3603 7853 \ 3608 7863 3744 8188 3745 8186 3746 911 3748 8040 3750 8041 3888 8088 \ 3889 7978 3890 7980 3906 7982 4033 7923 4034 253 4035 375 4037 7929 \ 4039 563 4042 7823 4043 255 4044 7927 4048 7925 4058 7833 4177 8018 \ 4178 8020 4194 8022 4321 192 4322 193 4323 194 4325 195 4327 256 4328 258 \ 4330 550 4331 196 4332 7842 4333 461 4334 512 4335 514 4336 7840 4337 260 \ 4346 197 4349 7680 4491 12499 4492 12500 4609 7847 4610 7845 4613 7851 \ 4620 7849 4753 7915 4754 7913 4757 7919 4764 7917 4768 7921 4896 8124 \ 4897 8122 4898 902 4900 7944 4902 7945 4903 8121 4904 8120 5067 12508 \ 5068 12509 5185 7954 5186 7956 5329 7760 5330 7762 5474 500 5475 284 \ 5479 7712 5480 286 5482 288 5485 486 5492 290 5618 979 5627 980 5761 8141 \ 5762 8142 5778 8143 5931 12496 5932 12497 6049 7872 6050 7870 6053 7876 \ 6060 7874 6219 12505 6220 12506 6338 313 6349 317 6352 7734 6356 315 \ 6358 7740 6359 7738 6481 7995 6482 7997 6498 7999 6624 8097 6625 8035 \ 6626 8037 6642 8039 6770 7729 6781 489 6784 7731 6788 311 6791 7733 \ 6914 340 6922 7768 6925 344 6926 528 6927 530 6928 7770 6932 342 6935 7774 \ 7083 12502 7084 12503 7202 7756 7207 556 7211 7758 7345 8056 7346 972 \ 7348 8000 7350 8001 7489 1117 7495 1251 7496 1081 7499 1253 7632 8080 \ 7633 7970 7634 7972 7650 7974 7777 7808 7778 7810 7779 372 7786 7814 \ 7787 7812 7792 7816 7921 8010 7922 8012 8065 8058 8066 973 8068 8016 \ 8070 8017 8071 8161 8072 8160 8075 971 8082 8166 8235 12412 8236 12413 \ 8352 8072 8353 7946 8354 7948 8370 7950 8501 7805 8512 7807 8667 12400 \ 8668 12401 8811 12409 8812 12410 8929 8162 8930 944 8946 8167 9079 1263 \ 9080 1118 9083 1265 9102 1267 9226 7683 9232 7685 9239 7687 9370 7690 \ 9373 270 9376 7692 9380 7696 9382 7698 9383 7694 9505 7857 9506 7855 \ 9509 7861 9516 7859 9650 509 9655 483 9819 12406 9820 12407 9937 7987 \ 9938 7989 9954 7991 10081 8027 10082 8029 10098 8031 10234 7691 10237 271 \ 10240 7693 10244 7697 10246 7699 10247 7695 10376 1233 10379 1235 10513 7963 \ 10514 7965 10683 12403 10684 12404 10801 236 10802 237 10803 238 10805 297 \ 10807 299 10808 301 10811 239 10812 7881 10813 464 10814 521 10815 523 \ 10816 7883 10817 303 10819 7725 10945 210 10946 211 10947 212 10949 213 \ 10951 332 10952 334 10954 558 10955 214 10956 7886 10957 465 10958 524 \ 10959 526 10960 7884 10961 490 10974 336 10975 416 11090 7764 11098 7766 \ 11233 8003 11234 8005 11377 1104 11384 1239 11387 1105 11521 8184 11522 908 \ 11524 8008 11526 8009 11665 7900 11666 7898 11669 7904 11676 7902 11680 7906 \ 11808 8064 11809 7938 11810 7940 11826 7942 11953 242 11954 243 11955 244 \ 11957 245 11959 333 11960 335 11962 559 11963 246 11964 7887 11965 466 \ 11966 525 11967 527 11968 7885 11969 491 11982 337 11983 417 12097 217 \ 12098 218 12099 219 12101 360 12103 362 12104 364 12107 220 12108 7910 \ 12109 467 12110 532 12111 534 12112 7908 12113 370 12115 7796 12118 7798 \ 12122 366 12126 368 12127 431 12128 7794 12241 8170 12242 910 12246 8025 \ 12247 8169 12248 8168 12251 939 12394 7787 12395 7831 12397 357 12400 7789 \ 12404 355 12406 7793 12407 7791 12409 539 12529 476 12530 472 12535 470 \ 12541 474 12672 8089 12673 7979 12674 7981 12690 7983 12818 378 12819 7825 \ 12826 380 12829 382 12832 7827 12839 7829 12961 8019 12962 8021 12978 8023 \ 13114 7682 13120 7684 13127 7686 13249 7955 13250 7957 13393 7761 13394 7763 \ 13539 292 13546 7714 13547 7718 13549 542 13552 7716 13556 7720 13557 7722 \ 13681 8050 13682 941 13684 7952 13686 7953 13824 8140 13825 8138 13826 905 \ 13828 7976 13830 7977 13976 1232 13979 1234 14145 3018 14146 3020 14258 501 \ 14259 285 14263 7713 14264 287 14266 289 14269 487 14276 291 14402 7742 \ 14410 7744 14416 7746 14546 508 14551 482 14689 8173 14690 901 14706 8129 \ 14833 1024 14840 1238 14843 1025 14978 314 14989 318 14992 7735 14996 316 \ 14998 7741 14999 7739 15122 346 15123 348 15130 7776 15133 352 15136 7778 \ 15140 350 15145 536 15265 7700 15266 7702 15409 7891 15410 7889 15413 7895 \ 15420 7893 15552 8081 15553 7971 15554 7973 15570 7975 15696 8104 15697 8042 \ 15698 8044 15714 8046 15842 341 15850 7769 15853 345 15854 529 15855 531 \ 15856 7771 15860 343 15863 7775 15988 8164 15990 8165 16129 8011 16130 8013 \ 16282 7818 16283 7820 16419 7852 16424 7862 16561 475 16562 471 16567 469 \ 16573 473 16704 8073 16705 7947 16706 7949 16722 7951 16849 7809 16850 7811 \ 16851 373 16858 7815 16859 7813 16864 7817 16874 7832 17002 7819 17003 7821 \ 17137 7914 17138 7912 17141 7918 17148 7916 17152 7920 17282 263 17283 265 \ 17290 267 17293 269 17300 231 17425 200 17426 201 17427 202 17429 7868 \ 17431 274 17432 276 17434 278 17435 203 17436 7866 17437 282 17438 516 \ 17439 518 17440 7864 17441 280 17443 7706 17444 552 17446 7704 17569 8136 \ 17570 904 17572 7960 17574 7961 17713 232 17714 233 17715 234 17717 7869 \ 17719 275 17720 277 17722 279 17723 235 17724 7867 17725 283 17726 517 \ 17727 519 17728 7865 17729 281 17731 7707 17732 553 17734 7705 17858 7728 \ 17869 488 17872 7730 17876 310 17879 7732 18001 8054 18002 943 18004 7984 \ 18006 7985 18007 8145 18008 8144 18011 970 18018 8150 18145 7994 18146 7996 \ 18162 7998 18323 3271 18432 8096 18433 8034 18434 8036 18450 8038 18579 309 \ 18589 496 18721 7890 18722 7888 18725 7894 18732 7892 18865 7901 18866 7899 \ 18869 7905 18876 7903 18880 7907 19009 1037 19015 1250 19016 1049 19019 1252 \ 19160 1218 19163 1245 19296 8065 19297 7939 19298 7941 19314 7943 19442 7765 \ 19450 7767 19589 7804 19600 7806 19729 249 19730 250 19731 251 19733 361 \ 19735 363 19736 365 19739 252 19740 7911 19741 468 19742 533 19743 535 \ 19744 7909 19745 371 19747 7797 19750 7799 19754 367 19758 369 19759 432 \ 19760 7795 19873 8146 19874 912 19890 8151 20023 1262 20024 1038 20027 1264 \ 20046 1266 20161 224 20162 225 20163 226 20165 227 20167 257 20168 259 \ 20170 551 20171 228 20172 7843 20173 462 20174 513 20175 515 20176 7841 \ 20177 261 20186 229 20189 7681 20306 262 20307 264 20314 266 20317 268 \ 20324 199 20449 7856 20450 7854 20453 7860 20460 7858 20628 1571] proc GetUniCharCompInfo {uc} { variable COMP_OFFSET_BITS variable COMP_COMMON_PAGE_MAP variable compPageMap variable compGroupMap set page [expr {($uc & 0x1fffff) >> $COMP_OFFSET_BITS}] if {[info exists compPageMap($page)]} { set apage $compPageMap($page) } else { set apage $COMP_COMMON_PAGE_MAP } lindex $compGroupMap \ [expr {($apage << $COMP_OFFSET_BITS) | \ ($uc & ((1 << $COMP_OFFSET_BITS) - 1))}] } set COMP_SINGLE_MASK 65536 set COMP_SECOND_MASK 131072 set COMP_MASK 65535 set COMP_LENGTH1 144 proc GetCompFirst {uc info} { variable COMP_SINGLE_MASK variable COMP_SECOND_MASK variable COMP_MASK variable compFirstList if {$info == -1 || !($info & $COMP_SINGLE_MASK)} { return -1 } if {!($info & $COMP_SECOND_MASK)} { set comp [lindex $compFirstList [expr {$info & $COMP_MASK}]] if {$uc == [lindex $comp 0]} { return [lindex $comp 1] } } return 0 } proc GetCompSecond {uc info} { variable COMP_SINGLE_MASK variable COMP_SECOND_MASK variable COMP_MASK variable compSecondList if {$info == -1 || !($info & $COMP_SINGLE_MASK)} { return -1 } if {$info & $COMP_SECOND_MASK} { set comp [lindex $compSecondList [expr {$info & $COMP_MASK}]] if {$uc == [lindex $comp 0]} { return [lindex $comp 1] } } return 0 } proc GetCompBoth {info1 info2} { variable COMP_SECOND_MASK variable COMP_MASK variable COMP_LENGTH1 variable compBothMap if {$info1 != -1 && $info2 != -1 && !($info1 & $COMP_SECOND_MASK) && ($info2 & $COMP_SECOND_MASK)} { set idx [expr {$COMP_LENGTH1 * $info1 + ($info2 & $COMP_MASK)}] if {[info exists compBothMap($idx)]} { return $compBothMap($idx) } else { return 0 } } else { return 0 } } } ; # namespace eval ::unicode::data tcllib-1.15/modules/stringprep/stringprep.test0000644000175000017500000001367212077663116021214 0ustar sergeisergei# stringprep.test -*- tcl -*- # # Tests for the stringprep package. # # Copyright (c) 2007 Sergei Golovan # Copyright (c) 2007 Pat Thoyts # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: stringprep.test,v 1.3 2009/11/02 00:26:44 patthoyts Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.3 testsNeedTcltest 1.0 testing { useLocalFile unicode_data.tcl useLocalFile unicode.tcl useLocalFile stringprep_data.tcl useLocalFile stringprep.tcl } # ------------------------------------------------------------------------- # Define two stringprep profiles # IDN Nameprep: http://www.ietf.org/rfc/rfc3491.txt ::stringprep::register nameprep \ -mapping {B.1 B.2} \ -normalization KC \ -prohibited {A.1 C.1.2 C.2.2 C.3 C.4 C.5 C.6 C.7 C.8 C.9} \ -prohibitedBidi 1 # XMPP Nodeprep: http://www.ietf.org/rfc/rfc3920.txt ::stringprep::register nodeprep \ -mapping {B.1 B.2} \ -normalization KC \ -prohibited {A.1 C.1.1 C.1.2 C.2.1 C.2.2 C.3 C.4 C.5 C.6 C.7 C.8 C.9} \ -prohibitedList {0x22 0x26 0x27 0x2f 0x3a 0x3c 0x3e 0x40} \ -prohibitedBidi 1 # ------------------------------------------------------------------------- test stringprep-1.1 {register: bad -mapping table} { catch {::stringprep::register type -mapping {B.4}} result set result } {::stringprep::register -mapping: Only B.1, B.2, B.3 tables are allowed} test stringprep-1.2 {register: bad -normalization option} { catch {::stringprep::register type -normalization KK} result set result } {::stringprep::register -normalization: Only D, C, KD, KC or empty normalization is allowed} test stringprep-1.3 {register: bad -prohibited table} { catch {::stringprep::register type -prohibited {B.1}} result set result } {::stringprep::register -prohibited: Only tables A.1, C.* are allowed to prohibit} test stringprep-1.4 {register: bad -prohibited table 2} { catch {::stringprep::register type -prohibited {C.4}} result set result } {::stringprep::register -prohibited: Must prohibit all C.3--C.9 tables or none of them} test stringprep-1.5 {register: bad -prohibitedList list} { catch {::stringprep::register type -prohibitedList {1 2 3 a b c}} result set result } {::stringprep::register -prohibitedList: List of integers expected} test stringprep-1.6 {register: bad -prohibitedBidi value} { catch {::stringprep::register type -prohibitedBidi yesss} result set result } {::stringprep::register -prohibitedBidi: Boolean value expected} test stringprep-2.1 {stringprep: bad profile} { catch {::stringprep::stringprep unknown ""} result set result } {invalid_profile} test stringprep-2.2 {stringprep: prohibited character} { catch {::stringprep::stringprep nodeprep "user@host"} result set result } {prohibited_character} test stringprep-2.3 {stringprep: prohibited bidi} { catch {::stringprep::stringprep nameprep "\u0627\u0031"} result set result } {prohibited_bidi} # ------------------------------------------------------------------------- # nameprep test vectors # http://www.gnu.org/software/libidn/draft-josefsson-idn-test-vectors.html # # list of: comment, input, output set vectors { { "Map to nothing" "foo\xC2\xAD\xCD\x8F\xE1\xA0\x86\xE1\xA0\x8B.bar\xE2\x80\x8B\xE2\x81\xA0.baz\xEF\xB8\x80\xEF\xB8\x88\xEF\xB8\x8F\xEF\xBB\xBF" "foo.bar.baz" } { "Case folding ASCII U+0043 U+0041 U+0046 U+0045" "CAFE" "cafe" } { "Case folding 8bit U+00DF (german sharp s)" "\xC3\x9F" "ss" } { "Case folding U+0130 (turkish capital I with dot)" "\xC4\xB0" "i\xcc\x87" } { "Case folding multibyte U+0143 U+037A" "\xC5\x83\xCD\xBA" "\xC5\x84 \xCE\xB9" } { "Case folding U+2121 U+33C6 U+1D7BB (Tcl cannot represent U+1D7BB)" "\xE2\x84\xA1\xE3\x8F\x86\xF0\x9D\x9E\xBB" "telc\xE2\x88\x95kg\xCF\x83" } { "Normalization of U+006a U+030c U+00A0 U+00AA" "\x6A\xCC\x8C\xC2\xA0\xC2\xAA" "\xC7\xB0 a" } { "Case folding U+1FB7 and normalization" "\xE1\xBE\xB7" "\xE1\xBE\xB6\xCE\xB9" } { "Case folding U+2121 U+33C6" "\xE2\x84\xA1\xE3\x8F\x86" "telc\xE2\x88\x95kg" } } set id 0 foreach vector $vectors { foreach {comment input output} $vector break if {$id == 5} { test nameprep-$id $comment knownBug { list [catch {::stringprep::stringprep nameprep \ [encoding convertfrom utf-8 $input]} res] $res } [list 0 [encoding convertfrom utf-8 $output]] } else { test nameprep-$id $comment { list [catch {::stringprep::stringprep nameprep \ [encoding convertfrom utf-8 $input]} res] $res } [list 0 [encoding convertfrom utf-8 $output]] } incr id } # ------------------------------------------------------------------------- # SASLPrep: http://www.ietf.org/rfc/rfc4013.txt ::stringprep::register saslprep \ -mapping {B.1} \ -normalization KC \ -prohibited {A.1 C.1.2 C.2.1 C.2.2 C.3 C.4 C.5 C.6 C.7 C.8 C.9} \ -prohibitedBidi 1 foreach {n input result title} { 1 "I\u00ADX" {0 IX} "SOFT HYPHEN mapped to nothing" 2 "user" {0 user} "no transformation" 3 "USER" {0 USER} "case preserved, will not match #2" 4 "\u00AA" {0 a} "output is NFKC, input in ISO 8859-1" 5 "\u2168" {0 IX} "output is NFKC, will match #1" 6 "\u0007" {1 prohibited_character} "Error - prohibited character" 7 "\u0627\u0031" {1 prohibited_bidi} "Error - bidirectional check" } { test saslprep-1.$n $title { list [catch {::stringprep::stringprep saslprep $input} res] $res } $result } # ------------------------------------------------------------------------- ::tcltest::cleanupTests # ------------------------------------------------------------------------- tcllib-1.15/modules/stringprep/stringprep.man0000644000175000017500000001213612077663116021002 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin stringprep n 1.0.1] [copyright {2007-2009, Sergei Golovan }] [moddesc {Preparation of Internationalized Strings}] [titledesc {Implementation of stringprep}] [require Tcl 8.3] [require stringprep 1.0.1] [description] [para] This is an implementation in Tcl of the Preparation of Internationalized Strings ("stringprep"). It allows to define stringprep profiles and use them to prepare Unicode strings for comparison as defined in RFC-3454. [section "COMMANDS"] [list_begin definitions] [call [cmd "::stringprep::register"] \ [arg profile] \ [opt [arg "-mapping list"]] \ [opt [arg "-normalization form"]] \ [opt [arg "-prohibited list"]] \ [opt [arg "-prohibitedList list"]] \ [opt [arg "-prohibitedCommand command"]] \ [opt [arg "-prohibitedBidi boolean"]]] Register the [package stringprep] profile named [arg profile]. Options are the following. [para] Option [arg -mapping] specifies [package stringprep] mapping tables. This parameter takes list of tables from appendix B of RFC-3454. The usual list values are {B.1 B.2} or {B.1 B.3} where B.1 contains characters which commonly map to nothing, B.3 specifies case folding, and B.2 is used in profiles with unicode normalization form KC. Defult value is {} which means no mapping. [para] Option [arg -normalization] takes a string and if it is nonempty then it uses as a name of Unicode normalization form. Any value of "D", "C", "KD" or "KC" may be used, though RFC-3454 defines only two options: no normalization or normalization using form KC. [para] Option [arg -prohibited] takes a list of RFC-3454 tables with prohibited characters. Current version does allow to prohibit either all tables from C.3 to C.9 or neither of them. An example of this list for RFC-3491 is {A.1 C.1.2 C.2.2 C.3 C.4 C.5 C.6 C.7 C.8 C.9}. [para] Option [arg -prohibitedList] specifies a list of additional prohibited characters. The list contains not characters themselves but their Unicode numbers. For example, Nodeprep specification from RFC-3920 forbids the following codes: {0x22 0x26 0x27 0x2f 0x3a 0x3c 0x3e 0x40} (\" \& \' / : < > @). [para] Option [arg -prohibitedCommand] specifies a command which is called for every character code in mapped and normalized string. If the command returns true then the character is considered prohibited. This option is useful when a list for [arg -prohibitedList] is too large. [para] Option [arg -prohibitedBidi] takes boolean value and if it is true then the bidirectional character processing rules defined in section 6 of RFC-3454 are used. [call [cmd "::stringprep::stringprep"] \ [arg profile] \ [arg string]] Performs [package stringprep] operations defined in profile [arg profile] to string [arg string]. Result is a prepared string or one of the following errors: [arg invalid_profile] (profile [arg profile] is not defined), [arg prohibited_character] (string [arg string] contains a prohibited character) or [arg prohibited_bidi] (string [arg string] contains a prohibited bidirectional sequence). [call [cmd "::stringprep::compare"] \ [arg profile] \ [arg string1] \ [arg string2]] Compares two unicode strings prepared accordingly to [package stringprep] profile [arg profile]. The command returns 0 if prepared strings are equal, -1 if [arg string1] is lexicographically less than [arg string2], or 1 if [arg string1] is lexicographically greater than [arg string2]. [list_end] [section EXAMPLES] Nameprep profile definition (see RFC-3491): [example { ::stringprep::register nameprep \ -mapping {B.1 B.2} \ -normalization KC \ -prohibited {A.1 C.1.2 C.2.2 C.3 C.4 C.5 C.6 C.7 C.8 C.9} \ -prohibitedBidi 1 }] Nodeprep and resourceprep profile definitions (see RFC-3920): [example { ::stringprep::register nodeprep \ -mapping {B.1 B.2} \ -normalization KC \ -prohibited {A.1 C.1.1 C.1.2 C.2.1 C.2.2 C.3 C.4 C.5 C.6 C.7 C.8 C.9} \ -prohibitedList {0x22 0x26 0x27 0x2f 0x3a 0x3c 0x3e 0x40} \ -prohibitedBidi 1 ::stringprep::register resourceprep \ -mapping {B.1} \ -normalization KC \ -prohibited {A.1 C.1.2 C.2.1 C.2.2 C.3 C.4 C.5 C.6 C.7 C.8 C.9} \ -prohibitedBidi 1 }] [section "REFERENCES"] [list_begin enum] [enum] "Preparation of Internationalized Strings ('stringprep')", ([uri http://www.ietf.org/rfc/rfc3454.txt]) [enum] "Nameprep: A Stringprep Profile for Internationalized Domain Names (IDN)", ([uri http://www.ietf.org/rfc/rfc3491.txt]) [enum] "Extensible Messaging and Presence Protocol (XMPP): Core", ([uri http://www.ietf.org/rfc/rfc3920.txt]) [list_end] [see_also unicode(n) ] [section "AUTHORS"] Sergei Golovan [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph stringprep] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords stringprep unicode] [manpage_end] tcllib-1.15/modules/stringprep/ChangeLog0000644000175000017500000000420512104363437017652 0ustar sergeisergei2013-02-01 Andreas Kupries * * Released and tagged Tcllib 1.15 ======================== * 2011-12-13 Andreas Kupries * * Released and tagged Tcllib 1.14 ======================== * 2011-01-24 Andreas Kupries * * Released and tagged Tcllib 1.13 ======================== * 2009-12-07 Andreas Kupries * * Released and tagged Tcllib 1.12 ======================== * 2009-11-02 Andreas Kupries * stringprep.man: Updated version numbers in the documentation * stringprep_data.man: as well. 2009-11-02 Pat Thoyts * stringprep.tcl: Applied patch from Sergei Golovan to fix * stringprep.test: the failing tests. * stringprep_data.tcl: * tools/gen_stringprep_data.tcl: 2008-12-12 Andreas Kupries * * Released and tagged Tcllib 1.11.1 ======================== * 2008-10-16 Andreas Kupries * * Released and tagged Tcllib 1.11 ======================== * 2008-03-19 Andreas Kupries * unicode.man: Added the standard section about feedback. * stringprep.man: * stringprep_data.man: Wrote documentation for the two helper * unicode_data.man: packages holding the data tables for the main (public) packages. 2008-03-14 Andreas Kupries * stringprep.man: Cleaned up a bit, replaced deprecated [nl] usage with [para]. 2008-03-06 Andreas Kupries * stringprep.test: Marked the tests with known trouble as with constraint 'knownBug'. 2008-01-29 Andreas Kupries * unicode.man: Replaced bad backslash-quoted brackets with proper [lb], [rb] markup. * stringprep.man: Fixed missing closing bracket. 2008-01-29 Pat Thoyts * stringprep: Initial import of an RFC 3454 'StringPrep' implementation * unicode: provided by Sergei Golovan. tcllib-1.15/modules/stringprep/unicode_data.man0000644000175000017500000000202212077663116021215 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin unicode::data n 1.0.0] [copyright {2007, Sergei Golovan }] [moddesc {Preparation of Internationalized Strings}] [titledesc {unicode data tables, generated, internal}] [require Tcl 8.3] [require unicode::data 1.0.0] [description] [para] The [package unicode::data] package is a helper for [package unicode], providing it with the data tables needed to perform its functions. It is an [emph internal] package which should not be accessed on its own. Because of that it has no publicly documented API either. Its implementation is generated by a script. [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph stringprep] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords stringprep unicode] [manpage_end] tcllib-1.15/modules/stringprep/stringprep_data.man0000644000175000017500000000204512077663116021771 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin stringprep::data n 1.0.1] [copyright {2007-2009, Sergei Golovan }] [moddesc {Preparation of Internationalized Strings}] [titledesc {stringprep data tables, generated, internal}] [require Tcl 8.3] [require stringprep::data 1.0.1] [description] [para] The [package stringprep::data] package is a helper for [package stringprep], providing it with the data tables needed to perform its functions. It is an [emph internal] package which should not be accessed on its own. Because of that it has no publicly documented API either. Its implementation is generated by a script. [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph stringprep] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords stringprep unicode] [manpage_end] tcllib-1.15/modules/stringprep/stringprep_data.tcl0000644000175000017500000016622412077663116022012 0ustar sergeisergei# stringprep_data.tcl -- # # Declarations of Unicode character information tables. This file is # automatically generated by the gen_stringprep_data.tcl script. Do not # modify this file by hand. # # Copyright (c) 1998 Scriptics Corporation. # Copyright (c) 2007 Alexey Shchepin # Copyright (c) 2008 Sergei Golovan # # RCS: @(#) $Id: stringprep_data.tcl,v 1.2 2009/11/02 00:26:44 patthoyts Exp $ # package provide stringprep::data 1.0.1 namespace eval ::stringprep::data { # # A 16-bit Unicode character is split into two parts in order to index # into the following tables. The lower OFFSET_BITS comprise an offset # into a page of characters. The upper bits comprise the page number. # set OFFSET_BITS 7 # # The pageMap is indexed by page number and returns an alternate page number # that identifies a unique page of characters. Many Unicode characters map # to the same alternate page number. # array unset pageMap array set pageMap [list \ 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13 14 14 \ 15 15 18 17 19 18 20 19 21 20 22 21 23 22 24 23 25 24 26 25 27 26 28 27 \ 29 28 30 29 31 30 32 31 33 32 34 33 35 34 36 35 37 36 38 37 39 38 40 39 \ 41 40 42 40 43 40 44 41 45 42 46 43 47 44 48 45 49 46 60 47 61 48 62 49 \ 63 50 64 51 65 52 66 53 67 54 68 55 69 55 70 56 71 57 72 58 73 59 74 55 \ 75 55 76 60 77 61 78 62 79 63 80 55 81 55 82 55 83 55 84 55 85 55 93 64 \ 94 55 95 65 96 66 97 67 98 68 99 69 100 70 101 71 102 72 103 73 104 40 \ 105 40 106 40 107 40 108 40 109 40 110 40 111 40 112 40 113 40 114 40 \ 115 40 116 40 117 40 118 40 119 40 120 40 121 40 122 40 123 40 124 40 \ 125 40 126 40 127 40 128 40 129 40 130 40 131 40 132 40 133 40 134 40 \ 135 40 136 40 137 40 138 40 139 40 140 40 141 40 142 40 143 40 144 40 \ 145 40 146 40 147 40 148 40 149 40 150 40 151 40 152 40 153 40 154 40 \ 155 74 156 40 157 40 158 40 159 40 160 40 161 40 162 40 163 40 164 40 \ 165 40 166 40 167 40 168 40 169 40 170 40 171 40 172 40 173 40 174 40 \ 175 40 176 40 177 40 178 40 179 40 180 40 181 40 182 40 183 40 184 40 \ 185 40 186 40 187 40 188 40 189 40 190 40 191 40 192 40 193 40 194 40 \ 195 40 196 40 197 40 198 40 199 40 200 40 201 40 202 40 203 40 204 40 \ 205 40 206 40 207 40 208 40 209 40 210 40 211 40 212 40 213 40 214 40 \ 215 40 216 40 217 40 218 40 219 40 220 40 221 40 222 40 223 40 224 40 \ 225 40 226 40 227 40 228 40 229 40 230 40 231 40 232 40 233 40 234 40 \ 235 40 236 40 237 40 238 40 239 40 240 40 241 40 242 40 243 40 244 40 \ 245 40 246 40 247 40 248 40 249 40 250 40 251 40 252 40 253 40 254 40 \ 255 40 256 40 257 40 258 40 259 40 260 40 261 40 262 40 263 40 264 40 \ 265 40 266 40 267 40 268 40 269 40 270 40 271 40 272 40 273 40 274 40 \ 275 40 276 40 277 40 278 40 279 40 280 40 281 40 282 40 283 40 284 40 \ 285 40 286 40 287 40 288 40 289 40 290 40 291 40 292 40 293 40 294 40 \ 295 40 296 40 297 40 298 40 299 40 300 40 301 40 302 40 303 40 304 40 \ 305 40 306 40 307 40 308 40 309 40 310 40 311 40 312 40 313 40 314 40 \ 315 40 316 40 317 40 318 40 319 75 320 40 321 40 322 40 323 40 324 40 \ 325 40 326 40 327 40 328 40 329 76 344 40 345 40 346 40 347 40 348 40 \ 349 40 350 40 351 40 352 40 353 40 354 40 355 40 356 40 357 40 358 40 \ 359 40 360 40 361 40 362 40 363 40 364 40 365 40 366 40 367 40 368 40 \ 369 40 370 40 371 40 372 40 373 40 374 40 375 40 376 40 377 40 378 40 \ 379 40 380 40 381 40 382 40 383 40 384 40 385 40 386 40 387 40 388 40 \ 389 40 390 40 391 40 392 40 393 40 394 40 395 40 396 40 397 40 398 40 \ 399 40 400 40 401 40 402 40 403 40 404 40 405 40 406 40 407 40 408 40 \ 409 40 410 40 411 40 412 40 413 40 414 40 415 40 416 40 417 40 418 40 \ 419 40 420 40 421 40 422 40 423 40 424 40 425 40 426 40 427 40 428 40 \ 429 40 430 40 431 77 432 78 433 78 434 78 435 78 436 78 437 78 438 78 \ 439 78 440 78 441 78 442 78 443 78 444 78 445 78 446 78 447 78 448 78 \ 449 78 450 78 451 78 452 78 453 78 454 78 455 78 456 78 457 78 458 78 \ 459 78 460 78 461 78 462 78 463 78 464 78 465 78 466 78 467 78 468 78 \ 469 78 470 78 471 78 472 78 473 78 474 78 475 78 476 78 477 78 478 78 \ 479 78 480 78 481 78 482 78 483 78 484 78 485 78 486 78 487 78 488 78 \ 489 78 490 78 491 78 492 78 493 78 494 78 495 78 496 78 497 78 498 40 \ 499 40 500 79 502 80 503 81 504 82 505 82 506 83 507 84 508 85 509 86 \ 510 87 511 88 518 89 520 90 928 40 929 91 930 92 931 93 936 94 937 95 \ 938 96 939 97 940 98 941 99 942 100 943 101 1023 102 1024 40 1025 40 \ 1026 40 1027 40 1028 40 1029 40 1030 40 1031 40 1032 40 1033 40 1034 40 \ 1035 40 1036 40 1037 40 1038 40 1039 40 1040 40 1041 40 1042 40 1043 40 \ 1044 40 1045 40 1046 40 1047 40 1048 40 1049 40 1050 40 1051 40 1052 40 \ 1053 40 1054 40 1055 40 1056 40 1057 40 1058 40 1059 40 1060 40 1061 40 \ 1062 40 1063 40 1064 40 1065 40 1066 40 1067 40 1068 40 1069 40 1070 40 \ 1071 40 1072 40 1073 40 1074 40 1075 40 1076 40 1077 40 1078 40 1079 40 \ 1080 40 1081 40 1082 40 1083 40 1084 40 1085 40 1086 40 1087 40 1088 40 \ 1089 40 1090 40 1091 40 1092 40 1093 40 1094 40 1095 40 1096 40 1097 40 \ 1098 40 1099 40 1100 40 1101 40 1102 40 1103 40 1104 40 1105 40 1106 40 \ 1107 40 1108 40 1109 40 1110 40 1111 40 1112 40 1113 40 1114 40 1115 40 \ 1116 40 1117 40 1118 40 1119 40 1120 40 1121 40 1122 40 1123 40 1124 40 \ 1125 40 1126 40 1127 40 1128 40 1129 40 1130 40 1131 40 1132 40 1133 40 \ 1134 40 1135 40 1136 40 1137 40 1138 40 1139 40 1140 40 1141 40 1142 40 \ 1143 40 1144 40 1145 40 1146 40 1147 40 1148 40 1149 40 1150 40 1151 40 \ 1152 40 1153 40 1154 40 1155 40 1156 40 1157 40 1158 40 1159 40 1160 40 \ 1161 40 1162 40 1163 40 1164 40 1165 40 1166 40 1167 40 1168 40 1169 40 \ 1170 40 1171 40 1172 40 1173 40 1174 40 1175 40 1176 40 1177 40 1178 40 \ 1179 40 1180 40 1181 40 1182 40 1183 40 1184 40 1185 40 1186 40 1187 40 \ 1188 40 1189 40 1190 40 1191 40 1192 40 1193 40 1194 40 1195 40 1196 40 \ 1197 40 1198 40 1199 40 1200 40 1201 40 1202 40 1203 40 1204 40 1205 40 \ 1206 40 1207 40 1208 40 1209 40 1210 40 1211 40 1212 40 1213 40 1214 40 \ 1215 40 1216 40 1217 40 1218 40 1219 40 1220 40 1221 40 1222 40 1223 40 \ 1224 40 1225 40 1226 40 1227 40 1228 40 1229 40 1230 40 1231 40 1232 40 \ 1233 40 1234 40 1235 40 1236 40 1237 40 1238 40 1239 40 1240 40 1241 40 \ 1242 40 1243 40 1244 40 1245 40 1246 40 1247 40 1248 40 1249 40 1250 40 \ 1251 40 1252 40 1253 40 1254 40 1255 40 1256 40 1257 40 1258 40 1259 40 \ 1260 40 1261 40 1262 40 1263 40 1264 40 1265 40 1266 40 1267 40 1268 40 \ 1269 40 1270 40 1271 40 1272 40 1273 40 1274 40 1275 40 1276 40 1277 40 \ 1278 40 1279 40 1280 40 1281 40 1282 40 1283 40 1284 40 1285 40 1286 40 \ 1287 40 1288 40 1289 40 1290 40 1291 40 1292 40 1293 40 1294 40 1295 40 \ 1296 40 1297 40 1298 40 1299 40 1300 40 1301 40 1302 40 1303 40 1304 40 \ 1305 40 1306 40 1307 40 1308 40 1309 40 1310 40 1311 40 1312 40 1313 40 \ 1314 40 1315 40 1316 40 1317 40 1318 40 1319 40 1320 40 1321 40 1322 40 \ 1323 40 1324 40 1325 40 1326 40 1327 40 1328 40 1329 40 1330 40 1331 40 \ 1332 40 1333 40 1334 40 1335 40 1336 40 1337 40 1338 40 1339 40 1340 40 \ 1341 40 1342 40 1343 40 1344 40 1345 40 1346 40 1347 40 1348 40 1349 40 \ 1350 40 1351 40 1352 40 1353 40 1354 40 1355 40 1356 40 1357 103 1520 40 \ 1521 40 1522 40 1523 40 1524 104 1535 102 2047 102 2559 102 3071 102 \ 3583 102 4095 102 4607 102 5119 102 5631 102 6143 102 6655 102 7167 102 \ 7168 105 7679 102 7680 78 7681 78 7682 78 7683 78 7684 78 7685 78 7686 78 \ 7687 78 7688 78 7689 78 7690 78 7691 78 7692 78 7693 78 7694 78 7695 78 \ 7696 78 7697 78 7698 78 7699 78 7700 78 7701 78 7702 78 7703 78 7704 78 \ 7705 78 7706 78 7707 78 7708 78 7709 78 7710 78 7711 78 7712 78 7713 78 \ 7714 78 7715 78 7716 78 7717 78 7718 78 7719 78 7720 78 7721 78 7722 78 \ 7723 78 7724 78 7725 78 7726 78 7727 78 7728 78 7729 78 7730 78 7731 78 \ 7732 78 7733 78 7734 78 7735 78 7736 78 7737 78 7738 78 7739 78 7740 78 \ 7741 78 7742 78 7743 78 7744 78 7745 78 7746 78 7747 78 7748 78 7749 78 \ 7750 78 7751 78 7752 78 7753 78 7754 78 7755 78 7756 78 7757 78 7758 78 \ 7759 78 7760 78 7761 78 7762 78 7763 78 7764 78 7765 78 7766 78 7767 78 \ 7768 78 7769 78 7770 78 7771 78 7772 78 7773 78 7774 78 7775 78 7776 78 \ 7777 78 7778 78 7779 78 7780 78 7781 78 7782 78 7783 78 7784 78 7785 78 \ 7786 78 7787 78 7788 78 7789 78 7790 78 7791 78 7792 78 7793 78 7794 78 \ 7795 78 7796 78 7797 78 7798 78 7799 78 7800 78 7801 78 7802 78 7803 78 \ 7804 78 7805 78 7806 78 7807 78 7808 78 7809 78 7810 78 7811 78 7812 78 \ 7813 78 7814 78 7815 78 7816 78 7817 78 7818 78 7819 78 7820 78 7821 78 \ 7822 78 7823 78 7824 78 7825 78 7826 78 7827 78 7828 78 7829 78 7830 78 \ 7831 78 7832 78 7833 78 7834 78 7835 78 7836 78 7837 78 7838 78 7839 78 \ 7840 78 7841 78 7842 78 7843 78 7844 78 7845 78 7846 78 7847 78 7848 78 \ 7849 78 7850 78 7851 78 7852 78 7853 78 7854 78 7855 78 7856 78 7857 78 \ 7858 78 7859 78 7860 78 7861 78 7862 78 7863 78 7864 78 7865 78 7866 78 \ 7867 78 7868 78 7869 78 7870 78 7871 78 7872 78 7873 78 7874 78 7875 78 \ 7876 78 7877 78 7878 78 7879 78 7880 78 7881 78 7882 78 7883 78 7884 78 \ 7885 78 7886 78 7887 78 7888 78 7889 78 7890 78 7891 78 7892 78 7893 78 \ 7894 78 7895 78 7896 78 7897 78 7898 78 7899 78 7900 78 7901 78 7902 78 \ 7903 78 7904 78 7905 78 7906 78 7907 78 7908 78 7909 78 7910 78 7911 78 \ 7912 78 7913 78 7914 78 7915 78 7916 78 7917 78 7918 78 7919 78 7920 78 \ 7921 78 7922 78 7923 78 7924 78 7925 78 7926 78 7927 78 7928 78 7929 78 \ 7930 78 7931 78 7932 78 7933 78 7934 78 7935 78 7936 78 7937 78 7938 78 \ 7939 78 7940 78 7941 78 7942 78 7943 78 7944 78 7945 78 7946 78 7947 78 \ 7948 78 7949 78 7950 78 7951 78 7952 78 7953 78 7954 78 7955 78 7956 78 \ 7957 78 7958 78 7959 78 7960 78 7961 78 7962 78 7963 78 7964 78 7965 78 \ 7966 78 7967 78 7968 78 7969 78 7970 78 7971 78 7972 78 7973 78 7974 78 \ 7975 78 7976 78 7977 78 7978 78 7979 78 7980 78 7981 78 7982 78 7983 78 \ 7984 78 7985 78 7986 78 7987 78 7988 78 7989 78 7990 78 7991 78 7992 78 \ 7993 78 7994 78 7995 78 7996 78 7997 78 7998 78 7999 78 8000 78 8001 78 \ 8002 78 8003 78 8004 78 8005 78 8006 78 8007 78 8008 78 8009 78 8010 78 \ 8011 78 8012 78 8013 78 8014 78 8015 78 8016 78 8017 78 8018 78 8019 78 \ 8020 78 8021 78 8022 78 8023 78 8024 78 8025 78 8026 78 8027 78 8028 78 \ 8029 78 8030 78 8031 78 8032 78 8033 78 8034 78 8035 78 8036 78 8037 78 \ 8038 78 8039 78 8040 78 8041 78 8042 78 8043 78 8044 78 8045 78 8046 78 \ 8047 78 8048 78 8049 78 8050 78 8051 78 8052 78 8053 78 8054 78 8055 78 \ 8056 78 8057 78 8058 78 8059 78 8060 78 8061 78 8062 78 8063 78 8064 78 \ 8065 78 8066 78 8067 78 8068 78 8069 78 8070 78 8071 78 8072 78 8073 78 \ 8074 78 8075 78 8076 78 8077 78 8078 78 8079 78 8080 78 8081 78 8082 78 \ 8083 78 8084 78 8085 78 8086 78 8087 78 8088 78 8089 78 8090 78 8091 78 \ 8092 78 8093 78 8094 78 8095 78 8096 78 8097 78 8098 78 8099 78 8100 78 \ 8101 78 8102 78 8103 78 8104 78 8105 78 8106 78 8107 78 8108 78 8109 78 \ 8110 78 8111 78 8112 78 8113 78 8114 78 8115 78 8116 78 8117 78 8118 78 \ 8119 78 8120 78 8121 78 8122 78 8123 78 8124 78 8125 78 8126 78 8127 78 \ 8128 78 8129 78 8130 78 8131 78 8132 78 8133 78 8134 78 8135 78 8136 78 \ 8137 78 8138 78 8139 78 8140 78 8141 78 8142 78 8143 78 8144 78 8145 78 \ 8146 78 8147 78 8148 78 8149 78 8150 78 8151 78 8152 78 8153 78 8154 78 \ 8155 78 8156 78 8157 78 8158 78 8159 78 8160 78 8161 78 8162 78 8163 78 \ 8164 78 8165 78 8166 78 8167 78 8168 78 8169 78 8170 78 8171 78 8172 78 \ 8173 78 8174 78 8175 78 8176 78 8177 78 8178 78 8179 78 8180 78 8181 78 \ 8182 78 8183 78 8184 78 8185 78 8186 78 8187 78 8188 78 8189 78 8190 78 \ 8191 106 8192 78 8193 78 8194 78 8195 78 8196 78 8197 78 8198 78 8199 78 \ 8200 78 8201 78 8202 78 8203 78 8204 78 8205 78 8206 78 8207 78 8208 78 \ 8209 78 8210 78 8211 78 8212 78 8213 78 8214 78 8215 78 8216 78 8217 78 \ 8218 78 8219 78 8220 78 8221 78 8222 78 8223 78 8224 78 8225 78 8226 78 \ 8227 78 8228 78 8229 78 8230 78 8231 78 8232 78 8233 78 8234 78 8235 78 \ 8236 78 8237 78 8238 78 8239 78 8240 78 8241 78 8242 78 8243 78 8244 78 \ 8245 78 8246 78 8247 78 8248 78 8249 78 8250 78 8251 78 8252 78 8253 78 \ 8254 78 8255 78 8256 78 8257 78 8258 78 8259 78 8260 78 8261 78 8262 78 \ 8263 78 8264 78 8265 78 8266 78 8267 78 8268 78 8269 78 8270 78 8271 78 \ 8272 78 8273 78 8274 78 8275 78 8276 78 8277 78 8278 78 8279 78 8280 78 \ 8281 78 8282 78 8283 78 8284 78 8285 78 8286 78 8287 78 8288 78 8289 78 \ 8290 78 8291 78 8292 78 8293 78 8294 78 8295 78 8296 78 8297 78 8298 78 \ 8299 78 8300 78 8301 78 8302 78 8303 78 8304 78 8305 78 8306 78 8307 78 \ 8308 78 8309 78 8310 78 8311 78 8312 78 8313 78 8314 78 8315 78 8316 78 \ 8317 78 8318 78 8319 78 8320 78 8321 78 8322 78 8323 78 8324 78 8325 78 \ 8326 78 8327 78 8328 78 8329 78 8330 78 8331 78 8332 78 8333 78 8334 78 \ 8335 78 8336 78 8337 78 8338 78 8339 78 8340 78 8341 78 8342 78 8343 78 \ 8344 78 8345 78 8346 78 8347 78 8348 78 8349 78 8350 78 8351 78 8352 78 \ 8353 78 8354 78 8355 78 8356 78 8357 78 8358 78 8359 78 8360 78 8361 78 \ 8362 78 8363 78 8364 78 8365 78 8366 78 8367 78 8368 78 8369 78 8370 78 \ 8371 78 8372 78 8373 78 8374 78 8375 78 8376 78 8377 78 8378 78 8379 78 \ 8380 78 8381 78 8382 78 8383 78 8384 78 8385 78 8386 78 8387 78 8388 78 \ 8389 78 8390 78 8391 78 8392 78 8393 78 8394 78 8395 78 8396 78 8397 78 \ 8398 78 8399 78 8400 78 8401 78 8402 78 8403 78 8404 78 8405 78 8406 78 \ 8407 78 8408 78 8409 78 8410 78 8411 78 8412 78 8413 78 8414 78 8415 78 \ 8416 78 8417 78 8418 78 8419 78 8420 78 8421 78 8422 78 8423 78 8424 78 \ 8425 78 8426 78 8427 78 8428 78 8429 78 8430 78 8431 78 8432 78 8433 78 \ 8434 78 8435 78 8436 78 8437 78 8438 78 8439 78 8440 78 8441 78 8442 78 \ 8443 78 8444 78 8445 78 8446 78 8447 78 8448 78 8449 78 8450 78 8451 78 \ 8452 78 8453 78 8454 78 8455 78 8456 78 8457 78 8458 78 8459 78 8460 78 \ 8461 78 8462 78 8463 78 8464 78 8465 78 8466 78 8467 78 8468 78 8469 78 \ 8470 78 8471 78 8472 78 8473 78 8474 78 8475 78 8476 78 8477 78 8478 78 \ 8479 78 8480 78 8481 78 8482 78 8483 78 8484 78 8485 78 8486 78 8487 78 \ 8488 78 8489 78 8490 78 8491 78 8492 78 8493 78 8494 78 8495 78 8496 78 \ 8497 78 8498 78 8499 78 8500 78 8501 78 8502 78 8503 78 8504 78 8505 78 \ 8506 78 8507 78 8508 78 8509 78 8510 78 8511 78 8512 78 8513 78 8514 78 \ 8515 78 8516 78 8517 78 8518 78 8519 78 8520 78 8521 78 8522 78 8523 78 \ 8524 78 8525 78 8526 78 8527 78 8528 78 8529 78 8530 78 8531 78 8532 78 \ 8533 78 8534 78 8535 78 8536 78 8537 78 8538 78 8539 78 8540 78 8541 78 \ 8542 78 8543 78 8544 78 8545 78 8546 78 8547 78 8548 78 8549 78 8550 78 \ 8551 78 8552 78 8553 78 8554 78 8555 78 8556 78 8557 78 8558 78 8559 78 \ 8560 78 8561 78 8562 78 8563 78 8564 78 8565 78 8566 78 8567 78 8568 78 \ 8569 78 8570 78 8571 78 8572 78 8573 78 8574 78 8575 78 8576 78 8577 78 \ 8578 78 8579 78 8580 78 8581 78 8582 78 8583 78 8584 78 8585 78 8586 78 \ 8587 78 8588 78 8589 78 8590 78 8591 78 8592 78 8593 78 8594 78 8595 78 \ 8596 78 8597 78 8598 78 8599 78 8600 78 8601 78 8602 78 8603 78 8604 78 \ 8605 78 8606 78 8607 78 8608 78 8609 78 8610 78 8611 78 8612 78 8613 78 \ 8614 78 8615 78 8616 78 8617 78 8618 78 8619 78 8620 78 8621 78 8622 78 \ 8623 78 8624 78 8625 78 8626 78 8627 78 8628 78 8629 78 8630 78 8631 78 \ 8632 78 8633 78 8634 78 8635 78 8636 78 8637 78 8638 78 8639 78 8640 78 \ 8641 78 8642 78 8643 78 8644 78 8645 78 8646 78 8647 78 8648 78 8649 78 \ 8650 78 8651 78 8652 78 8653 78 8654 78 8655 78 8656 78 8657 78 8658 78 \ 8659 78 8660 78 8661 78 8662 78 8663 78 8664 78 8665 78 8666 78 8667 78 \ 8668 78 8669 78 8670 78 8671 78 8672 78 8673 78 8674 78 8675 78 8676 78 \ 8677 78 8678 78 8679 78 8680 78 8681 78 8682 78 8683 78 8684 78 8685 78 \ 8686 78 8687 78 8688 78 8689 78 8690 78 8691 78 8692 78 8693 78 8694 78 \ 8695 78 8696 78 8697 78 8698 78 8699 78 8700 78 8701 78 8702 78 8703 106 \ ] set COMMON_PAGE_MAP 16 # # The groupMap is indexed by combining the alternate page number with # the page offset and returns a group number that identifies a unique # set of character attributes. # set groupMap [list \ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 3 3 3 \ 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2 2 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 2 2 2 2 0 5 5 5 5 5 5 5 5 \ 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 6 2 2 2 2 2 2 2 2 2 \ 4 2 2 7 2 2 2 2 2 2 2 8 2 2 2 2 4 2 2 2 2 2 3 3 3 3 3 3 3 3 3 3 3 3 \ 3 3 3 3 3 3 3 3 3 3 3 2 3 3 3 3 3 3 3 9 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 2 4 4 4 4 4 4 4 4 10 4 10 4 10 4 10 4 10 4 10 4 10 \ 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 \ 10 4 10 4 10 4 10 4 11 4 10 4 10 4 10 4 4 10 4 10 4 10 4 10 4 10 4 \ 10 4 10 4 10 4 12 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 \ 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 13 \ 10 4 10 4 10 4 14 4 15 10 4 10 4 16 10 4 17 17 10 4 4 18 19 20 10 4 \ 17 21 4 22 23 10 4 4 4 22 24 4 25 10 4 10 4 10 4 26 10 4 26 4 4 10 \ 4 26 10 4 27 27 10 4 10 4 28 10 4 4 4 10 4 4 4 4 4 4 4 29 10 4 29 10 \ 4 29 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 4 10 4 10 4 10 4 \ 10 4 10 4 10 4 10 4 10 4 10 4 30 29 10 4 10 4 31 32 10 4 10 4 10 4 \ 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 \ 4 10 4 10 4 10 4 33 34 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 34 34 4 4 4 4 4 4 4 4 4 2 2 4 4 4 4 4 4 4 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 4 4 2 2 2 2 2 2 2 2 2 2 2 2 2 2 4 4 4 4 4 2 2 2 2 2 2 2 2 2 4 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 35 35 2 2 2 36 2 2 2 2 2 2 \ 2 2 2 7 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 34 34 34 34 2 2 34 34 34 34 37 34 34 34 2 34 34 \ 34 34 34 2 2 38 2 39 39 39 34 40 34 41 41 42 3 3 3 3 3 3 3 3 3 3 3 \ 3 3 3 3 3 3 34 3 3 3 3 3 3 3 3 3 4 4 4 4 43 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 10 4 4 4 4 4 4 4 4 4 4 4 4 34 44 45 46 47 48 49 50 4 10 4 \ 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 51 52 53 4 54 \ 55 2 34 34 34 34 34 34 34 34 34 56 56 56 56 56 56 56 56 56 56 56 56 \ 56 56 56 56 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 \ 3 3 3 3 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 10 4 10 4 10 4 10 4 10 4 10 4 10 \ 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 4 2 2 2 2 34 2 \ 2 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 \ 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 \ 4 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 34 10 4 10 4 10 4 10 4 10 4 \ 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 \ 4 34 34 10 4 34 34 34 34 34 34 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 \ 4 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 57 57 57 57 57 57 57 57 57 57 57 57 \ 57 57 57 57 57 57 57 57 57 57 57 57 57 57 57 57 57 57 57 57 57 57 57 \ 57 57 57 34 34 4 4 4 4 4 4 4 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 58 34 4 2 34 34 34 34 34 34 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 34 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 34 2 2 2 59 2 59 2 2 59 2 34 34 34 34 34 34 34 34 34 \ 34 34 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 59 59 34 34 34 34 34 59 59 59 59 59 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 2 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 59 34 34 34 59 34 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 34 34 34 34 34 59 \ 59 59 59 59 59 59 59 59 59 59 2 2 2 2 2 2 2 2 2 2 2 34 34 34 34 34 \ 34 34 34 34 34 2 2 2 2 2 2 2 2 2 2 2 2 2 59 59 59 2 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 2 2 2 2 2 2 2 60 2 2 2 2 2 2 2 59 59 2 2 2 2 2 2 2 34 34 \ 2 2 2 2 2 2 2 2 2 2 59 59 59 59 59 34 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 34 5 59 2 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 34 34 34 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 2 2 2 2 2 2 2 2 2 2 2 59 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 2 2 4 34 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 34 2 4 4 4 4 2 2 2 2 2 2 2 2 \ 4 4 4 4 2 34 34 4 2 2 2 2 34 34 34 4 4 4 4 4 4 4 4 4 4 2 2 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 2 \ 4 4 34 4 4 4 4 4 4 4 4 34 34 4 4 34 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 34 4 4 4 4 4 4 4 34 4 34 34 34 4 4 4 4 34 34 2 34 4 \ 4 4 2 2 2 2 34 34 4 4 34 34 4 4 2 34 34 34 34 34 34 34 34 34 4 34 34 \ 34 34 4 4 34 4 4 4 2 2 34 34 4 4 4 4 4 4 4 4 4 4 4 4 2 2 4 4 4 4 4 \ 4 4 34 34 34 34 34 34 34 2 34 34 4 4 4 4 4 4 34 34 34 34 4 4 34 34 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 4 4 4 4 4 4 4 34 4 4 \ 34 4 4 34 4 4 34 34 2 34 4 4 4 2 2 34 34 34 34 2 2 34 34 2 2 2 34 34 \ 34 34 34 34 34 34 34 34 34 4 4 4 4 34 4 34 34 34 34 34 34 34 4 4 4 \ 4 4 4 4 4 4 4 2 2 4 4 4 34 34 34 34 34 34 34 34 34 34 34 34 2 2 4 34 \ 4 4 4 4 4 4 4 34 4 34 4 4 4 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 34 4 4 4 4 4 4 4 34 4 4 34 4 4 4 4 4 34 34 2 4 4 4 4 2 2 2 \ 2 2 34 2 2 4 34 4 4 2 34 34 4 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 4 34 34 34 34 34 4 4 4 4 4 4 4 4 4 4 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 2 4 4 34 4 4 4 4 4 4 4 4 34 34 4 4 34 34 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 4 4 4 4 4 4 4 34 4 4 \ 34 34 4 4 4 4 34 34 2 4 4 2 4 2 2 2 34 34 34 4 4 34 34 4 4 2 34 34 \ 34 34 34 34 34 34 2 4 34 34 34 34 4 4 34 4 4 4 34 34 34 34 4 4 4 4 \ 4 4 4 4 4 4 4 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 2 \ 4 34 4 4 4 4 4 4 34 34 34 4 4 4 34 4 4 4 4 34 34 34 4 4 34 4 34 4 4 \ 34 34 34 4 4 34 34 34 4 4 4 34 34 34 4 4 4 4 4 4 4 4 34 4 4 4 34 34 \ 34 34 4 4 2 4 4 34 34 34 4 4 4 34 4 4 4 2 34 34 34 34 34 34 34 34 34 \ 4 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 4 4 4 4 4 4 4 4 4 4 \ 4 4 34 34 34 34 34 34 34 34 34 34 34 34 34 34 4 4 4 34 4 4 4 4 4 4 \ 4 4 34 4 4 4 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 4 \ 4 4 4 4 4 4 4 4 4 34 4 4 4 4 4 34 34 34 34 2 2 2 4 4 4 4 34 2 2 2 34 \ 2 2 2 2 34 34 34 34 34 34 34 2 2 34 34 34 34 34 34 34 34 34 4 4 34 \ 34 34 34 4 4 4 4 4 4 4 4 4 4 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 4 4 34 4 4 4 4 4 4 4 4 34 4 4 4 34 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 4 4 4 4 4 4 4 4 4 4 34 4 4 4 4 4 34 \ 34 34 34 4 2 4 4 4 4 4 34 2 4 4 34 4 4 2 2 34 34 34 34 34 34 34 4 4 \ 34 34 34 34 34 34 34 4 34 4 4 34 34 34 34 4 4 4 4 4 4 4 4 4 4 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 4 4 34 4 4 4 4 4 4 \ 4 4 34 4 4 4 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 34 34 34 4 4 4 2 2 2 34 34 4 4 4 34 \ 4 4 4 2 34 34 34 34 34 34 34 34 34 4 34 34 34 34 34 34 34 34 4 4 34 \ 34 34 34 4 4 4 4 4 4 4 4 4 4 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 4 4 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 34 34 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 4 4 4 4 4 4 4 4 \ 4 34 4 34 34 4 4 4 4 4 4 4 34 34 34 2 34 34 34 34 4 4 4 2 2 2 34 2 \ 34 4 4 4 4 4 4 4 4 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 4 4 4 34 34 34 34 34 34 34 34 34 34 34 34 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 2 4 4 2 2 2 2 2 2 2 34 34 34 34 2 4 4 4 4 4 4 4 2 2 2 2 2 2 \ 2 2 4 4 4 4 4 4 4 4 4 4 4 4 4 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 4 4 34 4 34 34 4 4 34 4 34 34 4 34 34 34 34 34 34 4 4 4 4 34 4 4 \ 4 4 4 4 4 34 4 4 4 34 4 34 4 34 34 4 4 34 4 4 4 4 2 4 4 2 2 2 2 2 2 \ 34 2 2 4 34 34 4 4 4 4 4 34 4 34 2 2 2 2 2 2 34 34 4 4 4 4 4 4 4 4 \ 4 4 34 34 4 4 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 2 2 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 2 4 2 4 2 2 2 2 2 4 4 4 4 4 4 4 4 4 4 34 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 34 34 \ 34 34 34 2 2 2 2 2 2 2 2 2 2 2 2 2 2 4 2 2 2 2 2 4 2 2 4 4 4 4 34 34 \ 34 34 2 2 2 2 2 2 2 2 34 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 34 4 4 4 4 4 4 4 4 2 4 4 4 4 4 4 34 34 \ 4 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 34 4 4 4 4 4 34 4 4 34 4 2 2 2 2 4 2 34 34 34 2 2 4 2 34 \ 34 34 34 34 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 2 2 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 34 34 34 34 34 34 34 34 34 34 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 34 4 34 \ 34 34 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 34 34 34 34 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 34 34 34 34 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 34 34 34 34 34 4 4 4 \ 4 4 4 4 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 34 4 34 4 4 4 4 34 34 4 4 4 4 4 4 4 34 4 34 4 4 4 4 34 34 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 34 4 34 4 4 4 4 34 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 34 4 34 4 4 4 4 34 34 4 4 4 4 4 4 4 34 4 34 4 4 4 \ 4 34 34 4 4 4 4 4 4 4 34 4 4 4 4 4 4 4 34 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 34 4 34 4 4 4 4 34 34 4 4 4 4 4 4 4 34 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 34 34 34 34 34 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 34 34 34 34 34 \ 34 34 34 34 34 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 34 34 34 34 34 34 34 34 34 6 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 2 2 34 34 34 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 34 4 4 4 4 2 2 2 34 34 34 34 34 34 34 34 34 34 34 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 2 2 2 4 4 34 34 34 34 34 34 34 34 34 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 2 2 34 34 34 34 34 34 34 34 34 34 34 \ 34 4 4 4 4 4 4 4 4 4 4 4 4 4 34 4 4 4 34 2 2 34 34 34 34 34 34 34 34 \ 34 34 34 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 2 2 2 2 2 2 2 \ 4 4 4 4 4 4 4 4 2 4 4 2 2 2 2 2 2 2 2 2 2 2 4 4 4 4 4 4 4 2 4 34 34 \ 34 4 4 4 4 4 4 4 4 4 4 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 2 2 2 2 2 2 7 2 2 2 2 7 7 7 5 34 4 4 4 4 4 4 4 \ 4 4 4 34 34 34 34 34 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 \ 34 34 34 34 34 34 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 2 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 \ 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 \ 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 \ 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 \ 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 \ 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 61 62 63 64 \ 65 66 34 34 34 34 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 \ 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 \ 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 \ 10 4 10 4 10 4 10 4 10 4 10 4 10 4 10 4 34 34 34 34 34 34 4 4 4 4 4 \ 4 4 4 67 67 67 67 67 67 67 67 4 4 4 4 4 4 34 34 67 67 67 67 67 67 34 \ 34 4 4 4 4 4 4 4 4 67 67 67 67 67 67 67 67 4 4 4 4 4 4 4 4 67 67 67 \ 67 67 67 67 67 4 4 4 4 4 4 34 34 67 67 67 67 67 67 34 34 68 4 69 4 \ 70 4 71 4 34 67 34 67 34 67 34 67 4 4 4 4 4 4 4 4 67 67 67 67 67 67 \ 67 67 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 34 72 73 74 75 76 77 78 79 80 \ 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 \ 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 \ 4 4 120 121 122 34 123 124 67 67 125 125 126 2 127 2 2 2 128 129 130 \ 34 131 132 133 133 133 133 134 2 2 2 4 4 135 136 34 34 137 138 67 67 \ 139 139 34 2 2 2 4 4 140 141 142 4 143 144 67 67 145 145 146 2 2 2 \ 34 34 147 148 149 34 150 151 152 152 153 153 154 2 2 34 6 6 6 6 6 6 \ 6 6 6 6 6 155 156 156 157 158 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 5 5 35 35 35 35 35 6 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 34 34 34 34 2 34 34 34 34 34 34 34 \ 6 156 5 5 5 34 34 34 34 34 34 159 159 159 159 159 159 2 4 34 34 2 2 \ 2 2 2 2 2 2 2 2 2 4 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 2 2 2 2 2 2 2 2 160 2 2 2 2 2 2 2 \ 2 2 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 2 2 161 162 2 2 2 163 2 164 4 165 166 167 4 4 168 169 170 \ 4 2 168 171 2 2 172 172 172 173 174 2 2 175 176 177 2 173 2 178 2 179 \ 2 180 181 182 182 2 4 183 183 2 184 4 4 4 4 4 4 2 34 34 4 185 186 2 \ 2 2 2 2 187 4 4 4 4 2 2 34 34 34 34 34 34 34 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 188 188 188 188 188 188 188 188 188 188 188 188 188 188 188 188 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 34 34 34 34 34 34 34 34 \ 34 34 34 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 4 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 2 2 2 2 2 2 2 2 2 2 \ 2 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 189 189 189 189 189 189 189 189 189 \ 189 189 189 189 189 189 189 189 189 189 189 189 189 189 189 189 189 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 34 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 34 34 2 2 34 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 34 34 2 2 2 2 2 2 2 2 2 2 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 2 2 2 2 34 2 \ 2 2 2 34 34 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 34 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 34 2 34 2 2 2 2 34 34 34 2 34 2 2 2 2 2 2 2 34 34 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 34 34 34 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 34 2 2 2 2 2 2 2 2 2 2 2 2 2 2 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 34 34 34 34 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 34 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 34 34 34 34 34 34 34 34 34 34 34 34 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 35 35 35 35 35 35 35 35 35 35 35 \ 35 34 34 34 34 6 2 2 2 2 4 4 4 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 4 4 4 4 4 4 4 4 4 2 2 2 2 2 2 2 4 4 4 4 4 2 2 4 4 4 4 \ 4 2 2 2 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 34 2 2 2 2 4 4 4 \ 2 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 2 4 4 4 4 34 34 34 34 \ 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 34 34 34 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 34 34 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 34 34 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 4 4 4 4 4 4 4 4 4 4 4 4 34 34 34 34 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 190 4 191 4 192 4 34 34 34 \ 34 4 4 4 4 4 193 194 195 196 197 198 199 200 4 4 201 202 203 4 4 4 \ 204 205 206 207 208 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 209 210 \ 211 212 4 4 4 4 4 4 4 213 214 215 216 217 218 219 220 221 222 223 224 \ 225 226 4 227 4 4 228 229 230 231 4 232 4 233 234 4 4 4 4 4 4 4 4 235 \ 4 236 237 4 238 239 34 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 4 4 4 4 4 4 4 4 4 4 4 4 4 34 34 34 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 157 \ 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 \ 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 \ 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 \ 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 \ 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 \ 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 \ 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 \ 157 157 157 157 157 157 157 157 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 34 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 240 241 242 243 244 245 246 \ 34 34 34 34 34 34 34 34 34 34 34 34 247 248 249 250 251 34 34 34 34 \ 34 59 2 59 59 59 59 59 59 59 59 59 59 2 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 34 59 59 59 59 59 34 59 34 59 59 34 59 59 34 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 2 2 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 34 34 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 34 34 34 34 34 34 34 34 35 35 35 35 35 35 35 35 35 35 35 \ 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 34 34 34 7 7 7 7 7 7 7 7 7 7 7 7 7 \ 7 7 7 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 2 2 2 2 34 34 \ 34 34 34 34 34 34 34 34 34 34 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 34 34 2 2 2 2 2 2 2 2 2 2 34 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 34 2 2 2 2 34 34 34 34 59 59 59 59 59 34 59 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 59 \ 59 59 59 59 59 59 59 59 59 59 59 59 59 59 34 34 156 34 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 3 3 3 3 3 3 3 3 \ 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2 2 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 2 2 2 2 2 2 2 2 2 2 2 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 34 34 4 4 4 4 4 4 34 34 4 4 4 4 4 4 \ 34 34 4 4 4 4 4 4 34 34 4 4 4 34 34 34 2 2 2 2 2 2 2 34 2 2 2 2 2 2 \ 2 34 34 34 34 34 34 34 34 34 34 159 159 159 159 35 35 35 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 4 4 4 4 34 34 \ 34 34 34 34 34 34 34 34 34 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 252 252 252 252 252 252 252 \ 252 252 252 252 252 252 252 252 252 252 252 252 252 252 252 252 252 \ 252 252 252 252 252 252 252 252 252 252 252 252 252 252 34 34 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 34 34 34 34 34 34 \ 34 34 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 34 34 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 2 2 2 4 4 4 4 4 4 4 4 4 5 5 5 5 5 5 5 5 2 2 2 2 2 2 \ 2 2 4 4 2 2 2 2 2 2 2 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 2 2 2 2 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 253 253 253 253 253 253 253 253 253 253 253 253 253 \ 253 253 253 253 253 253 253 253 253 253 253 253 253 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 254 254 254 254 254 254 254 254 \ 254 254 254 254 254 254 254 254 254 254 254 254 254 254 254 254 254 \ 254 4 4 4 4 4 4 4 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 255 255 255 \ 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 \ 255 255 255 255 255 255 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 256 34 256 256 34 34 256 34 34 256 256 34 34 256 256 256 256 \ 34 256 256 256 256 256 256 256 256 4 4 4 4 34 4 34 4 4 4 4 34 4 4 34 \ 4 4 4 4 4 4 4 4 4 4 4 257 257 257 257 257 257 257 257 257 257 257 257 \ 257 257 257 257 257 257 257 257 257 257 257 257 257 257 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 258 258 34 258 258 258 258 \ 34 34 258 258 258 258 258 258 258 258 34 258 258 258 258 258 258 258 \ 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 259 259 34 259 \ 259 259 259 34 259 259 259 259 259 34 259 34 34 34 259 259 259 259 \ 259 259 259 34 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 260 260 260 260 260 260 260 260 260 260 260 260 260 260 260 260 260 \ 260 260 260 260 260 260 260 260 260 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 261 261 261 261 261 261 261 261 261 261 261 261 \ 261 261 261 261 261 261 261 261 261 261 261 261 261 261 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 262 262 262 262 262 262 262 \ 262 262 262 262 262 262 262 262 262 262 262 262 262 262 262 262 262 \ 262 262 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 263 263 \ 263 263 263 263 263 263 263 263 263 263 263 263 263 263 263 263 263 \ 263 263 263 263 263 263 263 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 264 264 264 264 264 264 264 264 264 264 264 264 264 264 \ 264 264 264 264 264 264 264 264 264 264 264 264 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 265 265 265 265 265 265 265 265 265 \ 265 265 265 265 265 265 265 265 265 265 265 265 265 265 265 265 265 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 34 34 34 266 \ 266 266 266 266 266 266 266 266 266 266 266 266 266 266 266 266 267 \ 266 266 266 266 266 266 266 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 268 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 269 269 269 269 269 269 269 269 269 269 \ 269 269 269 269 269 269 269 270 269 269 269 269 269 269 269 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 271 4 4 4 4 4 4 4 4 4 4 4 4 4 4 272 272 \ 272 272 272 272 272 272 272 272 272 272 272 272 272 272 272 273 272 \ 272 272 272 272 272 272 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 274 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 275 275 275 275 275 275 275 275 275 275 275 \ 275 275 275 275 275 275 276 275 275 275 275 275 275 275 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 277 4 4 4 4 4 4 4 4 4 4 4 4 4 4 278 278 278 \ 278 278 278 278 278 278 278 278 278 278 278 278 278 278 279 278 278 \ 278 278 278 278 278 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 280 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 34 34 34 34 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 \ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 35 35 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 \ 4 4 4 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 4 4 4 4 \ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 35 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 34 \ 34 34 34 34 34 34 34 34 34 34 35 35 35 35 35 35 35 35 35 35 35 35 35 \ 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 \ 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 \ 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 \ 35 35 35 35 35 35 35 35 35 35 35 35 35 35 157 157 157 157 157 157 157 \ 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 \ 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 \ 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 \ 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 \ 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 \ 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 \ 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 157 \ 35 35] # # Each group represents a unique set of character attributes. The attributes # are encoded into a 32-bit value as follows: # # Bit 0 A.1 # # Bit 1 B.1 # # Bit 2 B.3 # # Bit 3 C.1.1 # # Bit 4 C.1.2 # # Bit 5 C.2.1 # # Bit 6 C.2.2 # # Bit 7 C.3--C.9 # # Bit 8 D.1 # # Bit 9 D.2 # # Bit 10 Case maps to several characters # # Bits 11-31 Case delta: delta for case conversions. This should be the # highest field so we can easily sign extend. # set groups [list \ 32 8 0 66052 512 64 16 2 1587716 1540 2564 3588 5636 -247292 -548348 \ 430596 422404 420356 162308 414212 416260 424452 432644 428548 \ 436740 438788 446980 444932 449028 4612 7684 -198140 -114172 -265724 \ 1 128 237572 9728 78340 76292 131588 129540 11780 13828 -60924 \ -50684 -26112 -11776 -17920 -30204 -44540 -110076 -97788 -95740 \ -122364 -130556 164356 98820 15876 256 320 17924 19972 22020 24068 \ 26116 -118268 -15868 28164 30212 32260 34308 36356 38404 40452 \ 42500 44548 46596 48644 50692 52740 54788 56836 58884 60932 62980 \ 65028 67076 69124 71172 73220 75268 77316 79364 81412 83460 85508 \ 87556 89604 91652 93700 95748 97796 99844 101892 103940 105988 \ 108036 110084 112132 114180 116228 118276 120324 122372 124420 \ 126468 128516 130564 132612 134660 136708 138756 140804 142852 \ -151036 144900 -14689788 146948 148996 151044 153092 155140 -175612 \ 157188 159236 161284 163332 165380 -204284 167428 169476 171524 \ 173572 175620 -228860 -13820 177668 179716 181764 183812 185860 \ -261628 -257532 187908 18 66 640 384 192 189440 -17102336 191488 \ -16080384 193536 -17110528 -17112576 -17114624 -17118720 -17120768 \ -17116672 195584 -17122816 -17124864 -17126912 197632 199680 201728 \ -15394300 -17133056 -17167868 -16920060 -17190400 -17192448 -17182208 \ -15488512 -15463936 -17237504 33284 53764 204288 206336 208384 \ 210432 212480 214528 216576 218624 220672 222720 224768 226816 \ 228864 230912 232960 235008 237056 239104 241152 243200 245248 \ 247296 249344 251392 253440 255488 257536 259584 261632 263680 \ 265728 267776 269824 271872 273920 275968 278016 280064 282112 \ 284160 286208 288256 290304 292352 294400 296448 298496 300544 \ 302592 304640 306692 308740 310788 312836 314884 316932 318980 \ 321028 323076 325124 327172 329220 82436 -245167616 -245274112 \ -245380608 -245487104 -245593600 -245700096 -245806592 -245913088 \ -246019584 -246126080 -246232576 -246339072 -246445568 -244823552 \ -244844032 -244874752 -244942336 -244962816 -244993536 -245061120 \ -245081600 -245112320 -245179904 -245200384 -245231104 -245298688 \ -245319168 -245349888] # # Table for characters that lowercased to multiple ones # set multiCaseTable [list \ {115 115} \ {105 775} \ {700 110} \ {106 780} \ {32 953} \ {953 776 769} \ {965 776 769} \ {1381 1410} \ {104 817} \ {116 776} \ {119 778} \ {121 778} \ {97 702} \ {965 787} \ {965 787 768} \ {965 787 769} \ {965 787 834} \ {7936 953} \ {7937 953} \ {7938 953} \ {7939 953} \ {7940 953} \ {7941 953} \ {7942 953} \ {7943 953} \ {7936 953} \ {7937 953} \ {7938 953} \ {7939 953} \ {7940 953} \ {7941 953} \ {7942 953} \ {7943 953} \ {7968 953} \ {7969 953} \ {7970 953} \ {7971 953} \ {7972 953} \ {7973 953} \ {7974 953} \ {7975 953} \ {7968 953} \ {7969 953} \ {7970 953} \ {7971 953} \ {7972 953} \ {7973 953} \ {7974 953} \ {7975 953} \ {8032 953} \ {8033 953} \ {8034 953} \ {8035 953} \ {8036 953} \ {8037 953} \ {8038 953} \ {8039 953} \ {8032 953} \ {8033 953} \ {8034 953} \ {8035 953} \ {8036 953} \ {8037 953} \ {8038 953} \ {8039 953} \ {8048 953} \ {945 953} \ {940 953} \ {945 834} \ {945 834 953} \ {945 953} \ {8052 953} \ {951 953} \ {942 953} \ {951 834} \ {951 834 953} \ {951 953} \ {953 776 768} \ {953 776 769} \ {953 834} \ {953 776 834} \ {965 776 768} \ {965 776 769} \ {961 787} \ {965 834} \ {965 776 834} \ {8060 953} \ {969 953} \ {974 953} \ {969 834} \ {969 834 953} \ {969 953} \ {114 115} \ {176 99} \ {176 102} \ {110 111} \ {115 109} \ {116 101 108} \ {116 109} \ {104 112 97} \ {97 117} \ {111 118} \ {112 97} \ {110 97} \ {956 97} \ {109 97} \ {107 97} \ {107 98} \ {109 98} \ {103 98} \ {112 102} \ {110 102} \ {956 102} \ {104 122} \ {107 104 122} \ {109 104 122} \ {103 104 122} \ {116 104 122} \ {112 97} \ {107 112 97} \ {109 112 97} \ {103 112 97} \ {112 118} \ {110 118} \ {956 118} \ {109 118} \ {107 118} \ {109 118} \ {112 119} \ {110 119} \ {956 119} \ {109 119} \ {107 119} \ {109 119} \ {107 969} \ {109 969} \ {98 113} \ {99 8725 107 103} \ {99 111 46} \ {100 98} \ {103 121} \ {104 112} \ {107 107} \ {107 109} \ {112 104} \ {112 112 109} \ {112 114} \ {115 118} \ {119 98} \ {102 102} \ {102 105} \ {102 108} \ {102 102 105} \ {102 102 108} \ {115 116} \ {115 116} \ {1396 1398} \ {1396 1381} \ {1396 1387} \ {1406 1398} \ {1396 1389} \ ] # # The following constants are used to determine the category of a # Unicode character. # set A1Mask [expr {1 << 0}] set B1Mask [expr {1 << 1}] set B3Mask [expr {1 << 2}] set C11Mask [expr {1 << 3}] set C12Mask [expr {1 << 4}] set C21Mask [expr {1 << 5}] set C22Mask [expr {1 << 6}] set C39Mask [expr {1 << 7}] set D1Mask [expr {1 << 8}] set D2Mask [expr {1 << 9}] set MCMask [expr {1 << 10}] # # The following procs extract the fields of the character info. # proc GetCaseType {info} {expr {($info & 0xE0) >> 5}} proc GetCategory {info} {expr {$info & 0x1F}} proc GetDelta {info} {expr {$info >> 11}} proc GetMC {info} { variable multiCaseTable lindex $multiCaseTable [GetDelta $info] } # # This proc extracts the information about a character from the # Unicode character tables. # proc GetUniCharInfo {uc} { variable OFFSET_BITS variable COMMON_PAGE_MAP variable pageMap variable groupMap variable groups set page [expr {($uc & 0x1fffff) >> $OFFSET_BITS}] if {[info exists pageMap($page)]} { set apage $pageMap($page) } else { set apage $COMMON_PAGE_MAP } lindex $groups \ [lindex $groupMap \ [expr {($apage << $OFFSET_BITS) | \ ($uc & ((1 << $OFFSET_BITS) - 1))}]] } } ; # namespace eval ::stringprep::data tcllib-1.15/modules/stringprep/tools/0000755000175000017500000000000012104363635017237 5ustar sergeisergeitcllib-1.15/modules/stringprep/tools/gen_unicode_test.tcl0000644000175000017500000001637512077663116023303 0ustar sergeisergei#!/usr/bin/tclsh # gen_unicode_test.tcl -- # # This program parses the RFC 3454 file and generates the # corresponding unicode.test file with unicode package tests. # The input to this program should be NormalizationTest.txt. # It can be downloaded from: # ftp://ftp.unicode.org/Public/UNIDATA/NormalizationTest.txt # Short test suite is generated by default. If you want to generate # all tests (more than 300000 test cases) add suffix 'full' as the # third argument. # # Usage: gen_unicode_test.tcl infile outdir ?full? # # RCS: @(#) $Id: gen_unicode_test.tcl,v 1.1 2008/01/29 02:18:10 patthoyts Exp $ package require struct::list set short_test_list [list \ "LATIN CAPITAL LETTER D, COMBINING DOT ABOVE, COMBINING DOT BELOW" \ "NO-BREAK SPACE" \ "VULGAR FRACTION ONE HALF" \ "ORIYA LETTER RRA" \ "KANNADA VOWEL SIGN EE" \ "TIBETAN LETTER GHA" \ "MODIFIER LETTER CAPITAL A" \ "GREEK SMALL LETTER EPSILON WITH PSILI AND OXIA" \ "KANGXI RADICAL SPROUT" \ "HIRAGANA LETTER DE" \ "KATAKANA LETTER PA" \ "HANGUL LETTER SIOS-PIEUP" \ "HANGUL SYLLABLE GYANG" \ "CJK COMPATIBILITY IDEOGRAPH-F98E" \ "ARABIC LETTER HEH DOACHASHMEE ISOLATED FORM" \ "ARABIC LIGATURE AIN WITH JEEM ISOLATED FORM" \ "FULLWIDTH DIGIT THREE" \ "LATIN SMALL LETTER A, COMBINING CYRILLIC TITLO, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B" \ "LATIN SMALL LETTER A, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, COMBINING RING OVERLAY, LATIN SMALL LETTER B" \ "HANGUL SYLLABLE BYO, COMBINING TILDE OVERLAY, HANGUL JONGSEONG TIKEUT"] set fd [open [lindex $argv 0]] set all_tests {} set n 0 while {[gets $fd line] >= 0} { set line [string trim $line] if {![regexp \ {^([ [:xdigit:]]+);([ [:xdigit:]]+);([ [:xdigit:]]+);([ [:xdigit:]]+);([ [:xdigit:]]+);.*\) (.*)} \ $line -> c(1) c(2) c(3) c(4) c(5) title]} continue set q 1 foreach i {1 2 3 4 5} { set s($i) {} set us($i) "" foreach xnum $c($i) { set uc [scan $xnum %x] if {$uc > 0xffff} { set q 0 } lappend s($i) $uc append us($i) \\u$xnum } } if {!$q} { # Test case contains character which is greater than 0xFFFF and can't # be represented in Tcl continue } set test($n) [list $s(1) $s(2) $s(3) $s(4) $s(5) $title] set test1($n) [list $us(1) $us(2) $us(3) $us(4) $us(5) $title] if {[lsearch $short_test_list $title] >= 0} { lappend all_tests $n } incr n } close $fd if {[string equal [lindex $argv 2] full]} { set all_tests [struct::list iota $n] } set f [open [file join [lindex $argv 1] unicode.test] w] fconfigure $f -translation lf puts $f \ "# unicode.test # # Tests for the unicode package. This file is automatically generated by # the gen_unicode_test.tcl script. Do not modify this file by hands. # # RCS: @(#) \$Id\$ # ------------------------------------------------------------------------- source \[file join \\ \[file dirname \[file dirname \[file join \[pwd\] \[info script\]\]\]\] \\ devtools testutilities.tcl\] testsNeedTcl 8.3 testsNeedTcltest 1.0 testing { useLocalFile unicode_data.tcl useLocalFile unicode.tcl } # ------------------------------------------------------------------------- " set j 0 foreach i $all_tests { puts $f \ " test unicode-1.[incr j] {normalizeS D: [lindex $test1($i) 5]} { unicode::normalizeS D \"[lindex $test1($i) 0]\" } \"[lindex $test1($i) 2]\" test unicode-1.[incr j] {normalize D: [lindex $test($i) 5]} { unicode::normalize D [list [lindex $test($i) 1]] } {[lindex $test($i) 2]} test unicode-1.[incr j] {normalize D: [lindex $test($i) 5]} { unicode::normalize D [list [lindex $test($i) 2]] } {[lindex $test($i) 2]} test unicode-1.[incr j] {normalize D: [lindex $test($i) 5]} { unicode::normalize D [list [lindex $test($i) 3]] } {[lindex $test($i) 4]} test unicode-1.[incr j] {normalize D: [lindex $test($i) 5]} { unicode::normalize D [list [lindex $test($i) 4]] } {[lindex $test($i) 4]} " } set j 0 foreach i $all_tests { puts $f \ " test unicode-2.[incr j] {normalize C: [lindex $test($i) 5]} { unicode::normalize C [list [lindex $test($i) 0]] } {[lindex $test($i) 1]} test unicode-2.[incr j] {normalizeS C: [lindex $test1($i) 5]} { unicode::normalizeS C \"[lindex $test1($i) 1]\" } \"[lindex $test1($i) 1]\" test unicode-2.[incr j] {normalize C: [lindex $test($i) 5]} { unicode::normalize C [list [lindex $test($i) 2]] } {[lindex $test($i) 1]} test unicode-2.[incr j] {normalize C: [lindex $test($i) 5]} { unicode::normalize C [list [lindex $test($i) 3]] } {[lindex $test($i) 3]} test unicode-2.[incr j] {normalize C: [lindex $test($i) 5]} { unicode::normalize C [list [lindex $test($i) 4]] } {[lindex $test($i) 3]} " } set j 0 foreach i $all_tests { puts $f \ " test unicode-3.[incr j] {normalize KD: [lindex $test($i) 5]} { unicode::normalize KD [list [lindex $test($i) 0]] } {[lindex $test($i) 4]} test unicode-3.[incr j] {normalize KD: [lindex $test($i) 5]} { unicode::normalize KD [list [lindex $test($i) 1]] } {[lindex $test($i) 4]} test unicode-3.[incr j] {normalizeS KD: [lindex $test1($i) 5]} { unicode::normalizeS KD \"[lindex $test1($i) 2]\" } \"[lindex $test1($i) 4]\" test unicode-3.[incr j] {normalize KD: [lindex $test($i) 5]} { unicode::normalize KD [list [lindex $test($i) 3]] } {[lindex $test($i) 4]} test unicode-1.[incr j] {normalize KD: [lindex $test($i) 5]} { unicode::normalize KD [list [lindex $test($i) 4]] } {[lindex $test($i) 4]} " } set j 0 foreach i $all_tests { puts $f \ " test unicode-4.[incr j] {normalize KC: [lindex $test($i) 5]} { unicode::normalize KC [list [lindex $test($i) 0]] } {[lindex $test($i) 3]} test unicode-4.[incr j] {normalize KC: [lindex $test($i) 5]} { unicode::normalize KC [list [lindex $test($i) 1]] } {[lindex $test($i) 3]} test unicode-4.[incr j] {normalize KC: [lindex $test($i) 5]} { unicode::normalize KC [list [lindex $test($i) 2]] } {[lindex $test($i) 3]} test unicode-4.[incr j] {normalizeS KC: [lindex $test1($i) 5]} { unicode::normalizeS KC \"[lindex $test1($i) 3]\" } \"[lindex $test1($i) 3]\" test unicode-4.[incr j] {normalize KC: [lindex $test($i) 5]} { unicode::normalize KC [list [lindex $test($i) 4]] } {[lindex $test($i) 3]} " } puts $f \ " test unicode-5.1 {fromstring} { unicode::fromstring \"\\u0403\\u0405\\u0406\\u041f\\u0034\" } {1027 1029 1030 1055 52} test unicode-5.2 {fromstring} { unicode::fromstring \"\\u0001\\u0002\\u0003\\u0004\\u0005\\u0006\\u0007\\u0008\\u0009\\u000a\\u000b\\u000c\\u000d\" } {1 2 3 4 5 6 7 8 9 10 11 12 13} test unicode-6.1 {tostring} { unicode::tostring {16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1} } \"\\u0010\\u000f\\u000e\\u000d\\u000c\\u000b\\u000a\\u0009\\u0008\\u0007\\u0006\\u0005\\u0004\\u0003\\u0002\\u0001\" test unicode-6.2 {tostring} { unicode::tostring {12345 12346 12347 12348 12349 12350 12351} } \"\\u3039\\u303a\\u303b\\u303c\\u303d\\u303e\\u303f\" test unicode-7.1 {normalize bad form} { catch {unicode::normalize S \"\"} result set result } \"::unicode::normalize: Only D, C, KD and KC forms are allowed\" test unicode-8.1 {normalizeS bad form} { catch {unicode::normalizeS S \"\"} result set result } \"::unicode::normalizeS: Only D, C, KD and KC forms are allowed\" ::tcltest::cleanupTests " close $f tcllib-1.15/modules/stringprep/tools/gen_unicode_data.tcl0000644000175000017500000005145412077663116023232 0ustar sergeisergei#!/usr/bin/env tclsh # gen_unicode_data.tcl -- # # This program parses the UnicodeData files and generates the # corresponding unicode_data.tcl file with compressed character # data tables. The input to this program should be # UnicodeData.txt and CompositionExclusions.txt files # from: ftp://ftp.unicode.org/Public/UNIDATA/UnicodeData.txt # and ftp://ftp.unicode.org/Public/UNIDATA/CompositionExclusions.txt # # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # # Modified for ejabberd by Alexey Shchepin # Modified for Tcl stringprep by Sergei Golovan # # Usage: gen_unicode_data.tcl infile1 infile2 outdir # # RCS: @(#) $Id: gen_unicode_data.tcl,v 1.1 2008/01/29 02:18:10 patthoyts Exp $ namespace eval uni { set cclass_shift 2 set decomp_shift 3 set comp_shift 1 set shift 5; # number of bits of data within a page # This value can be adjusted to find the # best split to minimize table size variable pMap; # map from page to page index, each entry is # an index into the pages table, indexed by # page number variable pages; # map from page index to page info, each # entry is a list of indices into the groups # table, the list is indexed by the offset variable groups; # list of character info values, indexed by # group number, initialized with the # unassigned character group variable categories { Cn Lu Ll Lt Lm Lo Mn Me Mc Nd Nl No Zs Zl Zp Cc Cf Co Cs Pc Pd Ps Pe Pi Pf Po Sm Sc Sk So }; # Ordered list of character categories, must # match the enumeration in the header file. variable titleCount 0; # Count of the number of title case # characters. This value is used in the # regular expression code to allocate enough # space for the title case variants. } proc uni::getValue {items index} { variable categories variable titleCount # Extract character info set category [lindex $items 2] if {[scan [lindex $items 12] %4x toupper] == 1} { set toupper [expr {$index - $toupper}] } else { set toupper {} } if {[scan [lindex $items 13] %4x tolower] == 1} { set tolower [expr {$tolower - $index}] } else { set tolower {} } if {[scan [lindex $items 14] %4x totitle] == 1} { set totitle [expr {$index - $totitle}] } else { set totitle {} } set categoryIndex [lsearch -exact $categories $category] if {$categoryIndex < 0} { puts "Unexpected character category: $index($category)" set categoryIndex 0 } elseif {$category == "Lt"} { incr titleCount } return "$categoryIndex,$toupper,$tolower,$totitle" } proc uni::getGroup {value} { variable groups set gIndex [lsearch -exact $groups $value] if {$gIndex == -1} { set gIndex [llength $groups] lappend groups $value } return $gIndex } proc uni::addPage {info} { variable pMap variable pages set pIndex [lsearch -exact $pages $info] if {$pIndex == -1} { set pIndex [llength $pages] lappend pages $info } lappend pMap $pIndex return } proc uni::addPage {map_var pages_var info} { variable $map_var variable $pages_var set pIndex [lsearch -exact [set $pages_var] $info] if {$pIndex == -1} { set pIndex [llength [set $pages_var]] lappend $pages_var $info } lappend $map_var $pIndex return } proc uni::load_exclusions {data} { variable exclusions foreach line [split $data \n] { if {$line == ""} continue set items [split $line " "] if {[lindex $items 0] == "#"} continue scan [lindex $items 0] %x index set exclusions($index) "" } } proc uni::load_tables {data} { variable cclass_map variable decomp_map variable decomp_compat variable comp_map variable comp_first variable comp_second variable exclusions foreach line [split $data \n] { if {$line == ""} continue set items [split $line \;] scan [lindex $items 0] %x index set cclass [lindex $items 3] set decomp [lindex $items 5] set cclass_map($index) $cclass #set decomp_map($index) $cclass if {$decomp != ""} { set decomp_compat($index) 0 if {[string index [lindex $decomp 0] 0] == "<"} { set decomp_compat($index) 1 set decomp1 [lreplace $decomp 0 0] set decomp {} foreach ch $decomp1 { scan $ch %x ch lappend decomp $ch } set decomp_map($index) $decomp } else { switch -- [llength $decomp] { 1 { scan $decomp %x ch set decomp_map($index) $ch } 2 { scan $decomp "%x %x" ch1 ch2 set decomp [list $ch1 $ch2] set decomp_map($index) $decomp # hackish if {(![info exists cclass_map($ch1)] || \ $cclass_map($ch1) == 0) && \ ![info exists exclusions($index)]} { if {[info exists comp_first($ch1)]} { incr comp_first($ch1) } else { set comp_first($ch1) 1 } if {[info exists comp_second($ch2)]} { incr comp_second($ch2) } else { set comp_second($ch2) 1 } set comp_map($decomp) $index } else { #puts "Excluded $index" } } default { puts "Bad canonical decomposition: $line" } } } #puts "[format 0x%0.4x $index]\t$cclass\t$decomp_map($index)" } } #puts [array get comp_first] #puts [array get comp_second] } proc uni::buildTables {} { variable cclass_shift variable decomp_shift variable comp_shift variable cclass_map variable cclass_pmap {} variable cclass_pages {} variable decomp_map variable decomp_compat variable decomp_pmap {} variable decomp_pages {} variable decomp_list {} variable comp_map variable comp_pmap {} variable comp_pages {} variable comp_first variable comp_second variable comp_first_list {} variable comp_second_list {} variable comp_x_list {} variable comp_y_list {} variable comp_both_map {} set cclass_info {} set decomp_info {} set comp_info {} set cclass_mask [expr {(1 << $cclass_shift) - 1}] set decomp_mask [expr {(1 << $decomp_shift) - 1}] set comp_mask [expr {(1 << $comp_shift) - 1}] foreach comp [array names comp_map] { set ch1 [lindex $comp 0] if {[info exists comp_first($ch1)] && $comp_first($ch1) > 0 && \ [info exists comp_second($ch1)] && $comp_second($ch1) > 0} { if {[lsearch -exact $comp_x_list $ch1] < 0} { set i [llength $comp_x_list] lappend comp_x_list $ch1 set comp_info_map($ch1) $i lappend comp_y_list $ch1 set comp_info_map($ch1) $i puts "There should be no symbols which appears on" puts "both first and second place in composition" exit 1 } } } foreach comp [array names comp_map] { set ch1 [lindex $comp 0] set ch2 [lindex $comp 1] if {$comp_first($ch1) == 1 && ![info exists comp_second($ch1)]} { set i [llength $comp_first_list] lappend comp_first_list [list $ch2 $comp_map($comp)] set comp_info_map($ch1) [expr {$i | (1 << 16)}] } elseif {$comp_second($ch2) == 1 && ![info exists comp_first($ch2)]} { set i [llength $comp_second_list] lappend comp_second_list [list $ch1 $comp_map($comp)] set comp_info_map($ch2) [expr {$i | (1 << 16) | (1 << 17)}] } else { if {[lsearch -exact $comp_x_list $ch1] < 0} { set i [llength $comp_x_list] lappend comp_x_list $ch1 set comp_info_map($ch1) $i } if {[lsearch -exact $comp_y_list $ch2] < 0} { set i [llength $comp_y_list] lappend comp_y_list $ch2 set comp_info_map($ch2) [expr {$i | (1 << 17)}] } } } set next 0 for {set i 0} {$i <= 0x10ffff} {incr i} { #set gIndex [getGroup [getValue $i]] set cclass_offset [expr {$i & $cclass_mask}] if {[info exists cclass_map($i)]} { set cclass $cclass_map($i) } else { set cclass 0 } lappend cclass_info $cclass if {$cclass_offset == $cclass_mask} { addPage cclass_pmap cclass_pages $cclass_info set cclass_info {} } set decomp_offset [expr {$i & $decomp_mask}] if {[info exists decomp_map($i)]} { set decomp $decomp_map($i) if {[llength $decomp] > (1 << 14)} { puts "Too long decomp for $i" exit 1 } if {[info exists decomp_used($decomp)]} { lappend decomp_info [expr {$decomp_used($decomp) | ($decomp_compat($i) << 16)}] } else { set val [expr {([llength $decomp] << 17) + \ [llength $decomp_list]}] set decomp_used($decomp) $val lappend decomp_info [expr {$val | ($decomp_compat($i) << 16)}] #puts "$val $decomp" foreach d $decomp { lappend decomp_list $d } } } else { lappend decomp_info -1 } if {$decomp_offset == $decomp_mask} { addPage decomp_pmap decomp_pages $decomp_info set decomp_info {} } set comp_offset [expr {$i & $comp_mask}] if {[info exists comp_info_map($i)]} { set comp $comp_info_map($i) } else { set comp -1 } lappend comp_info $comp if {$comp_offset == $comp_mask} { addPage comp_pmap comp_pages $comp_info set comp_info {} } } #puts [array get decomp_map] #puts $decomp_list return } proc uni::main {} { global argc argv0 argv variable cclass_shift variable cclass_pmap variable cclass_pages variable decomp_shift variable decomp_pmap variable decomp_pages variable decomp_list variable comp_shift variable comp_map variable comp_pmap variable comp_pages variable comp_first_list variable comp_second_list variable comp_x_list variable comp_y_list variable pages variable groups {} variable titleCount if {$argc != 3} { puts stderr "\nusage: $argv0 \n" exit 1 } set f [open [lindex $argv 1] r] set data [read $f] close $f load_exclusions $data set f [open [lindex $argv 0] r] set data [read $f] close $f load_tables $data buildTables #puts "X = [llength $pMap] Y= [llength $pages] A= [llength $groups]" #set size [expr {[llength $pMap] + [llength $pages]*(1<<$shift)}] #puts "shift = 6, space = $size" #puts "title case count = $titleCount" set f [open [file join [lindex $argv 2] unicode_data.tcl] w] fconfigure $f -translation lf puts $f \ "# unicode_data.tcl -- # # Declarations of Unicode character information tables. This file is # automatically generated by the gen_unicode_data.tcl script. Do not # modify this file by hand. # # Copyright (c) 1998 Scriptics Corporation. # Copyright (c) 2007 Alexey Shchepin # Copyright (c) 2007 Sergei Golovan # # See the file \"license.terms\" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) \$Id\$ # # A 16-bit Unicode character is split into two parts in order to index # into the following tables. The lower CCLASS_OFFSET_BITS comprise an offset # into a page of characters. The upper bits comprise the page number. # package provide unicode::data 1.0.0 namespace eval ::unicode::data { set CCLASS_OFFSET_BITS $cclass_shift # # The cclassPageMap is indexed by page number and returns an alternate page number # that identifies a unique page of characters. Many Unicode characters map # to the same alternate page number. # array unset cclassPageMap array set cclassPageMap \[list \\" array unset tmp foreach idx $cclass_pmap { if {![info exists tmp($idx)]} { set tmp($idx) 1 } else { incr tmp($idx) } } set max 0 set max_id 0 foreach idx [array names tmp] { if {$tmp($idx) > $max} { set max $tmp($idx) set max_id $idx } } set line " " set last [expr {[llength $cclass_pmap] - 1}] for {set i 0} {$i <= $last} {incr i} { set num [lindex $cclass_pmap $i] if {$num != $max_id} { append line " $i $num" } if {[string length $line] > 70} { puts $f "$line \\" set line " " } } puts $f "$line\] set CCLASS_COMMON_PAGE_MAP $max_id # # The cclassGroupMap is indexed by combining the alternate page number with # the page offset and returns a combining class number. # set cclassGroupMap \[list \\" set line " " set lasti [expr {[llength $cclass_pages] - 1}] for {set i 0} {$i <= $lasti} {incr i} { set page [lindex $cclass_pages $i] set lastj [expr {[llength $page] - 1}] for {set j 0} {$j <= $lastj} {incr j} { append line [lindex $page $j] if {$j != $lastj || $i != $lasti} { append line " " } if {[string length $line] > 70} { puts $f "$line\\" set line " " } } } puts $f "$line\] proc GetUniCharCClass {uc} { variable CCLASS_OFFSET_BITS variable CCLASS_COMMON_PAGE_MAP variable cclassPageMap variable cclassGroupMap set page \[expr {(\$uc & 0x1fffff) >> \$CCLASS_OFFSET_BITS}\] if {\[info exists cclassPageMap(\$page)\]} { set apage \$cclassPageMap(\$page) } else { set apage \$CCLASS_COMMON_PAGE_MAP } lindex \$cclassGroupMap \\ \[expr {(\$apage << \$CCLASS_OFFSET_BITS) | \\ (\$uc & ((1 << \$CCLASS_OFFSET_BITS) - 1))}\] } set DECOMP_OFFSET_BITS $decomp_shift # # The pageMap is indexed by page number and returns an alternate page number # that identifies a unique page of characters. Many Unicode characters map # to the same alternate page number. # array unset decompPageMap array set decompPageMap \[list \\" array unset tmp foreach idx $decomp_pmap { if {![info exists tmp($idx)]} { set tmp($idx) 1 } else { incr tmp($idx) } } set max 0 set max_id 0 foreach idx [array names tmp] { if {$tmp($idx) > $max} { set max $tmp($idx) set max_id $idx } } set line " " set last [expr {[llength $decomp_pmap] - 1}] for {set i 0} {$i <= $last} {incr i} { set num [lindex $decomp_pmap $i] if {$num != $max_id} { append line " $i $num" } if {[string length $line] > 70} { puts $f "$line \\" set line " " } } puts $f "$line\] set DECOMP_COMMON_PAGE_MAP $max_id # # The decompGroupMap is indexed by combining the alternate page number with # the page offset and returns a group number that identifies a length and # shift of decomposition sequence in decompList # set decompGroupMap \[list \\" set line " " set lasti [expr {[llength $decomp_pages] - 1}] for {set i 0} {$i <= $lasti} {incr i} { set page [lindex $decomp_pages $i] set lastj [expr {[llength $page] - 1}] for {set j 0} {$j <= $lastj} {incr j} { append line [lindex $page $j] if {$j != $lastj || $i != $lasti} { append line " " } if {[string length $line] > 70} { puts $f "$line\\" set line " " } } } puts $f "$line\] # # List of decomposition sequences # set decompList \[list \\" set line " " set last [expr {[llength $decomp_list] - 1}] for {set i 0} {$i <= $last} {incr i} { set val [lindex $decomp_list $i] append line [format "%d" $val] if {$i != $last} { append line " " } if {[string length $line] > 70} { puts $f "$line\\" set line " " } } puts $f "$line\] set DECOMP_COMPAT_MASK [expr {1 << 16}] set DECOMP_INFO_BITS 17 # # This macro extracts the information about a character from the # Unicode character tables. # proc GetUniCharDecompCompatInfo {uc} { variable DECOMP_OFFSET_BITS variable DECOMP_COMMON_PAGE_MAP variable decompPageMap variable decompGroupMap set page \[expr {(\$uc & 0x1fffff) >> \$DECOMP_OFFSET_BITS}\] if {\[info exists decompPageMap(\$page)\]} { set apage \$decompPageMap(\$page) } else { set apage \$DECOMP_COMMON_PAGE_MAP } lindex \$decompGroupMap \\ \[expr {(\$apage << \$DECOMP_OFFSET_BITS) | \\ (\$uc & ((1 << \$DECOMP_OFFSET_BITS) - 1))}\] } proc GetUniCharDecompInfo {uc} { variable DECOMP_COMPAT_MASK set info \[GetUniCharDecompCompatInfo \$uc\] if {\$info & \$DECOMP_COMPAT_MASK} { return -1 } else { return \$info } } proc GetDecompList {info} { variable DECOMP_INFO_BITS variable decompList set decomp_len \[expr {\$info >> \$DECOMP_INFO_BITS}\] set decomp_shift \[expr {\$info & ((1 << (\$DECOMP_INFO_BITS - 1)) - 1)}\] lrange \$decompList \$decomp_shift \[expr {\$decomp_shift + \$decomp_len - 1}\] } set COMP_OFFSET_BITS $comp_shift # # The pageMap is indexed by page number and returns an alternate page number # that identifies a unique page of characters. Many Unicode characters map # to the same alternate page number. # array unset compPageMap array set compPageMap \[list \\" array unset tmp foreach idx $comp_pmap { if {![info exists tmp($idx)]} { set tmp($idx) 1 } else { incr tmp($idx) } } set max 0 set max_id 0 foreach idx [array names tmp] { if {$tmp($idx) > $max} { set max $tmp($idx) set max_id $idx } } set line " " set last [expr {[llength $comp_pmap] - 1}] for {set i 0} {$i <= $last} {incr i} { set num [lindex $comp_pmap $i] if {$num != $max_id} { append line " $i $num" } if {[string length $line] > 70} { puts $f "$line \\" set line " " } } puts $f "$line\] set COMP_COMMON_PAGE_MAP $max_id # # The groupMap is indexed by combining the alternate page number with # the page offset and returns a group number that identifies a unique # set of character attributes. # set compGroupMap \[list \\" set line " " set lasti [expr {[llength $comp_pages] - 1}] for {set i 0} {$i <= $lasti} {incr i} { set page [lindex $comp_pages $i] set lastj [expr {[llength $page] - 1}] for {set j 0} {$j <= $lastj} {incr j} { append line [lindex $page $j] if {$j != $lastj || $i != $lasti} { append line " " } if {[string length $line] > 70} { puts $f "$line\\" set line " " } } } puts $f "$line\] # # Lists of compositions for characters that appears only in one composition # set compFirstList \[list \\" set line " " set last [expr {[llength $comp_first_list] - 1}] for {set i 0} {$i <= $last} {incr i} { set val [lindex $comp_first_list $i] append line [format "{%d %d}" [lindex $val 0] [lindex $val 1]] if {$i != $last} { append line " " } if {[string length $line] > 60} { puts $f "$line\\" set line " " } } puts $f "$line\] set compSecondList \[list \\" set line " " set last [expr {[llength $comp_second_list] - 1}] for {set i 0} {$i <= $last} {incr i} { set val [lindex $comp_second_list $i] append line [format "{%d %d}" [lindex $val 0] [lindex $val 1]] if {$i != $last} { append line " " } if {[string length $line] > 60} { puts $f "$line\\" set line " " } } puts $f "$line\] # # Compositions matrix # array unset compBothMap array set compBothMap \[list \\" set lastx [expr {[llength $comp_x_list] - 1}] set lasty [expr {[llength $comp_y_list] - 1}] set line " " for {set i 0} {$i <= $lastx} {incr i} { for {set j 0} {$j <= $lasty} {incr j} { set comp [list [lindex $comp_x_list $i] [lindex $comp_y_list $j]] if {[info exists comp_map($comp)]} { append line " " [expr {$i*[llength $comp_x_list]+$j}] \ " " [format "%d" $comp_map($comp)] } if {[string length $line] > 70} { puts $f "$line \\" set line " " } } } puts $f "$line\] proc GetUniCharCompInfo {uc} { variable COMP_OFFSET_BITS variable COMP_COMMON_PAGE_MAP variable compPageMap variable compGroupMap set page \[expr {(\$uc & 0x1fffff) >> \$COMP_OFFSET_BITS}\] if {\[info exists compPageMap(\$page)\]} { set apage \$compPageMap(\$page) } else { set apage \$COMP_COMMON_PAGE_MAP } lindex \$compGroupMap \\ \[expr {(\$apage << \$COMP_OFFSET_BITS) | \\ (\$uc & ((1 << \$COMP_OFFSET_BITS) - 1))}\] } set COMP_SINGLE_MASK [expr {1 << 16}] set COMP_SECOND_MASK [expr {1 << 17}] set COMP_MASK [expr {(1 << 16) - 1}] set COMP_LENGTH1 [llength $comp_x_list] proc GetCompFirst {uc info} { variable COMP_SINGLE_MASK variable COMP_SECOND_MASK variable COMP_MASK variable compFirstList if {\$info == -1 || !(\$info & \$COMP_SINGLE_MASK)} { return -1 } if {!(\$info & \$COMP_SECOND_MASK)} { set comp \[lindex \$compFirstList \[expr {\$info & \$COMP_MASK}\]\] if {\$uc == \[lindex \$comp 0\]} { return \[lindex \$comp 1\] } } return 0 } proc GetCompSecond {uc info} { variable COMP_SINGLE_MASK variable COMP_SECOND_MASK variable COMP_MASK variable compSecondList if {\$info == -1 || !(\$info & \$COMP_SINGLE_MASK)} { return -1 } if {\$info & \$COMP_SECOND_MASK} { set comp \[lindex \$compSecondList \[expr {\$info & \$COMP_MASK}\]\] if {\$uc == \[lindex \$comp 0\]} { return \[lindex \$comp 1\] } } return 0 } proc GetCompBoth {info1 info2} { variable COMP_SECOND_MASK variable COMP_MASK variable COMP_LENGTH1 variable compBothMap if {\$info1 != -1 && \$info2 != -1 && \ !(\$info1 & \$COMP_SECOND_MASK) && (\$info2 & \$COMP_SECOND_MASK)} { set idx \[expr {\$COMP_LENGTH1 * \$info1 + (\$info2 & \$COMP_MASK)}\] if {\[info exists compBothMap(\$idx)\]} { return \$compBothMap(\$idx) } else { return 0 } } else { return 0 } } } ; # namespace eval ::unicode::data " close $f } uni::main return tcllib-1.15/modules/stringprep/tools/gen_stringprep_data.tcl0000644000175000017500000002757512077663116024010 0ustar sergeisergei#!/usr/bin/env tclsh # gen_stringprep_data.tcl -- # # This program parses the RFC 3454 file and generates the # corresponding stringprep_data.tcl file with compressed character # data tables. The input to this program should be rfc3454.txt. # It can be downloaded from http://www.ietf.org/rfc/rfc3454.txt # # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # # Modified for ejabberd by Alexey Shchepin # Modified for Tcl stringprep by Sergei Golovan # # Usage: gen_stringprep_data.tcl infile outdir # # RCS: @(#) $Id: gen_stringprep_data.tcl,v 1.2 2009/11/02 00:26:44 patthoyts Exp $ namespace eval uni { set shift 7; # number of bits of data within a page # This value can be adjusted to find the # best split to minimize table size variable pMap; # map from page to page index, each entry is # an index into the pages table, indexed by # page number variable pages; # map from page index to page info, each # entry is a list of indices into the groups # table, the list is indexed by the offset variable groups; # list of character info values, indexed by # group number, initialized with the # unassigned character group } proc uni::getValue {i} { variable casemap variable casemap2 variable tablemap if {[info exists tablemap($i)]} { set tables $tablemap($i) } else { set tables {} } if {[info exists casemap2($i)]} { set multicase 1 set delta $casemap2($i) } else { set multicase 0 if {[info exists casemap($i)]} { set delta $casemap($i) } else { set delta 0 } } if {abs($delta) > 0xFFFFF} { puts "delta must be less than 22 bits wide" exit } set a1 0 set b1 0 set b2 0 set b3 0 set c11 0 set c12 0 set c21 0 set c22 0 set c3 0 set c4 0 set c5 0 set c6 0 set c7 0 set c8 0 set c9 0 set d1 0 set d2 0 foreach tab $tables { switch -glob -- $tab { A.1 {set a1 1} B.1 {set b1 1} B.2 {set b2 1} B.3 {set b3 1} C.1.1 {set c11 1} C.1.2 {set c12 1} C.2.1 {set c21 1} C.2.2 {set c22 1} C.3 {set c3 1} C.4 {set c4 1} C.5 {set c5 1} C.6 {set c6 1} C.7 {set c7 1} C.8 {set c8 1} C.9 {set c9 1} D.1 {set d1 1} D.2 {set d2 1} } } set val [expr {($a1 << 0) | ($b1 << 1) | ($b3 << 2) | ($c11 << 3) | ($c12 << 4) | ($c21 << 5) | ($c22 << 6) | (($c3 | $c4 | $c5 | $c6 | $c7 | $c8 | $c9) << 7) | ($d1 << 8) | ($d2 << 9) | ($multicase << 10) | ($delta << 11)}] return $val } proc uni::getGroup {value} { variable groups set gIndex [lsearch -exact $groups $value] if {$gIndex == -1} { set gIndex [llength $groups] lappend groups $value } return $gIndex } proc uni::addPage {info} { variable pMap variable pages variable pages_map if {[info exists pages_map($info)]} { lappend pMap $pages_map($info) } else { set pIndex [llength $pages] lappend pages $info set pages_map($info) $pIndex lappend pMap $pIndex } return } proc uni::load_tables {data} { variable casemap variable casemap2 variable multicasemap variable tablemap set multicasemap {} set table "" foreach line [split $data \n] { if {$table == ""} { if {[regexp { ----- Start Table (.*) -----} $line temp table]} { #puts "Start table '$table'" } } else { if {[regexp { ----- End Table (.*) -----} $line temp table1]} { set table "" } else { if {$table == "B.1"} { if {[regexp {^ ([[:xdigit:]]+); ;} $line \ temp val]} { scan $val %x val if {$val <= 0x10ffff} { lappend tablemap($val) $table } } } elseif {$table == "B.2"} { # B.2 table is used for mapping with normalisation if {[regexp {^ ([[:xdigit:]]+); ([[:xdigit:]]+);} $line \ temp from to]} { scan $from %x from scan $to %x to if {$from <= 0x10ffff && $to <= 0x10ffff} { set casemap($from) [expr {$to - $from}] } } elseif {[regexp {^ ([[:xdigit:]]+); ([[:xdigit:]]+) ([[:xdigit:]]+);} $line \ temp from to1 to2]} { scan $from %x from scan $to1 %x to1 scan $to2 %x to2 if {$from <= 0x10ffff && \ $to1 <= 0x10ffff && $to2 <= 0x10ffff} { set casemap2($from) [llength $multicasemap] lappend multicasemap [list $to1 $to2] } } elseif {[regexp {^ ([[:xdigit:]]+); ([[:xdigit:]]+) ([[:xdigit:]]+) ([[:xdigit:]]+);} $line \ temp from to1 to2 to3]} { scan $from %x from scan $to1 %x to1 scan $to2 %x to2 scan $to3 %x to3 if {$from <= 0x10ffff && \ $to1 <= 0x10ffff && $to2 <= 0x10ffff && \ $to3 <= 0x10ffff} { set casemap2($from) [llength $multicasemap] lappend multicasemap [list $to1 $to2 $to3] } } elseif {[regexp {^ ([[:xdigit:]]+); ([[:xdigit:]]+) ([[:xdigit:]]+) ([[:xdigit:]]+) ([[:xdigit:]]+);} $line \ temp from to1 to2 to3 to4]} { scan $from %x from scan $to1 %x to1 scan $to2 %x to2 scan $to3 %x to3 scan $to4 %x to4 if {$from <= 0x10ffff && \ $to1 <= 0x10ffff && $to2 <= 0x10ffff && \ $to3 <= 0x10ffff && $to4 <= 0x10ffff} { set casemap2($from) [llength $multicasemap] lappend multicasemap [list $to1 $to2 $to3 $to4] } } else { #puts "missed: $line" } } elseif {$table == "B.3"} { # B.3 table is used for mapping without normalisation (B.3 is a subset of B.2) if {[regexp {^ ([[:xdigit:]]+);} $line temp from]} { scan $from %x from if {$from <= 0x10ffff} { lappend tablemap($from) $table } } } else { if {[regexp {^ ([[:xdigit:]]+)-([[:xdigit:]]+)} $line \ temp from to]} { scan $from %x from scan $to %x to for {set i $from} {$i <= $to && $i <= 0x10ffff} {incr i} { lappend tablemap($i) $table } } elseif {[regexp {^ ([[:xdigit:]]+)} $line \ temp val]} { scan $val %x val if {$val <= 0x10ffff} { lappend tablemap($val) $table } } } } } } } proc uni::buildTables {} { variable shift variable casemap variable tablemap variable pMap {} variable pages {} variable groups {} set info {} ;# temporary page info set mask [expr {(1 << $shift) - 1}] set next 0 for {set i 0} {$i <= 0x10ffff} {incr i} { set gIndex [getGroup [getValue $i]] # Split character index into offset and page number set offset [expr {$i & $mask}] set page [expr {($i >> $shift)}] # Add the group index to the info for the current page lappend info $gIndex # If this is the last entry in the page, add the page if {$offset == $mask} { addPage $info set info {} } } return } proc uni::main {} { global argc argv0 argv variable pMap variable pages variable groups variable shift variable multicasemap if {$argc != 2} { puts stderr "\nusage: $argv0 \n" exit 1 } set f [open [lindex $argv 0] r] set data [read $f] close $f load_tables $data buildTables #puts "X = [llength $pMap] Y= [llength $pages] A= [llength $groups]" #set size [expr {[llength $pMap] + [llength $pages]*(1<<$shift)}] #puts "shift = $shift, space = $size" set f [open [file join [lindex $argv 1] stringprep_data.tcl] w] fconfigure $f -translation lf puts $f \ "# stringprep_data.tcl -- # # Declarations of Unicode character information tables. This file is # automatically generated by the gen_stringprep_data.tcl script. Do not # modify this file by hand. # # Copyright (c) 1998 Scriptics Corporation. # Copyright (c) 2007 Alexey Shchepin # Copyright (c) 2008 Sergei Golovan # # RCS: @(#) \$Id\$ # package provide stringprep::data 1.0.1 namespace eval ::stringprep::data { # # A 16-bit Unicode character is split into two parts in order to index # into the following tables. The lower OFFSET_BITS comprise an offset # into a page of characters. The upper bits comprise the page number. # set OFFSET_BITS $shift # # The pageMap is indexed by page number and returns an alternate page number # that identifies a unique page of characters. Many Unicode characters map # to the same alternate page number. # array unset pageMap array set pageMap \[list \\" array unset tmp foreach idx $pMap { if {![info exists tmp($idx)]} { set tmp($idx) 1 } else { incr tmp($idx) } } set max 0 set max_id 0 foreach idx [array names tmp] { if {$tmp($idx) > $max} { set max $tmp($idx) set max_id $idx } } set line " " set last [expr {[llength $pMap] - 1}] for {set i 0} {$i <= $last} {incr i} { set num [lindex $pMap $i] if {$num != $max_id} { append line " $i $num" } if {[string length $line] > 70} { puts $f "$line \\" set line " " } } puts $f "$line\] set COMMON_PAGE_MAP $max_id # # The groupMap is indexed by combining the alternate page number with # the page offset and returns a group number that identifies a unique # set of character attributes. # set groupMap \[list \\" set line " " set lasti [expr {[llength $pages] - 1}] for {set i 0} {$i <= $lasti} {incr i} { set page [lindex $pages $i] set lastj [expr {[llength $page] - 1}] for {set j 0} {$j <= $lastj} {incr j} { append line [lindex $page $j] if {$j != $lastj || $i != $lasti} { append line " " } if {[string length $line] > 70} { puts $f "$line\\" set line " " } } } puts $f "$line\] # # Each group represents a unique set of character attributes. The attributes # are encoded into a 32-bit value as follows: # # Bit 0 A.1 # # Bit 1 B.1 # # Bit 2 B.3 # # Bit 3 C.1.1 # # Bit 4 C.1.2 # # Bit 5 C.2.1 # # Bit 6 C.2.2 # # Bit 7 C.3--C.9 # # Bit 8 D.1 # # Bit 9 D.2 # # Bit 10 Case maps to several characters # # Bits 11-31 Case delta: delta for case conversions. This should be the # highest field so we can easily sign extend. # set groups \[list \\" set line " " set last [expr {[llength $groups] - 1}] for {set i 0} {$i <= $last} {incr i} { set val [lindex $groups $i] append line [format "%d" $val] if {$i != $last} { append line " " } if {[string length $line] > 65} { puts $f "$line\\" set line " " } } puts $f "$line\] # # Table for characters that lowercased to multiple ones # set multiCaseTable \[list \\" set last [expr {[llength $multicasemap] - 1}] for {set i 0} {$i <= $last} {incr i} { set val [lindex $multicasemap $i] set line " " append line "{" [join $val " "] "}" puts $f "$line \\" } puts $f "\] # # The following constants are used to determine the category of a # Unicode character. # set A1Mask \[expr {1 << 0}\] set B1Mask \[expr {1 << 1}\] set B3Mask \[expr {1 << 2}\] set C11Mask \[expr {1 << 3}\] set C12Mask \[expr {1 << 4}\] set C21Mask \[expr {1 << 5}\] set C22Mask \[expr {1 << 6}\] set C39Mask \[expr {1 << 7}\] set D1Mask \[expr {1 << 8}\] set D2Mask \[expr {1 << 9}\] set MCMask \[expr {1 << 10}\] # # The following procs extract the fields of the character info. # proc GetCaseType {info} {expr {(\$info & 0xE0) >> 5}} proc GetCategory {info} {expr {\$info & 0x1F}} proc GetDelta {info} {expr {\$info >> 11}} proc GetMC {info} { variable multiCaseTable lindex \$multiCaseTable \[GetDelta \$info\] } # # This proc extracts the information about a character from the # Unicode character tables. # proc GetUniCharInfo {uc} { variable OFFSET_BITS variable COMMON_PAGE_MAP variable pageMap variable groupMap variable groups set page \[expr {(\$uc & 0x1fffff) >> \$OFFSET_BITS}\] if {\[info exists pageMap(\$page)\]} { set apage \$pageMap(\$page) } else { set apage \$COMMON_PAGE_MAP } lindex \$groups \\ \[lindex \$groupMap \\ \[expr {(\$apage << \$OFFSET_BITS) | \\ (\$uc & ((1 << \$OFFSET_BITS) - 1))}\]\] } } ; # namespace eval ::stringprep::data " close $f } uni::main return tcllib-1.15/modules/stringprep/pkgIndex.tcl0000644000175000017500000000051312077663116020361 0ustar sergeisergeipackage ifneeded stringprep 1.0.1 [list source [file join $dir stringprep.tcl]] package ifneeded stringprep::data 1.0.1 [list source [file join $dir stringprep_data.tcl]] package ifneeded unicode 1.0.0 [list source [file join $dir unicode.tcl]] package ifneeded unicode::data 1.0.0 [list source [file join $dir unicode_data.tcl]] tcllib-1.15/modules/stringprep/unicode.test0000644000175000017500000014723512077663116020450 0ustar sergeisergei# unicode.test -*- tcl -*- # # Tests for the unicode package. This file is automatically generated by # the gen_unicode_test.tcl script. Do not modify this file by hands. # # RCS: @(#) $Id: unicode.test,v 1.1 2008/01/29 02:18:10 patthoyts Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.3 testsNeedTcltest 1.0 testing { useLocalFile unicode_data.tcl useLocalFile unicode.tcl } # ------------------------------------------------------------------------- test unicode-1.1 {normalizeS D: LATIN CAPITAL LETTER D, COMBINING DOT ABOVE, COMBINING DOT BELOW} { unicode::normalizeS D "\u0044\u0307\u0323" } "\u0044\u0323\u0307" test unicode-1.2 {normalize D: LATIN CAPITAL LETTER D, COMBINING DOT ABOVE, COMBINING DOT BELOW} { unicode::normalize D {7692 775} } {68 803 775} test unicode-1.3 {normalize D: LATIN CAPITAL LETTER D, COMBINING DOT ABOVE, COMBINING DOT BELOW} { unicode::normalize D {68 803 775} } {68 803 775} test unicode-1.4 {normalize D: LATIN CAPITAL LETTER D, COMBINING DOT ABOVE, COMBINING DOT BELOW} { unicode::normalize D {7692 775} } {68 803 775} test unicode-1.5 {normalize D: LATIN CAPITAL LETTER D, COMBINING DOT ABOVE, COMBINING DOT BELOW} { unicode::normalize D {68 803 775} } {68 803 775} test unicode-1.6 {normalizeS D: NO-BREAK SPACE} { unicode::normalizeS D "\u00A0" } "\u00A0" test unicode-1.7 {normalize D: NO-BREAK SPACE} { unicode::normalize D 160 } {160} test unicode-1.8 {normalize D: NO-BREAK SPACE} { unicode::normalize D 160 } {160} test unicode-1.9 {normalize D: NO-BREAK SPACE} { unicode::normalize D 32 } {32} test unicode-1.10 {normalize D: NO-BREAK SPACE} { unicode::normalize D 32 } {32} test unicode-1.11 {normalizeS D: VULGAR FRACTION ONE HALF} { unicode::normalizeS D "\u00BD" } "\u00BD" test unicode-1.12 {normalize D: VULGAR FRACTION ONE HALF} { unicode::normalize D 189 } {189} test unicode-1.13 {normalize D: VULGAR FRACTION ONE HALF} { unicode::normalize D 189 } {189} test unicode-1.14 {normalize D: VULGAR FRACTION ONE HALF} { unicode::normalize D {49 8260 50} } {49 8260 50} test unicode-1.15 {normalize D: VULGAR FRACTION ONE HALF} { unicode::normalize D {49 8260 50} } {49 8260 50} test unicode-1.16 {normalizeS D: ORIYA LETTER RRA} { unicode::normalizeS D "\u0B5C" } "\u0B21\u0B3C" test unicode-1.17 {normalize D: ORIYA LETTER RRA} { unicode::normalize D {2849 2876} } {2849 2876} test unicode-1.18 {normalize D: ORIYA LETTER RRA} { unicode::normalize D {2849 2876} } {2849 2876} test unicode-1.19 {normalize D: ORIYA LETTER RRA} { unicode::normalize D {2849 2876} } {2849 2876} test unicode-1.20 {normalize D: ORIYA LETTER RRA} { unicode::normalize D {2849 2876} } {2849 2876} test unicode-1.21 {normalizeS D: KANNADA VOWEL SIGN EE} { unicode::normalizeS D "\u0CC7" } "\u0CC6\u0CD5" test unicode-1.22 {normalize D: KANNADA VOWEL SIGN EE} { unicode::normalize D 3271 } {3270 3285} test unicode-1.23 {normalize D: KANNADA VOWEL SIGN EE} { unicode::normalize D {3270 3285} } {3270 3285} test unicode-1.24 {normalize D: KANNADA VOWEL SIGN EE} { unicode::normalize D 3271 } {3270 3285} test unicode-1.25 {normalize D: KANNADA VOWEL SIGN EE} { unicode::normalize D {3270 3285} } {3270 3285} test unicode-1.26 {normalizeS D: TIBETAN LETTER GHA} { unicode::normalizeS D "\u0F43" } "\u0F42\u0FB7" test unicode-1.27 {normalize D: TIBETAN LETTER GHA} { unicode::normalize D {3906 4023} } {3906 4023} test unicode-1.28 {normalize D: TIBETAN LETTER GHA} { unicode::normalize D {3906 4023} } {3906 4023} test unicode-1.29 {normalize D: TIBETAN LETTER GHA} { unicode::normalize D {3906 4023} } {3906 4023} test unicode-1.30 {normalize D: TIBETAN LETTER GHA} { unicode::normalize D {3906 4023} } {3906 4023} test unicode-1.31 {normalizeS D: MODIFIER LETTER CAPITAL A} { unicode::normalizeS D "\u1D2C" } "\u1D2C" test unicode-1.32 {normalize D: MODIFIER LETTER CAPITAL A} { unicode::normalize D 7468 } {7468} test unicode-1.33 {normalize D: MODIFIER LETTER CAPITAL A} { unicode::normalize D 7468 } {7468} test unicode-1.34 {normalize D: MODIFIER LETTER CAPITAL A} { unicode::normalize D 65 } {65} test unicode-1.35 {normalize D: MODIFIER LETTER CAPITAL A} { unicode::normalize D 65 } {65} test unicode-1.36 {normalizeS D: GREEK SMALL LETTER EPSILON WITH PSILI AND OXIA} { unicode::normalizeS D "\u1F14" } "\u03B5\u0313\u0301" test unicode-1.37 {normalize D: GREEK SMALL LETTER EPSILON WITH PSILI AND OXIA} { unicode::normalize D 7956 } {949 787 769} test unicode-1.38 {normalize D: GREEK SMALL LETTER EPSILON WITH PSILI AND OXIA} { unicode::normalize D {949 787 769} } {949 787 769} test unicode-1.39 {normalize D: GREEK SMALL LETTER EPSILON WITH PSILI AND OXIA} { unicode::normalize D 7956 } {949 787 769} test unicode-1.40 {normalize D: GREEK SMALL LETTER EPSILON WITH PSILI AND OXIA} { unicode::normalize D {949 787 769} } {949 787 769} test unicode-1.41 {normalizeS D: KANGXI RADICAL SPROUT} { unicode::normalizeS D "\u2F2C" } "\u2F2C" test unicode-1.42 {normalize D: KANGXI RADICAL SPROUT} { unicode::normalize D 12076 } {12076} test unicode-1.43 {normalize D: KANGXI RADICAL SPROUT} { unicode::normalize D 12076 } {12076} test unicode-1.44 {normalize D: KANGXI RADICAL SPROUT} { unicode::normalize D 23662 } {23662} test unicode-1.45 {normalize D: KANGXI RADICAL SPROUT} { unicode::normalize D 23662 } {23662} test unicode-1.46 {normalizeS D: HIRAGANA LETTER DE} { unicode::normalizeS D "\u3067" } "\u3066\u3099" test unicode-1.47 {normalize D: HIRAGANA LETTER DE} { unicode::normalize D 12391 } {12390 12441} test unicode-1.48 {normalize D: HIRAGANA LETTER DE} { unicode::normalize D {12390 12441} } {12390 12441} test unicode-1.49 {normalize D: HIRAGANA LETTER DE} { unicode::normalize D 12391 } {12390 12441} test unicode-1.50 {normalize D: HIRAGANA LETTER DE} { unicode::normalize D {12390 12441} } {12390 12441} test unicode-1.51 {normalizeS D: KATAKANA LETTER PA} { unicode::normalizeS D "\u30D1" } "\u30CF\u309A" test unicode-1.52 {normalize D: KATAKANA LETTER PA} { unicode::normalize D 12497 } {12495 12442} test unicode-1.53 {normalize D: KATAKANA LETTER PA} { unicode::normalize D {12495 12442} } {12495 12442} test unicode-1.54 {normalize D: KATAKANA LETTER PA} { unicode::normalize D 12497 } {12495 12442} test unicode-1.55 {normalize D: KATAKANA LETTER PA} { unicode::normalize D {12495 12442} } {12495 12442} test unicode-1.56 {normalizeS D: HANGUL LETTER SIOS-PIEUP} { unicode::normalizeS D "\u317D" } "\u317D" test unicode-1.57 {normalize D: HANGUL LETTER SIOS-PIEUP} { unicode::normalize D 12669 } {12669} test unicode-1.58 {normalize D: HANGUL LETTER SIOS-PIEUP} { unicode::normalize D 12669 } {12669} test unicode-1.59 {normalize D: HANGUL LETTER SIOS-PIEUP} { unicode::normalize D 4402 } {4402} test unicode-1.60 {normalize D: HANGUL LETTER SIOS-PIEUP} { unicode::normalize D 4402 } {4402} test unicode-1.61 {normalizeS D: HANGUL SYLLABLE GYANG} { unicode::normalizeS D "\uAC4D" } "\u1100\u1163\u11BC" test unicode-1.62 {normalize D: HANGUL SYLLABLE GYANG} { unicode::normalize D 44109 } {4352 4451 4540} test unicode-1.63 {normalize D: HANGUL SYLLABLE GYANG} { unicode::normalize D {4352 4451 4540} } {4352 4451 4540} test unicode-1.64 {normalize D: HANGUL SYLLABLE GYANG} { unicode::normalize D 44109 } {4352 4451 4540} test unicode-1.65 {normalize D: HANGUL SYLLABLE GYANG} { unicode::normalize D {4352 4451 4540} } {4352 4451 4540} test unicode-1.66 {normalizeS D: CJK COMPATIBILITY IDEOGRAPH-F98E} { unicode::normalizeS D "\uF98E" } "\u5E74" test unicode-1.67 {normalize D: CJK COMPATIBILITY IDEOGRAPH-F98E} { unicode::normalize D 24180 } {24180} test unicode-1.68 {normalize D: CJK COMPATIBILITY IDEOGRAPH-F98E} { unicode::normalize D 24180 } {24180} test unicode-1.69 {normalize D: CJK COMPATIBILITY IDEOGRAPH-F98E} { unicode::normalize D 24180 } {24180} test unicode-1.70 {normalize D: CJK COMPATIBILITY IDEOGRAPH-F98E} { unicode::normalize D 24180 } {24180} test unicode-1.71 {normalizeS D: ARABIC LETTER HEH DOACHASHMEE ISOLATED FORM} { unicode::normalizeS D "\uFBAA" } "\uFBAA" test unicode-1.72 {normalize D: ARABIC LETTER HEH DOACHASHMEE ISOLATED FORM} { unicode::normalize D 64426 } {64426} test unicode-1.73 {normalize D: ARABIC LETTER HEH DOACHASHMEE ISOLATED FORM} { unicode::normalize D 64426 } {64426} test unicode-1.74 {normalize D: ARABIC LETTER HEH DOACHASHMEE ISOLATED FORM} { unicode::normalize D 1726 } {1726} test unicode-1.75 {normalize D: ARABIC LETTER HEH DOACHASHMEE ISOLATED FORM} { unicode::normalize D 1726 } {1726} test unicode-1.76 {normalizeS D: ARABIC LIGATURE AIN WITH JEEM ISOLATED FORM} { unicode::normalizeS D "\uFC29" } "\uFC29" test unicode-1.77 {normalize D: ARABIC LIGATURE AIN WITH JEEM ISOLATED FORM} { unicode::normalize D 64553 } {64553} test unicode-1.78 {normalize D: ARABIC LIGATURE AIN WITH JEEM ISOLATED FORM} { unicode::normalize D 64553 } {64553} test unicode-1.79 {normalize D: ARABIC LIGATURE AIN WITH JEEM ISOLATED FORM} { unicode::normalize D {1593 1580} } {1593 1580} test unicode-1.80 {normalize D: ARABIC LIGATURE AIN WITH JEEM ISOLATED FORM} { unicode::normalize D {1593 1580} } {1593 1580} test unicode-1.81 {normalizeS D: FULLWIDTH DIGIT THREE} { unicode::normalizeS D "\uFF13" } "\uFF13" test unicode-1.82 {normalize D: FULLWIDTH DIGIT THREE} { unicode::normalize D 65299 } {65299} test unicode-1.83 {normalize D: FULLWIDTH DIGIT THREE} { unicode::normalize D 65299 } {65299} test unicode-1.84 {normalize D: FULLWIDTH DIGIT THREE} { unicode::normalize D 51 } {51} test unicode-1.85 {normalize D: FULLWIDTH DIGIT THREE} { unicode::normalize D 51 } {51} test unicode-1.86 {normalizeS D: LATIN SMALL LETTER A, COMBINING CYRILLIC TITLO, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B} { unicode::normalizeS D "\u0061\u0483\u0315\u0300\u05AE\u0062" } "\u0061\u05AE\u0483\u0300\u0315\u0062" test unicode-1.87 {normalize D: LATIN SMALL LETTER A, COMBINING CYRILLIC TITLO, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B} { unicode::normalize D {97 1454 1155 768 789 98} } {97 1454 1155 768 789 98} test unicode-1.88 {normalize D: LATIN SMALL LETTER A, COMBINING CYRILLIC TITLO, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B} { unicode::normalize D {97 1454 1155 768 789 98} } {97 1454 1155 768 789 98} test unicode-1.89 {normalize D: LATIN SMALL LETTER A, COMBINING CYRILLIC TITLO, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B} { unicode::normalize D {97 1454 1155 768 789 98} } {97 1454 1155 768 789 98} test unicode-1.90 {normalize D: LATIN SMALL LETTER A, COMBINING CYRILLIC TITLO, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B} { unicode::normalize D {97 1454 1155 768 789 98} } {97 1454 1155 768 789 98} test unicode-1.91 {normalizeS D: LATIN SMALL LETTER A, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, COMBINING RING OVERLAY, LATIN SMALL LETTER B} { unicode::normalizeS D "\u0061\u093C\u0334\u20D8\u0062" } "\u0061\u0334\u20D8\u093C\u0062" test unicode-1.92 {normalize D: LATIN SMALL LETTER A, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, COMBINING RING OVERLAY, LATIN SMALL LETTER B} { unicode::normalize D {97 820 8408 2364 98} } {97 820 8408 2364 98} test unicode-1.93 {normalize D: LATIN SMALL LETTER A, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, COMBINING RING OVERLAY, LATIN SMALL LETTER B} { unicode::normalize D {97 820 8408 2364 98} } {97 820 8408 2364 98} test unicode-1.94 {normalize D: LATIN SMALL LETTER A, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, COMBINING RING OVERLAY, LATIN SMALL LETTER B} { unicode::normalize D {97 820 8408 2364 98} } {97 820 8408 2364 98} test unicode-1.95 {normalize D: LATIN SMALL LETTER A, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, COMBINING RING OVERLAY, LATIN SMALL LETTER B} { unicode::normalize D {97 820 8408 2364 98} } {97 820 8408 2364 98} test unicode-1.96 {normalizeS D: HANGUL SYLLABLE BYO, COMBINING TILDE OVERLAY, HANGUL JONGSEONG TIKEUT} { unicode::normalizeS D "\uBD64\u0334\u11AE" } "\u1107\u116D\u0334\u11AE" test unicode-1.97 {normalize D: HANGUL SYLLABLE BYO, COMBINING TILDE OVERLAY, HANGUL JONGSEONG TIKEUT} { unicode::normalize D {48484 820 4526} } {4359 4461 820 4526} test unicode-1.98 {normalize D: HANGUL SYLLABLE BYO, COMBINING TILDE OVERLAY, HANGUL JONGSEONG TIKEUT} { unicode::normalize D {4359 4461 820 4526} } {4359 4461 820 4526} test unicode-1.99 {normalize D: HANGUL SYLLABLE BYO, COMBINING TILDE OVERLAY, HANGUL JONGSEONG TIKEUT} { unicode::normalize D {48484 820 4526} } {4359 4461 820 4526} test unicode-1.100 {normalize D: HANGUL SYLLABLE BYO, COMBINING TILDE OVERLAY, HANGUL JONGSEONG TIKEUT} { unicode::normalize D {4359 4461 820 4526} } {4359 4461 820 4526} test unicode-2.1 {normalize C: LATIN CAPITAL LETTER D, COMBINING DOT ABOVE, COMBINING DOT BELOW} { unicode::normalize C {68 775 803} } {7692 775} test unicode-2.2 {normalizeS C: LATIN CAPITAL LETTER D, COMBINING DOT ABOVE, COMBINING DOT BELOW} { unicode::normalizeS C "\u1E0C\u0307" } "\u1E0C\u0307" test unicode-2.3 {normalize C: LATIN CAPITAL LETTER D, COMBINING DOT ABOVE, COMBINING DOT BELOW} { unicode::normalize C {68 803 775} } {7692 775} test unicode-2.4 {normalize C: LATIN CAPITAL LETTER D, COMBINING DOT ABOVE, COMBINING DOT BELOW} { unicode::normalize C {7692 775} } {7692 775} test unicode-2.5 {normalize C: LATIN CAPITAL LETTER D, COMBINING DOT ABOVE, COMBINING DOT BELOW} { unicode::normalize C {68 803 775} } {7692 775} test unicode-2.6 {normalize C: NO-BREAK SPACE} { unicode::normalize C 160 } {160} test unicode-2.7 {normalizeS C: NO-BREAK SPACE} { unicode::normalizeS C "\u00A0" } "\u00A0" test unicode-2.8 {normalize C: NO-BREAK SPACE} { unicode::normalize C 160 } {160} test unicode-2.9 {normalize C: NO-BREAK SPACE} { unicode::normalize C 32 } {32} test unicode-2.10 {normalize C: NO-BREAK SPACE} { unicode::normalize C 32 } {32} test unicode-2.11 {normalize C: VULGAR FRACTION ONE HALF} { unicode::normalize C 189 } {189} test unicode-2.12 {normalizeS C: VULGAR FRACTION ONE HALF} { unicode::normalizeS C "\u00BD" } "\u00BD" test unicode-2.13 {normalize C: VULGAR FRACTION ONE HALF} { unicode::normalize C 189 } {189} test unicode-2.14 {normalize C: VULGAR FRACTION ONE HALF} { unicode::normalize C {49 8260 50} } {49 8260 50} test unicode-2.15 {normalize C: VULGAR FRACTION ONE HALF} { unicode::normalize C {49 8260 50} } {49 8260 50} test unicode-2.16 {normalize C: ORIYA LETTER RRA} { unicode::normalize C 2908 } {2849 2876} test unicode-2.17 {normalizeS C: ORIYA LETTER RRA} { unicode::normalizeS C "\u0B21\u0B3C" } "\u0B21\u0B3C" test unicode-2.18 {normalize C: ORIYA LETTER RRA} { unicode::normalize C {2849 2876} } {2849 2876} test unicode-2.19 {normalize C: ORIYA LETTER RRA} { unicode::normalize C {2849 2876} } {2849 2876} test unicode-2.20 {normalize C: ORIYA LETTER RRA} { unicode::normalize C {2849 2876} } {2849 2876} test unicode-2.21 {normalize C: KANNADA VOWEL SIGN EE} { unicode::normalize C 3271 } {3271} test unicode-2.22 {normalizeS C: KANNADA VOWEL SIGN EE} { unicode::normalizeS C "\u0CC7" } "\u0CC7" test unicode-2.23 {normalize C: KANNADA VOWEL SIGN EE} { unicode::normalize C {3270 3285} } {3271} test unicode-2.24 {normalize C: KANNADA VOWEL SIGN EE} { unicode::normalize C 3271 } {3271} test unicode-2.25 {normalize C: KANNADA VOWEL SIGN EE} { unicode::normalize C {3270 3285} } {3271} test unicode-2.26 {normalize C: TIBETAN LETTER GHA} { unicode::normalize C 3907 } {3906 4023} test unicode-2.27 {normalizeS C: TIBETAN LETTER GHA} { unicode::normalizeS C "\u0F42\u0FB7" } "\u0F42\u0FB7" test unicode-2.28 {normalize C: TIBETAN LETTER GHA} { unicode::normalize C {3906 4023} } {3906 4023} test unicode-2.29 {normalize C: TIBETAN LETTER GHA} { unicode::normalize C {3906 4023} } {3906 4023} test unicode-2.30 {normalize C: TIBETAN LETTER GHA} { unicode::normalize C {3906 4023} } {3906 4023} test unicode-2.31 {normalize C: MODIFIER LETTER CAPITAL A} { unicode::normalize C 7468 } {7468} test unicode-2.32 {normalizeS C: MODIFIER LETTER CAPITAL A} { unicode::normalizeS C "\u1D2C" } "\u1D2C" test unicode-2.33 {normalize C: MODIFIER LETTER CAPITAL A} { unicode::normalize C 7468 } {7468} test unicode-2.34 {normalize C: MODIFIER LETTER CAPITAL A} { unicode::normalize C 65 } {65} test unicode-2.35 {normalize C: MODIFIER LETTER CAPITAL A} { unicode::normalize C 65 } {65} test unicode-2.36 {normalize C: GREEK SMALL LETTER EPSILON WITH PSILI AND OXIA} { unicode::normalize C 7956 } {7956} test unicode-2.37 {normalizeS C: GREEK SMALL LETTER EPSILON WITH PSILI AND OXIA} { unicode::normalizeS C "\u1F14" } "\u1F14" test unicode-2.38 {normalize C: GREEK SMALL LETTER EPSILON WITH PSILI AND OXIA} { unicode::normalize C {949 787 769} } {7956} test unicode-2.39 {normalize C: GREEK SMALL LETTER EPSILON WITH PSILI AND OXIA} { unicode::normalize C 7956 } {7956} test unicode-2.40 {normalize C: GREEK SMALL LETTER EPSILON WITH PSILI AND OXIA} { unicode::normalize C {949 787 769} } {7956} test unicode-2.41 {normalize C: KANGXI RADICAL SPROUT} { unicode::normalize C 12076 } {12076} test unicode-2.42 {normalizeS C: KANGXI RADICAL SPROUT} { unicode::normalizeS C "\u2F2C" } "\u2F2C" test unicode-2.43 {normalize C: KANGXI RADICAL SPROUT} { unicode::normalize C 12076 } {12076} test unicode-2.44 {normalize C: KANGXI RADICAL SPROUT} { unicode::normalize C 23662 } {23662} test unicode-2.45 {normalize C: KANGXI RADICAL SPROUT} { unicode::normalize C 23662 } {23662} test unicode-2.46 {normalize C: HIRAGANA LETTER DE} { unicode::normalize C 12391 } {12391} test unicode-2.47 {normalizeS C: HIRAGANA LETTER DE} { unicode::normalizeS C "\u3067" } "\u3067" test unicode-2.48 {normalize C: HIRAGANA LETTER DE} { unicode::normalize C {12390 12441} } {12391} test unicode-2.49 {normalize C: HIRAGANA LETTER DE} { unicode::normalize C 12391 } {12391} test unicode-2.50 {normalize C: HIRAGANA LETTER DE} { unicode::normalize C {12390 12441} } {12391} test unicode-2.51 {normalize C: KATAKANA LETTER PA} { unicode::normalize C 12497 } {12497} test unicode-2.52 {normalizeS C: KATAKANA LETTER PA} { unicode::normalizeS C "\u30D1" } "\u30D1" test unicode-2.53 {normalize C: KATAKANA LETTER PA} { unicode::normalize C {12495 12442} } {12497} test unicode-2.54 {normalize C: KATAKANA LETTER PA} { unicode::normalize C 12497 } {12497} test unicode-2.55 {normalize C: KATAKANA LETTER PA} { unicode::normalize C {12495 12442} } {12497} test unicode-2.56 {normalize C: HANGUL LETTER SIOS-PIEUP} { unicode::normalize C 12669 } {12669} test unicode-2.57 {normalizeS C: HANGUL LETTER SIOS-PIEUP} { unicode::normalizeS C "\u317D" } "\u317D" test unicode-2.58 {normalize C: HANGUL LETTER SIOS-PIEUP} { unicode::normalize C 12669 } {12669} test unicode-2.59 {normalize C: HANGUL LETTER SIOS-PIEUP} { unicode::normalize C 4402 } {4402} test unicode-2.60 {normalize C: HANGUL LETTER SIOS-PIEUP} { unicode::normalize C 4402 } {4402} test unicode-2.61 {normalize C: HANGUL SYLLABLE GYANG} { unicode::normalize C 44109 } {44109} test unicode-2.62 {normalizeS C: HANGUL SYLLABLE GYANG} { unicode::normalizeS C "\uAC4D" } "\uAC4D" test unicode-2.63 {normalize C: HANGUL SYLLABLE GYANG} { unicode::normalize C {4352 4451 4540} } {44109} test unicode-2.64 {normalize C: HANGUL SYLLABLE GYANG} { unicode::normalize C 44109 } {44109} test unicode-2.65 {normalize C: HANGUL SYLLABLE GYANG} { unicode::normalize C {4352 4451 4540} } {44109} test unicode-2.66 {normalize C: CJK COMPATIBILITY IDEOGRAPH-F98E} { unicode::normalize C 63886 } {24180} test unicode-2.67 {normalizeS C: CJK COMPATIBILITY IDEOGRAPH-F98E} { unicode::normalizeS C "\u5E74" } "\u5E74" test unicode-2.68 {normalize C: CJK COMPATIBILITY IDEOGRAPH-F98E} { unicode::normalize C 24180 } {24180} test unicode-2.69 {normalize C: CJK COMPATIBILITY IDEOGRAPH-F98E} { unicode::normalize C 24180 } {24180} test unicode-2.70 {normalize C: CJK COMPATIBILITY IDEOGRAPH-F98E} { unicode::normalize C 24180 } {24180} test unicode-2.71 {normalize C: ARABIC LETTER HEH DOACHASHMEE ISOLATED FORM} { unicode::normalize C 64426 } {64426} test unicode-2.72 {normalizeS C: ARABIC LETTER HEH DOACHASHMEE ISOLATED FORM} { unicode::normalizeS C "\uFBAA" } "\uFBAA" test unicode-2.73 {normalize C: ARABIC LETTER HEH DOACHASHMEE ISOLATED FORM} { unicode::normalize C 64426 } {64426} test unicode-2.74 {normalize C: ARABIC LETTER HEH DOACHASHMEE ISOLATED FORM} { unicode::normalize C 1726 } {1726} test unicode-2.75 {normalize C: ARABIC LETTER HEH DOACHASHMEE ISOLATED FORM} { unicode::normalize C 1726 } {1726} test unicode-2.76 {normalize C: ARABIC LIGATURE AIN WITH JEEM ISOLATED FORM} { unicode::normalize C 64553 } {64553} test unicode-2.77 {normalizeS C: ARABIC LIGATURE AIN WITH JEEM ISOLATED FORM} { unicode::normalizeS C "\uFC29" } "\uFC29" test unicode-2.78 {normalize C: ARABIC LIGATURE AIN WITH JEEM ISOLATED FORM} { unicode::normalize C 64553 } {64553} test unicode-2.79 {normalize C: ARABIC LIGATURE AIN WITH JEEM ISOLATED FORM} { unicode::normalize C {1593 1580} } {1593 1580} test unicode-2.80 {normalize C: ARABIC LIGATURE AIN WITH JEEM ISOLATED FORM} { unicode::normalize C {1593 1580} } {1593 1580} test unicode-2.81 {normalize C: FULLWIDTH DIGIT THREE} { unicode::normalize C 65299 } {65299} test unicode-2.82 {normalizeS C: FULLWIDTH DIGIT THREE} { unicode::normalizeS C "\uFF13" } "\uFF13" test unicode-2.83 {normalize C: FULLWIDTH DIGIT THREE} { unicode::normalize C 65299 } {65299} test unicode-2.84 {normalize C: FULLWIDTH DIGIT THREE} { unicode::normalize C 51 } {51} test unicode-2.85 {normalize C: FULLWIDTH DIGIT THREE} { unicode::normalize C 51 } {51} test unicode-2.86 {normalize C: LATIN SMALL LETTER A, COMBINING CYRILLIC TITLO, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B} { unicode::normalize C {97 1155 789 768 1454 98} } {97 1454 1155 768 789 98} test unicode-2.87 {normalizeS C: LATIN SMALL LETTER A, COMBINING CYRILLIC TITLO, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B} { unicode::normalizeS C "\u0061\u05AE\u0483\u0300\u0315\u0062" } "\u0061\u05AE\u0483\u0300\u0315\u0062" test unicode-2.88 {normalize C: LATIN SMALL LETTER A, COMBINING CYRILLIC TITLO, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B} { unicode::normalize C {97 1454 1155 768 789 98} } {97 1454 1155 768 789 98} test unicode-2.89 {normalize C: LATIN SMALL LETTER A, COMBINING CYRILLIC TITLO, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B} { unicode::normalize C {97 1454 1155 768 789 98} } {97 1454 1155 768 789 98} test unicode-2.90 {normalize C: LATIN SMALL LETTER A, COMBINING CYRILLIC TITLO, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B} { unicode::normalize C {97 1454 1155 768 789 98} } {97 1454 1155 768 789 98} test unicode-2.91 {normalize C: LATIN SMALL LETTER A, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, COMBINING RING OVERLAY, LATIN SMALL LETTER B} { unicode::normalize C {97 2364 820 8408 98} } {97 820 8408 2364 98} test unicode-2.92 {normalizeS C: LATIN SMALL LETTER A, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, COMBINING RING OVERLAY, LATIN SMALL LETTER B} { unicode::normalizeS C "\u0061\u0334\u20D8\u093C\u0062" } "\u0061\u0334\u20D8\u093C\u0062" test unicode-2.93 {normalize C: LATIN SMALL LETTER A, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, COMBINING RING OVERLAY, LATIN SMALL LETTER B} { unicode::normalize C {97 820 8408 2364 98} } {97 820 8408 2364 98} test unicode-2.94 {normalize C: LATIN SMALL LETTER A, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, COMBINING RING OVERLAY, LATIN SMALL LETTER B} { unicode::normalize C {97 820 8408 2364 98} } {97 820 8408 2364 98} test unicode-2.95 {normalize C: LATIN SMALL LETTER A, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, COMBINING RING OVERLAY, LATIN SMALL LETTER B} { unicode::normalize C {97 820 8408 2364 98} } {97 820 8408 2364 98} test unicode-2.96 {normalize C: HANGUL SYLLABLE BYO, COMBINING TILDE OVERLAY, HANGUL JONGSEONG TIKEUT} { unicode::normalize C {48484 820 4526} } {48484 820 4526} test unicode-2.97 {normalizeS C: HANGUL SYLLABLE BYO, COMBINING TILDE OVERLAY, HANGUL JONGSEONG TIKEUT} { unicode::normalizeS C "\uBD64\u0334\u11AE" } "\uBD64\u0334\u11AE" test unicode-2.98 {normalize C: HANGUL SYLLABLE BYO, COMBINING TILDE OVERLAY, HANGUL JONGSEONG TIKEUT} { unicode::normalize C {4359 4461 820 4526} } {48484 820 4526} test unicode-2.99 {normalize C: HANGUL SYLLABLE BYO, COMBINING TILDE OVERLAY, HANGUL JONGSEONG TIKEUT} { unicode::normalize C {48484 820 4526} } {48484 820 4526} test unicode-2.100 {normalize C: HANGUL SYLLABLE BYO, COMBINING TILDE OVERLAY, HANGUL JONGSEONG TIKEUT} { unicode::normalize C {4359 4461 820 4526} } {48484 820 4526} test unicode-3.1 {normalize KD: LATIN CAPITAL LETTER D, COMBINING DOT ABOVE, COMBINING DOT BELOW} { unicode::normalize KD {68 775 803} } {68 803 775} test unicode-3.2 {normalize KD: LATIN CAPITAL LETTER D, COMBINING DOT ABOVE, COMBINING DOT BELOW} { unicode::normalize KD {7692 775} } {68 803 775} test unicode-3.3 {normalizeS KD: LATIN CAPITAL LETTER D, COMBINING DOT ABOVE, COMBINING DOT BELOW} { unicode::normalizeS KD "\u0044\u0323\u0307" } "\u0044\u0323\u0307" test unicode-3.4 {normalize KD: LATIN CAPITAL LETTER D, COMBINING DOT ABOVE, COMBINING DOT BELOW} { unicode::normalize KD {7692 775} } {68 803 775} test unicode-1.5 {normalize KD: LATIN CAPITAL LETTER D, COMBINING DOT ABOVE, COMBINING DOT BELOW} { unicode::normalize KD {68 803 775} } {68 803 775} test unicode-3.6 {normalize KD: NO-BREAK SPACE} { unicode::normalize KD 160 } {32} test unicode-3.7 {normalize KD: NO-BREAK SPACE} { unicode::normalize KD 160 } {32} test unicode-3.8 {normalizeS KD: NO-BREAK SPACE} { unicode::normalizeS KD "\u00A0" } "\u0020" test unicode-3.9 {normalize KD: NO-BREAK SPACE} { unicode::normalize KD 32 } {32} test unicode-1.10 {normalize KD: NO-BREAK SPACE} { unicode::normalize KD 32 } {32} test unicode-3.11 {normalize KD: VULGAR FRACTION ONE HALF} { unicode::normalize KD 189 } {49 8260 50} test unicode-3.12 {normalize KD: VULGAR FRACTION ONE HALF} { unicode::normalize KD 189 } {49 8260 50} test unicode-3.13 {normalizeS KD: VULGAR FRACTION ONE HALF} { unicode::normalizeS KD "\u00BD" } "\u0031\u2044\u0032" test unicode-3.14 {normalize KD: VULGAR FRACTION ONE HALF} { unicode::normalize KD {49 8260 50} } {49 8260 50} test unicode-1.15 {normalize KD: VULGAR FRACTION ONE HALF} { unicode::normalize KD {49 8260 50} } {49 8260 50} test unicode-3.16 {normalize KD: ORIYA LETTER RRA} { unicode::normalize KD 2908 } {2849 2876} test unicode-3.17 {normalize KD: ORIYA LETTER RRA} { unicode::normalize KD {2849 2876} } {2849 2876} test unicode-3.18 {normalizeS KD: ORIYA LETTER RRA} { unicode::normalizeS KD "\u0B21\u0B3C" } "\u0B21\u0B3C" test unicode-3.19 {normalize KD: ORIYA LETTER RRA} { unicode::normalize KD {2849 2876} } {2849 2876} test unicode-1.20 {normalize KD: ORIYA LETTER RRA} { unicode::normalize KD {2849 2876} } {2849 2876} test unicode-3.21 {normalize KD: KANNADA VOWEL SIGN EE} { unicode::normalize KD 3271 } {3270 3285} test unicode-3.22 {normalize KD: KANNADA VOWEL SIGN EE} { unicode::normalize KD 3271 } {3270 3285} test unicode-3.23 {normalizeS KD: KANNADA VOWEL SIGN EE} { unicode::normalizeS KD "\u0CC6\u0CD5" } "\u0CC6\u0CD5" test unicode-3.24 {normalize KD: KANNADA VOWEL SIGN EE} { unicode::normalize KD 3271 } {3270 3285} test unicode-1.25 {normalize KD: KANNADA VOWEL SIGN EE} { unicode::normalize KD {3270 3285} } {3270 3285} test unicode-3.26 {normalize KD: TIBETAN LETTER GHA} { unicode::normalize KD 3907 } {3906 4023} test unicode-3.27 {normalize KD: TIBETAN LETTER GHA} { unicode::normalize KD {3906 4023} } {3906 4023} test unicode-3.28 {normalizeS KD: TIBETAN LETTER GHA} { unicode::normalizeS KD "\u0F42\u0FB7" } "\u0F42\u0FB7" test unicode-3.29 {normalize KD: TIBETAN LETTER GHA} { unicode::normalize KD {3906 4023} } {3906 4023} test unicode-1.30 {normalize KD: TIBETAN LETTER GHA} { unicode::normalize KD {3906 4023} } {3906 4023} test unicode-3.31 {normalize KD: MODIFIER LETTER CAPITAL A} { unicode::normalize KD 7468 } {65} test unicode-3.32 {normalize KD: MODIFIER LETTER CAPITAL A} { unicode::normalize KD 7468 } {65} test unicode-3.33 {normalizeS KD: MODIFIER LETTER CAPITAL A} { unicode::normalizeS KD "\u1D2C" } "\u0041" test unicode-3.34 {normalize KD: MODIFIER LETTER CAPITAL A} { unicode::normalize KD 65 } {65} test unicode-1.35 {normalize KD: MODIFIER LETTER CAPITAL A} { unicode::normalize KD 65 } {65} test unicode-3.36 {normalize KD: GREEK SMALL LETTER EPSILON WITH PSILI AND OXIA} { unicode::normalize KD 7956 } {949 787 769} test unicode-3.37 {normalize KD: GREEK SMALL LETTER EPSILON WITH PSILI AND OXIA} { unicode::normalize KD 7956 } {949 787 769} test unicode-3.38 {normalizeS KD: GREEK SMALL LETTER EPSILON WITH PSILI AND OXIA} { unicode::normalizeS KD "\u03B5\u0313\u0301" } "\u03B5\u0313\u0301" test unicode-3.39 {normalize KD: GREEK SMALL LETTER EPSILON WITH PSILI AND OXIA} { unicode::normalize KD 7956 } {949 787 769} test unicode-1.40 {normalize KD: GREEK SMALL LETTER EPSILON WITH PSILI AND OXIA} { unicode::normalize KD {949 787 769} } {949 787 769} test unicode-3.41 {normalize KD: KANGXI RADICAL SPROUT} { unicode::normalize KD 12076 } {23662} test unicode-3.42 {normalize KD: KANGXI RADICAL SPROUT} { unicode::normalize KD 12076 } {23662} test unicode-3.43 {normalizeS KD: KANGXI RADICAL SPROUT} { unicode::normalizeS KD "\u2F2C" } "\u5C6E" test unicode-3.44 {normalize KD: KANGXI RADICAL SPROUT} { unicode::normalize KD 23662 } {23662} test unicode-1.45 {normalize KD: KANGXI RADICAL SPROUT} { unicode::normalize KD 23662 } {23662} test unicode-3.46 {normalize KD: HIRAGANA LETTER DE} { unicode::normalize KD 12391 } {12390 12441} test unicode-3.47 {normalize KD: HIRAGANA LETTER DE} { unicode::normalize KD 12391 } {12390 12441} test unicode-3.48 {normalizeS KD: HIRAGANA LETTER DE} { unicode::normalizeS KD "\u3066\u3099" } "\u3066\u3099" test unicode-3.49 {normalize KD: HIRAGANA LETTER DE} { unicode::normalize KD 12391 } {12390 12441} test unicode-1.50 {normalize KD: HIRAGANA LETTER DE} { unicode::normalize KD {12390 12441} } {12390 12441} test unicode-3.51 {normalize KD: KATAKANA LETTER PA} { unicode::normalize KD 12497 } {12495 12442} test unicode-3.52 {normalize KD: KATAKANA LETTER PA} { unicode::normalize KD 12497 } {12495 12442} test unicode-3.53 {normalizeS KD: KATAKANA LETTER PA} { unicode::normalizeS KD "\u30CF\u309A" } "\u30CF\u309A" test unicode-3.54 {normalize KD: KATAKANA LETTER PA} { unicode::normalize KD 12497 } {12495 12442} test unicode-1.55 {normalize KD: KATAKANA LETTER PA} { unicode::normalize KD {12495 12442} } {12495 12442} test unicode-3.56 {normalize KD: HANGUL LETTER SIOS-PIEUP} { unicode::normalize KD 12669 } {4402} test unicode-3.57 {normalize KD: HANGUL LETTER SIOS-PIEUP} { unicode::normalize KD 12669 } {4402} test unicode-3.58 {normalizeS KD: HANGUL LETTER SIOS-PIEUP} { unicode::normalizeS KD "\u317D" } "\u1132" test unicode-3.59 {normalize KD: HANGUL LETTER SIOS-PIEUP} { unicode::normalize KD 4402 } {4402} test unicode-1.60 {normalize KD: HANGUL LETTER SIOS-PIEUP} { unicode::normalize KD 4402 } {4402} test unicode-3.61 {normalize KD: HANGUL SYLLABLE GYANG} { unicode::normalize KD 44109 } {4352 4451 4540} test unicode-3.62 {normalize KD: HANGUL SYLLABLE GYANG} { unicode::normalize KD 44109 } {4352 4451 4540} test unicode-3.63 {normalizeS KD: HANGUL SYLLABLE GYANG} { unicode::normalizeS KD "\u1100\u1163\u11BC" } "\u1100\u1163\u11BC" test unicode-3.64 {normalize KD: HANGUL SYLLABLE GYANG} { unicode::normalize KD 44109 } {4352 4451 4540} test unicode-1.65 {normalize KD: HANGUL SYLLABLE GYANG} { unicode::normalize KD {4352 4451 4540} } {4352 4451 4540} test unicode-3.66 {normalize KD: CJK COMPATIBILITY IDEOGRAPH-F98E} { unicode::normalize KD 63886 } {24180} test unicode-3.67 {normalize KD: CJK COMPATIBILITY IDEOGRAPH-F98E} { unicode::normalize KD 24180 } {24180} test unicode-3.68 {normalizeS KD: CJK COMPATIBILITY IDEOGRAPH-F98E} { unicode::normalizeS KD "\u5E74" } "\u5E74" test unicode-3.69 {normalize KD: CJK COMPATIBILITY IDEOGRAPH-F98E} { unicode::normalize KD 24180 } {24180} test unicode-1.70 {normalize KD: CJK COMPATIBILITY IDEOGRAPH-F98E} { unicode::normalize KD 24180 } {24180} test unicode-3.71 {normalize KD: ARABIC LETTER HEH DOACHASHMEE ISOLATED FORM} { unicode::normalize KD 64426 } {1726} test unicode-3.72 {normalize KD: ARABIC LETTER HEH DOACHASHMEE ISOLATED FORM} { unicode::normalize KD 64426 } {1726} test unicode-3.73 {normalizeS KD: ARABIC LETTER HEH DOACHASHMEE ISOLATED FORM} { unicode::normalizeS KD "\uFBAA" } "\u06BE" test unicode-3.74 {normalize KD: ARABIC LETTER HEH DOACHASHMEE ISOLATED FORM} { unicode::normalize KD 1726 } {1726} test unicode-1.75 {normalize KD: ARABIC LETTER HEH DOACHASHMEE ISOLATED FORM} { unicode::normalize KD 1726 } {1726} test unicode-3.76 {normalize KD: ARABIC LIGATURE AIN WITH JEEM ISOLATED FORM} { unicode::normalize KD 64553 } {1593 1580} test unicode-3.77 {normalize KD: ARABIC LIGATURE AIN WITH JEEM ISOLATED FORM} { unicode::normalize KD 64553 } {1593 1580} test unicode-3.78 {normalizeS KD: ARABIC LIGATURE AIN WITH JEEM ISOLATED FORM} { unicode::normalizeS KD "\uFC29" } "\u0639\u062C" test unicode-3.79 {normalize KD: ARABIC LIGATURE AIN WITH JEEM ISOLATED FORM} { unicode::normalize KD {1593 1580} } {1593 1580} test unicode-1.80 {normalize KD: ARABIC LIGATURE AIN WITH JEEM ISOLATED FORM} { unicode::normalize KD {1593 1580} } {1593 1580} test unicode-3.81 {normalize KD: FULLWIDTH DIGIT THREE} { unicode::normalize KD 65299 } {51} test unicode-3.82 {normalize KD: FULLWIDTH DIGIT THREE} { unicode::normalize KD 65299 } {51} test unicode-3.83 {normalizeS KD: FULLWIDTH DIGIT THREE} { unicode::normalizeS KD "\uFF13" } "\u0033" test unicode-3.84 {normalize KD: FULLWIDTH DIGIT THREE} { unicode::normalize KD 51 } {51} test unicode-1.85 {normalize KD: FULLWIDTH DIGIT THREE} { unicode::normalize KD 51 } {51} test unicode-3.86 {normalize KD: LATIN SMALL LETTER A, COMBINING CYRILLIC TITLO, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B} { unicode::normalize KD {97 1155 789 768 1454 98} } {97 1454 1155 768 789 98} test unicode-3.87 {normalize KD: LATIN SMALL LETTER A, COMBINING CYRILLIC TITLO, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B} { unicode::normalize KD {97 1454 1155 768 789 98} } {97 1454 1155 768 789 98} test unicode-3.88 {normalizeS KD: LATIN SMALL LETTER A, COMBINING CYRILLIC TITLO, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B} { unicode::normalizeS KD "\u0061\u05AE\u0483\u0300\u0315\u0062" } "\u0061\u05AE\u0483\u0300\u0315\u0062" test unicode-3.89 {normalize KD: LATIN SMALL LETTER A, COMBINING CYRILLIC TITLO, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B} { unicode::normalize KD {97 1454 1155 768 789 98} } {97 1454 1155 768 789 98} test unicode-1.90 {normalize KD: LATIN SMALL LETTER A, COMBINING CYRILLIC TITLO, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B} { unicode::normalize KD {97 1454 1155 768 789 98} } {97 1454 1155 768 789 98} test unicode-3.91 {normalize KD: LATIN SMALL LETTER A, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, COMBINING RING OVERLAY, LATIN SMALL LETTER B} { unicode::normalize KD {97 2364 820 8408 98} } {97 820 8408 2364 98} test unicode-3.92 {normalize KD: LATIN SMALL LETTER A, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, COMBINING RING OVERLAY, LATIN SMALL LETTER B} { unicode::normalize KD {97 820 8408 2364 98} } {97 820 8408 2364 98} test unicode-3.93 {normalizeS KD: LATIN SMALL LETTER A, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, COMBINING RING OVERLAY, LATIN SMALL LETTER B} { unicode::normalizeS KD "\u0061\u0334\u20D8\u093C\u0062" } "\u0061\u0334\u20D8\u093C\u0062" test unicode-3.94 {normalize KD: LATIN SMALL LETTER A, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, COMBINING RING OVERLAY, LATIN SMALL LETTER B} { unicode::normalize KD {97 820 8408 2364 98} } {97 820 8408 2364 98} test unicode-1.95 {normalize KD: LATIN SMALL LETTER A, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, COMBINING RING OVERLAY, LATIN SMALL LETTER B} { unicode::normalize KD {97 820 8408 2364 98} } {97 820 8408 2364 98} test unicode-3.96 {normalize KD: HANGUL SYLLABLE BYO, COMBINING TILDE OVERLAY, HANGUL JONGSEONG TIKEUT} { unicode::normalize KD {48484 820 4526} } {4359 4461 820 4526} test unicode-3.97 {normalize KD: HANGUL SYLLABLE BYO, COMBINING TILDE OVERLAY, HANGUL JONGSEONG TIKEUT} { unicode::normalize KD {48484 820 4526} } {4359 4461 820 4526} test unicode-3.98 {normalizeS KD: HANGUL SYLLABLE BYO, COMBINING TILDE OVERLAY, HANGUL JONGSEONG TIKEUT} { unicode::normalizeS KD "\u1107\u116D\u0334\u11AE" } "\u1107\u116D\u0334\u11AE" test unicode-3.99 {normalize KD: HANGUL SYLLABLE BYO, COMBINING TILDE OVERLAY, HANGUL JONGSEONG TIKEUT} { unicode::normalize KD {48484 820 4526} } {4359 4461 820 4526} test unicode-1.100 {normalize KD: HANGUL SYLLABLE BYO, COMBINING TILDE OVERLAY, HANGUL JONGSEONG TIKEUT} { unicode::normalize KD {4359 4461 820 4526} } {4359 4461 820 4526} test unicode-4.1 {normalize KC: LATIN CAPITAL LETTER D, COMBINING DOT ABOVE, COMBINING DOT BELOW} { unicode::normalize KC {68 775 803} } {7692 775} test unicode-4.2 {normalize KC: LATIN CAPITAL LETTER D, COMBINING DOT ABOVE, COMBINING DOT BELOW} { unicode::normalize KC {7692 775} } {7692 775} test unicode-4.3 {normalize KC: LATIN CAPITAL LETTER D, COMBINING DOT ABOVE, COMBINING DOT BELOW} { unicode::normalize KC {68 803 775} } {7692 775} test unicode-4.4 {normalizeS KC: LATIN CAPITAL LETTER D, COMBINING DOT ABOVE, COMBINING DOT BELOW} { unicode::normalizeS KC "\u1E0C\u0307" } "\u1E0C\u0307" test unicode-4.5 {normalize KC: LATIN CAPITAL LETTER D, COMBINING DOT ABOVE, COMBINING DOT BELOW} { unicode::normalize KC {68 803 775} } {7692 775} test unicode-4.6 {normalize KC: NO-BREAK SPACE} { unicode::normalize KC 160 } {32} test unicode-4.7 {normalize KC: NO-BREAK SPACE} { unicode::normalize KC 160 } {32} test unicode-4.8 {normalize KC: NO-BREAK SPACE} { unicode::normalize KC 160 } {32} test unicode-4.9 {normalizeS KC: NO-BREAK SPACE} { unicode::normalizeS KC "\u0020" } "\u0020" test unicode-4.10 {normalize KC: NO-BREAK SPACE} { unicode::normalize KC 32 } {32} test unicode-4.11 {normalize KC: VULGAR FRACTION ONE HALF} { unicode::normalize KC 189 } {49 8260 50} test unicode-4.12 {normalize KC: VULGAR FRACTION ONE HALF} { unicode::normalize KC 189 } {49 8260 50} test unicode-4.13 {normalize KC: VULGAR FRACTION ONE HALF} { unicode::normalize KC 189 } {49 8260 50} test unicode-4.14 {normalizeS KC: VULGAR FRACTION ONE HALF} { unicode::normalizeS KC "\u0031\u2044\u0032" } "\u0031\u2044\u0032" test unicode-4.15 {normalize KC: VULGAR FRACTION ONE HALF} { unicode::normalize KC {49 8260 50} } {49 8260 50} test unicode-4.16 {normalize KC: ORIYA LETTER RRA} { unicode::normalize KC 2908 } {2849 2876} test unicode-4.17 {normalize KC: ORIYA LETTER RRA} { unicode::normalize KC {2849 2876} } {2849 2876} test unicode-4.18 {normalize KC: ORIYA LETTER RRA} { unicode::normalize KC {2849 2876} } {2849 2876} test unicode-4.19 {normalizeS KC: ORIYA LETTER RRA} { unicode::normalizeS KC "\u0B21\u0B3C" } "\u0B21\u0B3C" test unicode-4.20 {normalize KC: ORIYA LETTER RRA} { unicode::normalize KC {2849 2876} } {2849 2876} test unicode-4.21 {normalize KC: KANNADA VOWEL SIGN EE} { unicode::normalize KC 3271 } {3271} test unicode-4.22 {normalize KC: KANNADA VOWEL SIGN EE} { unicode::normalize KC 3271 } {3271} test unicode-4.23 {normalize KC: KANNADA VOWEL SIGN EE} { unicode::normalize KC {3270 3285} } {3271} test unicode-4.24 {normalizeS KC: KANNADA VOWEL SIGN EE} { unicode::normalizeS KC "\u0CC7" } "\u0CC7" test unicode-4.25 {normalize KC: KANNADA VOWEL SIGN EE} { unicode::normalize KC {3270 3285} } {3271} test unicode-4.26 {normalize KC: TIBETAN LETTER GHA} { unicode::normalize KC 3907 } {3906 4023} test unicode-4.27 {normalize KC: TIBETAN LETTER GHA} { unicode::normalize KC {3906 4023} } {3906 4023} test unicode-4.28 {normalize KC: TIBETAN LETTER GHA} { unicode::normalize KC {3906 4023} } {3906 4023} test unicode-4.29 {normalizeS KC: TIBETAN LETTER GHA} { unicode::normalizeS KC "\u0F42\u0FB7" } "\u0F42\u0FB7" test unicode-4.30 {normalize KC: TIBETAN LETTER GHA} { unicode::normalize KC {3906 4023} } {3906 4023} test unicode-4.31 {normalize KC: MODIFIER LETTER CAPITAL A} { unicode::normalize KC 7468 } {65} test unicode-4.32 {normalize KC: MODIFIER LETTER CAPITAL A} { unicode::normalize KC 7468 } {65} test unicode-4.33 {normalize KC: MODIFIER LETTER CAPITAL A} { unicode::normalize KC 7468 } {65} test unicode-4.34 {normalizeS KC: MODIFIER LETTER CAPITAL A} { unicode::normalizeS KC "\u0041" } "\u0041" test unicode-4.35 {normalize KC: MODIFIER LETTER CAPITAL A} { unicode::normalize KC 65 } {65} test unicode-4.36 {normalize KC: GREEK SMALL LETTER EPSILON WITH PSILI AND OXIA} { unicode::normalize KC 7956 } {7956} test unicode-4.37 {normalize KC: GREEK SMALL LETTER EPSILON WITH PSILI AND OXIA} { unicode::normalize KC 7956 } {7956} test unicode-4.38 {normalize KC: GREEK SMALL LETTER EPSILON WITH PSILI AND OXIA} { unicode::normalize KC {949 787 769} } {7956} test unicode-4.39 {normalizeS KC: GREEK SMALL LETTER EPSILON WITH PSILI AND OXIA} { unicode::normalizeS KC "\u1F14" } "\u1F14" test unicode-4.40 {normalize KC: GREEK SMALL LETTER EPSILON WITH PSILI AND OXIA} { unicode::normalize KC {949 787 769} } {7956} test unicode-4.41 {normalize KC: KANGXI RADICAL SPROUT} { unicode::normalize KC 12076 } {23662} test unicode-4.42 {normalize KC: KANGXI RADICAL SPROUT} { unicode::normalize KC 12076 } {23662} test unicode-4.43 {normalize KC: KANGXI RADICAL SPROUT} { unicode::normalize KC 12076 } {23662} test unicode-4.44 {normalizeS KC: KANGXI RADICAL SPROUT} { unicode::normalizeS KC "\u5C6E" } "\u5C6E" test unicode-4.45 {normalize KC: KANGXI RADICAL SPROUT} { unicode::normalize KC 23662 } {23662} test unicode-4.46 {normalize KC: HIRAGANA LETTER DE} { unicode::normalize KC 12391 } {12391} test unicode-4.47 {normalize KC: HIRAGANA LETTER DE} { unicode::normalize KC 12391 } {12391} test unicode-4.48 {normalize KC: HIRAGANA LETTER DE} { unicode::normalize KC {12390 12441} } {12391} test unicode-4.49 {normalizeS KC: HIRAGANA LETTER DE} { unicode::normalizeS KC "\u3067" } "\u3067" test unicode-4.50 {normalize KC: HIRAGANA LETTER DE} { unicode::normalize KC {12390 12441} } {12391} test unicode-4.51 {normalize KC: KATAKANA LETTER PA} { unicode::normalize KC 12497 } {12497} test unicode-4.52 {normalize KC: KATAKANA LETTER PA} { unicode::normalize KC 12497 } {12497} test unicode-4.53 {normalize KC: KATAKANA LETTER PA} { unicode::normalize KC {12495 12442} } {12497} test unicode-4.54 {normalizeS KC: KATAKANA LETTER PA} { unicode::normalizeS KC "\u30D1" } "\u30D1" test unicode-4.55 {normalize KC: KATAKANA LETTER PA} { unicode::normalize KC {12495 12442} } {12497} test unicode-4.56 {normalize KC: HANGUL LETTER SIOS-PIEUP} { unicode::normalize KC 12669 } {4402} test unicode-4.57 {normalize KC: HANGUL LETTER SIOS-PIEUP} { unicode::normalize KC 12669 } {4402} test unicode-4.58 {normalize KC: HANGUL LETTER SIOS-PIEUP} { unicode::normalize KC 12669 } {4402} test unicode-4.59 {normalizeS KC: HANGUL LETTER SIOS-PIEUP} { unicode::normalizeS KC "\u1132" } "\u1132" test unicode-4.60 {normalize KC: HANGUL LETTER SIOS-PIEUP} { unicode::normalize KC 4402 } {4402} test unicode-4.61 {normalize KC: HANGUL SYLLABLE GYANG} { unicode::normalize KC 44109 } {44109} test unicode-4.62 {normalize KC: HANGUL SYLLABLE GYANG} { unicode::normalize KC 44109 } {44109} test unicode-4.63 {normalize KC: HANGUL SYLLABLE GYANG} { unicode::normalize KC {4352 4451 4540} } {44109} test unicode-4.64 {normalizeS KC: HANGUL SYLLABLE GYANG} { unicode::normalizeS KC "\uAC4D" } "\uAC4D" test unicode-4.65 {normalize KC: HANGUL SYLLABLE GYANG} { unicode::normalize KC {4352 4451 4540} } {44109} test unicode-4.66 {normalize KC: CJK COMPATIBILITY IDEOGRAPH-F98E} { unicode::normalize KC 63886 } {24180} test unicode-4.67 {normalize KC: CJK COMPATIBILITY IDEOGRAPH-F98E} { unicode::normalize KC 24180 } {24180} test unicode-4.68 {normalize KC: CJK COMPATIBILITY IDEOGRAPH-F98E} { unicode::normalize KC 24180 } {24180} test unicode-4.69 {normalizeS KC: CJK COMPATIBILITY IDEOGRAPH-F98E} { unicode::normalizeS KC "\u5E74" } "\u5E74" test unicode-4.70 {normalize KC: CJK COMPATIBILITY IDEOGRAPH-F98E} { unicode::normalize KC 24180 } {24180} test unicode-4.71 {normalize KC: ARABIC LETTER HEH DOACHASHMEE ISOLATED FORM} { unicode::normalize KC 64426 } {1726} test unicode-4.72 {normalize KC: ARABIC LETTER HEH DOACHASHMEE ISOLATED FORM} { unicode::normalize KC 64426 } {1726} test unicode-4.73 {normalize KC: ARABIC LETTER HEH DOACHASHMEE ISOLATED FORM} { unicode::normalize KC 64426 } {1726} test unicode-4.74 {normalizeS KC: ARABIC LETTER HEH DOACHASHMEE ISOLATED FORM} { unicode::normalizeS KC "\u06BE" } "\u06BE" test unicode-4.75 {normalize KC: ARABIC LETTER HEH DOACHASHMEE ISOLATED FORM} { unicode::normalize KC 1726 } {1726} test unicode-4.76 {normalize KC: ARABIC LIGATURE AIN WITH JEEM ISOLATED FORM} { unicode::normalize KC 64553 } {1593 1580} test unicode-4.77 {normalize KC: ARABIC LIGATURE AIN WITH JEEM ISOLATED FORM} { unicode::normalize KC 64553 } {1593 1580} test unicode-4.78 {normalize KC: ARABIC LIGATURE AIN WITH JEEM ISOLATED FORM} { unicode::normalize KC 64553 } {1593 1580} test unicode-4.79 {normalizeS KC: ARABIC LIGATURE AIN WITH JEEM ISOLATED FORM} { unicode::normalizeS KC "\u0639\u062C" } "\u0639\u062C" test unicode-4.80 {normalize KC: ARABIC LIGATURE AIN WITH JEEM ISOLATED FORM} { unicode::normalize KC {1593 1580} } {1593 1580} test unicode-4.81 {normalize KC: FULLWIDTH DIGIT THREE} { unicode::normalize KC 65299 } {51} test unicode-4.82 {normalize KC: FULLWIDTH DIGIT THREE} { unicode::normalize KC 65299 } {51} test unicode-4.83 {normalize KC: FULLWIDTH DIGIT THREE} { unicode::normalize KC 65299 } {51} test unicode-4.84 {normalizeS KC: FULLWIDTH DIGIT THREE} { unicode::normalizeS KC "\u0033" } "\u0033" test unicode-4.85 {normalize KC: FULLWIDTH DIGIT THREE} { unicode::normalize KC 51 } {51} test unicode-4.86 {normalize KC: LATIN SMALL LETTER A, COMBINING CYRILLIC TITLO, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B} { unicode::normalize KC {97 1155 789 768 1454 98} } {97 1454 1155 768 789 98} test unicode-4.87 {normalize KC: LATIN SMALL LETTER A, COMBINING CYRILLIC TITLO, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B} { unicode::normalize KC {97 1454 1155 768 789 98} } {97 1454 1155 768 789 98} test unicode-4.88 {normalize KC: LATIN SMALL LETTER A, COMBINING CYRILLIC TITLO, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B} { unicode::normalize KC {97 1454 1155 768 789 98} } {97 1454 1155 768 789 98} test unicode-4.89 {normalizeS KC: LATIN SMALL LETTER A, COMBINING CYRILLIC TITLO, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B} { unicode::normalizeS KC "\u0061\u05AE\u0483\u0300\u0315\u0062" } "\u0061\u05AE\u0483\u0300\u0315\u0062" test unicode-4.90 {normalize KC: LATIN SMALL LETTER A, COMBINING CYRILLIC TITLO, COMBINING COMMA ABOVE RIGHT, COMBINING GRAVE ACCENT, HEBREW ACCENT ZINOR, LATIN SMALL LETTER B} { unicode::normalize KC {97 1454 1155 768 789 98} } {97 1454 1155 768 789 98} test unicode-4.91 {normalize KC: LATIN SMALL LETTER A, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, COMBINING RING OVERLAY, LATIN SMALL LETTER B} { unicode::normalize KC {97 2364 820 8408 98} } {97 820 8408 2364 98} test unicode-4.92 {normalize KC: LATIN SMALL LETTER A, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, COMBINING RING OVERLAY, LATIN SMALL LETTER B} { unicode::normalize KC {97 820 8408 2364 98} } {97 820 8408 2364 98} test unicode-4.93 {normalize KC: LATIN SMALL LETTER A, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, COMBINING RING OVERLAY, LATIN SMALL LETTER B} { unicode::normalize KC {97 820 8408 2364 98} } {97 820 8408 2364 98} test unicode-4.94 {normalizeS KC: LATIN SMALL LETTER A, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, COMBINING RING OVERLAY, LATIN SMALL LETTER B} { unicode::normalizeS KC "\u0061\u0334\u20D8\u093C\u0062" } "\u0061\u0334\u20D8\u093C\u0062" test unicode-4.95 {normalize KC: LATIN SMALL LETTER A, DEVANAGARI SIGN NUKTA, COMBINING TILDE OVERLAY, COMBINING RING OVERLAY, LATIN SMALL LETTER B} { unicode::normalize KC {97 820 8408 2364 98} } {97 820 8408 2364 98} test unicode-4.96 {normalize KC: HANGUL SYLLABLE BYO, COMBINING TILDE OVERLAY, HANGUL JONGSEONG TIKEUT} { unicode::normalize KC {48484 820 4526} } {48484 820 4526} test unicode-4.97 {normalize KC: HANGUL SYLLABLE BYO, COMBINING TILDE OVERLAY, HANGUL JONGSEONG TIKEUT} { unicode::normalize KC {48484 820 4526} } {48484 820 4526} test unicode-4.98 {normalize KC: HANGUL SYLLABLE BYO, COMBINING TILDE OVERLAY, HANGUL JONGSEONG TIKEUT} { unicode::normalize KC {4359 4461 820 4526} } {48484 820 4526} test unicode-4.99 {normalizeS KC: HANGUL SYLLABLE BYO, COMBINING TILDE OVERLAY, HANGUL JONGSEONG TIKEUT} { unicode::normalizeS KC "\uBD64\u0334\u11AE" } "\uBD64\u0334\u11AE" test unicode-4.100 {normalize KC: HANGUL SYLLABLE BYO, COMBINING TILDE OVERLAY, HANGUL JONGSEONG TIKEUT} { unicode::normalize KC {4359 4461 820 4526} } {48484 820 4526} test unicode-5.1 {fromstring} { unicode::fromstring "\u0403\u0405\u0406\u041f\u0034" } {1027 1029 1030 1055 52} test unicode-5.2 {fromstring} { unicode::fromstring "\u0001\u0002\u0003\u0004\u0005\u0006\u0007\u0008\u0009\u000a\u000b\u000c\u000d" } {1 2 3 4 5 6 7 8 9 10 11 12 13} test unicode-6.1 {tostring} { unicode::tostring {16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1} } "\u0010\u000f\u000e\u000d\u000c\u000b\u000a\u0009\u0008\u0007\u0006\u0005\u0004\u0003\u0002\u0001" test unicode-6.2 {tostring} { unicode::tostring {12345 12346 12347 12348 12349 12350 12351} } "\u3039\u303a\u303b\u303c\u303d\u303e\u303f" test unicode-7.1 {normalize bad form} { catch {unicode::normalize S ""} result set result } "::unicode::normalize: Only D, C, KD and KC forms are allowed" test unicode-8.1 {normalizeS bad form} { catch {unicode::normalizeS S ""} result set result } "::unicode::normalizeS: Only D, C, KD and KC forms are allowed" ::tcltest::cleanupTests tcllib-1.15/modules/stringprep/unicode.man0000644000175000017500000000443612077663116020237 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin unicode n 1.0.0] [copyright {2007, Sergei Golovan }] [moddesc {Unicode normalization}] [titledesc {Implementation of Unicode normalization}] [require Tcl 8.3] [require unicode 1.0] [description] [para] This is an implementation in Tcl of the Unicode normalization forms. [section "COMMANDS"] [list_begin definitions] [call [cmd "::unicode::fromstring"] \ [arg string]] Converts [arg string] to list of integer Unicode character codes which is used in [package unicode] for internal string representation. [call [cmd "::unicode::tostring"] \ [arg uclist]] Converts list of integers [arg uclist] back to Tcl string. [call [cmd "::unicode::normalize"] \ [arg form] \ [arg uclist]] Normalizes Unicode characters list [arg ulist] according to [arg form] and returns the normalized list. Form [arg form] takes one of the following values: [arg D] (canonical decomposition), [arg C] (canonical decomposition, followed by canonical composition), [arg KD] (compatibility decomposition), or [arg KC] (compatibility decomposition, followed by canonical composition). [call [cmd "::unicode::normalizeS"] \ [arg form] \ [arg string]] A shortcut to ::unicode::tostring [lb]unicode::normalize \$form [lb]::unicode::fromstring \$string[rb][rb]. Normalizes Tcl string and returns normalized string. [list_end] [section EXAMPLES] [example { % ::unicode::fromstring "\u0410\u0411\u0412\u0413" 1040 1041 1042 1043 % ::unicode::tostring {49 50 51 52 53} 12345 % }] [example { % ::unicode::normalize D {7692 775} 68 803 775 % ::unicode::normalizeS KD "\u1d2c" A % }] [section "REFERENCES"] [list_begin enum] [enum] "Unicode Standard Annex #15: Unicode Normalization Forms", ([uri http://unicode.org/reports/tr15/]) [list_end] [see_also stringprep(n) ] [section "AUTHORS"] Sergei Golovan [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph stringprep] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords unicode normalization] [manpage_end] tcllib-1.15/modules/stringprep/stringprep.tcl0000644000175000017500000001517312077663116021015 0ustar sergeisergei# stringprep.tcl -*- tcl -*- # # Implementation of RFC 3454 "Preparation of Internationalized Strings" # # Copyright (c) 2007 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: stringprep.tcl,v 1.2 2009/11/02 00:26:44 patthoyts Exp $ package require stringprep::data 1.0 package require unicode 1.0 namespace eval ::stringprep { variable profiles array unset profiles } ######################################################################## # Register new stringprep profile proc ::stringprep::register {profile args} { variable profiles array set props [list -mapping "" \ -normalization "" \ -prohibited 0 \ -prohibitedList {} \ -prohibitedCommand "" \ -prohibitedBidi 0] foreach {opt val} $args { switch -- $opt { -mapping { foreach tab $val { switch -- $tab { B.1 - B.2 - B.3 {} default { return -code error \ "::stringprep::register -mapping: Only\ B.1, B.2, B.3 tables are allowed" } } } set props(-mapping) $val } -normalization { switch -- $val { D - C - KD - KC - "" { set props(-normalization) $val } default { return -code error \ "::stringprep::register -normalization: Only\ D, C, KD, KC or empty normalization is allowed" } } } -prohibited { set mask 0 set c39count 0 foreach tab $val { switch -- $tab { A.1 { set mask [expr {$mask | $data::A1Mask}] } C.1.1 { set mask [expr {$mask | $data::C11Mask}] } C.1.2 { set mask [expr {$mask | $data::C12Mask}] } C.2.1 { set mask [expr {$mask | $data::C21Mask}] } C.2.2 { set mask [expr {$mask | $data::C22Mask}] } C.3 - C.4 - C.5 - C.6 - C.7 - C.8 - C.9 { incr c39count } default { return -code error \ "::stringprep::register -prohibited: Only\ tables A.1, C.* are allowed to prohibit" } } } if {$c39count > 0 && $c39count < 7} { return -code error \ "::stringprep::register -prohibited: Must prohibit\ all C.3--C.9 tables or none of them" } if {$c39count > 0} { set mask [expr {$mask | $data::C39Mask}] } set props(-prohibited) $mask } -prohibitedList { if {[catch { foreach uc $val { if {![string is integer -strict $uc]} { error not_integer } else { lappend props(-prohibitedList) [expr {$uc}] } }}]} { return -code error \ "::stringprep::register -prohibitedList: List\ of integers expected" } } -prohibitedCommand { set props(-prohibitedCommand) $val } -prohibitedBidi { if {[string is true -strict $val]} { set props(-prohibitedBidi) 1 } elseif {[string is false -strict $val]} { set props(-prohibitedBidi) 0 } else { return -code error \ "::stringprep::register -prohibitedBidi: Boolean\ value expected" } } } } set profiles($profile) [array get props] } ######################################################################## # Register identity profile ::stringprep::register none \ -mapping {} \ -normalization {} \ -prohibited {} \ -prohibitedBidi 0 ######################################################################## proc ::stringprep::stringprep {profile str} { variable profiles if {![info exists profiles($profile)]} { return -code error invalid_profile } set uclist [::unicode::fromstring $str] set uclist [map $profile $uclist] if {[llength $uclist] == 0} { return "" } set uclist [normalize $profile $uclist] if {[prohibited $profile $uclist]} { return -code error prohibited_character } if {[prohibited_bidi $profile $uclist]} { return -code error prohibited_bidi } ::unicode::tostring $uclist } ######################################################################## proc ::stringprep::compare {profile str1 str2} { string compare [stringprep $profile $str1] [stringprep $profile $str2] } ######################################################################## # Mapping (section 3) proc ::stringprep::map {profile uclist} { variable profiles array set props $profiles($profile) set B1Mask 0 set B3Mask 0 set B2 0 foreach tab $props(-mapping) { switch -- $tab { B.1 { set B1Mask $data::B1Mask } B.2 { set B2 1 } B.3 { set B3Mask $data::B3Mask } } } set res {} foreach uc $uclist { set info [data::GetUniCharInfo $uc] if {$info & $B1Mask} { # Map to nothing continue } if {$B2 || ($info & $B3Mask)} { if {$info & $data::MCMask} { set res [concat $res [data::GetMC $info]] } else { lappend res [expr {$uc + [data::GetDelta $info]}] } } else { lappend res $uc } } return $res } ######################################################################## # Normalization (section 4) proc ::stringprep::normalize {profile uclist} { variable profiles array set props $profiles($profile) switch -- $props(-normalization) { D - C - KD - KC { return [::unicode::normalize $props(-normalization) $uclist] } default { return $uclist } } } ######################################################################## # Prohibit (section 5) proc ::stringprep::prohibited {profile uclist} { variable profiles array set props $profiles($profile) foreach uc $uclist { set info [data::GetUniCharInfo $uc] if {($info & $props(-prohibited)) || \ [lsearch -exact $props(-prohibitedList) $uc] >= 0} { return 1 } elseif {$props(-prohibitedCommand) != "" && \ [uplevel #0 $props(-prohibitedCommand) [list $uc]]} { return 1 } } return 0 } ######################################################################## # Check bidi (section 6) proc ::stringprep::prohibited_bidi {profile uclist} { variable profiles array set props $profiles($profile) if {!$props(-prohibitedBidi)} { return 0 } set info [data::GetUniCharInfo [lindex $uclist 0]] set first_ral [expr {$info & $data::D1Mask}] set last_ral 0 set have_ral 0 set have_l 0 foreach uc $uclist { set info [data::GetUniCharInfo $uc] set last_ral [expr {$info & $data::D1Mask}] set have_ral [expr {$have_ral || $last_ral}] set have_l [expr {$have_l || ($info & $data::D2Mask)}] } if {$have_ral && (!$first_ral || !$last_ral || $have_l)} { return 1 } else { return 0 } } ######################################################################## package provide stringprep 1.0.1 ######################################################################## tcllib-1.15/modules/stringprep/unicode.tcl0000644000175000017500000001605512077663116020246 0ustar sergeisergei# unicode.tcl -*- tcl -*- # # Implementation of RFC 3454 "Preparation of Internationalized Strings" # # Copyright (c) 2007 Sergei Golovan # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: unicode.tcl,v 1.1 2008/01/29 02:18:10 patthoyts Exp $ package require unicode::data 1.0 namespace eval ::unicode { # Hangul constants set SBase 0xac00 set LBase 0x1100 set VBase 0x1161 set TBase 0x11a7 set LCount 19 set VCount 21 set TCount 28 set NCount [expr {$VCount * $TCount}] set SCount [expr {$LCount * $NCount}] } ######################################################################## # ::unicode::fromstring converts string to list of integers proc ::unicode::fromstring {str} { set uclist {} foreach char [split $str ""] { lappend uclist [scan $char %c] } return $uclist } ######################################################################## # ::unicode::tostring converts list of integers to string proc ::unicode::tostring {uclist} { set res "" foreach num $uclist { append res [format %c $num] } return $res } ######################################################################## # ::unicode::normalize normalizes list of integers according to # http://unicode.org/reports/tr15/ # form is to be D, C, KD, or KC proc ::unicode::normalize {form uclist} { switch -- $form { D { return [normalizeD $uclist] } C { return [normalizeC $uclist] } KD { return [normalizeKD $uclist] } KC { return [normalizeKC $uclist] } default { return -code error \ "::unicode::normalize: Only D, C, KD and KC forms are\ allowed" } } } ######################################################################## # ::unicode::normalizeS normalizes string according to # http://unicode.org/reports/tr15/ # form is to be D, C, KD, or KC proc ::unicode::normalizeS {form str} { switch -- $form { D { return [tostring [normalizeD [fromstring $str]]] } C { return [tostring [normalizeC [fromstring $str]]] } KD { return [tostring [normalizeKD [fromstring $str]]] } KC { return [tostring [normalizeKC [fromstring $str]]] } default { return -code error \ "::unicode::normalizeS: Only D, C, KD and KC forms are\ allowed" } } } ######################################################################## proc ::unicode::normalizeD {uclist} { set res {} foreach uc $uclist { set res [concat $res [decomposeCanonical $uc]] } canonicalOrdering $res } proc ::unicode::normalizeC {uclist} { composeCanonical [normalizeD $uclist] } proc ::unicode::normalizeKD {uclist} { set res {} foreach uc $uclist { set res [concat $res [decomposeCompat $uc]] } canonicalOrdering $res } proc ::unicode::normalizeKC {uclist} { composeCanonical [normalizeKD $uclist] } ######################################################################## # Adjacent characters with nonzero character class should go in # order of increasing character class proc ::unicode::canonicalOrdering {uclist} { set res {} set slist {} foreach uc $uclist { set cclass [data::GetUniCharCClass $uc] if {$cclass != 0} { lappend slist [list $uc $cclass] } else { foreach s [lsort -integer -index 1 $slist] { lappend res [lindex $s 0] } set slist {} lappend res $uc } } foreach s [lsort -integer -index 1 $slist] { lappend res [lindex $s 0] } return $res } ######################################################################## proc ::unicode::decomposeHangul {uc} { variable SBase variable LBase variable VBase variable TBase variable LCount variable VCount variable TCount variable NCount variable SCount # Hangul decomposition is algorithmic set SIndex [expr {$uc - $SBase}] if {$SIndex >= 0 && $SIndex < $SCount} { set res {} set L [expr {$LBase + $SIndex / $NCount}] set V [expr {$VBase + ($SIndex % $NCount) / $TCount}] set T [expr {$TBase + $SIndex % $TCount}] set res [list $L $V] if {$T != $TBase} { lappend res $T } return $res } return -1 } ######################################################################## proc ::unicode::decomposeCanonical {uc} { # Try to decompose Hangul first set res [decomposeHangul $uc] if {$res >= 0} { return $res } # For others do a lookup in data tables set info [data::GetUniCharDecompInfo $uc] if {$info >= 0} { set res {} foreach c [data::GetDecompList $info] { set res [concat $res [decomposeCanonical $c]] } return $res } else { return [list $uc] } } ######################################################################## proc ::unicode::decomposeCompat {uc} { # Try to decompose Hangul first set res [decomposeHangul $uc] if {$res >= 0} { return $res } # For others do a lookup in data tables set info [data::GetUniCharDecompCompatInfo $uc] if {$info >= 0} { set res {} foreach c [data::GetDecompList $info] { set res [concat $res [decomposeCompat $c]] } return $res } else { return [list $uc] } } ######################################################################## proc ::unicode::composeTwo {uc1 uc2} { variable SBase variable LBase variable VBase variable TBase variable LCount variable VCount variable TCount variable NCount variable SCount # Hangul composition is algorithmic if {$uc1 >= $LBase && $uc1 < $LBase + $LCount && \ $uc2 >= $VBase && $uc2 < $VBase + $VCount} { return [expr {$SBase + (($uc1 - $LBase) * $VCount + \ ($uc2 - $VBase)) * $TCount}] } if {$uc1 >= $SBase && $uc1 < $SBase + $SCount && \ (($uc1 - $SBase) % $TCount) == 0 && \ $uc2 >= $TBase && $uc2 < $TBase + $TCount} { return [expr {$uc1 + $uc2 - $TBase}] } # For others do a lookup in data tables set info1 [data::GetUniCharCompInfo $uc1] set res [data::GetCompFirst $uc2 $info1] if {$res != -1} { return $res } set info2 [data::GetUniCharCompInfo $uc2] set res [data::GetCompSecond $uc1 $info2] if {$res != -1} { return $res } data::GetCompBoth $info1 $info2 } ######################################################################## proc ::unicode::composeCanonical {uclist} { if {[llength $uclist] == 0} { return {} } set res {} set comps {} set ch1 [lindex $uclist 0] set cclass_prev [data::GetUniCharCClass $ch1] foreach ch2 [lrange $uclist 1 end] { set cclass [data::GetUniCharCClass $ch2] if {($cclass_prev == 0 || $cclass > $cclass_prev) && \ [set ruc [composeTwo $ch1 $ch2]]} { set ch1 $ruc } else { if {$cclass == 0} { lappend res $ch1 set res [concat $res $comps] set comps {} set ch1 $ch2 set cclass_prev 0 } else { lappend comps $ch2 set cclass_prev $cclass } } } lappend res $ch1 concat $res $comps } ######################################################################## package provide unicode 1.0.0 tcllib-1.15/modules/counter/0000755000175000017500000000000012104363635015361 5ustar sergeisergeitcllib-1.15/modules/counter/ChangeLog0000644000175000017500000001635212104363437017142 0ustar sergeisergei2013-02-01 Andreas Kupries * * Released and tagged Tcllib 1.15 ======================== * 2011-12-13 Andreas Kupries * * Released and tagged Tcllib 1.14 ======================== * 2011-01-24 Andreas Kupries * * Released and tagged Tcllib 1.13 ======================== * 2009-12-07 Andreas Kupries * * Released and tagged Tcllib 1.12 ======================== * 2008-12-12 Andreas Kupries * * Released and tagged Tcllib 1.11.1 ======================== * 2008-10-16 Andreas Kupries * * Released and tagged Tcllib 1.11 ======================== * 2007-09-12 Andreas Kupries * * Released and tagged Tcllib 1.10 ======================== * 2007-03-21 Andreas Kupries * counter.man: Fixed all warnings due to use of now deprecated commands. Added a section about how to give feedback. 2006-10-03 Andreas Kupries * * Released and tagged Tcllib 1.9 ======================== * 2006-09-27 Andreas Kupries * counter.test: [SF Tcllib Bug 1272754]. Using 'format' to get results with a deterministic precision. 2006-01-29 Andreas Kupries * counter.test: Fixed use of duplicate test names. 2006-01-22 Andreas Kupries * counter.test: More boilerplate simplified via use of test support. 2006-01-19 Andreas Kupries * counter.test: Hooked into the new common test support code. 2006-01-10 Andreas Kupries * counter.test: Fixed [SF Tcllib Bug 1316036]. Uncluttering test output. 2005-10-06 Andreas Kupries * * Released and tagged Tcllib 1.8 ======================== * 2005-04-11 Andreas Kupries * counter.tcl: Re-added the 'alt' attribute, i.e. the output now contains both 'title' and 'alt', so that all browsers will be satisfied, whichever attribute they use for their tooltips. 2005-04-07 Andreas Kupries * counter.tcl: Replace usage of the 'alt' attribute in a the tag with the 'title' attribute. Fixed [SF Tcllib Bug 1176744]. Reported by David Gravereaux . 2004-10-05 Andreas Kupries * * Released and tagged Tcllib 1.7 ======================== * Wed Sep 29 12:13:38 2004 Andreas Kupries * counter.tcl (MergeDay): Fixed [Tcllib SF Bug 943984], a typo causing loss of data. Reported by David Gravereaux . 2004-09-23 Andreas Kupries * counter.tcl: Fixed expr'essions without braces. 2004-08-18 Michael Schlenker * counter.tcl: Error message added in counter::get if -avgn is used on a non -lastn counter. Replaced fragile prefix stripping with string map in counter::names with a more robust string range based version. 2004-05-23 Andreas Kupries * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * 2003-11-20 Andreas Kupries * counter.man: Added documentation for counter::reset. This fixes [SF Tcllib Bug 759959]. Also added some keywords. 2003-08-13 Brent Welch * counter.tcl: Fixed math in counter::start and counter::stop 2003-05-05 Andreas Kupries * * Released and tagged Tcllib 1.4 ======================== * 2003-05-02 Andreas Kupries * counter.test: Deactivated 'counter-timehist' (via constraint), this test is load-dependent. I.e. it will fail if the machine the test are run on is heavily loaded. 2003-04-24 Andreas Kupries * counter.test: Added missing propagation of test results. 2003-04-11 Andreas Kupries * counter.tcl: * counter.man: * pkgIndex.tcl: Fixed bug #614591. Set version of the package to to 2.0.1. 2003-02-23 David N. Welton * counter.tcl (counter::names): Use string map instead of regsub. Require Tcl 8.2 as a consequence. 2003-01-16 Andreas Kupries * counter.man: More semantic markup, less visual one. 2002-08-30 Andreas Kupries * counter.tcl: Updated 'info exist' to 'info exists'. 2002-04-16 Andreas Kupries * counter.man: Added doctools manpage. 2001-09-05 Andreas Kupries * counter.tcl: Restricted export list to public API. [456255]. Patch by Hemang Lavana 2001-07-10 Andreas Kupries * counter.tcl: Frink 2.2 run, fixed dubious code. 2001-07-09 Brent Welch * counter.test: Fixed histlog test 2001-06-21 Andreas Kupries * counter.tcl: Fixed dubious code reported by frink. 2000-10-04 Brent Welch * counter.tcl: Fixed bug in counter::MergeDay 2000-10-03 Brent Welch * counter.tcl: Fixed bug in label format for daily graph. 2000-10-02 Brent Welch * NAME CHANGE from "stats" to "counter" * counter.tcl: Changed shading of histogram labels. 2000-10-02 Brent Welch * modules/stats/stats.tcl: Added stats::htmlHistDisplayRow so that the calling page could define the overall table structure. 2000-10-01 Brent Welch * modules/stats/stats.tcl: Fixed calculation of hourBase and minuteBase when secsPerMinute was not 60. 2000-09-23 Brent Welch * modules/stats/stats.tcl: Time-based histograms were not displaying the 23rd hour nor the 59th minute. 2000-09-22 Brent Welch * modules/stats/stats.tcl: Fixed initialization when the server starts in the 59'th minute. The first after event was an hour too long, so the first hour of data didn't display correctly. 2000-09-21 Brent Welch * modules/stats/stats.tcl: Added time labels and tick marks to all the time-based histograms. Fixed alignment of per-minute and per-hour histograms. 2000-09-20 Brent Welch * modules/stats/stats.tcl: Refined the countGet routine to return things needed by the TclHttpd status module. Refined the value-based histogram display. * modules/stats/stats.tests: Added more tests. * modules/stats/stats.n: Completed the man page. 2000-09-15 Brent Welch * Created this module. tcllib-1.15/modules/counter/pkgIndex.tcl0000644000175000017500000000113212077663115017640 0ustar sergeisergei# 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.2]} {return} package ifneeded counter 2.0.4 [list source [file join $dir counter.tcl]] tcllib-1.15/modules/counter/counter.test0000644000175000017500000001421412077663115017750 0ustar sergeisergei# -*- tcl -*- # Tests for the counter module. # # This file contains a collection of tests for a module in the # Standard Tcl Library. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1998-2000 by Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: counter.test,v 1.13 2006/10/09 21:41:40 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.2 testsNeedTcltest 1.0 testing { useLocal counter.tcl counter } # ------------------------------------------------------------------------- proc Stamp {tag} { puts stderr "[clock format [clock seconds]] [clock clicks -milliseconds] $tag" } # ------------------------------------------------------------------------- test counter-1.1 {counter::init} { catch {counter::init} err } {1} if 0 { set x 0 puts "incr scaler [time {incr x} 100]" set a(x) 0 puts "incr array [time {incr a(x)} 100]" set a(x) 0 set a(n) 0 puts "rawcount [time { set a(x) [expr {$a(x) + 2.4}] incr a(n) } 100]" } test counter-simple {counter::count} { counter::init simple counter::count simple counter::count simple counter::count simple counter::get simple } {3} #puts "simple [time {counter::count simple} 100]" test counter-avg-1.0 {counter::count} { counter::init avg counter::count avg 2.2 counter::count avg 3.3 counter::count avg 9.8 format %3.1f [counter::get avg -avg] } {5.1} test counter-avg-1.1 {counter::count} { counter::init avg counter::get avg -avg } {0} test counter-lastn-1.0 {averge over lastn} { counter::init lastn -lastn 4 counter::count lastn 2.2 counter::count lastn 4.6 counter::get lastn -avgn } {3.4} test counter-lastn-1.1 {averge over lastn} { counter::init lastn -lastn 4 counter::count lastn 2.2 counter::count lastn 3.3 counter::count lastn 8.6 counter::count lastn 4.1 counter::count lastn 6.9 counter::count lastn 0.4 counter::get lastn -avgn } {5.0} #puts "lastn [time {counter::count lastn 2.4} 100]" test counter-lastn-1.2 {lifetime average} { counter::init lastn -lastn 4 counter::count lastn 2.2 counter::count lastn 3.3 counter::count lastn 8.6 counter::count lastn 4.1 counter::count lastn 6.9 counter::count lastn 0.4 counter::get lastn -avg } {4.25} #puts "lastn [time {counter::count lastn 2.4} 100]" test counter-hist-1.0 {basic histogram} { counter::init hist -hist 10 counter::count hist 2.2 counter::count hist 18.6 counter::count hist 14.1 counter::count hist 26.9 counter::count hist 20.4 counter::count hist 23.3 counter::count hist 53.3 counter::get hist -hist } {0 1 1 2 2 3 5 1} test counter-hist-1.1 {histogram average} { counter::init hist -hist 10 counter::count hist 2.2 counter::count hist 18.6 counter::count hist 14.1 counter::count hist 26.9 counter::count hist 20.4 counter::count hist 23.3 counter::count hist 53.3 format %13.10f [counter::get hist -avg] } {22.6857142857} #puts "hist [time {counter::count hist 2.4} 100]" test counter-hist2x {counter::count} { counter::init hist -hist2x 10 counter::count hist 8 counter::count hist 18 counter::count hist 28 counter::count hist 38 counter::count hist 48 counter::count hist 58 counter::count hist 68 counter::count hist 78 counter::count hist 178 counter::count hist 478 counter::get hist -hist } {0 1 1 1 2 2 3 4 5 1 6 1} #puts "hist2x [time {counter::count hist 50} 100]" test counter-hist10x {counter::count} { counter::init hist -hist10x 10 counter::count hist 8 counter::count hist 18 counter::count hist 28 counter::count hist 38 counter::count hist 48 counter::count hist 58 counter::count hist 68 counter::count hist 78 counter::count hist 178 counter::count hist 478 counter::count hist 1478 counter::count hist 1478000 counter::get hist -hist } {0 1 1 7 2 2 3 1 6 1} test counter-histlog {counter::count} { counter::init histlog -histlog 1 counter::count histlog 0.1 counter::count histlog 0.5 counter::count histlog 0.9 counter::count histlog 1.0 counter::count histlog 2 counter::count histlog 3 counter::count histlog 5 counter::count histlog 10 counter::count histlog 30 counter::count histlog 50 counter::count histlog 100 counter::count histlog 300 counter::count histlog 500 counter::count histlog 1000 counter::get histlog -hist } {-2 1 0 4 1 2 2 1 3 2 4 1 5 1 6 2} test counter-timehist {counter::count} {load-dependent} { counter::init hits -timehist 4 catch {#puts stderr "Pausing during timehist tests"} counter::count hits 2 # We need to reach in and find out what bucket was used array set info [counter::get hits -all] set min0 $info(lastMinute) after [expr 4000] counter::count hits 4 after [expr 4000] counter::count hits 8 set result [list] foreach {n v} [counter::get hits -hist] { if {$v > 0} { lappend result [expr {$n - $min0}] $v } } #puts "timehist [time {counter::count hits} 100]" set result } {0 2 1 4 2 8} test counter-countNames {counter::names} { counter::init simple counter::init avg counter::init lastn -lastn 4 counter::init hist -hist 10 counter::init histlog -histlog 1 counter::init hits -timehist 4 lsort [counter::names] } {avg hist histlog hits lastn simple} test counter-countExists {counter::exists} { counter::init simple counter::init lastn -lastn 4 unset counter::T-lastn list [counter::exists simple] [counter::exists lastn] } {1 0} test counter-countReset {counter::reset} { counter::init simple counter::count simple 1 counter::count simple 1 counter::count simple 1 counter::reset simple counter::get simple } {0} testsuiteCleanup tcllib-1.15/modules/counter/counter.tcl0000644000175000017500000010460712077663115017561 0ustar sergeisergei# counter.tcl -- # # Procedures to manage simple counters and histograms. # # Copyright (c) 1998-2000 by Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: counter.tcl,v 1.23 2005/09/30 05:36:38 andreas_kupries Exp $ package require Tcl 8.2 namespace eval ::counter { # Variables of name counter::T-$tagname # are created as arrays to support each counter. # Time-based histograms are kept in sync with each other, # so these variables are shared among them. # These base times record the time corresponding to the first bucket # of the per-minute, per-hour, and per-day time-based histograms. variable startTime variable minuteBase variable hourBase variable hourEnd variable dayBase variable hourIndex variable dayIndex # The time-based histogram uses an after event and a list # of counters to do mergeing on. variable tagsToMerge if {![info exists tagsToMerge]} { set tagsToMerge {} } variable mergeInterval namespace export init reset count exists get names start stop namespace export histHtmlDisplay histHtmlDisplayRow histHtmlDisplayBarChart } # ::counter::init -- # # Set up a counter. # # Arguments: # tag The identifier for the counter. Pass this to counter::count # args option values pairs that define characteristics of the counter: # See the man page for definitons. # # Results: # None. # # Side Effects: # Initializes state about a counter. proc ::counter::init {tag args} { upvar #0 counter::T-$tag counter if {[info exists counter]} { unset counter } set counter(N) 0 ;# Number of samples set counter(total) 0 set counter(type) {} # With an empty type the counter is a simple accumulator # for which we can compute an average. Here we loop through # the args to determine what additional counter attributes # we need to maintain in counter::count foreach {option value} $args { switch -- $option { -timehist { variable tagsToMerge variable secsPerMinute variable startTime variable minuteBase variable hourBase variable dayBase variable hourIndex variable dayIndex upvar #0 counter::H-$tag histogram upvar #0 counter::Hour-$tag hourhist upvar #0 counter::Day-$tag dayhist # Clear the histograms. for {set i 0} {$i < 60} {incr i} { set histogram($i) 0 } for {set i 0} {$i < 24} {incr i} { set hourhist($i) 0 } if {[info exists dayhist]} { unset dayhist } set dayhist(0) 0 # Clear all-time high records set counter(maxPerMinute) 0 set counter(maxPerHour) 0 set counter(maxPerDay) 0 # The value associated with -timehist is the number of seconds # in each bucket. Normally this is 60, but for # testing, we compress minutes. The value is limited at # 60 because the per-minute buckets are accumulated into # per-hour buckets later. if {$value == "" || $value == 0 || $value > 60} { set value 60 } # Histogram state variables. # All time-base histograms share the same bucket size # and starting times to keep them all synchronized. # So, we only initialize these parameters once. if {![info exists secsPerMinute]} { set secsPerMinute $value set startTime [clock seconds] set dayIndex 0 set dayStart [clock scan [clock format $startTime \ -format 00:00]] # Figure out what "hour" we are set delta [expr {$startTime - $dayStart}] set hourIndex [expr {$delta / ($secsPerMinute * 60)}] set day [expr {$hourIndex / 24}] set hourIndex [expr {$hourIndex % 24}] set hourBase [expr {$dayStart + $day * $secsPerMinute * 60 * 24}] set minuteBase [expr {$hourBase + $hourIndex * 60 * $secsPerMinute}] set partialHour [expr {$startTime - ($hourBase + $hourIndex * 60 * $secsPerMinute)}] set secs [expr {(60 * $secsPerMinute) - $partialHour}] if {$secs <= 0} { set secs 1 } # After the first timer, the event occurs once each "hour" set mergeInterval [expr {60 * $secsPerMinute * 1000}] after [expr {$secs * 1000}] [list counter::MergeHour $mergeInterval] } if {[lsearch $tagsToMerge $tag] < 0} { lappend tagsToMerge $tag } # This records the last used slots in order to zero-out the # buckets that are skipped during idle periods. set counter(lastMinute) -1 # The following is referenced when bugs cause histogram # hits outside the expect range (overflow and underflow) set counter(bucketsize) 0 } -group { # Cluster a set of counters with a single total upvar #0 counter::H-$tag histogram if {[info exists histogram]} { unset histogram } set counter(group) $value } -lastn { # The lastN samples are kept if a vector to form a running average. upvar #0 counter::V-$tag vector set counter(lastn) $value set counter(index) 0 if {[info exists vector]} { unset vector } for {set i 0} {$i < $value} {incr i} { set vector($i) 0 } } -hist { # A value-based histogram with buckets for different values. upvar #0 counter::H-$tag histogram if {[info exists histogram]} { unset histogram } set counter(bucketsize) $value set counter(mult) 1 } -hist2x { upvar #0 counter::H-$tag histogram if {[info exists histogram]} { unset histogram } set counter(bucketsize) $value set counter(mult) 2 } -hist10x { upvar #0 counter::H-$tag histogram if {[info exists histogram]} { unset histogram } set counter(bucketsize) $value set counter(mult) 10 } -histlog { upvar #0 counter::H-$tag histogram if {[info exists histogram]} { unset histogram } set counter(bucketsize) $value } -simple { # Useful when disabling predefined -timehist or -group counter } default { return -code error "Unsupported option $option.\ Must be -timehist, -group, -lastn, -hist, -hist2x, -hist10x, -histlog, or -simple." } } if {[string length $option]} { # In case an option doesn't change the type, but # this feature of the interface isn't used, etc. lappend counter(type) $option } } # Instead of supporting a counter that could have multiple attributes, # we support a single type to make counting more efficient. if {[llength $counter(type)] > 1} { return -code error "Multiple type attributes not supported. Use only one of\ -timehist, -group, -lastn, -hist, -hist2x, -hist10x, -histlog, -disabled." } return "" } # ::counter::reset -- # # Reset a counter. # # Arguments: # tag The identifier for the counter. # # Results: # None. # # Side Effects: # Deletes the counter and calls counter::init again for it. proc ::counter::reset {tag args} { upvar #0 counter::T-$tag counter # Layer reset on top of init. Here we figure out what # we need to pass into the init procedure to recreate it. switch -- $counter(type) { "" { set args "" } -group { upvar #0 counter::H-$tag histogram if {[info exists histogram]} { unset histogram } set args [list -group $counter(group)] } -lastn { upvar #0 counter::V-$tag vector if {[info exists vector]} { unset vector } set args [list -lastn $counter(lastn)] } -hist - -hist10x - -histlog - -hist2x { upvar #0 counter::H-$tag histogram if {[info exists histogram]} { unset histogram } set args [list $counter(type) $counter(bucketsize)] } -timehist { foreach h [list counter::H-$tag counter::Hour-$tag counter::Day-$tag] { upvar #0 $h histogram if {[info exists histogram]} { unset histogram } } set args [list -timehist $counter::secsPerMinute] } default {#ignore} } unset counter eval {counter::init $tag} $args set counter(resetDate) [clock seconds] return "" } # ::counter::count -- # # Accumulate statistics. # # Arguments: # tag The counter identifier. # delta The increment amount. Defaults to 1. # arg For -group types, this is the histogram index. # # Results: # None # # Side Effects: # Accumlate statistics. proc ::counter::count {tag {delta 1} args} { upvar #0 counter::T-$tag counter set counter(total) [expr {$counter(total) + $delta}] incr counter(N) # Instead of supporting a counter that could have multiple attributes, # we support a single type to make counting a skosh more efficient. # foreach option $counter(type) { switch -- $counter(type) { "" { # Simple counter return } -group { upvar #0 counter::H-$tag histogram set subIndex [lindex $args 0] if {![info exists histogram($subIndex)]} { set histogram($subIndex) 0 } set histogram($subIndex) [expr {$histogram($subIndex) + $delta}] } -lastn { upvar #0 counter::V-$tag vector set vector($counter(index)) $delta set counter(index) [expr {($counter(index) +1)%$counter(lastn)}] } -hist { upvar #0 counter::H-$tag histogram set bucket [expr {int($delta / $counter(bucketsize))}] if {![info exists histogram($bucket)]} { set histogram($bucket) 0 } incr histogram($bucket) } -hist10x - -hist2x { upvar #0 counter::H-$tag histogram set bucket 0 for {set max $counter(bucketsize)} {$delta > $max} \ {set max [expr {$max * $counter(mult)}]} { incr bucket } if {![info exists histogram($bucket)]} { set histogram($bucket) 0 } incr histogram($bucket) } -histlog { upvar #0 counter::H-$tag histogram set bucket [expr {int(log($delta)*$counter(bucketsize))}] if {![info exists histogram($bucket)]} { set histogram($bucket) 0 } incr histogram($bucket) } -timehist { upvar #0 counter::H-$tag histogram variable minuteBase variable secsPerMinute set minute [expr {([clock seconds] - $minuteBase) / $secsPerMinute}] if {$minute > 59} { # this occurs while debugging if the process is # stopped at a breakpoint too long. set minute 59 } # Initialize the current bucket and # clear any buckets we've skipped since the last sample. if {$minute != $counter(lastMinute)} { set histogram($minute) 0 for {set i [expr {$counter(lastMinute)+1}]} \ {$i < $minute} \ {incr i} { set histogram($i) 0 } set counter(lastMinute) $minute } set histogram($minute) [expr {$histogram($minute) + $delta}] } default {#ignore} } # } return } # ::counter::exists -- # # Return true if the counter exists. # # Arguments: # tag The counter identifier. # # Results: # 1 if it has been defined. # # Side Effects: # None. proc ::counter::exists {tag} { upvar #0 counter::T-$tag counter return [info exists counter] } # ::counter::get -- # # Return statistics. # # Arguments: # tag The counter identifier. # option What statistic to get # args Needed by some options. # # Results: # With no args, just the counter value. # # Side Effects: # None. proc ::counter::get {tag {option -total} args} { upvar #0 counter::T-$tag counter switch -- $option { -total { return $counter(total) } -totalVar { return ::counter::T-$tag\(total) } -N { return $counter(N) } -avg { if {$counter(N) == 0} { return 0 } else { return [expr {$counter(total) / double($counter(N))}] } } -avgn { if {$counter(type) != "-lastn"} { return -code error "The -avgn option is only supported for -lastn counters." } upvar #0 counter::V-$tag vector set sum 0 for {set i 0} {($i < $counter(N)) && ($i < $counter(lastn))} {incr i} { set sum [expr {$sum + $vector($i)}] } if {$i == 0} { return 0 } else { return [expr {$sum / double($i)}] } } -hist { upvar #0 counter::H-$tag histogram if {[llength $args]} { # Return particular bucket set bucket [lindex $args 0] if {[info exists histogram($bucket)]} { return $histogram($bucket) } else { return 0 } } else { # Dump the whole histogram set result {} if {$counter(type) == "-group"} { set sort -dictionary } else { set sort -integer } foreach x [lsort $sort [array names histogram]] { lappend result $x $histogram($x) } return $result } } -histVar { return ::counter::H-$tag } -histHour { upvar #0 counter::Hour-$tag histogram set result {} foreach x [lsort -integer [array names histogram]] { lappend result $x $histogram($x) } return $result } -histHourVar { return ::counter::Hour-$tag } -histDay { upvar #0 counter::Day-$tag histogram set result {} foreach x [lsort -integer [array names histogram]] { lappend result $x $histogram($x) } return $result } -histDayVar { return ::counter::Day-$tag } -maxPerMinute { return $counter(maxPerMinute) } -maxPerHour { return $counter(maxPerHour) } -maxPerDay { return $counter(maxPerDay) } -resetDate { if {[info exists counter(resetDate)]} { return $counter(resetDate) } else { return "" } } -all { return [array get counter] } default { return -code error "Invalid option $option.\ Should be -all, -total, -N, -avg, -avgn, -hist, -histHour,\ -histDay, -totalVar, -histVar, -histHourVar, -histDayVar -resetDate." } } } # ::counter::names -- # # Return the list of defined counters. # # Arguments: # none # # Results: # A list of counter tags. # # Side Effects: # None. proc ::counter::names {} { set result {} foreach v [info vars ::counter::T-*] { if {[info exists $v]} { # Declared arrays might not exist, yet # strip prefix from name set v [string range $v [string length "::counter::T-"] end] lappend result $v } } return $result } # ::counter::MergeHour -- # # Sum the per-minute histogram into the next hourly bucket. # On 24-hour boundaries, sum the hourly buckets into the next day bucket. # This operates on all time-based histograms. # # Arguments: # none # # Results: # none # # Side Effects: # See description. proc ::counter::MergeHour {interval} { variable hourIndex variable minuteBase variable hourBase variable tagsToMerge variable secsPerMinute after $interval [list counter::MergeHour $interval] if {![info exists hourBase] || $hourIndex == 0} { set hourBase $minuteBase } set minuteBase [clock seconds] foreach tag $tagsToMerge { upvar #0 counter::T-$tag counter upvar #0 counter::H-$tag histogram upvar #0 counter::Hour-$tag hourhist # Clear any buckets we've skipped since the last sample. for {set i [expr {$counter(lastMinute)+1}]} {$i < 60} {incr i} { set histogram($i) 0 } set counter(lastMinute) -1 # Accumulate into the next hour bucket. set hourhist($hourIndex) 0 set max 0 foreach i [array names histogram] { set hourhist($hourIndex) [expr {$hourhist($hourIndex) + $histogram($i)}] if {$histogram($i) > $max} { set max $histogram($i) } } set perSec [expr {$max / $secsPerMinute}] if {$perSec > $counter(maxPerMinute)} { set counter(maxPerMinute) $perSec } } set hourIndex [expr {($hourIndex + 1) % 24}] if {$hourIndex == 0} { counter::MergeDay } } # ::counter::MergeDay -- # # Sum the per-minute histogram into the next hourly bucket. # On 24-hour boundaries, sum the hourly buckets into the next day bucket. # This operates on all time-based histograms. # # Arguments: # none # # Results: # none # # Side Effects: # See description. proc ::counter::MergeDay {} { variable dayIndex variable dayBase variable hourBase variable tagsToMerge variable secsPerMinute # Save the hours histogram into a bucket for the last day # counter(day,$day) is the starting time for that day bucket if {![info exists dayBase]} { set dayBase $hourBase } foreach tag $tagsToMerge { upvar #0 counter::T-$tag counter upvar #0 counter::Day-$tag dayhist upvar #0 counter::Hour-$tag hourhist set dayhist($dayIndex) 0 set max 0 for {set i 0} {$i < 24} {incr i} { if {[info exists hourhist($i)]} { set dayhist($dayIndex) [expr {$dayhist($dayIndex) + $hourhist($i)}] if {$hourhist($i) > $max} { set max $hourhist($i) } } } set perSec [expr {double($max) / ($secsPerMinute * 60)}] if {$perSec > $counter(maxPerHour)} { set counter(maxPerHour) $perSec } } set perSec [expr {double($dayhist($dayIndex)) / ($secsPerMinute * 60 * 24)}] if {$perSec > $counter(maxPerDay)} { set counter(maxPerDay) $perSec } incr dayIndex } # ::counter::histHtmlDisplay -- # # Create an html display of the histogram. # # Arguments: # tag The counter tag # args option, value pairs that affect the display: # -title Label to display above bar chart # -unit minutes, hours, or days select time-base histograms. # Specify anything else for value-based histograms. # -images URL of /images directory. # -gif Image for normal histogram bars # -ongif Image for the active histogram bar # -max Maximum number of value-based buckets to display # -height Pixel height of the highest bar # -width Pixel width of each bar # -skip Buckets to skip when labeling value-based histograms # -format Format used to display labels of buckets. # -text If 1, a text version of the histogram is dumped, # otherwise a graphical one is generated. # # Results: # HTML for the display as a complete table. # # Side Effects: # None. proc ::counter::histHtmlDisplay {tag args} { append result "

\n\n" append result [eval {counter::histHtmlDisplayRow $tag} $args] append result
return $result } # ::counter::histHtmlDisplayRow -- # # Create an html display of the histogram. # # Arguments: # See counter::histHtmlDisplay # # Results: # HTML for the display. Ths is one row of a 2-column table, # the calling page must define the tag. # # Side Effects: # None. proc ::counter::histHtmlDisplayRow {tag args} { upvar #0 counter::T-$tag counter variable secsPerMinute variable minuteBase variable hourBase variable dayBase variable hourIndex variable dayIndex array set options [list \ -title $tag \ -unit "" \ -images /images \ -gif Blue.gif \ -ongif Red.gif \ -max -1 \ -height 100 \ -width 4 \ -skip 4 \ -format %.2f \ -text 0 ] array set options $args # Support for self-posting pages that can clear counters. append result "" if {[ncgi::value resetCounter] == $tag} { counter::reset $tag return "" } switch -glob -- $options(-unit) { min* { upvar #0 counter::H-$tag histogram set histname counter::H-$tag if {![info exists minuteBase]} { return "" } set time $minuteBase set secsForMax $secsPerMinute set periodMax $counter(maxPerMinute) set curIndex [expr {([clock seconds] - $minuteBase) / $secsPerMinute}] set options(-max) 60 set options(-min) 0 } hour* { upvar #0 counter::Hour-$tag histogram set histname counter::Hour-$tag if {![info exists hourBase]} { return "" } set time $hourBase set secsForMax [expr {$secsPerMinute * 60}] set periodMax $counter(maxPerHour) set curIndex [expr {$hourIndex - 1}] if {$curIndex < 0} { set curIndex 23 } set options(-max) 24 set options(-min) 0 } day* { upvar #0 counter::Day-$tag histogram set histname counter::Day-$tag if {![info exists dayBase]} { return "" } set time $dayBase set secsForMax [expr {$secsPerMinute * 60 * 24}] set periodMax $counter(maxPerDay) set curIndex dayIndex set options(-max) $dayIndex set options(-min) 0 } default { # Value-based histogram with arbitrary units. upvar #0 counter::H-$tag histogram set histname counter::H-$tag set unit $options(-unit) set curIndex "" set time "" } } if {! [info exists histogram]} { return "\n" } set max 0 set maxName 0 foreach {name value} [array get histogram] { if {$value > $max} { set max $value set maxName $name } } # Start 2-column HTML display. A summary table at the left, the histogram on the right. append result "\n append result "\n return $result } # ::counter::histHtmlDisplayBarChart -- # # Create an html display of the histogram. # # Arguments: # tag The counter tag. # histVar The name of the histogram array # max The maximum counter value in a histogram bucket. # curIndex The "current" histogram index, for time-base histograms. # time The base, or starting time, for the time-based histograms. # args The array get of the options passed into histHtmlDisplay # # Results: # HTML for the bar chart. # # Side Effects: # See description. proc ::counter::histHtmlDisplayBarChart {tag histVar max curIndex time args} { upvar #0 counter::T-$tag counter upvar 1 $histVar histogram variable secsPerMinute array set options $args append result "
\n" append result "\n" append result "\n" append result "" append result "\n" if {[info exists secsForMax]} { # Time-base histogram set string {} set t $secsForMax set days [expr {$t / (60 * 60 * 24)}] if {$days == 1} { append string "1 Day " } elseif {$days > 1} { append string "$days Days " } set t [expr {$t - $days * (60 * 60 * 24)}] set hours [expr {$t / (60 * 60)}] if {$hours == 1} { append string "1 Hour " } elseif {$hours > 1} { append string "$hours Hours " } set t [expr {$t - $hours * (60 * 60)}] set mins [expr {$t / 60}] if {$mins == 1} { append string "1 Minute " } elseif {$mins > 1} { append string "$mins Minutes " } set t [expr {$t - $mins * 60}] if {$t == 1} { append string "1 Second " } elseif {$t > 1} { append string "$t Seconds " } append result "" append result "\n" append result "" append result "\n" if {$periodMax > 0} { append result "" append result "\n" } append result "" switch -glob -- $options(-unit) { min* { append result "\n" } hour* { append result "\n" } day* { append result "\n" } default {#ignore} } } else { # Value-base histogram set ix [lsort -integer [array names histogram]] set mode [expr {$counter(bucketsize) * $maxName}] set first [expr {$counter(bucketsize) * [lindex $ix 0]}] set last [expr {$counter(bucketsize) * [lindex $ix end]}] append result "" append result "\n" append result "" append result "\n" append result "" append result "\n" append result "" append result "\n" append result "" append result "\n" append result "\n" if {$options(-max) < 0} { set options(-max) [lindex $ix end] } if {![info exists options(-min)]} { set options(-min) [lindex $ix 0] } } # End table nested inside left-hand column append result
[html::font]$options(-title)
[html::font]Total[html::font][format $options(-format) $counter(total)]
[html::font]Bucket Size[html::font]$string
[html::font]Max Per Sec[html::font][format %.2f [expr {$max/double($secsForMax)}]]
[html::font]Best Per Sec[html::font][format %.2f $periodMax]
[html::font]Starting Time[html::font][clock format $time \ -format %k:%M:%S]
[html::font][clock format $time \ -format %k:%M:%S]
[html::font][clock format $time \ -format "%b %d %k:%M"]
[html::font]Average[html::font][format $options(-format) [counter::get $tag -avg]]
[html::font]Mode[html::font]$mode
[html::font]Minimum[html::font]$first
[html::font]Maximum[html::font]$last
[html::font]Unit[html::font]$unit
[html::font]" append result "Reset
\n append result 		\n" # Display the histogram if {$options(-text)} { } else { append result [eval \ {counter::histHtmlDisplayBarChart $tag histogram $max $curIndex $time} \ [array get options]] } # Close the right hand column, but leave our caller's table open. append result
\n" set ix [lsort -integer [array names histogram]] for {set t $options(-min)} {$t < $options(-max)} {incr t} { if {![info exists histogram($t)]} { set value 0 } else { set value $histogram($t) } if {$max == 0 || $value == 0} { set height 1 } else { set percent [expr {round($value * 100.0 / $max)}] set height [expr {$percent * $options(-height) / 100}] } if {$t == $curIndex} { set img src=$options(-images)/$options(-ongif) } else { set img src=$options(-images)/$options(-gif) } append result "\n" } append result "" # Count buckets outside the range requested set overflow 0 set underflow 0 foreach t [lsort -integer [array names histogram]] { if {($options(-max) > 0) && ($t > $options(-max))} { incr overflow } if {($options(-min) >= 0) && ($t < $options(-min))} { incr underflow } } # Append a row of labels at the bottom. set colors {black #CCCCCC} set bgcolors {#CCCCCC black} set colori 0 if {$counter(type) != "-timehist"} { # Label each bucket with its value # This is probably wrong for hist2x and hist10x append result "" set skip $options(-skip) if {![info exists counter(mult)]} { set counter(mult) 1 } # These are tick marks set img src=$options(-images)/$options(-gif) append result "" for {set i $options(-min)} {$i < $options(-max)} {incr i} { if {(($i % $skip) == 0)} { append result "\n" } else { append result "" } } append result # These are the labels append result "" for {set i $options(-min)} {$i < $options(-max)} {incr i} { if {$counter(type) == "-histlog"} { if {[catch {expr {int(log($i) * $counter(bucketsize))}} x]} { # Out-of-bounds break } } else { set x [expr {$i * $counter(bucketsize) * $counter(mult)}] } set label [format $options(-format) $x] if {(($i % $skip) == 0)} { set color [lindex $colors $colori] set bg [lindex $bgcolors $colori] set colori [expr {($colori+1) % 2}] append result "" } } append result } else { switch -glob -- $options(-unit) { min* { if {$secsPerMinute != 60} { set format %k:%M:%S set skip 12 } else { set format %k:%M set skip 4 } set deltaT $secsPerMinute set wrapDeltaT [expr {$secsPerMinute * -59}] } hour* { if {$secsPerMinute != 60} { set format %k:%M set skip 4 } else { set format %k set skip 2 } set deltaT [expr {$secsPerMinute * 60}] set wrapDeltaT [expr {$secsPerMinute * 60 * -23}] } day* { if {$secsPerMinute != 60} { set format "%m/%d %k:%M" set skip 10 } else { set format %k set skip $options(-skip) } set deltaT [expr {$secsPerMinute * 60 * 24}] set wrapDeltaT 0 } default {#ignore} } # These are tick marks set img src=$options(-images)/$options(-gif) append result "" foreach t [lsort -integer [array names histogram]] { if {(($t % $skip) == 0)} { append result "\n" } else { append result "" } } append result set lastLabel "" append result "" foreach t [lsort -integer [array names histogram]] { # Label each bucket with its time set label [clock format $time -format $format] if {(($t % $skip) == 0) && ($label != $lastLabel)} { set color [lindex $colors $colori] set bg [lindex $bgcolors $colori] set colori [expr {($colori+1) % 2}] append result "" set lastLabel $label } if {$t == $curIndex} { incr time $wrapDeltaT } else { incr time $deltaT } } append result \n } append result "
$value
$label
$label
" if {$underflow > 0} { append result "
Skipped $underflow samples <\ [expr {$options(-min) * $counter(bucketsize)}]\n" } if {$overflow > 0} { append result "
Skipped $overflow samples >\ [expr {$options(-max) * $counter(bucketsize)}]\n" } return $result } # ::counter::start -- # # Start an interval timer. This should be pre-declared with # type either -hist, -hist2x, or -hist20x # # Arguments: # tag The counter identifier. # instance There may be multiple intervals outstanding # at any time. This serves to distinquish them. # # Results: # None # # Side Effects: # Records the starting time for the instance of this interval. proc ::counter::start {tag instance} { upvar #0 counter::Time-$tag time # clock clicks can return negative values if the sign bit is set # Here we turn it into a 31-bit counter because we only want # relative differences set msec [expr {[clock clicks -milliseconds] & 0x7FFFFFFF}] set time($instance) [list $msec [clock seconds]] } # ::counter::stop -- # # Record an interval timer. # # Arguments: # tag The counter identifier. # instance There may be multiple intervals outstanding # at any time. This serves to distinquish them. # func An optional function used to massage the time # stamp before putting into the histogram. # # Results: # None # # Side Effects: # Computes the current interval and adds it to the histogram. proc ::counter::stop {tag instance {func ::counter::Identity}} { upvar #0 counter::Time-$tag time if {![info exists time($instance)]} { # Extra call. Ignore so we can debug error cases. return } set msec [expr {[clock clicks -milliseconds] & 0x7FFFFFFF}] set now [list $msec [clock seconds]] set delMicros [expr {[lindex $now 0] - [lindex $time($instance) 0]}] if {$delMicros < 0} { # Microsecond counter wrapped. set delMicros [expr {0x7FFFFFFF - [lindex $time($instance) 0] + [lindex $now 0]}] } set delSecond [expr {[lindex $now 1] - [lindex $time($instance) 1]}] unset time($instance) # It is quite possible that the millisecond counter is much # larger than 1000, so we just use it unless our microsecond # calculation is screwed up. if {$delMicros >= 0} { counter::count $tag [$func [expr {$delMicros / 1000.0}]] } else { counter::count $tag [$func $delSecond] } } # ::counter::Identity -- # # Return its argument. This is used as the default function # to apply to an interval timer. # # Arguments: # x Some value. # # Results: # $x # # Side Effects: # None proc ::counter::Identity {x} { return $x } package provide counter 2.0.4 tcllib-1.15/modules/counter/counter.man0000644000175000017500000001656112077663115017553 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin counter n 2.0.4] [moddesc {Counters and Histograms}] [titledesc {Procedures for counters and histograms}] [category {Data structures}] [require Tcl 8] [require counter [opt 2.0.4]] [description] [para] The [package counter] package provides a counter facility and can compute statistics and histograms over the collected data. [list_begin definitions] [call [cmd ::counter::init] [arg {tag args}]] This defines a counter with the name [arg tag]. The [arg args] determines the characteristics of the counter. The [arg args] are [list_begin definitions] [def "[option -group] [arg name]"] Keep a grouped counter where the name of the histogram bucket is passed into [cmd ::counter::count]. [def "[option -hist] [arg bucketsize]"] Accumulate the counter into histogram buckets of size [arg bucketsize]. For example, if the samples are millisecond time values and [arg bucketsize] is 10, then each histogram bucket represents time values of 0 to 10 msec, 10 to 20 msec, 20 to 30 msec, and so on. [def "[option -hist2x] [arg bucketsize]"] Accumulate the statistic into histogram buckets. The size of the first bucket is [arg bucketsize], each other bucket holds values 2 times the size of the previous bucket. For example, if [arg bucketsize] is 10, then each histogram bucket represents time values of 0 to 10 msec, 10 to 20 msec, 20 to 40 msec, 40 to 80 msec, and so on. [def "[option -hist10x] [arg bucketsize]"] Accumulate the statistic into histogram buckets. The size of the first bucket is [arg bucketsize], each other bucket holds values 10 times the size of the previous bucket. For example, if [arg bucketsize] is 10, then each histogram bucket represents time values of 0 to 10 msec, 10 to 100 msec, 100 to 1000 msec, and so on. [def "[option -lastn] [arg N]"] Save the last [arg N] values of the counter to maintain a "running average" over the last [arg N] values. [def "[option -timehist] [arg secsPerMinute]"] Keep a time-based histogram. The counter is summed into a histogram bucket based on the current time. There are 60 per-minute buckets that have a size determined by [arg secsPerMinute], which is normally 60, but for testing purposes can be less. Every "hour" (i.e., 60 "minutes") the contents of the per-minute buckets are summed into the next hourly bucket. Every 24 "hours" the contents of the per-hour buckets are summed into the next daily bucket. The counter package keeps all time-based histograms in sync, so the first [arg secsPerMinute] value seen by the package is used for all subsequent time-based histograms. [list_end] [call [cmd ::counter::count] [arg tag] [opt [arg delta]] [opt [arg instance]]] Increment the counter identified by [arg tag]. The default increment is 1, although you can increment by any value, integer or real, by specifying [arg delta]. You must declare each counter with [cmd ::counter::init] to define the characteristics of counter before you start to use it. If the counter type is [option -group], then the counter identified by [arg instance] is incremented. [call [cmd ::counter::start] [arg {tag instance}]] Record the starting time of an interval. The [arg tag] is the name of the counter defined as a [option -hist] value-based histogram. The [arg instance] is used to distinguish this interval from any other intervals that might be overlapping this one. [call [cmd ::counter::stop] [arg {tag instance}]] Record the ending time of an interval. The delta time since the corresponding [cmd ::counter::start] call for [arg instance] is recorded in the histogram identified by [arg tag]. [call [cmd ::counter::get] [arg {tag args}]] Return statistics about a counter identified by [arg tag]. The [arg args] determine what value to return: [list_begin definitions] [def [option -total]] Return the total value of the counter. This is the default if [arg args] is not specified. [def [option -totalVar]] Return the name of the total variable. Useful for specifying with -textvariable in a Tk widget. [def [option -N]] Return the number of samples accumulated into the counter. [def [option -avg]] Return the average of samples accumulated into the counter. [def [option -avgn]] Return the average over the last [arg N] samples taken. The [arg N] value is set in the [cmd ::counter::init] call. [def "[option -hist] [arg bucket]"] If [arg bucket] is specified, then the value in that bucket of the histogram is returned. Otherwise the complete histogram is returned in array get format sorted by bucket. [def [option -histVar]] Return the name of the histogram array variable. [def [option -histHour]] Return the complete hourly histogram in array get format sorted by bucket. [def [option -histHourVar]] Return the name of the hourly histogram array variable. [def [option -histDay]] Return the complete daily histogram in array get format sorted by bucket. [def [option -histDayVar]] Return the name of the daily histogram array variable. [def [option -resetDate]] Return the clock seconds value recorded when the counter was last reset. [def [option -all]] Return an array get of the array used to store the counter. This includes the total, the number of samples (N), and any type-specific information. This does not include the histogram array. [list_end] [call [cmd ::counter::exists] [arg tag]] Returns 1 if the counter is defined. [call [cmd ::counter::names]] Returns a list of all counters defined. [call [cmd ::counter::histHtmlDisplay] [arg {tag args}]] Generate HTML to display a histogram for a counter. The [arg args] control the format of the display. They are: [list_begin definitions] [def "[option -title] [arg string]"] Label to display above bar chart [def "[option -unit] [arg unit]"] Specify [const minutes], [const hours], or [const days] for the time-base histograms. For value-based histograms, the [arg unit] is used in the title. [def "[option -images] [arg url]"] URL of /images directory. [def "[option -gif] [arg filename]"] Image for normal histogram bars. The [arg filename] is relative to the [option -images] directory. [def "[option -ongif] [arg filename]"] Image for the active histogram bar. The [arg filename] is relative to the [option -images] directory. [def "[option -max] [arg N]"] Maximum number of value-based buckets to display. [def "[option -height] [arg N]"] Pixel height of the highest bar. [def "[option -width] [arg N]"] Pixel width of each bar. [def "[option -skip] [arg N]"] Buckets to skip when labeling value-based histograms. [def "[option -format] [arg string]"] Format used to display labels of buckets. [def "[option -text] [arg boolean]"] If 1, a text version of the histogram is dumped, otherwise a graphical one is generated. [list_end] [call [cmd ::counter::reset] [arg {tag args}]] Resets the counter with the name [arg tag] to an initial state. The [arg args] determine the new characteristics of the counter. They have the same meaning as described for [cmd ::counter::init]. [list_end] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph counter] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords statistics histogram counting tallying] [manpage_end] tcllib-1.15/modules/wip/0000755000175000017500000000000012104363635014501 5ustar sergeisergeitcllib-1.15/modules/wip/ChangeLog0000644000175000017500000000612612104363437016260 0ustar sergeisergei2013-02-01 Andreas Kupries * * Released and tagged Tcllib 1.15 ======================== * 2011-12-13 Andreas Kupries * * Released and tagged Tcllib 1.14 ======================== * 2011-01-24 Andreas Kupries * * Released and tagged Tcllib 1.13 ======================== * 2010-04-07 Andreas Kupries * wip2.tcl (run_next_*): Fixed the run_next_ commands to stop * wip.tcl: when detecting the end of the program. New feature, * wip.man: a callback to handle unknown command words, defaults * pkgIndex.tcl: to throwing an error. Updated documentation. Bumped versions to 1.2 and 2.2. 2010-04-05 Andreas Kupries * wip2.tcl (run_next_if, run_nextifnot): Extended API, two * wip.tcl (run_next_if, run_nextifnot): more run_next_ * wip.man: commands to run a single following command instead * pkgIndex.tcl: of all acceptable. Updated documentation. Bumped versions to 1.1.3 and 2.1.3. 2009-12-07 Andreas Kupries * * Released and tagged Tcllib 1.12 ======================== * 2009-10-27 Andreas Kupries * wip.tcl: Made sure that wip classes are in the global * wip2.tcl: namespace. 2009-03-02 Andreas Kupries * wip.man: Made the use of 'wip' class in the snit macro * wip.tcl: 'wip::dsl' fully qualified to prevent mis-resolutions * wip2.tcl: of the name in case the user is a '...::wip' class * pkgIndex.tcl: itself. In snit say this would resolve to the user instead of the wip interpreter. Bumped the versions to 1.1.2 and 2.1.2 respectively. 2008-12-12 Andreas Kupries * * Released and tagged Tcllib 1.11.1 ======================== * 2008-10-16 Andreas Kupries * * Released and tagged Tcllib 1.11 ======================== * 2008-09-03 Andreas Kupries * wip.tcl: Changed the name of the wip processor component added * wip2.tcl: to DSL system, prevent it from clashing with the name * pkgIndex.tcl: of the wip-core snit::type. Bumped the versions to * wip.man: 1.1.1 and 2.1.1. 2007-10-26 Andreas Kupries * wip.tcl: Extended error reporting, and fixes of bad indices in * wip2.tcl: the methods manipulating the program (insert, push, etc). wip v2 only extended error reporting. * wip.tcl: Extended with method to undef DSL commands. * wip2.tcl: Updated both variants, and the documentation. * wip.man: Bumped versions to 1.1 and 2.1 respectively. * pkgIndex.tcl: 2007-09-12 Andreas Kupries * * Released and tagged Tcllib 1.10 ======================== * 2007-07-30 Andreas Kupries * wip.man: Fixed bugs uncovered during test of * wip.tcl: first user, fileutil::multi::op. * wip2.tcl: 2007-07-27 Andreas Kupries * New Module. tcllib-1.15/modules/wip/pkgIndex.tcl0000644000175000017500000000037612077663116016772 0ustar sergeisergeiif {![package vsatisfies [package provide Tcl] 8.4]} {return} package ifneeded wip 1.2 [list source [file join $dir wip.tcl]] if {![package vsatisfies [package provide Tcl] 8.5]} {return} package ifneeded wip 2.2 [list source [file join $dir wip2.tcl]] tcllib-1.15/modules/wip/wip.tcl0000644000175000017500000003173612077663116016024 0ustar sergeisergei# ### ### ### ######### ######### ######### ## # (c) 2008-2009 Andreas Kupries. # WIP = Word Interpreter (Also a Work In Progress :). Especially while # it is running :P # Micro interpreter for lists of words. Domain specific languages # based on this will have a bit of a Forth feel, with the input stream # segmented into words and any other structuring left to whatever # language. Note that we have here in essence only the core dispatch # loop, and no actual commands whatsoever, making this definitely only # a Forth feel and not an actual Forth. # The idea is derived from Colin McCormack's treeql processor, # modified to require less boiler plate within the command # implementations, at the expense of, likely, execution speed. In # addition the interface between processor core and commands is more # complex too. # ### ### ### ######### ######### ######### ## Requisites package require Tcl 8.4 # For Tcl 8.{3,4} only snit1 of a suitable patchlevel is possible. package require snit 1.3 # The run_next_* methods use set operations (x in set) package require struct::set # ### ### ### ######### ######### ######### ## API & Implementation snit::type ::wip { # ### ### ### ######### ######### ######### ## API constructor {e args} {} ; # create processor # Defining commands and where they dispatch to. method def {name {cp {}}} {} ; # Define a DSL command. method def/ {name arity {cp {}}} {} ; # Ditto, with explicit arity. method defl {names} {} ; # Def many, simple names (cp = name) method defd {dict} {} ; # s.a. name/cp dict method deflva {args} {} ; # s.a. defl, var arg form method defdva {args} {} ; # s.a. defd, var arg form method undefva {args} {} ; # Remove DSL commands from the map. method undefl {names} {} ; # Ditto, names given as list. # Execution of word lists. method runl {alist} {} ; # execute list of words method run {args} {} ; # ditto, words as varargs method run_next {} {} ; # run the next command in the input. method run_next_while {accept} {} ; # s.a., while acceptable command method run_next_until {reject} {} ; # s.a., until rejectable command method run_next_if {accept} {} ; # s.a., if acceptable command method run_next_ifnot {reject} {} ; # s.a., if not rejectable command # Manipulation of the input word list. method peek {} {} ; # peek at next word in input method next {} {} ; # pull next word from input method insert {at args} {} ; # insert words back into the input method push {args} {} ; # ditto, at == 0 # ### ### ### ######### ######### ######### ## Processor construction. constructor {e args} { if {$e eq ""} { return -code error "No engine specified" } set engine $e $self unknown [mymethod ErrorForUnknown] $self Definitions $args return } method Definitions {alist} { # args = series of 'def name' and 'def name cp' statements. # The code to handle them is in essence a WIP too, just # hardcoded, as state machine. set state expect-def set n {} set cp {} foreach a $alist { if {$state eq "expect-def"} { if {$a ne "def"} { return -code error "Expected \"def\", got \"$a\"" } set state get-name } elseif {$state eq "get-name"} { set name $a set state get-cp-or-def } elseif {$state eq "get-cp-or-def"} { # This means that 'def' cannot be a command prefix for # DSL command. if {$a eq "def"} { # Short definition, name only, completed. $self def $name # We already have the first word of the next # definition here, name is coming up next. set state get-name } else { # Long definition, name + cp, completed. $self def $name $a # Must be followed by the next definition. set state expect-def } } } if {$state eq "get-cp-or-def"} { # Had a short definition last, now complete. $self def $name } elseif {$state eq "get-name"} { # Incomplete definition at the end, bogus return -code error "Incomplete definition at end, name missing." } return } # ### ### ### ######### ######### ######### ## Processor state ## Handle of the object incoming commands are dispatched to. ## The currently active DSL code, i.e. word list. variable unknown {} ; # command prefix invoked when # encountering unknown command words. variable engine {} ; # command variable program {} ; # list (string) variable arity -array {} ; # array (command name -> command arity) variable cmd -array {} ; # array (command name -> method cmd prefix) # ### ### ### ######### ######### ######### ## API: DSL definition ## DSL words map to method-prefixes, i.e. method names + fixed ## arguments. We store them with the engine already added in front ## to make them regular command prefixes. No 'mymethod' however, ## that works only in engine code itself, not form the outside. method def {name {mp {}}} { if {$mp eq {}} { # Derive method-prefix from DSL word. set mp [list $name] set m $name set n 0 } else { # No need to check for an empty method-prefix. That cannot # happen, as it is diverted, see above. set m [lindex $mp 0] set n [expr {[llength $mp]-1}] } # Get method arguments, check for problems. set a [$engine info args $m] if {[lindex $a end] eq "args"} { return -code error "Unable to handle Tcl varargs" } # The arity of the command is number of required arguments, # with compensation for those already covered by the # method-prefix. set cmd($name) [linsert $mp 0 $engine] set arity($name) [expr {[llength $a] - $n}] return } method def/ {name ay {mp {}}} { # Like def, except that the arity is specified # explicitly. This is for methods with a variable number of # arguments in their definition, possibly dependent on the # fixed parts of the prefix. if {$mp eq {}} { # Derive method-prefix from DSL word. set mp [list $name] set m $name } else { # No need to check for an empty method-prefix. That cannot # happen, as it is diverted, see above. set m [lindex $mp 0] } # The arity of the command is specified by the caller. set cmd($name) [linsert $mp 0 $engine] set arity($name) $ay return } method deflva {args} { $self defl $args ; return } method defdva {args} { $self defd $args ; return } method defl {names} { foreach n $names { $self def $n } ; return } method defd {dict} { if {[llength $dict]%2==1} { return -code error "Expected a dictionary, got \"$dict\"" } foreach {name mp} $dict { $self def $name $mp } return } method undefva {args} { $self undefl $args ; return } method undefl {names} { foreach name $names { unset -nocomplain cmd($name) unset -nocomplain arity($name) } return } # ### ### ### ######### ######### ######### ## API: DSL execution # ## Consider moving the core implementation into procs, to reduce ## call overhead method run {args} { return [$self runl $args] } method runl {alist} { # Note: We are saving the current program and restore it # afterwards, this handles the possibility that this is a # recursive call into the dispatcher. set saved $program set program $alist set r {} while {[llength $program]} { set r [$self run_next] } set program $saved return $r } method run_next_while {accept} { set r {} while {[llength $program] && [struct::set contains $accept [$self peek]]} { set r [$self run_next] } return $r } method run_next_until {reject} { set r {} while {[llength $program] && ![struct::set contains $reject [$self peek]]} { set r [$self run_next] } return $r } method run_next_if {accept} { set r {} if {[llength $program] && [struct::set contains $accept [$self peek]]} { set r [$self run_next] } return $r } method run_next_ifnot {reject} { set r {} if {[llength $program] && ![struct::set contains $reject [$self peek]]} { set r [$self run_next] } return $r } method run_next {} { # The first word in the list is the current command. Determine # the number of its fixed arguments. This also checks command # validity in general. set c [lindex $program 0] if {![info exists arity($c)]} { # Invoke the unknown handler return [uplevel #0 [linsert $unknown end $c]] } set n $arity($c) set m $cmd($c) # Take the fixed arguments from the input as well. if {[llength $program] <= $n} { return -code error -errorcode WIP \ "Not enough arguments for command \"$c\"" } set cargs [lrange $program 1 $n] incr n # Remove the command to dispatch, and its fixed arguments from # the program. This is done before the dispatch so that the # command has access to the true current state of the input. set program [lrange $program $n end] # Now run the command with its arguments. Commands needing # more than the declared fixed number of arguments are # responsible for reading them from input via the method # 'next' provided by the processor core. # Note: m already has the engine at the front, it was stored # that way, see 'def'. if {![llength $cargs]} { return [eval $m] } else { # Explanation: First linsert constructs 'linsert $m end {*}$cargs', # which the inner eval transforms into '{*}$m {*}$cargs', which at # last is run by the outer eval. return [eval [eval [linsert $cargs 0 linsert $m end]]] } } # ### ### ### ######### ######### ######### ## Input manipulation # Get next word from the input (shift) method next {} { set w [lindex $program 0] set program [lrange $program 1 end] return $w } # Peek at the next word in the input method peek {} { return [lindex $program 0] } # Retrieve the whole current program method peekall {} { return $program } # Replace the current programm method replace {args} { set program $args return } method replacel {alist} { set program $alist return } # Insert words into the input stream. method insert {at args} { set program [eval [linsert $args 0 linsert $program $at]] return } method insertl {at alist} { set program [eval [linsert $alist 0 linsert $program $at]] return } # <=> insert 0 method push {args} { set program [eval [linsert $args 0 linsert $program 0]] return } method pushl {alist} { set program [eval [linsert $alist 0 linsert $program 0]] return } # <=> insert end method add {args} { set program [eval [linsert $args 0 linsert $program end]] return } method addl {alist} { set program [eval [linsert $alist 0 linsert $program end]] return } # ### ### ### ######### ######### ######### method unknown {cmdprefix} { set unknown $cmdprefix return } method ErrorForUnknown {word} { return -code error -errorcode WIP \ "Unknown command \"$word\"" } ## # ### ### ### ######### ######### ######### } # ### ### ### ######### ######### ######### ## # Macro to declare the method of a component as proc. We use this # later to make access to a WIP processor simpler (no need to write # the component reference on our own). And no, this is not the same as # the standard delegation. Doing that simply replaces the component # name in the call with '$self'. We remove the need to have this # written in the call. snit::macro wip::methodasproc {var method suffix} { proc $method$suffix {args} [string map [list @v@ $var @m@ $method] { upvar 1 {@v@} dst return [eval [linsert $args 0 $dst {@m@}]] }] } # ### ### ### ######### ######### ######### ## Ready # ### ### ### ######### ######### ######### ## # Macro to install most of the boilerplate needed to setup and use a # WIP. The only thing left is to call the method 'wip_setup' in the # constructor of the class using WIP. This macro allows the creation # of multiple wip's, through custom suffices. snit::macro wip::dsl {{suffix {}}} { if {$suffix ne ""} {set suffix _$suffix} # Instance state, wip processor used to run the language component mywip$suffix # Standard method to create the processor component. The user has # to manually add a call of this method to the constructor. method wip${suffix}_setup {} [string map [list @@ $suffix] { install {mywip@@} using ::wip "${selfns}::mywip@@" $self }] # Procedures for easy access to the processor methods, without # having to use self and wip. I.e. special delegation. foreach {p} { add addl def undefva undefl defd defdva defl deflva def/ insert insertl replace replacel push pushl run runl next peek peekall run_next run_next_until run_next_while run_next_ifnot run_next_if } { wip::methodasproc mywip$suffix $p $suffix } return } # ### ### ### ######### ######### ######### ## Ready package provide wip 1.2 tcllib-1.15/modules/wip/wip.man0000644000175000017500000003026112077663116016005 0ustar sergeisergei[comment {-*- text -*-}] [manpage_begin wip n 2.2] [copyright {2007-2010 Andreas Kupries }] [moddesc {Word Interpreter}] [titledesc {Word Interpreter}] [category {Programming tools}] [require Tcl 8.4] [require wip [opt 2.2]] [require snit [opt 1.3]] [require struct::set] [description] [para] This package provides a micro interpreter for lists of words. Domain specific languages based on this will have a bit of a Forth feel, with the input stream segmented into words and any other structuring left to whatever the language desired. Note that we have here in essence only the core dispatch loop, and no actual commands whatsoever, making this definitely only a Forth feel and not an actual Forth. [para] The idea is derived from Colin McCormack's [package treeql] processor, modified to require less boiler plate within the command implementations, at the expense of, likely, execution speed. In addition the interface between processor core and commands is more complex too. [section {GENERAL BEHAVIOUR}] Word interpreters have a mappping from the names of the language commands they shall recognize to the methods in the engine to invoke for them, and possibly fixed arguments for these methods. This mapping is largely static, however it is possible to change it during the execution of a word list (= program). [para] At the time a language command is defined the word interpreter will use [package snit]'s introspection capabilities to determine the number of arguments expected by the method of the egnine, and together with the number of fixed arguments supplied in the method prefix of the mapping it then knows how many arguments the language command is expecting. This is the command's [term arity]. Variable-argument methods (i.e. with the last argument named [arg args]) are [emph not] allowed and will cause the word interpreter to throw an error at definition time. [para] Note that while I said [package snit]'s abilities the engine object can be written in any way, as long as it understands the method [method {info args}], which takes a method name and returns the list of arguments for that method. [para] When executing a list of words (aka program) the first word is always taken as the name of a language command, and the next words as its arguments, per the [term arity] of the command. Command and argument words are removed from the list and then associated method of the engine is executed with the argument words. The process then repeats using the then-first word of the list. [para] Note that the methods implementing the language commands may have full access to the list of words and are allowed to manipulate as they see fit. [list_begin enum] [enum] This means, for example, that while we cannot specify variable-argument methods directly they can consume words after their fixed arguments before returning to the execution loop. This may be under the control of their fixed arguments. [enum] Another possibility is the use of method [method run_next] and its variants to execute commands coming after the current command, changing the order of execution. [enum] Execution can be further changed by use of the program accessor methods which allow a command implementation to modify the remaining list of words (insert, replace, prepend, append words) without executing them immediately. [enum] At last the basic [method run] methods save and restore an existing list of words when used, enabling recursive use from within command implementations. [list_end] [section {CLASS API}] The main command of the package is: [list_begin definitions] [call [cmd ::wip] [arg wipName] [arg engine] [arg arg]...] The command creates a new word interpreter object with an associated global Tcl command whose name is [arg wipName]. If however the string [const %AUTO%] was used as object name the package will generate its own unique name for the object. [para] The [arg engine] is the object the word interpreter will dispatch all recognized commands to, and the [arg arg]uments are a word list which defines an initial mapping from language words to engine methods. [para] The recognized language of this word list is [list_begin definitions] [call [cmd def] [arg name]] Defines [arg name] as command of the language, to be mapped to a method of the [arg engine] having the same name. [call [cmd def] [arg name] [arg method_prefix]] Defines [arg name] as command of the language, to be mapped to the method of the [arg engine] named in the [arg method_prefix]. [list_end] [para] The returned command may be used to invoke various operations on the object. It has the following general form: [list_begin definitions] [call [cmd wipName] [arg option] [opt [arg "arg arg ..."]]] [arg Option] and the [arg arg]s determine the exact behavior of the command. [list_end] [list_end] The package additionally exports the command: [list_begin definitions] [call [cmd wip::dsl] [opt [arg suffix]]] This command is for use within snit types which wish to use one or more wip interpreters as a component. Use within the type definition installs most of the boilerplate needed to setup and use a word interpreter. [para] It installs a component named [emph wip], and a method [method wip_setup] for initializing it. This method has to be called from within the constructor of the type using the word interpreter. If further installs a series of procedures which make the object API of the word interpreter directly available to the type's methods, without having to specify the component. [para] [emph Note] that this does and cannot install the language to interpret, i.e. the mapping from words to engine methods. [para] It is possible to instantiate multiple word interpreter components within a type by using different suffices as arguments to the command. In that case the name of the component changes to 'wip_[var \$suffix]', the setup command becomes 'wip_[var \$suffix]_setup' and all the procedures also get the suffix '_[var \$suffix]'. [list_end] [section {OBJECT API}] The following commands are possible for word interpreter objects: [list_begin definitions] [call [arg wipName] [method def] [arg name] [opt [arg method_prefix]]] Defines a language command [arg name] and maps it to the method named in the engine's [arg method_prefix]. If the [arg method_prefix] name is not specified it is simply the name of the language command. [call [arg wipName] [method defl] [arg names]] Defines a series of language commands, specified through the list of [arg names], all of which are mapped to engine methods of the same name. [call [arg wipName] [method defd] [arg dict]] Defines a series of language commands, specified through the dictionary [arg dict] of names and method prefixes. [call [arg wipName] [method deflva] [arg name]...] As method [method defl], however the list of names is specified through multiple arguments. [call [arg wipName] [method defdva] ([arg name] [arg method_prefix])...] As method [method defd], however the dictionary of names and method prefixes is specified through multiple arguments. [call [arg wipName] [method undefl] [arg names]] Removes the named series of language commands from the mapping. [call [arg wipName] [method undefva] [arg name]...] As method [method undefl], however the list of names is specified through multiple arguments. [call [arg wipName] [method unknown] [arg cmdprefix]] Sets the handler for unknown words to [arg cmdprefix]. This command prefix takes one argument, the current word, and either throws some error, or returns the result of executing the word, as defined by the handler. The default handler simply throws an error. [call [arg wipName] [method runl] [arg wordlist]] Treats the list of words in [arg wordlist] as a program and executes the contained command one by one. The result of the command executed last is returned as the result of this command. [para] The [arg wordlist] is stored in the object for access by the other [term run]-methods, and the general program accessor methods (see below). A previously stored wordlist is saved during the execution of this method and restored before it returns. This enables the recursive execution of word lists within word lists. [call [arg wipName] [method run] [arg word]...] As method [method runl], however the list of words to execute is specified through multiple arguments. [call [arg wipName] [method run_next]] Low-level method. Determines the next word in the list of words, and its arguments, and then executes it. The result of the executed word is the result of this method. [para] Exposed for use within command implementations. The methods [method run] and [method runl] use it to execute words until their word list is exhausted. [call [arg wipName] [method run_next_while] [arg acceptable]] Low-level method. Invokes the method [method run_next] as long as the next word is in the set of [arg acceptable] words, and the program is not empty. The result of the command executed last is returned as the result of this command. [para] Exposed for use within command implementations to change the order of execution. [call [arg wipName] [method run_next_until] [arg rejected]] Low-level method. Invokes the method [method run_next] until the next word is in the set of [arg rejected] words, and the program is not empty. The result of the command executed last is returned as the result of this command. [para] Exposed for use within command implementations to change the order of execution. [call [arg wipName] [method run_next_if] [arg acceptable]] Low-level method. Invokes the method [method run_next] if the next word is in the set of [arg acceptable] words, and the program is not empty. The result of the command executed last is returned as the result of this command. [para] Exposed for use within command implementations to change the order of execution. [call [arg wipName] [method run_next_ifnot] [arg rejected]] Low-level method. Invokes the method [method run_next] if the next word is not in the set of [arg rejected] words, and the program is not empty. The result of the command executed last is returned as the result of this command. [para] Exposed for use within command implementations to change the order of execution. [call [arg wipName] [method next]] Returns the next word in the programm. The word is also removed. [call [arg wipName] [method peek]] Returns the next word in the programm without removing it [call [arg wipName] [method peekall]] Returns the remaining programm in toto. [call [arg wipName] [method insertl] [arg at] [arg wordlist]] Basic programm accessor method. Inserts the specified [arg wordlist] into the program, just before the word at position [arg at]. Positions are counted from [const zero]. [call [arg wipName] [method replacel] [arg wordlist]] Basic programm accessor method. Replaces the whole stored program with the specified [arg wordlist]. [call [arg wipName] [method pushl] [arg wordlist]] Program accessor method. The specified [arg wordlist] is added to the front of the remaining program. Equivalent to [para] [example {$wip insertl 0 $wordlist}] [call [arg wipName] [method addl] [arg wordlist]] Program accessor method. The specified [arg wordlist] is appended at the end of the remaining program. Equivalent to [para] [example {$wip insertl end $wordlist}] [call [arg wipName] [method insert] [arg at] [arg word]...] Like method [method insertl], except the words are specified through multiple arguments. [call [arg wipName] [method replace] [arg word]...] Like method [method setl], except the words are specified through multiple arguments. [call [arg wipName] [method push] [arg word]...] Like method [method pushl], except the words are specified through multiple arguments. [call [arg wipName] [method add] [arg word]...] Like method [method addl], except the words are specified through multiple arguments. [list_end] [section EXAMPLES] No examples yet. [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph wip] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords word list interpreter] [manpage_end] tcllib-1.15/modules/wip/wip2.tcl0000644000175000017500000003163412077663116016103 0ustar sergeisergei# ### ### ### ######### ######### ######### ## # (c) 2008-2010 Andreas Kupries. # WIP = Word Interpreter (Also a Work In Progress :). Especially while # it is running :P # Micro interpreter for lists of words. Domain specific languages # based on this will have a bit of a Forth feel, with the input stream # segmented into words and any other structuring left to whatever # language. Note that we have here in essence only the core dispatch # loop, and no actual commands whatsoever, making this definitely only # a Forth feel and not an actual Forth. # The idea is derived from Colin McCormack's treeql processor, # modified to require less boiler plate within the command # implementations, at the expense of, likely, execution speed. In # addition the interface between processor core and commands is more # complex too. # ### ### ### ######### ######### ######### ## Requisites package require Tcl 8.5 # Use new Tcl 8.5a6+ features for specification of allowed packages. # We can use snit 1.3 and anything above (incl. v2+). package require snit 1.3- # The run_next_* methods use set operations (x in set) package require struct::set # For 8.5 we are using features like word-expansion to simplify the # various evaluations. Otherwise this is identical to v1. # ### ### ### ######### ######### ######### ## API & Implementation snit::type ::wip { # ### ### ### ######### ######### ######### ## API constructor {e args} {} ; # create processor # Defining commands and where they dispatch to. method def {name {cp {}}} {} ; # Define a DSL command. method def/ {name arity {cp {}}} {} ; # Ditto, with explicit arity. method defl {names} {} ; # Def many, simple names (cp = name) method defd {dict} {} ; # s.a. name/cp dict method deflva {args} {} ; # s.a. defl, var arg form method defdva {args} {} ; # s.a. defd, var arg form method undefva {args} {} ; # Remove DSL commands from the map. method undefl {names} {} ; # Ditto, names given as list. # Execution of word lists. method runl {alist} {} ; # execute list of words method run {args} {} ; # ditto, words as varargs method run_next {} {} ; # run the next command in the input. method run_next_while {accept} {} ; # s.a., while acceptable command method run_next_until {reject} {} ; # s.a., until rejectable command method run_next_if {accept} {} ; # s.a., if acceptable command method run_next_ifnot {reject} {} ; # s.a., if not rejectable command # Manipulation of the input word list. method peek {} {} ; # peek at next word in input method next {} {} ; # pull next word from input method insert {at args} {} ; # insert words back into the input method push {args} {} ; # ditto, at == 0 # Set callback for unknown command words. method unknown {commandprefix} {} # ### ### ### ######### ######### ######### ## Processor construction. constructor {e args} { if {$e eq ""} { return -code error "No engine specified" } set engine $e $self unknown [mymethod ErrorForUnknown] $self Definitions $args return } method Definitions {alist} { # args = series of 'def name' and 'def name cp' statements. # The code to handle them is in essence a WIP too, just # hardcoded, as state machine. set state expect-def set n {} set cp {} foreach a $alist { if {$state eq "expect-def"} { if {$a ne "def"} { return -code error "Expected \"def\", got \"$a\"" } set state get-name } elseif {$state eq "get-name"} { set name $a set state get-cp-or-def } elseif {$state eq "get-cp-or-def"} { # This means that 'def' cannot be a command prefix for # DSL command. if {$a eq "def"} { # Short definition, name only, completed. $self def $name # We already have the first word of the next # definition here, name is coming up next. set state get-name } else { # Long definition, name + cp, completed. $self def $name $a # Must be followed by the next definition. set state expect-def } } } if {$state eq "get-cp-or-def"} { # Had a short definition last, now complete. $self def $name } elseif {$state eq "get-name"} { # Incomplete definition at the end, bogus return -code error "Incomplete definition at end, name missing." } return } # ### ### ### ######### ######### ######### ## Processor state ## Handle of the object incoming commands are dispatched to. ## The currently active DSL code, i.e. word list. variable unknown {} ; # command prefix invoked when # encountering unknown command words. variable engine {} ; # command variable program {} ; # list (string) variable arity -array {} ; # array (command name -> command arity) variable cmd -array {} ; # array (command name -> method cmd prefix) # ### ### ### ######### ######### ######### ## API: DSL definition ## DSL words map to method-prefixes, i.e. method names + fixed ## arguments. We store them with the engine already added in front ## to make them regular command prefixes. No 'mymethod' however, ## that works only in engine code itself, not from the outside. method def {name {mp {}}} { if {$mp eq {}} { # Derive method-prefix from DSL word. set mp [list $name] set m $name set n 0 } else { # No need to check for an empty method-prefix. That cannot # happen, as it is diverted, see above. set m [lindex $mp 0] set n [expr {[llength $mp]-1}] } # Get method arguments, check for problems. set a [$engine info args $m] if {[lindex $a end] eq "args"} { return -code error "Unable to handle Tcl varargs" } # The arity of the command is the number of required # arguments, with compensation for those already covered by # the method-prefix. set cmd($name) [linsert $mp 0 $engine] set arity($name) [expr {[llength $a] - $n}] return } method def/ {name ay {mp {}}} { # Like def, except that the arity is specified # explicitly. This is for methods with a variable number of # arguments in their definition, possibly dependent on the # fixed parts of the prefix. if {$mp eq {}} { # Derive method-prefix from DSL word. set mp [list $name] set m $name } else { # No need to check for an empty method-prefix. That cannot # happen, as it is diverted, see above. set m [lindex $mp 0] } # The arity of the command is specified by the caller. set cmd($name) [linsert $mp 0 $engine] set arity($name) $ay return } method deflva {args} { $self defl $args ; return } method defdva {args} { $self defd $args ; return } method defl {names} { foreach n $names { $self def $n } ; return } method defd {dict} { if {[llength $dict]%2==1} { return -code error "Expected a dictionary, got \"$dict\"" } foreach {name mp} $dict { $self def $name $mp } return } method undefva {args} { $self undefl $args ; return } method undefl {names} { foreach name $names { unset -nocomplain cmd($name) unset -nocomplain arity($name) } return } # ### ### ### ######### ######### ######### ## API: DSL execution # ## Consider moving the core implementation into procs, to reduce ## call overhead method run {args} { return [$self runl $args] } method runl {alist} { # Note: We are saving the current program and restore it # afterwards, this handles the possibility that this is a # recursive call into the dispatcher. set saved $program set program $alist set r {} while {[llength $program]} { set r [$self run_next] } set program $saved return $r } method run_next_while {accept} { set r {} while {[llength $program] && [struct::set contains $accept [$self peek]]} { set r [$self run_next] } return $r } method run_next_until {reject} { set r {} while {[llength $program] && ![struct::set contains $reject [$self peek]]} { set r [$self run_next] } return $r } method run_next_if {accept} { set r {} if {[llength $program] && [struct::set contains $accept [$self peek]]} { set r [$self run_next] } return $r } method run_next_ifnot {reject} { set r {} if {[llength $program] && ![struct::set contains $reject [$self peek]]} { set r [$self run_next] } return $r } method run_next {} { # The first word in the list is the current command. Determine # the number of its fixed arguments. This also checks command # validity in general. set c [lindex $program 0] if {![info exists arity($c)]} { # Invoke the unknown handler set program [lrange $program 1 end] return [uplevel #0 [list {*}$unknown $c]] } set n $arity($c) set m $cmd($c) # Take the fixed arguments from the input as well. if {[llength $program] <= $n} { return -code error -errorcode WIP \ "Not enough arguments for command \"$c\"" } set cargs [lrange $program 1 $n] incr n # Remove the command to dispatch, and its fixed arguments from # the program. This is done before the dispatch so that the # command has access to the true current state of the input. set program [lrange $program $n end] # Now run the command with its arguments. Commands needing # more than the declared fixed number of arguments are # responsible for reading them from input via the method # 'next' provided by the processor core. # Note: m already has the engine at the front, it was stored # that way, see 'def'. return [{*}$m {*}$cargs] } # ### ### ### ######### ######### ######### ## Input manipulation # Get next word from the input (shift) method next {} { set w [lindex $program 0] set program [lrange $program 1 end] return $w } # Peek at the next word in the input method peek {} { return [lindex $program 0] } # Retrieve the whole current program method peekall {} { return $program } # Replace the current programm method replace {args} { set program $args return } method replacel {alist} { set program $alist return } # Insert words into the input stream. method insert {at args} { set program [linsert $program $at {*}$args] return } method insertl {at alist} { set program [linsert $program $at {*}$alist] return } # <=> insert 0 method push {args} { set program [linsert $program 0 {*}$args] return } method pushl {alist} { set program [linsert $program 0 {*}$alist] return } # <=> insert end method add {args} { set program [linsert $program end {*}$args] return } method addl {alist} { set program [linsert $program end {*}$alist] return } # ### ### ### ######### ######### ######### method unknown {cmdprefix} { set unknown $cmdprefix return } method ErrorForUnknown {word} { return -code error -errorcode WIP \ "Unknown command \"$word\"" } ## # ### ### ### ######### ######### ######### } # ### ### ### ######### ######### ######### ## # Macro to declare the method of a component as proc. We use this # later to make access to a WIP processor simpler (no need to write # the component reference on our own). And no, this is not the same as # the standard delegation. Doing that simply replaces the component # name in the call with '$self'. We remove the need to have this # written in the call. snit::macro wip::methodasproc {var method suffix} { proc $method$suffix {args} [string map [list @v@ $var @m@ $method] { upvar 1 {@v@} dst return [$dst {@m@} {*}$args] }] } # ### ### ### ######### ######### ######### ## Ready # ### ### ### ######### ######### ######### ## # Macro to install most of the boilerplate needed to setup and use a # WIP. The only thing left is to call the method 'wip_setup' in the # constructor of the class using WIP. This macro allows the creation # of multiple wip's, through custom suffices. snit::macro wip::dsl {{suffix {}}} { if {$suffix ne ""} {set suffix _$suffix} # Instance state, wip processor used to run the language component mywip$suffix # Standard method to create the processor component. The user has # to manually add a call of this method to the constructor. method wip${suffix}_setup {} [string map [list @@ $suffix] { install {mywip@@} using ::wip "${selfns}::mywip@@" $self }] # Procedures for easy access to the processor methods, without # having to use self and wip. I.e. special delegation. foreach {p} { add addl def undefva undefl defd defdva defl deflva def/ insert insertl replace replacel push pushl run runl next peek peekall run_next run_next_until run_next_while run_next_ifnot run_next_if } { wip::methodasproc mywip$suffix $p $suffix } return } # ### ### ### ######### ######### ######### ## Ready package provide wip 2.2 tcllib-1.15/modules/soundex/0000755000175000017500000000000012104363635015367 5ustar sergeisergeitcllib-1.15/modules/soundex/ChangeLog0000644000175000017500000000503012104363437017137 0ustar sergeisergei2013-02-01 Andreas Kupries * * Released and tagged Tcllib 1.15 ======================== * 2011-12-13 Andreas Kupries * * Released and tagged Tcllib 1.14 ======================== * 2011-01-24 Andreas Kupries * * Released and tagged Tcllib 1.13 ======================== * 2009-12-07 Andreas Kupries * * Released and tagged Tcllib 1.12 ======================== * 2008-12-12 Andreas Kupries * * Released and tagged Tcllib 1.11.1 ======================== * 2008-10-16 Andreas Kupries * * Released and tagged Tcllib 1.11 ======================== * 2008-06-14 Andreas Kupries * soundex.pcx: New file. Syntax definitions for the public commands of the soundex package. 2007-09-12 Andreas Kupries * * Released and tagged Tcllib 1.10 ======================== * 2007-03-21 Andreas Kupries * soundex.man: Fixed all warnings due to use of now deprecated commands. Added a section about how to give feedback. 2006-10-03 Andreas Kupries * * Released and tagged Tcllib 1.9 ======================== * 2006-01-26 Andreas Kupries * soundex.test: More boilerplate simplified via use of test support. 2006-01-19 Andreas Kupries * soundex.test: Hooked into the new common test support code. 2005-10-06 Andreas Kupries * * Released and tagged Tcllib 1.8 ======================== * 2004-10-05 Andreas Kupries * * Released and tagged Tcllib 1.7 ======================== * 2004-05-23 Andreas Kupries * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * 2003-05-05 Andreas Kupries * * Released and tagged Tcllib 1.4 ======================== * 2003-04-01 Andreas Kupries * soundex.tcl: New module for soundex algorithms. * soundex.man: * soundex.test: * pkgIndex.tcl: tcllib-1.15/modules/soundex/soundex.pcx0000644000175000017500000000130512077663116017575 0ustar sergeisergei# -*- tcl -*- soundex.pcx # Syntax of the commands provided by package soundex. # # For use by TclDevKit's static syntax checker (v4.1+). # See http://www.activestate.com/solutions/tcl/ # See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api # for the specification of the format of the code in this file. # package require pcx pcx::register soundex pcx::tcldep 1.0 needs tcl 8.2 namespace eval ::soundex {} #pcx::message FOO {... text ...} type #pcx::scan pcx::check 1.0 std ::soundex::knuth \ {checkSimpleArgs 1 1 { checkWord }} # Initialization via pcx::init. # Use a ::soundex::init procedure for non-standard initialization. pcx::complete tcllib-1.15/modules/soundex/pkgIndex.tcl0000644000175000017500000000113012077663116017645 0ustar sergeisergei# 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.2]} {return} package ifneeded soundex 1.0 [list source [file join $dir soundex.tcl]] tcllib-1.15/modules/soundex/soundex.man0000644000175000017500000000252212077663116017560 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin soundex n 1.0] [copyright {????, Algorithm: Donald E. Knuth}] [copyright {2003, Documentation: Andreas Kupries }] [copyright {1998, Tcl port: Evan Rempel }] [moddesc {Soundex}] [titledesc {Soundex}] [category {Hashes, checksums, and encryption}] [require Tcl 8.2] [require soundex [opt 1.0]] [description] [para] This package provides soundex algorithms which allow the comparison of words based on their phonetic likeness. [para] Currently only an algorithm by Knuth is provided, which is tuned to english names and words. [list_begin definitions] [call [cmd ::soundex::knuth] [arg string]] Computes the soundex code of the input [arg string] using Knuth's algorithm and returns it as the result of the command. [list_end] [section EXAMPLES] [example { % ::soundex::knuth Knuth K530 }] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph soundex] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords soundex knuth {text comparison} {text likeness}] [manpage_end] tcllib-1.15/modules/soundex/soundex.tcl0000644000175000017500000000624412077663116017574 0ustar sergeisergei# soundex.tcl -- # # Implementation of soundex in Tcl # # Copyright (c) 2003 by Andreas Kupries # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: soundex.tcl,v 1.3 2004/01/15 06:36:14 andreas_kupries Exp $ package require Tcl 8.2 namespace eval ::soundex {} ## ------------------------------------------------------------ ## ## I. Soundex by Knuth. # This implementation of the Soundex algorithm is released to the public # domain: anyone may use it for any purpose. See if I care. # N. Dean Pentcheff 1/13/89 Dept. of Zoology University of California Berkeley, # CA 94720 dean@violet.berkeley.edu # TCL port by Evan Rempel 2/10/98 Dept Comp Services University of Victoria. # erempel@uvic.ca # proc ::soundex::knuth ( string ) # # Given as argument: a character string. Returns: a static string, 4 characters long # This string is the Soundex key for the argument string. # Side effects and limitations: # Does not clobber the string passed in as the argument. No limit on # argument string length. Assumes a character set with continuously # ascending and contiguous letters within each case and within the digits # (e.g. this works for ASCII and bombs in EBCDIC. But then, most things # do.). Reference: Adapted from Knuth, D.E. (1973) The art of computer # programming; Volume 3: Sorting and searching. Addison-Wesley Publishing # Company: Reading, Mass. Page 392. # Special cases: Leading or embedded spaces, numerals, or punctuation are squeezed # out before encoding begins. # # Null strings or those with no encodable letters return the code 'Z000'. # # Test data from Knuth (1973): # Euler Gauss Hilbert Knuth Lloyd Lukasiewicz # E460 G200 H416 K530 L300 L222 namespace eval ::soundex { variable soundexKnuthCode array set soundexKnuthCode { a 0 b 1 c 2 d 3 e 0 f 1 g 2 h 0 i 0 j 2 k 2 l 4 m 5 n 5 o 0 p 1 q 2 r 6 s 2 t 3 u 0 v 1 w 0 x 2 y 0 z 2 } } proc ::soundex::knuth {in} { variable soundexKnuthCode set key "" # Remove the leading/trailing white space punctuation etc. set TempIn [string trim $in "\t\n\r .,'-"] # Only use alphabetic characters, so strip out all others # also, soundex index uses only lower case chars, so force to lower regsub -all {[^a-z]} [string tolower $TempIn] {} TempIn if {[string length $TempIn] == 0} { return Z000 } set last [string index $TempIn 0] set key [string toupper $last] set last $soundexKnuthCode($last) # Scan rest of string, stop at end of string or when the key is # full set count 1 set MaxIndex [string length $TempIn] for {set index 1} {(($count < 4) && ($index < $MaxIndex))} {incr index } { set chcode $soundexKnuthCode([string index $TempIn $index]) # Fold together adjacent letters sharing the same code if {![string equal $last $chcode]} { set last $chcode # Ignore code==0 letters except as separators if {$last != 0} then { set key $key$last incr count } } } return [string range ${key}0000 0 3] } package provide soundex 1.0 tcllib-1.15/modules/soundex/soundex.test0000644000175000017500000000234112077663116017763 0ustar sergeisergei# -*- tcl -*- # soundex.test: tests for the soundex commands. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 2003 by Andreas Kupries # # RCS: @(#) $Id: soundex.test,v 1.5 2006/10/09 21:41:42 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.2 testsNeedTcltest 1.0 testing { useLocal soundex.tcl soundex } # ------------------------------------------------------------------------- namespace import ::soundex::knuth # ------------------------------------------------------------------------- foreach {n in out} { 1.0 Euler E460 1.1 Gauss G200 1.2 Hilbert H416 1.3 Knuth K530 1.4 Lloyd L300 1.5 Lukasiewicz L222 } { test soundex-$n {knuth soundex} { ::soundex::knuth $in } $out } # ------------------------------------------------------------------------- testsuiteCleanup tcllib-1.15/modules/base64/0000755000175000017500000000000012104363635014766 5ustar sergeisergeitcllib-1.15/modules/base64/ascii85.man0000644000175000017500000000470712077663115016745 0ustar sergeisergei[manpage_begin ascii85 n 1.0] [copyright "2010, Emiliano Gavil\u00e1n"] [moddesc {Text encoding & decoding binary data}] [titledesc {ascii85-encode/decode binary data}] [category {Text processing}] [require Tcl 8.4] [require ascii85 [opt 1.0]] [description] [para] This package provides procedures to encode binary data into ascii85 and back. [list_begin definitions] [call [cmd ::ascii85::encode] [opt "[option -maxlen] [arg maxlen]"] [opt "[option -wrapchar] [arg wrapchar]"] [arg string]] Ascii85 encodes the given binary [arg string] and returns the encoded result. Inserts the character [arg wrapchar] every [arg maxlen] characters of output. [arg wrapchar] defaults to newline. [arg maxlen] defaults to [const 76]. [para] [emph {Note well}]: If your string is not simple ascii you should fix the string encoding before doing ascii85 encoding. See the examples. [para] The command will throw an error for negative values of [arg maxlen], or if [arg maxlen] is not an integer number. [call [cmd ::ascii85::decode] [arg "string"]] Ascii85 decodes the given [arg "string"] and returns the binary data. The decoder ignores whitespace in the string, as well as tabs and newlines. [list_end] [section {EXAMPLES}] [example { % ascii85::encode "Hello, world" 87cURD_*#TDfTZ) }] [example { % ascii85::encode [string repeat xyz 24] G^4U[H$X^\H?a^]G^4U[H$X^\H?a^]G^4U[H$X^\H?a^]G^4U[H$X^\H?a^]G^4U[H$X^\H?a^]G ^4U[H$X^\H?a^] % ascii85::encode -wrapchar "" [string repeat xyz 24] G^4U[H$X^\H?a^]G^4U[H$X^\H?a^]G^4U[H$X^\H?a^]G^4U[H$X^\H?a^]G^4U[H$X^\H?a^]G^4U[H$X^\H?a^] }] [example { # NOTE: ascii85 encodes BINARY strings. % set chemical [encoding convertto utf-8 "C\u2088H\u2081\u2080N\u2084O\u2082"] % set encoded [ascii85::encode $chemical] 6fN]R8E,5Pidu\UiduhZidua % set caffeine [encoding convertfrom utf-8 [ascii85::decode $encoded]] }] [section References] [list_begin enum] [enum] [uri http://en.wikipedia.org/wiki/Ascii85] [enum] Postscript Language Reference Manual, 3rd Edition, page 131. [uri http://www.adobe.com/devnet/postscript/pdfs/PLRM.pdf] [list_end] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph base64] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords encoding ascii85] [manpage_end] tcllib-1.15/modules/base64/base64.man0000644000175000017500000000441512077663115016560 0ustar sergeisergei[manpage_begin base64 n 2.4.2] [copyright {2000, Eric Melski}] [copyright {2001, Miguel Sofer}] [moddesc {Text encoding & decoding binary data}] [titledesc {base64-encode/decode binary data}] [category {Text processing}] [require Tcl 8] [require base64 [opt 2.4.2]] [description] [para] This package provides procedures to encode binary data into base64 and back. [list_begin definitions] [call [cmd ::base64::encode] [opt "[option -maxlen] [arg maxlen]"] [opt "[option -wrapchar] [arg wrapchar]"] [arg string]] Base64 encodes the given binary [arg string] and returns the encoded result. Inserts the character [arg wrapchar] every [arg maxlen] characters of output. [arg wrapchar] defaults to newline. [arg maxlen] defaults to [const 76]. [para] [emph Note] that if [arg maxlen] is set to [const 0], the output will not be wrapped at all. [para] [emph {Note well}]: If your string is not simple ascii you should fix the string encoding before doing base64 encoding. See the examples. [para] The command will throw an error for negative values of [arg maxlen], or if [arg maxlen] is not an integer number. [call [cmd ::base64::decode] [arg "string"]] Base64 decodes the given [arg "string"] and returns the binary data. The decoder ignores whitespace in the string. [list_end] [section {EXAMPLES}] [example { % base64::encode "Hello, world" SGVsbG8sIHdvcmxk }] [example { % base64::encode [string repeat xyz 20] eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6 eHl6eHl6eHl6 % base64::encode -wrapchar "" [string repeat xyz 20] eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6 }] [example { # NOTE: base64 encodes BINARY strings. % set chemical [encoding convertto utf-8 "C\u2088H\u2081\u2080N\u2084O\u2082"] % set encoded [base64::encode $chemical] Q+KCiEjigoHigoBO4oKET+KCgg== % set caffeine [encoding convertfrom utf-8 [base64::decode $encoded]] }] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph base64] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords encoding base64] [manpage_end] tcllib-1.15/modules/base64/ascii85.test0000644000175000017500000001633212077663115017146 0ustar sergeisergei# Tests for the base64 module. -*- tcl -*- # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1998-2000 by Ajuba Solutions. # All rights reserved. # # RCS: @(#) $Id: ascii85.test,v 1.1 2010/05/03 21:48:39 andreas_kupries Exp $ # ------------------------------------------------------------------------- package require tcltest source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.4 testsNeedTcltest 1.0 testing { useLocal ascii85.tcl ascii85 } # ------------------------------------------------------------------------- # Encoding tests # ------------------------------------------------------------------------- test ascii85-1.1 {ascii85::encode} { ascii85::encode "this is a test\n" } {FD,B0+DGm>@3BZ'F*%`} test ascii85-1.2 {ascii85::encode wraps lines at 76 characters} { set str "The short red fox ran quickly through the green field " append str "and jumped over the tall brown bear\n" ascii85::encode $str } {<+ohcF(fK4FK>_$8DBNqABk(ppGp%3BEc6)5BHVD1AKYW+AS#a%AnbgmA0>;uA0>W0D /a&s+E)F7EZfI;AKZ)'Cht5'Ec6/>+C\njEXD} test ascii85-1.3 {ascii85::encode with wrap length set to 60} { set str "The short red fox ran quickly through the green field " append str "and jumped over the tall brown bear\n" ascii85::encode -maxlen 60 $str } {<+ohcF(fK4FK>_$8DBNqABk(ppGp%3BEc6)5BHVD1AKYW+AS#a% AnbgmA0>;uA0>W0D/a&s+E)F7EZfI;AKZ)'Cht5'Ec6/>+C\njEXD} test ascii85-1.4 {ascii85::encode with wrap length set to 0} { set str "The short red fox ran quickly through the green field " append str "and jumped over the tall brown bear\n" ascii85::encode -maxlen 0 $str } {<+ohcF(fK4FK>_$8DBNqABk(ppGp%3BEc6)5BHVD1AKYW+AS#a%AnbgmA0>;uA0>W0D/a&s+E)F7EZfI;AKZ)'Cht5'Ec6/>+C\njEXD} test ascii85-1.5 {ascii85::encode with wrap length set to 76, wrapchar to newline+space} { set str "The short red fox ran quickly through the green field " append str "and jumped over the tall brown bear\n" ascii85::encode -maxlen 76 -wrapchar "\n " $str } {<+ohcF(fK4FK>_$8DBNqABk(ppGp%3BEc6)5BHVD1AKYW+AS#a%AnbgmA0>;uA0>W0D /a&s+E)F7EZfI;AKZ)'Cht5'Ec6/>+C\njEXD} test ascii85-1.6 {ascii85::encode, errors} { list [catch {ascii85::encode} msg] $msg } [list 1 "wrong # args: should be \"ascii85::encode ?-maxlen maxlen? ?-wrapchar wrapchar? string\""] test ascii85-1.7 {ascii85::encode, errors} { list [catch {ascii85::encode -maxlen foo} msg] $msg } [list 1 "wrong # args: should be \"ascii85::encode ?-maxlen maxlen? ?-wrapchar wrapchar? string\""] # changed form the original. ascii85 checks for correct # args before # checking for valid options. Now this test is duplicate of 1.12 test ascii85-1.8 {ascii85::encode, errors} { list [catch {ascii85::encode -maxlen foo bar} msg] $msg } [list 1 {expected positive integer but got "foo"}] test ascii85-1.9 {ascii85::encode, errors} { list [catch {ascii85::encode -maxlen foo -wrapchar bar} msg] $msg } [list 1 "wrong # args: should be \"ascii85::encode ?-maxlen maxlen? ?-wrapchar wrapchar? string\""] test ascii85-1.10 {ascii85::encode, errors} { list [catch {ascii85::encode -foo bar baz} msg] $msg } [list 1 "unknown option \"-foo\": must be -maxlen or -wrapchar"] test ascii85-1.11 {ascii85::encode with bogus wrap length (< 0)} { set str "The short red fox ran quickly through the green field " append str "and jumped over the tall brown bear\n" list [catch { ascii85::encode -maxlen -3 $str } msg] $msg } {1 {expected positive integer but got "-3"}} # dulicate of 1.8 test ascii85-1.12 {ascii85::encode with bogus wrap length (non-numeric)} { set str "The short red fox ran quickly through the green field " append str "and jumped over the tall brown bear\n" list [catch { ascii85::encode -maxlen foo $str } msg] $msg } {1 {expected positive integer but got "foo"}} test ascii85-1.13 {ascii85::encode with bogus wrap length (non-integer)} { set str "The short red fox ran quickly through the green field " append str "and jumped over the tall brown bear\n" list [catch { ascii85::encode -maxlen 1.5 $str } msg] $msg } {1 {expected positive integer but got "1.5"}} test ascii85-1.14 {ascii85::encode with wrap length set to 20} { set str "The short red fox ran quickly through the green field " append str "and jumped over the tall brown bear\n" ascii85::encode -maxlen 20 $str } {<+ohcF(fK4FK& GT_$8DBNqABk(ppGp%3B Ec6)5BHVD1AKYW+AS#a% AnbgmA0>;uA0>W0D/a&s +E)F7EZfI;AKZ)'Cht5' Ec6/>+C\njEXD} test ascii85-1.15 {ascii85::encode with wrap length set to 23 (prime)} { set str "The short red fox ran quickly through the green field " append str "and jumped over the tall brown bear\n" ascii85::encode -maxlen 23 $str } {<+ohcF(fK4FK>_ $8DBNqABk(ppGp%3BEc6)5B HVD1AKYW+AS#a%AnbgmA0>; uA0>W0D/a&s+E)F7EZfI;AK Z)'Cht5'Ec6/>+C\njEXD} test ascii85-1.16 {ascii85::encode string of length zero} { ascii85::encode "" } "" # ------------------------------------------------------------------------- # Decoding tests # ------------------------------------------------------------------------- test ascii85-2.1 {ascii85::decode} { ascii85::decode {FD,B0+DGm>@3BZ'F*%`} } "this is a test\n" test ascii85-2.2 {ascii85::decode ignores newlines} { set str {<+ohcF(fK4FK>_$8DBNqABk(ppGp%3BEc6)5BHVD1AKYW+AS#a%AnbgmA0>;uA0>W0D} append str \n append str {/a&s+E)F7EZfI;AKZ)'Cht5'Ec6/>+C\njEXD} ascii85::decode $str } "The short red fox ran quickly through the green field and jumped over the tall brown bear\n" test ascii85-2.3 {ascii85::decode error chars not in range} { list [catch {ascii85::decode "ab~cd"} msg] $msg } {1 {error decoding data: chars outside the allowed range}} test ascii85-2.4 {ascii85::decode error "z" char misplaced} { list [catch {ascii85::decode "abczd"} msg] $msg } {1 {error decoding data: "z" char misplaced}} test ascii85-2.5 {ascii85::decode error trailing char} { list [catch {ascii85::decode "abcde5"} msg] $msg } {1 {error decoding data: trailing char}} test ascii85-2.6 {ascii85::decode decoding of null chars} { foreach enc [list !! !!! !!!! z z!!] { lappend res [ascii85::decode $enc] } set res } [list \x00 \x00\x00 \x00\x00\x00 \x00\x00\x00\x00 \x00\x00\x00\x00\x00] test ascii85-2.7 {ascii85::decode integer range limit} { ascii85::decode s8W-! } "\xff\xff\xff\xff" test ascii85-2.8 {ascii85::decode integer range overflow} { list [catch {ascii85::decode {s8W-"}} msg] $msg } {1 {error decoding data: decoded group overflow}} test ascii85-2.9 {ascii85::decode of empty string} { ascii85::decode "" } "" # ------------------------------------------------------------------------- # Identity tests # ------------------------------------------------------------------------- test ascii85-3.1 {ascii85 identity test} { ascii85::decode [ascii85::encode "this is a test"] } "this is a test" test ascii85-3.2 {base64 identity test} { set x \f\xee set y [ascii85::decode [ascii85::encode $x]] string compare $x $y } 0 testsuiteCleanup return tcllib-1.15/modules/base64/uuencode.bench0000644000175000017500000000216112077663115017603 0ustar sergeisergei# -*- tcl -*- # Tcl Benchmark File # # This file contains a number of benchmarks for the 'uuencode' module. # This allow developers to monitor/gauge/track package performance. # # (c) 2005 Andreas Kupries # We need at least version 8.2 for the package and thus the # benchmarks. if {![package vsatisfies [package provide Tcl] 8.2]} { return } # ### ### ### ######### ######### ######### ########################### ## Setting up the environment ... package forget uuencode catch {namespace delete ::uuencode} source [file join [file dirname [info script]] uuencode.tcl] # ### ### ### ######### ######### ######### ########################### ## Benchmarks. foreach n {10 100 1000 10000} { bench -desc "UUENCODE encode ${n}X" -pre { set str [string repeat X $n] } -body { uuencode::encode $str } -post { unset str } bench -desc "UUENCODE decode ${n}X" -pre { set str [uuencode::encode [string repeat X $n]] } -body { uuencode::decode $str } -post { unset str } } # ### ### ### ######### ######### ######### ########################### ## Complete tcllib-1.15/modules/base64/ChangeLog0000644000175000017500000003327212104363437016547 0ustar sergeisergei2013-02-01 Andreas Kupries * * Released and tagged Tcllib 1.15 ======================== * 2013-01-08 Andreas Kupries * base64.man: [Bug 3581373]: Document behaviour for -maxlen 0. 2011-12-13 Andreas Kupries * * Released and tagged Tcllib 1.14 ======================== * 2011-11-08 Andreas Kupries * base64.test: [Bug 2976290]: Disable new test when Trf is available. It actually performs a decoding. 2011-01-24 Andreas Kupries * * Released and tagged Tcllib 1.13 ======================== * 2010-07-06 Andreas Kupries * base64.tcl (::base64::decode): [Bug 2976290]: Throw a proper * base64.man: error when trying to decode padding with not enough * base64.test: data in front of it. Extended testsuite. Bumped to * pkgIndex.tcl: version 2.4.2. 2010-05-04 Andreas Kupries * base64.man:: Fix small typo, default for -maxlen changed to 76. 2010-05-03 Andreas Kupries * ascii85.man: [FR 2993200]: Added new package ascii85, * ascii85.tcl: provided by Emiliano * ascii85.test: * pkgIndex.tcl: 2009-12-07 Andreas Kupries * * Released and tagged Tcllib 1.12 ======================== * 2009-05-07 Pat Thoyts * uuencode.tcl: Changed poor idiom for setting interp result. * yencode.tcl: 2009-01-28 Andreas Kupries * base64.tcl: Define a number of transient variables in the namespace, to avoid creative-writing. Fixes [Bug 2538424]. * pkgIndex.tcl: Bumped version to 2.4.1. * base64.man: 2008-12-12 Andreas Kupries * * Released and tagged Tcllib 1.11.1 ======================== * 2008-12-11 Andreas Kupries * yencode.tcl: Fixed bug in the yencoder. Escaped characters * yencode.man: have to be rotated by 64 according to the yEnc * yencode.test: specification v1.3, not 42. Bumped version to * pkgIndex.tcl: 1.1.2. Updated tests. * uuencode.test: Better handling of loading 'tcllibc'. 2008-10-16 Andreas Kupries * * Released and tagged Tcllib 1.11 ======================== * 2008-06-12 Andreas Kupries * base64.pcx: New files. Syntax definitions for the public * uuencode.pcx: commands of the packages base74, uuencode, * yencode.pcx: and yencode. 2008-05-28 Andreas Kupries * base64.tcl: Changed the default setting for -maxlen to 76 to * base64.man: coincide with MIME definitions and Trf, making * base64.test: the very fast path default, with no output reflow * pkgIndex.tcl: required at all. Bumped version to 2.4. ** POTENTIAL INCOMPATIBILITY ** for all users depending on the default setting to be 60. 2008-05-22 Andreas Kupries * base64.test: Extended with tests using bogus values of -maxchar, * base64.tcl: and non-standard values. Fixed bugs in the maxlen * base64.man: handling of the pure Tcl implementation which * pkgIndex.tcl: allowed the output to have more than maxlen characters per line. Performance fix: Replaced Miguel's O(n^2) reflow algorithm (maxlen handling after Trf) with Gustaf Neumann's O(n) algorithm. Minor changes to the guarding conditions by myself, and fixes for the fast cases. Bumped the version to 2.3.3. 2007-09-12 Andreas Kupries * * Released and tagged Tcllib 1.10 ======================== * 2007-03-19 Andreas Kupries * base64.man: Fixed all warnings due to use of now deprecated * uuencode.man: commands. Added a section about how to give * yencode.man: feedback. 2006-11-04 Pat Thoyts * base64c.tcl: Silence critcl warning. 2006-10-13 Andreas Kupries * uuencode.test: Documentation and code (error messages) disagreed * uuencode.man: about the accepted options, and tests were * uuencode.tcl: missing entirely. The code additionally missed some checks regarding the proper number of arguments, nor had it tests checking that either. Added tests and synchronized code and documentation. 2006-10-03 Andreas Kupries * * Released and tagged Tcllib 1.9 ======================== * 2006-01-22 Andreas Kupries * yencode.test: More boilerplate simplified via use of test support. * uuencode.test: * base64.test: 2006-01-19 Andreas Kupries * yencode.test: Hooked into the new common test support code. * uuencode.test: * base64.test: 2005-10-18 Andreas Kupries * base64.bench: Basic benchmarks for base64, uuencode, * uuencode.bench: and yencode. Encode/decode of strings * yencode.bench: only. 2005-10-06 Andreas Kupries * * Released and tagged Tcllib 1.8 ======================== * 2005-08-26 Andreas Kupries * uuencode.test: Deconfused the testsuite's belief of which accelerators is in use. Removed superfluous output, and added a flag variable for actual use of Trf, not only presence. Changed definition of test 1.4 to use this flag. This is for [Tcllib SF Bug 1273537]. 2004-10-05 Andreas Kupries * base64.man: Cleaned the doc up a bit. Especially highlighted the recently added note recording binary by separating it from the general description a bit (same location, new paragraph). 2005-02-17 Pat Thoyts * base64.man: Added some examples and attempted to point out that proper string encoding may be needed for unicode strings. 2004-10-05 Andreas Kupries * * Released and tagged Tcllib 1.7 ======================== * 2004-08-15 Andreas Kupries * base64.tcl: Typo police. * uuencode.tcl: * uuencode.man: * yencode.man: 2004-07-21 Andreas Kupries * uuencode.man: Polished a bit (options, keywords). * yencode.man: 2004-07-19 Andreas Kupries * base64.man: Added copyright notes for the early authors, as far as I am aware of them. 2004-05-23 Andreas Kupries * uuencode.tcl: Updated version number to sync with 1.6.1 * uuencode.man: release * pkgIndex.tcl: 2004-05-23 Andreas Kupries * * Released and tagged Tcllib 1.6.1 ======================== * 2004-05-23 Andreas Kupries * uuencode.tcl: Rel. engineering. Updated version number * uuencode.man: of uuencode to reflect its changes, to 1.1.1. * pkgIndex.tcl: 2004-03-09 Jeff Hobbs * uuencode.tcl (::uuencode::pad): don't use log package 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * 2003-10-24 Andreas Kupries * base64.test: * base64.tcl: Applied patch fixing [Bug 821126]. Variable 'output' is now initialized to empty to have it defined at all times. Extended testsuite to cover the fixed cases. 2003-10-21 Andreas Kupries * base64.tcl: Added code to the Trf supported 'decode'r to ignore whitespace in hte encoded input. [Bug 736900]. 2003-07-24 Pat Thoyts * base64c.tcl: Added the placeholder package. 2003-05-14 Pat Thoyts * Merged DEVELOPMENT branch from DEVELOPMENT-root to DEVELOPMENT-merge-1 This brings in the critcl enhancements for uuencode and yencode along with a few extra tests for yencode. 2003-05-05 Andreas Kupries * * Released and tagged Tcllib 1.4 ======================== * 2003-04-22 Pat Thoyts * base64c.tcl: Added file to define the base64c C coded package. * uuencode.tcl: Added critcl code into the package. * yencode.tcl: Added critcl code into the package. 2003-04-22 Pat Thoyts * all: Created DEVELOPMENT branch - tagged root-DEVELOPMENT. This branch contains criticl-based C code to speed up some of the computationally expensive functions - generates a base64c package. 2003-04-21 Andreas Kupries * uuencode.test: Added code to suppress output from the log package during the test. 2003-04-11 Andreas Kupries * uuencode.man: * base64.tcl: * base64.man: * pkgIndex.tcl: Fixed bug #614591. Set version of the base64 package to to 2.2.2. uuencode is now at version 1.0.2 throughout. 2003-03-24 Andreas Kupries * uuencode.test: * uuencode.tcl: Fixed bug #700327, reported by Roger Niva . Added '--' before actual data argument to prevent mishandling of data beginning with a dash ('-'). Extended the testsuite to cover these cases. 2003-02-23 David N. Welton * base64.tcl: Bumped base64.tcl Tcl requirement to 8.2, swapped out regsub for string map. 2003-01-25 Pat Thoyts * yencode.tcl: * uuencode.tcl: Added Tcl 8.2 version requirement, bumped versions and added copyright to man pages. Fixed uuencode to work with Tcl 8.2 2002-06-03 Andreas Kupries * pkgIndex.tcl: * base64.tcl: * base64.n: * base64.man: Bumped base64 to version 2.2.1. * pkgIndex.tcl: * uuencode.tcl: * uuencode.n: * uuencode.man: Bumped uuencode to version 1.0.1. 2002-05-27 Andreas Kupries * yencode.test: Fixed SF Tcllib Bug #548354 so that the datafile used by the test is found even if the build directory is outside of the tcllib directory hierarchy. Original patch provided by Larry Virden , changed by me to work in my configuration too. 2002-04-24 Andreas Kupries * uuencode.tcl: * yencode.tcl: * base64.tcl: Fixed decoding of empty string in tcl implementation. Fixes bug #548112. 2002-04-17 Pat Thoyts * yencode.tcl, yencode.test, yencode.man, yencode.test.data, * yencode.test.out: initial import of yEnc encode/decode package plus man page and test. 2002-04-17 Pat Thoyts * uuencode.tcl: fixed bug #544452 to handle DOS input files and tolerate incorrect uuencoded line lengths. * uuencode.test: added tests for the above bug conditions. 2002-01-17 Pat Thoyts * uuencode.tcl: added support for Trf and fixed length bug 2002-01-16 Pat Thoyts * uuencode.tcl: initial import of uuencode package * pkgIndex.tcl: added uuencode package 2001-09-05 Andreas Kupries * base64.tcl: Restricted export list to public API. [456255]. Patch by Hemang Lavana 2001-07-31 Andreas Kupries * base64.n: Added manpage [446584]. 2001-07-10 Andreas Kupries * base64.tcl: Frink 2.2 run, fixed dubious code. 2001-06-21 Andreas Kupries * base64.tcl: Greatly increased speed, obtained by: using lists instead of arrays, splitting the input with [binary scan], taking the bytes to be encoded three at a time, and reformulating the decoding algorithm to be purely arithmetic. Improved backwards compatibility, now runs with Tcl8.0. Nudged version to 2.2 2000-10-11 Brent Welch * base64.tcl: Fixed bug in base64::decode where trailing bytes were not always decoded correctly (!). This only shows up with low-valued characters (less than 0x10) near the end of a string that was padded with = Nudged version to 2.1 so we can distinquish this version that has bug fixes and new features. 2000-10-10 Eric Melski * base64.tcl: Extending base64::encode to accept optional arguments ?-maxlen maxlen? and ?-wrapchar wrapchar?, to control the line wrapping and the character(s) used to cause the wrapping. Based on work by Joel Saunier. 2000-03-09 Eric Melski * base64.test: Adapted tests to work in tcllib test framework. 2000-03-04 Eric Melski * base64.test: Added tests for decoding data that was padded with ='s * base64.tcl: Fixed a bug with line wrapping in the encoder -- it was not properly counting the number of characters emitted, so it was not wrapping when it should. Changed the chars/line to 60, so the output would be identical to that produced by GNU uuecode 4.2, for easy testing purposes. Fixed a bug in the decoder with newlines -- it was not ignoring them as it should according to RFC 2045. Fixed a bug in decoder dealing with data that was padded with ='s. * base64.test: Some rudimentary tests for the encoder/decoder. 2000-03-02 Eric Melski * pkgIndex.tcl: added pkgIndex file. tcllib-1.15/modules/base64/base64.pcx0000644000175000017500000000446512077663115016604 0ustar sergeisergei# -*- tcl -*- base64.pcx # Syntax of the commands provided by package base64. # # For use by TclDevKit's static syntax checker. # See http://www.activestate.com/solutions/tcl/ # See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api # for the documentation describing the format of the code contained in this file # package require pcx pcx::register base64 pcx::tcldep 2.3.2 needs tcl 8.2 namespace eval ::base64 {} # Using the indirections below looks to be quite pointless, given that # they simply substitute the commands for others. I am doing this for # two reasons. # First, the rules coming after become self-commenting, i.e. a # maintainer can immediately see what an argument is supposed to be, # instead of having to search elsewhere (like the documentation and # implementation). In this manner our definitions here are a type of # semantic markup. # The second reason is that while we have no special checks now we # cannot be sure if such will (have to) be added in the future. With # all checking routed through our definitions we now already have the # basic infrastructure (i.e. hooks) in place in which we can easily # add any new checks by simply redefining the relevant command, and # all the rules update on their own. Mostly. This should cover 90% of # the cases. Sometimes new checks will require to create deeper # distinctions between different calls of the same thing. For such we # may have to update the rules as well, to provide the necessary # information to the checker. interp alias {} base64::checkLineLength {} checkInt ; # interp alias {} base64::checkWrapChar {} checkWord ; # interp alias {} base64::checkData {} checkWord ; # #pcx::message FOO {... text ...} type #pcx::scan pcx::check 2.3.2 std ::base64::decode \ {checkSimpleArgs 1 1 { base64::checkData }} # NOTE: Is '-maxlen' < 0 allowed? # Doc doesn't forbid it, code doesn't catch it. # May crash it however, i.e be a bug. # Check testsuite. pcx::check 2.3.2 std ::base64::encode \ {checkSimpleArgs 1 -1 { {checkSwitches 1 { {-maxlen base64::checkLineLength} {-wrapchar base64::checkWrapChar} } {checkSimpleArgs 1 1 { base64::checkData }}} }} # Initialization via pcx::init. # Use a ::base64::init procedure for non-standard initialization. pcx::complete tcllib-1.15/modules/base64/base64.tcl0000644000175000017500000002645212077663115016574 0ustar sergeisergei# base64.tcl -- # # Encode/Decode base64 for a string # Stephen Uhler / Brent Welch (c) 1997 Sun Microsystems # The decoder was done for exmh by Chris Garrigues # # Copyright (c) 1998-2000 by Ajuba Solutions. # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: base64.tcl,v 1.32 2010/07/06 19:15:40 andreas_kupries Exp $ # Version 1.0 implemented Base64_Encode, Base64_Decode # Version 2.0 uses the base64 namespace # Version 2.1 fixes various decode bugs and adds options to encode # Version 2.2 is much faster, Tcl8.0 compatible # Version 2.2.1 bugfixes # Version 2.2.2 bugfixes # Version 2.3 bugfixes and extended to support Trf # @mdgen EXCLUDE: base64c.tcl package require Tcl 8.2 namespace eval ::base64 { namespace export encode decode } if {![catch {package require Trf 2.0}]} { # Trf is available, so implement the functionality provided here # in terms of calls to Trf for speed. # ::base64::encode -- # # Base64 encode a given string. # # Arguments: # args ?-maxlen maxlen? ?-wrapchar wrapchar? string # # If maxlen is 0, the output is not wrapped. # # Results: # A Base64 encoded version of $string, wrapped at $maxlen characters # by $wrapchar. proc ::base64::encode {args} { # Set the default wrapchar and maximum line length to match # the settings for MIME encoding (RFC 3548, RFC 2045). These # are the settings used by Trf as well. Various RFCs allow for # different wrapping characters and wraplengths, so these may # be overridden by command line options. set wrapchar "\n" set maxlen 76 if { [llength $args] == 0 } { error "wrong # args: should be \"[lindex [info level 0] 0]\ ?-maxlen maxlen? ?-wrapchar wrapchar? string\"" } set optionStrings [list "-maxlen" "-wrapchar"] for {set i 0} {$i < [llength $args] - 1} {incr i} { set arg [lindex $args $i] set index [lsearch -glob $optionStrings "${arg}*"] if { $index == -1 } { error "unknown option \"$arg\": must be -maxlen or -wrapchar" } incr i if { $i >= [llength $args] - 1 } { error "value for \"$arg\" missing" } set val [lindex $args $i] # The name of the variable to assign the value to is extracted # from the list of known options, all of which have an # associated variable of the same name as the option without # a leading "-". The [string range] command is used to strip # of the leading "-" from the name of the option. # # FRINK: nocheck set [string range [lindex $optionStrings $index] 1 end] $val } # [string is] requires Tcl8.2; this works with 8.0 too if {[catch {expr {$maxlen % 2}}]} { return -code error "expected integer but got \"$maxlen\"" } elseif {$maxlen < 0} { return -code error "expected positive integer but got \"$maxlen\"" } set string [lindex $args end] set result [::base64 -mode encode -- $string] # Trf's encoder implicitly uses the settings -maxlen 76, # -wrapchar \n for its output. We may have to reflow this for # the settings chosen by the user. A second difference is that # Trf closes the output with the wrap char sequence, # always. The code here doesn't. Therefore 'trimright' is # needed in the fast cases. if {($maxlen == 76) && [string equal $wrapchar \n]} { # Both maxlen and wrapchar are identical to Trf's # settings. This is the super-fast case, because nearly # nothing has to be done. Only thing to do is strip a # terminating wrapchar. set result [string trimright $result] } elseif {$maxlen == 76} { # wrapchar has to be different here, length is the # same. We can use 'string map' to transform the wrap # information. set result [string map [list \n $wrapchar] \ [string trimright $result]] } elseif {$maxlen == 0} { # Have to reflow the output to no wrapping. Another fast # case using only 'string map'. 'trimright' is not needed # here. set result [string map [list \n ""] $result] } else { # Have to reflow the output from 76 to the chosen maxlen, # and possibly change the wrap sequence as well. # Note: After getting rid of the old wrap sequence we # extract the relevant segments from the string without # modifying the string. Modification, i.e. removal of the # processed part, means 'shifting down characters in # memory', making the algorithm O(n^2). By avoiding the # modification we stay in O(n). set result [string map [list \n ""] $result] set l [expr {[string length $result]-$maxlen}] for {set off 0} {$off < $l} {incr off $maxlen} { append res [string range $result $off [expr {$off+$maxlen-1}]] $wrapchar } append res [string range $result $off end] set result $res } return $result } # ::base64::decode -- # # Base64 decode a given string. # # Arguments: # string The string to decode. Characters not in the base64 # alphabet are ignored (e.g., newlines) # # Results: # The decoded value. proc ::base64::decode {string} { regsub -all {\s} $string {} string ::base64 -mode decode -- $string } } else { # Without Trf use a pure tcl implementation namespace eval base64 { variable base64 {} variable base64_en {} # We create the auxiliary array base64_tmp, it will be unset later. variable base64_tmp variable i set i 0 foreach char {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z \ a b c d e f g h i j k l m n o p q r s t u v w x y z \ 0 1 2 3 4 5 6 7 8 9 + /} { set base64_tmp($char) $i lappend base64_en $char incr i } # # Create base64 as list: to code for instance C<->3, specify # that [lindex $base64 67] be 3 (C is 67 in ascii); non-coded # ascii chars get a {}. we later use the fact that lindex on a # non-existing index returns {}, and that [expr {} < 0] is true # # the last ascii char is 'z' variable char variable len variable val scan z %c len for {set i 0} {$i <= $len} {incr i} { set char [format %c $i] set val {} if {[info exists base64_tmp($char)]} { set val $base64_tmp($char) } else { set val {} } lappend base64 $val } # code the character "=" as -1; used to signal end of message scan = %c i set base64 [lreplace $base64 $i $i -1] # remove unneeded variables unset base64_tmp i char len val namespace export encode decode } # ::base64::encode -- # # Base64 encode a given string. # # Arguments: # args ?-maxlen maxlen? ?-wrapchar wrapchar? string # # If maxlen is 0, the output is not wrapped. # # Results: # A Base64 encoded version of $string, wrapped at $maxlen characters # by $wrapchar. proc ::base64::encode {args} { set base64_en $::base64::base64_en # Set the default wrapchar and maximum line length to match # the settings for MIME encoding (RFC 3548, RFC 2045). These # are the settings used by Trf as well. Various RFCs allow for # different wrapping characters and wraplengths, so these may # be overridden by command line options. set wrapchar "\n" set maxlen 76 if { [llength $args] == 0 } { error "wrong # args: should be \"[lindex [info level 0] 0]\ ?-maxlen maxlen? ?-wrapchar wrapchar? string\"" } set optionStrings [list "-maxlen" "-wrapchar"] for {set i 0} {$i < [llength $args] - 1} {incr i} { set arg [lindex $args $i] set index [lsearch -glob $optionStrings "${arg}*"] if { $index == -1 } { error "unknown option \"$arg\": must be -maxlen or -wrapchar" } incr i if { $i >= [llength $args] - 1 } { error "value for \"$arg\" missing" } set val [lindex $args $i] # The name of the variable to assign the value to is extracted # from the list of known options, all of which have an # associated variable of the same name as the option without # a leading "-". The [string range] command is used to strip # of the leading "-" from the name of the option. # # FRINK: nocheck set [string range [lindex $optionStrings $index] 1 end] $val } # [string is] requires Tcl8.2; this works with 8.0 too if {[catch {expr {$maxlen % 2}}]} { return -code error "expected integer but got \"$maxlen\"" } elseif {$maxlen < 0} { return -code error "expected positive integer but got \"$maxlen\"" } set string [lindex $args end] set result {} set state 0 set length 0 # Process the input bytes 3-by-3 binary scan $string c* X foreach {x y z} $X { ADD [lindex $base64_en [expr {($x >>2) & 0x3F}]] if {$y != {}} { ADD [lindex $base64_en [expr {(($x << 4) & 0x30) | (($y >> 4) & 0xF)}]] if {$z != {}} { ADD [lindex $base64_en [expr {(($y << 2) & 0x3C) | (($z >> 6) & 0x3)}]] ADD [lindex $base64_en [expr {($z & 0x3F)}]] } else { set state 2 break } } else { set state 1 break } } if {$state == 1} { ADD [lindex $base64_en [expr {(($x << 4) & 0x30)}]] ADD = ADD = } elseif {$state == 2} { ADD [lindex $base64_en [expr {(($y << 2) & 0x3C)}]] ADD = } return $result } proc ::base64::ADD {x} { # The line length check is always done before appending so # that we don't get an extra newline if the output is a # multiple of $maxlen chars long. upvar 1 maxlen maxlen length length result result wrapchar wrapchar if {$maxlen && $length >= $maxlen} { append result $wrapchar set length 0 } append result $x incr length return } # ::base64::decode -- # # Base64 decode a given string. # # Arguments: # string The string to decode. Characters not in the base64 # alphabet are ignored (e.g., newlines) # # Results: # The decoded value. proc ::base64::decode {string} { if {[string length $string] == 0} {return ""} set base64 $::base64::base64 set output "" ; # Fix for [Bug 821126] binary scan $string c* X foreach x $X { set bits [lindex $base64 $x] if {$bits >= 0} { if {[llength [lappend nums $bits]] == 4} { foreach {v w z y} $nums break set a [expr {($v << 2) | ($w >> 4)}] set b [expr {(($w & 0xF) << 4) | ($z >> 2)}] set c [expr {(($z & 0x3) << 6) | $y}] append output [binary format ccc $a $b $c] set nums {} } } elseif {$bits == -1} { # = indicates end of data. Output whatever chars are left. # The encoding algorithm dictates that we can only have 1 or 2 # padding characters. If x=={}, we must (*) have 12 bits of input # (enough for 1 8-bit output). If x!={}, we have 18 bits of # input (enough for 2 8-bit outputs). # # (*) If we don't then the input is broken (bug 2976290). foreach {v w z} $nums break # Bug 2976290 if {$w == {}} { return -code error "Not enough data to process padding" } set a [expr {($v << 2) | (($w & 0x30) >> 4)}] if {$z == {}} { append output [binary format c $a ] } else { set b [expr {(($w & 0xF) << 4) | (($z & 0x3C) >> 2)}] append output [binary format cc $a $b] } break } else { # RFC 2045 says that line breaks and other characters not part # of the Base64 alphabet must be ignored, and that the decoder # can optionally emit a warning or reject the message. We opt # not to do so, but to just ignore the character. continue } } return $output } } package provide base64 2.4.2 tcllib-1.15/modules/base64/uuencode.man0000644000175000017500000000547112077663115017306 0ustar sergeisergei[manpage_begin uuencode n 1.1.4] [copyright {2002, Pat Thoyts}] [moddesc {Text encoding & decoding binary data}] [titledesc {UU-encode/decode binary data}] [category {Text processing}] [require Tcl 8] [require uuencode [opt 1.1.4]] [description] [para] This package provides a Tcl-only implementation of the [syscmd uuencode(1)] and [syscmd uudecode(1)] commands. This encoding packs binary data into printable ASCII characters. [list_begin definitions] [call [cmd ::uuencode::encode] [arg string]] returns the uuencoded data. This will encode all the data passed in even if this is longer than the uuencode maximum line length. If the number of input bytes is not a multiple of 3 then additional 0 bytes are added to pad the string. [call [cmd ::uuencode::decode] [arg string]] Decodes the given encoded data. This will return any padding characters as well and it is the callers responsibility to deal with handling the actual length of the encoded data. (see uuencode). [call [cmd ::uuencode::uuencode] [opt "[option -name] [arg string]"] [opt "[option -mode] [arg octal]"] "([option -file] [arg filename] | [opt [option --]] [arg string])"] [call [cmd ::uuencode::uudecode] "([option -file] [arg filename] | [opt [option --]] [arg string])"] UUDecode a file or block of data. A file may contain more than one embedded file so the result is a list where each element is a three element list of filename, mode value and data. [list_end] [section OPTIONS] [list_begin definitions] [def "-filename name"] Cause the uuencode or uudecode commands to read their data from the named file rather that taking a string parameter. [def "-name string"] The uuencoded data header line contains the suggested file name to be used when unpacking the data. Use this option to change this from the default of "data.dat". [def "-mode octal"] The uuencoded data header line contains a suggested permissions bit pattern expressed as an octal string. To change the default of 0644 you can set this option. For instance, 0755 would be suitable for an executable. See [syscmd chmod(1)]. [list_end] [section EXAMPLES] [para] [example { % set d [uuencode::encode "Hello World!"] 2&5L;&\\@5V]R;&0A }] [para] [example { % uuencode::uudecode $d Hello World! }] [para] [example { % set d [uuencode::uuencode -name hello.txt "Hello World"] begin 644 hello.txt +2&5L;&\@5V]R;&0` ` end }] [para] [example { % uuencode::uudecode $d {hello.txt 644 {Hello World}} }] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph base64] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords encoding uuencode] [manpage_end] tcllib-1.15/modules/base64/uuencode.test0000644000175000017500000001265612077663115017515 0ustar sergeisergei# uuencode.test - Copyright (C) 2002 Pat Thoyts # # Tests for the Tcllib uuencode package # # ------------------------------------------------------------------------- # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ------------------------------------------------------------------------- # RCS: @(#) $Id: uuencode.test,v 1.15 2008/12/12 04:57:46 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.2 testsNeedTcltest 1.0 testing { useTcllibC useLocalKeep uuencode.tcl uuencode } # ------------------------------------------------------------------------- set trf 0 if {[llength [info commands ::uuencode::CEncode]]} { puts "> critcl based" } elseif {[package provide Trf] != {}} { puts "> Trf based" set trf 1 } else { puts "> pure tcl" } package require log log::lvSuppress notice # ------------------------------------------------------------------------- test uuencode-1.0 {encode string} { catch {::uuencode::encode ABC} result set result } "04)#" test uuencode-1.1 {decode string} { catch {::uuencode::decode "04)#"} result set result } "ABC" test uuencode-1.2 {encode longer string} { catch {::uuencode::encode [string repeat x 102]} result set result } [string repeat ">'AX" 34] test uuencode-1.3 {decode longer string} { catch {::uuencode::decode [string repeat ">'AX" 34]} result set result } [string repeat x 102] # Trf uses a different padding character. if {!$trf} { # critcl / pure tcl based set testdata {begin 644 data.dat 75&AE(&-A="!S870@;VX@=&AE(&UA="X` ` end} } else { set testdata {begin 644 data.dat 75&AE(&-A="!S870@;VX@=&AE(&UA="X~ ` end} } test uuencode-1.4 {uuencode string} { catch {::uuencode::uuencode "The cat sat on the mat."} result set result } $testdata test uuencode-1.5 {uudecode string} { catch {::uuencode::uudecode $testdata} result set result } [list [list data.dat 644 "The cat sat on the mat."]] test uuencode-1.6 {encode dash-string} { catch {::uuencode::encode -BC} result set result } "+4)#" test uuencode-1.7 {decode dash-string} { catch {::uuencode::decode "-4)#"} result set result } "5BC" # ------------------------------------------------------------------------- set testdata [list \ "begin 644 data.dat" \ "75&AE(&-A=\"!S870@;VX@=&AE(&UA=\"X" \ "`" \ "end" ] test uuencode-2.1 {uudecode unpadded lines} { catch {::uuencode::uudecode [join $testdata "\n"]} result set result } [list [list data.dat 644 "The cat sat on the mat."]] test uuencode-2.2 {uudecode DOS line endings} { set f [open uuencode.test.data w] fconfigure $f -translation binary puts -nonewline $f [join $testdata "\r\n"] close $f catch {::uuencode::uudecode -file uuencode.test.data} result set result } [list [list data.dat 644 "The cat sat on the mat."]] foreach {n in out} { 0 a {80``} 1 abc {86)C} 2 \0 {````} 3 "\r\n\t" {#0H)} 4 "hello world" {:&5L;&\@=V]R;&0`} } { test uuencode-3.$n {check the pure tcl encoder} { list [catch {::uuencode::Encode $in} r] $r } [list 0 $out] } # ------------------------------------------------------------------------- test uuencode-4.0 {encode bad args} { catch {::uuencode::uuencode -bogus} result set result } {bad option -bogus: must be -file, -mode, or -name} test uuencode-4.1 {encode wrong#args} { catch {::uuencode::uuencode -file} result set result } {wrong # args: should be "uuencode ?-name string? ?-mode octal? (-file filename | ?--? string)"} test uuencode-4.2 {encode wrong#args} { catch {::uuencode::uuencode -name} result set result } {wrong # args: should be "uuencode ?-name string? ?-mode octal? (-file filename | ?--? string)"} test uuencode-4.3 {encode wrong#args} { catch {::uuencode::uuencode -mode} result set result } {wrong # args: should be "uuencode ?-name string? ?-mode octal? (-file filename | ?--? string)"} test uuencode-4.4 {encode wrong#args} { catch {::uuencode::uuencode -mode 1} result set result } {wrong # args: should be "uuencode ?-name string? ?-mode octal? (-file filename | ?--? string)"} test uuencode-4.5 {encode wrong#args} { catch {::uuencode::uuencode -name foo} result set result } {wrong # args: should be "uuencode ?-name string? ?-mode octal? (-file filename | ?--? string)"} test uuencode-4.6 {encode wrong#args} { catch {::uuencode::uuencode --} result set result } {wrong # args: should be "uuencode ?-name string? ?-mode octal? (-file filename | ?--? string)"} test uuencode-5.0 {decode bad args} { catch {::uuencode::uudecode -bogus} result set result } {bad option -bogus: must be -file} test uuencode-5.1 {decode wrong#args} { catch {::uuencode::uudecode -file} result set result } {wrong # args: should be "uudecode (-file filename | ?--? string)"} test uuencode-5.2 {decode wrong#args} { catch {::uuencode::uudecode --} result set result } {wrong # args: should be "uudecode (-file filename | ?--? string)"} # ------------------------------------------------------------------------- file delete -force uuencode.test.data testsuiteCleanup # Local Variables: # mode: tcl # indent-tabs-mode: nil # End: tcllib-1.15/modules/base64/yencode.test.data0000644000175000017500000000111012077663115020223 0ustar sergeisergeiyEnc - Testfile (1) ASCII: 255..0 ÿþýüûúùø÷öõôóòñðïîíìëêéèçæåäãâáàßÞÝÜÛÚÙØ×ÖÕÔÓÒÑÐÏÎÍÌËÊÉÈÇÆÅÄÃÂÁÀ¿¾½¼»º¹¸·¶µ´³²±°¯®­¬«ª©¨§¦¥¤£¢¡ Ÿžœ›š™˜—–•”“’‘ŽŒ‹Š‰ˆ‡†…„ƒ‚€~}|{zyxwvutsrqponmlkjihgfedcba`_^]\[ZYXWVUTSRQPONMLKJIHGFEDCBA@?>=<;:9876543210/.-,+*)('&%$#"!   ASCII: 0..255   !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~€‚ƒ„…†‡ˆ‰Š‹ŒŽ‘’“”•–—˜™š›œžŸ ¡¢£¤¥¦§¨©ª«¬­®¯°±²³´µ¶·¸¹º»¼½¾¿ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖ×ØÙÚÛÜÝÞßàáâãäåæçèéêëìíîïðñòóôõö÷øùúûüýþÿ End of Testfile tcllib-1.15/modules/base64/pkgIndex.tcl0000644000175000017500000000055212077663115017252 0ustar sergeisergeiif {![package vsatisfies [package provide Tcl] 8.2]} {return} package ifneeded base64 2.4.2 [list source [file join $dir base64.tcl]] package ifneeded uuencode 1.1.5 [list source [file join $dir uuencode.tcl]] package ifneeded yencode 1.1.3 [list source [file join $dir yencode.tcl]] package ifneeded ascii85 1.0 [list source [file join $dir ascii85.tcl]] tcllib-1.15/modules/base64/yencode.tcl0000644000175000017500000002264312077663115017134 0ustar sergeisergei# yencode.tcl - Copyright (C) 2002 Pat Thoyts # # Provide a Tcl only implementation of yEnc encoding algorithm # # ------------------------------------------------------------------------- # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ------------------------------------------------------------------------- # @(#)$Id: yencode.tcl,v 1.13 2009/05/07 01:10:37 patthoyts Exp $ # FUTURE: Rework to allow switching between the tcl/critcl implementations. package require Tcl 8.2; # tcl minimum version catch {package require crc32}; # tcllib 1.1 catch {package require tcllibc}; # critcl enhancements for tcllib namespace eval ::yencode { variable version 1.1.3 namespace export encode decode yencode ydecode } # ------------------------------------------------------------------------- proc ::yencode::Encode {s} { set r {} binary scan $s c* d foreach {c} $d { set v [expr {($c + 42) % 256}] if {$v == 0x00 || $v == 0x09 || $v == 0x0A || $v == 0x0D || $v == 0x3D} { append r "=" set v [expr {($v + 64) % 256}] } append r [format %c $v] } return $r } proc ::yencode::Decode {s} { if {[string length $s] == 0} {return ""} set r {} set esc 0 binary scan $s c* d foreach c $d { if {$c == 61 && $esc == 0} { set esc 1 continue } set v [expr {($c - 42) % 256}] if {$esc} { set v [expr {($v - 64) % 256}] set esc 0 } append r [format %c $v] } return $r } # ------------------------------------------------------------------------- # C coded versions for critcl built base64c package # ------------------------------------------------------------------------- if {[package provide critcl] != {}} { namespace eval ::yencode { critcl::ccode { #include } critcl::ccommand CEncode {dummy interp objc objv} { Tcl_Obj *inputPtr, *resultPtr; int len, rlen, xtra; unsigned char *input, *p, *r, v; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "data"); return TCL_ERROR; } /* fetch the input data */ inputPtr = objv[1]; input = Tcl_GetByteArrayFromObj(inputPtr, &len); /* calculate the length of the encoded result */ rlen = len; for (p = input; p < input + len; p++) { v = (*p + 42) % 256; if (v == 0 || v == 9 || v == 0x0A || v == 0x0D || v == 0x3D) rlen++; } /* allocate the output buffer */ resultPtr = Tcl_NewObj(); r = Tcl_SetByteArrayLength(resultPtr, rlen); /* encode the input */ for (p = input; p < input + len; p++) { v = (*p + 42) % 256; if (v == 0 || v == 9 || v == 0x0A || v == 0x0D || v == 0x3D) { *r++ = '='; v = (v + 64) % 256; } *r++ = v; } Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } critcl::ccommand CDecode {dummy interp objc objv} { Tcl_Obj *inputPtr, *resultPtr; int len, rlen, esc; unsigned char *input, *p, *r, v; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "data"); return TCL_ERROR; } /* fetch the input data */ inputPtr = objv[1]; input = Tcl_GetByteArrayFromObj(inputPtr, &len); /* allocate the output buffer */ resultPtr = Tcl_NewObj(); r = Tcl_SetByteArrayLength(resultPtr, len); /* encode the input */ for (p = input, esc = 0, rlen = 0; p < input + len; p++) { if (*p == 61 && esc == 0) { esc = 1; continue; } v = (*p - 42) % 256; if (esc) { v = (v - 64) % 256; esc = 0; } *r++ = v; rlen++; } Tcl_SetByteArrayLength(resultPtr, rlen); Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } } } if {[info command ::yencode::CEncode] != {}} { interp alias {} ::yencode::encode {} ::yencode::CEncode interp alias {} ::yencode::decode {} ::yencode::CDecode } else { interp alias {} ::yencode::encode {} ::yencode::Encode interp alias {} ::yencode::decode {} ::yencode::Decode } # ------------------------------------------------------------------------- # Description: # Pop the nth element off a list. Used in options processing. # proc ::yencode::Pop {varname {nth 0}} { upvar $varname args set r [lindex $args $nth] set args [lreplace $args $nth $nth] return $r } # ------------------------------------------------------------------------- proc ::yencode::yencode {args} { array set opts {mode 0644 filename {} name {} line 128 crc32 1} while {[string match -* [lindex $args 0]]} { switch -glob -- [lindex $args 0] { -f* { set opts(filename) [Pop args 1] } -m* { set opts(mode) [Pop args 1] } -n* { set opts(name) [Pop args 1] } -l* { set opts(line) [Pop args 1] } -c* { set opts(crc32) [Pop args 1] } -- { Pop args ; break } default { set options [join [lsort [array names opts]] ", -"] return -code error "bad option [lindex $args 0]:\ must be -$options" } } Pop args } if {$opts(name) == {}} { set opts(name) $opts(filename) } if {$opts(name) == {}} { set opts(name) "data.dat" } if {! [string is boolean $opts(crc32)]} { return -code error "bad option -crc32: argument must be true or false" } if {$opts(filename) != {}} { set f [open $opts(filename) r] fconfigure $f -translation binary set data [read $f] close $f } else { if {[llength $args] != 1} { return -code error "wrong \# args: should be\ \"yencode ?options? -file name | data\"" } set data [lindex $args 0] } set opts(size) [string length $data] set r {} append r [format "=ybegin line=%d size=%d name=%s" \ $opts(line) $opts(size) $opts(name)] "\n" set ndx 0 while {$ndx < $opts(size)} { set pln [string range $data $ndx [expr {$ndx + $opts(line) - 1}]] set enc [encode $pln] incr ndx [string length $pln] append r $enc "\r\n" } append r [format "=yend size=%d" $ndx] if {$opts(crc32)} { append r " crc32=" [crc::crc32 -format %x $data] } return $r } # ------------------------------------------------------------------------- # Description: # Perform ydecoding of a file or data. A file may contain more than one # encoded data section so the result is a list where each element is a # three element list of the provided filename, the file size and the # data itself. # proc ::yencode::ydecode {args} { array set opts {mode 0644 filename {} name default.bin} while {[string match -* [lindex $args 0]]} { switch -glob -- [lindex $args 0] { -f* { set opts(filename) [Pop args 1] } -- { Pop args ; break; } default { set options [join [lsort [array names opts]] ", -"] return -code error "bad option [lindex $args 0]:\ must be -$opts" } } Pop args } if {$opts(filename) != {}} { set f [open $opts(filename) r] set data [read $f] close $f } else { if {[llength $args] != 1} { return -code error "wrong \# args: should be\ \"ydecode ?options? -file name | data\"" } set data [lindex $args 0] } set state false set result {} foreach {line} [split $data "\n"] { set line [string trimright $line "\r\n"] switch -exact -- $state { false { if {[string match "=ybegin*" $line]} { regexp {line=(\d+)} $line -> opts(line) regexp {size=(\d+)} $line -> opts(size) regexp {name=(\d+)} $line -> opts(name) if {$opts(name) == {}} { set opts(name) default.bin } set state true set r {} } } true { if {[string match "=yend*" $line]} { set state false lappend result [list $opts(name) $opts(size) $r] } else { append r [decode $line] } } } } return $result } # ------------------------------------------------------------------------- package provide yencode $::yencode::version # ------------------------------------------------------------------------- # # Local variables: # mode: tcl # indent-tabs-mode: nil # End: tcllib-1.15/modules/base64/ascii85.tcl0000644000175000017500000001733412077663115016754 0ustar sergeisergei# ascii85.tcl -- # # Encode/Decode ascii85 for a string # # Copyright (c) Emiliano Gavilan # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require Tcl 8.4 namespace eval ascii85 { namespace export encode encodefile decode # default values for encode options variable options array set options [list -wrapchar \n -maxlen 76] } # ::ascii85::encode -- # # Ascii85 encode a given string. # # Arguments: # args ?-maxlen maxlen? ?-wrapchar wrapchar? string # # If maxlen is 0, the output is not wrapped. # # Results: # A Ascii85 encoded version of $string, wrapped at $maxlen characters # by $wrapchar. proc ascii85::encode {args} { variable options set alen [llength $args] if {$alen != 1 && $alen != 3 && $alen != 5} { return -code error "wrong # args:\ should be \"[lindex [info level 0] 0]\ ?-maxlen maxlen?\ ?-wrapchar wrapchar? string\"" } set data [lindex $args end] array set opts [array get options] array set opts [lrange $args 0 end-1] foreach key [array names opts] { if {[lsearch -exact [array names options] $key] == -1} { return -code error "unknown option \"$key\":\ must be -maxlen or -wrapchar" } } if {![string is integer -strict $opts(-maxlen)] || $opts(-maxlen) < 0} { return -code error "expected positive integer but got\ \"$opts(-maxlen)\"" } # perform this check early if {[string length $data] == 0} { return "" } # shorten the names set ml $opts(-maxlen) set wc $opts(-wrapchar) # if maxlen is zero, don't wrap the output if {$ml == 0} { set wc "" } set encoded {} binary scan $data c* X set len [llength $X] set rest [expr {$len % 4}] set lastidx [expr {$len - $rest - 1}] foreach {b1 b2 b3 b4} [lrange $X 0 $lastidx] { # calculate the 32 bit value # this is an inlined version of the [encode4bytes] proc # included here for performance reasons set val [expr { ( (($b1 & 0xff) << 24) |(($b2 & 0xff) << 16) |(($b3 & 0xff) << 8) | ($b4 & 0xff) ) & 0xffffffff }] if {$val == 0} { # four \0 bytes encodes as "z" instead of "!!!!!" append current "z" } else { # no magic numbers here. # 52200625 -> 85 ** 4 # 614125 -> 85 ** 3 # 7225 -> 85 ** 2 append current [binary format ccccc \ [expr { ( $val / 52200625) + 33 }] \ [expr { (($val % 52200625) / 614125) + 33 }] \ [expr { (($val % 614125) / 7225) + 33 }] \ [expr { (($val % 7225) / 85) + 33 }] \ [expr { ( $val % 85) + 33 }]] } if {[string length $current] >= $ml} { append encoded [string range $current 0 [expr {$ml - 1}]] $wc set current [string range $current $ml end] } } if { $rest } { # there are remaining bytes. # pad with \0 and encode not using the "z" convention. # finally, add ($rest + 1) chars. set val 0 foreach {b1 b2 b3 b4} [pad [lrange $X [incr lastidx] end] 4 0] break append current [string range [encode4bytes $b1 $b2 $b3 $b4] 0 $rest] } append encoded [regsub -all -- ".{$ml}" $current "&$wc"] return $encoded } proc ascii85::encode4bytes {b1 b2 b3 b4} { set val [expr { ( (($b1 & 0xff) << 24) |(($b2 & 0xff) << 16) |(($b3 & 0xff) << 8) | ($b4 & 0xff) ) & 0xffffffff }] return [binary format ccccc \ [expr { ( $val / 52200625) + 33 }] \ [expr { (($val % 52200625) / 614125) + 33 }] \ [expr { (($val % 614125) / 7225) + 33 }] \ [expr { (($val % 7225) / 85) + 33 }] \ [expr { ( $val % 85) + 33 }]] } # ::ascii85::encodefile -- # # Ascii85 encode the contents of a file using default values # for maxlen and wrapchar parameters. # # Arguments: # fname The name of the file to encode. # # Results: # An Ascii85 encoded version of the contents of the file. # This is a convenience command proc ascii85::encodefile {fname} { set fd [open $fname] fconfigure $fd -encoding binary -translation binary return [encode [read $fd]][close $fd] } # ::ascii85::decode -- # # Ascii85 decode a given string. # # Arguments: # string The string to decode. # Leading spaces and tabs are removed, along with trailing newlines # # Results: # The decoded value. proc ascii85::decode {data} { # get rid of leading spaces/tabs and trailing newlines set data [string map [list \n {} \t {} { } {}] $data] set len [string length $data] # perform this ckeck early if {! $len} { return "" } set decoded {} set count 0 set group [list] binary scan $data c* X foreach char $X { # we must check that every char is in the allowed range if {$char < 33 || $char > 117 } { # "z" is an exception if {$char == 122} { if {$count == 0} { # if a "z" char appears at the beggining of a group, # it decodes as four null bytes append decoded \x00\x00\x00\x00 continue } else { # if not, is an error return -code error \ "error decoding data: \"z\" char misplaced" } } # char is not in range and not a "z" at the beggining of a group return -code error \ "error decoding data: chars outside the allowed range" } lappend group $char incr count if {$count == 5} { # this is an inlined version of the [decode5chars] proc # included here for performance reasons set val [expr { ([lindex $group 0] - 33) * wide(52200625) + ([lindex $group 1] - 33) * 614125 + ([lindex $group 2] - 33) * 7225 + ([lindex $group 3] - 33) * 85 + ([lindex $group 4] - 33) }] if {$val > 0xffffffff} { return -code error "error decoding data: decoded group overflow" } else { append decoded [binary format I $val] incr count -5 set group [list] } } } set len [llength $group] switch -- $len { 0 { # all input has been consumed # do nothing } 1 { # a single char is a condition error, there should be at least 2 return -code error \ "error decoding data: trailing char" } default { # pad with "u"s, decode and add ($len - 1) bytes append decoded [string range \ [decode5chars [pad $group 5 122]] \ 0 \ [expr {$len - 2}]] } } return $decoded } proc ascii85::decode5chars {group} { set val [expr { ([lindex $group 0] - 33) * wide(52200625) + ([lindex $group 1] - 33) * 614125 + ([lindex $group 2] - 33) * 7225 + ([lindex $group 3] - 33) * 85 + ([lindex $group 4] - 33) }] if {$val > 0xffffffff} { return -code error "error decoding data: decoded group overflow" } return [binary format I $val] } proc ascii85::pad {chars len padchar} { while {[llength $chars] < $len} { lappend chars $padchar } return $chars } package provide ascii85 1.0 tcllib-1.15/modules/base64/yencode.pcx0000644000175000017500000000555612077663115017150 0ustar sergeisergei# -*- tcl -*- yencode.pcx # Syntax of the commands provided by package yencode. # # For use by TclDevKit's static syntax checker. # See http://www.activestate.com/solutions/tcl/ # See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api # for the documentation describing the format of the code contained in this file # package require pcx pcx::register yencode pcx::tcldep 1.1.1 needs tcl 8.2 namespace eval ::yencode {} # Using the indirections below looks to be quite pointless, given that # they simply substitute the commands for others. I am doing this for # two reasons. # First, the rules coming after become self-commenting, i.e. a # maintainer can immediately see what an argument is supposed to be, # instead of having to search elsewhere (like the documentation and # implementation). In this manner our definitions here are a type of # semantic markup. # The second reason is that while we have no special checks now we # cannot be sure if such will (have to) be added in the future. With # all checking routed through our definitions we now already have the # basic infrastructure (i.e. hooks) in place in which we can easily # add any new checks by simply redefining the relevant command, and # all the rules update on their own. Mostly. This should cover 90% of # the cases. Sometimes new checks will require to create deeper # distinctions between different calls of the same thing. For such we # may have to update the rules as well, to provide the necessary # information to the checker. interp alias {} yencode::checkMode {} checkWord ; # interp alias {} yencode::checkDstFilename {} checkWord ; # interp alias {} yencode::checkData {} checkWord ; # interp alias {} yencode::checkLineLength {} checkInt ; # interp alias {} yencode::checkCrc32Flag {} checkBoolean ; # #pcx::message FOO {... text ...} type #pcx::scan pcx::check 1.1.1 std ::yencode::ydecode \ {checkConstrained {checkSimpleArgs 1 -1 { {checkSwitches 1 { {-filename {checkSetConstraint hasfilename checkFileName}} -- } {checkConstraint { {hasfilename {checkSimpleArgs 0 0 {}}} {!hasfilename {checkSimpleArgs 1 1 { yencode::checkData }}} } {}}} }}} # TODO: Limit -mode to a octal numbers (file permissions) pcx::check 1.1.1 std ::yencode::yencode \ {checkConstrained {checkSimpleArgs 1 -1 { {checkSwitches 1 { {-crc32 yencode::checkCrc32Flag} {-line yencode::checkLineLength} {-mode yencode::checkMode} {-name yencode::checkDstFilename} {-filename {checkSetConstraint hasfilename checkFileName}} -- } {checkConstraint { {hasfilename {checkSimpleArgs 0 0 {}}} {!hasfilename {checkSimpleArgs 1 1 { yencode::checkData }}} } {}}} }}} # Initialization via pcx::init. # Use a ::yencode::init procedure for non-standard initialization. pcx::complete tcllib-1.15/modules/base64/base64c.tcl0000644000175000017500000000101112077663115016717 0ustar sergeisergei# base64c - Copyright (C) 2003 Pat Thoyts # # This package is a place-holder for the critcl enhanced code present in # the tcllib base64 module. # # Normally this code will become part of the tcllibc library. # # @sak notprovided base64c package require critcl package provide base64c 0.1.0 namespace eval ::base64c { variable base64c_rcsid {$Id: base64c.tcl,v 1.5 2008/03/25 07:15:35 andreas_kupries Exp $} critcl::ccode { /* no code required in this file */ } } tcllib-1.15/modules/base64/yencode.test0000644000175000017500000000524612077663115017331 0ustar sergeisergei# yencode.test - Copyright (C) 2002 Pat Thoyts # # Tests for the Tcllib yencode package # # ------------------------------------------------------------------------- # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ------------------------------------------------------------------------- # RCS: @(#) $Id: yencode.test,v 1.11 2008/12/12 04:57:46 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.2 testsNeedTcltest 1.0 testing { # FUTURE: Switch tcl/critcl implementations useTcllibC useLocalKeep yencode.tcl yencode } # ------------------------------------------------------------------------- if {[llength [info commands ::yencode::CEncode]]} { puts "> critcl based" } else { puts "> pure tcl" } proc ::yencode::loaddata {filename {translation auto}} { set f [open $filename r] fconfigure $f -translation $translation set data [read $f] close $f return $data } # ------------------------------------------------------------------------- set datafile [localPath yencode.test.data] test yencode-1.0 {yencode yEnc test file} { set enc [::yencode::yencode -file $datafile] set dec [::yencode::ydecode $enc] set chk [::yencode::loaddata $datafile] string equal $dec $chk } {0} # ------------------------------------------------------------------------- foreach {n in out} { 0 A {k} 1 ABC {klm} 2 \0\1\2 {*+,} 3 "\r\n\t" {743} 4 "\xd6\xe0\xe3" {=@=J=M} } { test yencode-2.$n.a {check the pure tcl encode} { list [catch {::yencode::Encode $in} r] $r } [list 0 $out] test yencode-2.$n.b {check the pure tcl decode} { list [catch {::yencode::Decode $out} r] $r } [list 0 $in] } if {[llength [info commands ::yencode::CEncode]]} { foreach {n in out} { 0 A {k} 1 ABC {klm} 2 \0\1\2 {*+,} 3 "\r\n\t" {743} 4 "\xd6\xe0\xe3" {=@=J=M} } { test yencode-3.$n.a {check the critcl encode} { list [catch {::yencode::Encode $in} r] $r } [list 0 $out] test yencode-3.$n.b {check the critcl decode} { list [catch {::yencode::Decode $out} r] $r } [list 0 $in] } } # ------------------------------------------------------------------------- catch { unset datafile rename ::yencode::loaddata {} } testsuiteCleanup # Local Variables: # mode: tcl # indent-tabs-mode: nil # End: tcllib-1.15/modules/base64/yencode.man0000644000175000017500000000566112077663115017126 0ustar sergeisergei[manpage_begin yencode n 1.1.2] [copyright {2002, Pat Thoyts}] [moddesc {Text encoding & decoding binary data}] [titledesc {Y-encode/decode binary data}] [category {Text processing}] [require Tcl 8.2] [require yencode [opt 1.1.2]] [description] [para] This package provides a Tcl-only implementation of the yEnc file encoding. This is a recently introduced method of encoding binary files for transmission through Usenet. This encoding packs binary data into a format that requires an 8-bit clean transmission layer but that escapes characters special to the [term NNTP] posting protocols. See [uri http://www.yenc.org/] for details concerning the algorithm. [list_begin definitions] [call [cmd ::yencode::encode] [arg string]] returns the yEnc encoded data. [call [cmd ::yencode::decode] [arg "string"]] Decodes the given yEnc encoded data. [call [cmd ::yencode::yencode] \ [opt "[option -name] [arg string]"] \ [opt "[option -line] [arg integer]"] \ [opt "[option -crc32] [arg boolean]"] \ "([option -file] [arg filename] | [opt [option --]] [arg string])"] Encode a file or block of data. [call [cmd ::yencode::ydecode] \ "([option -file] [arg filename] | [opt [option --]] [arg string])"] Decode a file or block of data. A file may contain more than one embedded file so the result is a list where each element is a three element list of filename, file size and data. [list_end] [section OPTIONS] [list_begin definitions] [def "-filename name"] Cause the yencode or ydecode commands to read their data from the named file rather that taking a string parameter. [def "-name string"] The encoded data header line contains the suggested file name to be used when unpacking the data. Use this option to change this from the default of "data.dat". [def "-line integer"] The yencoded data header line contains records the line length used during the encoding. Use this option to select a line length other that the default of 128. Note that NNTP imposes a 1000 character line length limit and some gateways may have trouble with more than 255 characters per line. [def "-crc32 boolean"] The yEnc specification recommends the inclusion of a cyclic redundancy check value in the footer. Use this option to change the default from [arg true] to [arg false]. [list_end] [para] [example { % set d [yencode::yencode -file testfile.txt] =ybegin line=128 size=584 name=testfile.txt -o- data not shown -o- =yend size=584 crc32=ded29f4f }] [section References] [list_begin enum] [enum] [uri http://www.yenc.org/yenc-draft.1.3.txt] [list_end] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph base64] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords encoding yEnc yencode ydecode] [manpage_end] tcllib-1.15/modules/base64/yencode.test.out0000644000175000017500000000165612077663115020140 0ustar sergeisergeiFrom: develop@winews.net Newsgroups: yenc Date: 27 Oct 2001 15:07:44 +0200 Subject: yEnc-Prefix: "testfile.txt" 584 yEnc bytes - yEnc test (1) Message-ID: <4407f.ra1200@liebchen.winews.net> Path: liebchen.winews.net!not-for-mail Lines: 16 X-Newsreader: MyNews -- =ybegin line=128 size=584 name=testfile.txt £o˜JWJ~ž“–JR[S74k}mssdJ\__XXZ74)('&%$#"! =M =J=I=@ÿþýüûúùø÷öõôóòñðïîíìëêéèçæåäãâáàßÞÝÜÛÚÙØ×ÖÕÔÓÒ ÑÐÏÎÍÌËÊÉÈÇÆÅÄÃÂÁÀ¿¾½¼»º¹¸·¶µ´³²±°¯®­¬«ª©¨§¦¥¤£¢¡ Ÿžœ›š™˜—–•”“’‘ŽŒ‹Š‰ˆ‡†…„ƒ‚€~}|{zyxwvutsrqponmlkjihgfedcba`_^]\[ZYXWVUTSR QPONMLKJIHGFEDCBA@?>=}<;:9876543210/=n-,+*74k}mssdJZXX\__74*+,-=n/0123456789:;<=}>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijkl mnopqrstuvwxyz{|}~€‚ƒ„…†‡ˆ‰Š‹ŒŽ‘’“”•–—˜™š›œžŸ ¡¢£¤¥¦§¨©ª«¬­®¯°±²³´µ¶·¸¹º»¼½¾¿ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖ×ØÙÚÛÜÝÞßàáâãäåæçèéêëì íîïðñòóôõö÷øùúûüýþÿ=@=I=J =M !"#$%&'()74o˜ŽJ™J~ž“–74 =yend size=584 crc32=ded29f4f tcllib-1.15/modules/base64/ascii85.pcx0000644000175000017500000000447512077663115016766 0ustar sergeisergei# -*- tcl -*- ascii85.pcx # Syntax of the commands provided by package ascii85. # # For use by TclDevKit's static syntax checker. # See http://www.activestate.com/solutions/tcl/ # See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api # for the documentation describing the format of the code contained in this file # package require pcx pcx::register ascii85 pcx::tcldep 1.0 needs tcl 8.4 namespace eval ::ascii85 {} # Using the indirections below looks to be quite pointless, given that # they simply substitute the commands for others. I am doing this for # two reasons. # First, the rules coming after become self-commenting, i.e. a # maintainer can immediately see what an argument is supposed to be, # instead of having to search elsewhere (like the documentation and # implementation). In this manner our definitions here are a type of # semantic markup. # The second reason is that while we have no special checks now we # cannot be sure if such will (have to) be added in the future. With # all checking routed through our definitions we now already have the # basic infrastructure (i.e. hooks) in place in which we can easily # add any new checks by simply redefining the relevant command, and # all the rules update on their own. Mostly. This should cover 90% of # the cases. Sometimes new checks will require to create deeper # distinctions between different calls of the same thing. For such we # may have to update the rules as well, to provide the necessary # information to the checker. interp alias {} ascii85::checkLineLength {} checkInt ; # interp alias {} ascii85::checkWrapChar {} checkWord ; # interp alias {} ascii85::checkData {} checkWord ; # #pcx::message FOO {... text ...} type #pcx::scan pcx::check 1.0 std ::ascii85::decode \ {checkSimpleArgs 1 1 { ascii85::checkData }} # NOTE: Is '-maxlen' < 0 allowed? # Doc doesn't forbid it, code doesn't catch it. # May crash it however, i.e be a bug. # Check testsuite. pcx::check 1.0 std ::ascii85::encode \ {checkSimpleArgs 1 -1 { {checkSwitches 1 { {-maxlen ascii85::checkLineLength} {-wrapchar ascii85::checkWrapChar} } {checkSimpleArgs 1 1 { ascii85::checkData }}} }} # Initialization via pcx::init. # Use a ::ascii85::init procedure for non-standard initialization. pcx::complete tcllib-1.15/modules/base64/yencode.bench0000644000175000017500000000215012077663115017420 0ustar sergeisergei# -*- tcl -*- # Tcl Benchmark File # # This file contains a number of benchmarks for the 'yencode' module. # This allow developers to monitor/gauge/track package performance. # # (c) 2005 Andreas Kupries # We need at least version 8.2 for the package and thus the # benchmarks. if {![package vsatisfies [package provide Tcl] 8.2]} { return } # ### ### ### ######### ######### ######### ########################### ## Setting up the environment ... package forget yencode catch {namespace delete ::yencode} source [file join [file dirname [info script]] yencode.tcl] # ### ### ### ######### ######### ######### ########################### ## Benchmarks. foreach n {10 100 1000 10000} { bench -desc "YENCODE encode ${n}X" -pre { set str [string repeat X $n] } -body { yencode::encode $str } -post { unset str } bench -desc "YENCODE decode ${n}X" -pre { set str [yencode::encode [string repeat X $n]] } -body { yencode::decode $str } -post { unset str } } # ### ### ### ######### ######### ######### ########################### ## Complete tcllib-1.15/modules/base64/base64.bench0000644000175000017500000000264012077663115017062 0ustar sergeisergei# -*- tcl -*- # Tcl Benchmark File # # This file contains a number of benchmarks for the 'base64' module. # This allow developers to monitor/gauge/track package performance. # # (c) 2005 Andreas Kupries # We need at least version 8.2 for the package and thus the # benchmarks. if {![package vsatisfies [package provide Tcl] 8.2]} { return } # ### ### ### ######### ######### ######### ########################### ## Setting up the environment ... set moddir [file dirname [file dirname [info script]]] lappend auto_path $moddir package forget base64 catch {namespace delete ::base64} source [file join [file dirname [info script]] base64.tcl] # ### ### ### ######### ######### ######### ########################### ## Benchmarks. foreach n {10 100 1000 10000} { bench -desc "BASE64 encode ${n}X" -pre { set str [string repeat X $n] } -body { base64::encode $str } -post { unset str } bench -desc "BASE64 decode ${n}X" -pre { set str [base64::encode [string repeat X $n]] } -body { base64::decode $str } -post { unset str } } foreach wrap {1 10 60 100} { foreach n {10 100 1000 10000} { bench -desc "BASE64 encode ${n}X -wrap $wrap" -pre { set str [string repeat X $n] } -body { base64::encode -wrap $wrap $str } -post { unset str } } } # ### ### ### ######### ######### ######### ########################### ## Complete tcllib-1.15/modules/base64/base64.test0000644000175000017500000001472412077663115016770 0ustar sergeisergei# Tests for the base64 module. -*- tcl -*- # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1998-2000 by Ajuba Solutions. # All rights reserved. # # RCS: @(#) $Id: base64.test,v 1.17 2011/11/09 04:31:24 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.2 testsNeedTcltest 1.0 testing { useLocal base64.tcl base64 } # ------------------------------------------------------------------------- if {[catch {package present Trf}]} { puts "> pure Tcl" tcltest::testConstraint trf 0 } else { puts "> Trf based" tcltest::testConstraint trf 1 } # ------------------------------------------------------------------------- test base64-1.1 {base64::encode} { base64::encode "this is a test\n" } "dGhpcyBpcyBhIHRlc3QK" test base64-1.2 {base64::encode wraps lines at 76 characters} { set str "The short red fox ran quickly through the green field " append str "and jumped over the tall brown bear\n" base64::encode $str } "VGhlIHNob3J0IHJlZCBmb3ggcmFuIHF1aWNrbHkgdGhyb3VnaCB0aGUgZ3JlZW4gZmllbGQgYW5k IGp1bXBlZCBvdmVyIHRoZSB0YWxsIGJyb3duIGJlYXIK" test base64-1.3 {base64::encode with wrap length set to 60} { set str "The short red fox ran quickly through the green field " append str "and jumped over the tall brown bear\n" base64::encode -maxlen 60 $str } "VGhlIHNob3J0IHJlZCBmb3ggcmFuIHF1aWNrbHkgdGhyb3VnaCB0aGUgZ3Jl ZW4gZmllbGQgYW5kIGp1bXBlZCBvdmVyIHRoZSB0YWxsIGJyb3duIGJlYXIK" test base64-1.4 {base64::encode with wrap length set to 0} { set str "The short red fox ran quickly through the green field " append str "and jumped over the tall brown bear\n" base64::encode -maxlen 0 $str } "VGhlIHNob3J0IHJlZCBmb3ggcmFuIHF1aWNrbHkgdGhyb3VnaCB0aGUgZ3JlZW4gZmllbGQgYW5kIGp1bXBlZCBvdmVyIHRoZSB0YWxsIGJyb3duIGJlYXIK" test base64-1.5 {base64::encode with wrap length set to 76, wrapchar to newline+space} { set str "The short red fox ran quickly through the green field " append str "and jumped over the tall brown bear\n" base64::encode -maxlen 76 -wrapchar "\n " $str } "VGhlIHNob3J0IHJlZCBmb3ggcmFuIHF1aWNrbHkgdGhyb3VnaCB0aGUgZ3JlZW4gZmllbGQgYW5k IGp1bXBlZCBvdmVyIHRoZSB0YWxsIGJyb3duIGJlYXIK" test base64-1.6 {base64::encode, errors} { list [catch {base64::encode} msg] $msg } [list 1 "wrong # args: should be \"base64::encode ?-maxlen maxlen? ?-wrapchar wrapchar? string\""] test base64-1.7 {base64::encode, errors} { list [catch {base64::encode -maxlen foo} msg] $msg } [list 1 "value for \"-maxlen\" missing"] test base64-1.8 {base64::encode, errors} { list [catch {base64::encode -maxlen foo bar} msg] $msg } [list 1 "expected integer but got \"foo\""] test base64-1.9 {base64::encode, errors} { list [catch {base64::encode -maxlen foo -wrapchar bar} msg] $msg } [list 1 "value for \"-wrapchar\" missing"] test base64-1.10 {base64::encode, errors} { list [catch {base64::encode -foo bar} msg] $msg } [list 1 "unknown option \"-foo\": must be -maxlen or -wrapchar"] test base64-1.11 {base64::encode with bogus wrap length (< 0)} { set str "The short red fox ran quickly through the green field " append str "and jumped over the tall brown bear\n" list [catch { base64::encode -maxlen -3 $str } msg] $msg } {1 {expected positive integer but got "-3"}} test base64-1.12 {base64::encode with bogus wrap length (non-numeric)} { set str "The short red fox ran quickly through the green field " append str "and jumped over the tall brown bear\n" list [catch { base64::encode -maxlen foo $str } msg] $msg } {1 {expected integer but got "foo"}} test base64-1.13 {base64::encode with bogus wrap length (non-integer)} { set str "The short red fox ran quickly through the green field " append str "and jumped over the tall brown bear\n" list [catch { base64::encode -maxlen 1.5 $str } msg] $msg } {1 {expected integer but got "1.5"}} test base64-1.14 {base64::encode with wrap length set to 20} { set str "The short red fox ran quickly through the green field " append str "and jumped over the tall brown bear\n" base64::encode -maxlen 20 $str } "VGhlIHNob3J0IHJlZCBm b3ggcmFuIHF1aWNrbHkg dGhyb3VnaCB0aGUgZ3Jl ZW4gZmllbGQgYW5kIGp1 bXBlZCBvdmVyIHRoZSB0 YWxsIGJyb3duIGJlYXIK" test base64-1.15 {base64::encode with wrap length set to 23 (prime)} { set str "The short red fox ran quickly through the green field " append str "and jumped over the tall brown bear\n" base64::encode -maxlen 23 $str } "VGhlIHNob3J0IHJlZCBmb3g gcmFuIHF1aWNrbHkgdGhyb3 VnaCB0aGUgZ3JlZW4gZmllb GQgYW5kIGp1bXBlZCBvdmVy IHRoZSB0YWxsIGJyb3duIGJ lYXIK" test base64-2.1 {base64::decode} { base64::decode "dGhpcyBpcyBhIHRlc3QK" } "this is a test\n" test base64-2.2 {base64::decode ignores newlines} { set str "VGhlIHNob3J0IHJlZCBmb3ggcmFuIHF1aWNrbHkgdGhyb3VnaCB0aGUgZ3Jl\n" append str "ZW4gZmllbGQgYW5kIGp1bXBlZCBvdmVyIHRoZSB0YWxsIGJyb3duIGJlYXIK" base64::decode $str } "The short red fox ran quickly through the green field and jumped over the tall brown bear\n" test base64-2.3 {base64::decode handles equal sign padding} { # decode the encoding of a string that will be padded in the encoding with # one padding char base64::decode [base64::encode "01234"] } "01234" test base64-2.4 {base64::decode handles equal sign padding} { # decode the encoding of a string that will be padded in the encoding with # two padding chars base64::decode [base64::encode "0123"] } "0123" test base64-2.5 {base64::decode} { base64::decode "" } "" test base64-2.6 {base64::decode} { base64::decode " " } "" test base64-3.1 {base64 identity test} { base64::decode [base64::encode "this is a test"] } "this is a test" test base64-3.2 {base64 identity test} { # This test fails on version 1.5 because of the format %04x bug # when handling the last characters set x \f\xee set y [base64::decode [base64::encode $x]] string compare $x $y } 0 # For trf a known bug. test base64-4.0 {base64 -- sf bug 2976290} {!trf} { list [catch { ::base64::decode s=GQMRAk5WXhsABh0NEx4RXBocBVgBHQMXHRgEFltMQENQXEFOExJVQ0RAQERUQ0dAEhYEExVIRRVVFENWKxMKABsPGBI6LRoYLhsEFhsXGFkXEwZXGQMIHg== } msg] $msg } {1 {Not enough data to process padding}} testsuiteCleanup return tcllib-1.15/modules/base64/uuencode.tcl0000644000175000017500000002574612077663115017324 0ustar sergeisergei# uuencode - Copyright (C) 2002 Pat Thoyts # # Provide a Tcl only implementation of uuencode and uudecode. # # ------------------------------------------------------------------------- # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ------------------------------------------------------------------------- # @(#)$Id: uuencode.tcl,v 1.22 2009/05/07 01:10:37 patthoyts Exp $ package require Tcl 8.2; # tcl minimum version # Try and get some compiled helper package. if {[catch {package require tcllibc}]} { catch {package require Trf} } namespace eval ::uuencode { variable version 1.1.5 namespace export encode decode uuencode uudecode } proc ::uuencode::Enc {c} { return [format %c [expr {($c != 0) ? (($c & 0x3f) + 0x20) : 0x60}]] } proc ::uuencode::Encode {s} { set r {} binary scan $s c* d foreach {c1 c2 c3} $d { if {$c1 == {}} {set c1 0} if {$c2 == {}} {set c2 0} if {$c3 == {}} {set c3 0} append r [Enc [expr {$c1 >> 2}]] append r [Enc [expr {(($c1 << 4) & 060) | (($c2 >> 4) & 017)}]] append r [Enc [expr {(($c2 << 2) & 074) | (($c3 >> 6) & 003)}]] append r [Enc [expr {($c3 & 077)}]] } return $r } proc ::uuencode::Decode {s} { if {[string length $s] == 0} {return ""} set r {} binary scan [pad $s] c* d foreach {c0 c1 c2 c3} $d { append r [format %c [expr {((($c0-0x20)&0x3F) << 2) & 0xFF | ((($c1-0x20)&0x3F) >> 4) & 0xFF}]] append r [format %c [expr {((($c1-0x20)&0x3F) << 4) & 0xFF | ((($c2-0x20)&0x3F) >> 2) & 0xFF}]] append r [format %c [expr {((($c2-0x20)&0x3F) << 6) & 0xFF | (($c3-0x20)&0x3F) & 0xFF}]] } return $r } # ------------------------------------------------------------------------- # C coded version of the Encode/Decode functions for base64c package. # ------------------------------------------------------------------------- if {[package provide critcl] != {}} { namespace eval ::uuencode { critcl::ccode { #include static unsigned char Enc(unsigned char c) { return (c != 0) ? ((c & 0x3f) + 0x20) : 0x60; } } critcl::ccommand CEncode {dummy interp objc objv} { Tcl_Obj *inputPtr, *resultPtr; int len, rlen, xtra; unsigned char *input, *p, *r; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "data"); return TCL_ERROR; } inputPtr = objv[1]; input = Tcl_GetByteArrayFromObj(inputPtr, &len); if ((xtra = (3 - (len % 3))) != 3) { if (Tcl_IsShared(inputPtr)) inputPtr = Tcl_DuplicateObj(inputPtr); input = Tcl_SetByteArrayLength(inputPtr, len + xtra); memset(input + len, 0, xtra); len += xtra; } rlen = (len / 3) * 4; resultPtr = Tcl_NewObj(); r = Tcl_SetByteArrayLength(resultPtr, rlen); memset(r, 0, rlen); for (p = input; p < input + len; p += 3) { char a, b, c; a = *p; b = *(p+1), c = *(p+2); *r++ = Enc(a >> 2); *r++ = Enc(((a << 4) & 060) | ((b >> 4) & 017)); *r++ = Enc(((b << 2) & 074) | ((c >> 6) & 003)); *r++ = Enc(c & 077); } Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } critcl::ccommand CDecode {dummy interp objc objv} { Tcl_Obj *inputPtr, *resultPtr; int len, rlen, xtra; unsigned char *input, *p, *r; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "data"); return TCL_ERROR; } /* if input is not mod 4, extend it with nuls */ inputPtr = objv[1]; input = Tcl_GetByteArrayFromObj(inputPtr, &len); if ((xtra = (4 - (len % 4))) != 4) { if (Tcl_IsShared(inputPtr)) inputPtr = Tcl_DuplicateObj(inputPtr); input = Tcl_SetByteArrayLength(inputPtr, len + xtra); memset(input + len, 0, xtra); len += xtra; } /* output will be 1/3 smaller than input and a multiple of 3 */ rlen = (len / 4) * 3; resultPtr = Tcl_NewObj(); r = Tcl_SetByteArrayLength(resultPtr, rlen); memset(r, 0, rlen); for (p = input; p < input + len; p += 4) { char a, b, c, d; a = *p; b = *(p+1), c = *(p+2), d = *(p+3); *r++ = (((a - 0x20) & 0x3f) << 2) | (((b - 0x20) & 0x3f) >> 4); *r++ = (((b - 0x20) & 0x3f) << 4) | (((c - 0x20) & 0x3f) >> 2); *r++ = (((c - 0x20) & 0x3f) << 6) | (((d - 0x20) & 0x3f) ); } Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } } } # ------------------------------------------------------------------------- # Description: # Permit more tolerant decoding of invalid input strings by padding to # a multiple of 4 bytes with nulls. # Result: # Returns the input string - possibly padded with uuencoded null chars. # proc ::uuencode::pad {s} { if {[set mod [expr {[string length $s] % 4}]] != 0} { append s [string repeat "`" [expr {4 - $mod}]] } return $s } # ------------------------------------------------------------------------- # If the Trf package is available then we shall use this by default but the # Tcllib implementations are always visible if needed (ie: for testing) if {[info command ::uuencode::CDecode] != {}} { # tcllib critcl package interp alias {} ::uuencode::encode {} ::uuencode::CEncode interp alias {} ::uuencode::decode {} ::uuencode::CDecode } elseif {[package provide Trf] != {}} { proc ::uuencode::encode {s} { return [::uuencode -mode encode -- $s] } proc ::uuencode::decode {s} { return [::uuencode -mode decode -- [pad $s]] } } else { # pure-tcl then interp alias {} ::uuencode::encode {} ::uuencode::Encode interp alias {} ::uuencode::decode {} ::uuencode::Decode } # ------------------------------------------------------------------------- proc ::uuencode::uuencode {args} { array set opts {mode 0644 filename {} name {}} set wrongargs "wrong \# args: should be\ \"uuencode ?-name string? ?-mode octal?\ (-file filename | ?--? string)\"" while {[string match -* [lindex $args 0]]} { switch -glob -- [lindex $args 0] { -f* { if {[llength $args] < 2} { return -code error $wrongargs } set opts(filename) [lindex $args 1] set args [lreplace $args 0 0] } -m* { if {[llength $args] < 2} { return -code error $wrongargs } set opts(mode) [lindex $args 1] set args [lreplace $args 0 0] } -n* { if {[llength $args] < 2} { return -code error $wrongargs } set opts(name) [lindex $args 1] set args [lreplace $args 0 0] } -- { set args [lreplace $args 0 0] break } default { return -code error "bad option [lindex $args 0]:\ must be -file, -mode, or -name" } } set args [lreplace $args 0 0] } if {$opts(name) == {}} { set opts(name) $opts(filename) } if {$opts(name) == {}} { set opts(name) "data.dat" } if {$opts(filename) != {}} { set f [open $opts(filename) r] fconfigure $f -translation binary set data [read $f] close $f } else { if {[llength $args] != 1} { return -code error $wrongargs } set data [lindex $args 0] } set r {} append r [format "begin %o %s" $opts(mode) $opts(name)] "\n" for {set n 0} {$n < [string length $data]} {incr n 45} { set s [string range $data $n [expr {$n + 44}]] append r [Enc [string length $s]] append r [encode $s] "\n" } append r "`\nend" return $r } # ------------------------------------------------------------------------- # Description: # Perform uudecoding of a file or data. A file may contain more than one # encoded data section so the result is a list where each element is a # three element list of the provided filename, the suggested mode and the # data itself. # proc ::uuencode::uudecode {args} { array set opts {mode 0644 filename {}} set wrongargs "wrong \# args: should be \"uudecode (-file filename | ?--? string)\"" while {[string match -* [lindex $args 0]]} { switch -glob -- [lindex $args 0] { -f* { if {[llength $args] < 2} { return -code error $wrongargs } set opts(filename) [lindex $args 1] set args [lreplace $args 0 0] } -- { set args [lreplace $args 0 0] break } default { return -code error "bad option [lindex $args 0]:\ must be -file" } } set args [lreplace $args 0 0] } if {$opts(filename) != {}} { set f [open $opts(filename) r] set data [read $f] close $f } else { if {[llength $args] != 1} { return -code error $wrongargs } set data [lindex $args 0] } set state false set result {} foreach {line} [split $data "\n"] { switch -exact -- $state { false { if {[regexp {^begin ([0-7]+) ([^\s]*)} $line \ -> opts(mode) opts(name)]} { set state true set r {} } } true { if {[string match "end" $line]} { set state false lappend result [list $opts(name) $opts(mode) $r] } else { scan $line %c c set n [expr {($c - 0x21)}] append r [string range \ [decode [string range $line 1 end]] 0 $n] } } } } return $result } # ------------------------------------------------------------------------- package provide uuencode $::uuencode::version # ------------------------------------------------------------------------- # # Local variables: # mode: tcl # indent-tabs-mode: nil # End: tcllib-1.15/modules/base64/uuencode.pcx0000644000175000017500000000524612077663115017325 0ustar sergeisergei# -*- tcl -*- uuencode.pcx # Syntax of the commands provided by package uuencode. # # For use by TclDevKit's static syntax checker. # See http://www.activestate.com/solutions/tcl/ # See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api # for the documentation describing the format of the code contained in this file # package require pcx pcx::register uuencode pcx::tcldep 1.1.4 needs tcl 8.2 namespace eval ::uuencode {} # Using the indirections below looks to be quite pointless, given that # they simply substitute the commands for others. I am doing this for # two reasons. # First, the rules coming after become self-commenting, i.e. a # maintainer can immediately see what an argument is supposed to be, # instead of having to search elsewhere (like the documentation and # implementation). In this manner our definitions here are a type of # semantic markup. # The second reason is that while we have no special checks now we # cannot be sure if such will (have to) be added in the future. With # all checking routed through our definitions we now already have the # basic infrastructure (i.e. hooks) in place in which we can easily # add any new checks by simply redefining the relevant command, and # all the rules update on their own. Mostly. This should cover 90% of # the cases. Sometimes new checks will require to create deeper # distinctions between different calls of the same thing. For such we # may have to update the rules as well, to provide the necessary # information to the checker. interp alias {} uuencode::checkMode {} checkWord ; # interp alias {} uuencode::checkDstFilename {} checkWord ; # interp alias {} uuencode::checkData {} checkWord ; # #pcx::message FOO {... text ...} type #pcx::scan pcx::check 1.1.4 std ::uuencode::uudecode \ {checkConstrained {checkSimpleArgs 1 -1 { {checkSwitches 1 { {-filename {checkSetConstraint hasfilename checkFileName}} -- } {checkConstraint { {hasfilename {checkSimpleArgs 0 0 {}}} {!hasfilename {checkSimpleArgs 1 1 { uuencode::checkData }}} } {}}} }}} # TODO: Limit -mode to a octal numbers (file permissions) pcx::check 1.1.4 std ::uuencode::uuencode \ {checkConstrained {checkSimpleArgs 1 -1 { {checkSwitches 1 { {-filename {checkSetConstraint hasfilename checkFileName}} {-mode uuencode::checkMode} {-name uuencode::checkDstFilename} -- } {checkConstraint { {hasfilename {checkSimpleArgs 0 0 {}}} {!hasfilename {checkSimpleArgs 1 1 { uuencode::checkData }}} } {}}} }}} # Initialization via pcx::init. # Use a ::uuencode::init procedure for non-standard initialization. pcx::complete tcllib-1.15/modules/javascript/0000755000175000017500000000000012104363635016050 5ustar sergeisergeitcllib-1.15/modules/javascript/javascript.tcl0000644000175000017500000003255412077663116020741 0ustar sergeisergei# javascript.tcl -- # # This file contains procedures that create HTML and Java Script # functions that implement objects such as: # # paired multi-selection boxes # guarded submit buttons # parent and child checkboxes # # Copyright (c) 1998-2000 by Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: javascript.tcl,v 1.5 2005/09/30 05:36:39 andreas_kupries Exp $ package require Tcl 8 package require ncgi 1 package provide javascript 1.0.2 namespace eval ::javascript { # The SelectionObjList namespace variable is used to keep the list of # selection boxes that were created as parts of paired multi-selection # boxes. When a submit button is made for pages that have paired # multi-selection boxes, we set a hidden field to store the initial values # in the box. variable SelectionObjList {} } # ::javascript::BeginJS -- # # Create HTML code to begin a java script program. # # Arguments: # none. # # Results: # Returns HTML code. proc ::javascript::BeginJS {} { return "\n\n" } # ::javascript::MakeMultiSel -- # # Construct HTML code to create a multi-selection box. # # Arguments: # id The suffix of all HTML objects in this megawidget. # side Either "left" or "right". # eltValues The values to populate the selection box with. # eltNames The values to populate the selection box with. # emptyElts The number of empty box entry to stuff in the # Selection box as placeholders for elts to be added. # length The number of elts to show before adding a vertical # scrollbar. # minWidth Number of spaces to determin the minimum box width. # # Results: # Returns HTML to show the selection box. proc ::javascript::MakeMultiSel {id side eltValues eltNames emptyElts \ length minWidth} { variable SelectionObjList # Add this selection box to the list. set name "$side$id" lappend SelectionObjList $name # Create the selection box and populate it with elts. set html "" append html "" return $html } # ::javascript::MakeClickProc -- # # Create a "moveSelected$id" java script procedure to move selected items # from one selection box to the other. # # Arguments: # id The suffix of all objects in this multiselection megawidget. # # Results: # Returns java script code. proc ::javascript::MakeClickProc {id} { set result "\nfunction moveSelected${id}(fromObj,toObj) \{\n" # If nothing is selected, do nothing. append result "\n if (fromObj.selectedIndex > -1) \{" # Find the first empty element in the toObj. append result { for (var k = 0; toObj.options[k].value != ""; k++) {} } # Move the selected elements from the fromObj to the end of the toObj. # Shift the objects in the fromObj to fill any empty spots. # Clear out any extra slots in the fromObj. # Deselect any selected elements (deselect with both 'selected = false' # and by setting selectedIndex to -1, because setting selectedIndex to # -1 didn't seem to clear selection on all windows browsers. append result { for (var i = fromObj.selectedIndex, j = fromObj.selectedIndex; fromObj.options[i].value != ""; i++) { if (fromObj.options[i].selected) { toObj.options[k].text = fromObj.options[i].text toObj.options[k++].value = fromObj.options[i].value fromObj.options[i].selected = false } else { fromObj.options[j].text = fromObj.options[i].text fromObj.options[j++].value = fromObj.options[i].value } } for (; j < i; j++) { fromObj.options[j].text = "" fromObj.options[j].value = "" } fromObj.selectedIndex = -1 } # Close the if statement and the function append result " \} \} " return $result } # ::javascript::makeSelectorWidget -- # # Construct HTML code to create a dual-multi-selection megawidget. This # megawidget consists of two side-by-side multi-selection boxes # separated by a left arrow and a right arrow button. The right arrow # button moves all items selected in the left box to the right box. The # left arrow button moves all items selected in the right box to the left # box. # # Arguments: # id The suffix of all HTML objects in this megawidget. # leftLabel The text that appears above the left selection box. # leftValueList The values of items in the left selection box. # leftNameList The names to appear in the left selection box. # rightLabel The text that appears above the right selection box. # rightValueList The values of items in the right selection box. # rightNameList The names to appear in the right selection box. # length (optional) The number of elts to show before adding a # vertical scrollbar. Defaults to 8. # minWidth (optional) The number of spaces to determin the # minimum box width. Defaults to 32. # # Results: # Returns HTML to show the dual-multi-selection megawidget. proc ::javascript::makeSelectorWidget {id leftLabel leftValueList leftNameList \ rightLabel rightValueList rightNameList {length 8} {minWidth 32}} { set html "" append html [BeginJS] \ [MakeClickProc $id] \ [EndJS] append html "\n\n" set leftLen [llength $leftValueList] set rightLen [llength $rightValueList] set len [expr {$leftLen + $rightLen}] append html "\n" append html "\n" append html "\n" append html "\n" \ "
" \ $leftLabel "" $rightLabel "
" \ [MakeMultiSel $id "left" $leftValueList $leftNameList \ $rightLen $length $minWidth] \ "  " \ "\n" set args "this.form.left${id},this.form.right${id}" append html "" set args "this.form.right${id},this.form.left${id}" append html "" append html "
> \">
\n" \ "		" \ [MakeMultiSel $id "right" $rightValueList $rightNameList \ $leftLen $length $minWidth] \ "  
\n" # Add a hidden field to collect the data. append html "\n" \ "\n" return $html } # ::javascript::makeSubmitButton -- # # Create an HTML submit button that resets a hidden field for each # registered multi-selection box. # # Arguments: # name the name of the HTML button object to create. # value the label of the HTML button object to create. # # Results: # Returns HTML submit button code. proc ::javascript::makeSubmitButton {name value} { variable SelectionObjList set html "" # Create the java script procedure that gathers the current values for each # registered multi-selection box. append html [BeginJS] append html "\nfunction getSelections(form) \{\n" # For each registered selection box, reset hidden field to # store nonempty values. foreach obj $SelectionObjList { set selObj "form.$obj" set hiddenObj "form.val$obj" append html " var tmp$obj = \"\"\n" append html " for (var i$obj = 0; i$obj < $selObj.length; i$obj++) {\n" append html " if ($selObj.options\[i$obj\].value == \"\") {\n" append html " break\n" append html " }\n" append html " tmp$obj += \" \" + $selObj.options\[i$obj\].value\n" append html " }\n" append html " $hiddenObj.value = tmp$obj \n" } append html "\}\n" append html [EndJS] # Empty the selection box for the next page. set SelectionObjList {} # Create the HTML submit button. append html "" return $html } # ::javascript::makeProtectedSubmitButton -- # # Create an HTML submit button that prompts the user with a # continue/cancel shutdown warning before the form is submitted. # # Arguments: # name the name of the HTML button object to create. # value the label of the HTML button object to create. # msg The message to display when the button is pressed. # # Results: # Returns HTML submit button code. proc ::javascript::makeProtectedSubmitButton {name value msg} { set html "" # Create the java script procedure that gives the user the option to cancel # the server shutdown request. append html [BeginJS] append html "\nfunction areYouSure${name}(form) \{\n" append html " if (confirm(\"$msg\")) \{\n" append html " return true\n" append html " \} else \{\n" append html " return false\n" append html " \}\n" append html "\}\n" append html [EndJS] # Create the HTML submit button. append html "" return $html } # ::javascript::makeMasterButton -- # # Create an HTML button that sets it's slave checkboxs to the boolean # value. # # Arguments: # master the name of the child's parent html checkbox object. # value the value of the master. # slaves the name of child html checkbox object to create. # boolean the java script boolean value that will be given to all the # slaves. Must be true or false. # # Results: # Returns HTML code to create the child checkbox. proc ::javascript::makeMasterButton {master value slavePattern boolean} { set html "" # Create the java script "checkMaster$name" proc that gets called when the # master checkbox is selected or de-selected. append html [BeginJS] append html "\nfunction checkMaster${master}(form) \{\n" append html " for (var i = 0; i < form.elements.length; i++) \{\n" append html " if (form.elements\[i\].name.match('$slavePattern')) \{\n" append html " form.elements\[i\].checked = $boolean \n" append html " \}\n" append html " \}\n" append html "\}\n" append html [EndJS] # Create the HTML button object. append html "\n" return $html } # ::javascript::makeParentCheckbox -- # # Create an HTML checkbox and tie its value to that of it's child # checkbox. If the parent is unchecked, the child is automatically # unchecked. # # Arguments: # parentName the name of parent html checkbox object to create. # childName the name of the parent's child html checkbox object # Results: # Returns HTML code to create the child checkbox. proc ::javascript::makeParentCheckbox {parentName childName} { set parentObj "form.$parentName" set childObj "form.$childName" set html "" # Create the java script "checkParent$name" proc that gets called when the # parent checkbox is selected or de-selected. append html [BeginJS] append html "\nfunction checkParent${parentName}(form) \{\n" append html " if (!$parentObj.checked && $childObj.checked) \{\n" append html " $childObj.checked = false\n" append html " \}\n" append html "\}\n" append html [EndJS] # Create the HTML checkbox object. append html "" return $html } # ::javascript::makeChildCheckbox -- # # Create an HTML checkbox and tie its value to that of it's parent # checkbox. If the child is checked, the parent is automatically # checked. # # Arguments: # parentName the name of the child's parent html checkbox object # childName the name of child html checkbox object to create. # # Results: # Returns HTML code to create the child checkbox. proc ::javascript::makeChildCheckbox {parentName childName} { set parentObj "form.$parentName" set childObj "form.$childName" set html "" # Create the java script "checkChild$name" proc that gets called when the # child checkbox is selected or de-selected. append html [BeginJS] append html "\nfunction checkChild${childName}(form) \{\n" append html " if ($childObj.checked && !$parentObj.checked) \{\n" append html " $parentObj.checked = true\n" append html " \}\n" append html "\}\n" append html [EndJS] # Create the HTML checkbox object. append html "" return $html } tcllib-1.15/modules/javascript/ChangeLog0000644000175000017500000000570312104363437017627 0ustar sergeisergei2013-02-01 Andreas Kupries * * Released and tagged Tcllib 1.15 ======================== * 2011-12-13 Andreas Kupries * * Released and tagged Tcllib 1.14 ======================== * 2011-01-24 Andreas Kupries * * Released and tagged Tcllib 1.13 ======================== * 2009-12-07 Andreas Kupries * * Released and tagged Tcllib 1.12 ======================== * 2008-12-12 Andreas Kupries * * Released and tagged Tcllib 1.11.1 ======================== * 2008-10-16 Andreas Kupries * * Released and tagged Tcllib 1.11 ======================== * 2007-09-12 Andreas Kupries * * Released and tagged Tcllib 1.10 ======================== * 2007-06-20 Andreas Kupries * javascript.man: Fixed bug [SF Bug 1740574], typos in the documentation. Thanks to David Scott Cargo for the report. 2007-03-21 Andreas Kupries * javascript.man: Fixed all warnings due to use of now deprecated commands. Added a section about how to give feedback. 2006-10-03 Andreas Kupries * * Released and tagged Tcllib 1.9 ======================== * 2005-10-06 Andreas Kupries * * Released and tagged Tcllib 1.8 ======================== * 2005-09-28 Andreas Kupries * pkgIndex.tcl: Removed the check for ncgi v1 being loaded before javascript. This type of check has been done traditionally in the implementation itself. Only checks for Tcl versions should be done in the index. 2004-10-05 Andreas Kupries * * Released and tagged Tcllib 1.7 ======================== * 2004-05-23 Andreas Kupries * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * 2003-05-05 Andreas Kupries * * Released and tagged Tcllib 1.4 ======================== * 2003-04-11 Andreas Kupries * javascript.tcl: * javascript.man: * pkgIndex.tcl: Fixed bug #614591. Set version of the package to to 1.0.1. 2003-01-16 Andreas Kupries * javascript.man: More semantic markup, less visual one. 2002-04-12 Andreas Kupries * javascript.man: Added doctools manpage. 2000-11-01 Melissa Chawla * javascript.tcl: created this package. tcllib-1.15/modules/javascript/javascript.man0000644000175000017500000001046512077663116020727 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin javascript n 1.0.2] [moddesc {HTML and Java Script Generation}] [titledesc {Procedures to generate HTML and Java Script structures.}] [category {CGI programming}] [require Tcl 8] [require javascript [opt 1.0.2]] [description] [para] The [package ::javascript] package provides commands that generate HTML and Java Script code. These commands typically return an HTML string as their result. In particular, they do not output their result to [const stdout]. [para] [list_begin definitions] [call [cmd ::javascript::makeSelectorWidget] [arg {id leftLabel leftValueList rightLabel rightValueList rightNameList}] [opt [arg length]] [opt [arg minWidth]]] Construct HTML code to create a dual-multi-selection megawidget. This megawidget consists of two side-by-side multi-selection boxes separated by a left arrow and a right arrow button. The right arrow button moves all items selected in the left box to the right box. The left arrow button moves all items selected in the right box to the left box. The [arg id] argument is the suffix of all HTML objects in this megawidget. The [arg leftLabel] argument is the text that appears above the left selection box. The [arg leftValueList] argument is the values of items in the left selection box. The [arg leftNameList] argument is the names to appear in the left selection box. The [arg rightLabel] argument is the text that appears above the right selection box. The [arg rightValueList] argument is the values of items in the right selection box. The [arg rightNameList] argument is the names to appear in the right selection box. The [arg length] argument (optional) determines the number of elts to show before adding a vertical scrollbar; it defaults to 8. The [arg minWidth] argument (optional) is the number of spaces to determine the minimum box width; it defaults to 32. [call [cmd ::javascript::makeSubmitButton] [arg {name value}]] Create an HTML submit button that resets a hidden field for each registered multi-selection box. The [arg name] argument is the name of the HTML button object to create. The [arg value] argument is the label of the HTML button object to create. [call [cmd ::javascript::makeProtectedSubmitButton] [arg {name value msg}]] Create an HTML submit button that prompts the user with a continue/cancel shutdown warning before the form is submitted. The [arg name] argument is the name of the HTML button object to create. The [arg value] argument is the label of the HTML button object to create. The [arg msg] argument is the message to display when the button is pressed. [call [cmd ::javascript::makeMasterButton] [arg {master value slavePattern boolean}]] Create an HTML button that sets its slave checkboxs to the boolean value. The [arg master] argument is the name of the child's parent html checkbox object. The [arg value] argument is the value of the master. The [arg slaves] argument is the name of child html checkbox object to create. The [arg boolean] argument is the java script boolean value that will be given to all the slaves; it must be "true" or "false". [call [cmd ::javascript::makeParentCheckbox] [arg {parentName childName}]] Create an HTML checkbox and tie its value to that of its child checkbox. If the parent is unchecked, the child is automatically unchecked. The [arg parentName] argument is the name of parent html checkbox object to create. The [arg childName] argument is the name of the parent's child html checkbox object. [call [cmd ::javascript::makeChildCheckbox] [arg {parentName childName}]] Create an HTML checkbox and tie its value to that of its parent checkbox. If the child is checked, the parent is automatically checked. The [arg parentName] argument is the name of the child's parent html checkbox object. The [arg childName] argument is the name of child html checkbox object to create. [list_end] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph javascript] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [see_also html ncgi] [keywords javascript html checkbox submitbutton selectionbox] [manpage_end] tcllib-1.15/modules/javascript/pkgIndex.tcl0000644000175000017500000000026312077663116020334 0ustar sergeisergei# Tcl package index file, version 1.1 if {![package vsatisfies [package provide Tcl] 8]} {return} package ifneeded javascript 1.0.2 [list source [file join $dir javascript.tcl]] tcllib-1.15/modules/control/0000755000175000017500000000000012104363635015362 5ustar sergeisergeitcllib-1.15/modules/control/ChangeLog0000644000175000017500000001577712104363437017155 0ustar sergeisergei2013-02-01 Andreas Kupries * * Released and tagged Tcllib 1.15 ======================== * 2011-12-13 Andreas Kupries * * Released and tagged Tcllib 1.14 ======================== * 2011-01-24 Andreas Kupries * * Released and tagged Tcllib 1.13 ======================== * 2009-12-07 Andreas Kupries * * Released and tagged Tcllib 1.12 ======================== * 2009-11-23 Andreas Kupries * do.test: Fixed result difference between 8.5/8.6. 2008-12-12 Andreas Kupries * * Released and tagged Tcllib 1.11.1 ======================== * 2008-10-16 Andreas Kupries * * Released and tagged Tcllib 1.11 ======================== * 2007-09-12 Andreas Kupries * * Released and tagged Tcllib 1.10 ======================== * 2007-03-21 Andreas Kupries * control.man: Fixed all warnings due to use of now deprecated commands. Added a section about how to give feedback. 2006-10-03 Andreas Kupries * * Released and tagged Tcllib 1.9 ======================== * 2006-01-22 Andreas Kupries * do.test: More boilerplate simplified via use of test support. * no-op.test: 2006-01-19 Andreas Kupries * no-op.test: Hooked into the new common test support code. * do.test: 2005-10-06 Andreas Kupries * * Released and tagged Tcllib 1.8 ======================== * 2005-09-19 Andreas Kupries * do.test (test do-2.3): Made the expected error stack conditional on the version of Tcl executing the testsuite. Tcl 8.5 is now generating a stack different from 8.4 or below. 2004-10-05 Andreas Kupries * * Released and tagged Tcllib 1.7 ======================== * 2004-05-23 Andreas Kupries * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * 2003-05-05 Andreas Kupries * * Released and tagged Tcllib 1.4 ======================== * 2003-05-01 Pat Thoyts * do.test: Skip test 1.14 if tcl < 8.3. 2003-04-11 Andreas Kupries * control.man: * control.tcl: * pkgIndex.tcl: Set version of the package to to 0.1.2. 2003-01-16 Andreas Kupries * control.man: More semantic markup, less visual one. 2002-03-25 Andreas Kupries * control.man: Fixed formatting errors in the doctools manpage. 2002-02-21 Don Porter * control.tcl: * pkgIndex.tcl: Bumped to 0.1.1. * rswitch.tcl: * rswitch.test: removed files from HEAD branch that aren't yet ready for release. * tclIndex: ran genIndex 2002-02-21 Reinhard Max * do.test: Updated do-2.3 to reflect the change of the standard "wrong # args:..." message for Tcl 8.4. (Bug #517595) 2002-02-14 Andreas Kupries * assert.tcl: * do.tcl: Frink run 2002-01-29 Reinhard Max * do.test: Changed the performance comparison part at the end to be skipped during "make test". * RELEASE 0.1: bundled with tcllib 1.2 2002-01-18 Don Porter * Bumped back to 0.1, which has never been released yet. 2002-01-18 Andreas Kupries * Bumped version to 0.2 2002-01-18 Reinhard Max * do.tcl: * do.test: * control.n: Extended [control::do] to allow ommitting the 2nd and 3rd argument. Added tests and changed the manpage to reflect this. 2001-11-30 Don Porter * control.n: Changed format to match precedent in Tcl's memory.n. 2001-11-27 Don Porter * control.n: Added [control::do] to SYNOPSIS. 2001-11-09 Don Porter * control.n: Some revisions to [control::do] documentation, and added LIMITATIONS section where the [return -code] limitation is explained. Corrections to *roff markup. 2001-11-08 Don Porter * ascaller.tcl (ErrorInfoAsCaller): new utility proc that provides only ::errorInfo management, leaving return code matters to the caller. * do.tcl: At the prompting of Reinhard Max, replaced use of the [BodyAsCaller] and [CommandAsCaller] routines with the simpler [ErrorInfoAsCaller] with big performance improvement. * do.test: New tests from Reinhard Max for testing ::errorInfo. * tclIndex: generated 2001-11-07 Don Porter * do.tcl: updated to use [BodyAsCaller] and [CommandAsCaller] so that proper ::errorInfo management is achieved. * rswitch.tcl: * ascaller.tcl (new-file): factored out utility procs from rswitch.tcl so they can be used by other conotrol commands. * tclIndex: generated * rswitch.test: corrected syntax error [Bug 478989] 2001-11-07 Reinhard Max * do.tcl: * do.test: New files: define and test [control::do]. * control.tcl: * control.n: Added support and documentation for [control::do]. * tclIndex: Generated. 2001-11-03 Don Porter * rswitch.tcl: Replaced bogus copyright notice with public domain boilerplate. * rswitch.test: Added tests and test source material. * pkgIndex.tcl: * control.tcl: Addition of rswitch means bump 0.0 -> 0.1. * genIndex (new file): * index.tcl (deleted file): renamed index.tcl -> genIndex so it won't be mistakenly installed anymore. Purpose of genIndex is to regenerate the tclIndex file. [Bug 475846] * tclIndex: Generated. 2001-11-03 Pat Thoyts * rswitch.tcl: checked in Don's usenet posted implementation * rswitch.test: some tests for the rswitch.tcl command. RELEASE 0: bundled with tcllib 1.1 2001-08-21 Don Porter * control.tcl: * control.n: Added and documented new commands [control::control] and [control::assert]. * pkgIndex.tcl: Updated to reflect Tcl 8.2 dependence. * tclIndex: Generated * assert.tcl: New file: implements [control::assert]. 2001-08-21 Don Porter * index.tcl: New file: Utility script for generating tclIndex. * tclIndex: Generated. * no-op.tcl: * no-op.test: New files: Define and test [control::no-op]. * control.tcl: * control.n: * pkgIndex.tcl: * ChangeLog: New files: Main provide script, documentation, and hand-crafted index script of new control package. tcllib-1.15/modules/control/no-op.test0000644000175000017500000000222512077663115017321 0ustar sergeisergei# -*- tcl -*- # Tests for [control::no-op]. # # This file contains a collection of tests for the command [control::no-op] # of the package control in tcllib, the Standard Tcl Library. Sourcing this # file into Tcl runs the tests and generates output for errors. No output # means no errors were found. # # RCS: @(#) $Id: no-op.test,v 1.5 2006/10/09 21:41:40 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.2 testsNeedTcltest 1.0 testing { useLocal control.tcl control } # ------------------------------------------------------------------------- namespace import ::control::no-op # ------------------------------------------------------------------------- test no-op-0.0 {no-op return value} { no-op } {} test no-op-1.0 {no-op argument substitution} { set bcount 0 set b x trace variable b r {incr bcount ;#} set acount 0 proc a args {incr ::acount} list [no-op a $b {a} {a $b} [a] [a $b] {[a]}] $acount $bcount } {{} 2 2} testsuiteCleanup return tcllib-1.15/modules/control/do.tcl0000644000175000017500000000405312077663115016477 0ustar sergeisergei# do.tcl -- # # Tcl implementation of a "do ... while|until" loop. # # Originally written for the "Texas Tcl Shootout" programming contest # at the 2000 Tcl Conference in Austin/Texas. # # Copyright (c) 2001 by Reinhard Max # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: do.tcl,v 1.6 2004/01/15 06:36:12 andreas_kupries Exp $ # namespace eval ::control { proc do {body args} { # # Implements a "do body while|until test" loop # # It is almost as fast as builtin "while" command for loops with # more than just a few iterations. # set len [llength $args] if {$len !=2 && $len != 0} { set proc [namespace current]::[lindex [info level 0] 0] return -code error "wrong # args: should be \"$proc body\" or \"$proc body \[until|while\] test\"" } set test 0 foreach {whileOrUntil test} $args { switch -exact -- $whileOrUntil { "while" {} "until" { set test !($test) } default { return -code error \ "bad option \"$whileOrUntil\": must be until, or while" } } break } # the first invocation of the body set code [catch { uplevel 1 $body } result] # decide what to do upon the return code: # # 0 - the body executed successfully # 1 - the body raised an error # 2 - the body invoked [return] # 3 - the body invoked [break] # 4 - the body invoked [continue] # everything else - return and pass on the results # switch -exact -- $code { 0 {} 1 { return -errorinfo [ErrorInfoAsCaller uplevel do] \ -errorcode $::errorCode -code error $result } 3 { # FRINK: nocheck return } 4 {} default { return -code $code $result } } # the rest of the loop set code [catch {uplevel 1 [list while $test $body]} result] if {$code == 1} { return -errorinfo [ErrorInfoAsCaller while do] \ -errorcode $::errorCode -code error $result } return -code $code $result } } tcllib-1.15/modules/control/pkgIndex.tcl0000644000175000017500000000021012077663115017635 0ustar sergeisergeiif {![package vsatisfies [package provide Tcl] 8.2]} {return} package ifneeded control 0.1.3 [list source [file join $dir control.tcl]] tcllib-1.15/modules/control/do.test0000644000175000017500000001417512077663115016702 0ustar sergeisergei# do.test -- # # Tests for [control::do] # # RCS: @(#) $Id: do.test,v 1.14 2009/11/24 04:52:49 andreas_kupries Exp $ # # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.2 testsNeedTcltest 1.0 testing { useLocal control.tcl control } # ------------------------------------------------------------------------- namespace import ::control::do # ---------------------------------------- test {do-1.0} {do ... while} { set x 0 do {incr x} while {$x < 10} set x } 10 # ---------------------------------------- test {do-1.1} {do ... until} { set x 0 do {incr x} until {$x > 10} set x } 11 # ---------------------------------------- test {do-1.2} {break} { set x 0 do { incr x if {$x == 5} {break} } until {$x == 10} set x } 5 # ---------------------------------------- test {do-1.3} {continue} { set x 0 set xx [list] do { incr x if {$x == 5} {continue} lappend xx $x } until {$x == 10} set xx } {1 2 3 4 6 7 8 9 10} # ---------------------------------------- test {do-1.4} {error} { catch { set x 0 do { incr x if {$x == 5} {foo} } while {$x < 10} } result list $x $result } {5 {invalid command name "foo"}} # ---------------------------------------- test {do-1.5} {return} { proc foo {} { set x 0 do { incr x if {$x == 5} { return $x } } while {$x < 10} } set result [foo] rename foo "" set result } 5 # ---------------------------------------- test {do-1.6} {break in the first loop} { set x 0 do { break incr x } while {$x < 10} set x } 0 # ---------------------------------------- test {do-1.7} {continue in the first loop} { set x 0 set xx [list] do { incr x if {$x == 1} {continue} lappend xx $x } until {$x == 10} set xx } {2 3 4 5 6 7 8 9 10} # ---------------------------------------- test {do-1.8} {error in the first loop} { set x 0 catch { do { foo incr x } until {$x == 10} } result list $x $result } {0 {invalid command name "foo"}} # ---------------------------------------- test {do-1.9} {[do ... while] with false condition} { set x 0 do { incr x } while 0 set x } 1 # ---------------------------------------- test do-1.10 {[do ... until] with true condition} { set x 0 do { incr x } until 1 set x } 1 # ---------------------------------------- test do-1.11 {third arg is neither while nor until} { set x 0 catch { do { incr x } foo 1 set x } result list $x $result } {0 {bad option "foo": must be until, or while}} # ---------------------------------------- test do-1.12 {stack traces for errors in the first iteration} { proc a {} b proc b {} {do c while 1} proc c {} d catch a set ::errorInfo } {invalid command name "d" while executing "d" (procedure "c" line 1) invoked from within "c" ("do" body line 1) invoked from within "do c while 1" (procedure "b" line 1) invoked from within "b" (procedure "a" line 1) invoked from within "a"} # ---------------------------------------- test do-1.14 {stack traces for errors in subsequent iterations} tcl8.3plus { proc a {} b proc b {} { set i 10 do { incr i -1 c $i } while {$i} } proc c {i} {if {$i==5} e} catch a set ::errorInfo } {invalid command name "e" while executing "e" (procedure "c" line 1) invoked from within "c $i" ("do" body line 3) invoked from within "do { incr i -1 c $i } while {$i}" (procedure "b" line 3) invoked from within "b" (procedure "a" line 1) invoked from within "a"} # ---------------------------------------- test do-2.0 {one-shot do} { set x 0 do {incr x} set x } 1 # ---------------------------------------- test do-2.1 {one-shot do with break} { set x 0 do {incr x; break; incr x} set x } 1 # ---------------------------------------- test do-2.2 {wrong no of arguments} { set x 0 set res [catch {do {incr x} foo} ret] list $x $res $errorInfo } {0 1 {wrong # args: should be "::control::do body" or "::control::do body [until|while] test" while executing "do {incr x} foo"}} # ---------------------------------------- if {[package vsatisfies [package provide Tcl] 8.6]} { # 8.6+ set do23res {1 {wrong # args: should be "do body ?arg ...?" while executing "do"}} } elseif {[package vsatisfies [package provide Tcl] 8.5]} { # 8.5+ set do23res {1 {wrong # args: should be "do body ..." while executing "do"}} } else { # 8.4- set do23res {1 {wrong # args: should be "do body args" while executing "do"}} } test do-2.3 {wrong no of arguments} {} { set res [catch do] if {[string match \ {no value given for parameter "body" to "do"*} \ $::errorInfo] } then { set ::errorInfo {wrong # args: should be "do body args" while executing "do"} } list $res $::errorInfo } $do23res # ---------------------------------------- test do-2.4 {one-shot do with error} { set x 0 set res [catch {do { incr x foo incr x }}] list $x $res $::errorInfo } {1 1 {invalid command name "foo" while executing "foo" ("do" body line 3) invoked from within "do { incr x foo incr x }"}} testsuiteCleanup if {[info exists ::argv0] && $::argv0 == [info script]} { # a proc that wastes some time proc something {n} { for {set i 0} {$i < $n} {incr i} {} } proc main {} { # run it for the first time to get it byte compiled something 1 set payload { something 10 incr x } puts "\nComparing performance of do-while, do-until and builtin while..." set format "%-8s : %20s for %4d iteration(s)." foreach c {1 10 5000} { puts "" foreach {descr script} { {do while} {do $payload while {$x < $c}} {do until} {do $payload until {$x == $c}} {while} {while {$x < $c} $payload} } { set x 0 puts [format $format $descr [lrange [time $script 1] 0 1] $x] } } } main } # Local variables: # mode: tcl # End: tcllib-1.15/modules/control/ascaller.tcl0000644000175000017500000000463512077663115017671 0ustar sergeisergei# ascaller.tcl - # # A few utility procs that manage the evaluation of a command # or a script in the context of a caller, taking care of all # the ugly details of proper return codes, errorcodes, and # a good stack trace in ::errorInfo as appropriate. # ------------------------------------------------------------------------- # # RCS: @(#) $Id: ascaller.tcl,v 1.3 2004/01/15 06:36:12 andreas_kupries Exp $ namespace eval ::control { proc CommandAsCaller {cmdVar resultVar {where {}} {codeVar code}} { set x [expr {[string equal "" $where] ? {} : [subst -nobackslashes {\n ($where)}]}] set script [subst -nobackslashes -nocommands { set $codeVar [catch {uplevel 1 $$cmdVar} $resultVar] if {$$codeVar > 1} { return -code $$codeVar $$resultVar } if {$$codeVar == 1} { if {[string equal {"uplevel 1 $$cmdVar"} \ [lindex [split [set ::errorInfo] \n] end]]} { set $codeVar [join \ [lrange [split [set ::errorInfo] \n] 0 \ end-[expr {4+[llength [split $$cmdVar \n]]}]] \n] } else { set $codeVar [join \ [lrange [split [set ::errorInfo] \n] 0 end-1] \n] } return -code error -errorcode [set ::errorCode] \ -errorinfo "$$codeVar$x" $$resultVar } }] return $script } proc BodyAsCaller {bodyVar resultVar codeVar {where {}}} { set x [expr {[string equal "" $where] ? {} : [subst -nobackslashes -nocommands \ {\n ($where[string map {{ ("uplevel"} {}} \ [lindex [split [set ::errorInfo] \n] end]]}]}] set script [subst -nobackslashes -nocommands { set $codeVar [catch {uplevel 1 $$bodyVar} $resultVar] if {$$codeVar == 1} { if {[string equal {"uplevel 1 $$bodyVar"} \ [lindex [split [set ::errorInfo] \n] end]]} { set ::errorInfo [join \ [lrange [split [set ::errorInfo] \n] 0 end-2] \n] } set $codeVar [join \ [lrange [split [set ::errorInfo] \n] 0 end-1] \n] return -code error -errorcode [set ::errorCode] \ -errorinfo "$$codeVar$x" $$resultVar } }] return $script } proc ErrorInfoAsCaller {find replace} { set info $::errorInfo set i [string last "\n (\"$find" $info] if {$i == -1} {return $info} set result [string range $info 0 [incr i 6]] ;# keep "\n (\"" append result $replace ;# $find -> $replace incr i [string length $find] set j [string first ) $info [incr i]] ;# keep rest of parenthetical append result [string range $info $i $j] return $result } } tcllib-1.15/modules/control/control.man0000644000175000017500000001354312077663115017552 0ustar sergeisergei[manpage_begin control n 0.1.3] [moddesc {Tcl Control Flow Commands}] [titledesc {Procedures for control flow structures.}] [category {Programming tools}] [require Tcl 8.2] [require control [opt 0.1.3]] [description] [para] The [cmd control] package provides a variety of commands that provide additional flow of control structures beyond the built-in ones provided by Tcl. These are commands that in many programming languages might be considered [emph keywords], or a part of the language itself. In Tcl, control flow structures are just commands like everything else. [section COMMANDS] [list_begin definitions] [call [cmd control::control] [arg command] [arg option] [opt [arg "arg arg ..."]]] The [cmd control] command is used as a configuration command for customizing the other public commands of the control package. The [arg command] argument names the command to be customized. The set of valid [arg option] and subsequent arguments are determined by the command being customized, and are documented with the command. [call [cmd control::assert] [arg expr] [opt [arg "arg arg ..."]]] When disabled, the [cmd assert] command behaves exactly like the [cmd no-op] command. [para] When enabled, the [cmd assert] command evaluates [arg expr] as an expression (in the same way that [cmd expr] evaluates its argument). If evaluation reveals that [arg expr] is not a valid boolean expression (according to [lb][cmd "string is boolean -strict"][rb]), an error is raised. If [arg expr] evaluates to a true boolean value (as recognized by [cmd if]), then [cmd assert] returns an empty string. Otherwise, the remaining arguments to [cmd assert] are used to construct a message string. If there are no arguments, the message string is "assertion failed: $expr". If there are arguments, they are joined by [cmd join] to form the message string. The message string is then appended as an argument to a callback command, and the completed callback command is evaluated in the global namespace. [para] The [cmd assert] command can be customized by the [cmd control] command in two ways: [para] [lb][cmd "control::control assert enabled"] [opt [arg boolean]][rb] queries or sets whether [cmd control::assert] is enabled. When called without a [arg boolean] argument, a boolean value is returned indicating whether the [cmd control::assert] command is enabled. When called with a valid boolean value as the [arg boolean] argument, the [cmd control::assert] command is enabled or disabled to match the argument, and an empty string is returned. [para] [lb][cmd "control::control assert callback"] [opt [arg command]][rb] queries or sets the callback command that will be called by an enabled [cmd assert] on assertion failure. When called without a [arg command] argument, the current callback command is returned. When called with a [arg command] argument, that argument becomes the new assertion failure callback command. Note that an assertion failure callback command is always defined, even when [cmd assert] is disabled. The default callback command is [lb][cmd "return -code error"][rb]. [para] Note that [cmd control::assert] has been written so that in combination with [lb][cmd "namespace import"][rb], it is possible to use enabled [cmd assert] commands in some namespaces and disabled [cmd assert] commands in other namespaces at the same time. This capability is useful so that debugging efforts can be independently controlled module by module. [para] [example { % package require control % control::control assert enabled 1 % namespace eval one namespace import ::control::assert % control::control assert enabled 0 % namespace eval two namespace import ::control::assert % one::assert {1 == 0} assertion failed: 1 == 0 % two::assert {1 == 0} }] [call [cmd control::do] [arg body] [opt [arg "option test"]]] The [cmd do] command evaluates the script [arg body] repeatedly [emph until] the expression [arg test] becomes true or as long as ([emph while]) [arg test] is true, depending on the value of [arg option] being [const until] or [const while]. If [arg option] and [arg test] are omitted the body is evaluated exactly once. After normal completion, [cmd do] returns an empty string. Exceptional return codes ([cmd break], [cmd continue], [cmd error], etc.) during the evaluation of [arg body] are handled in the same way the [cmd while] command handles them, except as noted in [sectref LIMITATIONS], below. [call [cmd control::no-op] [opt [arg "arg arg ..."]]] The [cmd no-op] command takes any number of arguments and does nothing. It returns an empty string. [list_end] [section LIMITATIONS] Several of the commands provided by the [cmd control] package accept arguments that are scripts to be evaluated. Due to fundamental limitations of Tcl's [cmd catch] and [cmd return] commands, it is not possible for these commands to properly evaluate the command [lb][cmd "return -code \$code"][rb] within one of those script arguments for any value of [arg \$code] other than [arg ok]. In this way, the commands of the [cmd control] package are limited as compared to Tcl's built-in control flow commands (such as [cmd if], [cmd while], etc.) and those control flow commands that can be provided by packages coded in C. An example of this difference: [para] [example { % package require control % proc a {} {while 1 {return -code error a}} % proc b {} {control::do {return -code error b} while 1} % catch a 1 % catch b 0 }] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph control] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [see_also expr if join namespace return string while break continue] [keywords control flow structure no-op assert do] [manpage_end] tcllib-1.15/modules/control/assert.tcl0000644000175000017500000000420212077663115017372 0ustar sergeisergei# assert.tcl -- # # The [assert] command of the package "control". # # RCS: @(#) $Id: assert.tcl,v 1.3 2004/01/15 06:36:12 andreas_kupries Exp $ namespace eval ::control { namespace eval assert { namespace export EnabledAssert DisabledAssert variable CallbackCmd [list return -code error] namespace import [namespace parent]::no-op rename no-op DisabledAssert proc EnabledAssert {expr args} { variable CallbackCmd set code [catch {uplevel 1 [list expr $expr]} res] if {$code} { return -code $code $res } if {![string is boolean -strict $res]} { return -code error "invalid boolean expression: $expr" } if {$res} {return} if {[llength $args]} { set msg [join $args] } else { set msg "assertion failed: $expr" } # Might want to catch this namespace eval :: $CallbackCmd [list $msg] } proc enabled {args} { set n [llength $args] if {$n > 1} { return -code error "wrong # args: should be\ \"[lindex [info level 0] 0] ?boolean?\"" } if {$n} { set val [lindex $args 0] if {![string is boolean -strict $val]} { return -code error "invalid boolean value: $val" } if {$val} { [namespace parent]::AssertSwitch Disabled Enabled } else { [namespace parent]::AssertSwitch Enabled Disabled } } else { return [string equal [namespace origin EnabledAssert] \ [namespace origin [namespace parent]::assert]] } return "" } proc callback {args} { set n [llength $args] if {$n > 1} { return -code error "wrong # args: should be\ \"[lindex [info level 0] 0] ?command?\"" } if {$n} { return [variable CallbackCmd [lindex $args 0]] } variable CallbackCmd return $CallbackCmd } } proc AssertSwitch {old new} { if {[string equal [namespace origin assert] \ [namespace origin assert::${new}Assert]]} {return} rename assert ${old}Assert rename ${new}Assert assert } namespace import assert::DisabledAssert assert::EnabledAssert # For indexer proc assert args # rename assert {} # Initial default: disabled asserts rename DisabledAssert assert } tcllib-1.15/modules/control/control.tcl0000644000175000017500000000135712077663115017561 0ustar sergeisergei# control.tcl -- # # This is the main package provide script for the package # "control". It provides commands that govern the flow of # control of a program. # # RCS: @(#) $Id: control.tcl,v 1.15 2005/09/30 05:36:38 andreas_kupries Exp $ package require Tcl 8.2 namespace eval ::control { variable version 0.1.3 namespace export assert control do no-op rswitch proc control {command args} { # Need to add error handling here namespace eval [list $command] $args } # Set up for auto-loading the commands variable home [file join [pwd] [file dirname [info script]]] if {[lsearch -exact $::auto_path $home] == -1} { lappend ::auto_path $home } package provide [namespace tail [namespace current]] $version } tcllib-1.15/modules/control/no-op.tcl0000644000175000017500000000043312077663115017123 0ustar sergeisergei# no-op.tcl -- # # The [no-op] command of the package "control". # It accepts any number of arguments and does nothing. # It returns an empty string. # # RCS: @(#) $Id: no-op.tcl,v 1.2 2004/01/15 06:36:12 andreas_kupries Exp $ namespace eval ::control { proc no-op args {} } tcllib-1.15/modules/control/genIndex0000644000175000017500000000071712077663115017060 0ustar sergeisergei# Utility program to generate tclIndex file package require Tcl 8.3 set home [file join [pwd] [file dirname [info script]]] cd $home set files [glob -nocomplain *.tcl] set idx [lsearch $files control.tcl] set files [lreplace $files $idx $idx] set idx [lsearch $files index.tcl] set files [lreplace $files $idx $idx] set idx [lsearch $files pkgIndex.tcl] set files [lreplace $files $idx $idx] eval [list auto_mkindex .] $files #pkg_mkIndex -direct . control.tcl tcllib-1.15/modules/control/tclIndex0000644000175000017500000000222612077663115017066 0ustar sergeisergei# Tcl autoload index file, version 2.0 # This file is generated by the "auto_mkindex" command # and sourced to set up indexing information for one or # more commands. Typically each line is a command that # sets an element in the auto_index array, where the # element name is the name of a command and the value is # a script that loads the command. set auto_index(::control::CommandAsCaller) [list source [file join $dir ascaller.tcl]] set auto_index(::control::BodyAsCaller) [list source [file join $dir ascaller.tcl]] set auto_index(::control::ErrorInfoAsCaller) [list source [file join $dir ascaller.tcl]] set auto_index(::control::assert::EnabledAssert) [list source [file join $dir assert.tcl]] set auto_index(::control::assert::enabled) [list source [file join $dir assert.tcl]] set auto_index(::control::assert::callback) [list source [file join $dir assert.tcl]] set auto_index(::control::AssertSwitch) [list source [file join $dir assert.tcl]] set auto_index(::control::assert) [list source [file join $dir assert.tcl]] set auto_index(::control::do) [list source [file join $dir do.tcl]] set auto_index(::control::no-op) [list source [file join $dir no-op.tcl]] tcllib-1.15/modules/grammar_aycock/0000755000175000017500000000000012104363635016661 5ustar sergeisergeitcllib-1.15/modules/grammar_aycock/ChangeLog0000644000175000017500000000221612104363437020434 0ustar sergeisergei2013-02-01 Andreas Kupries * * Released and tagged Tcllib 1.15 ======================== * 2011-12-13 Andreas Kupries * * Released and tagged Tcllib 1.14 ======================== * 2011-01-24 Andreas Kupries * * Released and tagged Tcllib 1.13 ======================== * 2011-01-12 Andreas Kupries * pkgIndex.tcl: Fixed guard condition, requiring 8.5+. * aycock.test: Fixed test setup, i.e. added the standard boilerplate. * aycock-build.tcl: Made proc names fully qualified. * aycock-debug.tcl: * aycock-runtime.tcl: All files changed from Windows to Unix line endings. 2010-10-22 Kevin B. Kenny * aycock.man: Added a missing [list_begin] [list_end] pair bracketing the list of methods for the parser. 2010-10-18 Kevin B, Kenny * aycock-build.tcl: * aycock-debug.tcl: * aycock-runtime.tcl: * aycock.man: * aycock.test: * pkgIndex.tcl: 1.0 release of an Aycock-Earley-Horspool parser generator for Tcl. tcllib-1.15/modules/grammar_aycock/pkgIndex.tcl0000644000175000017500000000054212077663116021145 0ustar sergeisergeiif {![package vsatisfies [package provide Tcl] 8.5]} {return} package ifneeded grammar::aycock 1.0 \ [list source [file join $dir aycock-build.tcl]] package ifneeded grammar::aycock::debug 1.0 \ [list source [file join $dir aycock-debug.tcl]] package ifneeded grammar::aycock::runtime 1.0 \ [list source [file join $dir aycock-runtime.tcl]] tcllib-1.15/modules/grammar_aycock/aycock-build.tcl0000644000175000017500000004542412077663116021752 0ustar sergeisergei#---------------------------------------------------------------------- # # aycock-build.tcl -- # # Procedures needed to compile an Aycock-Horspool-Earley parser. # # Copyright (c) 2006 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: aycock-build.tcl,v 1.2 2011/01/13 02:47:47 andreas_kupries Exp $ # #---------------------------------------------------------------------- package provide grammar::aycock 1.0 package require Tcl 8.4 # Bring in procedures that aid in debugging a parser; they will in turn # bring in procedures that implement the runtime system. package require grammar::aycock::debug 1.0 namespace eval grammar::aycock { # The 'aycock' namespace exports only the 'parser' command, which # constructs a parser. namespace export parser } # grammar::aycock::parser -- # # Creates an Aycock-Earley parser. # # Parameters: # rules - A list that can be broken down into productions. # dump - The optional flag, '-verbose'. If supplied, the rules # and resulting LRE(0) automaton are dumped to the standard # output. # # Results: # Returns the name of a parser, which is an ensemble # supporting a number of subcommands for processing the # language defined by $rules. # # Each production takes the form # symbol ::= rhs { action } # where symbol is a single word defining a nonterminal # symbol; rhs is the right-hand side (a sequence of nonterminal # or terminal symbols) and action is a single word giving # a script to execute when the production is reduced. Within the # action, a variable $_ is defined, which is a list of the same # length as rhs giving the semantic values of each symbol on the # right-hand side. proc ::grammar::aycock::parser {rules {dump {}}} { set name [MakeParser] ProcessRules $name $rules ComputeNullable $name RewriteGrammar $name MakeState0 $name MakeState $name 0 \u22a2 CompleteAutomaton $name unset ${name}::Cores if {$dump eq {-verbose}} { puts "parser: $name" puts "Rules:" DumpRuleSet $name stdout puts "------------------------------------------------------------" DumpAutomaton $name stdout } set l [NeverReduced $name] if {[llength $l] != 0} { return -code error "Rules never reduced: $l" } unset ${name}::Items return $name } # grammar::aycock::MakeParser -- # # Constructs the ensemble that will contain an Aycock parser. # # Results: # Returns the name of the parser, which is an ensemble within # the "aycock" namespace. # # The following commands are members of the ensemble: # parse -- Parses a sequence of symbols and returns its lexical # value. # destroy -- Destroys the parser. # terminals -- Lists the terminal symbols accepted by the parser # nonterminals -- Lists the nonterminal symbols reduced by the parser # save -- Returns a command to recreate the parser without needing # to analyze the rule set. proc ::grammar::aycock::MakeParser {} { variable parserCount set name [namespace current]::parser[incr parserCount] namespace eval $name { namespace export parse terminals nonterminals save destroy } proc ${name}::parse {symList vallist {clientData {}}} \ [string map [list \ PROC [namespace current]::Parse \ PARSER $name] { PROC PARSER $symList $vallist $clientData }] proc ${name}::terminals {} \ [list [namespace current]::Terminals $name] proc ${name}::nonterminals {} \ [list [namespace current]::Nonterminals $name] proc ${name}::save {} \ [list [namespace current]::Save $name] proc ${name}::destroy {} \ [list namespace delete $name] namespace eval $name { namespace ensemble create } return $name } # grammar::aycock::ProcessRules -- # # Processes the rule set presented to grammar::aycock::parser # # Parameters: # parser -- Name of the parser # rules -- Rule set # # Results: # None. # # Side effects: # RuleSet is set to be a dictionary indexed by nonterminal symbol # name, whose values are alternating right-hand sides and names # of action procedures. A set of Action procedures is constructed # for the reduction actions. proc ::grammar::aycock::ProcessRules {parser rules} { namespace upvar $parser \ RuleSet RuleSet \ ActionProcs ActionProcs \ APCount APCount # Locate the "::=" symbols within the rules. set RuleSet [dict create] set ActionProcs [dict create] set APCount 0 set positions {} set i 0 foreach sym $rules { if {$sym eq {::=}} { lappend positions [expr {$i-1}] } incr i } lappend positions [llength $rules] # For each rule, place the right-hand side and action into # the appropriate RuleSet entry. set lastp [lindex $positions 0] set top [lindex $rules $lastp] foreach p [lrange $positions 1 end] { set lhs [lindex $rules $lastp] set rhs [lrange $rules [expr {$lastp + 2}] [expr {$p - 2}]] set action [MakeAction $parser [lindex $rules [expr {$p - 1}]]] set lastp $p dict lappend RuleSet $lhs $rhs dict lappend RuleSet $lhs $action } # Make a special "start" rule (whose name is the empty string) # whose right-hand side is "right tack" followed by the name of # the initial rule. dict lappend RuleSet {} [list \u22a2 $top] dict lappend RuleSet {} [MakeAction $parser {lindex $_ 1}] # Clean up memory. unset ${parser}::ActionProcs unset ${parser}::APCount return } # grammar::aycock::MakeAction -- # # Defines an action procedure for the parser to use at run time. # # Parameters: # parser -- Name of the parser # body -- Body of the action procedure, which is expected to # return the semantic value of some nonterminal after reduction. # # Results: # Returns the name of the action procedure. # # Side effects: # Creates the action procedure, which will accept a single parameter, # "_", containing the semantic values of the symbols on the right-hand # side. proc ::grammar::aycock::MakeAction {parser {body {lindex $_ 0}}} { namespace upvar $parser \ ActionProcs ActionProcs \ APCount APCount if {$body eq {}} { set body {lindex $_ 0} } if {![dict exists $ActionProcs $body]} { set pname Action\#[incr APCount] dict set ActionProcs $body $pname namespace eval $parser [list proc $pname {_ clientData} $body] } return [dict get $ActionProcs $body] } # grammar::aycock::ComputeNullable -- # # Determines which rules in the parser's rule set are nullable, that # is, can match the empty sequence of input symbols. # # Parameters: # parser -- Name of the parser. # # Results: # None. # # Side effects: # Sets 'Nullable' to a dictionary whose keys are nonterminal symbol # names and whose values are 1 if the symbol is nullable and 0 otherwise. proc ::grammar::aycock::ComputeNullable {parser} { namespace upvar $parser \ RuleSet RuleSet \ Nullable Nullable set Nullable [dict create] set tbd {} dict for {lhs rules} $RuleSet { dict set Nullable $lhs 0 foreach {rhs action} $rules { if {[llength $rhs] == 0} { dict set Nullable $lhs 1 } else { set ntonly 1 foreach sym $rhs { if {![dict exists $RuleSet $sym]} { set ntonly 0 break } } if {$ntonly} { lappend tbd $lhs $rhs } } } } set changed 1 while {$changed} { set changed 0 foreach {lhs rhs} $tbd { if {![dict get $Nullable $lhs]} { set nullable 1 foreach sym $rhs { if {![dict get $Nullable $sym]} { set nullable 0 break } } if {$nullable} { dict set Nullable $lhs 1 set changed 1 } } } } return } # grammar::aycock::RewriteGrammar -- # # Rewrite $parser's grammar into Nihilistic Normal Form {NNF} # # Parameters: # parser -- Parser to rewrite. # # Results: # None. # # Side effects: # Rewrites the rule set to separate nullable rules from other # rules. The nullable rules are distinguished by having # "{\u00d8}" appended to their names. proc ::grammar::aycock::RewriteGrammar {parser} { namespace upvar $parser \ RuleSet RuleSet \ Nullable Nullable set newRuleSet [dict create] # Create a work list wth all rules not yet examined set worklist {} dict for {lhs rules} $RuleSet { foreach {rhs action} $rules { lappend worklist $lhs $rhs 0 1 $action } } # Process the rules in sequence from the worklist. For each rule, # determine whether it contains a sequence of nullable symbols # on the right-hand side. If it does, split it on the last nullable # symbol. Continue until all possible splits have been done. for {set k 0} {$k < [llength $worklist]} {incr k 5} { foreach {lhs rhs position candidateFlag action} \ [lrange $worklist $k [expr {$k+4}]] break set n [llength $rhs] while {$position < $n} { set sym [lindex $rhs $position] if {![dict exists $Nullable $sym] || ![dict get $Nullable $sym]} { set candidateFlag 0 } else { set newrhs $rhs lset newrhs $position ${sym}\{\u00d8\} lappend worklist $lhs $newrhs [expr {$position+1}] \ $candidateFlag $action set candidateFlag 0 } incr position } if {$position >= $n} { if {$candidateFlag} { set lhs ${lhs}\{\u00d8\} } dict lappend newRuleSet $lhs $rhs dict lappend newRuleSet $lhs $action } } set RuleSet $newRuleSet unset Nullable return } # grammar::aycock::DumpRuleSet -- # # Displays the set of rules in a parser. # # Parameters: # parser - Name of the parser # chan - Channel on which to display the rules # # Results: # None. # # Side effects: # Displays the rule set on the given channel. proc ::grammar::aycock::DumpRuleSet {parser chan} { namespace upvar $parser RuleSet RuleSet dict for {lhs rules} $RuleSet { dict for {rhs action} $rules { puts $chan "$lhs ::= $rhs [list [info body ${parser}::${action}]]" } } return } # grammar::aycock::MakeState0 -- # # Makes the first state of a parser's automaton. # # Parameters: # parser -- Parser under construction. # # Results: # None. # # Side effects: # Builds a state corresponding to the reduction of the start # symbol. Creates "Completions", "Items", "Cores", and "Edges"; # Completions will be a list of lists of right-hand-sides # completed in each state. # Items will be a list of LRE(0) items belonging to # the states. Each item is represented as three elements: # the nonterminal symbol, the rule number in that nonterminal's # rule list, and the position of the dot within the right-hand side. # Edges will be a two-level dictionary - the outer key is state # number and the inner key is a symbol - giving the 'goto' symbol # for a given state and symbol. # Cores is a work dictionary used to avoid state duplication. proc ::grammar::aycock::MakeState0 {parser} { namespace upvar $parser \ RuleSet RuleSet \ Completions Completions \ Items Items \ Cores Cores \ Edges Edges set items {} set i 0 foreach {rhs action} [dict get $RuleSet {}] { lappend items {} $i 0 incr i 2 } set Completions [list {}] set Items [list $items] set Cores [dict create] set Edges [dict create] return } # grammar::aycock::MakeState -- # # Constructs a state of the parsing automaton. # # Parameters: # parser -- Parser under construction # stateIdx - Ordinal number of a state being examined. # sym - Symbol whose goto is being computed # # Results: # Returns goto(state,sym) # # Side effects: # Constructs a new state if necessary, updating Completions, Items # Cores and Edges to reflect it. proc ::grammar::aycock::MakeState {parser stateIdx sym} { namespace upvar $parser \ RuleSet RuleSet \ Completions Completions \ Items Items \ Cores Cores \ Edges Edges if {$sym == {}} { error "Null symbol in MakeState" } set complete [lindex $Completions $stateIdx] # Compute the epsilon-kernel items for the given transition. set Kitems {} set items [lindex $Items $stateIdx] foreach {lhs prodIndex pos} $items { set rhs [lindex [dict get $RuleSet $lhs] $prodIndex] if {[lindex $rhs $pos] == $sym} { set nextPos [SkipOver $rhs [expr {$pos+1}]] lappend Kitems [list $lhs $prodIndex $nextPos] } } # Determine whether we've already built the state. set core {} foreach tuple \ [lsort -index 0 \ [lsort -integer -index 1 \ [lsort -integer -index 2 $Kitems]]] { foreach {lhs prodIndex pos} $tuple break lappend core $lhs $prodIndex $pos } if {[dict exists $Cores $core]} { return [dict get $Cores $core] } # We haven't built it yet - so we need to build it now. Let k and # nk be the state numbers for the epsilon-kernel and epsilon-non-kernel # states. set k [llength $Items] set nk [expr {$k + 1}] set Kitems $core set NKitems {} set Kedges [dict create] set predicted [dict create] set Kcomplete {} # enumerate all the LRE(0) items in the epsilon-kernel set foreach {lhs rhsIndex pos} $Kitems { set rhs [lindex [dict get $RuleSet $lhs] $rhsIndex] if {$pos == [llength $rhs]} { # reduction lappend Kcomplete $lhs $rhsIndex $pos continue } elseif {![dict exists $RuleSet [set nextSym [lindex $rhs $pos]]]} { # transition on a terminal symbol if {![dict exists $Kedges $nextSym] } { dict set Kedges $nextSym {} } } else { # GOTO on a nonterminal dict set Kedges $nextSym {} if {![dict exists $predicted $nextSym]} { dict set predicted $nextSym 1 set prhsIndex 0 foreach {prhs paction} [dict get $RuleSet $nextSym] { set ppos [SkipOver $prhs] lappend NKitems $nextSym $prhsIndex $ppos incr prhsIndex 2 } } } } # build the state for the epsilon-kernel lappend Completions $Kcomplete lappend Items $Kitems dict set Edges $stateIdx $sym $k dict set Edges $k $Kedges if {[llength $NKitems] == 0} { return $k } # now start with the non-kernel set. We need to build it before # we can figure out whether we've built it already set NKcomplete {} # enumerate all the LRE(0) items in the non-kernel set set NKedges [dict create] set w 0 while {$w < [llength $NKitems] } { foreach {lhs rhsIndex pos} [lrange $NKitems $w [expr {$w+2}]] break incr w 3 set rhs [lindex [dict get $RuleSet $lhs] $rhsIndex] if {$pos == [llength $rhs]} { # reduction lappend NKComplete [list $lhs $rhsIndex $pos] continue } set nextSym [lindex $rhs $pos] if {![dict exists $RuleSet $nextSym]} { # transition on a terminal symbol if {![dict exists $NKedges $nextSym]} { dict set NKedges $nextSym {} } } else { # GOTO on a nonterminal dict set NKedges $nextSym {} if {![dict exists $predicted $nextSym]} { dict set predicted $nextSym 1 set prhsIndex 0 dict for {prhs paction} [dict get $RuleSet $nextSym] { set ppos [SkipOver $prhs] lappend NKitems $nextSym $prhsIndex $ppos incr prhsIndex 2 } } } } # Now we might be able to add NKedges, and NK, or maybe we don't need to. set core [lsort [dict keys $predicted]] if {[dict exists $Cores $core]} { dict set Edges $k {} [dict get $Cores $core] } else { dict set Cores $core $nk dict set Edges $k {} $nk lappend Completions $NKcomplete lappend Items $NKitems dict set Edges $nk $NKedges } # Return the new kernel state's number. return $k } # grammar::aycock::SkipOver -- # # Service procedure that skips over nullable symbols beginning at # a given position on a right-hand side. # # Parameters: # rhs - Right-hand side being analyzed # pos - Starting position within the rhs # # Results: # Returns the index of the first non-nullable symbol after $pos, # which will be the fictitious symbol beyond the end of the right-hand # side if no non-nullable symbols remain. proc ::grammar::aycock::SkipOver {rhs {pos 0}} { set n [llength $rhs] while {$pos < $n} { if {[string range [lindex $rhs $pos] end-2 end] ne "\{\u00d8\}"} { break } incr pos } return $pos } # grammar::aycock::CopmpleteAutomaton -- # # Completes building the parser automaton once the first state # has been constructed. # # Parameters: # parser -- Name of the parser. # # Results: # None. # # Works by a brute-force approach: for each state, for each symbol # that the state can transition on, add goto(state,symbol) to the # state set; iterate until convergence. proc ::grammar::aycock::CompleteAutomaton {parser} { namespace upvar $parser \ RuleSet RuleSet \ Items Items \ Edges Edges set changes 1 while {$changes} { set changes 0 set worklist {} dict for {state d} [dict get $Edges] { dict for {sym v} $d { if {$v eq {}} { if {$state < [llength $Items]} { lappend worklist \ [list $state [dict exists $RuleSet $sym] $sym] set changes 1 } } } } foreach tuple \ [lsort -integer -index 0 \ [lsort -integer -index 1 \ [lsort -dictionary -index 2 $worklist]]] { foreach {state - sym} $tuple break ::grammar::aycock::GoTo $parser $state $sym } } } # grammar::aycock::GoTo -- # # Computes goto(state,symbol) in a parser. # # Parameters: # parser -- Name of the parser # state -- Index of the state # sym -- Symbol whose goto is being computed. # # Results: # Returns the goto entry. # # Side effects: # Constructs a new state if needed. proc ::grammar::aycock::GoTo {parser state sym} { namespace upvar $parser Edges Edges if {![dict exists $Edges $state] || ![dict exists $Edges $state $sym]} { return {} } else { set rv [dict get $Edges $state $sym] if {$rv eq {}} { set rv [MakeState $parser $state $sym] dict set Edges $state $sym $rv } } return $rv } # grammar::aycock::DumpAutomaton -- # # Displays the parsing automaton of an Aycock-Earley parser on a # channel. # # Parameters: # parser - Parser to display # chan - Channel to use # # Results: # None. # # Side effects: # Dumps the grammar (in NNF) and the states of the parsing # automaton. For each state, indicates the LRE(0) items in that # state, the completion list for the state, and the GOTO function # for the state. proc ::grammar::aycock::DumpAutomaton {parser chan} { namespace upvar $parser \ Completions Completions \ Items Items \ Edges Edges for {set ns 0} {$ns < [llength $Completions]} {incr ns} { set completions [lindex $Completions $ns] puts $chan "state $ns:" if {[info exists Items]} { set items [lindex $Items $ns] DumpItemSet $parser $items $chan puts $chan " ------------------------------" } puts $chan " completions:" DumpItemSet $parser $completions $chan puts $chan " ------------------------------" puts $chan " goto:" set worklist {} dict for {sym nexts} [dict get $Edges $ns] { if {$sym eq {}} { set sym \u03b5 } lappend worklist [list $sym $nexts] } foreach pair [lsort -integer -index 1 $worklist] { foreach {sym nexts} $pair break puts $chan [format " %-22s%4d" $sym $nexts] } puts $chan "------------------------------------" } } tcllib-1.15/modules/grammar_aycock/aycock.man0000644000175000017500000001132112077663116020633 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin aycock n 1.0] [copyright "2006 by Kevin B. Kenny Redistribution permitted under the terms of the Open\ Publication License "] [moddesc "Aycock-Horspool-Earley parser generator for Tcl"] [category "Grammars and finite automata"] [require Tcl 8.5] [require grammar::aycock [opt 1.0]] [description] [keywords grammar parser aycock earley horspool] [keywords ambiguous parsing transducer] [para] The [package grammar::aycock] package implements a parser generator for the class of parsers described in John Aycock and R. Nigel Horspool. Practical Earley Parsing. [emph "The Computer Journal,"] [strong 45](6):620-630, 2002. [uri http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.12.4254] [section "PROCEDURES"] The [package grammar::aycock] package exports the single procedure: [list_begin definitions] [call [cmd ::aycock::parser] [arg grammar] [opt [option -verbose]]] Generates a parser for the given [arg grammar], and returns its name. If the optional [option -verbose] flag is given, dumps verbose information relating to the generated parser to the standard output. The returned parser is an object that accepts commands as shown in [sectref {OBJECT COMMAND}] below. [list_end] [section "OBJECT COMMAND"] [list_begin definitions] [call [arg parserName] [method parse] [arg symList] [arg valList] [opt [arg clientData]]] Invokes a parser returned from [cmd ::aycock::parser]. [arg symList] is a list of grammar symbols representing the terminals in an input string, and [arg valList] is a list of their semantic values. The result is the semantic value of the entire string when parsed. [call [arg parserName] [method destroy]] Destroys a parser constructed by [cmd ::aycock::parser]. [call [arg parserName] [method terminals]] Returns a list of terminal symbols that may be presented in the [arg symList] argument to the [method parse] object command. [call [arg parserName] [method nonterminals]] Returns a list of nonterminal symbols that were defined in the parser's grammar. [call [arg parserName] [method save]] Returns a Tcl script that will reconstruct the parser without needing all the mechanism of the parser generator at run time. The reconstructed parser depends on a set of commands in the package [package grammar::aycock::runtime], which is also automatically loaded when the [package grammar::aycock] package is loaded. [list_end] [section "DESCRIPTION"] The [cmd grammar::aycock::parser] command accepts a grammar expressed as a Tcl list. The list must be structured as the concatenation of a set of [term rule]s. Each [term rule] comprises a variable number of elements in the list: [list_begin bullet] [bullet]The name of the nonterminal symbol that the rule reduces. [bullet]The literal string, [const "::="] [bullet]Zero or more names of terminal or nonterminal symbols that comprise the right-hand-side of the rule. [bullet]Finally, a Tcl script to execute when the rule is reduced. Within the given script, a variable called [var _] contains a list of the semantic values of the symbols on the right-hand side. The value returned by the script is expected to be the semantic value of the left-hand side. If the [arg clientData] parameter was passed to the [method parse] method, it is available in a variable called [var clientData]. It is permissible for the script to be the empty string. In this case, the semantic value of the rule will be the same as the semantic value of the first symbol on the right-hand side. If the right-hand side is also empty, the semantic value will be the empty string. [list_end] Parsing is done with an Earley parser, which is not terribly efficient in speed or memory consumption, but which deals effectively with ambiguous grammars. For this reason, the [package grammar::aycock] package is perhaps best adapted to natural-language processing or the parsing of extraordinarily complex languages in which ambiguity can be tolerated. [section EXAMPLE] The following code demonstrates a trivial desk calculator, admitting only [const +], [const *] and parentheses as its operators. It also shows the format in which the lexical analyzer is expected to present terminal symbols to the parser. [example { set p [aycock::parser { start ::= E {} E ::= E + T {expr {[lindex $_ 0] + [lindex $_ 2]}} E ::= T {} T ::= T * F {expr {[lindex $_ 0] * [lindex $_ 2]}} T ::= F {} F ::= NUMBER {} F ::= ( E ) {lindex $_ 1} }] puts [$p parse {( NUMBER + NUMBER ) * ( NUMBER + NUMBER ) } \ {{} 2 {} 3 {} {} {} 7 {} 1 {}}] $p destroy }] The example, when run, prints [const 40]. [section KEYWORDS] Aycock, Earley, Horspool, parser, compiler [manpage_end] tcllib-1.15/modules/grammar_aycock/aycock-debug.tcl0000644000175000017500000001062712077663116021736 0ustar sergeisergei#---------------------------------------------------------------------- # # aycock-debug.tcl -- # # Procedures needed to debug an Aycock-Horspool-Earley parser. # # Copyright (c) 2006 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: aycock-debug.tcl,v 1.2 2011/01/13 02:47:47 andreas_kupries Exp $ # #---------------------------------------------------------------------- package provide grammar::aycock::debug 1.0 package require Tcl 8.4 # Bring in the runtime library package require grammar::aycock::runtime 1.0 # grammar::aycock::Terminals -- # # List the terminal symbols used in a parser's grammar # # Usage: # $parser terminals # # Results: # Returns a list of the terminal symbols proc ::grammar::aycock::Terminals {parser} { namespace upvar $parser RuleSet RuleSet set t [dict create] dict for {lhs rules} $RuleSet { dict for {rhs action} $rules { foreach sym $rhs { if {$sym ne "\u22a2"} { if {![dict exists $RuleSet $sym]} { dict set t $sym {} } } } } } return [lsort -dictionary [dict keys $t]] } # grammar::aycock::Nonterminals -- # # List the nonterminal symbols used in a parser's grammar # # Usage: # $parser nonterminals # # Results: # Returns a list of the nonterminal symbols proc ::grammar::aycock::Nonterminals {parser} { namespace upvar $parser RuleSet RuleSet set t [dict create] dict for {lhs rules} $RuleSet { dict for {rhs action} $rules { foreach sym $rhs { if {$sym ne "\u22a2"} { if {[dict exists $RuleSet $sym]} { dict set t $sym {} } } } } } return [lsort -dictionary [dict keys $t]] } # grammar::aycock::NeverReduced -- # # Checks a parser's grammar for rules that cannot be reduced. # # Parameters: # parser -- Name of the parser # # Results: # Return a list of the left-hand sides of rules never reduced. proc ::grammar::aycock::NeverReduced {parser} { namespace upvar $parser RuleSet RuleSet set t [dict create] foreach {lhs rules} $RuleSet { dict set t $lhs {} } foreach s [Nonterminals $parser] { dict unset t $s } dict unset t {} return [lsort [dict keys $t]] } # grammar::aycock::Save -- # # Produces a script that will load an Aycock-Earley parser without # needing to do all the state analysis. # # Usage: # $parser save # # Results: # Returns a script that when evaluated will reload the parser. proc ::grammar::aycock::Save {parser} { namespace upvar $parser \ RuleSet RuleSet \ Completions Completions \ Edges Edges set actions [dict create] set rex1 {} dict for {lhs rules} $RuleSet { set rex2 {} foreach {rhs action} $rules { dict set actions $action {} append rex2 \n \t [list $rhs $action] } append rex2 \n " " append rex1 \n " " [list $lhs $rex2] } append rex1 \n set i 0 set sex1 {} foreach {completions} $Completions { set nc 0 append sex1 \n " " [list $completions [dict get $Edges $i]] incr i } append sex1 \n set retval [list [namespace current]::Restore $rex1 $sex1] foreach action [lsort -dictionary [dict keys $actions]] { lappend retval $action \ [string trimright [info body ${parser}::$action]]\n } return $retval } # grammar::aycock::DumpItemSet -- # # Displays a representation of an LRE(0) item set on a channel # # Parameters: # parser - Name of the parser # s - Item set to display # chan - Channel to use # # Results: # None # # Side effects: # Writes the LRE(0) item set on the given channel proc ::grammar::aycock::DumpItemSet {parser s {chan stdout}} { foreach {lhs prodIndex pos} $s { DumpItem $parser $lhs $prodIndex $pos $chan } return } # grammar::aycock::DumpItem -- # # Displays a representation of an LRE(0) item on a channel # # Parameters: # parser - Name of the parser # lhs - Left-hand side of the reduction # prodIndex - Ordinal position of the right-hand side among # all right-hand sides for that LHS # pos - Position of the dot on the right-hand side # chan - Channel to use # # Results: # None # # Side effects: # Writes the LRE(0) item on the given channel proc ::grammar::aycock::DumpItem {parser lhs prodIndex pos {chan stdout}} { namespace upvar $parser RuleSet RuleSet set rhs [lindex [dict get $RuleSet $lhs] $prodIndex] puts $chan " $lhs ::= [linsert $rhs $pos \u00b7]" return } tcllib-1.15/modules/grammar_aycock/aycock.test0000644000175000017500000001175512077663116021052 0ustar sergeisergei# -*- tcl -*- # aycock.test -- # # Tests for the Aycock-Earley-Horspool parser generator # # Tests for the Aycock-Earley-Horspool parser generator are quite rudimentary # at this point; they walk through only basic functionality and surely do not # explore corner cases. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.0 support { useLocal aycock-runtime.tcl grammar::aycock::runtime grammar::aycock useLocalKeep aycock-debug.tcl grammar::aycock::debug grammar::aycock } testing { useLocalKeep aycock-build.tcl grammar::aycock grammar::aycock } # ------------------------------------------------------------------------- proc parser1 {} { grammar::aycock::parser { S ::= if E then S else S { set _ } S ::= if E then S { set _ } S ::= X {} } } test aycock-1.1 {basic parser for an ambiguous grammar} { -body { set parser [parser1] set result [$parser parse \ {if E then if E then X else X } \ {if E1 then if E2 then S1 else S2}] $parser destroy unset parser set result } -cleanup {unset result} -result {if E1 then {if E2 then S1 else S2}} } test aycock-1.2 {basic parser, another case} { -setup { set parser [parser1] } -body { $parser parse \ {if E then if E then X else X else if E then X else X } \ {if E1 then if E2 then S1 else S2 else if E3 then S3 else S4} } -cleanup {$parser destroy; unset parser} -result {if E1 then {if E2 then S1 else S2} else {if E3 then S3 else S4}} } test aycock-2.1 {save and restore a parser} { -body { set parser1 [parser1] set saved [$parser1 save] $parser1 destroy set parser2 [eval $saved] $parser2 parse \ {if E then if E then X else X } \ {if E1 then if E2 then S1 else S2} } -cleanup { catch {$parser2 destroy} catch {unset parser2} catch {unset saved} catch {$parser1 destroy} catch {unset parser1} } -result {if E1 then {if E2 then S1 else S2}} } rename parser1 {} test aycock-3.1 {dangling else grammar, another form} { -body { set parser [grammar::aycock::parser { S ::= if E then S elsepart { set _ } elsepart ::= else S { set _ } elsepart ::= { list (empty) } S ::= X {} }] list [$parser parse \ {if E then if E then X else X } \ {if E1 then if E2 then S1 else S2}] \ [$parser parse \ {if E then if E then X else X else if E then X else X } \ {if E1 then if E2 then S1 else S2 else if E3 then S3 else S4}] } -cleanup { catch {$parser destroy} catch {unset parser} } -result {{if E1 then {if E2 then S1 (empty)} {else S2}} {if E1 then {if E2 then S1 {else S2}} {else {if E3 then S3 {else S4}}}}} } test aycock-3.2 {unary and binary operations, wrong precedence} { -body { set parser [grammar::aycock::parser { E ::= E - E {set _} E ::= E + E {set _} E ::= UMINUS E {set _} E ::= X {set _} UMINUS ::= - {list UMINUS} }] list \ [$parser parse \ {- X - X} \ {- a - b}] \ [$parser parse \ {X - X - X} \ {a - b - c}] \ [$parser parse \ {X + X - X} \ {a + b - c}] } -cleanup { catch {$parser destroy} catch {unset parser} } -result {{UMINUS {a - b}} {{a - b} - c} {{a + b} - c}} } test aycock-4.1 {parses with lots of ambiguity} { -body { set parser [grammar::aycock::parser { A ::= b B {set _} B ::= P P Q {linsert $_ 0 rule1} B ::= P Q Q {linsert $_ 0 rule2} P ::= p {} P ::= {list empty P} Q ::= q {} Q ::= {list empty Q} }] list \ [$parser parse {b} {b}] \ [$parser parse {b p q} {b p q}] \ [$parser parse {b q q} {b q q}] } -cleanup { catch {$parser destroy} catch {unset parser} } -result {{b {rule1 {empty P} {empty P} {empty Q}}} {b {rule1 {empty P} p q}} {b {rule2 {empty P} q q}}} } test aycock-5.1 {desk calculator skeleton} { -body { set p [grammar::aycock::parser { start ::= E {} E ::= E + T {expr {[lindex $_ 0] + [lindex $_ 2]}} E ::= T {} T ::= T * F {expr {[lindex $_ 0] * [lindex $_ 2]}} T ::= F {} F ::= NUMBER {} F ::= ( E ) {lindex $_ 1} }] list \ [$p parse \ {NUMBER * NUMBER + NUMBER} \ {2 * 3 + 4 }] \ [$p parse \ {NUMBER * ( NUMBER + NUMBER )} \ {2 * ( 3 + 4 )}] } -cleanup { catch {$p destroy} catch {unset p} } -result {10 14} } # ------------------------------------------------------------------------- tcltest::cleanupTests return tcllib-1.15/modules/grammar_aycock/aycock-runtime.tcl0000644000175000017500000003067612077663116022341 0ustar sergeisergei#---------------------------------------------------------------------- # # aycock-runtime.tcl -- # # Procedures needed to execute an Aycock-Horspool-Earley parser. # # Copyright (c) 2006 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: aycock-runtime.tcl,v 1.2 2011/01/13 02:47:47 andreas_kupries Exp $ # #---------------------------------------------------------------------- package provide grammar::aycock::runtime 1.0 package require Tcl 8.5 # Define the directory containing this package's scripts namespace eval grammar {} namespace eval grammar::aycock { variable parserCount 0 } # grammar::aycock::Restore -- # # Restores a parser from saved state. # # Parameters; # rules - Saved rule set # automaton - Saved automaton # args - Saved action procedures # # Results: # Returns the constructed parser's name # # Side effects: # Reconstructs the parser proc ::grammar::aycock::Restore {rules automaton args} { set name [MakeParser] variable ${name}::RuleSet variable ${name}::Completions variable ${name}::Edges set RuleSet $rules set Edges [dict create] set Completions {} set i 0 foreach {completions edges} $automaton { lappend Completions $completions dict set Edges $i $edges incr i } foreach {actionName actionBody} $args { namespace eval ${name} \ [list proc $actionName {_ clientData} $actionBody] } return ${name} } # grammar::aycock::MakeParser -- # # Constructs the ensemble that will contain an Aycock parser. # # Results: # Returns the name of the parser, which is an ensemble within # the "aycock" namespace. # # The following commands are members of the ensemble: # parse -- Parses a sequence of symbols and returns its lexical # value. # destroy -- Destroys the parser. # terminals -- Lists the terminal symbols accepted by the parser # nonterminals -- Lists the nonterminal symbols reduced by the parser # save -- Returns a command to recreate the parser without needing # to analyze the rule set. proc ::grammar::aycock::MakeParser {} { variable parserCount set name [namespace current]::parser[incr parserCount] namespace eval $name { namespace export parse destroy namespace export terminals nonterminals save } proc ${name}::parse {symList vallist {clientData {}}} \ [string map [list \ PROC [namespace current]::Parse \ PARSER $name] { PROC PARSER $symList $vallist $clientData }] proc ${name}::terminals {} \ [list [namespace current]::Terminals $name] proc ${name}::nonterminals {} \ [list [namespace current]::Nonterminals $name] proc ${name}::save {} \ [list [namespace current]::Save $name] proc ${name}::destroy {} \ [list namespace delete $name] namespace eval $name { namespace ensemble create } return $name } # grammar::aycock::MakeSet -- # # Run one step of an Earley parse. # # Parameters: # parser -- Name of the parser # setsVar -- Sets of parser states already constructed # sym -- Input symbol # # Results: # Returns the sets of parser states updated with the transition on the # given input # # Each parser state is an ordered pair (automaton state, parent) # where parent is the position in the input string where the substring # matching the given state begins. A state set is a dictionary whose # keys are parser states and whose values are "links" - a link consists of # the automaton state, parent, and state set of the predecessor, # the automaton state, parent and state set of the cause, and # the LRE(0) parser state of the symbol being reduced - see Aycock's # paper for the details on how these are interpreted. proc ::grammar::aycock::MakeSet {parser setsVar sym} { upvar 1 $setsVar sets namespace upvar $parser \ Completions Completions \ Edges Edges # Find the state index and set up "current" and "next" state sets. set ip1 [llength $sets] set i [expr {$ip1 - 1}] set curSet [lindex $sets end] set newSet {} # Work through the "current" set to determine "next state" transitions. set j 0 set worklist $curSet while {$j < [llength $worklist]} { set item [lindex $worklist $j] incr j 2 foreach {state parent} $item break # Advance using the 'goto' on the current input symbol if {$sym ne {} && [dict exists $Edges $state $sym]} { set k [dict get $Edges $state $sym] set createdItem [list $k $parent] set links [list $state $parent $i] dict set newSet $createdItem $links {} # Also add the epsilon-transition from that state if {[dict exists $Edges $k {}]} { set nk [dict get $Edges $k {}] set createdItem [list $nk [expr {$i+1}]] dict set newSet $createdItem {} {} } } if {$parent != $i} { # Reduce any completions in the current state, adding # them to the worklist because their 'goto' items may # also be shifted. foreach {lhs rhs pos} [lindex $Completions $state] { if {$lhs eq {}} continue foreach pitem [lindex $sets $parent] { foreach {pstate pparent} $pitem break if {[dict exists $Edges $pstate $lhs]} { # goto on the newly-reduced nonterminal set k [dict get $Edges $pstate $lhs] set createdItem [list $k $pparent] set links [list $pstate $pparent $parent \ $state $parent $i \ $lhs $rhs $pos] if {![dict exists $curSet $createdItem]} { lappend worklist $createdItem $links } dict set curSet $createdItem $links {} if {[dict exists $Edges $k {}]} { # epsilon-transition from the nonterminal's goto set nk [dict get $Edges $k {}] set createdItem [list $nk $i] if {![dict exists $curSet $createdItem]} { lappend worklist $createdItem {} } dict set curSet $createdItem {} {} } } } } } } set sets [lreplace $sets[set sets {}] end end $curSet $newSet] } # grammar::aycock::Parse -- # # Runs an Aycock-Earley parser # # Usage: # $parser parse symlist vallist # # Parameters: # symlist - List of token names created by scanning an input # vallist - List of semantic values corresponding to the # tokens in $symlist # clientData - Client data to be passed to semantic action procedures # # Results: # Returns whatever the semantic action in the top-level reduction # of the parse returns. proc ::grammar::aycock::Parse {parser symlist vallist {clientData {}}} { namespace upvar $parser \ RuleSet RuleSet \ Edges Edges set sets [list [dict create [list 1 0] {} [list 2 0] {}]] set i 0 foreach sym $symlist { MakeSet $parser sets $sym if {[llength [lindex $sets end]] == 0} { return -code error "syntax error before symbol $i ($sym: [lindex $vallist $i])" } incr i } MakeSet $parser sets {} set startSym [lindex [dict get $RuleSet {}] 0 1] #set finalState [dict get $Edges 2 $startSym] set finalState [dict get $Edges 1 $startSym] # TODO - check that the final state *is* final... it has to contain an # acceptor somewhere. return [Reconstruct $parser {} $finalState 0 $vallist $sets \ [expr {[llength $sets] - 2}] $clientData] } # grammar::aycock::Reconstruct -- # # Reconstructs the parse that leads to reducing a given nonterminal # symbol, and determines the nonterminal's semantic value. # # Parameters: # parser -- Aycock parser # nt - Name of the nonterminal being reduced # state - Parser state that contains the reduction # parent - Position in the input list of the start of the reduction # vallist - List of semantic values corresponding the the symbols # on the right hand side of the reduction # sets - List of sets generated by grammar::aycock::MakeSet # k - Position in the input list at the start of the reduction # clientData - Client data for semantic actions # # Results: # Returns the semantic value of the left-hand side of the reduction proc ::grammar::aycock::Reconstruct {parser nt state parent vallist sets k clientData} { namespace upvar $parser \ RuleSet RuleSet \ Completions Completions \ Edges Edges set choices {} # Here it's possible that Completions contains completions for the # wrong nonterminal? set complete [lindex $Completions $state] if {[llength $complete] != 3} { set complete {} foreach {lhs rhs pos} [lindex $Completions $state] { if {$lhs eq $nt} { lappend complete $lhs $rhs $pos } } } set compIdx [ChooseReduction $parser $complete] foreach {lhs rhsIndex pos} \ [lrange $complete [expr {3*$compIdx}] [expr {3*$compIdx+2}]] break foreach {rhs action} [lrange [dict get $RuleSet $lhs] $rhsIndex [expr {$rhsIndex+1}]] break set cmd [list ${parser}::$action] set args {} foreach sym $rhs { lappend args {} } for {set i [expr {[llength $rhs]-1}]} {$i >= 0} {incr i -1} { set sym [lindex $rhs $i] if {![dict exists $RuleSet $sym]} { # terminal symbol if {$sym != "\u22a2"} { lset args $i [lindex $vallist [expr {$k-1}]] set predecessors {} dict for {key v} \ [dict get [lindex $sets $k] [list $state $parent]] { foreach {pstate pparent pk cstate cparent ck lhs rhsIndex pos} $key break # should be only one transition on a terminal break } set state $pstate set parent $pparent set k $pk } } elseif {[string range $sym end-2 end] == "\{\u00d8\}"} { lset args $i [DeriveEpsilon $parser $sym $clientData] } elseif {[dict exists [lindex $sets $k] [list $state $parent]]} { set causes {} set links [dict get [lindex $sets $k] [list $state $parent]] set keys {} set reductions {} dict for {key v} $links { foreach {pstate pparent pk cstate cparent ck \ lhs rhsIndex pos} $key break lappend reductions $lhs $rhsIndex $pos lappend keys $key } set keyIdx [ChooseReduction $parser $reductions] set key [lindex $keys $keyIdx] foreach {pstate pparent pk cstate cparent ck \ lhs rhsIndex pos} $key break lset args $i \ [Reconstruct $parser $sym $cstate $cparent $vallist \ $sets $ck $clientData] set state $pstate set parent $pparent set k $pk } else { return -code error "syntax error: incomplete parse" } } set v [eval [list $cmd $args $clientData]] return $v } # grammar::aycock::ChooseReduction -- # # Resolves an ambiguity in an Aycock-Earley parse # # Parameters: # parser - Parser structure # lritems - List of LR items that could be reduced. # # Results: # Returns the ordinal number of the reduction to choose # # Always resolves in favour of the shortest right-hand side. This choice # is equivalent to choosing "resolve shift/reduce conflicts in favour # of shifting" in an LR parser, and is adequate to handling situations # like "dangling ELSE." It is not adequate for handling things like a # YACC-style ambiguous expression grammar with precedence and associativity; # that sort of processing would need additional investigation. proc ::grammar::aycock::ChooseReduction {parser lritems} { # if {[llength $lritems] != 3} { # puts "Need to choose which item to reduce:" # DumpItemSet $parser $lritems # } # choose the shortest reduction - this is equivalent to # "resolve in favour of shift" set ind -1 set shortest 99999 set i 0 foreach {lhs rhsIndex pos} $lritems { if {$pos < $shortest} { set shortest $pos set ind $i } incr i } return $ind } # grammar::aycock::DeriveEpsilon -- # # Performs a set of semantic actions needed to derive the # empty string within a set of reductions in an Aycock-Earley parser. # # Parameters: # parser -- Parser data structure # sym -- Non-terminal symbol that reduces to the empty string. # clientData - Client data for semantic actions # # Results: # Returns the semantic value of the given symbol proc ::grammar::aycock::DeriveEpsilon {parser sym clientData} { # need to find the rule that derives the null string, and # expand it out. namespace upvar $parser RuleSet RuleSet set rules [dict get $RuleSet $sym] set idx 0 if { [llength $rules] != 2 } { set items {} set i 0 foreach {rhs action} $rules { lappend items $sym $i [llength $rhs] incr i 2 } set idx [expr {2 * [ChooseReduction $parser $items]}] } set rhs [lindex $rules $idx] set action [lindex $rules [expr {$idx + 1}]] set cmd [list ${parser}::$action] set args {} foreach sym $rhs { lappend args {} } for {set i [expr {[llength $rhs] - 1}]} {$i >= 0} {incr i -1} { lset args $i [DeriveEpsilon $parser [lindex $rhs $i] $clientData] } set r [eval [list $cmd $args $clientData]] return $r } tcllib-1.15/modules/doctools2base/0000755000175000017500000000000012104363635016445 5ustar sergeisergeitcllib-1.15/modules/doctools2base/nroff_manmacros.man0000644000175000017500000000211012077663116022314 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin doctools::nroff::man_macros n 0.1] [copyright {2009 Andreas Kupries }] [moddesc {Documentation tools}] [titledesc {Default CSS style for NROFF export plugins}] [category {Documentation tools}] [require Tcl 8.4] [require doctools::nroff::man_macros [opt 0.1]] [keywords doctools export plugin nroff man_macros macros] [description] This package provides a single command providing access to the definition of the nroff [emph man] macro set to use for NROFF markup generated by the various NROFF export plugins. [para] This is an internal package of doctools, for use by [term export] plugins, i.e. the packages converting doctools related documented into other formats, most notably [term nroff]. [section API] [list_begin definitions] [call [cmd ::doctools::nroff::man_macros::contents]] This command returns the text of the default CSS style to use for NROFF generated by the various NROFF export plugins. [list_end] [vset CATEGORY doctools] [include include/feedback.inc] [manpage_end] tcllib-1.15/modules/doctools2base/msgcat.tcl0000644000175000017500000000315712077663116020443 0ustar sergeisergei# -*- tcl -*- # Copyright (c) 2009 Andreas Kupries # L10N, I18N # Support package. Handling of message catalogs within the various # doctools document processing packages. Contrary to the regular # msgcat package here message catalogs are equated with packages. This # makes their use easier, as the user does not have to know the # location of the message catalogs. Locating a desired catalog is # handled through Tcl's regular package management. # To this end this package provides a command analogous to # 'msgcat::load', just replacing direct file access with package # loading. This is 'doctools::msgcat::init'. # # ## ### ##### ######## ############# ##################### ## Requirements package require Tcl 8.4 ; # Required Core package require msgcat ; # Fondation catalog database namespace eval ::doctools::msgcat {} # # ## ### ##### ######## ############# ##################### ## Overide catalog unknown handler to report missing strings ## as fatal problem. DEBUG only. if 0 { proc ::msgcat::mcunknown {locale code} { return "unknown error code \"$code\" (for locale $locale)" } } # # ## ### ##### ######## ############# ##################### ## Public API proc ::doctools::msgcat::init {prefix} { set matches 0 foreach p [msgcat::mcpreferences] { set pkg doctools::msgcat::${prefix}::${p} if {![catch { package require $pkg }]} { incr matches } } return $matches } # # ## ### ##### ######## ############# ##################### ## Ready namespace eval ::doctools::msgcat { namespace export init } package provide doctools::msgcat 0.1 return tcllib-1.15/modules/doctools2base/ChangeLog0000644000175000017500000000251712104363437020224 0ustar sergeisergei2013-02-01 Andreas Kupries * * Released and tagged Tcllib 1.15 ======================== * 2011-12-13 Andreas Kupries * * Released and tagged Tcllib 1.14 ======================== * 2011-01-24 Andreas Kupries * * Released and tagged Tcllib 1.13 ======================== * 2010-06-08 Andreas Kupries * msgcat.man: [Bug 3012669]: Renamed this manpage, conflicted with * tcllib_msgcat.man: the manpage for package msgcat in the core. 2009-12-07 Andreas Kupries * * Released and tagged Tcllib 1.12 ======================== * 2009-04-27 Andreas Kupries * paths.tcl: Fixed version mismatch. * nroff_manmacros.tcl: Renamed package (man.macros -> man_macros) * nroff_manmacros.man: to match the set of allowed characters in * tests/common: Tcl Module names. This fixes [Bug 2782256]. * pkgIndex.tcl: 2009-04-16 Andreas Kupries * html.tcl: Fix version mismatch. * text.tcl: Fix version mismatch. * tests/common: Fix handling of directories. 2009-03-31 Andreas Kupries * Doctools version 2, base packages. tcllib-1.15/modules/doctools2base/paths.tcl0000644000175000017500000000311412077663116020275 0ustar sergeisergei# docidx.tcl -- # # Generic path list management, for use by import management. # # Copyright (c) 2009 Andreas Kupries # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: paths.tcl,v 1.2 2009/04/29 02:09:46 andreas_kupries Exp $ # Each object manages a list of paths. # ### ### ### ######### ######### ######### ## Requisites package require Tcl 8.4 package require snit # ### ### ### ######### ######### ######### ## API snit::type ::doctools::paths { # ### ### ### ######### ######### ######### ## Options :: None # ### ### ### ######### ######### ######### ## Creation, destruction # Default constructor. # Default destructor. # ### ### ### ######### ######### ######### ## Methods :: Querying and manipulating the list of paths. method paths {} { return $mypaths } method add {path} { set pos [lsearch $mypaths $path] if {$pos >= 0 } return lappend mypaths $path return } method remove {path} { set pos [lsearch $mypaths $path] if {$pos < 0} return set mypaths [lreplace $mypaths $pos $pos] return } method clear {} { set mypaths {} return } # ### ### ### ######### ######### ######### ## Internal methods :: None # ### ### ### ######### ######### ######### ## State :: List of paths. variable mypaths {} ## # ### ### ### ######### ######### ######### } # ### ### ### ######### ######### ######### ## Ready package provide doctools::paths 0.1 return tcllib-1.15/modules/doctools2base/pkgIndex.tcl0000644000175000017500000000233212077663116020730 0ustar sergeisergeiif {![package vsatisfies [package provide Tcl] 8.4]} {return} # Packages for the doctools {idx,toc,doc} v2 implementation # (still v1.1 doc{idx,toc} languages). # Supporting packages # - Handling configuration variables, and include paths. # - Handling text generation, the nroff man.macros definitions, # HTML/XML generation, and the default CSS style # - Handling of message catalogs as packages. # - Recursive descent parser for Tcl strings (as expected by 'subst -novariables'). package ifneeded doctools::config 0.1 [list source [file join $dir config.tcl]] package ifneeded doctools::paths 0.1 [list source [file join $dir paths.tcl]] package ifneeded doctools::text 0.1 [list source [file join $dir text.tcl]] package ifneeded doctools::nroff::man_macros 0.1 [list source [file join $dir nroff_manmacros.tcl]] package ifneeded doctools::html 0.1 [list source [file join $dir html.tcl]] package ifneeded doctools::html::cssdefaults 0.1 [list source [file join $dir html_cssdefaults.tcl]] package ifneeded doctools::msgcat 0.1 [list source [file join $dir msgcat.tcl]] package ifneeded doctools::tcl::parse 0.1 [list source [file join $dir tcl_parse.tcl]] tcllib-1.15/modules/doctools2base/config.tcl0000644000175000017500000000370112077663116020425 0ustar sergeisergei# docidx.tcl -- # # Generic configuration management, for use by import and export # managers. # # Copyright (c) 2009 Andreas Kupries # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: config.tcl,v 1.2 2011/11/17 08:00:45 andreas_kupries Exp $ # Each object manages a set of configuration variables. # ### ### ### ######### ######### ######### ## Requisites package require Tcl 8.4 package require snit # ### ### ### ######### ######### ######### ## API snit::type ::doctools::config { # ### ### ### ######### ######### ######### ## Options :: None # ### ### ### ######### ######### ######### ## Creating, destruction # Default constructor. # Default destructor. # ### ### ### ######### ######### ######### ## Public methods. Reading and writing the configuration. method names {} { return [array names myconfiguration] } method get {} { return [array get myconfiguration] } method set {name {value {}}} { # 7 instead of 3 in the condition below, because of the 4 # implicit arguments snit is providing to each method. if {[llength [info level 0]] == 7} { set myconfiguration($name) $value } elseif {![info exists myconfiguration($name)]} { return -code error "can't read \"$name\": no such variable" } return $myconfiguration($name) } method unset {args} { if {![llength $args]} { lappend args * } foreach pattern $args { array unset myconfiguration $pattern } return } # ### ### ### ######### ######### ######### ## Internal methods :: None. # ### ### ### ######### ######### ######### ## State :: Configuration data, Tcl array variable myconfiguration -array {} ## # ### ### ### ######### ######### ######### } # ### ### ### ######### ######### ######### ## Ready package provide doctools::config 0.1 return tcllib-1.15/modules/doctools2base/tcl_parse.test0000644000175000017500000000557212077663116021341 0ustar sergeisergei# -*- tcl -*- # docparsetcl.test: tests for the doctools::parse::tcl package. # # Copyright (c) 2009 by Andreas Kupries # All rights reserved. # # RCS: @(#) $Id: tcl_parse.test,v 1.1 2009/04/01 04:27:47 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.4 testsNeedTcltest 2.0 support { useAccel [useTcllibC] struct/tree.tcl struct::tree TestAccelInit struct::tree useAccel [useTcllibC] struct/stack.tcl struct::stack TestAccelInit struct::stack useAccel [useTcllibC] struct/sets.tcl struct::set TestAccelInit struct::set use struct/list.tcl struct::list use snit/snit.tcl snit use fileutil/fileutil.tcl fileutil use log/logger.tcl logger use treeql/treeql.tcl treeql } testing { useLocal tcl_parse.tcl doctools::tcl::parse } # ------------------------------------------------------------------------- test doctools-tcl-parse-1.0 {parse file, wrong#args} -body { doctools::tcl::parse file } -returnCodes error -result {wrong # args: should be "::doctools::tcl::parse::Snit_typemethodfile type t path ?root?"} test doctools-tcl-parse-1.1 {parse file, wrong#args} -body { doctools::tcl::parse file T } -returnCodes error -result {wrong # args: should be "::doctools::tcl::parse::Snit_typemethodfile type t path ?root?"} test doctools-tcl-parse-1.2 {parse file, wrong#args} -body { doctools::tcl::parse file T P R XXX } -returnCodes error -result {wrong # args: should be "::doctools::tcl::parse::Snit_typemethodfile type t path ?root?"} test doctools-tcl-parse-2.0 {parse text, wrong#args} -body { doctools::tcl::parse text } -returnCodes error -result {wrong # args: should be "::doctools::tcl::parse::Snit_typemethodtext type t text ?root?"} test doctools-tcl-parse-2.1 {parse text, wrong#args} -body { doctools::tcl::parse text T } -returnCodes error -result {wrong # args: should be "::doctools::tcl::parse::Snit_typemethodtext type t text ?root?"} test doctools-tcl-parse-2.2 {parse text, wrong#args} -body { doctools::tcl::parse text T P R XXX } -returnCodes error -result {wrong # args: should be "::doctools::tcl::parse::Snit_typemethodtext type t text ?root?"} # tcl_parse tests, numbering starts at 10 # ------------------------------------------------------------------------- TestAccelDo struct::stack stkimpl { TestAccelDo struct::set setimpl { TestAccelDo struct::tree impl { source [localPath tests/tcl_parse] } } } #---------------------------------------------------------------------- TestAccelExit struct::tree TestAccelExit struct::set TestAccelExit struct::stack testsuiteCleanup return tcllib-1.15/modules/doctools2base/html.tcl0000644000175000017500000001271012077663116020124 0ustar sergeisergei# -*- tcl -*- # Copyright (c) 2009 Andreas Kupries # Support package. Basic html generation commands. # # ## ### ##### ######## ############# ##################### ## Requirements package require Tcl 8.4 ; # Required Core package require doctools::text ; # Basic generator state management. namespace eval ::doctools::html {} doctools::text::import ::doctools::html # # ## ### ##### ######## ############# ##################### proc ::doctools::html::begin {} { text::begin Begin return } proc ::doctools::html::save {} { variable state set current [array get state] text::save Begin set state(stack) $current return } proc ::doctools::html::restore {} { variable state set html [text::restore] array set state $state(stack) return $html } proc ::doctools::html::collect {script} { save uplevel 1 $script return [restore] } # # ## ### ##### ######## ############# ##################### proc ::doctools::html::tag1 {name args} { text::+ <$name if {[llength $args]} { foreach {a v} $args { text::+ " $a=\"$v\"" } } text::+ > return } proc ::doctools::html::tag {name args} { tagD $name $args return } proc ::doctools::html::tagD {name dict} { variable state lappend state(tstack) $name text::+ <$name if {[llength $dict]} { foreach {a v} $dict { text::+ " $a=\"$v\"" } } text::+ > return } proc ::doctools::html::/tag {} { variable state set tag [lindex $state(tstack) end] set state(tstack) [lreplace $state(tstack) end end] text::+ return } proc ::doctools::html::tag/ {name args} { variable state lappend state(tstack) $tag text::+ <$tag if {[llength $args]} { foreach {a v} $args { text::+ " $a=\"$v\"" } text::+ { } } text::+ /> return } proc ::doctools::html::tag* {name args} { set script [lindex $args end] set args [lreplace $args end end] tagD $name $args uplevel 1 $script /tag return } proc ::doctools::html::tag= {name args} { set text [lindex $args end] set args [lreplace $args end end] eval [linsert $args 0 tag $name] + $text /tag return } # # ## ### ##### ######## ############# ##################### proc ::doctools::html::+ {text} { text::+ [Quote $text] return } proc ::doctools::html::comment {comment} { text::+ "" return } proc ::doctools::html::++ {html} { text::+ $html return } # # ## ### ##### ######## ############# ##################### proc ::doctools::html::import {{namespace {}}} { uplevel 1 [list namespace eval ${namespace}::html { namespace import ::doctools::html::* }] return } proc ::doctools::html::importhere {{namespace ::}} { uplevel 1 [list namespace eval ${namespace} { namespace import ::doctools::html::* }] return } # # ## ### ##### ######## ############# ##################### proc ::doctools::html::Begin {} { variable state array unset state * array set state { tags {} stack {} } return } proc ::doctools::html::Quote {text} { variable textMap return [string map $textMap $text] } # # ## ### ##### ######## ############# ##################### namespace eval ::doctools::html { variable state array set state {} # Replaces HTML markup characters in $text with the appropriate # entity references. variable textMap { & & < < > > \xa0   \xb0 ° \xc0 À \xd0 Ð \xe0 à \xf0 ð \xa1 ¡ \xb1 ± \xc1 Á \xd1 Ñ \xe1 á \xf1 ñ \xa2 ¢ \xb2 ² \xc2 Â \xd2 Ò \xe2 â \xf2 ò \xa3 £ \xb3 ³ \xc3 Ã \xd3 Ó \xe3 ã \xf3 ó \xa4 ¤ \xb4 ´ \xc4 Ä \xd4 Ô \xe4 ä \xf4 ô \xa5 ¥ \xb5 µ \xc5 Å \xd5 Õ \xe5 å \xf5 õ \xa6 ¦ \xb6 ¶ \xc6 Æ \xd6 Ö \xe6 æ \xf6 ö \xa7 § \xb7 · \xc7 Ç \xd7 × \xe7 ç \xf7 ÷ \xa8 ¨ \xb8 ¸ \xc8 È \xd8 Ø \xe8 è \xf8 ø \xa9 © \xb9 ¹ \xc9 É \xd9 Ù \xe9 é \xf9 ù \xaa ª \xba º \xca Ê \xda Ú \xea ê \xfa ú \xab « \xbb » \xcb Ë \xdb Û \xeb ë \xfb û \xac ¬ \xbc ¼ \xcc Ì \xdc Ü \xec ì \xfc ü \xad ­ \xbd ½ \xcd Í \xdd Ý \xed í \xfd ý \xae ® \xbe ¾ \xce Î \xde Þ \xee î \xfe þ \xaf &hibar; \xbf ¿ \xcf Ï \xdf ß \xef ï \xff ÿ {"} " } ; # " make the emacs highlighting code happy. # Text commands which are html commands, unchanged namespace import \ ::doctools::text::done \ ::doctools::text::+++ \ ::doctools::text::newline \ ::doctools::text::prefix \ ::doctools::text::indent \ ::doctools::text::dedent \ ::doctools::text::indented \ ::doctools::text::indenting \ ::doctools::text::newlines namespace export begin done save restore collect + +++ \ prefix indent dedent indented indenting newline newlines \ tag /tag tag/ tag* tag1 tag= comment ++ } # # ## ### ##### ######## ############# ##################### package provide doctools::html 0.1 return tcllib-1.15/modules/doctools2base/msgcat.test0000644000175000017500000000312612077663116020634 0ustar sergeisergei# -*- tcl -*- # doctools::msgcat.test: tests for the doctools::msgcat package. # # Copyright (c) 2009 by Andreas Kupries # All rights reserved. # # RCS: @(#) $Id: msgcat.test,v 1.1 2009/04/01 04:27:47 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.4 testsNeedTcltest 2 support { # NOTE: Better use a base local file and test package ? use doctools2idx/msgcat_c.tcl doctools::msgcat::idx::c ; # See 'doctools-msgcat-2.0'. } testing { useLocal msgcat.tcl doctools::msgcat } # ------------------------------------------------------------------------- array_unset env LANG* array_unset env LC_* set env(LANG) C ; # Usually default if nothing is set, OS X requires this. # ------------------------------------------------------------------------- # search paths ............................................................. test doctools-msgcat-1.0 {init, wrong#args, not enough} -body { doctools::msgcat::init } -returnCodes error -result {wrong # args: should be "doctools::msgcat::init prefix"} test doctools-msgcat-1.1 {init, wrong#args, too many} -body { doctools::msgcat::init fu bar } -returnCodes error -result {wrong # args: should be "doctools::msgcat::init prefix"} test doctools-msgcat-2.0 {init, ok args} -body { doctools::msgcat::init idx } -result 1 # ------------------------------------------------------------------------- testsuiteCleanup return tcllib-1.15/modules/doctools2base/tests/0000755000175000017500000000000012104363635017607 5ustar sergeisergeitcllib-1.15/modules/doctools2base/tests/tcl_data/0000755000175000017500000000000012104363635021362 5ustar sergeisergeitcllib-1.15/modules/doctools2base/tests/tcl_data/ok/0000755000175000017500000000000012104363635021773 5ustar sergeisergeitcllib-1.15/modules/doctools2base/tests/tcl_data/ok/out/0000755000175000017500000000000012104363635022602 5ustar sergeisergeitcllib-1.15/modules/doctools2base/tests/tcl_data/ok/out/03_command30000644000175000017500000000036412077663116024541 0ustar sergeisergeiroot () ....node1 (col 4 line 1 range {1 3} text foo type Command) ........node5 (col 6 line 1 range {5 5} text x type Text) ........node7 (col 9 line 1 range {7 8} text {$y} type Text) ....node8 (col 0 line 2 range {10 10} text { } type Text) tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/out/16_text0000644000175000017500000000010512077663116024021 0ustar sergeisergeiroot () ....node1 (col 0 line 2 range {0 5} text {a b c } type Text) tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/out/05_command50000644000175000017500000000027312077663116024544 0ustar sergeisergeiroot () ....node1 (col 4 line 1 range {1 3} text foo type Command) ........node5 (col 9 line 1 range {6 8} text {x y} type Text) ....node6 (col 0 line 2 range {11 11} text { } type Text) tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/out/11_continuation10000644000175000017500000000036312077663116025631 0ustar sergeisergeiroot () ....node1 (col 4 line 1 range {1 3} text foo type Command) ........node5 (col 6 line 1 range {5 5} text x type Text) ........node7 (col 8 line 1 range {10 10} text y type Text) ....node8 (col 0 line 2 range {12 12} text { } type Text) tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/out/02_command20000644000175000017500000000035712077663116024541 0ustar sergeisergeiroot () ....node1 (col 4 line 1 range {1 3} text foo type Command) ........node5 (col 6 line 1 range {5 5} text x type Text) ........node7 (col 8 line 1 range {7 7} text y type Text) ....node8 (col 0 line 2 range {9 9} text { } type Text) tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/out/08_command80000644000175000017500000000027412077663116024553 0ustar sergeisergeiroot () ....node1 (col 4 line 1 range {1 3} text foo type Command) ........node5 (col 10 line 1 range {6 9} text x\ \{ type Text) ....node7 (col 0 line 2 range {12 12} text { } type Text) tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/out/04_command40000644000175000017500000000027312077663116024542 0ustar sergeisergeiroot () ....node1 (col 4 line 1 range {1 3} text foo type Command) ........node5 (col 9 line 1 range {6 8} text {x y} type Text) ....node6 (col 0 line 2 range {11 11} text { } type Text) tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/out/09_command_nested0000644000175000017500000000027412077663116026026 0ustar sergeisergeiroot () ....node1 (col 4 line 1 range {1 3} text foo type Command) ........node5 (col 9 line 1 range {6 8} text bar type Command) ....node8 (col 0 line 2 range {11 11} text { } type Text) tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/out/17_text_multiline0000644000175000017500000000011412077663116026104 0ustar sergeisergeiroot () ....node1 (col 0 line 3 range {0 11} text {a b c d e f } type Text) tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/out/07_command70000644000175000017500000000027412077663116024551 0ustar sergeisergeiroot () ....node1 (col 4 line 1 range {1 3} text foo type Command) ........node5 (col 10 line 1 range {6 9} text x\ \{ type Text) ....node7 (col 0 line 2 range {12 12} text { } type Text) tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/out/14_emptyword10000644000175000017500000000026612077663116025156 0ustar sergeisergeiroot () ....node1 (col 4 line 1 range {1 3} text foo type Command) ........node4 (col 6 line 1 range {5 5} text {} type Text) ....node5 (col 0 line 2 range {8 8} text { } type Text) tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/out/01_command10000644000175000017500000000017312077663116024533 0ustar sergeisergeiroot () ....node1 (col 4 line 1 range {1 3} text foo type Command) ....node4 (col 0 line 2 range {5 5} text { } type Text) tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/out/13_continuation30000644000175000017500000000037012077663116025633 0ustar sergeisergeiroot () ....node1 (col 4 line 1 range {1 3} text foo type Command) ........node5 (col 6 line 1 range {5 5} text x type Text) ........node7 (col 2 line 2 range {8 13} text {y z} type Text) ....node10 (col 0 line 3 range {16 16} text { } type Text) tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/out/12_continuation20000644000175000017500000000037012077663116025631 0ustar sergeisergeiroot () ....node1 (col 4 line 1 range {1 3} text foo type Command) ........node5 (col 6 line 1 range {5 5} text x type Text) ........node7 (col 2 line 2 range {8 13} text {y z} type Text) ....node10 (col 0 line 3 range {16 16} text { } type Text) tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/out/06_command60000644000175000017500000000027412077663116024547 0ustar sergeisergeiroot () ....node1 (col 4 line 1 range {1 3} text foo type Command) ........node5 (col 10 line 1 range {6 9} text { y} type Text) ....node7 (col 0 line 2 range {12 12} text { } type Text) tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/out/10_combined0000644000175000017500000000147212077663116024617 0ustar sergeisergeiroot () ....node1 (col 0 line 4 range {0 5} text {a b c } type Text) ....node2 (col 4 line 4 range {7 9} text foo type Command) ........node6 (col 8 line 4 range {11 13} text bar type Text) ........node8 (col 13 line 4 range {16 18} text {a b} type Text) ........node10 (col 17 line 4 range {21 22} text { } type Text) ....node11 (col 0 line 5 range {24 24} text { } type Text) ....node12 (col 4 line 5 range {26 28} text fox type Command) ........node16 (col 9 line 5 range {31 33} text bar type Command) ....node19 (col 0 line 6 range {36 36} text { } type Text) ....node20 (col 4 line 6 range {38 40} text dog type Command) ........node24 (col 9 line 6 range {45 48} text wags type Text) ........node26 (col 3 line 7 range {51 61} text {tail .} type Text) ....node30 (col 0 line 11 range {64 70} text { e f g } type Text) tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/out/15_emptyword20000644000175000017500000000026612077663116025160 0ustar sergeisergeiroot () ....node1 (col 4 line 1 range {1 3} text foo type Command) ........node4 (col 6 line 1 range {5 5} text {} type Text) ....node5 (col 0 line 2 range {8 8} text { } type Text) tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/out/18_command90000644000175000017500000000055512077663116024557 0ustar sergeisergeiroot () ....node1 (col 4 line 1 range {1 3} text foo type Command) ....node4 (col 9 line 1 range {6 8} text bar type Command) ....node7 (col 11 line 1 range {10 10} text { } type Text) ....node8 (col 13 line 1 range {12 12} text x type Command) ....node11 (col 16 line 1 range {15 15} text y type Command) ....node14 (col 0 line 2 range {17 17} text { } type Text) tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/in/0000755000175000017500000000000012104363635022401 5ustar sergeisergeitcllib-1.15/modules/doctools2base/tests/tcl_data/ok/in/03_command30000644000175000017500000000001312077663116024327 0ustar sergeisergei[foo x $y] tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/in/16_text0000644000175000017500000000000612077663116023620 0ustar sergeisergeia b c tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/in/05_command50000644000175000017500000000001412077663116024334 0ustar sergeisergei[foo "x y"] tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/in/11_continuation10000644000175000017500000000001512077663116025422 0ustar sergeisergei[foo x \ y] tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/in/02_command20000644000175000017500000000001212077663116024324 0ustar sergeisergei[foo x y] tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/in/08_command80000644000175000017500000000001512077663116024343 0ustar sergeisergei[foo "x \{"] tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/in/04_command40000644000175000017500000000001412077663116024332 0ustar sergeisergei[foo {x y}] tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/in/09_command_nested0000644000175000017500000000001412077663116025615 0ustar sergeisergei[foo [bar]] tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/in/17_text_multiline0000644000175000017500000000001412077663116025702 0ustar sergeisergeia b c d e f tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/in/07_command70000644000175000017500000000001512077663116024341 0ustar sergeisergei[foo {x \{}] tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/in/14_emptyword10000644000175000017500000000001112077663116024741 0ustar sergeisergei[foo {}] tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/in/01_command10000644000175000017500000000000612077663116024325 0ustar sergeisergei[foo] tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/in/13_continuation30000644000175000017500000000002112077663116025423 0ustar sergeisergei[foo x {y \ z}] tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/in/12_continuation20000644000175000017500000000002112077663116025421 0ustar sergeisergei[foo x "y \ z"] tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/in/06_command60000644000175000017500000000001512077663116024337 0ustar sergeisergei[foo "\n y"] tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/in/10_combined0000644000175000017500000000010712077663116024410 0ustar sergeisergeia b c [foo bar {a b} \n] [fox [bar]] [dog \ wags "tail\t\ ."] e f g tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/in/15_emptyword20000644000175000017500000000001112077663116024743 0ustar sergeisergei[foo ""] tcllib-1.15/modules/doctools2base/tests/tcl_data/ok/in/18_command90000644000175000017500000000002212077663116024343 0ustar sergeisergei[foo][bar] [x][y] tcllib-1.15/modules/doctools2base/tests/tcl_data/fail/0000755000175000017500000000000012104363635022275 5ustar sergeisergeitcllib-1.15/modules/doctools2base/tests/tcl_data/fail/out-ec/0000755000175000017500000000000012104363635023471 5ustar sergeisergeitcllib-1.15/modules/doctools2base/tests/tcl_data/fail/out-ec/3_unexpected_char0000644000175000017500000000003712077663116027005 0ustar sergeisergeidoctools::tcl::parse eof 8 1 8 tcllib-1.15/modules/doctools2base/tests/tcl_data/fail/out-ec/2_unexpected_eof0000644000175000017500000000003712077663116026640 0ustar sergeisergeidoctools::tcl::parse eof 4 1 4 tcllib-1.15/modules/doctools2base/tests/tcl_data/fail/out-ec/1_command0000644000175000017500000000004012077663116025252 0ustar sergeisergeidoctools::tcl::parse char 4 1 4 tcllib-1.15/modules/doctools2base/tests/tcl_data/fail/out/0000755000175000017500000000000012104363635023104 5ustar sergeisergeitcllib-1.15/modules/doctools2base/tests/tcl_data/fail/out/3_unexpected_char0000644000175000017500000000006412077663116026420 0ustar sergeisergeiUnexpected end of input in QuotedString at line 1.8 tcllib-1.15/modules/doctools2base/tests/tcl_data/fail/out/2_unexpected_eof0000644000175000017500000000005712077663116026255 0ustar sergeisergeiUnexpected end of input in Command at line 1.4 tcllib-1.15/modules/doctools2base/tests/tcl_data/fail/out/1_command0000644000175000017500000000007012077663116024670 0ustar sergeisergeiUnexpected character '\n' in UnquotedString at line 1.4 tcllib-1.15/modules/doctools2base/tests/tcl_data/fail/in/0000755000175000017500000000000012104363635022703 5ustar sergeisergeitcllib-1.15/modules/doctools2base/tests/tcl_data/fail/in/3_unexpected_char0000644000175000017500000000001012077663116026206 0ustar sergeisergei[foo "x tcllib-1.15/modules/doctools2base/tests/tcl_data/fail/in/2_unexpected_eof0000644000175000017500000000000412077663116026044 0ustar sergeisergei[footcllib-1.15/modules/doctools2base/tests/tcl_data/fail/in/1_command0000644000175000017500000000001012077663116024461 0ustar sergeisergei[foo x] tcllib-1.15/modules/doctools2base/tests/common0000644000175000017500000001504212077663116021032 0ustar sergeisergei# -*- tcl -*- # Code common to the various control files. # # Copyright (c) 2009 by Andreas Kupries # All rights reserved. # # RCS: @(#) $Id: common,v 1.3 2009/04/29 02:09:46 andreas_kupries Exp $ # ------------------------------------------------------------------------- # Similar to TestFiles in devtools/testutilities.tcl, but not # identical. Here we do not expect source'able test suites, but data # files, organized in sections under a main directory. proc TestFilesProcess {maindir section inset outset -> nv lv iv dv ev script} { upvar 1 $nv n $lv label $dv data $ev expected $iv inputfile set pattern $maindir/$section/$inset/* set files [TestFilesGlob $pattern] if {![llength $files]} { return -code error "No files matching \"$pattern\"" } foreach src $files { if {[string match *README* $src]} continue if {[file isdirectory $src]} continue set srcname [file tail $src] set exp [localPath $maindir]/$section/$outset/$srcname set data [fileutil::cat $src] set expected [string trim [fileutil::cat $exp]] set expected [string map [list @ $::tcltest::testsDirectory] $expected] regexp -- {^([0-9]+)} $srcname -> n regsub -all -- {^[0-9]+} $srcname {} label scan $n %d n set label [string trim [string map {_ { }} $label]] set inputfile $src uplevel 1 $script } return } # ------------------------------------------------------------------------- proc setup_plugins {} { global env array_unset env LANG* array_unset env LC_* set env(LANG) C ; # Usually default if nothing is set, OS X requires this. set paths [join [list \ [tcllibPath doctools2] \ [tcllibPath struct] \ [tcllibPath textutil]] \ [expr {$::tcl_platform(platform) eq "windows" ? ";" : ":"}]] # Initialize the paths an import plugin manager should use when # searching for an import plugin used by the code under test, and # also provide the paths enabling the import plugins to find their # supporting packages as well. set env(DOCTOOLS_IDX_IMPORT_PLUGINS) $paths # Initialize the paths an export plugin manager should use when # searching for an export plugin used by the code under test, and # also provide the paths enabling the export plugins to find their # supporting packages as well. set env(DOCTOOLS_IDX_EXPORT_PLUGINS) $paths return } # ------------------------------------------------------------------------- proc stripcomments {text} { set pattern {[[:space:]]*\[comment[[:space:]][[:space:]]*\{[^\}]*\}[[:space:]]*\][[:space:]]*} regsub -all -- $pattern $text {} text return $text } proc striphtmlcomments {text {n {}}} { set pattern {} if {$n eq {}} { regsub -all -- $pattern $text {} text } else { while {$n} { regsub -- $pattern $text {} text incr n -1 } } return $text } proc stripmanmacros {text} { return [string map [list \n[doctools::nroff::man_macros::contents] {}] $text] } proc stripnroffcomments {text {n {}}} { # return $text set pattern "'\\\\\"\[^\n\]*\n" if {$n eq {}} { regsub -all -- $pattern $text {} text } else { while {$n} { regsub -- $pattern $text {} text incr n -1 } } return $text } # ------------------------------------------------------------------------- # Validate a serialization against the tree it # was generated from. proc validate_serial {t serial {rootname {}}} { if {$rootname == {}} { set rootname [$t rootname] } # List length is multiple of 3 if {[llength $serial] % 3} { return serial/wrong#elements } # Scan through list and built a number helper # structures (arrays). array set a {} array set p {} array set ch {} foreach {node parent attr} $serial { # Node has to exist in tree if {![$t exists $node]} { return node/$node/unknown } if {![info exists ch($node)]} {set ch($node) {}} # Parent reference has to be empty or # integer, == 0 %3, >=0, < length serial if {$parent != {}} { if {![string is integer -strict $parent]} { return node/$node/parent/no-integer/$parent } if {$parent % 3} { return node/$node/parent/not-triple/$parent } if {$parent < 0} { return node/$node/parent/out-of-bounds/$parent } if {$parent >= [llength $serial]} { return node/$node/parent/out-of-bounds/$parent } # Resolve parent index into node name, has to match set parentnode [lindex $serial $parent] if {![$t exists $parentnode]} { return node/$node/parent/unknown/$parent/$parentnode } if {![string equal [$t parent $node] $parentnode]} { return node/$node/parent/mismatch/$parent/$parentnode/[$t parent $node] } lappend ch($parentnode) $node } else { set p($node) {} } # Attr list has to be of even length. if {[llength $attr] % 2} { return attr/$node/wrong#elements } # Attr have to exist and match in all respects if {![string equal \ [dictsort $attr] \ [dictsort [$t getall $node]]]} { return attr/$node/mismatch } } # Second pass, check that the children information is encoded # correctly. Reconstructed data has to match originals. foreach {node parent attr} $serial { if {![string equal $ch($node) [$t children $node]]} { return node/$node/children/mismatch } } # Reverse check # - List of nodes from the 'rootname' and check # that it and all its children are present # in the structure. set ::FOO {} $t walk $rootname n {walker $n} foreach n $::FOO { if {![info exists ch($n)]} { return node/$n/mismatch/reachable/missing } } if {[llength $::FOO] != [llength $serial]/3} { return structure/mismatch/#nodes/multiples } if {[llength $::FOO] != [array size ch]} { return structure/mismatch/#nodes/multiples/ii } return ok } # Callbacks for tree walking. # Remember the node in a global variable. proc walker {node} { lappend ::FOO $node } proc match_tree {ta tb} { match_node $ta [$ta rootname] $tb [$tb rootname] return } proc match_node {ta a tb b} { if {[dictsort [$ta getall $a]] ne [dictsort [$tb getall $b]]} { return -code error "$ta/$a at $tb/$b, attribute mismatch (([dictsort [$ta getall $a]]) ne ([dictsort [$tb getall $b]]))" } if {[llength [$ta children $a]] != [llength [$tb children $b]]} { return -code error "$ta/$a at $tb/$b, children mismatch" } foreach ca [$ta children $a] cb [$tb children $b] { match_node $ta $ca $tb $cb } return } # ------------------------------------------------------------------------- return tcllib-1.15/modules/doctools2base/tests/tcl_parse0000644000175000017500000000356412077663116021524 0ustar sergeisergei# -*- tcl -*- # docparsetcl.testsuite: tests for the tcl parser. # # Copyright (c) 2009 Andreas Kupries # All rights reserved. # # RCS: @(#) $Id: tcl_parse,v 1.1 2009/04/01 04:27:47 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [localPath tests/common] set mytestdir tests/tcl_data # ------------------------------------------------------------------------- TestFilesProcess $mytestdir ok in out -> n label input data expected { test doctools-tcl-parse-${stkimpl}-${setimpl}-${impl}-10.$n "doctools::tcl::parse, $label, ok" -setup { struct::tree myresult } -body { doctools::tcl::parse text myresult $data set res {} myresult walk root tok { lappend res "[string repeat {....} [myresult depth $tok]]$tok ([dictsort [myresult getall $tok]])" } join $res \n } -cleanup { myresult destroy } -result $expected } # ------------------------------------------------------------------------- TestFilesProcess $mytestdir fail in out -> n label input data expected { test doctools-tcl-parse-${stkimpl}-${setimpl}-${impl}-11.$n "doctools::tcl::parse, $label, eror message" -setup { struct::tree myresult } -body { doctools::tcl::parse text myresult $data } -cleanup { myresult destroy } -returnCodes error -result $expected } TestFilesProcess $mytestdir fail in out-ec -> n label input data expected { test doctools-tcl-parse-${stkimpl}-${setimpl}-${impl}-12.$n "doctools::tcl::parse, $label, error code" -setup { struct::tree myresult } -body { # Catch and rethrow using the error code as new message. catch { doctools::tcl::parse text myresult $data } set ::errorCode } -cleanup { myresult destroy } -result $expected } # ------------------------------------------------------------------------- unset input data expected n label res return tcllib-1.15/modules/doctools2base/text.tcl0000644000175000017500000001115712077663116020150 0ustar sergeisergei# -*- tcl -*- # Copyright (c) 2009 Andreas Kupries # Support package. Basic text generation commands. # # ## ### ##### ######## ############# ##################### ## Requirements package require Tcl 8.4 ; # Required Core namespace eval ::doctools::text {} # # ## ### ##### ######## ############# ##################### proc ::doctools::text::begin {} { variable state array unset state * array set state { stack {} buffer {} prefix {} pstack {} underl {} break 0 newlines 1 indenting 1 } return } proc ::doctools::text::done {} { variable state return $state(buffer) } proc ::doctools::text::save {} { variable state set current [array get state] begin set state(stack) $current return } proc ::doctools::text::restore {} { variable state set text [done] array set state $state(stack) return $text } proc ::doctools::text::collect {script} { save uplevel 1 $script return [restore] } # # ## ### ##### ######## ############# ##################### proc ::doctools::text::+ {text} { variable state if {$state(break)} { +++ [string repeat \n $state(break)] +++ $state(prefix) set state(break) 0 } +++ $text set state(underl) [string length $text] return } proc ::doctools::text::underline {char} { variable state newline + [string repeat [string index $char 0] $state(underl)] newline return } proc ::doctools::text::+++ {text} { variable state append state(buffer) $text return } # # ## ### ##### ######## ############# ##################### proc ::doctools::text::newline {{increment 1}} { variable state if {!$state(newlines)} { return 0 } incr state(break) $increment return 1 } proc ::doctools::text::newline? {} { variable state if {!$state(newlines)} { return 0 } if {$state(break)} { return 1 } if {![string length $state(buffer)]} { return 1 } if {[string index $state(buffer) end] eq "\n"} { return 1 } incr state(break) return 1 } # # ## ### ##### ######## ############# ##################### proc ::doctools::text::prefix {text} { variable state if {!$state(indenting)} return set state(prefix) $text return } proc ::doctools::text::indent {{increment 2}} { variable state if {!$state(indenting)} return lappend state(pstack) $state(prefix) set state(prefix) [string repeat { } $increment]$state(prefix) return } proc ::doctools::text::dedent {} { variable state if {!$state(indenting)} return set state(prefix) [lindex $state(pstack) end] set state(pstack) [lreplace $state(pstack) end end] return } proc ::doctools::text::indented {increment script} { indent $increment uplevel 1 $script dedent return } # # ## ### ##### ######## ############# ##################### proc ::doctools::text::indenting {enable} { variable state set state(indenting) $enable return } proc ::doctools::text::newlines {enable} { variable state set state(newlines) $enable return } # # ## ### ##### ######## ############# ##################### proc ::doctools::text::field {wvar elements {index {}}} { upvar 1 $wvar width set width 0 #puts @!$width if {$index ne {}} { foreach e $elements { #puts stdout @/$e set e [lindex $e $index] #puts stdout @^$e set l [string length $e] if {$l <= $width} continue set width $l } } else { foreach e $elements { #puts stdout @/$e set l [string length $e] if {$l <= $width} continue set width $l } } #puts stdout @=$width return } proc ::doctools::text::right {wvar str} { upvar $wvar width return [format %${width}s $str] } proc ::doctools::text::left {wvar str} { upvar $wvar width return [format %-${width}s $str] } # # ## ### ##### ######## ############# ##################### proc ::doctools::text::import {{namespace {}}} { uplevel 1 [list namespace eval ${namespace}::text { namespace import ::doctools::text::* }] return } proc ::doctools::text::importhere {{namespace ::}} { uplevel 1 [list namespace eval ${namespace} { namespace import ::doctools::text::* }] return } # # ## ### ##### ######## ############# ##################### namespace eval ::doctools::text { variable state array set state {} namespace export begin done save restore collect + underline +++ \ prefix indent dedent indented indenting newline newlines \ field right left newline? } # # ## ### ##### ######## ############# ##################### package provide doctools::text 0.1 return tcllib-1.15/modules/doctools2base/html_cssdefaults.man0000644000175000017500000000206112077663116022513 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin doctools::html::cssdefaults n 0.1] [copyright {2009 Andreas Kupries }] [moddesc {Documentation tools}] [titledesc {Default CSS style for HTML export plugins}] [category {Documentation tools}] [require Tcl 8.4] [require doctools::html::cssdefaults [opt 0.1]] [keywords doctools export plugin HTML CSS style] [description] This package provides a single command providing access to the text of the default CSS style to use for HTML markup generated by the various HTML export plugins. [para] This is an internal package of doctools, for use by [term export] plugins, i.e. the packages converting doctools related documented into other formats, most notably [term HTML]. [section API] [list_begin definitions] [call [cmd ::doctools::html::cssdefaults::contents]] This command returns the text of the default CSS style to use for HTML markup generated by the various HTML export plugins. [list_end] [vset CATEGORY doctools] [include include/feedback.inc] [manpage_end] tcllib-1.15/modules/doctools2base/include/0000755000175000017500000000000012104363635020070 5ustar sergeisergeitcllib-1.15/modules/doctools2base/include/feedback.inc0000644000175000017500000000065612077663116022324 0ustar sergeisergei[section {Bugs, Ideas, Feedback}] [vset TRACKER http://sourceforge.net/tracker/?group_id=12883] [vset LABEL {Tcllib SF Trackers}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph [vset CATEGORY]] of the [uri [vset TRACKER] [vset LABEL]]. Please also report any ideas for enhancements you may have for either package and/or documentation. tcllib-1.15/modules/doctools2base/tcllib_msgcat.man0000644000175000017500000000357112077663116021765 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin doctools::msgcat n 0.1] [copyright {2009 Andreas Kupries }] [moddesc {Documentation tools}] [titledesc {Message catalog management for the various document parsers}] [category {Documentation tools}] [require Tcl 8.4] [require msgcat] [require doctools::msgcat [opt 0.1]] [description] [keywords doctools docidx doctoc {message catalog}] [keywords localization l10n internationalization i18n] [keywords {catalog package} {message package}] The package [package doctools::msgcat] is a support module handling the selection of message catalogs for the various document processing packages in the doctools system version 2. As such it is an internal package a regular user (developer) should not be in direct contact with. [para] If you are such please go the documentation of either [list_begin enumerated] [enum] [package doctools::doc], [enum] [package doctools::toc], or [enum] [package doctools::idx] [list_end] [para] Within the system architecture this package resides under the various parser packages, and is shared by them. Underneath it, but not explicit dependencies, are the packages providing the message catalogs for the various languages. [section API] [list_begin definitions] [call [cmd ::doctools::msgcat::init] [arg prefix]] The command locates and loads the message catalogs for all the languages returned by [cmd msgcat::mcpreferences], provided that they could be found. It returns an integer number describing how many packages were found and loaded. [para] The names of the packages the command will look for have the form "doctools::msgcat::[arg prefix]::[var langcode]", with [arg prefix] the argument to the command, and the [var langcode] supplied by the result of [cmd msgcat::mcpreferences]. [list_end] [vset CATEGORY doctools] [include include/feedback.inc] [manpage_end] tcllib-1.15/modules/doctools2base/tcl_parse.man0000644000175000017500000001251612077663116021131 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin doctools::tcl::parse n 1] [copyright {2009 Andreas Kupries }] [moddesc {Documentation tools}] [titledesc {Processing text in 'subst -novariables' format}] [category {Documentation tools}] [keywords doctools parser subst command word {Tcl syntax}] [require Tcl 8.4] [require snit] [require fileutil] [require logger] [require struct::list] [require struct::stack] [require struct::set] [require treeql] [description] This package provides commands for parsing text with embedded Tcl commands as accepted by the Tcl builtin command [cmd {subst -novariables}]. The result of the parsing is an abstract syntax tree. [para] This is an internal package of doctools, for use by the higher level parsers processing the [term docidx], [term doctoc], and [term doctools] markup languages. [section API] [list_begin definitions] [call [cmd ::doctools::tcl::parse] [method text] \ [arg tree] [arg text] [opt [arg root]]] The command takes the [arg text] and parses it under the assumption that it contains a string acceptable to the Tcl builtin command [cmd {subst -novariables}]. Errors are thrown otherwise during the parsing. The format used for these errors in described in section [sectref {Error format}]. [para] The command returns the empty string as it result. The actual result of the parsing is entered into the tree structure [arg tree], under the node [arg root]. If [arg root] is not specified the root of [arg tree] is used. The [arg tree] has to exist and be the command of a tree object which supports the same methods as trees created by the package [package struct::tree]. [para] In case of errors [arg tree] will be left in an undefined state. [call [cmd ::doctools::tcl::parse] [method file] \ [arg tree] [arg path] [opt [arg root]]] The same as [method text], except that the text to parse is read from the file specified by [arg path]. [list_end] [section {Error format}] When the parser encounters a problem in the input it will throw an error using the format described here. [list_begin enumerated] [enum] The message will contain the reason for the problem (unexpected character or end of input in input), the character in question, if any, and the line and column the problem was found at, in a human readable form. This part is not documented further as its format may change as we see fit. It is intended for human consumption, not machine. [enum] The error code however will contain a machine-readable representation of the problem, in the form of a 5-element list containing, in the order listed below [list_begin enumerated] [enum] the constant string [const doctools::tcl::parse] [enum] the cause of the problem, one of [list_begin definitions] [def [const char]] Unexpected character in input [def [const eof]] Unexpected end of the input [list_end] [enum] The location of the problem as offset from the beginning of the input, counted in characters. Note: Line markers count as one character. [enum] The line the problem was found on (counted from 1 (one)), [enum] The column the problem was found at (counted from 0 (zero)) [list_end] [list_end] [section {Tree Structure}] After successfully parsing a string the generated tree will have the following structure: [list_begin enumerated] [enum] In the following items the word 'root' refers to the node which was specified as the root of the tree when invoking either [method text] or [method file]. This may be the actual root of the tree. [enum] All the following items further ignore the possibility of pre-existing attributes in the pre-existing nodes. If attributes exists with the same names as the attributes used by the parser the pre-existing values are written over. Attributes with names not clashing with the parser's attributes are not touched. [enum] The root node has no attributes. [enum] All other nodes have the attributes [list_begin definitions] [def type] The value is a string from the set { Command , Text , Word } [def range] The value is either empty or a 2-element list containing integer numbers. The numbers are the offsets of the first and last character in the input text, of the token described by the node,. [def line] The value is an integer, it describes the line in the input the token described by the node ends on. Lines are counted from 1 ([const one]). [def col] The value is an integer, it describes the column in the line in the input the token described by the node ends on. Columns are counted from 0 ([const zero]). [list_end] [enum] The children of the root, if any, are of type Command and Text, in semi-alternation. This means: After a Text node a Command node has to follow, and anything can follow a Command node, a Text or other Command node. [enum] The children of a Command node, if any, are of type Command, and Text, and Word, they describe the arguments of the command. [enum] The children of a Word node, if any, are of type Command, Text, in semi-alternation. This means: After a Text node a Command node has to follow, and anything can follow a Command node, a Text or other Command node. [enum] A Word node without children represents the empty string. [enum] All Text nodes are leaves of the tree. [enum] All leaves of the tree are either Text or Command nodes. Word nodes cannot be leaves. [list_end] [vset CATEGORY doctools] [include include/feedback.inc] [manpage_end] tcllib-1.15/modules/doctools2base/nroff_manmacros.tcl0000644000175000017500000001275712077663116022345 0ustar sergeisergei# -*- tcl -*- # Copyright (c) 2009 Andreas Kupries # Support package. Container for the man.macros needed by the nroff # export plugins when instructed to inline the commands the # documentation is using. # # ## ### ##### ######## ############# ##################### ## Requirements package require Tcl 8.4 ; # Required Core namespace eval ::doctools::nroff::man_macros { # Contents of the file we carry variable c {} } proc ::doctools::nroff::man_macros::contents {} { variable c return $c } set ::doctools::nroff::man_macros::c {'\" The definitions below are for supplemental macros used in Tcl/Tk '\" manual entries. '\" '\" .AP type name in/out ?indent? '\" Start paragraph describing an argument to a library procedure. '\" type is type of argument (int, etc.), in/out is either "in", "out", '\" or "in/out" to describe whether procedure reads or modifies arg, '\" and indent is equivalent to second arg of .IP (shouldn't ever be '\" needed; use .AS below instead) '\" '\" .AS ?type? ?name? '\" Give maximum sizes of arguments for setting tab stops. Type and '\" name are examples of largest possible arguments that will be passed '\" to .AP later. If args are omitted, default tab stops are used. '\" '\" .BS '\" Start box enclosure. From here until next .BE, everything will be '\" enclosed in one large box. '\" '\" .BE '\" End of box enclosure. '\" '\" .CS '\" Begin code excerpt. '\" '\" .CE '\" End code excerpt. '\" '\" .VS ?version? ?br? '\" Begin vertical sidebar, for use in marking newly-changed parts '\" of man pages. The first argument is ignored and used for recording '\" the version when the .VS was added, so that the sidebars can be '\" found and removed when they reach a certain age. If another argument '\" is present, then a line break is forced before starting the sidebar. '\" '\" .VE '\" End of vertical sidebar. '\" '\" .DS '\" Begin an indented unfilled display. '\" '\" .DE '\" End of indented unfilled display. '\" '\" .SO '\" Start of list of standard options for a Tk widget. The '\" options follow on successive lines, in four columns separated '\" by tabs. '\" '\" .SE '\" End of list of standard options for a Tk widget. '\" '\" .OP cmdName dbName dbClass '\" Start of description of a specific option. cmdName gives the '\" option's name as specified in the class command, dbName gives '\" the option's name in the option database, and dbClass gives '\" the option's class in the option database. '\" '\" .UL arg1 arg2 '\" Print arg1 underlined, then print arg2 normally. '\" '\" RCS: @(#) $Id: nroff_manmacros.tcl,v 1.2 2009/04/29 02:09:46 andreas_kupries Exp $ '\" '\" # Set up traps and other miscellaneous stuff for Tcl/Tk man pages. .if t .wh -1.3i ^B .nr ^l \n(.l .ad b '\" # Start an argument description .de AP .ie !"\\$4"" .TP \\$4 .el \{\ . ie !"\\$2"" .TP \\n()Cu . el .TP 15 .\} .ta \\n()Au \\n()Bu .ie !"\\$3"" \{\ \&\\$1 \\fI\\$2\\fP (\\$3) .\".b .\} .el \{\ .br .ie !"\\$2"" \{\ \&\\$1 \\fI\\$2\\fP .\} .el \{\ \&\\fI\\$1\\fP .\} .\} .. '\" # define tabbing values for .AP .de AS .nr )A 10n .if !"\\$1"" .nr )A \\w'\\$1'u+3n .nr )B \\n()Au+15n .\" .if !"\\$2"" .nr )B \\w'\\$2'u+\\n()Au+3n .nr )C \\n()Bu+\\w'(in/out)'u+2n .. .AS Tcl_Interp Tcl_CreateInterp in/out '\" # BS - start boxed text '\" # ^y = starting y location '\" # ^b = 1 .de BS .br .mk ^y .nr ^b 1u .if n .nf .if n .ti 0 .if n \l'\\n(.lu\(ul' .if n .fi .. '\" # BE - end boxed text (draw box now) .de BE .nf .ti 0 .mk ^t .ie n \l'\\n(^lu\(ul' .el \{\ .\" Draw four-sided box normally, but don't draw top of .\" box if the box started on an earlier page. .ie !\\n(^b-1 \{\ \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul' .\} .el \}\ \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul' .\} .\} .fi .br .nr ^b 0 .. '\" # VS - start vertical sidebar '\" # ^Y = starting y location '\" # ^v = 1 (for troff; for nroff this doesn't matter) .de VS .if !"\\$2"" .br .mk ^Y .ie n 'mc \s12\(br\s0 .el .nr ^v 1u .. '\" # VE - end of vertical sidebar .de VE .ie n 'mc .el \{\ .ev 2 .nf .ti 0 .mk ^t \h'|\\n(^lu+3n'\L'|\\n(^Yu-1v\(bv'\v'\\n(^tu+1v-\\n(^Yu'\h'-|\\n(^lu+3n' .sp -1 .fi .ev .\} .nr ^v 0 .. '\" # Special macro to handle page bottom: finish off current '\" # box/sidebar if in box/sidebar mode, then invoked standard '\" # page bottom macro. .de ^B .ev 2 'ti 0 'nf .mk ^t .if \\n(^b \{\ .\" Draw three-sided box if this is the box's first page, .\" draw two sides but no top otherwise. .ie !\\n(^b-1 \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c .el \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c .\} .if \\n(^v \{\ .nr ^x \\n(^tu+1v-\\n(^Yu \kx\h'-\\nxu'\h'|\\n(^lu+3n'\ky\L'-\\n(^xu'\v'\\n(^xu'\h'|0u'\c .\} .bp 'fi .ev .if \\n(^b \{\ .mk ^y .nr ^b 2 .\} .if \\n(^v \{\ .mk ^Y .\} .. '\" # DS - begin display .de DS .RS .nf .sp .. '\" # DE - end display .de DE .fi .RE .sp .. '\" # SO - start of list of standard options .de SO .SH "STANDARD OPTIONS" .LP .nf .ta 4c 8c 12c .ft B .. '\" # SE - end of list of standard options .de SE .fi .ft R .LP See the \\fBoptions\\fR manual entry for details on the standard options. .. '\" # OP - start of full description for a single option .de OP .LP .nf .ta 4c Command-Line Name: \\fB\\$1\\fR Database Name: \\fB\\$2\\fR Database Class: \\fB\\$3\\fR .fi .IP .. '\" # CS - begin code excerpt .de CS .RS .nf .ta .25i .5i .75i 1i .. '\" # CE - end code excerpt .de CE .fi .RE .. .de UL \\$1\l'|0\(ul'\\$2 ..} package provide doctools::nroff::man_macros 0.1 return tcllib-1.15/modules/doctools2base/tcl_parse.tcl0000644000175000017500000005274612077663116021151 0ustar sergeisergei# -*- tcl -*- # Copyright (c) 2009 Andreas Kupries # Recursive descent parser for Tcl commands embedded in a string. (=> # subst -novariables, without actual evaluation of the embedded # commands). Useful for processing templates, etc. The result is an # abstract syntax tree of strings and commands, which in turn have # strings and commands as arguments. # The tree can be processed further. The nodes of the tree are # annotated with line/column/offset information to allow later stages # the reporting of higher-level syntax and semantic errors with exact # locations in the input. # TODO :: Add ability to report progress through the # TODO :: input. Callback. Invoked in 'Initialize', 'Step', and # TODO :: 'Finalize'. # TODO :: Investigate possibility of using tclparser package # TODO :: ('parser') to handle the command pieces embedded in the # TODO :: text. # # ## ### ##### ######## ############# ##################### ## Requirements package require Tcl 8.4 ; # Required runtime. package require snit ; # OO system. package require fileutil ; # File utilities. package require logger ; # User feedback. package require struct::list ; # Higher-order list operations. package require struct::stack ; # Stacks package require struct::set ; # Finite sets package require treeql ; # Tree queries and transformation. # # ## ### ##### ######## ############# ##################### ## logger::initNamespace ::doctools::tcl::parse snit::type ::doctools::tcl::parse { # # ## ### ##### ######## ############# ## Public API typemethod file {t path {root {}}} { $type text $t [fileutil::cat -translation binary -encoding binary $path] $root } typemethod text {t text {root {}}} { # --- --- --- --------- --------- --------- # Phase 1. Lexical processing. # The resulting tree contains the raw tokens. See # below for the specification of the resulting tree # structure. # # This part is a recursive descent parser using Tcl's 12 rules # for processing the input. Note: Variable references are not # recognized, they are processed like regular text. Initialize $t $text $root String Finalize # Tree structure # - All nodes but the root have the attributes 'type', 'range', 'line', and 'col'. # # * 'type' in { Command, Text, Backslash, Word, Quote, Continuation, QBrace } # * 'range' is 2-element list (offset start, offset end) # * 'line' is integer number > 0 # * 'col' is integer number >= 0 # # 'type' specifies what sort of token the node contains. # # 'range' is the location of the token as offsets in # characters from the beginning of the string, for # first and last character in the token. EOL markers # count as one character. This can be empty. # # 'line', 'col' are the location of the first character # AFTER the token, as the line and column the character is # on and at. # # Meaning of the various node types # # Command .... : A command begins here, the text in the range # .............. is the opening bracket. # Text ....... : A text segment in a word, anything up to the # .............. beginning of a backslash sequence or of an # .............. embedded command. # Backslash .. : A backslash sequence. The text under the # .............. range is the whole sequence. # Word ....... : The beginning of an unquoted, quoted or # .............. braced word. The text under the range is the # .............. opening quote or brace, if any. The range is # .............. empty for an unquoted word. # Quote ...... : An embedded double-quote character which is # .............. not the end of a quoted string (a special # .............. type of backslash sequence). The range is the # .............. whole sequence. # Continuation : A continuation line in an unquoted, quoted, # .............. or braced string. The range covers the whole # .............. sequence, including the whitespace trailing # .............. it. # QBrace ..... : A quoted brace in a braced string. A special # .............. kind of backslash sequence. The range covers # .............. the whole sequence. # --- --- --- --------- --------- --------- # Phase 2. Convert the token tree into a syntax tree. # This phase simplifies the tree by converting and # eliminating special tokens, and further decouples # it from the input by storing the relevant string # ranges of the input in the tree. For the the # specification of the resulting structure see method # 'Verify'. # # The sub-phases are and do # # (a) Extract the string information from the input and store # them in their Text tokens. # (b) Convert the special tokens (QBrace, Backslash, Quote, # Continuation) into equivalent 'Text' tokens, with proper # string information. # (c) Merge adjacent 'Text' tokens. # (d) Remove irrelevant 'Word' tokens. These are tokens with a # single Text token as child. Word tokens without children # however represent empty strings. They are converted into # an equivalent Text node instead. # (e) Pull the first word of commands into the command token, # and ensure that it is not dynamic, i.e not an embedded # command. ShowTree $t "Raw tree" set q [treeql %AUTO% -tree $t] # (a) foreach n [$q query tree withatt type Text] { struct::list assign [$t get $n range] a e #$t unset $n range $t set $n text [string range $mydata $a $e] } ShowTree $t "Text annotation" # (b1) foreach n [$q query tree withatt type QBrace] { struct::list assign [$t get $n range] a e incr a ; # Skip backslash #$t unset $n range $t set $n text [string range $mydata $a $e] $t set $n type Text } ShowTree $t "Special conversion 1, quoted braces" # (b2) foreach n [$q query tree withatt type Backslash] { struct::list assign [$t get $n range] a e #$t unset $n range $t set $n text [subst -nocommands -novariables [string range $mydata $a $e]] #puts <'[string range $mydata $a $e]'> #puts _'[subst -nocommands -novariables [string range $mydata $a $e]]'_ $t set $n type Text } ShowTree $t "Special conversion 2, backslash sequences" # (b3) foreach n [$q query tree withatt type Quote] { #$t unset $n range $t set $n text "\"" $t set $n type Text } ShowTree $t "Special conversion 3, quoted double quotes" # (b4) foreach n [$q query tree withatt type Continuation] { #$t unset $n range $t set $n text { } $t set $n type Text } ShowTree $t "Special conversion 4, continuation lines" # (c) foreach n [$q query tree withatt type Text right withatt type Text] { set left [$t previous $n] $t append $left text [$t get $n text] # Extend covered range. Copy location. struct::list assign [$t get $left range] a _ struct::list assign [$t get $n range] _ e $t set $left range [list $a $e] $t set $left line [$t get $n line] $t set $left col [$t get $n col] $t delete $n } ShowTree $t "Merged adjacent texts" # (d) foreach n [$q query tree withatt type Word] { if {![$t numchildren $n]} { $t set $n type Text $t set $n text {} } elseif {[$t numchildren $n] == 1} { $t cut $n } } ShowTree $t "Dropped simple words" # (e) foreach n [$q query tree withatt type Command] { set first [lindex [$t children $n] 0] if {[$t get $first type] eq "Word"} { error {Dynamic command name} } $t set $n text [$t get $first text] $t set $n range [$t get $first range] $t set $n line [$t get $first line] $t set $n col [$t get $first col] $t delete $first } ShowTree $t "Command lifting" $q destroy Verify $t return } proc Verify {t} { # Tree structure ... # Attributes Values # - type string in {'Command','Text','Word'} (phase 2) # - range 2-tuple (integer, integer), can be empty. start and end offset of the word in the input string. # - line integer, line the node starts on. First line is 1 # - col integer, column the node starts on (#char since start of line, first char is 0) # Constraints # .(i) The root node has no attributes at all. # .(ii) The children of the root are Command and Text nodes in semi-alternation. # I.e.: After a Text node a Command has to follow. # After a Command node either Text or Command can follow. # .(iii) The children of a Command node are Text, Word, and Command nodes, the command arguments. If any. # .(iv) The children of a Word node are Command and Text nodes in semi-alternation. # .(v) All Text nodes are leafs. # .(vi) Any Command node can be a leaf. # .(vii) Word nodes cannot be leafs. # .(viii) All non-root nodes have the attributes 'type', 'range', 'col', and 'line'. foreach n [$t nodes] { if {[$t parent $n] eq ""} { # (ii) set last {} foreach c [$t children $n] { set type [$t get $c type] if {![struct::set contains {Command Text} $type]} { return -code error "$c :: Bad node type $type in child of root node" } elseif {($type eq $last) && ($last eq "Text")} { return -code error "$c :: Bad node $type, not semi-alternating" } set last $type } # (i) if {[llength [$t getall $n]]} { return -code error "$n :: Bad root node, has attributes, should not" } continue } else { # (viii) foreach k {range line col} { if {![$t keyexists $n $k]} { return -code error "$n :: Bad node, attribute '$k' missing" } } } set type [$t get $n type] switch -exact -- $type { Command { # (vi) # No need to check children. May have some or not, # and no specific sequence is required. } Word { # (vii) if {![llength [$t children $n]]} { return -code error "$n :: Bad word node is leaf" } # (iv) set last {} foreach c [$t children $n] { set type [$t get $c type] if {![struct::set contains {Command Text} $type]} { return -code error "$n :: Bad node type $type in word node" } elseif {($type eq $last) && ($last eq "Text")} { return -code error "$c :: Bad node $type, not semi-alternating" } set last $type } } Text { # (v) if {[llength [$t children $n]]} { return -code error "$n :: Bad text node is not leaf" } } default { # (iii) return -code error "$n :: Bad node type $type" } } } return } # # ## ### ##### ######## ############# ## Internal methods, lexical processing proc String {} { while 1 { Note @String if {[EOF]} break if {[Command]} continue if {[TextSegment]} continue if {[Backslash]} continue Stop ;# Unexpected character } Note @EOF return } proc Command {} { # A command starts with an opening bracket. Note ?Command if {![Match "\\A(\\\[)" range]} { Note \t%No-Command return 0 } Note !Command PushRoot [Node Command $range] while {[Word]} { # Step over any whitespace after the last word Whitespace # Command ends at the closing bracket if {[Match "\\A(\\])" range]} break if {![EOF]} continue Stop ;# Unexpected end of input } Note !CommandStop PopRoot return 1 } proc TextSegment {} { # A text segment is anything up to a command start or start of # a back slash sequence. Note ?TextSegment if {![Match "\\A(\[^\\\[\]+)" range]} { Note \t%No-TextSegment return 0 } Note !TextSegment Node Text $range return 1 } proc TextSegmentWithoutQuote {} { Note ?TextSegmentWithoutQuote # A text segment without quote is anything up to a command # start or start of a back slash sequence, or a double-quote # character. if {![Match "\\A(\[^\"\\\\\[\]+)" range]} { Note \t%No-TextSegmentWithoutQuote return 0 } Note !TextSegment Node Text $range return 1 } proc Backslash {} { Note ?Backslash if { ![Match "\\A(\\\\x\[a-fA-F0-9\]+)" range] && ![Match "\\A(\\\\u\[a-fA-F0-9\]{1,4})" range] && ![Match "\\A(\\\\\[0-2\]\[0-7\]{2})" range] && ![Match "\\A(\\\\\[0-7\]{1,2})" range] && ![Match {\A(\\[abfnrtv])} range] } { Note \t%No-Backslash return 0 } Note !Backslash Node Backslash $range return 1 } proc Word {} { Note ?Word if {[QuotedWord]} {return 1} if {[BracedWord 0]} {return 1} return [UnquotedWord] } proc Whitespace {} { Note ?Whitespace if {![Match {\A([ \t]|(\\\n[ \t]*))+} range]} { Note \t%No-Whitespace return 0 } Note !Whitespace return 1 } proc QuotedWord {} { # A quoted word starts with a double quote. Note ?QuotedWord if {![Match "\\A(\")" range]} { Note \t%No-QuotedWord return 0 } Note !QuotedWord PushRoot [Node Word $range] QuotedString PopRoot return 1 } proc BracedWord {keepclose} { # A braced word starts with an opening brace. Note ?BracedWord/$keepclose if {![Match "\\A(\{)" range]} { Note \t%No-BracedWord/$keepclose return 0 } Note !BracedWord/$keepclose PushRoot [Node Word $range] BracedString $keepclose PopRoot return 1 } proc UnquotedWord {} { Note !UnquotedWord PushRoot [Node Word {}] UnquotedString PopRoot return 1 } proc QuotedString {} { Note !QuotedString while 1 { Note !QuotedStringPart # A quoted word (and thus the embedded string) ends with # double quote. if {[Match "\\A(\")" range]} { return } # Now try to match possible pieces of the string. This is # a repetition of the code in 'String', except for the # different end condition above, and the possible embedded # double quotes and continuation lines the outer string # can ignore. if {[Command]} continue if {[Quote]} continue if {[QuotedBraces]} continue if {[Continuation]} continue if {[Backslash]} continue # Check after backslash recognition and processing if {[TextSegmentWithoutQuote]} continue Stop ;# Unexpected character or end of input } return } proc BracedString {keepclose} { while 1 { Note !BracedStringPart # Closing brace encountered. keepclose is set if we are in # a nested braced string. Only then do we have to put the # brace as a regular text piece into the string if {[Match "\\A(\})" range]} { if {$keepclose} { Node Text $range } return } # Special sequences. if {[QuotedBraces]} continue if {[Continuation]} continue if {[BracedWord 1]} continue # A backslash without a brace coming after is regular a # character. if {[Match {\A(\\)} range]} { Node Text $range continue } # Gooble sequence of regular characters. Stops at # backslash and braces. Backslash stop is needed to handle # the case of them starting a quoted brace. if {[Match {\A([^\\\{\}]*)} range]} { Node Text $range continue } Stop ;# Unexpected character or end of input. } } proc UnquotedString {} { while 1 { Note !UnquotedStringPart # Stop conditions # - end of string # - whitespace # - Closing bracket (end of command the word is in) if {[EOF]} return if {[Whitespace]} return if {[Peek "\\A(\\\])" range]} return # Match each possible type of part if {[Command]} continue if {[Quote]} continue if {[Continuation]} continue if {[Backslash]} continue # Last, capture backslash sequences first. if {[UnquotedTextSegment]} continue Stop ;# Unexpected character or end of input. } return } proc UnquotedTextSegment {} { # All chars but whitespace and brackets (start or end of # command). Note ?UnquotedTextSegment if {![Match {\A([^\]\[\t\n ]+)} range]} { Note \t%No-UnquotedTextSegment return 0 } Note !UnquotedTextSegment Node Text $range return 1 } proc Quote {} { Note ?EmdeddedQuote if {![Match "\\A(\\\")" range]} { Note \t%No-EmdeddedQuote return 0 } # Embedded double quote, not the end of the quoted string. Note !EmdeddedQuote Node Quote $range return 1 } proc Continuation {} { Note ?ContinuationLine if {![Match "\\A(\\\\\n\[ \t\]*)" range]} { Note \t%No-ContinuationLine return 0 } Note !ContinuationLine Node Continuation $range return 1 } proc QuotedBraces {} { Note ?QuotedBrace if { ![Match "\\A(\\\\\{)" range] && ![Match "\\A(\\\\\})" range] } { Note \t%No-QuotedBrace return 0 } Note !QuotedBrace Node QBrace $range return 1 } # # ## ### ##### ######## ############# ## Tree construction helper commands. proc Node {what range} { set n [lindex [$mytree insert $myroot end] 0] Note "+\tNode $n @ $myroot $what" $mytree set $n type $what $mytree set $n range $range $mytree set $n line $myline $mytree set $n col $mycol return $n } proc PushRoot {x} { Note "Push Root = $x" $myrootstack push $myroot set myroot $x return } proc PopRoot {} { set myroot [$myrootstack pop] Note "Pop Root = $myroot" return } # # ## ### ##### ######## ############# ## Error reporting proc Stop {} { ::variable myerr set ahead [string range $mydata $mypos [expr {$mypos + 30}]] set err [expr {![string length $ahead] ? "eof" : "char"}] set ahead [string map [list \n \\n \t \\t \r \\r] [string range $ahead 0 0]] set caller [lindex [info level -1] 0] set msg "[format $myerr($err) $ahead $caller] at line ${myline}.$mycol" set err [list doctools::tcl::parse $err $mypos $myline $mycol] return -code error -errorcode $err $msg } # # ## ### ##### ######## ############# ## Input processing. Match/peek lexemes, update location after ## stepping over a range. Match = Peek + Step. proc EOF {} { Note "?EOF($mypos >= $mysize) = [expr {$mypos >= $mysize}]" return [expr {$mypos >= $mysize}] } proc Match {pattern rv} { upvar 1 $rv range set ok [Peek $pattern range] if {$ok} {Step $range} return $ok } proc Peek {pattern rv} { upvar 1 $rv range Note Peek($pattern)----|[string map [list "\n" "\\n" "\t" "\\t"] [string range $mydata $mypos [expr {$mypos + 30}]]]| if {[regexp -start $mypos -indices -- $pattern $mydata -> range]} { Note \tOK return 1 } else { Note \tFAIL return 0 } } proc Step {range} { struct::list assign $range a e set mylastpos $mypos set mypos $e incr mypos set pieces [split [string range $mydata $a $e] \n] set delta [string length [lindex $pieces end]] set nlines [expr {[llength $pieces] - 1}] if {$nlines} { incr myline $nlines set mycol $delta } else { incr mycol $delta } return } # # ## ### ##### ######## ############# ## Setup / Shutdown of parser/lexer proc Initialize {t text root} { set mytree $t if {$root eq {}} { set myroot [$t rootname] } else { set myroot $root } if {$myrootstack ne {}} Finalize set myrootstack [struct::stack %AUTO%] $myrootstack clear set mydata $text set mysize [string length $mydata] set mypos 0 set myline 1 set mycol 0 return } proc Finalize {} { $myrootstack destroy set myrootstack {} return } # # ## ### ##### ######## ############# ## Debugging helper commands ## Add ability to disable these. ## For the tree maybe add ability to dump through a callback ? proc Note {text} { upvar 1 range range set m {} append m "$text " if {[info exists range]} { append m "($range) " if {$range != {}} { foreach {a e} $range break append m " = \"[string map [list "\n" "\\n" "\t" "\\t"] \ [string range $mydata $a $e]]\"" } } else { append m "@$mypos ($myline/$mycol)" } #log::debug $m puts $m return } #proc ShowTreeX {args} {} proc ShowTreeX {t x} { puts "=== \[ $x \] [string repeat = [expr {72 - [string length $x] - 9}]]" $t walk root -order pre -type dfs n { set prefix [string repeat .... [$t depth $n]] puts "$prefix$n <[DictSort [$t getall $n]]>" } return } proc Note {args} {} proc ShowTree {args} {} # # ## ### ##### ######## ############# proc DictSort {dict} { array set tmp $dict set res {} foreach k [lsort -dict [array names tmp]] { lappend res $k $tmp($k) } return $res } # # ## ### ##### ######## ############# ## Parser state typevariable mytree {} ; # Tree we are working on typevariable myroot {} ; # Current root to add nodes to. typevariable myrootstack {} typevariable mydata {} ; # String to parse. typevariable mysize 0 ; # Length of string to parse, cache typevariable mylastpos ; # Last current position. typevariable mypos 0 ; # Current parse location, offset from typevariable myline 1 ; # the beginning of the string, line typevariable mycol 0 ; # we are on, and the column within the # line. typevariable myerr -array { char {Unexpected character '%1$s' in %2$s} eof {Unexpected end of input in %2$s} } # # ## ### ##### ######## ############# ## Configuration pragma -hasinstances no ; # singleton pragma -hastypeinfo no ; # no introspection pragma -hastypedestroy no ; # immortal ## # # ## ### ##### ######## ############# } namespace eval ::doctools::tcl { namespace export parse } # # ## ### ##### ######## ############# ##################### ## Ready package provide doctools::tcl::parse 0.1 return tcllib-1.15/modules/doctools2base/html_cssdefaults.tcl0000644000175000017500000000571512077663116022533 0ustar sergeisergei# -*- tcl -*- # Copyright (c) 2009 Andreas Kupries # Support package. Container for the default CSS style used by the # html export plugins when the user does not specify its own style. # # ## ### ##### ######## ############# ##################### ## Requirements package require Tcl 8.4 ; # Required Core namespace eval ::doctools::html::cssdefaults { # Contents of the file we carry variable c {} } proc ::doctools::html::cssdefaults::contents {} { variable c return $c } set ::doctools::html::cssdefaults::c { HTML { background: #FFFFFF; color: black; } BODY { background: #FFFFFF; color: black; } DIV.doctools { margin-left: 10%; margin-right: 10%; } DIV.doctools H1,DIV.doctools H2 { margin-left: -5%; } H1, H2, H3, H4 { margin-top: 1em; font-family: sans-serif; font-size: large; color: #005A9C; background: transparent; text-align: left; } H1.title, H1.idx-title { text-align: center; } UL,OL { margin-right: 0em; margin-top: 3pt; margin-bottom: 3pt; } UL LI { list-style: disc; } OL LI { list-style: decimal; } DT { padding-top: 1ex; } UL.toc,UL.toc UL, UL.toc UL UL { font: normal 12pt/14pt sans-serif; list-style: none; } LI.section, LI.subsection { list-style: none; margin-left: 0em; text-indent: 0em; padding: 0em; } PRE { display: block; font-family: monospace; white-space: pre; margin: 0%; padding-top: 0.5ex; padding-bottom: 0.5ex; padding-left: 1ex; padding-right: 1ex; width: 100%; } PRE.example { color: black; background: #f5dcb3; border: 1px solid black; } UL.requirements LI, UL.syntax LI { list-style: none; margin-left: 0em; text-indent: 0em; padding: 0em; } DIV.synopsis { color: black; background: #80ffff; border: 1px solid black; font-family: serif; margin-top: 1em; margin-bottom: 1em; } UL.syntax { margin-top: 1em; border-top: 1px solid black; } UL.requirements { margin-bottom: 1em; border-bottom: 1px solid black; } DIV.idx-kwnav { width: 100%; margin-top: 5pt; margin-bottom: 5pt; margin-left: 0%; margin-right: 0%; padding-top: 5pt; padding-bottom: 5pt; background: #DDDDDD; color: black; border: 1px solid black; text-align: center; font-size: small; font-family: sans-serif; } /* TR.even/odd are used to get alternately colored table rows. * Could probably choose better colors here... */ TR.idx-even { color: black; background: #efffef; } TR.idx-odd { color: black; background: #efefff; } DIV.idx-header, DIV.idx-footer, DIV.idx-leader { width: 100%; margin-left: 0%; margin-right: 0%; } TH { color: #005A9C; background: #DDDDDD; text-align: center; font-family: sans-serif; font-weight: bold; } } package provide doctools::html::cssdefaults 0.1 return tcllib-1.15/modules/smtpd/0000755000175000017500000000000012104363635015031 5ustar sergeisergeitcllib-1.15/modules/smtpd/ChangeLog0000644000175000017500000001321312104363437016603 0ustar sergeisergei2013-02-01 Andreas Kupries * * Released and tagged Tcllib 1.15 ======================== * 2011-12-13 Andreas Kupries * * Released and tagged Tcllib 1.14 ======================== * 2011-04-11 Andreas Kupries * smtpd.man: [RFE 3247765]: Added option to configure the * smtpd.tcl: smtpd greeting/banner. Bumped to version 1.5 * pkgIndex.tcl 2011-01-24 Andreas Kupries * * Released and tagged Tcllib 1.13 ======================== * 2009-12-07 Andreas Kupries * * Released and tagged Tcllib 1.12 ======================== * 2008-12-12 Andreas Kupries * * Released and tagged Tcllib 1.11.1 ======================== * 2008-10-16 Andreas Kupries * * Released and tagged Tcllib 1.11 ======================== * 2007-09-12 Andreas Kupries * * Released and tagged Tcllib 1.10 ======================== * 2007-03-21 Andreas Kupries * smtpd.man: Fixed all warnings due to use of now deprecated commands. Added a section about how to give feedback. 2006-10-03 Andreas Kupries * * Released and tagged Tcllib 1.9 ======================== * 2005-10-06 Andreas Kupries * * Released and tagged Tcllib 1.8 ======================== * 2005-06-21 Pat Thoyts * smtpd.tcl: bug #1224575 - as per RFC2821:3.7 we must accept null return path addresses. The programmers validate_sender proc can then decide to accept or reject such a submission. 2005-06-14 Pat Thoyts * smtpd.tcl: The -deliver options should accept a script prefix not just a command. Set version to 1.4.0 2004-10-05 Andreas Kupries * * Released and tagged Tcllib 1.7 ======================== * 2004-06-26 Pat Thoyts * smtpd.tcl: Implemented RFC3207 - Secure SMTP over TLS. This adds a number of configuration options and a new command (available if the tls package is provided and -usetls is set to true.) Also implemented the SMTP HELP command and switched to using the logger package from tcllib. * /examples/smtpd/tk_smtpdTLS: New demo server to show off the TLS features added here. 2004-06-18 Pat Thoyts * pkgIndex.tcl: Incremented version to 1.2.2 * smtpd.man: * smtpd.tcl: * smtpd.tcl (::smtpd::gmtoffset): Fixed bug #934134. The TZ calculation was inverted and failed to cope with times spanning midnight. * smtpd.tcl (::smtpd::HELO): Shortened the response to a single line which is a more common smtpd response and may help with simple clients. 2004-05-23 Andreas Kupries * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * 2003-05-05 Andreas Kupries * * Released and tagged Tcllib 1.4 ======================== * 2003-04-10 Andreas Kupries * smtpd.tcl: Fixed bug #614591. 2003-01-25 Pat Thoyts * smtpd.tcl: Fix bug #674333: require Tcl version 8.3+ (the mime package requires 8.3 therefore so do we.) 2003-01-16 Andreas Kupries * smtpd.man: More semantic markup, less visual one. 2003-01-02 Pat Thoyts * smtpd.tcl: Added exception catching to all channel comms. Added some ESMTP option handling (rudimentary). Added SMTP Transparency handling. (RFC 2821: 4.5.2) Improved error messages for DATA command. 2002-10-25 Pat Thoyts * smtpd.tcl: Implemented request #627960 to propagate the network interface name into the server messages. Added a catch around the deliver call and permit the deliver code to return SMTP failure codes via ::errorCode. 2002-10-08 Pat Thoyts * smtpd.tcl: Implemented feature request #531531. Added -deliverMIME option to provide mail as a MIME token. * smtpd.man: Updated for the new delivery option. * tk_smtpdMIME: New example using the -deliverMIME option. 2002-09-25 David N. Welton * smtpd.man: Fixed documentation error in deliver example. 2002-09-19 David N. Welton * smtpd.tcl (smtpd::service): Added Andreas' suggested changes to avoid a bgerror caused by a broken pipe. 2002-09-16 Pat Thoyts * smtpd.tcl: fixed bug #609835 to cope with multiple addresses in MAIL and RCPT commands without raising exception. 2002-04-10 Andreas Kupries * smtpd.man: Added doctools manpage. 2001-12-10 Pat Thoyts * smtpd.tcl (smtpd::gmtoffset): Fixed for cases where the hour offset is invalid. 2001-11-19 Andreas Kupries * Moved example.tcl to the standard location in 'tcllib/examples/smtpd'. Also renamed it to "tk_smtpd". 2001-11-06 Pat Thoyts * smtpd.tcl: Tcl SMTP server package. * smtpd.n: Manual page for the Tcl SMTP server. * example.tcl: Simple demo of server use and authentication. tcllib-1.15/modules/smtpd/clients/0000755000175000017500000000000012104363635016472 5ustar sergeisergeitcllib-1.15/modules/smtpd/clients/php.ini0000644000175000017500000000245712077663116020000 0ustar sergeisergei[PHP] engine = On short_open_tag = On asp_tags = Off precision = 14 y2k_compliance = Off output_buffering = 4096 output_handler = zlib.output_compression = Off implicit_flush = Off allow_call_time_pass_reference = Off safe_mode = Off safe_mode_gid = Off safe_mode_include_dir = safe_mode_exec_dir = safe_mode_allowed_env_vars = PHP_ safe_mode_protected_env_vars = LD_LIBRARY_PATH disable_functions = expose_php = On max_execution_time = 30 ; Maximum execution time of each script, in seconds memory_limit = 8M ; Maximum amount of memory a script may consume (8MB) error_reporting = E_ALL display_errors = Off display_startup_errors = Off log_errors = On track_errors = Off warn_plus_overloading = Off variables_order = "GPCS" register_globals = Off register_argc_argv = Off post_max_size = 8M gpc_order = "GPC" magic_quotes_gpc = Off magic_quotes_runtime = Off magic_quotes_sybase = Off auto_prepend_file = auto_append_file = default_mimetype = "text/html" doc_root = user_dir = extension_dir = ./ enable_dl = On file_uploads = On upload_max_filesize = 2M allow_url_fopen = On [mail function] ; Win32 only SMTP = localhost sendmail_from = postmaster@localhost ; For Unix only. You may supply arguments as well (default: "sendmail -t -i"). ;sendmail_path = ; Local Variables: ; tab-width: 4 ; End: tcllib-1.15/modules/smtpd/clients/mail-test.php0000644000175000017500000000113312077663116021106 0ustar sergeisergei"; $body = "This is a sample message send from PHP.\r\n"; $body .= "As always, let us check the transparency function:\r\n"; $body .= ". <-- there should be a dot there.\r\n"; $body .= "Bye"; mail($rcpt, $subject, $body, $hdrs); ?> tcllib-1.15/modules/smtpd/clients/README0000644000175000017500000000111412077663116017355 0ustar sergeisergeiThese files are mail sending test scripts written in various scripting languages. The purpose of these is to check that our SMTPd inter-operates successfully with everyone else's SMTP client software. Feel free to add a test script for your favourite other language - or to improve the usage of any of the current languages. mail-test.pl - Perl test script mail-test.py - Python test mail-test.rb - Ruby test mail-test.php - PHP test (requires some php.ini configuration) php.ini - PHP ini file (default for Windows installations) mail-test.tcl - and of course, a Tcl client! tcllib-1.15/modules/smtpd/clients/mail-test.rb0000644000175000017500000000063112077663116020724 0ustar sergeisergeirequire 'net/smtp' sndr = 'ruby-test-script@localhost' rcpt = 'tcllib-test@localhost' msg = 'From: Ruby To: SMTPD Subject: Testing from Ruby This is a sample message send from Ruby. As always, let us check the transparency function: . <-- there should be a dot there. Bye' Net::SMTP.start('localhost', 25) do |smtp| smtp.send_mail msg, sndr, rcpt end tcllib-1.15/modules/smtpd/clients/mail-test.py0000644000175000017500000000227312077663116020755 0ustar sergeisergei# Python mail sample import sys, smtplib class SMTPTest: def __init__(self, interface='localhost', port=25): self.svr = smtplib.SMTP(interface, port) self.svr.set_debuglevel(1) def sendmail(self, sender, recipient, message): try: self.svr.sendmail(sender, recipient, message) except: print "oops" def quit(self): self.svr.quit() def test(): sndr = "python-script-test@localhost" rcpt = "tcllib-test@localhost" mesg = """From: Python Mailer To: Tcllib Tester Date: Fri Dec 20 14:20:49 2002 Subject: test from python This is a sample message from Python. Hope it's OK Check transparency: . <- there should be one dot here. Done """ # Connect svr = SMTPTest('localhost') # Try normal message svr.sendmail(sndr, rcpt, mesg) # should fail: invalid recipient. svr.sendmail(sndr, "", mesg) # should fail: NULL recipient only valid for sender svr.sendmail(sndr, "<>", mesg) # should be ok: null sender (permitted for daemon responses) svr.sendmail("<>", rcpt, mesg) svr.quit() if __name__ == '__main__': test() tcllib-1.15/modules/smtpd/clients/mail-test.tcl0000644000175000017500000000075112077663116021106 0ustar sergeisergeipackage require mime package require smtp set sndr "tcl-test-script@localhost" set rcpt "tcllib-test@localhost" set msg "This is a sample message send from Tcl.\nAs\ always, let us check the transparency function:\n. <-- there\ should be a dot there.\nBye" set tok [mime::initialize -canonical text/plain -encoding 7bit -string $msg] mime::setheader $tok Subject "Testing from Tcl" smtp::sendmessage $tok -servers localhost \ -header [list To $rcpt] \ -header [list From $sndr] tcllib-1.15/modules/smtpd/clients/mail-test.pl0000644000175000017500000000725512077663116020745 0ustar sergeisergei# mail-test.pl - Copyright (C) 2003 Pat Thoyts # # Send some mail from Perl. # # This sends two messages, one valid and one without a recipient using the # SMTP protocol. # # usage: ./mail-test.pl smtpd-host ?smtpd-port? # # ------------------------------------------------------------------------- use diagnostics; use strict; use Net::SMTP; use Sys::Hostname; my ($smtp_smart_host, $smtp_smart_port) = (shift, shift); $smtp_smart_host = 'localhost' if (!$smtp_smart_host); $smtp_smart_port = 25 if (!$smtp_smart_port); my $smtp_default_from = 'postmaster@' . hostname(); my $smtp_timeout = 120; my $smtp_log_mail = 0; my $smtp_debug = 1; my $sender_address = 'perl-test-script@' . hostname() . ''; my $recipient_address = 'tcl-smtpd@' . $smtp_smart_host . ''; my $from_address = 'Perl Test Script '; my $ro_address = 'Tcl Server '; print "Sending valid message\n"; test_ok(); print "Sending invalid message\n"; test_no_rcpt(); sub test_no_rcpt { my $header = 'From: ' . $sender_address . "\n"; $header .= 'Subject: perl test' . "\n"; my $message = <new($smtp_smart_host, Hello => hostname(), Port => $smtp_smart_port, Timeout => $smtp_timeout, Debug => $smtp_debug) || die "SMTP failed to connect: $!"; $smtp->mail($from, (Size=>length($msg), Bits=>'8')); $smtp->to(@rcpts); if ($smtp->data()) { # start sending data; $smtp->datasend($msg); # send the message $smtp->dataend(); # finished sending data } else { $smtp->reset(); } $smtp->quit; # end of session if ( $smtp_log_mail ) { if ( open(MAILLOG, ">> data/maillog") ) { print MAILLOG "From $from at ", localtime() . "\n"; print MAILLOG "To: " . join(@rcpts, ',') . "\n"; print MAILLOG $msg . "\n\n"; close(MAILLOG); } } } # ------------------------------------------------------------------------- tcllib-1.15/modules/smtpd/pkgIndex.tcl0000644000175000017500000000112412077663116017312 0ustar sergeisergei# 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 smtpd 1.5 [list source [file join $dir smtpd.tcl]] tcllib-1.15/modules/smtpd/smtpd.tcl0000644000175000017500000007227612077663116016710 0ustar sergeisergei# smtpd.tcl - Copyright (C) 2001 Pat Thoyts # # This provides a minimal implementation of the Simple Mail Tranfer Protocol # as per RFC821 and RFC2821 (http://www.normos.org/ietf/rfc/rfc821.txt) and # is designed for use during local testing of SMTP client software. # # ------------------------------------------------------------------------- # This software is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY # or FITNESS FOR A PARTICULAR PURPOSE. See the file 'license.terms' for # more details. # ------------------------------------------------------------------------- package require Tcl 8.3; # tcl minimum version package require logger; # tcllib 1.3 package require mime; # tcllib # @mdgen EXCLUDE: clients/mail-test.tcl namespace eval ::smtpd { variable rcsid {$Id: smtpd.tcl,v 1.22 2011/11/17 08:00:45 andreas_kupries Exp $} variable version 1.5 variable stopped namespace export start stop configure variable commands if {![info exists commands]} { set commands {EHLO HELO MAIL RCPT DATA RSET NOOP QUIT HELP} # non-minimal commands HELP VRFY EXPN VERB ETRN DSN } variable extensions if {! [info exists extensions]} { array set extensions { 8BITMIME {} SIZE 0 } } variable options if {! [info exists options]} { array set options { serveraddr {} deliverMIME {} deliver {} validate_host {} validate_sender {} validate_recipient {} usetls 0 tlsopts {} } set options(banner) "tcllib smtpd $version" } variable tlsopts {-cadir -cafile -certfile -cipher -command -keyfile -password -request -require -ssl2 -ssl3 -tls1} variable log if {![info exists log]} { set log [logger::init smtpd] ${log}::setlevel warn proc ${log}::stdoutcmd {level text} { variable service puts "\[[clock format [clock seconds] -format {%H:%M:%S}]\ $service $level\] $text" } } variable Help if {![info exists Help]} { array set Help { {} {{Topics:} { HELO MAIL DATA RSET NOOP QUIT} {For more information use "HELP ".}} HELO {{HELO } { Introduce yourself.}} MAIL {{MAIL FROM: [ ]} { Specify the sender of the message.} { If using ESMTP there may be additional parameters of the} { form NAME=VALUE.}} DATA {{DATA} { Send your mail message.} { End with a line containing a single dot.}} RSET {{RSET} { Reset the session.}} NOOP {{NOOP} { Command ignored by server.}} QUIT {{QUIT} { Exit SMTP session}} } } } # ------------------------------------------------------------------------- # Description: # Obtain configuration options for the server. # proc ::smtpd::cget {option} { variable options variable tlsopts variable log set optname [string trimleft $option -] if { [string equal option -loglevel] } { return [${log}::currentloglevel] } elseif { [info exists options($optname)] } { return $options($optname) } elseif {[lsearch -exact $tlsopts -$optname] != -1} { set ndx [lsearch -exact $options(tlsopts) -$optname] if {$ndx != -1} { return [lindex $options(tlsopts) [incr ndx]] } return {} } else { return -code error "unknown option \"-$optname\": \ must be one of -[join [array names options] {, -}]" } } # ------------------------------------------------------------------------- # Description: # Configure server options. These include validation of hosts or users # and a procedure to handle delivery of incoming mail. The -deliver # procedure must handle mail because the server may release all session # resources once the deliver proc has completed. # An example might be to exec procmail to deliver the mail to users. # proc ::smtpd::configure {args} { variable options variable commands variable extensions variable log variable tlsopts if {[llength $args] == 0} { set r [list -loglevel [${log}::currentloglevel]] foreach {opt value} [array get options] { lappend r -$opt $value } lappend r - return $r } while {[string match -* [set option [lindex $args 0]]]} { switch -glob -- $option { -loglevel {${log}::setlevel [Pop args 1]} -deliverMIME {set options(deliverMIME) [Pop args 1]} -deliver {set options(deliver) [Pop args 1]} -validate_host {set options(validate_host) [Pop args 1]} -validate_sender {set options(validate_sender) [Pop args 1]} -validate_recipient {set options(validate_recipient) [Pop args 1]} -banner {set options(banner) [Pop args 1]} -usetls { set usetls [Pop args 1] if {$usetls && ![catch {package require tls}]} { set options(usetls) 1 set extensions(STARTTLS) {} lappend commands STARTTLS } } -- { Pop args; break } default { set failed 1 if {[lsearch $tlsopts $option] != -1} { set options(tlsopts) \ [concat $options(tlsopts) $option [Pop args 1]] set failed 0 } set msg "unknown option: \"$option\":\ must be one of -deliverMIME, -deliver,\ -validate_host, -validate_recipient,\ -validate_sender or an option suitable\ to tls::init" if {$failed} { return -code error $msg } } } Pop args } return {} } # ------------------------------------------------------------------------- # Description: # Start the server on the given interface and port. # proc ::smtpd::start {{myaddr {}} {port 25}} { variable options variable stopped if {[info exists options(socket)]} { return -code error \ "smtpd service already running on socket $options(socket)" } if {$myaddr != {}} { set options(serveraddr) $myaddr set myaddr "-myaddr $myaddr" } else { if {$options(serveraddr) == {}} { set options(serveraddr) [info hostname] } } set options(socket) [eval socket \ -server [namespace current]::accept $myaddr $port] set stopped 0 Log notice "smtpd service started on $options(socket)" return $options(socket) } # ------------------------------------------------------------------------- # Description: # Stop a running server. Do nothing if the server isn't running. # proc ::smtpd::stop {} { variable options variable stopped if {[info exists options(socket)]} { close $options(socket) set stopped 1 Log notice "smtpd service stopped" unset options(socket) } } # ------------------------------------------------------------------------- # Description: # Accept a new connection and setup a fileevent handler to process the new # session. Performs a host id validation step before allowing access. # proc ::smtpd::accept {channel client_addr client_port} { variable options variable version upvar [namespace current]::state_$channel State # init state array catch {unset State} initializeState $channel set State(access) allowed set State(client_addr) $client_addr set State(client_port) $client_port set accepted true # configure the data channel fconfigure $channel -buffering line -translation crlf -encoding ascii fileevent $channel readable [list [namespace current]::service $channel] # check host access permissions if {[cget -validate_host] != {}} { if {[catch {eval [cget -validate_host] $client_addr} msg] } { Log notice "access denied for $client_addr:$client_port: $msg" Puts $channel "550 Access denied: $msg" set State(access) denied set accepted false } } if {$accepted} { # Accept the connection Log notice "connect from $client_addr:$client_port on $channel" Puts $channel "220 $options(serveraddr) $options(banner); [timestamp]" } return } # ------------------------------------------------------------------------- # Description: # Initialize the channel state array. Called by accept and RSET. # proc ::smtpd::initializeState {channel} { upvar [namespace current]::state_$channel State set State(indata) 0 set State(to) {} set State(from) {} set State(data) {} set State(options) {} } # ------------------------------------------------------------------------- # Description: # Access the state of a connected session using the channel name as part # of the state array name. Called with no value, it returns the current # value of the item (or {} if not defined). # proc ::smtpd::state {channel args} { if {[llength $args] == 0} { return [array get [namespace current]::state_$channel] } set arrname [namespace current]::[subst state_$channel] if {[llength $args] == 1} { set r {} if {[info exists [subst $arrname]($args)]} { # FRINK: nocheck set r [set [subst $arrname]($args)] } return $r } foreach {name value} $args { # FRINK: nocheck set [namespace current]::[subst state_$channel]($name) $value } return {} } # ------------------------------------------------------------------------- # Description: # Pop the nth element off a list. Used in options processing. # proc ::smtpd::Pop {varname {nth 0}} { upvar $varname args set r [lindex $args $nth] set args [lreplace $args $nth $nth] return $r } # ------------------------------------------------------------------------- # Description: # Wrapper to call our log procedure. # proc ::smtpd::Log {level text} { variable log ${log}::${level} $text } # ------------------------------------------------------------------------- # Description: # Safe puts. # If the client closes the channel, then puts will throw an error. Lets # terminate the session if this occurs. proc ::smtpd::Puts {channel args} { if {[catch {uplevel puts $channel $args} msg]} { Log error $msg catch { close $channel # FRINK: nocheck unset -- [namespace current]::state_$channel } } return $msg } # ------------------------------------------------------------------------- # Description: # Perform the chat with a connected client. This procedure accepts input on # the connected socket and executes commands according to the state of the # session. # proc ::smtpd::service {channel} { variable commands variable options upvar [namespace current]::state_$channel State if {[eof $channel]} { close $channel return } if {[catch {gets $channel cmdline} msg]} { close $channel Log error $msg return } if { $cmdline == "" && [eof $channel] } { Log warn "client has closed the channel" return } Log debug "received: $cmdline" # If we are handling a DATA section, keep looking for the end of data. if {$State(indata)} { if {$cmdline == "."} { set State(indata) 0 fconfigure $channel -translation crlf if {[catch {deliver $channel} err]} { # permit delivery handler to return SMTP errors in errorCode if {[regexp {\d{3}} $::errorCode]} { Puts $channel "$::errorCode $err" } else { Puts $channel "554 Transaction failed: $err" } } else { Puts $channel "250 [state $channel id]\ Message accepted for delivery" } } else { # RFC 2821 section 4.5.2: Transparency if {[string match {..*} $cmdline]} { set cmdline [string range $cmdline 1 end] } lappend State(data) $cmdline } return } # Process SMTP commands (case insensitive) set cmd [string toupper [lindex [split $cmdline] 0]] if {[lsearch $commands $cmd] != -1} { if {[info proc $cmd] == {}} { Puts $channel "500 $cmd not implemented" } else { # If access denied then client can only issue QUIT. if {$State(access) == "denied" && $cmd != "QUIT" } { Puts $channel "503 bad sequence of commands" } else { set r [eval $cmd $channel [list $cmdline]] } } } else { Puts $channel "500 Invalid command" } return } # ------------------------------------------------------------------------- # Description: # Generate a random ASCII character for use in mail identifiers. # proc ::smtpd::uidchar {} { set c . while {! [string is alnum $c]} { set n [expr {int(rand() * 74 + 48)}] set c [format %c $n] } return $c } # Description: # Generate a unique random identifier using only ASCII alphanumeric chars. # proc ::smtpd::uid {} { set r {} for {set cn 0} {$cn < 12} {incr cn} { append r [uidchar] } return $r } # ------------------------------------------------------------------------- # Description: # Calculate the local offset from GMT in hours for use in the timestamp # proc ::smtpd::gmtoffset {} { set now [clock seconds] set local [clock format $now -format "%j %H" -gmt false] set zulu [clock format $now -format "%j %H" -gmt true] set lh [expr {([scan [lindex $local 0] %d] * 24) \ + [scan [lindex $local 1] %d]}] set zh [expr {([scan [lindex $zulu 0] %d] * 24) \ + [scan [lindex $zulu 1] %d]}] set off [expr {$lh - $zh}] set off [format "%+03d00" $off] return $off } # ------------------------------------------------------------------------- # Description: # Generate a standard SMTP compliant timestamp. That is a local time but with # the timezone represented as an offset. # proc ::smtpd::timestamp {} { set ts [clock format [clock seconds] \ -format "%a, %d %b %Y %H:%M:%S" -gmt false] append ts " " [gmtoffset] return $ts } # ------------------------------------------------------------------------- # Description: # Get the servers ip address (from http://purl.org/mini/tcl/526.html) # proc ::smtpd::server_ip {} { set me [socket -server xxx -myaddr [info hostname] 0] set ip [lindex [fconfigure $me -sockname] 0] close $me return $ip } # ------------------------------------------------------------------------- # Description: # deliver is called once a mail transaction is completed and there is # no deliver procedure defined # The configured -deliverMIME procedure is called with a MIME token. # If no such callback is defined then try the -deliver option and use # the old API. # proc ::smtpd::deliver {channel} { set deliverMIME [cget deliverMIME] if { $deliverMIME != {} \ && [state $channel from] != {} \ && [state $channel to] != {} \ && [state $channel data] != {} } { # create a MIME token from the mail message. set tok [mime::initialize -string \ [join [state $channel data] "\n"]] # mime::setheader $tok "From" [state $channel from] # foreach recipient [state $channel to] { # mime::setheader $tok "To" $recipient -mode append # } # catch and rethrow any errors. set err [catch {eval $deliverMIME [list $tok]} msg] mime::finalize $tok -subordinates all if {$err} { Log debug "error in deliver: $msg" return -code error -errorcode $::errorCode \ -errorinfo $::errorInfo $msg } } else { # Try the old interface deliver_old $channel } } # ------------------------------------------------------------------------- # Description: # Deliver is called once a mail transaction is completed (defined as the # completion of a DATA command). The configured -deliver procedure is called # with the sender, list of recipients and the text of the mail. # proc ::smtpd::deliver_old {channel} { set deliver [cget deliver] if { $deliver != {} \ && [state $channel from] != {} \ && [state $channel to] != {} \ && [state $channel data] != {} } { if {[catch {$deliver [state $channel from] \ [state $channel to] \ [state $channel data]} msg]} { Log debug "error in deliver: $msg" return -code error -errorcode $::errorCode \ -errorinfo $::errorInfo $msg } } } # ------------------------------------------------------------------------- proc ::smtpd::split_address {address} { set start [string first < $address] set end [string last > $address] set addr [string range $address $start $end] incr end set opts [string trim [string range $address $end end]] return [list $addr $opts] } # ------------------------------------------------------------------------- # The SMTP Commands # ------------------------------------------------------------------------- # Description: # Initiate an SMTP session # Reference: # RFC2821 4.1.1.1 # proc ::smtpd::HELO {channel line} { variable options if {[state $channel domain] != {}} { Puts $channel "503 bad sequence of commands" Log debug "HELO received out of sequence." return } set r [regexp -nocase {^HELO\s+([-\w\.]+)\s*$} $line -> domain] if {$r == 0} { Puts $channel "501 Syntax error in parameters or arguments" Log debug "HELO received \"$line\"" return } Puts $channel "250 $options(serveraddr) Hello $domain\ \[[state $channel client_addr]\], pleased to meet you" state $channel domain $domain Log debug "HELO on $channel from $domain" return } # ------------------------------------------------------------------------- # Description: # Initiate an ESMTP session # Reference: # RFC2821 4.1.1.1 proc ::smtpd::EHLO {channel line} { variable options variable extensions if {[state $channel domain] != {}} { Puts $channel "503 bad sequence of commands" Log debug "EHLO received out of sequence." return } set r [regexp -nocase {^EHLO\s+([-\w\.]+)\s*$} $line -> domain] if {$r == 0} { Puts $channel "501 Syntax error in parameters or arguments" Log debug "EHLO received \"$line\"" return } Puts $channel "250-$options(serveraddr) Hello $domain\ \[[state $channel client_addr]\], pleased to meet you" foreach {extn opts} [array get extensions] { Puts $channel [string trimright "250-$extn $opts"] } Puts $channel "250 Ready for mail." state $channel domain $domain Log debug "EHLO on $channel from $domain" return } # ------------------------------------------------------------------------- # Description: # Reference: # RFC2821 4.1.1.2 # proc ::smtpd::MAIL {channel line} { set r [regexp -nocase {^MAIL FROM:\s*(.*)} $line -> from] if {$r == 0} { Puts $channel "501 Syntax error in parameters or arguments" Log debug "MAIL received \"$line\"" return } if {[catch { set from [split_address $from] set opts [lindex $from 1] set from [lindex $from 0] eval array set addr [mime::parseaddress $from] # RFC2821 3.7: we must accept null return path addresses. if {[string equal "<>" $from]} { set addr(error) {} } } msg]} { set addr(error) $msg } if {$addr(error) != {} } { Log debug "MAIL failed $addr(error)" Puts $channel "501 Syntax error in parameters or arguments" return } if {[cget -validate_sender] != {}} { if {[catch {eval [cget -validate_sender] $addr(address)}]} { # this user has been denied Log info "MAIL denied user $addr(address)" Puts $channel "553 Requested action not taken:\ mailbox name not allowed" return } } Log debug "MAIL FROM: $addr(address)" state $channel from $from state $channel options $opts Puts $channel "250 OK" return } # ------------------------------------------------------------------------- # Description: # Specify a recipient for this mail. This command may be executed multiple # times to contruct a list of recipients. If a -validate_recipient # procedure is configured then this is used. An error from the validation # procedure indicates an invalid or unacceptable mailbox. # Reference: # RFC2821 4.1.1.3 # Notes: # The postmaster mailbox MUST be supported. (RFC2821: 4.5.1) # proc ::smtpd::RCPT {channel line} { set r [regexp -nocase {^RCPT TO:\s*(.*)} $line -> to] if {$r == 0} { Puts $channel "501 Syntax error in parameters or arguments" Log debug "RCPT received \"$line\"" return } if {[catch { set to [split_address $to] set opts [lindex $to 1] set to [lindex $to 0] eval array set addr [mime::parseaddress $to] } msg]} { set addr(error) $msg } if {$addr(error) != {}} { Log debug "RCPT failed $addr(error)" Puts $channel "501 Syntax error in parameters or arguments" return } if {[string match -nocase "postmaster" $addr(local)]} { # we MUST support this recipient somehow as mail. Log notice "RCPT to postmaster" } else { if {[cget -validate_recipient] != {}} { if {[catch {eval [cget -validate_recipient] $addr(address)}]} { # this recipient has been denied Log info "RCPT denied mailbox $addr(address)" Puts $channel "553 Requested action not taken:\ mailbox name not allowed" return } } } Log debug "RCPT TO: $addr(address)" set recipients {} catch {set recipients [state $channel to]} lappend recipients $to state $channel to $recipients Puts $channel "250 OK" return } # ------------------------------------------------------------------------- # Description: # Begin accepting data for the mail payload. A line containing a single # period marks the end of the data and the server will then deliver the # mail. RCPT and MAIL commands must have been executed before the DATA # command. # Reference: # RFC2821 4.1.1.4 # Notes: # The DATA section is the only part of the protocol permitted to use non- # ASCII characters and non-CRLF line endings and some clients take # advantage of this. Therefore we change the translation option on the # channel and reset it once the DATA command is completed. See the # 'service' procedure for the handling of DATA lines. # We also insert trace information as per RFC2821:4.4 # proc ::smtpd::DATA {channel line} { variable version upvar [namespace current]::state_$channel State Log debug "DATA" if { $State(from) == {}} { Puts $channel "503 bad sequence: no sender specified" } elseif { $State(to) == {}} { Puts $channel "503 bad sequence: no recipient specified" } else { Puts $channel "354 Enter mail, end with \".\" on a line by itself" set State(id) [uid] set State(indata) 1 lappend trace "Return-Path: $State(from)" lappend trace "Received: from [state $channel domain]\ \[[state $channel client_addr]\]" lappend trace "\tby [info hostname] with tcllib smtpd ($version)" if {[info exists State(tls)] && $State(tls)} { catch { array set t [::tls::status $channel] lappend trace "\t(version=TLS1/SSL3 cipher=$t(cipher) bits=$t(sbits) verify=NO)" } } lappend trace "\tid $State(id); [timestamp]" set State(data) $trace fconfigure $channel -translation auto ;# naughty: RFC2821:2.3.7 } return } # ------------------------------------------------------------------------- # Description: # Reset the server state for this connection. # Reference: # RFC2821 4.1.1.5 # proc ::smtpd::RSET {channel line} { upvar [namespace current]::state_$channel State Log debug "RSET on $channel" if {[catch {initializeState $channel} msg]} { Log warn "RSET: $msg" } Puts $channel "250 OK" return } # ------------------------------------------------------------------------- # Description: # Verify the existence of a mailbox on the server # Reference: # RFC2821 4.1.1.6 # #proc ::smtpd::VRFY {channel line} { # # VRFY SP String CRLF #} # ------------------------------------------------------------------------- # Description: # Expand a mailing list. # Reference: # RFC2821 4.1.1.7 # #proc ::smtpd::EXPN {channel line} { # # EXPN SP String CRLF #} # ------------------------------------------------------------------------- # Description: # Return a help message. # Reference: # RFC2821 4.1.1.8 # proc ::smtpd::HELP {channel line} { variable Help set cmd {} regexp {^HELP\s*(\w+)?} $line -> cmd if {[info exists Help($cmd)]} { foreach line $Help($cmd) { Puts $channel "214-$line" } Puts $channel "214 End of HELP" } else { Puts $channel "504 HELP topic \"$cmd\" unknown." } } # ------------------------------------------------------------------------- # Description: # Perform no action. # Reference: # RFC2821 4.1.1.9 # proc ::smtpd::NOOP {channel line} { set str {} regexp -nocase {^NOOP (.*)$} -> str Log debug "NOOP: $str" Puts $channel "250 OK" return } # ------------------------------------------------------------------------- # Description: # Terminate a session and close the transmission channel. # Reference: # RFC2821 4.1.1.10 # Notes: # The server is only permitted to close the channel once it has received # a QUIT message. # proc ::smtpd::QUIT {channel line} { variable options upvar [namespace current]::state_$channel State Log debug "QUIT on $channel" Puts $channel "221 $options(serveraddr) Service closing transmission channel" close $channel # cleanup the session state array. unset State return } # ------------------------------------------------------------------------- # Description: # Implement support for secure mail transactions using the TLS package. # Reference: # RFC3207 # Notes: # proc ::smtpd::STARTTLS {channel line} { variable options upvar [namespace current]::state_$channel State Log debug "$line on $channel" if {![string equal $line STARTTLS]} { Puts $channel "501 Syntax error (no parameters allowed)" return } if {[lsearch -exact $options(tlsopts) -certfile] == -1 || [lsearch -exact $options(tlsopts) -keyfile] == -1} { Puts $channel "454 TLS not available due to temporary reason" return } set import [linsert $options(tlsopts) 0 ::tls::import $channel -server 1] Puts $channel "220 Ready to start TLS" if {[catch $import msg]} { Puts $channel "454 TLS not available due to temporary reason" } else { set State(domain) {}; # RFC3207:4.2 set State(tls) 1 } return } # ------------------------------------------------------------------------- # Logging callback for use with tls - you must specify this when configuring # smtpd if you wan to use it. # proc ::smtpd::tlscallback {option args} { switch -exact -- $option { "error" { foreach {chan msg} $args break Log error "TLS error '$msg'" } "verify" { foreach {chan depth cert rc err} $args break if {$rc ne "1"} { Log error "TLS verify/$depth Bad cert '$err' (rc=$rc)" } else { array set c $cert Log notice "TLS verify/$depth: $c(subject)" } return $rc } "info" { foreach {chan major minor state msg} $args break if {$msg ne ""} { append state ": $msg" } Log debug "TLS ${major}.${minor} $state" } default { Log warn "bad option \"$option\" in smtpd::callback" } } } # ------------------------------------------------------------------------- package provide smtpd $smtpd::version # ------------------------------------------------------------------------- # Local variables: # mode: tcl # indent-tabs-mode: nil # End: tcllib-1.15/modules/smtpd/smtpd.man0000644000175000017500000002200712077663116016664 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin smtpd n 1.5] [copyright {Pat Thoyts }] [moddesc {Tcl SMTP Server Package}] [titledesc {Tcl SMTP server implementation}] [category Networking] [require Tcl 8.3] [require smtpd [opt 1.5]] [description] [para] The [package smtpd] package provides a simple Tcl-only server library for the Simple Mail Transfer Protocol as described in RFC 821 ([uri http://www.rfc-editor.org/rfc/rfc821.txt]) and RFC 2821 ([uri http://www.rfc-editor.org/rfc/rfc2821.txt]). By default the server will bind to the default network address and the standard SMTP port (25). [para] This package was designed to permit testing of Mail User Agent code from a developers workstation. [emph "It does not attempt to deliver \ mail to your mailbox." ] Instead users of this package are expected to write a procedure that will be called when mail arrives. Once this procedure returns, the server has nothing further to do with the mail. [section SECURITY] On Unix platforms binding to the SMTP port requires root privileges. I would not recommend running any script-based server as root unless there is some method for dropping root privileges immediately after the socket is bound. Under Windows platforms, it is not necessary to have root or administrator privileges to bind low numbered sockets. However, security on these platforms is weak anyway. [para] In short, this code should probably not be used as a permanently running Mail Transfer Agent on an Internet connected server, even though we are careful not to evaluate remote user input. There are many other well tested and security audited programs that can be used as mail servers for internet connected hosts. [section COMMANDS] [list_begin definitions] [call [cmd ::smtpd::start] [opt [arg myaddr]] [opt [arg port]]] Start the service listening on [arg port] or the default port 25. If [arg myaddr] is given as a domain-style name or numerical dotted-quad IP address then the server socket will be bound to that network interface. By default the server is bound to all network interfaces. For example: [para] [example { set sock [::smtpd::start [info hostname] 0] }] [para] will bind to the hosts internet interface on the first available port. [para] At present the package only supports a single instance of a SMTP server. This could be changed if required at the cost of making the package a little more complicated to read. If there is a good reason for running multiple SMTP services then it will only be necessary to fix the [var options] array and the [var ::smtpd::stopped] variable usage. [para] As the server code uses [cmd fileevent](n) handlers to process the input on sockets you will need to run the event loop. This means either you should be running from within [syscmd wish](1) or you should [cmd vwait](n) on the [var ::smtpd::stopped] variable which is set when the server is stopped. [call [cmd ::smtpd::stop]] Halt the server and release the listening socket. If the server has not been started then this command does nothing. The [var ::smtpd::stopped] variable is set for use with [cmd vwait](n). [para] It should be noted that stopping the server does not disconnect any currently active sessions as these are operating over an independent channel. Only explicitly tracking and closing these sessions, or exiting the server process will close down all the running sessions. This is similar to the usual unix daemon practice where the server performs a [syscmd fork](2) and the client session continues on the child process. [call [cmd ::smptd::configure] [opt "[arg option] [arg value]"] [opt "[arg option] [arg value] [arg ...]"]] Set configuration options for the SMTP server. Most values are the name of a callback procedure to be called at various points in the SMTP protocol. See the [sectref CALLBACKS] section for details of the procedures. [list_begin definitions] [def "[option -banner] [arg text]"] Text of a custom banner message. The default banner is "tcllib smtpd 1.5". Note that changing the banner does not affect the bracketing text in the full greeting, printing status 220, server-address, and timestamp. [def "[option -validate_host] [arg proc]"] Callback to authenticate new connections based on the ip-address of the client. [def "[option -validate_sender] [arg proc]"] Callback to authenticate new connections based on the senders email address. [def "[option -validate_recipient] [arg proc]"] Callback to validate and authorize a recipient email address [def "[option -deliverMIME] [arg proc]"] Callback used to deliver mail as a mime token created by the tcllib [package mime] package. [def "[option -deliver] [arg proc]"] Callback used to deliver email. This option has no effect if the [option -deliverMIME] option has been set. [list_end] [call [cmd ::smtpd::cget] [opt [arg option]]] If no [arg option] is specified the command will return a list of all options and their current values. If an option is specified it will return the value of that option. [list_end] [section CALLBACKS] [list_begin definitions] [def "[cmd validate_host] callback"] This procedure is called with the clients ip address as soon as a connection request has been accepted and before any protocol commands are processed. If you wish to deny access to a specific host then an error should be returned by this callback. For example: [para] [example { proc validate_host {ipnum} { if {[string match "192.168.1.*" $ipnum]} { error "go away!" } } }] [para] If access is denied the client will receive a standard message that includes the text of your error, such as: [para] [example { 550 Access denied: I hate you. }] [para] As per the SMTP protocol, the connection is not closed but we wait for the client to send a QUIT command. Any other commands cause a [const {503 Bad Sequence}] error. [def "[cmd validate_sender] callback"] The validate_sender callback is called with the senders mail address during processing of a MAIL command to allow you to accept or reject mail based upon the declared sender. To reject mail you should throw an error. For example, to reject mail from user "denied": [para] [example { proc validate_sender {address} { eval array set addr [mime::parseaddress $address] if {[string match "denied" $addr(local)]} { error "mailbox $addr(local) denied" } return } }] [para] The content of any error message will not be passed back to the client. [def "[cmd validate_recipient] callback"] The validate_recipient callback is similar to the validate_sender callback and permits you to verify a local mailbox and accept mail for a local user address during RCPT command handling. To reject mail, throw an error as above. The error message is ignored. [def "[cmd deliverMIME] callback"]] The deliverMIME callback is called once a mail message has been successfully passed to the server. A mime token is constructed from the sender, recipients and data and the users procedure it called with this single argument. When the call returns, the mime token is cleaned up so if the user wishes to preserve the data she must make a copy. [para] [example { proc deliverMIME {token} { set sender [lindex [mime::getheader $token From] 0] set recipients [lindex [mime::getheader $token To] 0] set mail "From $sender [clock format [clock seconds]]" append mail "\n" [mime::buildmessage $token] puts $mail } }] [def "[cmd deliver] callback"] The deliver callback is called once a mail message has been successfully passed to the server and there is no -deliverMIME option set. The procedure is called with the sender, a list of recipients and the text of the mail as a list of lines. For example: [para] [example { proc deliver {sender recipients data} { set mail "From $sender \ [clock format [clock seconds]]" append mail "\n" [join $data "\n"] puts "$mail" } }] [para] Note that the DATA command will return an error if no sender or recipient has yet been defined. [list_end] [section VARIABLES] [list_begin definitions] [def [var ::smtpd::stopped]] This variable is set to [const true] during the [cmd ::smtpd::stop] command to permit the use of the [cmd vwait](n) command. [comment ::smtpd::postmaster] [comment {The e-mail address of the person that is the contact for the server.}] [list_end] [section AUTHOR] Written by Pat Thoyts [uri mailto:patthoyts@users.sourceforge.net]. [section LICENSE] This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file [file license.terms] for more details. [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph smtpd] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords smtpd smtp services {rfc 821} {rfc 2821} vwait socket] [manpage_end] tcllib-1.15/modules/hook/0000755000175000017500000000000012104363635014642 5ustar sergeisergeitcllib-1.15/modules/hook/hook.tcl0000644000175000017500000002435212077663116016322 0ustar sergeisergei# hook.tcl # # This file implements the hook(n) Subject/Observer # callback mechanism. Any number of observers can register for # a particular hook from a particular subject; when the # subject calls the hook, all observers are called. # # Copyright (C) 2010 by Will Duquette # # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL # WARRANTIES. namespace eval hook { namespace export bind call cget configure forget namespace ensemble create # Subject Dictionary: # # Dictionary subject -> hook -> observer -> binding variable sdict [dict create] # Observer Dictionary: # # Dictionary observer -> subject -> hook -> 1 # # The "1" is so that the hook name is a key, and can be # cleared using [dict unset $o $s $h] variable odict [dict create] # Observer counter # # Used to auto-generate observer names in [hook bind]. variable observerCounter 0 # Configuration options # # -errorcommand Handles errors in hook bindings. # -tracecommand Trace called hooks. variable options array set options { -errorcommand {} -tracecommand {} } } # hook::bind -- # # By default, binds an observer to a subject's hook. # Alternatively, bind can delete or query a binding, or query a # number of bindings. # # Arguments: # subject (optional) The name of the entity that owns the hook. # It will usually be a fully-qualified command # name, but "virtual" subjects are also allowed. # # hook (optional) The name of the hook. By convention, # hook names are enclosed in angle brackets and contain # no whitespace; however, any non-empty string is allowed. # # observer (optional) The name of the entity observing the hook. # It will usually be a fully-qualified command name, # but "virtual" observers are also allowed. # # If observer is the empty string, an observer name # of the form "::hook::ob" will be generated. # # binding (optional) The binding proper, a command prefix to which # the hook's arguments will be appended. # # Results: # If called with no arguments, returns a list of the names of the # subjects to which observers are bound. # # If called with just a subject name, returns a list of the names # of the subject's hooks to which bindings are bound. # # If called with just a subject name and a hook name, returns a # list of the names of the observers bound to that subject and hook. # # If called with a subject name, hook name, and observer name, # returns the associated binding, or the empty string if none. # # If called with all four arguments, it either adds or deletes # a binding. If the binding is the empty string, any existing # binding is deleted and the empty string is returned. # Otherwise the binding is saved, and the observer name is # returned. The observer will be automatically # generated if the empty string is given. proc hook::bind {args} { variable sdict variable odict variable observerCounter # FIRST, there should be no more than four args. set argc [llength $args] if {$argc > 4} { return -code error "wrong # args: should be \"hook bind ?subject? ?hook? ?observer? ?binding?\"" } lassign $args subject hook observer binding # NEXT, Add, update, or delete a binding. if {$argc == 4} { if {$binding ne ""} { # FIRST, auto-generate an observer, if need be. Note that # with bignums there's no chance of running out of valid # observer IDs. if {$observer eq ""} { set observer [namespace current]::ob[incr observerCounter] } # NEXT, add or update the binding dict set sdict $subject $hook $observer $binding dict set odict $observer $subject $hook 1 # NEXT, return the observer. return $observer } else { dict unset sdict $subject $hook $observer dict unset odict $observer $subject $hook } return } # NEXT, Query a binding if {$argc == 3} { if {[dict exists $sdict $subject $hook $observer]} { return [dict get $sdict $subject $hook $observer] } else { return {} } } # NEXT, Query the observers bound to a subject and hook. if {$argc == 2} { if {[dict exists $sdict $subject $hook]} { return [dict keys [dict get $sdict $subject $hook]] } else { return {} } } # NEXT, query the bound hooks for a given subject. if {$argc == 1} { if {[dict exists $sdict $subject]} { return [dict keys [dict get $sdict $subject]] } else { return {} } } # FINALLY, query the subjects with active bindings. return [dict keys $sdict] } # hook::forget -- # # Forget all bindings in which a named entity appears as either # subject or observer. No error is raised if the named entity # appears in no bindings at all. # # Arguments: # object The name of a subject, an observer, or both. # # Results: # Returns the empty string. proc hook::forget {object} { variable sdict variable odict # FIRST, get rid of any odict entries for which this object # is the subject. if {[dict exists $sdict $object]} { dict for {hook dict_o} [dict get $sdict $object] { dict for {observer binding} $dict_o { dict unset odict $observer $object $hook } } } # NEXT, get rid of any sdict entries for which this object is # the observer. if {[dict exists $odict $object]} { dict for {subject hdict} [dict get $odict $object] { dict for {hook dummy} $hdict { dict unset sdict $subject $hook $object } } } # NEXT, get rid of this object from sdict as subject. dict unset sdict $object # NEXT, get rid of this object form odict as observers. dict unset odict $object return } # hook::call -- # # A subject calls a hook. Bindings are called for all bound # observers. There is no guarantee of the order in which bindings # will be called. All bindings are called before the call returns. # Note that modules should document the hooks they call, including # details of any arguments associated with each hook. # # Arguments: # subject The subject sending the hook # hook The name of the hook being sent # args (optional) any arguments for this subject and hook. # # Results: # The bindings are called in no particular order; the args are # appended to each binding. Returns the empty string. # # If -errorcommand is defined, errors in bindings are handled # by the specified command. It is called with three arguments: # a list of the subject, hook, args, and observer, the error result, # and the return options dictionary. # # When the -tracecommand is set, it is called with four arguments: # the subject, the hook, a list of the hook arguments, and a # list of the receiving observers. proc hook::call {subject hook args} { variable sdict variable options # FIRST, If there are no observers we're done. if {[dict exists $sdict $subject $hook]} { set observers [dict keys [dict get $sdict $subject $hook]] } else { set observers [list] } # NEXT, for each observer, retrieve the binding (if it # still exists) and execute it. Keep track of the observers # for which the hook was actually called. set called [list] foreach observer $observers { # FIRST, skip bindings that no longer exist. if {![dict exists $sdict $subject $hook $observer]} { continue } set binding [dict get $sdict $subject $hook $observer] # NEXT, remember that we called a binding for this observer. lappend called $observer if {$options(-errorcommand) eq ""} { uplevel #0 [list {*}$binding {*}$args] } elseif {[catch { uplevel #0 [list {*}$binding {*}$args] } result opts]} { uplevel #0 \ [list {*}$options(-errorcommand) \ [list $subject $hook $args $observer] \ $result \ $opts] } } if {$options(-tracecommand) ne ""} { {*}$options(-tracecommand) $subject $hook $args $called } return } # hook::cget -- # # Returns the value of a hook configuration option. # # Arguments: # option The name of the option # # Results: # Returns the option's value. Throws an error if the # option name is invalid. proc hook::cget {option} { variable options if {$option ni [array names options]} { return -code error "unknown option \"$option\"" } return $options($option) } # hook::configure -- # # Sets the value of one or more hook configuration options. # # Arguments: # args A list of option names and their values # # Results: # Saves the option values. Throws an error for unknown options # and invalid values. No option values are changed on error. proc hook::configure {args} { variable options # FIRST, validate the options set argc [llength $args] set i 0 while {$i < $argc} { # FIRST, make sure it's a known option. set option [lindex $args [incr i]-1] if {$option ni [array names options]} { return -code error "unknown option \"$option\"" } # NEXT, make sure a value is specified. if {$i == $argc} { return -code error "value for \"$option\" missing" } # NEXT, skip the value incr i } # NEXT, save the values array set options $args return } # --------------------------------------------------------------- # Ready package provide hook 0.1 tcllib-1.15/modules/hook/ChangeLog0000644000175000017500000000136112104363437016415 0ustar sergeisergei2013-02-01 Andreas Kupries * * Released and tagged Tcllib 1.15 ======================== * 2011-12-13 Andreas Kupries * * Released and tagged Tcllib 1.14 ======================== * 2011-02-23 Andreas Kupries * hook.man: [Bug 3167244]: Moved examples to their own lines to avoid placement of following text on the .CE lines, causing a staircase effect. The doctools should be fixed as well. 2011-01-24 Andreas Kupries * * Released and tagged Tcllib 1.13 ======================== * 2011-01-12 Andreas Kupries * New module 'hook'. tcllib-1.15/modules/hook/hook.man0000644000175000017500000002743412077663116016317 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin hook n 0.1] [copyright {2010, by William H. Duquette}] [moddesc {Hooks}] [titledesc {Hooks}] [category {Programming tools}] [require Tcl 8.5] [require hook [opt 0.1]] [keywords hook event subject observer producer callback] [keywords publisher subscriber uevent] [see_also uevent(n)] [description] [para] This package provides the [cmd hook] ensemble command, which implements the Subject/Observer pattern. It allows [term subjects], which may be [term modules], [term objects], [term widgets], and so forth, to synchronously call [term hooks] which may be bound to an arbitrary number of subscribers, called [term observers]. A subject may call any number of distinct hooks, and any number of observers can bind callbacks to a particular hook called by a particular subject. Hook bindings can be queried and deleted. [para] This man page is intended to be a reference only. [section Concepts] [subsection Introduction] Tcl modules usually send notifications to other modules in two ways: via Tk events, and via callback options like the text widget's [option -yscrollcommand] option. Tk events are available only in Tk, and callback options require tight coupling between the modules sending and receiving the notification. [para] Loose coupling between sender and receiver is often desirable, however. In Model/View/Controller terms, a View can send a command (stemming from user input) to the Controller, which updates the Model. The Model can then call a hook [emph {to which all relevant Views subscribe.}] The Model is decoupled from the Views, and indeed need not know whether any Views actually exist. At present, Tcl/Tk has no standard mechanism for implementing loose coupling of this kind. This package defines a new command, [cmd hook], which implements just such a mechanism. [subsection Bindings] The [cmd hook] command manages a collection of hook bindings. A hook binding has four elements: [list_begin enumerated] [enum] A [term subject]: the name of the entity that will be calling the hook. [enum] The [term hook] itself. A hook usually reflects some occurrence in the life of the [term subject] that other entities might care to know about. A [term hook] has a name, and may also have arguments. Hook names are arbitrary strings. Each [term subject] must document the names and arguments of the hooks it can call. [enum] The name of the [term observer] that wishes to receive the [term hook] from the [term subject]. [enum] A command prefix to which the [term hook] arguments will be appended when the binding is executed. [list_end] [subsection {Subjects and observers}] For convenience, this document collectively refers to subjects and observers as [term objects], while placing no requirements on how these [term objects] are actually implemented. An object can be a [package TclOO] or [package Snit] or [package XOTcl] object, a Tcl command, a namespace, a module, a pseudo-object managed by some other object (as tags are managed by the Tk text widget) or simply a well-known name. [para] Subject and observer names are arbitrary strings; however, as [cmd hook] might be used at the package level, it's necessary to have conventions that avoid name collisions between packages written by different people. [para] Therefore, any subject or observer name used in core or package level code should look like a Tcl command name, and should be defined in a namespace owned by the package. Consider, for example, an ensemble command [cmd ::foo] that creates a set of pseudo-objects and uses [package hook] to send notifications. The pseudo-objects have names that are not commands and exist in their own namespace, rather like file handles do. To avoid name collisions with subjects defined by other packages, users of [package hook], these [cmd ::foo] handles should have names like [const ::foo::1], [const ::foo::2], and so on. [para] Because object names are arbitrary strings, application code can use whatever additional conventions are dictated by the needs of the application. [section Reference] Hook provides the following commands: [list_begin definitions] [call [cmd hook] [method bind] [opt [arg subject]] [opt [arg hook]] [opt [arg observer]] [opt [arg cmdPrefix]]] This subcommand is used to create, update, delete, and query hook bindings. [para] Called with no arguments it returns a list of the subjects with hooks to which observers are currently bound. [para] Called with one argument, a [arg subject], it returns a list of the subject's hooks to which observers are currently bound. [para] Called with two arguments, a [arg subject] and a [arg hook], it returns a list of the observers which are currently bound to this [arg subject] and [arg hook]. [para] Called with three arguments, a [arg subject], a [arg hook], and an [arg observer], it returns the binding proper, the command prefix to be called when the hook is called, or the empty string if there is no such binding. [para] Called with four arguments, it creates, updates, or deletes a binding. If [arg cmdPrefix] is the empty string, it deletes any existing binding for the [arg subject], [arg hook], and [arg observer]; nothing is returned. Otherwise, [arg cmdPrefix] must be a command prefix taking as many additional arguments as are documented for the [arg subject] and [arg hook]. The binding is added or updated, and the observer is returned. [para] If the [arg observer] is the empty string, "", it will create a new binding using an automatically generated observer name of the form [const ::hook::ob]<[var number]>. The automatically generated name will be returned, and can be used to query, update, and delete the binding as usual. If automated observer names are always used, the observer name effectively becomes a unique binding ID. [para] It is possible to call [cmd {hook bind}] to create or delete a binding to a [arg subject] and [arg hook] while in an observer binding for that same [arg subject] and [arg hook]. The following rules determine what happens when [example { hook bind $s $h $o $binding }] is called during the execution of [example { hook call $s $h }] [list_begin enumerated] [enum] No binding is ever called after it is deleted. [enum] When a binding is called, the most recently given command prefix is always used. [enum] The set of observers whose bindings are to be called is determined when this method begins to execute, and does not change thereafter, except that deleted bindings are not called. [list_end] In particular: [list_begin enumerated] [enum] If [var \$o]s binding to [var \$s] and [var \$h] is deleted, and [var \$o]s binding has not yet been called during this execution of [example { hook call $s $h }] it will not be called. (Note that it might already have been called; and in all likelihood, it is probably deleting itself.) [enum] If [var \$o] changes the command prefix that's bound to [var \$s] and [var \$h], and if [var \$o]s binding has not yet been called during this execution of [example { hook call $s $h }] the new binding will be called when the time comes. (But again, it is probably [var \$o]s binding that is is making the change.) [enum] If a new observer is bound to [var \$s] and [var \$h], its binding will not be called until the next invocation of [example { hook call $s $h }] [list_end] [call [cmd hook] [method call] [arg subject] [arg hook] [opt [arg args]...]] This command is called when the named [arg subject] wishes to call the named [arg hook]. All relevant bindings are called with the specified arguments in the global namespace. Note that the bindings are called synchronously, before the command returns; this allows the [arg args] to include references to entities that will be cleaned up as soon as the hook has been called. [para] The order in which the bindings are called is not guaranteed. If sequence among observers must be preserved, define one observer and have its bindings call the other callbacks directly in the proper sequence. [para] Because the [cmd hook] mechanism is intended to support loose coupling, it is presumed that the [arg subject] has no knowledge of the observers, nor any expectation regarding return values. This has a number of implications: [list_begin enumerated] [enum] [cmd {hook call}] returns the empty string. [enum] Normal return values from observer bindings are ignored. [enum] Errors and other exceptional returns propagate normally by default. This will rarely be what is wanted, because the subjects usually have no knowledge of the observers and will therefore have no particular competence at handling their errors. That makes it an application issue, and so applications will usually want to define an [option -errorcommand]. [list_end] If the [option -errorcommand] configuration option has a non-empty value, its value will be invoked for all errors and other exceptional returns in observer bindings. See [cmd {hook configure}], below, for more information on configuration options. [call [cmd hook] [method forget] [arg object]] This command deletes any existing bindings in which the named [arg object] appears as either the [term subject] or the [term observer]. Bindings deleted by this method will never be called again. In particular, [list_begin enumerated] [enum] If an observer is forgotten during a call to [cmd {hook call}], any uncalled binding it might have had to the relevant subject and hook will [emph not] be called subsequently. [enum] If a subject [var \$s] is forgotten during a call to [example {hook call $s $h}] then [cmd {hook call}] will return as soon as the current binding returns. No further bindings will be called. [list_end] [call [cmd hook] [method cget] [arg option]] This command returns the value of one of the [cmd hook] command's configuration options. [call [cmd hook] [method configure] [option option] [arg value] ...] This command sets the value of one or more of the [cmd hook] command's configuration options: [list_begin options] [opt_def -errorcommand [arg cmdPrefix]] If the value of this option is the empty string, "", then errors and other exception returns in binding scripts are propagated normally. Otherwise, it must be a command prefix taking three additional arguments: [list_begin enumerated] [enum] a 4-element list {subject hook arglist observer}, [enum] the result string, and [enum] the return options dictionary. [list_end] Given this information, the [option -errorcommand] can choose to log the error, call [cmd {interp bgerror}], delete the errant binding (thus preventing the error from arising a second time) and so forth. [opt_def -tracecommand [arg cmdPrefix]] The option's value should be a command prefix taking four arguments: [list_begin enumerated] [enum] a [term subject], [enum] a [term hook], [enum] a list of the hook's argument values, and [enum] a list of [term objects] the hook was called for. [list_end] The command will be called for each hook that is called. This allows the application to trace hook execution for debugging purposes. [list_end] [list_end] [section Example] The [cmd ::model] module calls the hook in response to commands that change the model's data: [example { hook call ::model }] The [widget .view] megawidget displays the model state, and needs to know about model updates. Consequently, it subscribes to the ::model's hook. [example { hook bind ::model .view [list .view ModelUpdate] }] When the [cmd ::model] calls the hook, the [widget .view]s ModelUpdate subcommand will be called. [para] Later the [widget .view] megawidget is destroyed. In its destructor, it tells the [term hook] that it no longer exists: [example { hook forget .view }] All bindings involving [widget .view] are deleted. [section Credits] Hook has been designed and implemented by William H. Duquette. [vset CATEGORY hook] [include ../doctools2base/include/feedback.inc] [manpage_end] tcllib-1.15/modules/hook/pkgIndex.tcl0000644000175000017500000000023512077663116017125 0ustar sergeisergeiif {![package vsatisfies [package provide Tcl] 8.5]} { # PRAGMA: returnok return } package ifneeded hook 0.1 [list source [file join $dir hook.tcl]] tcllib-1.15/modules/hook/hook.test0000644000175000017500000002755512077663116016527 0ustar sergeisergei# hook.test -*- tcl -*- # # This file contains the test suite for hook-0.1.tcl. # # Copyright (C) 2010 by Will Duquette # # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL # WARRANTIES. #----------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.1 support { } testing { useLocal hook.tcl hook } #----------------------------------------------------------------------- # Helper procs variable info array set info { callList {} traceList {} errorList {} } proc cleanup {} { variable info array set info { callList {} traceList {} errorList {} } foreach subject [hook bind] { hook forget $subject } hook configure -errorcommand {} -tracecommand {} # Ensure that auto-generated observers are repeatable. set ::hook::observerCounter 0 } proc TestBinding {subject hook observer args} { variable info lappend info(callList) [list $subject $hook $observer $args] return } proc GetCalls {} { variable info return $info(callList) } proc TraceCommand {subject hook args observers} { variable info lappend info(traceList) [list $subject $hook $args $observers] } proc GetTrace {} { variable info return $info(traceList) } proc TestBind {subject hook observer} { hook bind $subject $hook $observer \ [list TestBinding $subject $hook $observer] } proc ErrorCommand {call result opts} { variable info set opts [dict remove $opts -errorinfo -errorline] lappend info(errorList) [list $call $result $opts] } proc GetError {} { variable info return $info(errorList) } if {[package vsatisfies [package provide Tcl] 8.6]} { proc EResult {a b} { return $b } } else { proc EResult {a b} { return $a } } #----------------------------------------------------------------------- # cget test cget-1.1 {unknown option name} -body { hook cget -nonesuch } -returnCodes { error } -result {unknown option "-nonesuch"} test cget-1.2 {retrieve option value} -body { hook cget -errorcommand } -result {} #----------------------------------------------------------------------- # configure test configure-1.1 {unknown option name} -body { hook configure -nonesuch } -returnCodes { error } -result {unknown option "-nonesuch"} test configure-1.2 {missing option value} -body { hook configure -errorcommand } -returnCodes { error } -result {value for "-errorcommand" missing} test configure-2.1 {set values} -body { hook configure -errorcommand foo -tracecommand bar list [hook cget -errorcommand] [hook cget -tracecommand] } -cleanup { hook configure -errorcommand {} -tracecommand {} } -result {foo bar} #----------------------------------------------------------------------- # bind test bind-1.1 {too many arguments} -body { hook bind a b c d e } -returnCodes { error } -result "wrong # args: should be \"hook bind ?subject? ?hook? ?observer? ?binding?\"" test bind-2.1 {bindings can be made} -body { hook bind S1

O1 {B1 arg1 arg2} hook bind S1

O1 } -cleanup { cleanup } -result {B1 arg1 arg2} test bind-2.2 {bindings can be deleted} -body { hook bind S1

O1 {B1 arg1 arg2} hook bind S1

O1 {} hook bind S1

O1 } -cleanup { cleanup } -result {} test bind-3.1 {bound observers can be queried} -body { hook bind S1

O1 B1 hook bind S1

O2 B2 hook bind S2

O2 B3 set a [hook bind S1

] set b [hook bind S2

] set c [hook bind S2

] list $a $b $c } -cleanup { cleanup } -result {{O1 O2} O2 {}} test bind-3.2 {bound hooks can be queried} -body { hook bind S1

O1 B1 hook bind S1

O2 B2 hook bind S2

O2 B3 set a [hook bind S1] set b [hook bind S2] set c [hook bind S3] list $a $b $c } -cleanup { cleanup } -result {{

}

{}} test bind-3.3 {bound subjects can be queried} -body { hook bind S1

O1 B1 hook bind S1

O2 B2 hook bind S2

O2 B3 hook bind } -cleanup { cleanup } -result {S1 S2} test bind-3.4 {deleted bindings can no longer be queried} -body { hook bind S1

O1 B1 hook bind S1

O2 B2 hook bind S2

O2 B3 hook bind S1

O2 {} set a [hook bind S1

] set b [hook bind S2

] set c [hook bind S2

] list $a $b $c } -cleanup { cleanup } -result {O1 O2 {}} test bind-4.1 {auto-generated observer is returned} -body { hook bind S1

"" {B1 arg1 arg2} } -cleanup { cleanup } -result {::hook::ob1} test bind-4.2 {auto-generated observer is a real observer} -body { set ob [hook bind S1

"" {B1 arg1 arg2}] hook bind S1

$ob } -cleanup { cleanup } -result {B1 arg1 arg2} test bind-4.3 {successive calls get distinct observers} -body { set a [hook bind S1

"" {B1 arg1 arg2}] set b [hook bind S1

"" {B2 arg1 arg2}] list $a $b } -cleanup { cleanup } -result {::hook::ob1 ::hook::ob2} test bind-5.1 {binding deleted during hook call is not called} -body { # If a subject/hook is called, and if a binding deletes some # other binding to that same subject/hook, and if the second binding # has not yet been called, it should not be called. hook bind S1

O1 {hook bind S1

O2 ""} TestBind S1

O2 TestBind S1

O3 hook call S1

# Should see O3 but not O2. GetCalls } -cleanup { cleanup } -result {{S1

O3 {}}} test bind-5.2 {binding revised during hook call is called} -body { # If a subject/hook is called, and if a binding changes some # other observer's binding to that same subject/hook, and if the # other observer's binding has not yet been called, it is the # changed binding that will be called. hook bind S1

O1 {TestBind S1

O2} hook bind S1

O2 {error "Rebind Failed"} hook call S1

# Should see O2 in result, instead of getting "Rebind Failed" error. GetCalls } -cleanup { cleanup } -result {{S1

O2 {}}} test bind-5.3 {binding added during hook call is not called} -body { # If a subject/hook is called, and a binding adds a new binding # for a new observer for this same subject/hook, the new binding # will not be called this time around. hook bind S1

O1 {TestBind S1

O3} TestBind S1

O2 hook call S1

# Should see O2 in result, but not O3 GetCalls } -cleanup { cleanup } -result {{S1

O2 {}}} #----------------------------------------------------------------------- # forget test forget-1.1 {can forget safely when not yet initialized} -body { hook forget NONESUCH } -result {} test forget-1.2 {can forget unbound entity safely} -body { hook bind S1

O1 B1 hook forget NONESUCH hook bind S1

O1 } -cleanup { cleanup } -result {B1} test forget-1.3 {can forget subject} -body { hook bind S1

O1 B1 hook bind S2

O2 B2 hook bind S3

O3 B3 hook forget S2 hook bind } -cleanup { cleanup } -result {S1 S3} test forget-1.4 {can forget subject} -body { hook bind S1

O1 B1 hook bind S2

O2 B2 hook bind S3

O3 B3 hook forget O2 hook bind S2

} -cleanup { cleanup } -result {} test forget-2.1 {observer forgotten during hook call is not called} -body { # If an observer has a binding to a particular subject/hook, and if # in a call to that subject/hook the observer is forgotten, and # if that observer's binding has not yet been called, it should not # be called. hook bind S1

O1 {hook forget O2} TestBind S1

O2 TestBind S1

O3 hook call S1

# Should get O3 but not O2 GetCalls } -cleanup { cleanup } -result {{S1

O3 {}}} test forget-2.2 {subject forgotten during hook call, no more calls} -body { # If a subject/hook is called, and some binding forgets the subject, # no uncalled bindings for that subject/hook should be called. TestBind S1

O1 hook bind S1

O2 {hook forget S1} TestBind S1

O3 hook call S1

# Should get O1 but not O3 GetCalls } -cleanup { cleanup } -result {{S1

O1 {}}} #----------------------------------------------------------------------- # call test call-1.1 {can call safely before anything is bound} -body { hook call S1

} -result {} test call-1.2 {can call safely when hook isn't bound} -body { hook bind S1

O1 B1 hook call S2

} -cleanup { cleanup } -result {} test call-1.3 {bindings are executed} -body { TestBind S1

O1 hook call S1

GetCalls } -cleanup { cleanup } -result {{S1

O1 {}}} test call-1.4 {multiple bindings are executed} -body { TestBind S1

O1 TestBind S1

O2 hook call S1

GetCalls } -cleanup { cleanup } -result {{S1

O1 {}} {S1

O2 {}}} test call-1.5 {only relevant bindings are executed} -body { TestBind S1

O1 TestBind S2

O2 hook call S1

GetCalls } -cleanup { cleanup } -result {{S1

O1 {}}} test call-2.1 {errors propagate normally} -body { hook bind S1

O1 {error "Simulated Error"} hook call S1

} -returnCodes { error } -cleanup { cleanup } -result {Simulated Error} test call-2.2 {other exceptions propagate normally} -body { hook bind S1

O1 {return -code break "Simulated Break"} hook call S1

} -returnCodes { break } -cleanup { cleanup } -result {Simulated Break} #----------------------------------------------------------------------- # -errorcommand test errorerror-1.1 {error with -errorcommand {}} -body { hook bind S1

O1 {error "simulated error"} hook call S1

} -returnCodes { error } -cleanup { cleanup } -result {simulated error} test errorcommand-1.2 {error with -errorcommand set} -body { hook configure -errorcommand ErrorCommand hook bind S1

O1 {error "simulated error"} hook call S1

GetError } -cleanup { cleanup } -result [EResult \ {{{S1

{} O1} {simulated error} {-code 1 -level 0 -errorcode NONE}}} \ {{{S1

{} O1} {simulated error} {-code 1 -level 0 -errorstack {INNER {error {simulated error}} UP 1 CALL {::hook::call S1

}} -errorcode NONE}}}] test errorcommand-1.3 {handled errors don't break sequence of calls} -body { hook configure -errorcommand ErrorCommand TestBind S1

O1 hook bind S1

O2 {error "simulated error"} TestBind S1

O3 hook call S1

list [GetCalls] [GetError] } -cleanup { cleanup } -result [EResult \ {{{S1

O1 {}} {S1

O3 {}}} {{{S1

{} O2} {simulated error} {-code 1 -level 0 -errorcode NONE}}}} \ {{{S1

O1 {}} {S1

O3 {}}} {{{S1

{} O2} {simulated error} {-code 1 -level 0 -errorstack {INNER {error {simulated error}} UP 1 CALL {::hook::call S1

}} -errorcode NONE}}}}] test errorcommand-1.4 {-errorcommand handles other exceptions} -body { hook configure -errorcommand ErrorCommand hook bind S1

O1 {return -code break "simulated break"} hook call S1

GetError } -cleanup { cleanup } -result {{{S1

{} O1} {simulated break} {-code 3 -level 1}}} #----------------------------------------------------------------------- # -tracecommand test tracecommand-1.1 {-tracecommand is called} -body { TestBind S1

O1 TestBind S1

O2 TestBind S2

O2 hook configure -tracecommand TraceCommand hook call S1

hook call S2

hook call S3

GetTrace } -cleanup { cleanup } -result {{S1

{} {O1 O2}} {S2

{} O2} {S3

{} {}}} #----------------------------------------------------------------------- # Clean up and finish ::tcltest::cleanupTeststcllib-1.15/modules/hook/license.terms0000644000175000017500000000413712077663116017353 0ustar sergeisergeiThis software is copyrighted by William H. Duquette. 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. GOVERNMENT USE: If you are acquiring this software on behalf of the U.S. government, the Government shall have only "Restricted Rights" in the software and related documentation as defined in the Federal Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you are acquiring the software on behalf of the Department of Defense, the software shall be classified as "Commercial Computer Software" and the Government shall have only "Restricted Rights" as defined in Clause 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the authors grant the U.S. Government and others acting in its behalf permission to use and distribute the software in accordance with the terms specified in this license. tcllib-1.15/modules/math/0000755000175000017500000000000012104363635014633 5ustar sergeisergeitcllib-1.15/modules/math/TODO0000755000175000017500000000122312077663116015332 0ustar sergeisergeiThis file records outstanding actions for the math module dd. 26 october 2005, Arjen Markus qcomplex.test: extend the tests for cos/sin .. to include non-real results. dd. 28 september 2005, Arjen Markus optimize.tcl: linear programming algorithm ignores certain constraints (of type x > 0). Needs to be fixed dd. 22 june 2004, Arjen Markus interpolate.man: add examples interpolate.tcl: more consistency in the calling convention checks on arguments (add tests for them) optimize.man: example of a parametrized function (also a test case!) optimize.tcl: provide an alternative for maximum tcllib-1.15/modules/math/calculus.man0000755000175000017500000003061712077663116017163 0ustar sergeisergei[manpage_begin math::calculus n 0.7.1] [copyright {2002,2003,2004 Arjen Markus}] [moddesc {Tcl Math Library}] [titledesc {Integration and ordinary differential equations}] [category Mathematics] [require Tcl 8.4] [require math::calculus 0.7.1] [description] [para] This package implements several simple mathematical algorithms: [list_begin itemized] [item] The integration of a function over an interval [item] The numerical integration of a system of ordinary differential equations. [item] Estimating the root(s) of an equation of one variable. [list_end] [para] The package is fully implemented in Tcl. No particular attention has been paid to the accuracy of the calculations. Instead, well-known algorithms have been used in a straightforward manner. [para] This document describes the procedures and explains their usage. [section "PROCEDURES"] This package defines the following public procedures: [list_begin definitions] [call [cmd ::math::calculus::integral] [arg begin] [arg end] [arg nosteps] [arg func]] Determine the integral of the given function using the Simpson rule. The interval for the integration is [lb][arg begin], [arg end][rb]. The remaining arguments are: [list_begin definitions] [def [arg nosteps]] Number of steps in which the interval is divided. [def [arg func]] Function to be integrated. It should take one single argument. [list_end] [para] [call [cmd ::math::calculus::integralExpr] [arg begin] [arg end] [arg nosteps] [arg expression]] Similar to the previous proc, this one determines the integral of the given [arg expression] using the Simpson rule. The interval for the integration is [lb][arg begin], [arg end][rb]. The remaining arguments are: [list_begin definitions] [def [arg nosteps]] Number of steps in which the interval is divided. [def [arg expression]] Expression to be integrated. It should use the variable "x" as the only variable (the "integrate") [list_end] [para] [call [cmd ::math::calculus::integral2D] [arg xinterval] [arg yinterval] [arg func]] [call [cmd ::math::calculus::integral2D_accurate] [arg xinterval] [arg yinterval] [arg func]] The commands [cmd integral2D] and [cmd integral2D_accurate] calculate the integral of a function of two variables over the rectangle given by the first two arguments, each a list of three items, the start and stop interval for the variable and the number of steps. [para] The command [cmd integral2D] evaluates the function at the centre of each rectangle, whereas the command [cmd integral2D_accurate] uses a four-point quadrature formula. This results in an exact integration of polynomials of third degree or less. [para] The function must take two arguments and return the function value. [call [cmd ::math::calculus::integral3D] [arg xinterval] [arg yinterval] [arg zinterval] [arg func]] [call [cmd ::math::calculus::integral3D_accurate] [arg xinterval] [arg yinterval] [arg zinterval] [arg func]] The commands [cmd integral3D] and [cmd integral3D_accurate] are the three-dimensional equivalent of [cmd integral2D] and [cmd integral3D_accurate]. The function [emph func] takes three arguments and is integrated over the block in 3D space given by three intervals. [call [cmd ::math::calculus::eulerStep] [arg t] [arg tstep] [arg xvec] [arg func]] Set a single step in the numerical integration of a system of differential equations. The method used is Euler's. [list_begin definitions] [def [arg t]] Value of the independent variable (typically time) at the beginning of the step. [def [arg tstep]] Step size for the independent variable. [def [arg xvec]] List (vector) of dependent values [def [arg func]] Function of t and the dependent values, returning a list of the derivatives of the dependent values. (The lengths of xvec and the return value of "func" must match). [list_end] [para] [call [cmd ::math::calculus::heunStep] [arg t] [arg tstep] [arg xvec] [arg func]] Set a single step in the numerical integration of a system of differential equations. The method used is Heun's. [list_begin definitions] [def [arg t]] Value of the independent variable (typically time) at the beginning of the step. [def [arg tstep]] Step size for the independent variable. [def [arg xvec]] List (vector) of dependent values [def [arg func]] Function of t and the dependent values, returning a list of the derivatives of the dependent values. (The lengths of xvec and the return value of "func" must match). [list_end] [para] [call [cmd ::math::calculus::rungeKuttaStep] [arg t] [arg tstep] [arg xvec] [arg func]] Set a single step in the numerical integration of a system of differential equations. The method used is Runge-Kutta 4th order. [list_begin definitions] [def [arg t]] Value of the independent variable (typically time) at the beginning of the step. [def [arg tstep]] Step size for the independent variable. [def [arg xvec]] List (vector) of dependent values [def [arg func]] Function of t and the dependent values, returning a list of the derivatives of the dependent values. (The lengths of xvec and the return value of "func" must match). [list_end] [para] [call [cmd ::math::calculus::boundaryValueSecondOrder] [arg coeff_func] [arg force_func] [arg leftbnd] [arg rightbnd] [arg nostep]] Solve a second order linear differential equation with boundary values at two sides. The equation has to be of the form (the "conservative" form): [example_begin] d dy d -- A(x)-- + -- B(x)y + C(x)y = D(x) dx dx dx [example_end] Ordinarily, such an equation would be written as: [example_begin] d2y dy a(x)--- + b(x)-- + c(x) y = D(x) dx2 dx [example_end] The first form is easier to discretise (by integrating over a finite volume) than the second form. The relation between the two forms is fairly straightforward: [example_begin] A(x) = a(x) B(x) = b(x) - a'(x) C(x) = c(x) - B'(x) = c(x) - b'(x) + a''(x) [example_end] Because of the differentiation, however, it is much easier to ask the user to provide the functions A, B and C directly. [list_begin definitions] [def [arg coeff_func]] Procedure returning the three coefficients (A, B, C) of the equation, taking as its one argument the x-coordinate. [def [arg force_func]] Procedure returning the right-hand side (D) as a function of the x-coordinate. [def [arg leftbnd]] A list of two values: the x-coordinate of the left boundary and the value at that boundary. [def [arg rightbnd]] A list of two values: the x-coordinate of the right boundary and the value at that boundary. [def [arg nostep]] Number of steps by which to discretise the interval. The procedure returns a list of x-coordinates and the approximated values of the solution. [list_end] [para] [call [cmd ::math::calculus::solveTriDiagonal] [arg acoeff] [arg bcoeff] [arg ccoeff] [arg dvalue]] Solve a system of linear equations Ax = b with A a tridiagonal matrix. Returns the solution as a list. [list_begin definitions] [def [arg acoeff]] List of values on the lower diagonal [def [arg bcoeff]] List of values on the main diagonal [def [arg ccoeff]] List of values on the upper diagonal [def [arg dvalue]] List of values on the righthand-side [list_end] [para] [call [cmd ::math::calculus::newtonRaphson] [arg func] [arg deriv] [arg initval]] Determine the root of an equation given by [example_begin] func(x) = 0 [example_end] using the method of Newton-Raphson. The procedure takes the following arguments: [list_begin definitions] [def [arg func]] Procedure that returns the value the function at x [def [arg deriv]] Procedure that returns the derivative of the function at x [def [arg initval]] Initial value for x [list_end] [para] [call [cmd ::math::calculus::newtonRaphsonParameters] [arg maxiter] [arg tolerance]] Set the numerical parameters for the Newton-Raphson method: [list_begin definitions] [def [arg maxiter]] Maximum number of iteration steps (defaults to 20) [def [arg tolerance]] Relative precision (defaults to 0.001) [list_end] [call [cmd ::math::calculus::regula_falsi] [arg f] [arg xb] [arg xe] [arg eps]] Return an estimate of the zero or one of the zeros of the function contained in the interval [lb]xb,xe[rb]. The error in this estimate is of the order of eps*abs(xe-xb), the actual error may be slightly larger. [para] The method used is the so-called [emph {regula falsi}] or [emph "false position"] method. It is a straightforward implementation. The method is robust, but requires that the interval brackets a zero or at least an uneven number of zeros, so that the value of the function at the start has a different sign than the value at the end. [para] In contrast to Newton-Raphson there is no need for the computation of the function's derivative. [list_begin arguments] [arg_def command f] Name of the command that evaluates the function for which the zero is to be returned [arg_def float xb] Start of the interval in which the zero is supposed to lie [arg_def float xe] End of the interval [arg_def float eps] Relative allowed error (defaults to 1.0e-4) [list_end] [list_end] [para] [emph Notes:] [para] Several of the above procedures take the [emph names] of procedures as arguments. To avoid problems with the [emph visibility] of these procedures, the fully-qualified name of these procedures is determined inside the calculus routines. For the user this has only one consequence: the named procedure must be visible in the calling procedure. For instance: [example_begin] namespace eval ::mySpace { namespace export calcfunc proc calcfunc { x } { return $x } } # # Use a fully-qualified name # namespace eval ::myCalc { proc detIntegral { begin end } { return [lb]integral $begin $end 100 ::mySpace::calcfunc[rb] } } # # Import the name # namespace eval ::myCalc { namespace import ::mySpace::calcfunc proc detIntegral { begin end } { return [lb]integral $begin $end 100 calcfunc[rb] } } [example_end] [para] Enhancements for the second-order boundary value problem: [list_begin itemized] [item] Other types of boundary conditions (zero gradient, zero flux) [item] Other schematisation of the first-order term (now central differences are used, but upstream differences might be useful too). [list_end] [section EXAMPLES] Let us take a few simple examples: [para] Integrate x over the interval [lb]0,100[rb] (20 steps): [example_begin] proc linear_func { x } { return $x } puts "Integral: [lb]::math::calculus::integral 0 100 20 linear_func[rb]" [example_end] For simple functions, the alternative could be: [example_begin] puts "Integral: [lb]::math::calculus::integralExpr 0 100 20 {$x}[rb]" [example_end] Do not forget the braces! [para] The differential equation for a dampened oscillator: [para] [example_begin] x'' + rx' + wx = 0 [example_end] [para] can be split into a system of first-order equations: [para] [example_begin] x' = y y' = -ry - wx [example_end] [para] Then this system can be solved with code like this: [para] [example_begin] proc dampened_oscillator { t xvec } { set x [lb]lindex $xvec 0[rb] set x1 [lb]lindex $xvec 1[rb] return [lb]list $x1 [lb]expr {-$x1-$x}[rb][rb] } set xvec { 1.0 0.0 } set t 0.0 set tstep 0.1 for { set i 0 } { $i < 20 } { incr i } { set result [lb]::math::calculus::eulerStep $t $tstep $xvec dampened_oscillator[rb] puts "Result ($t): $result" set t [lb]expr {$t+$tstep}[rb] set xvec $result } [example_end] [para] Suppose we have the boundary value problem: [para] [example_begin] Dy'' + ky = 0 x = 0: y = 1 x = L: y = 0 [example_end] [para] This boundary value problem could originate from the diffusion of a decaying substance. [para] It can be solved with the following fragment: [para] [example_begin] proc coeffs { x } { return [lb]list $::Diff 0.0 $::decay[rb] } proc force { x } { return 0.0 } set Diff 1.0e-2 set decay 0.0001 set length 100.0 set y [lb]::math::calculus::boundaryValueSecondOrder \ coeffs force {0.0 1.0} [lb]list $length 0.0[rb] 100[rb] [example_end] [see_also romberg] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph {math :: calculus}] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords math calculus integration "differential equations" roots] [manpage_end] tcllib-1.15/modules/math/calculus.testscript0000755000175000017500000000424412077663116020611 0ustar sergeisergei# calculus.test -- # Test cases for the Calculus package # source calculus.tcl # # Simple test functions - exact result predictable! # proc const_func { x } { return 1 } proc linear_func { x } { return $x } proc downward_linear { x } { return [expr {100.0-$x}] } proc downward_linear { x } { return [expr {100.0-$x}] } # # Test the Integral proc # puts "[::Calculus::Integral 0 100 100 const_func] - expected: 100" puts "[::Calculus::Integral 0 100 100 linear_func] - expected: 5000" puts "[::Calculus::Integral 0 100 100 downward_linear] - expected: 5000" puts "[::Calculus::Integral 0 100 100 downward_linear] - expected: 5000" puts "[::Calculus::IntegralExpr 0 100 100 {100.0-$x}] - expected: 5000" proc const_func2d { x y } { return 1 } proc linear_func2d { x y } { return $x } puts "[::Calculus::Integral2D { 0 100 10 } { 0 50 1 } const_func2d] - \ expected 5000" puts "[::Calculus::Integral2D { 0 100 1 } { 0 50 1 } const_func2d] - \ expected 5000" puts "[::Calculus::Integral2D { 0 100 10 } { 0 50 1 } linear_func2d] - \ expected 250000" # xvec should one long! proc const_func { t xvec } { return 1.0 } # xvec should be two long! proc dampened_oscillator { t xvec } { set x [lindex $xvec 0] set x1 [lindex $xvec 1] return [list $x1 [expr {-$x1-$x}]] } foreach method {EulerStep HeunStep} { puts "Method: $method" set xvec 0.0 set t 0.0 set tstep 1.0 for { set i 0 } { $i < 10 } { incr i } { set result [::Calculus::$method $t $tstep $xvec const_func] puts "Result ($t): $result" set t [expr {$t+$tstep}] set xvec $result } set xvec { 1.0 0.0 } set t 0.0 set tstep 0.1 for { set i 0 } { $i < 20 } { incr i } { set result [::Calculus::$method $t $tstep $xvec dampened_oscillator] puts "Result ($t): $result" set t [expr {$t+$tstep}] set xvec $result } } # # Boundary value problems: # use simple functions # proc coeffs { x } { return {1.0 0.0 0.0} } proc forces { x } { return 0.0 } puts [::Calculus::BoundaryValueSecondOrder coeffs forces {0.0 1.0} {100.0 0.0} 10] puts [::Calculus::BoundaryValueSecondOrder coeffs forces {0.0 0.0} {100.0 1.0} 10] tcllib-1.15/modules/math/plotstat.tcl0000755000175000017500000001744312077663116017233 0ustar sergeisergei# plotstat.tcl -- # # Set of very simple drawing routines, belonging to the statistics # package # # version 0.1: initial implementation, january 2003 namespace eval ::math::statistics {} # plot-scale # Set the scale for a plot in the given canvas # # Arguments: # canvas Canvas widget to use # xmin Minimum x value # xmax Maximum x value # ymin Minimum y value # ymax Maximum y value # # Result: # None # # Side effect: # Array elements set # proc ::math::statistics::plot-scale { canvas xmin xmax ymin ymax } { variable plot if { $xmin == $xmax } { set xmax [expr {1.1*$xmin+1.0}] } if { $ymin == $ymax } { set ymax [expr {1.1*$ymin+1.0}] } set plot($canvas,xmin) $xmin set plot($canvas,xmax) $xmax set plot($canvas,ymin) $ymin set plot($canvas,ymax) $ymax set cwidth [$canvas cget -width] set cheight [$canvas cget -height] set cx 20 set cy 20 set cx2 [expr {$cwidth-$cx}] set cy2 [expr {$cheight-$cy}] set plot($canvas,cx) $cx set plot($canvas,cy) $cy set plot($canvas,dx) [expr {($cwidth-2*$cx)/double($xmax-$xmin)}] set plot($canvas,dy) [expr {($cheight-2*$cy)/double($ymax-$ymin)}] set plot($canvas,cx2) $cx2 set plot($canvas,cy2) $cy2 $canvas create line $cx $cy $cx $cy2 $cx2 $cy2 -tag axes } # plot-xydata # Create a simple XY plot in the given canvas (collection of dots) # # Arguments: # canvas Canvas widget to use # xdata Series of independent data # ydata Series of dependent data # tag Tag to give to the plotted data (defaults to xyplot) # # Result: # None # # Side effect: # Simple xy graph in the canvas # # Note: # The tag can be used to manipulate the xy graph # proc ::math::statistics::plot-xydata { canvas xdata ydata {tag xyplot} } { PlotXY $canvas points $tag $xdata $ydata } # plot-xyline # Create a simple XY plot in the given canvas (continuous line) # # Arguments: # canvas Canvas widget to use # xdata Series of independent data # ydata Series of dependent data # tag Tag to give to the plotted data (defaults to xyplot) # # Result: # None # # Side effect: # Simple xy graph in the canvas # # Note: # The tag can be used to manipulate the xy graph # proc ::math::statistics::plot-xyline { canvas xdata ydata {tag xyplot} } { PlotXY $canvas line $tag $xdata $ydata } # plot-tdata # Create a simple XY plot in the given canvas (the index in the list # is the horizontal coordinate; points) # # Arguments: # canvas Canvas widget to use # tdata Series of dependent data # tag Tag to give to the plotted data (defaults to xyplot) # # Result: # None # # Side effect: # Simple xy graph in the canvas # # Note: # The tag can be used to manipulate the xy graph # proc ::math::statistics::plot-tdata { canvas tdata {tag xyplot} } { PlotXY $canvas points $tag {} $tdata } # plot-tline # Create a simple XY plot in the given canvas (the index in the list # is the horizontal coordinate; line) # # Arguments: # canvas Canvas widget to use # tdata Series of dependent data # tag Tag to give to the plotted data (defaults to xyplot) # # Result: # None # # Side effect: # Simple xy graph in the canvas # # Note: # The tag can be used to manipulate the xy graph # proc ::math::statistics::plot-tline { canvas tdata {tag xyplot} } { PlotXY $canvas line $tag {} $tdata } # PlotXY # Create a simple XY plot (points or lines) in the given canvas # # Arguments: # canvas Canvas widget to use # type Type: points or line # tag Tag to give to the plotted data # xdata Series of independent data (if empty: index used instead) # ydata Series of dependent data # # Result: # None # # Side effect: # Simple xy graph in the canvas # # Note: # This is the actual routine # proc ::math::statistics::PlotXY { canvas type tag xdata ydata } { variable plot if { ![info exists plot($canvas,xmin)] } { return -code error -errorcode "No scaling given for canvas $canvas" } set xmin $plot($canvas,xmin) set xmax $plot($canvas,xmax) set ymin $plot($canvas,ymin) set ymax $plot($canvas,ymax) set dx $plot($canvas,dx) set dy $plot($canvas,dy) set cx $plot($canvas,cx) set cy $plot($canvas,cy) set cx2 $plot($canvas,cx2) set cy2 $plot($canvas,cy2) set plotpoints [expr {$type == "points"}] set xpresent [expr {[llength $xdata] > 0}] set idx 0 set coords {} foreach y $ydata { if { $xpresent } { set x [lindex $xdata $idx] } else { set x $idx } incr idx if { $x == {} } continue if { $y == {} } continue if { $x > $xmax } continue if { $x < $xmin } continue if { $y > $ymax } continue if { $y < $ymin } continue if { $plotpoints } { set xc [expr {$cx+$dx*($x-$xmin)-2}] set yc [expr {$cy2-$dy*($y-$ymin)-2}] set xc2 [expr {$xc+4}] set yc2 [expr {$yc+4}] $canvas create oval $xc $yc $xc2 $yc2 -tag $tag -fill black } else { set xc [expr {$cx+$dx*($x-$xmin)}] set yc [expr {$cy2-$dy*($y-$ymin)}] lappend coords $xc $yc } } if { ! $plotpoints } { $canvas create line $coords -tag $tag } } # plot-histogram # Create a simple histogram in the given canvas # # Arguments: # canvas Canvas widget to use # counts Series of bucket counts # limits Series of upper limits for the buckets # tag Tag to give to the plotted data (defaults to xyplot) # # Result: # None # # Side effect: # Simple histogram in the canvas # # Note: # The number of limits determines how many bars are drawn, # the number of counts that is expected is one larger. The # lower and upper limits of the first and last bucket are # taken to be equal to the scale's extremes # proc ::math::statistics::plot-histogram { canvas counts limits {tag xyplot} } { variable plot if { ![info exists plot($canvas,xmin)] } { return -code error -errorcode DATA "No scaling given for canvas $canvas" } if { ([llength $counts]-[llength $limits]) != 1 } { return -code error -errorcode ARG \ "Number of counts does not correspond to number of limits" } set xmin $plot($canvas,xmin) set xmax $plot($canvas,xmax) set ymin $plot($canvas,ymin) set ymax $plot($canvas,ymax) set dx $plot($canvas,dx) set dy $plot($canvas,dy) set cx $plot($canvas,cx) set cy $plot($canvas,cy) set cx2 $plot($canvas,cx2) set cy2 $plot($canvas,cy2) # # Construct a sufficiently long list of x-coordinates # set xdata [concat $xmin $limits $xmax] set idx 0 foreach x $xdata y $counts { incr idx if { $y == {} } continue set x1 $x if { $x < $xmin } { set x1 $xmin } if { $x > $xmax } { set x1 $xmax } if { $y > $ymax } { set y $ymax } if { $y < $ymin } { set y $ymin } set x2 [lindex $xdata $idx] if { $x2 < $xmin } { set x2 $xmin } if { $x2 > $xmax } { set x2 $xmax } set xc [expr {$cx+$dx*($x1-$xmin)}] set xc2 [expr {$cx+$dx*($x2-$xmin)}] set yc [expr {$cy2-$dy*($y-$ymin)}] set yc2 $cy2 $canvas create rectangle $xc $yc $xc2 $yc2 -tag $tag -fill blue } } # # Simple test code # if { [info exists ::argv0] && ([file tail [info script]] == [file tail $::argv0]) } { set xdata {1 2 3 4 5 10 20 6 7 8 1 3 4 5 6 7} set ydata {2 3 4 5 6 10 20 7 8 1 3 4 5 6 7 1} canvas .c canvas .c2 pack .c .c2 -side top -fill both ::math::statistics::plot-scale .c 0 10 0 10 ::math::statistics::plot-scale .c2 0 20 0 10 ::math::statistics::plot-xydata .c $xdata $ydata ::math::statistics::plot-xyline .c $xdata $ydata ::math::statistics::plot-histogram .c2 {1 3 2 0.1 4 2} {-1 3 10 11 23} ::math::statistics::plot-tdata .c2 $xdata ::math::statistics::plot-tline .c2 $xdata } tcllib-1.15/modules/math/fuzzy.man0000755000175000017500000001112612077663116016531 0ustar sergeisergei[manpage_begin math::fuzzy n 0.2] [moddesc {Tcl Math Library}] [titledesc {Fuzzy comparison of floating-point numbers}] [category Mathematics] [require Tcl [opt 8.3]] [require math::fuzzy [opt 0.2]] [description] [para] The package Fuzzy is meant to solve common problems with floating-point numbers in a systematic way: [list_begin itemized] [item] Comparing two numbers that are "supposed" to be identical, like 1.0 and 2.1/(1.2+0.9) is not guaranteed to give the intuitive result. [item] Rounding a number that is halfway two integer numbers can cause strange errors, like int(100.0*2.8) != 28 but 27 [list_end] [para] The Fuzzy package is meant to help sorting out this type of problems by defining "fuzzy" comparison procedures for floating-point numbers. It does so by allowing for a small margin that is determined automatically - the margin is three times the "epsilon" value, that is three times the smallest number [emph eps] such that 1.0 and 1.0+$eps canbe distinguished. In Tcl, which uses double precision floating-point numbers, this is typically 1.1e-16. [section "PROCEDURES"] Effectively the package provides the following procedures: [list_begin definitions] [call [cmd ::math::fuzzy::teq] [arg value1] [arg value2]] Compares two floating-point numbers and returns 1 if their values fall within a small range. Otherwise it returns 0. [call [cmd ::math::fuzzy::tne] [arg value1] [arg value2]] Returns the negation, that is, if the difference is larger than the margin, it returns 1. [call [cmd ::math::fuzzy::tge] [arg value1] [arg value2]] Compares two floating-point numbers and returns 1 if their values either fall within a small range or if the first number is larger than the second. Otherwise it returns 0. [call [cmd ::math::fuzzy::tle] [arg value1] [arg value2]] Returns 1 if the two numbers are equal according to [lb]teq[rb] or if the first is smaller than the second. [call [cmd ::math::fuzzy::tlt] [arg value1] [arg value2]] Returns the opposite of [lb]tge[rb]. [call [cmd ::math::fuzzy::tgt] [arg value1] [arg value2]] Returns the opposite of [lb]tle[rb]. [call [cmd ::math::fuzzy::tfloor] [arg value]] Returns the integer number that is lower or equal to the given floating-point number, within a well-defined tolerance. [call [cmd ::math::fuzzy::tceil] [arg value]] Returns the integer number that is greater or equal to the given floating-point number, within a well-defined tolerance. [call [cmd ::math::fuzzy::tround] [arg value]] Rounds the floating-point number off. [call [cmd ::math::fuzzy::troundn] [arg value] [arg ndigits]] Rounds the floating-point number off to the specified number of decimals (Pro memorie). [list_end] Usage: [example_begin] if { [lb]teq $x $y[rb] } { puts "x == y" } if { [lb]tne $x $y[rb] } { puts "x != y" } if { [lb]tge $x $y[rb] } { puts "x >= y" } if { [lb]tgt $x $y[rb] } { puts "x > y" } if { [lb]tlt $x $y[rb] } { puts "x < y" } if { [lb]tle $x $y[rb] } { puts "x <= y" } set fx [lb]tfloor $x[rb] set fc [lb]tceil $x[rb] set rounded [lb]tround $x[rb] set roundn [lb]troundn $x $nodigits[rb] [example_end] [section {TEST CASES}] The problems that can occur with floating-point numbers are illustrated by the test cases in the file "fuzzy.test": [list_begin itemized] [item] Several test case use the ordinary comparisons, and they fail invariably to produce understandable results [item] One test case uses [lb]expr[rb] without braces ({ and }). It too fails. [list_end] The conclusion from this is that any expression should be surrounded by braces, because otherwise very awkward things can happen if you need accuracy. Furthermore, accuracy and understandable results are enhanced by using these "tolerant" or fuzzy comparisons. [para] Note that besides the Tcl-only package, there is also a C-based version. [section REFERENCES] Original implementation in Fortran by dr. H.D. Knoble (Penn State University). [para] P. E. Hagerty, "More on Fuzzy Floor and Ceiling," APL QUOTE QUAD 8(4):20-24, June 1978. Note that TFLOOR=FL5 took five years of refereed evolution (publication). [para] L. M. Breed, "Definitions for Fuzzy Floor and Ceiling", APL QUOTE QUAD 8(3):16-23, March 1978. [para] D. Knuth, Art of Computer Programming, Vol. 1, Problem 1.2.4-5. [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph {math :: fuzzy}] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords math floating-point rounding] [manpage_end] tcllib-1.15/modules/math/linalg.tcl0000755000175000017500000017724712077663116016640 0ustar sergeisergei# linalg.tcl -- # Linear algebra package, based partly on Hume's LA package, # partly on experiments with various representations of # matrices. Also the functionality of the BLAS library has # been taken into account. # # General information: # - The package provides both a high-level general interface and # a lower-level specific interface for various LA functions # and tasks. # - The general procedures perform some checks and then call # the various specific procedures. The general procedures are # aimed at robustness and ease of use. # - The specific procedures do not check anything, they are # designed for speed. Failure to comply to the interface # requirements will presumably lead to [expr] errors. # - Vectors are represented as lists, matrices as lists of # lists, where the rows are the innermost lists: # # / a11 a12 a13 \ # | a21 a22 a23 | == { {a11 a12 a13} {a21 a22 a23} {a31 a32 a33} } # \ a31 a32 a33 / # package require Tcl 8.4 namespace eval ::math::linearalgebra { # Define the namespace namespace export dim shape conforming symmetric namespace export norm norm_one norm_two norm_max normMatrix namespace export dotproduct unitLengthVector normalizeStat namespace export axpy axpy_vect axpy_mat crossproduct namespace export add add_vect add_mat namespace export sub sub_vect sub_mat namespace export scale scale_vect scale_mat matmul transpose namespace export rotate angle choleski namespace export getrow getcol getelem setrow setcol setelem namespace export mkVector mkMatrix mkIdentity mkDiagonal namespace export mkHilbert mkDingdong mkBorder mkFrank namespace export mkMoler mkWilkinsonW+ mkWilkinsonW- namespace export solveGauss solveTriangular namespace export solveGaussBand solveTriangularBand namespace export solvePGauss namespace export determineSVD eigenvectorsSVD namespace export leastSquaresSVD namespace export orthonormalizeColumns orthonormalizeRows namespace export show to_LA from_LA namespace export swaprows swapcols namespace export dger dgetrf mkRandom mkTriangular namespace export det largesteigen } # dim -- # Return the dimension of an object (scalar, vector or matrix) # Arguments: # obj Object like a scalar, vector or matrix # Result: # Dimension: 0 for a scalar, 1 for a vector, 2 for a matrix # proc ::math::linearalgebra::dim { obj } { set shape [shape $obj] if { $shape != 1 } { return [llength [shape $obj]] } else { return 0 } } # shape -- # Return the shape of an object (scalar, vector or matrix) # Arguments: # obj Object like a scalar, vector or matrix # Result: # List of the sizes: 1 for a scalar, number of components # for a vector, number of rows and columns for a matrix # proc ::math::linearalgebra::shape { obj } { set result [llength $obj] if { [llength [lindex $obj 0]] <= 1 } { return $result } else { lappend result [llength [lindex $obj 0]] } return $result } # show -- # Return a string representing the vector or matrix, # for easy printing # Arguments: # obj Object like a scalar, vector or matrix # format Format to be used (defaults to %6.4f) # rowsep Separator for rows (defaults to \n) # colsep Separator for columns (defaults to " ") # Result: # String representing the vector or matrix # proc ::math::linearalgebra::show { obj {format %6.4f} {rowsep \n} {colsep " "} } { set result "" if { [llength [lindex $obj 0]] == 1 } { foreach v $obj { append result "[format $format $v]$rowsep" } } else { foreach row $obj { foreach v $row { append result "[format $format $v]$colsep" } append result $rowsep } } return $result } # conforming -- # Determine if two objects (vector or matrix) are conforming # in shape, rows or for a matrix multiplication # Arguments: # type Type of conforming: shape, rows or matmul # obj1 First object (vector or matrix) # obj2 Second object (vector or matrix) # Result: # 1 if they conform, 0 if not # proc ::math::linearalgebra::conforming { type obj1 obj2 } { set shape1 [shape $obj1] set shape2 [shape $obj2] set result 0 if { $type == "shape" } { set result [expr {[lindex $shape1 0] == [lindex $shape2 0] && [lindex $shape1 1] == [lindex $shape2 1]}] } if { $type == "rows" } { set result [expr {[lindex $shape1 0] == [lindex $shape2 0]}] } if { $type == "matmul" } { set result [expr {[lindex $shape1 1] == [lindex $shape2 0]}] } return $result } # crossproduct -- # Return the "cross product" of two 3D vectors # Arguments: # vect1 First vector # vect2 Second vector # Result: # Cross product # proc ::math::linearalgebra::crossproduct { vect1 vect2 } { if { [llength $vect1] == 3 && [llength $vect2] == 3 } { foreach {v11 v12 v13} $vect1 {v21 v22 v23} $vect2 {break} return [list \ [expr {$v12*$v23 - $v13*$v22}] \ [expr {$v13*$v21 - $v11*$v23}] \ [expr {$v11*$v22 - $v12*$v21}] ] } else { return -code error "Cross-product only defined for 3D vectors" } } # angle -- # Return the "angle" between two vectors (in radians) # Arguments: # vect1 First vector # vect2 Second vector # Result: # Angle between the two vectors # proc ::math::linearalgebra::angle { vect1 vect2 } { set dp [dotproduct $vect1 $vect2] set n1 [norm_two $vect1] set n2 [norm_two $vect2] if { $n1 == 0.0 || $n2 == 0.0 } { return -code error "Angle not defined for null vector" } return [expr {acos($dp/$n1/$n2)}] } # norm -- # Compute the (1-, 2- or Inf-) norm of a vector # Arguments: # vector Vector (list of numbers) # type Either 1, 2 or max/inf to indicate the type of # norm (default: 2, the euclidean norm) # Result: # The (1-, 2- or Inf-) norm of a vector # Level-1 BLAS : # if type = 1, corresponds to DASUM # if type = 2, corresponds to DNRM2 # proc ::math::linearalgebra::norm { vector {type 2} } { if { $type == 2 } { return [norm_two $vector] } if { $type == 1 } { return [norm_one $vector] } if { $type == "max" || $type == "inf" } { return [norm_max $vector] } return -code error "Unknown norm: $type" } # norm_one -- # Compute the 1-norm of a vector # Arguments: # vector Vector # Result: # The 1-norm of a vector # proc ::math::linearalgebra::norm_one { vector } { set sum 0.0 foreach c $vector { set sum [expr {$sum+abs($c)}] } return $sum } # norm_two -- # Compute the 2-norm of a vector (euclidean norm) # Arguments: # vector Vector # Result: # The 2-norm of a vector # Note: # Rely on the function hypot() to make this robust # against overflow and underflow # proc ::math::linearalgebra::norm_two { vector } { set sum 0.0 foreach c $vector { set sum [expr {hypot($c,$sum)}] } return $sum } # norm_max -- # Compute the inf-norm of a vector (maximum of its components) # Arguments: # vector Vector # index, optional if non zero, returns a list made of the maximum # value and the index where that maximum was found. # if zero, returns the maximum value. # Result: # The inf-norm of a vector # Level-1 BLAS : # if index!=0, corresponds to IDAMAX # proc ::math::linearalgebra::norm_max { vector {index 0}} { set max [lindex $vector 0] set imax 0 set i 0 foreach c $vector { if {[expr {abs($c)>$max}]} then { set imax $i set max [expr {abs($c)}] } incr i } if {$index == 0} then { set result $max } else { set result [list $max $imax] } return $result } # normMatrix -- # Compute the (1-, 2- or Inf-) norm of a matrix # Arguments: # matrix Matrix (list of row vectors) # type Either 1, 2 or max/inf to indicate the type of # norm (default: 2, the euclidean norm) # Result: # The (1-, 2- or Inf-) norm of the matrix # proc ::math::linearalgebra::normMatrix { matrix {type 2} } { set v {} foreach row $matrix { lappend v [norm $row $type] } return [norm $v $type] } # symmetric -- # Determine if the matrix is symmetric or not # Arguments: # matrix Matrix (list of row vectors) # eps Tolerance (defaults to 1.0e-8) # Result: # 1 if symmetric (within the tolerance), 0 if not # proc ::math::linearalgebra::symmetric { matrix {eps 1.0e-8} } { set shape [shape $matrix] if { [lindex $shape 0] != [lindex $shape 1] } { return 0 } set norm_org [normMatrix $matrix] set norm_asymm [normMatrix [sub $matrix [transpose $matrix]]] if { $norm_asymm <= $eps*$norm_org } { return 1 } else { return 0 } } # dotproduct -- # Compute the dot product of two vectors # Arguments: # vect1 First vector # vect2 Second vector # Result: # The dot product of the two vectors # Level-1 BLAS : corresponds to DDOT # proc ::math::linearalgebra::dotproduct { vect1 vect2 } { if { [llength $vect1] != [llength $vect2] } { return -code error "Vectors must be of equal length" } set sum 0.0 foreach c1 $vect1 c2 $vect2 { set sum [expr {$sum + $c1*$c2}] } return $sum } # unitLengthVector -- # Normalize a vector so that a length 1 results and return the new vector # Arguments: # vector Vector to be normalized # Result: # A vector of length 1 # proc ::math::linearalgebra::unitLengthVector { vector } { set scale [norm_two $vector] if { $scale == 0.0 } { return -code error "Can not normalize a null-vector" } return [scale [expr {1.0/$scale}] $vector] } # normalizeStat -- # Normalize a matrix or vector in a statistical sense and return the result # Arguments: # mv Matrix or vector to be normalized # Result: # A matrix or vector whose columns are normalised to have a mean of # 0 and a standard deviation of 1. # proc ::math::linearalgebra::normalizeStat { mv } { if { [llength [lindex $mv 0]] > 1 } { set result {} foreach vector [transpose $mv] { lappend result [NormalizeStat_vect $vector] } return [transpose $result] } else { return [NormalizeStat_vect $mv] } } # NormalizeStat_vect -- # Normalize a vector in a statistical sense and return the result # Arguments: # v Vector to be normalized # Result: # A vector whose elements are normalised to have a mean of # 0 and a standard deviation of 1. If all coefficients are equal, # a null-vector is returned. # proc ::math::linearalgebra::NormalizeStat_vect { v } { if { [llength $v] <= 1 } { return -code error "Vector can not be normalised - too few coefficients" } set sum 0.0 set sum2 0.0 set count 0.0 foreach c $v { set sum [expr {$sum + $c}] set sum2 [expr {$sum2 + $c*$c}] set count [expr {$count + 1.0}] } set corr [expr {$sum/$count}] set factor [expr {($sum2-$sum*$sum/$count)/($count-1)}] if { $factor > 0.0 } { set factor [expr {1.0/sqrt($factor)}] } else { set factor 0.0 } set result {} foreach c $v { lappend result [expr {$factor*($c-$corr)}] } return $result } # axpy -- # Compute the sum of a scaled vector/matrix and another # vector/matrix: a*x + y # Arguments: # scale Scale factor (a) for the first vector/matrix # mv1 First vector/matrix (x) # mv2 Second vector/matrix (y) # Result: # The result of a*x+y # Level-1 BLAS : if mv1 is a vector, corresponds to DAXPY # proc ::math::linearalgebra::axpy { scale mv1 mv2 } { if { [llength [lindex $mv1 0]] > 1 } { return [axpy_mat $scale $mv1 $mv2] } else { return [axpy_vect $scale $mv1 $mv2] } } # axpy_vect -- # Compute the sum of a scaled vector and another vector: a*x + y # Arguments: # scale Scale factor (a) for the first vector # vect1 First vector (x) # vect2 Second vector (y) # Result: # The result of a*x+y # Level-1 BLAS : corresponds to DAXPY # proc ::math::linearalgebra::axpy_vect { scale vect1 vect2 } { set result {} foreach c1 $vect1 c2 $vect2 { lappend result [expr {$scale*$c1+$c2}] } return $result } # axpy_mat -- # Compute the sum of a scaled matrix and another matrix: a*x + y # Arguments: # scale Scale factor (a) for the first matrix # mat1 First matrix (x) # mat2 Second matrix (y) # Result: # The result of a*x+y # proc ::math::linearalgebra::axpy_mat { scale mat1 mat2 } { set result {} foreach row1 $mat1 row2 $mat2 { lappend result [axpy_vect $scale $row1 $row2] } return $result } # add -- # Compute the sum of two vectors/matrices # Arguments: # mv1 First vector/matrix (x) # mv2 Second vector/matrix (y) # Result: # The result of x+y # proc ::math::linearalgebra::add { mv1 mv2 } { if { [llength [lindex $mv1 0]] > 1 } { return [add_mat $mv1 $mv2] } else { return [add_vect $mv1 $mv2] } } # add_vect -- # Compute the sum of two vectors # Arguments: # vect1 First vector (x) # vect2 Second vector (y) # Result: # The result of x+y # proc ::math::linearalgebra::add_vect { vect1 vect2 } { set result {} foreach c1 $vect1 c2 $vect2 { lappend result [expr {$c1+$c2}] } return $result } # add_mat -- # Compute the sum of two matrices # Arguments: # mat1 First matrix (x) # mat2 Second matrix (y) # Result: # The result of x+y # proc ::math::linearalgebra::add_mat { mat1 mat2 } { set result {} foreach row1 $mat1 row2 $mat2 { lappend result [add_vect $row1 $row2] } return $result } # sub -- # Compute the difference of two vectors/matrices # Arguments: # mv1 First vector/matrix (x) # mv2 Second vector/matrix (y) # Result: # The result of x-y # proc ::math::linearalgebra::sub { mv1 mv2 } { if { [llength [lindex $mv1 0]] > 0 } { return [sub_mat $mv1 $mv2] } else { return [sub_vect $mv1 $mv2] } } # sub_vect -- # Compute the difference of two vectors # Arguments: # vect1 First vector (x) # vect2 Second vector (y) # Result: # The result of x-y # proc ::math::linearalgebra::sub_vect { vect1 vect2 } { set result {} foreach c1 $vect1 c2 $vect2 { lappend result [expr {$c1-$c2}] } return $result } # sub_mat -- # Compute the difference of two matrices # Arguments: # mat1 First matrix (x) # mat2 Second matrix (y) # Result: # The result of x-y # proc ::math::linearalgebra::sub_mat { mat1 mat2 } { set result {} foreach row1 $mat1 row2 $mat2 { lappend result [sub_vect $row1 $row2] } return $result } # scale -- # Scale a vector or a matrix # Arguments: # scale Scale factor (scalar; a) # mv Vector/matrix (x) # Result: # The result of a*x # Level-1 BLAS : if mv is a vector, corresponds to DSCAL # proc ::math::linearalgebra::scale { scale mv } { if { [llength [lindex $mv 0]] > 1 } { return [scale_mat $scale $mv] } else { return [scale_vect $scale $mv] } } # scale_vect -- # Scale a vector # Arguments: # scale Scale factor to apply (a) # vect Vector to be scaled (x) # Result: # The result of a*x # Level-1 BLAS : corresponds to DSCAL # proc ::math::linearalgebra::scale_vect { scale vect } { set result {} foreach c $vect { lappend result [expr {$scale*$c}] } return $result } # scale_mat -- # Scale a matrix # Arguments: # scale Scale factor to apply # mat Matrix to be scaled # Result: # The result of x+y # proc ::math::linearalgebra::scale_mat { scale mat } { set result {} foreach row $mat { lappend result [scale_vect $scale $row] } return $result } # rotate -- # Apply a planar rotation to two vectors # Arguments: # c Cosine of the angle # s Sine of the angle # vect1 First vector (x) # vect2 Second vector (y) # Result: # A list of two elements: c*x-s*y and s*x+c*y # proc ::math::linearalgebra::rotate { c s vect1 vect2 } { set result1 {} set result2 {} foreach v1 $vect1 v2 $vect2 { lappend result1 [expr {$c*$v1-$s*$v2}] lappend result2 [expr {$s*$v1+$c*$v2}] } return [list $result1 $result2] } # transpose -- # Transpose a matrix # Arguments: # matrix Matrix to be transposed # Result: # The transposed matrix # Note: # The second transpose implementation is faster on large # matrices (100x100 say), there is no significant difference # on small ones (10x10 say). # # proc ::math::linearalgebra::transpose_old { matrix } { set row {} set transpose {} foreach c [lindex $matrix 0] { lappend row 0.0 } foreach r $matrix { lappend transpose $row } set nr 0 foreach r $matrix { set nc 0 foreach c $r { lset transpose $nc $nr $c incr nc } incr nr } return $transpose } proc ::math::linearalgebra::transpose { matrix } { set transpose {} set c 0 foreach col [lindex $matrix 0] { set newrow {} foreach row $matrix { lappend newrow [lindex $row $c] } lappend transpose $newrow incr c } return $transpose } # MorV -- # Identify if the object is a row/column vector or a matrix # Arguments: # obj Object to be examined # Result: # The letter R, C or M depending on the shape # (just to make it all work fine: S for scalar) # Note: # Private procedure to fix a bug in matmul # proc ::math::linearalgebra::MorV { obj } { if { [llength $obj] > 1 } { if { [llength [lindex $obj 0]] > 1 } { return "M" } else { return "C" } } else { if { [llength [lindex $obj 0]] > 1 } { return "R" } else { return "S" } } } # matmul -- # Multiply a vector/matrix with another vector/matrix # Arguments: # mv1 First vector/matrix (x) # mv2 Second vector/matrix (y) # Result: # The result of x*y # proc ::math::linearalgebra::matmul_org { mv1 mv2 } { if { [llength [lindex $mv1 0]] > 1 } { if { [llength [lindex $mv2 0]] > 1 } { return [matmul_mm $mv1 $mv2] } else { return [matmul_mv $mv1 $mv2] } } else { if { [llength [lindex $mv2 0]] > 1 } { return [matmul_vm $mv1 $mv2] } else { return [matmul_vv $mv1 $mv2] } } } proc ::math::linearalgebra::matmul { mv1 mv2 } { switch -exact -- "[MorV $mv1][MorV $mv2]" { "MM" { return [matmul_mm $mv1 $mv2] } "MC" { return [matmul_mv $mv1 $mv2] } "MR" { return -code error "Can not multiply a matrix with a row vector - wrong order" } "RM" { return [matmul_vm [transpose $mv1] $mv2] } "RC" { return [dotproduct [transpose $mv1] $mv2] } "RR" { return -code error "Can not multiply a matrix with a row vector - wrong order" } "CM" { return [transpose [matmul_vm $mv1 $mv2]] } "CR" { return [matmul_vv $mv1 [transpose $mv2]] } "CC" { return [matmul_vv $mv1 $mv2] } "SS" { return [expr {$mv1 * $mv2}] } default { return -code error "Can not use a scalar object" } } } # matmul_mv -- # Multiply a matrix and a column vector # Arguments: # matrix Matrix (applied left: A) # vector Vector (interpreted as column vector: x) # Result: # The vector A*x # Level-2 BLAS : corresponds to DTRMV # proc ::math::linearalgebra::matmul_mv { matrix vector } { set newvect {} foreach row $matrix { set sum 0.0 foreach v $vector c $row { set sum [expr {$sum+$v*$c}] } lappend newvect $sum } return $newvect } # matmul_vm -- # Multiply a row vector with a matrix # Arguments: # vector Vector (interpreted as row vector: x) # matrix Matrix (applied right: A) # Result: # The vector xtrans*A = Atrans*x # proc ::math::linearalgebra::matmul_vm { vector matrix } { return [transpose [matmul_mv [transpose $matrix] $vector]] } # matmul_vv -- # Multiply two vectors to obtain a matrix # Arguments: # vect1 First vector (column vector, x) # vect2 Second vector (row vector, y) # Result: # The "outer product" x*ytrans # proc ::math::linearalgebra::matmul_vv { vect1 vect2 } { set newmat {} foreach v1 $vect1 { set newrow {} foreach v2 $vect2 { lappend newrow [expr {$v1*$v2}] } lappend newmat $newrow } return $newmat } # matmul_mm -- # Multiply two matrices # Arguments: # mat1 First matrix (A) # mat2 Second matrix (B) # Result: # The matrix product A*B # Note: # By transposing matrix B we can access the columns # as rows - much easier and quicker, as they are # the elements of the outermost list. # Level-3 BLAS : # corresponds to DGEMM (alpha op(A) op(B) + beta C) when alpha=1, op(X)=X and beta=0 # corresponds to DTRMM (alpha op(A) B) when alpha = 1, op(X)=X # proc ::math::linearalgebra::matmul_mm { mat1 mat2 } { set newmat {} set tmat [transpose $mat2] foreach row1 $mat1 { set newrow {} foreach row2 $tmat { lappend newrow [dotproduct $row1 $row2] } lappend newmat $newrow } return $newmat } # mkVector -- # Make a vector of a given size # Arguments: # ndim Dimension of the vector # value Default value for all elements (default: 0.0) # Result: # A list with ndim elements, representing a vector # proc ::math::linearalgebra::mkVector { ndim {value 0.0} } { set result {} while { $ndim > 0 } { lappend result $value incr ndim -1 } return $result } # mkUnitVector -- # Make a unit vector in a given direction # Arguments: # ndim Dimension of the vector # dir The direction (0, ... ndim-1) # Result: # A list with ndim elements, representing a unit vector # proc ::math::linearalgebra::mkUnitVector { ndim dir } { if { $dir < 0 || $dir >= $ndim } { return -code error "Invalid direction for unit vector - $dir" } else { set result [mkVector $ndim] lset result $dir 1.0 } return $result } # mkMatrix -- # Make a matrix of a given size # Arguments: # nrows Number of rows # ncols Number of columns # value Default value for all elements (default: 0.0) # Result: # A nested list, representing an nrows x ncols matrix # proc ::math::linearalgebra::mkMatrix { nrows ncols {value 0.0} } { set result {} while { $nrows > 0 } { lappend result [mkVector $ncols $value] incr nrows -1 } return $result } # mkIdent -- # Make an identity matrix of a given size # Arguments: # size Number of rows/columns # Result: # A nested list, representing an size x size identity matrix # proc ::math::linearalgebra::mkIdentity { size } { set result [mkMatrix $size $size 0.0] while { $size > 0 } { incr size -1 lset result $size $size 1.0 } return $result } # mkDiagonal -- # Make a diagonal matrix of a given size # Arguments: # diag List of values to appear on the diagonal # # Result: # A nested list, representing a diagonal matrix # proc ::math::linearalgebra::mkDiagonal { diag } { set size [llength $diag] set result [mkMatrix $size $size 0.0] while { $size > 0 } { incr size -1 lset result $size $size [lindex $diag $size] } return $result } # mkHilbert -- # Make a Hilbert matrix of a given size # Arguments: # size Size of the matrix # Result: # A nested list, representing a Hilbert matrix # Notes: # Hilbert matrices are very ill-conditioned wrt # eigenvalue/eigenvector problems. Therefore they # are good candidates for testing the accuracy # of algorithms and implementations. # proc ::math::linearalgebra::mkHilbert { size } { set result {} for { set j 0 } { $j < $size } { incr j } { set row {} for { set i 0 } { $i < $size } { incr i } { lappend row [expr {1.0/($i+$j+1.0)}] } lappend result $row } return $result } # mkDingdong -- # Make a Dingdong matrix of a given size # Arguments: # size Size of the matrix # Result: # A nested list, representing a Dingdong matrix # Notes: # Dingdong matrices are imprecisely represented, # but have the property of being very stable in # such algorithms as Gauss elimination. # proc ::math::linearalgebra::mkDingdong { size } { set result {} for { set j 0 } { $j < $size } { incr j } { set row {} for { set i 0 } { $i < $size } { incr i } { lappend row [expr {0.5/($size-$i-$j-0.5)}] } lappend result $row } return $result } # mkOnes -- # Make a square matrix consisting of ones # Arguments: # size Number of rows/columns # Result: # A nested list, representing a size x size matrix, # filled with 1.0 # proc ::math::linearalgebra::mkOnes { size } { return [mkMatrix $size $size 1.0] } # mkMoler -- # Make a Moler matrix # Arguments: # size Size of the matrix # Result: # A nested list, representing a Moler matrix # Notes: # Moler matrices have a very simple Choleski # decomposition. It has one small eigenvalue # and it can easily upset elimination methods # for systems of linear equations # proc ::math::linearalgebra::mkMoler { size } { set result {} for { set j 0 } { $j < $size } { incr j } { set row {} for { set i 0 } { $i < $size } { incr i } { if { $i == $j } { lappend row [expr {$i+1}] } else { lappend row [expr {($i>$j?$j:$i)-1.0}] } } lappend result $row } return $result } # mkFrank -- # Make a Frank matrix # Arguments: # size Size of the matrix # Result: # A nested list, representing a Frank matrix # proc ::math::linearalgebra::mkFrank { size } { set result {} for { set j 0 } { $j < $size } { incr j } { set row {} for { set i 0 } { $i < $size } { incr i } { lappend row [expr {($i>$j?$j:$i)-2.0}] } lappend result $row } return $result } # mkBorder -- # Make a bordered matrix # Arguments: # size Size of the matrix # Result: # A nested list, representing a bordered matrix # Note: # This matrix has size-2 eigenvalues at 1. # proc ::math::linearalgebra::mkBorder { size } { set result {} for { set j 0 } { $j < $size } { incr j } { set row {} for { set i 0 } { $i < $size } { incr i } { set entry 0.0 if { $i == $j } { set entry 1.0 } elseif { $j != $size-1 && $i == $size-1 } { set entry [expr {pow(2.0,-$j)}] } elseif { $i != $size-1 && $j == $size-1 } { set entry [expr {pow(2.0,-$i)}] } else { set entry 0.0 } lappend row $entry } lappend result $row } return $result } # mkWilkinsonW+ -- # Make a Wilkinson W+ matrix # Arguments: # size Size of the matrix # Result: # A nested list, representing a Wilkinson W+ matrix # Note: # This kind of matrix has pairs of eigenvalues that # are very close together. Usually the order is odd. # proc ::math::linearalgebra::mkWilkinsonW+ { size } { set result {} for { set j 0 } { $j < $size } { incr j } { set row {} for { set i 0 } { $i < $size } { incr i } { if { $i == $j } { # int(n/2) + 1 - min(i,n-i+1) set min [expr {(($i+1)>$size-($i+1)+1? $size-($i+1)+1 : ($i+1))}] set entry [expr {int($size/2) + 1 - $min}] } elseif { $i == $j+1 || $i+1 == $j } { set entry 1 } else { set entry 0.0 } lappend row $entry } lappend result $row } return $result } # mkWilkinsonW- -- # Make a Wilkinson W- matrix # Arguments: # size Size of the matrix # Result: # A nested list, representing a Wilkinson W- matrix # Note: # This kind of matrix has pairs of eigenvalues with # opposite signs (if the order is odd). # proc ::math::linearalgebra::mkWilkinsonW- { size } { set result {} for { set j 0 } { $j < $size } { incr j } { set row {} for { set i 0 } { $i < $size } { incr i } { if { $i == $j } { set entry [expr {int($size/2) + 1 - ($i+1)}] } elseif { $i == $j+1 || $i+1 == $j } { set entry 1 } else { set entry 0.0 } lappend row $entry } lappend result $row } return $result } # mkRandom -- # Make a square matrix consisting of random numbers # Arguments: # size Number of rows/columns # Result: # A nested list, representing a size x size matrix, # filled with random numbers # proc ::math::linearalgebra::mkRandom { size } { set result {} for { set j 0 } { $j < $size } { incr j } { set row {} for { set i 0 } { $i < $size } { incr i } { lappend row [expr {rand()}] } lappend result $row } return $result } # mkTriangular -- # Make a triangular matrix consisting of a constant # Arguments: # size Number of rows/columns # uplo U if the matrix is upper triangular (default), L if the # matrix is lower triangular. # value Default value for all elements (default: 0.0) # Result: # A nested list, representing a size x size matrix, # filled with random numbers # proc ::math::linearalgebra::mkTriangular { size {uplo "U"} {value 1.0}} { switch -- $uplo { "U" { set result {} for { set j 0 } { $j < $size } { incr j } { set row {} for { set i 0 } { $i < $size } { incr i } { if {$i<$j} then { lappend row 0. } else { lappend row $value } } lappend result $row } } "L" { set result {} for { set j 0 } { $j < $size } { incr j } { set row {} for { set i 0 } { $i < $size } { incr i } { if {$i>$j} then { lappend row 0. } else { lappend row $value } } lappend result $row } } default { error "Unknown value for parameter uplo : $uplo" } } return $result } # getrow -- # Get the specified row from a matrix # Arguments: # matrix Matrix in question # row Index of the row # imin Minimum index of the column (default 0) # imax Maximum index of the column (default ncols-1) # # Result: # A list with the values on the requested row # proc ::math::linearalgebra::getrow { matrix row {imin 0} {imax ""}} { if {$imax==""} then { foreach {nrows ncols} [shape $matrix] {break} if {$ncols==""} then { # the matrix is a vector set imax 0 } else { set imax [expr {$ncols - 1}] } } set row [lindex $matrix $row] return [lrange $row $imin $imax] } # setrow -- # Set the specified row in a matrix # Arguments: # matrix _Name_ of matrix in question # row Index of the row # newvalues New values for the row # imin Minimum column index (default 0) # imax Maximum column index (default ncols-1) # # Result: # Updated matrix # Side effect: # The matrix is updated # proc ::math::linearalgebra::setrow { matrix row newvalues {imin 0} {imax ""}} { upvar $matrix mat if {$imax==""} then { foreach {nrows ncols} [shape $mat] {break} if {$ncols==""} then { # the matrix is a vector set imax 0 } else { set imax [expr {$ncols - 1}] } } set icol $imin foreach value $newvalues { lset mat $row $icol $value incr icol if {$icol>$imax} then { break } } return $mat } # getcol -- # Get the specified column from a matrix # Arguments: # matrix Matrix in question # col Index of the column # imin Minimum row index (default 0) # imax Minimum row index (default nrows-1) # # Result: # A list with the values on the requested column # proc ::math::linearalgebra::getcol { matrix col {imin 0} {imax ""}} { if {$imax==""} then { set nrows [llength $matrix] set imax [expr {$nrows - 1}] } set result {} set iline 0 foreach row $matrix { if {$iline>=$imin && $iline<=$imax} then { lappend result [lindex $row $col] } incr iline } return $result } # setcol -- # Set the specified column in a matrix # Arguments: # matrix _Name_ of matrix in question # col Index of the column # newvalues New values for the column # imin Minimum row index (default 0) # imax Minimum row index (default nrows-1) # # Result: # Updated matrix # Side effect: # The matrix is updated # proc ::math::linearalgebra::setcol { matrix col newvalues {imin 0} {imax ""}} { upvar $matrix mat if {$imax==""} then { set nrows [llength $mat] set imax [expr {$nrows - 1}] } set index 0 for { set i $imin } { $i <= $imax } { incr i } { lset mat $i $col [lindex $newvalues $index] incr index } return $mat } # getelem -- # Get the specified element (row,column) from a matrix/vector # Arguments: # matrix Matrix in question # row Index of the row # col Index of the column (not present for vectors) # # Result: # The matrix element (row,column) # proc ::math::linearalgebra::getelem { matrix row {col {}} } { if { $col != {} } { lindex $matrix $row $col } else { lindex $matrix $row } } # setelem -- # Set the specified element (row,column) in a matrix or vector # Arguments: # matrix _Name_ of matrix/vector in question # row Index of the row # col Index of the column/new value # newvalue New value for the element (not present for vectors) # # Result: # Updated matrix # Side effect: # The matrix is updated # proc ::math::linearalgebra::setelem { matrix row col {newvalue {}} } { upvar $matrix mat if { $newvalue != {} } { lset mat $row $col $newvalue } else { lset mat $row $col } return $mat } # swaprows -- # Swap two rows of a matrix # Arguments: # matrix Matrix defining the coefficients # irow1 Index of first row # irow2 Index of second row # imin Minimum column index (default 0) # imax Maximum column index (default ncols-1) # # Result: # The matrix with the two rows swaped. # proc ::math::linearalgebra::swaprows { matrix irow1 irow2 {imin 0} {imax ""}} { upvar $matrix mat #swaprows1 mat $irow1 $irow2 $imin $imax swaprows2 mat $irow1 $irow2 $imin $imax } proc ::math::linearalgebra::swaprows1 { matrix irow1 irow2 {imin 0} {imax ""}} { upvar $matrix mat if {$imax==""} then { foreach {nrows ncols} [shape $mat] {break} if {$ncols==""} then { # the matrix is a vector set imax 0 } else { set imax [expr {$ncols - 1}] } } set row1 [getrow $mat $irow1 $imin $imax] set row2 [getrow $mat $irow2 $imin $imax] setrow mat $irow1 $row2 $imin $imax setrow mat $irow2 $row1 $imin $imax return $mat } proc ::math::linearalgebra::swaprows2 { matrix irow1 irow2 {imin 0} {imax ""}} { upvar $matrix mat if {$imax==""} then { foreach {nrows ncols} [shape $mat] {break} if {$ncols==""} then { # the matrix is a vector set imax 0 } else { set imax [expr {$ncols - 1}] } } set row1 [lrange [lindex $mat $irow1] $imin $imax] set row2 [lrange [lindex $mat $irow2] $imin $imax] setrow mat $irow1 $row2 $imin $imax setrow mat $irow2 $row1 $imin $imax return $mat } # swapcols -- # Swap two cols of a matrix # Arguments: # matrix Matrix defining the coefficients # icol1 Index of first column # icol2 Index of second column # imin Minimum row index (default 0) # imax Minimum row index (default nrows-1) # # Result: # The matrix with the two columns swaped. # proc ::math::linearalgebra::swapcols { matrix icol1 icol2 {imin 0} {imax ""}} { upvar $matrix mat if {$imax==""} then { set nrows [llength $mat] set imax [expr {$nrows - 1}] } set col1 [getcol $mat $icol1 $imin $imax] set col2 [getcol $mat $icol2 $imin $imax] setcol mat $icol1 $col2 $imin $imax setcol mat $icol2 $col1 $imin $imax return $mat } # solveGauss -- # Solve a system of linear equations using Gauss elimination # Arguments: # matrix Matrix defining the coefficients # bvect Right-hand side (may be several columns) # # Result: # Solution of the system or an error in case of singularity # LAPACK : corresponds to DGETRS, without row interchanges # proc ::math::linearalgebra::solveGauss { matrix bvect } { set norows [llength $matrix] set nocols $norows for { set i 0 } { $i < $nocols } { incr i } { set sweep_row [getrow $matrix $i] set bvect_sweep [getrow $bvect $i] # No pivoting yet set sweep_fact [expr {double([lindex $sweep_row $i])}] for { set j [expr {$i+1}] } { $j < $norows } { incr j } { set current_row [getrow $matrix $j] set bvect_current [getrow $bvect $j] set factor [expr {-[lindex $current_row $i]/$sweep_fact}] lset matrix $j [axpy_vect $factor $sweep_row $current_row] lset bvect $j [axpy_vect $factor $bvect_sweep $bvect_current] } } return [solveTriangular $matrix $bvect] } # solvePGauss -- # Solve a system of linear equations using Gauss elimination # with partial pivoting # Arguments: # matrix Matrix defining the coefficients # bvect Right-hand side (may be several columns) # # Result: # Solution of the system or an error in case of singularity # LAPACK : corresponds to DGETRS # proc ::math::linearalgebra::solvePGauss { matrix bvect } { set ipiv [dgetrf matrix] set norows [llength $matrix] set nm1 [expr {$norows - 1}] # Perform all permutations on b for { set k 0 } { $k < $nm1 } { incr k } { # Swap b(k) and b(mu) with mu = P(k) set tmp [lindex $bvect $k] set mu [lindex $ipiv $k] setrow bvect $k [lindex $bvect $mu] setrow bvect $mu $tmp } # Perform forward substitution for { set k 0 } { $k < $nm1 } { incr k } { set bk [lindex $bvect $k] # Substitution for { set iline [expr {$k+1}] } { $iline < $norows } { incr iline } { set aik [lindex $matrix $iline $k] set maik [expr {-1. * $aik}] set bi [lindex $bvect $iline] setrow bvect $iline [axpy $maik $bk $bi] } } # Perform backward substitution return [solveTriangular $matrix $bvect] } # solveTriangular -- # Solve a system of linear equations where the matrix is # upper-triangular # Arguments: # matrix Matrix defining the coefficients # bvect Right-hand side (may be several columns) # uplo U if the matrix is upper triangular (default), L if the # matrix is lower triangular. # # Result: # Solution of the system or an error in case of singularity # LAPACK : corresponds to DTPTRS, but in the current command, the matrix # is in regular format (unpacked). # proc ::math::linearalgebra::solveTriangular { matrix bvect {uplo "U"}} { set norows [llength $matrix] set nocols $norows switch -- $uplo { "U" { for { set i [expr {$norows-1}] } { $i >= 0 } { incr i -1 } { set sweep_row [getrow $matrix $i] set bvect_sweep [getrow $bvect $i] set sweep_fact [expr {double([lindex $sweep_row $i])}] set norm_fact [expr {1.0/$sweep_fact}] lset bvect $i [scale $norm_fact $bvect_sweep] for { set j [expr {$i-1}] } { $j >= 0 } { incr j -1 } { set current_row [getrow $matrix $j] set bvect_current [getrow $bvect $j] set factor [expr {-[lindex $current_row $i]/$sweep_fact}] lset bvect $j [axpy_vect $factor $bvect_sweep $bvect_current] } } } "L" { for { set i 0 } { $i < $norows } { incr i } { set sweep_row [getrow $matrix $i] set bvect_sweep [getrow $bvect $i] set sweep_fact [expr {double([lindex $sweep_row $i])}] set norm_fact [expr {1.0/$sweep_fact}] lset bvect $i [scale $norm_fact $bvect_sweep] for { set j 0 } { $j < $i } { incr j } { set bvect_current [getrow $bvect $i] set bvect_sweep [getrow $bvect $j] set factor [lindex $sweep_row $j] set factor [expr { -1. * $factor * $norm_fact }] lset bvect $i [axpy_vect $factor $bvect_sweep $bvect_current] } } } default { error "Unknown value for parameter uplo : $uplo" } } return $bvect } # solveGaussBand -- # Solve a system of linear equations using Gauss elimination, # where the matrix is stored as a band matrix. # Arguments: # matrix Matrix defining the coefficients (in band form) # bvect Right-hand side (may be several columns) # # Result: # Solution of the system or an error in case of singularity # proc ::math::linearalgebra::solveGaussBand { matrix bvect } { set norows [llength $matrix] set nocols $norows set nodiags [llength [lindex $matrix 0]] set lowdiags [expr {($nodiags-1)/2}] for { set i 0 } { $i < $nocols } { incr i } { set sweep_row [getrow $matrix $i] set bvect_sweep [getrow $bvect $i] set sweep_fact [lindex $sweep_row [expr {$lowdiags-$i}]] for { set j [expr {$i+1}] } { $j <= $lowdiags } { incr j } { set sweep_row [concat [lrange $sweep_row 1 end] 0.0] set current_row [getrow $matrix $j] set bvect_current [getrow $bvect $j] set factor [expr {-[lindex $current_row $i]/$sweep_fact}] lset matrix $j [axpy_vect $factor $sweep_row $current_row] lset bvect $j [axpy_vect $factor $bvect_sweep $bvect_current] } } return [solveTriangularBand $matrix $bvect] } # solveTriangularBand -- # Solve a system of linear equations where the matrix is # upper-triangular (stored as a band matrix) # Arguments: # matrix Matrix defining the coefficients (in band form) # bvect Right-hand side (may be several columns) # # Result: # Solution of the system or an error in case of singularity # proc ::math::linearalgebra::solveTriangularBand { matrix bvect } { set norows [llength $matrix] set nocols $norows set nodiags [llength [lindex $matrix 0]] set uppdiags [expr {($nodiags-1)/2}] set middle [expr {($nodiags-1)/2}] for { set i [expr {$norows-1}] } { $i >= 0 } { incr i -1 } { set sweep_row [getrow $matrix $i] set bvect_sweep [getrow $bvect $i] set sweep_fact [lindex $sweep_row $middle] set norm_fact [expr {1.0/$sweep_fact}] lset bvect $i [scale $norm_fact $bvect_sweep] for { set j [expr {$i-1}] } { $j >= $i-$middle && $j >= 0 } \ { incr j -1 } { set current_row [getrow $matrix $j] set bvect_current [getrow $bvect $j] set k [expr {$i-$middle}] set factor [expr {-[lindex $current_row $k]/$sweep_fact}] lset bvect $j [axpy_vect $factor $bvect_sweep $bvect_current] } } return $bvect } # determineSVD -- # Determine the singular value decomposition of a matrix # Arguments: # A Matrix to be examined # epsilon Tolerance for the procedure (defaults to 2.3e-16) # # Result: # List of the three elements U, S and V, where: # U, V orthogonal matrices, S a diagonal matrix (here a vector) # such that A = USVt # Note: # This is taken directly from Hume's LA package, and adjusted # to fit the different matrix format. Also changes are applied # that can be found in the second edition of Nash's book # "Compact numerical methods for computers" # # To be done: transpose the algorithm so that we can work # on rows, rather than columns # proc ::math::linearalgebra::determineSVD { A {epsilon 2.3e-16} } { foreach {m n} [shape $A] {break} set tolerance [expr {$epsilon * $epsilon* $m * $n}] set V [mkIdentity $n] # # Top of the iteration # set count 1 for {set isweep 0} {$isweep < 30 && $count > 0} {incr isweep} { set count [expr {$n*($n-1)/2}] ;# count of rotations in a sweep for {set j 0} {$j < [expr {$n-1}]} {incr j} { for {set k [expr {$j+1}]} {$k < $n} {incr k} { set p [set q [set r 0.0]] for {set i 0} {$i < $m} {incr i} { set Aij [lindex $A $i $j] set Aik [lindex $A $i $k] set p [expr {$p + $Aij*$Aik}] set q [expr {$q + $Aij*$Aij}] set r [expr {$r + $Aik*$Aik}] } if { $q < $r } { set c 0.0 set s 1.0 } elseif { $q * $r == 0.0 } { # Underflow of small elements incr count -1 continue } elseif { ($p*$p)/($q*$r) < $tolerance } { # Cols j,k are orthogonal incr count -1 continue } else { set q [expr {$q-$r}] set v [expr {sqrt(4.0*$p*$p + $q*$q)}] set c [expr {sqrt(($v+$q)/(2.0*$v))}] set s [expr {-$p/($v*$c)}] # s == sine of rotation angle, c == cosine # Note: -s in comparison with original LA! } # # Rotation of A # set colj [getcol $A $j] set colk [getcol $A $k] foreach {colj colk} [rotate $c $s $colj $colk] {break} setcol A $j $colj setcol A $k $colk # # Rotation of V # set colj [getcol $V $j] set colk [getcol $V $k] foreach {colj colk} [rotate $c $s $colj $colk] {break} setcol V $j $colj setcol V $k $colk } ;#k } ;# j #puts "pass=$isweep skipped rotations=$count" } ;# isweep set S {} for {set j 0} {$j < $n} {incr j} { set q [norm_two [getcol $A $j]] lappend S $q if { $q >= $tolerance } { set newcol [scale [expr {1.0/$q}] [getcol $A $j]] setcol A $j $newcol } } ;# j # # Prepare the output # set U $A if { $m < $n } { set U {} incr m -1 foreach row $A { lappend U [lrange $row 0 $m] } puts $U } return [list $U $S $V] } # eigenvectorsSVD -- # Determine the eigenvectors and eigenvalues of a real # symmetric matrix via the SVD # Arguments: # A Matrix to be examined # eps Tolerance for the procedure (defaults to 2.3e-16) # # Result: # List of the matrix of eigenvectors and the vector of corresponding # eigenvalues # Note: # This is taken directly from Hume's LA package, and adjusted # to fit the different matrix format. Also changes are applied # that can be found in the second edition of Nash's book # "Compact numerical methods for computers" # proc ::math::linearalgebra::eigenvectorsSVD { A {eps 2.3e-16} } { foreach {m n} [shape $A] {break} if { $m != $n } { return -code error "Expected a square matrix" } # # Determine the shift h so that the matrix A+hI is positive # definite (the Gershgorin region) # set h {} set i 0 foreach row $A { set aii [lindex $row $i] set sum [expr {2.0*abs($aii) - [norm_one $row]}] incr i if { $h == {} || $sum < $h } { set h $sum } } if { $h <= $eps } { set h [expr {$h - sqrt($eps)}] # try to make smallest eigenvalue positive and not too small set A [sub $A [scale_mat $h [mkIdentity $m]]] } else { set h 0.0 } # # Determine the SVD decomposition: this holds the # eigenvectors and eigenvalues # foreach {U S V} [determineSVD $A $eps] {break} # # Rescale and flip signs if all negative or zero # for {set j 0} {$j < $n} {incr j} { set s 0.0 set notpositive 0 for {set i 0} {$i < $n} {incr i} { set Uij [lindex $U $i $j] if { $Uij <= 0.0 } { incr notpositive } set s [expr {$s + $Uij*$Uij}] } set s [expr {sqrt($s)}] if { $notpositive == $n } { set sf [expr {-$s}] } else { set sf $s } set colv [getcol $U $j] setcol U $j [scale_vect [expr {1.0/$sf}] $colv] } for {set j 0} {$j < $n} {incr j} { lset S $j [expr {[lindex $S $j] + $h}] } return [list $U $S] } # leastSquaresSVD -- # Determine the solution to the least-squares problem Ax ~ y # via the singular value decomposition # Arguments: # A Matrix to be examined # y Dependent variable # qmin Minimum singular value to be considered (defaults to 0) # epsilon Tolerance for the procedure (defaults to 2.3e-16) # # Result: # Vector x as the solution of the least-squares problem # proc ::math::linearalgebra::leastSquaresSVD { A y {qmin 0.0} {epsilon 2.3e-16} } { foreach {m n} [shape $A] {break} foreach {U S V} [determineSVD $A $epsilon] {break} set tol [expr {$epsilon * $epsilon * $n * $n}] # # form Utrans*y into g # set g {} for {set j 0} {$j < $n} {incr j} { set s 0.0 for {set i 0} {$i < $m} {incr i} { set Uij [lindex $U $i $j] set yi [lindex $y $i] set s [expr {$s + $Uij*$yi}] } lappend g $s ;# g[j] = $s } # # form VS+g = VS+Utrans*g # set x {} for {set j 0} {$j < $n} {incr j} { set s 0.0 for {set i 0} {$i < $n} {incr i} { set zi [lindex $S $i] if { $zi > $qmin } { set Vji [lindex $V $j $i] set gi [lindex $g $i] set s [expr {$s + $Vji*$gi/$zi}] } } lappend x $s } return $x } # choleski -- # Determine the Choleski decomposition of a symmetric, # positive-semidefinite matrix (this condition is not checked!) # # Arguments: # matrix Matrix to be treated # # Result: # Lower-triangular matrix (L) representing the Choleski decomposition: # L Lt = matrix # proc ::math::linearalgebra::choleski { matrix } { foreach {rows cols} [shape $matrix] {break} set result $matrix for { set j 0 } { $j < $cols } { incr j } { if { $j > 0 } { for { set i $j } { $i < $cols } { incr i } { set sum [lindex $result $i $j] for { set k 0 } { $k <= $j-1 } { incr k } { set Aki [lindex $result $i $k] set Akj [lindex $result $j $k] set sum [expr {$sum-$Aki*$Akj}] } lset result $i $j $sum } } # # Take care of a singular matrix # if { [lindex $result $j $j] <= 0.0 } { lset result $j $j 0.0 } # # Scale the column # set s [expr {sqrt([lindex $result $j $j])}] for { set i 0 } { $i < $cols } { incr i } { if { $i >= $j } { if { $s == 0.0 } { lset result $i $j 0.0 } else { lset result $i $j [expr {[lindex $result $i $j]/$s}] } } else { lset result $i $j 0.0 } } } return $result } # orthonormalizeColumns -- # Orthonormalize the columns of a matrix, using the modified # Gram-Schmidt method # Arguments: # matrix Matrix to be treated # # Result: # Matrix with pairwise orthogonal columns, each having length 1 # proc ::math::linearalgebra::orthonormalizeColumns { matrix } { transpose [orthonormalizeRows [transpose $matrix]] } # orthonormalizeRows -- # Orthonormalize the rows of a matrix, using the modified # Gram-Schmidt method # Arguments: # matrix Matrix to be treated # # Result: # Matrix with pairwise orthogonal rows, each having length 1 # proc ::math::linearalgebra::orthonormalizeRows { matrix } { set result $matrix set rowno 0 foreach r $matrix { set newrow [unitLengthVector [getrow $result $rowno]] setrow result $rowno $newrow incr rowno set rowno2 $rowno # # Update the matrix immediately: this is numerically # more stable # foreach nextrow [lrange $result $rowno end] { set factor [dotproduct $newrow $nextrow] set nextrow [sub_vect $nextrow [scale_vect $factor $newrow]] setrow result $rowno2 $nextrow incr rowno2 } } return $result } # dger -- # Performs the rank 1 operation alpha*x*y' + A # Arguments: # matrix name of the matrix to process (the matrix must be square) # alpha a real value # x a vector # y a vector # scope if not provided, the operation is performed on all rows/columns of A # if provided, it is expected to be the list [list imin imax jmin jmax] # where : # imin Minimum row index # imax Maximum row index # jmin Minimum column index # jmax Maximum column index # # Result: # Updated matrix # Level-3 BLAS : corresponds to DGER # proc ::math::linearalgebra::dger { matrix alpha x y {scope ""}} { upvar $matrix mat set nrows [llength $mat] set ncols $nrows if {$scope==""} then { set imin 0 set imax [expr {$nrows - 1}] set jmin 0 set jmax [expr {$ncols - 1}] } else { foreach {imin imax jmin jmax} $scope {break} } set xy [matmul $x $y] set alphaxy [scale $alpha $xy] for { set iline $imin } { $iline <= $imax } { incr iline } { set ilineshift [expr {$iline - $imin}] set matiline [lindex $mat $iline] set alphailine [lindex $alphaxy $ilineshift] for { set icol $jmin } { $icol <= $jmax } { incr icol } { set icolshift [expr {$icol - $jmin}] set aij [lindex $matiline $icol] set shift [lindex $alphailine $icolshift] setelem mat $iline $icol [expr {$aij + $shift}] } } return $mat } # dgetrf -- # Computes an LU factorization of a general matrix, using partial, # pivoting with row interchanges. # # Arguments: # matrix On entry, the matrix to be factored. # On exit, the factors L and U from the factorization # P*A = L*U; the unit diagonal elements of L are not stored. # # Result: # Returns the permutation vector, as a list of length n-1. # The last entry of the permutation is not stored, since it is # implicitely known, with value n (the last row is not swapped # with any other row). # At index #i of the permutation is stored the index of the row #j # which is swapped with row #i at step #i. That means that each # index of the permutation gives the permutation at each step, not the # cumulated permutation matrix, which is the product of permutations. # The factorization has the form # P * A = L * U # where P is a permutation matrix, L is lower triangular with unit # diagonal elements, and U is upper triangular. # # LAPACK : corresponds to DGETRF # proc ::math::linearalgebra::dgetrf { matrix } { upvar $matrix mat set norows [llength $mat] set nocols $norows # Initialize permutation set nm1 [expr {$norows - 1}] set ipiv {} # Perform Gauss transforms for { set k 0 } { $k < $nm1 } { incr k } { # Search pivot in column n, from lines k to n set column [getcol $mat $k $k $nm1] foreach {abspivot murel} [norm_max $column 1] {break} # Shift mu, because max returns with respect to the column (k:n,k) set mu [expr {$murel + $k}] # Swap lines k and mu from columns 1 to n swaprows mat $k $mu set akk [lindex $mat $k $k] # Store permutation lappend ipiv $mu # Store pivots for lines k+1 to n in columns k+1 to n set kp1 [expr {$k+1}] set akp1 [getcol $mat $k $kp1 $nm1] set mult [expr {1. / double($akk)}] set akp1 [scale $mult $akp1] setcol mat $k $akp1 $kp1 $nm1 # Perform transform for lines k+1 to n set akp1k [getcol $mat $k $kp1 $nm1] set akkp1 [lrange [lindex $mat $k] $kp1 $nm1] set scope [list $kp1 $nm1 $kp1 $nm1] dger mat -1. $akp1k $akkp1 $scope } return $ipiv } # det -- # Returns the determinant of the given matrix, based on PA=LU # decomposition (i.e. dgetrf). # # Arguments: # matrix The matrix values. # ipiv The pivots (optionnal). # If the pivots are not provided, a PA=LU decomposition # is performed. # If the pivots are provided, we assume that it # contains the pivots and that the matrix A contains the # L and U factors, as provided by dgterf. # # Result: # Returns the determinant # proc ::math::linearalgebra::det { matrix {ipiv ""}} { if { $ipiv == "" } then { set ipiv [dgetrf matrix] } set det 1.0 set norows [llength $matrix] set i 0 foreach row $matrix { set uu [lindex $row $i] set det [expr {$det * $uu}] if { $i < $norows - 1 } then { set ii [lindex $ipiv $i] if { $ii!=$i } then { set det [expr {-1.0 * $det}] } } incr i } return $det } # largesteigen -- # Returns a list made of the largest eigenvalue (in magnitude) # and associated eigenvector. # Uses Power Method. # # Arguments: # matrix The matrix values. # tolerance The relative tolerance of the eigenvalue. # maxiter The maximum number of iterations # # Result: # Returns a list of two items, where the first item # is the eigenvalue and the second is the eigenvector. # Note # This is algorithm #7.3.3 of Golub & Van Loan. # proc ::math::linearalgebra::largesteigen { matrix {tolerance 1.e-8} {maxiter 10}} { set norows [llength $matrix] set q [mkVector $norows 1.0] set lambda 1.0 for { set k 0 } { $k < $maxiter } { incr k } { set z [matmul $matrix $q] set zn [norm $z] if { $zn == 0.0 } then { return -code error "Cannot continue power method : matrix is singular" } set s [expr {1.0 / $zn}] set q [scale $s $z] set prod [matmul $matrix $q] set lambda_old $lambda set lambda [dotproduct $q $prod] if { abs($lambda - $lambda_old) < $tolerance * abs($lambda_old) } then { break } } return [list $lambda $q] } # to_LA -- # Convert a matrix or vector to the LA format # Arguments: # mv Matrix or vector to be converted # # Result: # List according to LA conventions # proc ::math::linearalgebra::to_LA { mv } { foreach {rows cols} [shape $mv] { if { $cols == {} } { set cols 0 } } set result [list 2 $rows $cols] foreach row $mv { set result [concat $result $row] } return $result } # from_LA -- # Convert a matrix or vector from the LA format # Arguments: # mv Matrix or vector to be converted # # Result: # List according to current conventions # proc ::math::linearalgebra::from_LA { mv } { foreach {rows cols} [lrange $mv 1 2] {break} if { $cols != 0 } { set result {} set elem2 2 for { set i 0 } { $i < $rows } { incr i } { set elem1 [expr {$elem2+1}] incr elem2 $cols lappend result [lrange $mv $elem1 $elem2] } } else { set result [lrange $mv 3 end] } return $result } # # Announce the package's presence # package provide math::linearalgebra 1.1.4 if { 0 } { Te doen: behoorlijke testen! matmul solveGauss_band join_col, join_row kleinste-kwadraten met SVD en met Gauss PCA } if { 0 } { set matrix {{1.0 2.0 -1.0} {3.0 1.1 0.5} {1.0 -2.0 3.0}} set bvect {{1.0 2.0 -1.0} {3.0 1.1 0.5} {1.0 -2.0 3.0}} puts [join [::math::linearalgebra::solveGauss $matrix $bvect] \n] set bvect {{4.0 2.0} {12.0 1.2} {4.0 -2.0}} puts [join [::math::linearalgebra::solveGauss $matrix $bvect] \n] } if { 0 } { set vect1 {1.0 2.0} set vect2 {3.0 4.0} ::math::linearalgebra::axpy_vect 1.0 $vect1 $vect2 ::math::linearalgebra::add_vect $vect1 $vect2 puts [time {::math::linearalgebra::axpy_vect 1.0 $vect1 $vect2} 50000] puts [time {::math::linearalgebra::axpy_vect 2.0 $vect1 $vect2} 50000] puts [time {::math::linearalgebra::axpy_vect 1.0 $vect1 $vect2} 50000] puts [time {::math::linearalgebra::axpy_vect 1.1 $vect1 $vect2} 50000] puts [time {::math::linearalgebra::add_vect $vect1 $vect2} 50000] } if { 0 } { set M {{1 2} {2 1}} puts "[::math::linearalgebra::determineSVD $M]" } if { 0 } { set M {{1 2} {2 1}} puts "[::math::linearalgebra::normMatrix $M]" } if { 0 } { set M {{1.3 2.3} {2.123 1}} puts "[::math::linearalgebra::show $M]" set M {{1.3 2.3 45 3.} {2.123 1 5.6 0.01}} puts "[::math::linearalgebra::show $M]" puts "[::math::linearalgebra::show $M %12.4f]" } if { 0 } { set M {{1 0 0} {1 1 0} {1 1 1}} puts [::math::linearalgebra::orthonormalizeRows $M] } if { 0 } { set M [::math::linearalgebra::mkMoler 5] puts [::math::linearalgebra::choleski $M] } if { 0 } { set M [::math::linearalgebra::mkRandom 20] set b [::math::linearalgebra::mkVector 20] puts "Gauss A = LU" puts [time {::math::linearalgebra::solveGauss $M $b} 5] puts "Gauss PA = LU" puts [time {::math::linearalgebra::solvePGauss $M $b} 5] # Gauss A = LU # 7607.4 microseconds per iteration # Gauss PA = LU # 17428.4 microseconds per iteration } tcllib-1.15/modules/math/special.tcl0000755000175000017500000001227112077663116016773 0ustar sergeisergei# special.tcl -- # Provide well-known special mathematical functions # # This file contains a collection of tests for one or more of the Tcllib # procedures. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 2004 by Arjen Markus. All rights reserved. # # RCS: @(#) $Id: special.tcl,v 1.13 2008/08/13 07:28:47 arjenmarkus Exp $ # package require math package require math::constants package require math::statistics # namespace special # Create a convenient namespace for the "special" mathematical functions # namespace eval ::math::special { # # Define a number of common mathematical constants # ::math::constants::constants pi variable halfpi [expr {$pi/2.0}] # # Functions defined in other math submodules # if { [info commands Beta] == {} } { namespace import ::math::Beta namespace import ::math::ln_Gamma } # # Export the various functions # namespace export Beta ln_Gamma Gamma erf erfc fresnel_C fresnel_S sinc } # Gamma -- # The Gamma function - synonym for "factorial" # proc ::math::special::Gamma {x} { if { [catch { expr {exp( [ln_Gamma $x] )} } result] } { return -code error -errorcode $::errorCode $result } return $result } # erf -- # The error function # Arguments: # x The value for which the function must be evaluated # Result: # erf(x) # Note: # The algoritm used is due to George Marsaglia # See: http://www.velocityreviews.com/forums/t317358-erf-function-in-c.html # I did not want to copy and convert the even more accurate but # rather lengthy algorithm used by lcc-win32/Sun # proc ::math::special::erf {x} { set x [expr {$x*sqrt(2.0)}] if { $x > 10.0 } { return 1.0 } if { $x < -10.0 } { return -1.0 } set a 1.2533141373155 set b -1.0 set pwr 1.0 set t 0.0 set z 0.0 set s [expr {$a+$b*$x}] set i 2 while { $s != $t } { set a [expr {($a+$z*$b)/double($i)}] set b [expr {($b+$z*$a)/double($i+1)}] set pwr [expr {$pwr*$x*$x}] set t $s set s [expr {$s+$pwr*($a+$x*$b)}] incr i 2 } return [expr {1.0-2.0*$s*exp(-0.5*$x*$x-0.9189385332046727418)}] } # erfc -- # The complement of the error function # Arguments: # x The value for which the function must be evaluated # Result: # erfc(x) = 1.0-erf(x) # proc ::math::special::erfc {x} { set x [expr {$x*sqrt(2.0)}] if { $x > 10.0 } { return 0.0 } if { $x < -10.0 } { return 0.0 } set a 1.2533141373155 set b -1.0 set pwr 1.0 set t 0.0 set z 0.0 set s [expr {$a+$b*$x}] set i 2 while { $s != $t } { set a [expr {($a+$z*$b)/double($i)}] set b [expr {($b+$z*$a)/double($i+1)}] set pwr [expr {$pwr*$x*$x}] set t $s set s [expr {$s+$pwr*($a+$x*$b)}] incr i 2 } return [expr {2.0*$s*exp(-0.5*$x*$x-0.9189385332046727418)}] } # ComputeFG -- # Compute the auxiliary functions f and g # # Arguments: # x Parameter of the integral (x>=0) # Result: # Approximate values for f and g # Note: # See Abramowitz and Stegun. The accuracy is 2.0e-3. # proc ::math::special::ComputeFG {x} { list [expr {(1.0+0.926*$x)/(2.0+1.792*$x+3.104*$x*$x)}] \ [expr {1.0/(2.0+4.142*$x+3.492*$x*$x+6.670*$x*$x*$x)}] } # fresnel_C -- # Compute the Fresnel cosine integral # # Arguments: # x Parameter of the integral (x>=0) # Result: # Value of C(x) = integral from 0 to x of cos(0.5*pi*x^2) # Note: # This relies on a rational approximation of the two auxiliary functions f and g # proc ::math::special::fresnel_C {x} { variable halfpi if { $x < 0.0 } { error "Domain error: x must be non-negative" } if { $x == 0.0 } { return 0.0 } foreach {f g} [ComputeFG $x] {break} set xarg [expr {$halfpi*$x*$x}] return [expr {0.5+$f*sin($xarg)-$g*cos($xarg)}] } # fresnel_S -- # Compute the Fresnel sine integral # # Arguments: # x Parameter of the integral (x>=0) # Result: # Value of S(x) = integral from 0 to x of sin(0.5*pi*x^2) # Note: # This relies on a rational approximation of the two auxiliary functions f and g # proc ::math::special::fresnel_S {x} { variable halfpi if { $x < 0.0 } { error "Domain error: x must be non-negative" } if { $x == 0.0 } { return 0.0 } foreach {f g} [ComputeFG $x] {break} set xarg [expr {$halfpi*$x*$x}] return [expr {0.5-$f*cos($xarg)-$g*sin($xarg)}] } # sinc -- # Compute the sinc function # Arguments: # x Value of the argument # Result: # sin(x)/x # proc ::math::special::sinc {x} { if { $x == 0.0 } { return 1.0 } else { return [expr {sin($x)/$x}] } } # Bessel functions and elliptic integrals -- # source [file join [file dirname [info script]] "bessel.tcl"] source [file join [file dirname [info script]] "classic_polyns.tcl"] source [file join [file dirname [info script]] "elliptic.tcl"] source [file join [file dirname [info script]] "exponential.tcl"] package provide math::special 0.2.2 tcllib-1.15/modules/math/bignum.man0000755000175000017500000002137312077663116016630 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin math::bignum n 3.1] [copyright {2004 Salvatore Sanfilippo }] [copyright {2004 Arjen Markus }] [moddesc {Tcl Math Library}] [titledesc {Arbitrary precision integer numbers}] [category Mathematics] [require Tcl [opt 8.4]] [require math::bignum [opt 3.1]] [description] [para] The bignum package provides arbitrary precision integer math (also known as "big numbers") capabilities to the Tcl language. Big numbers are internally represented at Tcl lists: this package provides a set of procedures operating against the internal representation in order to: [list_begin itemized] [item] perform math operations [item] convert bignums from the internal representation to a string in the desired radix and vice versa. [list_end] But the two constants "0" and "1" are automatically converted to the internal representation, in order to easily compare a number to zero, or increment a big number. [para] The bignum interface is opaque, so operations on bignums that are not returned by procedures in this package (but created by hand) may lead to unspecified behaviours. It's safe to treat bignums as pure values, so there is no need to free a bignum, or to duplicate it via a special operation. [section "EXAMPLES"] This section shows some simple example. This library being just a way to perform math operations, examples may be the simplest way to learn how to work with it. Consult the API section of this man page for information about individual procedures. [para] [example_begin] package require math::bignum # Multiplication of two bignums set a [lb]::math::bignum::fromstr 88888881111111[rb] set b [lb]::math::bignum::fromstr 22222220000000[rb] set c [lb]::math::bignum::mul $a $b[rb] puts [lb]::math::bignum::tostr $c[rb] ; # => will output 1975308271604953086420000000 set c [lb]::math::bignum::sqrt $c[rb] puts [lb]::math::bignum::tostr $c[rb] ; # => will output 44444440277777 # From/To string conversion in different radix set a [lb]::math::bignum::fromstr 1100010101010111001001111010111 2[rb] puts [lb]::math::bignum::tostr $a 16[rb] ; # => will output 62ab93d7 # Factorial example proc fact n { # fromstr is not needed for 0 and 1 set z 1 for {set i 2} {$i <= $n} {incr i} { set z [lb]::math::bignum::mul $z [lb]::math::bignum::fromstr $i[rb][rb] } return $z } puts [lb]::math::bignum::tostr [lb]fact 100[rb][rb] [example_end] [section "API"] [list_begin definitions] [call [cmd ::math::bignum::fromstr] [arg string] ?[arg radix]?] Convert [emph string] into a bignum. If [emph radix] is omitted or zero, the string is interpreted in hex if prefixed with [emph 0x], in octal if prefixed with [emph ox], in binary if it's pefixed with [emph bx], as a number in radix 10 otherwise. If instead the [emph radix] argument is specified in the range 2-36, the [emph string] is interpreted in the given radix. Please note that this conversion is not needed for two constants : [emph 0] and [emph 1]. (see the example) [call [cmd ::math::bignum::tostr] [arg bignum] ?[arg radix]?] Convert [emph bignum] into a string representing the number in the specified radix. If [emph radix] is omitted, the default is 10. [call [cmd ::math::bignum::sign] [arg bignum]] Return the sign of the bignum. The procedure returns 0 if the number is positive, 1 if it's negative. [call [cmd ::math::bignum::abs] [arg bignum]] Return the absolute value of the bignum. [call [cmd ::math::bignum::cmp] [arg a] [arg b]] Compare the two bignums a and b, returning [emph 0] if [emph {a == b}], [emph 1] if [emph {a > b}], and [emph -1] if [emph {a < b}]. [call [cmd ::math::bignum::iszero] [arg bignum]] Return true if [emph bignum] value is zero, otherwise false is returned. [call [cmd ::math::bignum::lt] [arg a] [arg b]] Return true if [emph {a < b}], otherwise false is returned. [call [cmd ::math::bignum::le] [arg a] [arg b]] Return true if [emph {a <= b}], otherwise false is returned. [call [cmd ::math::bignum::gt] [arg a] [arg b]] Return true if [emph {a > b}], otherwise false is returned. [call [cmd ::math::bignum::ge] [arg a] [arg b]] Return true if [emph {a >= b}], otherwise false is returned. [call [cmd ::math::bignum::eq] [arg a] [arg b]] Return true if [emph {a == b}], otherwise false is returned. [call [cmd ::math::bignum::ne] [arg a] [arg b]] Return true if [emph {a != b}], otherwise false is returned. [call [cmd ::math::bignum::isodd] [arg bignum]] Return true if [emph bignum] is odd. [call [cmd ::math::bignum::iseven] [arg bignum]] Return true if [emph bignum] is even. [call [cmd ::math::bignum::add] [arg a] [arg b]] Return the sum of the two bignums [emph a] and [emph b]. [call [cmd ::math::bignum::sub] [arg a] [arg b]] Return the difference of the two bignums [emph a] and [emph b]. [call [cmd ::math::bignum::mul] [arg a] [arg b]] Return the product of the two bignums [emph a] and [emph b]. The implementation uses Karatsuba multiplication if both the numbers are bigger than a given threshold, otherwise the direct algorith is used. [call [cmd ::math::bignum::divqr] [arg a] [arg b]] Return a two-elements list containing as first element the quotient of the division between the two bignums [emph a] and [emph b], and the remainder of the division as second element. [call [cmd ::math::bignum::div] [arg a] [arg b]] Return the quotient of the division between the two bignums [emph a] and [emph b]. [call [cmd ::math::bignum::rem] [arg a] [arg b]] Return the remainder of the division between the two bignums [emph a] and [emph b]. [call [cmd ::math::bignum::mod] [arg n] [arg m]] Return [emph n] modulo [emph m]. This operation is called modular reduction. [call [cmd ::math::bignum::pow] [arg base] [arg exp]] Return [emph base] raised to the exponent [emph exp]. [call [cmd ::math::bignum::powm] [arg base] [arg exp] [arg m]] Return [emph base] raised to the exponent [emph exp], modulo [emph m]. This function is often used in the field of cryptography. [call [cmd ::math::bignum::sqrt] [arg bignum]] Return the integer part of the square root of [emph bignum] [call [cmd ::math::bignum::rand] [arg bits]] Return a random number of at most [emph bits] bits. The returned number is internally generated using Tcl's [emph {expr rand()}] function and is not suitable where an unguessable and cryptographically secure random number is needed. [call [cmd ::math::bignum::lshift] [arg bignum] [arg bits]] Return the result of left shifting [emph bignum]'s binary representation of [emph bits] positions on the left. This is equivalent to multiplying by 2^[emph bits] but much faster. [call [cmd ::math::bignum::rshift] [arg bignum] [arg bits]] Return the result of right shifting [emph bignum]'s binary representation of [emph bits] positions on the right. This is equivalent to dividing by [emph 2^bits] but much faster. [call [cmd ::math::bignum::bitand] [arg a] [arg b]] Return the result of doing a bitwise AND operation on a and b. The operation is restricted to positive numbers, including zero. When negative numbers are provided as arguments the result is undefined. [call [cmd ::math::bignum::bitor] [arg a] [arg b]] Return the result of doing a bitwise OR operation on a and b. The operation is restricted to positive numbers, including zero. When negative numbers are provided as arguments the result is undefined. [call [cmd ::math::bignum::bitxor] [arg a] [arg b]] Return the result of doing a bitwise XOR operation on a and b. The operation is restricted to positive numbers, including zero. When negative numbers are provided as arguments the result is undefined. [call [cmd ::math::bignum::setbit] [arg bignumVar] [arg bit]] Set the bit at [emph bit] position to 1 in the bignum stored in the variable [emph bignumVar]. Bit 0 is the least significant. [call [cmd ::math::bignum::clearbit] [arg bignumVar] [arg bit]] Set the bit at [emph bit] position to 0 in the bignum stored in the variable [emph bignumVar]. Bit 0 is the least significant. [call [cmd ::math::bignum::testbit] [arg bignum] [arg bit]] Return true if the bit at the [emph bit] position of [emph bignum] is on, otherwise false is returned. If [emph bit] is out of range, it is considered as set to zero. [call [cmd ::math::bignum::bits] [arg bignum]] Return the number of bits needed to represent bignum in radix 2. [list_end] [para] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph {math :: bignum}] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords tcl multiprecision math bignums] [manpage_end] tcllib-1.15/modules/math/bignum.test0000755000175000017500000004143112077663116017031 0ustar sergeisergei# -*- tcl -*- # bignum.test -- # Test cases for the ::math::bignum package # # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.4 testsNeedTcltest 2.1 support { useLocal math.tcl math } testing { useLocal bignum.tcl math::bignum } # ------------------------------------------------------------------------- proc matchBignums { expected actual } { set match 1 foreach a $actual e $expected { if { $a != $b } { set match 0 break } } return $match } # # Note: # Some tests use the internal representation directly. # The variables atombits is assumed to be 16 # if { $::math::bignum::atombits != 16 } { puts "Prerequisite: atombits = 16" # # The maximum value for the atoms is 2**16-1 = 65535 # } # ------------------------------------------------------------------------- # # Tests: fromstr/tostr (use the internal representation directly) # test "Fromstr-1.0" "Convert string representing small number (1)" -body { ::math::bignum::fromstr 1 } -result {bignum 0 1} test "Fromstr-1.1" "Convert string representing small number (2)" -body { ::math::bignum::fromstr 257 } -result {bignum 0 257} test "Fromstr-1.2" "Convert string representing big number (1)" -body { ::math::bignum::fromstr "[expr {256*256*256}]" } -result {bignum 0 0 256} test "Fromstr-1.3" "Convert string representing big number (2)" -body { ::math::bignum::fromstr "[expr {256*256*256+1}]" } -result {bignum 0 1 256} test "Fromstr-1.4" "Convert string representing negative number" -body { ::math::bignum::fromstr "[expr {-256*256*256-1}]" } -result {bignum 1 1 256} test "Fromstr-1.5" "Convert string representing binary number (1)" -body { ::math::bignum::fromstr "10000000000000000000000000000000" 2 } -result {bignum 0 0 32768} test "Fromstr-1.6" "Convert string representing binary number (2)" -body { ::math::bignum::fromstr "10000000000000000000000000000001" 2 } -result {bignum 0 1 32768} test "Fromstr-1.7" "Convert string representing hex number (1)" -body { ::math::bignum::fromstr "ffffffff" 16 } -result {bignum 0 65535 65535} test "Fromstr-1.8" "Convert string representing hex number (2)" -body { ::math::bignum::fromstr "-ffffffff" 16 } -result {bignum 1 65535 65535} test "Fromstr-1.9" "Convert string representing 2*16+1" -body { ::math::bignum::fromstr "65537" } -result {bignum 0 1 1} test "Fromstr-1.10" "Convert string representing 2*16" -body { ::math::bignum::fromstr "65536" } -result {bignum 0 0 1} test "Tostr-2.0" "Convert small number (1)" -body { ::math::bignum::tostr {bignum 0 1} } -result 1 test "Tostr-2.1" "Convert small number (2)" -body { ::math::bignum::tostr {bignum 0 257} } -result 257 test "Tostr-2.2" "Convert big number (1)" -body { ::math::bignum::tostr {bignum 0 0 256} } -result "[expr {256*256*256}]" test "Tostr-2.3" "Convert big number (2)" -body { ::math::bignum::tostr {bignum 0 1 256} } -result "[expr {256*256*256+1}]" test "Tostr-2.4" "Convert negative number" -body { ::math::bignum::tostr {bignum 1 1 256} } -result "[expr {-256*256*256-1}]" test "Tostr-2.5" "Convert binary number (1)" -body { ::math::bignum::tostr {bignum 0 0 32768} 2 } -result "10000000000000000000000000000000" test "Tostr-2.6" "Convert binary number (2)" -body { ::math::bignum::tostr {bignum 0 1 32768} 2 } -result "10000000000000000000000000000001" test "Tostr-2.7" "Convert hex number (1)" -body { ::math::bignum::tostr {bignum 0 65535 65535} 16 } -result "ffffffff" test "Tostr-2.8" "Convert hex number (2)" -body { ::math::bignum::tostr {bignum 1 65535 65535} 16 } -result "-ffffffff" test "Tostr-2.9" "Convert very big number" -body { ::math::bignum::tostr [::math::bignum::fromstr "10000000000000000000"] } -result "10000000000000000000" test "Tostr-2.10" "Convert to ternary number" -body { ::math::bignum::tostr {bignum 0 9} 3 } -result "100" # # Arithmetic operations # test "Plus-3.0" "Add two smallish numbers" -body { set a [::math::bignum::fromstr "100000"] set b [::math::bignum::fromstr "100001"] set c [::math::bignum::add $a $b] ::math::bignum::tostr $c } -result "200001" test "Plus-3.1" "Add two big numbers" -body { set a [::math::bignum::fromstr "100000000000000"] set b [::math::bignum::fromstr "100001000000001"] set c [::math::bignum::add $a $b] ::math::bignum::tostr $c } -result "200001000000001" test "Plus-3.2" "Add two very large numbers" -body { set a [::math::bignum::fromstr "1[string repeat 0 200]1"] set b [::math::bignum::fromstr "2[string repeat 0 200]2"] set c [::math::bignum::add $a $b] ::math::bignum::tostr $c } -result "3[string repeat 0 200]3" test "Plus-3.3" "Add zero to a large number" -body { set a [::math::bignum::fromstr "1[string repeat 0 200]1"] set b 0 set c [::math::bignum::add $a $b] ::math::bignum::tostr $c } -result "1[string repeat 0 200]1" test "Plus-3.4" "Add one to a large number" -body { set a [::math::bignum::fromstr "1[string repeat 9 200]"] set b 1 set c [::math::bignum::add $a $b] ::math::bignum::tostr $c } -result "2[string repeat 0 200]" test "Minus-3.2" "Subtract two smallish numbers" -body { set a [::math::bignum::fromstr "100000"] set b [::math::bignum::fromstr "100001"] set c [::math::bignum::sub $a $b] ::math::bignum::tostr $c } -result "-1" test "Minus-3.3" "Subtract two big numbers" -body { set a [::math::bignum::fromstr "100000000000000"] set b [::math::bignum::fromstr "100001000000001"] set c [::math::bignum::sub $a $b] ::math::bignum::tostr $c } -result "-1000000001" test "Minus-3.4" "Subtract one from a big number" -body { set a [::math::bignum::fromstr "1[string repeat 0 50]"] set b 1 set c [::math::bignum::sub $a $b] ::math::bignum::tostr $c } -result [string repeat 9 50] test "Compare-4.0" "Compare a set of two numbers" -body { set okay 1 foreach {astring bstring op} { 1 -1 gt 1 -1 ge 1 1 ge 1 1 eq -1 1 lt -1 1 le 10000000 -10000000 gt 10000000 -10000000 ge 10000000 10000000 eq -10000000 10000000 lt -10000000 10000000 le 100000000000 -100000000000 gt 100000000000 -100000000000 ge 100000000000 100000000000 eq -100000000000 100000000000 lt -100000000000 100000000000 le 1000000000000000000000 -1000000000000000000000 gt 1000000000000000000000 -1000000000000000000000 ge 1000000000000000000000 1000000000000000000000 eq -1000000000000000000000 1000000000000000000000 lt -1000000000000000000000 1000000000000000000000 le -1000000000000000000000 1000000000000000000000 ne } { set a [::math::bignum::fromstr $astring] set b [::math::bignum::fromstr $bstring] if { ! [::math::bignum::$op $a $b] } { set okay "False: $astring $op $bstring" break } } return $okay } -result 1 test "Compare-4.1" "Compare a set of two numbers (inverse result)" -body { set okay 1 foreach {astring bstring op} { -1 1 gt -1 1 ge 1 1 ne 1 -1 lt 1 -1 le -10000000 10000000 gt -10000000 10000000 ge 10000000 10000000 ne 10000000 -10000000 lt 10000000 -10000000 le -100000000000 100000000000 gt -100000000000 100000000000 ge 100000000000 100000000000 ne 100000000000 -100000000000 lt 100000000000 -100000000000 le -1000000000000000000000 1000000000000000000000 gt -1000000000000000000000 1000000000000000000000 ge 1000000000000000000000 1000000000000000000000 ne 1000000000000000000000 -1000000000000000000000 lt 1000000000000000000000 -1000000000000000000000 le 1000000000000000000000 -1000000000000000000000 eq } { set a [::math::bignum::fromstr $astring] set b [::math::bignum::fromstr $bstring] # # None should be true # if { [::math::bignum::$op $a $b] } { set okay "True: $astring $op $bstring - should be false" break } } return $okay } -result 1 test "Compare-4.2" "Compare a set of numbers against 0 and 1" -body { set okay 1 foreach {astring opzero opone} { -1 lt lt 1 gt eq -10000000 lt lt 10000000 gt gt 0 eq lt 2 gt gt } { set a [::math::bignum::fromstr $astring] foreach b {0 1} op [list $opzero $opone] { # # None should be true # if {! [::math::bignum::$op $a $b] } { set okay "False: $astring $op $b - should be true" break } } } return $okay } -result 1 test "Mult-5.0" "Multiply two small numbers" -body { set a [::math::bignum::fromstr 10] set b [::math::bignum::fromstr 1000] set c [::math::bignum::mul $a $b] ::math::bignum::tostr $c } -result "10000" test "Mult-5.0a" "Multiply small numbers by 0" -body { set okay 1 foreach a {1 0 -1 100000 -10000 100000000000 -100000000000} { set n [::math::bignum::fromstr $a] if {! [::math::bignum::iszero [::math::bignum::mul $n 0]]} { set okay "Multiplying $a by 0 does not give 0" return } } set okay } -result 1 test "Mult-5.0b" "Multiply small numbers by 1" -body { set okay 1 foreach a {1 0 -1 100000 -10000 100000000000 -100000000000} { set n [::math::bignum::fromstr $a] if {! [::math::bignum::eq [::math::bignum::mul $n 1] $n]} { set okay "Multiplying $a by 1 does not give $a" return } } set okay } -result 1 test "Mult-5.1" "Multiply two small negative numbers" -body { set a [::math::bignum::fromstr -10] set b [::math::bignum::fromstr -1000] set c [::math::bignum::mul $a $b] ::math::bignum::tostr $c } -result "10000" test "Mult-5.2" "Multiply two very large numbers" -body { set a [::math::bignum::fromstr "1[string repeat 0 100]"] set b [::math::bignum::fromstr "2[string repeat 0 200]"] set c [::math::bignum::mul $a $b] ::math::bignum::tostr $c } -result "2[string repeat 0 300]" test "Mult-5.3" "Multiply two very large numbers of opposite sign" -body { set a [::math::bignum::fromstr "1[string repeat 0 100]"] set b [::math::bignum::fromstr "-2[string repeat 0 200]"] set c [::math::bignum::mul $a $b] ::math::bignum::tostr $c } -result "-2[string repeat 0 300]" test "Mult-5.4" "Katsabura multiplication with two very large numbers of opposite sign" -body { set a [::math::bignum::fromstr "1[string repeat 0 1000]"] set b [::math::bignum::fromstr "-2[string repeat 0 2000]"] set c [::math::bignum::mul $a $b] ::math::bignum::tostr $c } -result "-2[string repeat 0 3000]" # Div test "Div-6.1" "Divide 0 by any number" -body { set okay 1 foreach n {1 -1 2 -2 10 -10 1000000000 -100000000} { set a [::math::bignum::fromstr $n] if {! [::math::bignum::iszero [::math::bignum::div 0 $a]]} { set okay "Zero divided by $n does not give zero" break } } set okay } -result 1 test "Div-6.2" "Divide small numbers by 1" -body { set okay 1 foreach n {0 1 -1 2 -2 10 -10 1000000000 -100000000} { set a [::math::bignum::fromstr $n] if {! [::math::bignum::eq [::math::bignum::div $a 1] $a]} { set okay "$n divided by 1 does not give $n" break } } set okay } -result 1 test "Div-6.3" "Divide big numbers by 2" -body { set okay 1 set two [::math::bignum::fromstr 2] foreach p {2 5 10 50 100} { set n 1[string repeat 0 $p] set a [::math::bignum::fromstr $n] set q 5[string repeat 0 [expr {$p-1}]] if {! [string equal [::math::bignum::tostr [::math::bignum::div $a $two]] $q]} { set okay "$n divided by 2 does not give $q" break } } set okay } -result 1 test "Pow-7.1" "Exponentiate large numbers" -body { set a [::math::bignum::fromstr "1[string repeat 0 10]"] set b [::math::bignum::fromstr 1] set okay 1 foreach p {1 2 3 4 5 6 7 8 9 10} { set c [::math::bignum::mul $b $a] set d [::math::bignum::pow $a $p] if { [::math::bignum::ne $c $d] } { set okay "False: $a**$p != $c" } } return $okay } -result 1 # Left and right shifts set c 0 foreach {z n} { 1 1 2 1 4 1 -1 1 -2 1 -4 1 1 2 2 2 4 2 -1 2 -2 2 -4 2 1000001 1 2000001 1 4000001 1 -1000001 1 -2000001 1 -4000001 1 10000000001 1 20000000001 1 40000000001 1 -10000000001 1 -20000000001 1 -40000000001 1 10000000001 11 20000000001 11 40000000001 11 -10000000001 11 -20000000001 11 -40000000001 11 10000000001 21 20000000001 21 40000000001 21 -10000000001 21 -20000000001 21 -40000000001 21 } { incr c test "Lshift-8.$c" "Lshift large numbers" -body { set x [::math::bignum::lshift [::math::bignum::fromstr $z] $n] set y [expr {$z << $n}] ::math::bignum::cmp $x [::math::bignum::fromstr $y] } -result 0 test "Rshift-8.$c" "Rshift large numbers" -body { set x [::math::bignum::rshift [::math::bignum::fromstr $z] $n] set y [expr {$z >> $n}] ::math::bignum::cmp $x [::math::bignum::fromstr $y] } -result 0 } # Bit operations (And, Or, Xor) foreach {n a b zand zor zxor} { 0 0 0 0 0 0 1 1 2 0 3 3 2 1 3 1 3 2 3 2 3 2 3 1 } { set a [::math::bignum::fromstr $a] set b [::math::bignum::fromstr $b] set zand [::math::bignum::fromstr $zand] set zor [::math::bignum::fromstr $zor] set zxor [::math::bignum::fromstr $zxor] test "Bitand-8.$n" "BitAnd large numbers" -body { ::math::bignum::bitand $a $b } -result $zand test "Bitor-9.$n" "BitOr large numbers" -body { ::math::bignum::bitor $a $b } -result $zor test "Bitxor-10.$n" "BitXor large numbers" -body { ::math::bignum::bitxor $a $b } -result $zxor } test "Mod-11.1" "Modulo and remainder for small numbers" -body { set okay 1 foreach {n d m r} { 100 -3 -2 1 -100 -3 -1 -1 -100 3 2 -1 100 3 1 1 } { set a [::math::bignum::fromstr $n] set b [::math::bignum::fromstr $d] set modulo [::math::bignum::tostr [::math::bignum::mod $a $b]] set remainder [::math::bignum::tostr [::math::bignum::rem $a $b]] if {! [string equal $modulo $m]} { set okay "$n modulo $d does not give $m" break } if {! [string equal $remainder $r]} { set okay "the remainder of $n/$d is not given as $r" break } } return $okay } -result 1 # Bit operations (Test bit) test testbit-1.0 {test with bit in range of used bits} -setup { set z [::math::bignum::fromstr 3220] ::math::bignum::setbit z 24 } -body { ::math::bignum::testbit $z 23 } -cleanup { unset z } -result 0 test testbit-1.1 {test with bit beyond range of used bits} -setup { set z [::math::bignum::fromstr 3220] } -body { ::math::bignum::testbit $z 23 } -cleanup { unset z } -result 0 test testbit-1.2 {test with bit in range of used bits} -setup { set z [::math::bignum::fromstr 3220] ::math::bignum::setbit z 24 } -body { ::math::bignum::testbit $z 24 } -cleanup { unset z } -result 1 # ------------------------------------------------------------------------- # # TODO: all the other operations and functions # # ------------------------------------------------------------------------- # End of test cases testsuiteCleanup tcllib-1.15/modules/math/interpolate.test0000755000175000017500000002170612077663116020101 0ustar sergeisergei# -*- tcl -*- # interpolate.test -- # Test cases for the ::math::interpolate package # # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.4 testsNeedTcltest 2.1 support { use struct/matrix.tcl struct::matrix useLocal math.tcl math } testing { useLocal interpolate.tcl math::interpolate } # ------------------------------------------------------------------------- # # Minimisation via steepest-descent # proc matchNumbers {expected actual} { set match 1 foreach a $actual e $expected { if {$e != 0.0} { if {abs($a-$e) > 0.5e-4*abs($a+$e)} { set match 0 break } } else { if {abs($a-$e) > 1.0e-5} { set match 0 break } } } return $match } customMatch numbers matchNumbers # ------------------------------------------------------------------------- # # Test cases: interpolation in tables # set t [::math::interpolate::defineTable table1 \ { x v1 v2 v3 } \ { 0 0 10 1 1 1 9 4 2 2 8 9 5 5 5 25 7 7 3 49 10 10 0 100 }] test "Interpolate-1.1" "Interpolate in a one-dimensional table" \ -match numbers -body { set result {} foreach x { -1.0 0.0 3.0 5.0 9.9 11.0 } { set result [concat $result \ [::math::interpolate::interp-1d-table $t $x]] } set result } -result { -1 0 10 1 0 0 10 1 3 3 7 14.333333 5 5 5 25 9.9 9.9 0.1 98.3 11 10 0 100 } # value = x+y set t2 [::math::interpolate::defineTable table2 \ { x y1 y2 y3 } \ { - 0 3 10 1 1 4 11 2 2 5 12 5 5 8 15 7 7 10 17 10 10 13 20 }] test "Interpolate-1.2" "Interpolate in a two-dimensional table" \ -match numbers -body { set result {} foreach y { -1.0 0.0 3.0 5.0 9.9 11.0 } { foreach x { -1.0 0.0 3.0 5.0 9.9 11.0 } { set result [concat $result \ $x $y [::math::interpolate::interp-table $t2 $x $y]] } } set result } -result { -1.0 -1.0 1.0 0.0 -1.0 1.0 3.0 -1.0 3.0 5.0 -1.0 5.0 9.9 -1.0 9.9 11.0 -1.0 10.0 -1.0 0.0 1.0 0.0 0.0 1.0 3.0 0.0 3.0 5.0 0.0 5.0 9.9 0.0 9.9 11.0 0.0 10.0 -1.0 3.0 4.0 0.0 3.0 4.0 3.0 3.0 6.0 5.0 3.0 8.0 9.9 3.0 12.9 11.0 3.0 13.0 -1.0 5.0 6.0 0.0 5.0 6.0 3.0 5.0 8.0 5.0 5.0 10.0 9.9 5.0 14.9 11.0 5.0 15.0 -1.0 9.9 10.9 0.0 9.9 10.9 3.0 9.9 12.9 5.0 9.9 14.9 9.9 9.9 19.8 11.0 9.9 19.9 -1.0 11.0 11.0 0.0 11.0 11.0 3.0 11.0 13.0 5.0 11.0 15.0 9.9 11.0 19.9 11.0 11.0 20.0 } # linear interpolation: y = x + 1 and y = 2*x, x<5, or 20-2*x, x>5 test "Interpolate-2.1" "Linear interpolation - 1" \ -match numbers -body { set result {} set xyvalues { 0.0 1.0 10.0 11.0 } foreach x { 0.0 4.0 7.0 10.0 101.0 } { lappend result [::math::interpolate::interp-linear $xyvalues $x] } set result } -result { 1.0 5.0 8.0 11.0 11.0 } test "Interpolate-2.2" "Linear interpolation - 2" \ -match numbers -body { set result {} set xyvalues { 0.0 0.0 5.0 10.0 10.0 0.0 } foreach x { 0.0 4.0 7.0 10.0 11.0 } { lappend result [::math::interpolate::interp-linear $xyvalues $x] } set result } -result { 0.0 8.0 6.0 0.0 0.0 } # Lagrange interpolation: y = x + 1 test "Interpolate-3.1" "Lagrange interpolation - 1" \ -match numbers -body { set result {} set xyvalues { 0.0 1.0 10.0 11.0 } foreach x { 0.0 4.0 7.0 10.0 101.0 } { lappend result [::math::interpolate::interp-lagrange $xyvalues $x] } set result } -result { 1.0 5.0 8.0 11.0 102.0 } #Lagrange interpolation (2) - expected: y=10-2*(x-5)**2/5 test "Interpolate-3.2" "Lagrange interpolation - 2" \ -match numbers -body { set result {} set xyvalues { 0.0 0.0 5.0 10.0 10.0 0.0 } foreach x { 0.0 4.0 7.0 10.0 11.0 } { lappend result [::math::interpolate::interp-lagrange $xyvalues $x] } set result } -result { 0.0 9.6 8.4 0.0 -4.4 } # Spatial interpolation test "Interpolate-4.1" "Spatial interpolation - 1" \ -match numbers -body { set result {} set xyzvalues { {-1.0 0.0 -2.0 } { 1.0 0.0 2.0 } } foreach coord { {0.0 0.0} {0.0 1.0} {3.0 0.0} {100.0 0.0} } { lappend result [::math::interpolate::interp-spatial $xyzvalues $coord] } set result } -result { 0.0 0.0 1.2 0.039996 } test "Interpolate-4.2" "Spatial interpolation - 2" \ -match numbers -body { set result {} set xyzvalues { {-1.0 0.0 { -2.0 1.0 } } { 1.0 0.0 { 2.0 -1.0 } } } foreach coord { {0.0 0.0} {0.0 1.0} {3.0 0.0} {100.0 0.0} } { set result [concat $result \ [::math::interpolate::interp-spatial $xyzvalues $coord]] } set result } -result { 0.0 0.0 0.0 0.0 1.2 -0.6 0.039996 -0.019998 } # # Test TODO: parameters for spatial interpolation # test interpolate-5.1 "neville algorithm" \ -body { set problems {} namespace import ::math::interpolate::neville set xtable [list 0. 30. 45. 60. 90. 120. 135. 150. 180.] set ytable [list 0. 0.5 [expr sqrt(0.5)] [expr sqrt(0.75)] 1. \ [expr sqrt(0.75)] [expr sqrt(0.5)] 0.5 0.] for { set x -15 } { $x <= 195 } { incr x } { foreach { y error } [neville $xtable $ytable $x] break set diff [expr { abs( $y - sin( $x*3.1415926535897932/180. ) ) }] if { $error > 3.e-4 || ( $diff > $error && $diff > 1.e-8 ) } { append problems \n "interpolating for sine of " $x " degrees" \ \n "value was " $y " +/- " $error \ \n "actual error was " $diff } } set problems } \ -result {} proc matchNumbers {expected actual} { set match 1 foreach a $actual e $expected { if {abs($a-$e) > 0.1e-6} { set match 0 break } } return $match } customMatch numbers matchNumbers test "cubic-splines-1.0" "Interpolate linear function" \ -match numbers -body { set xcoord {1 2 3 4 5} set ycoord {1 2 3 4 5} set coeffs [::math::interpolate::prepare-cubic-splines $xcoord $ycoord] set yvalues {} foreach x {1.5 2.5 3.5 4.5} { lappend yvalues [::math::interpolate::interp-cubic-splines $coeffs $x] } set yvalues } -result {1.5 2.5 3.5 4.5} test "cubic-splines-1.1" "Interpolate quadratic function" \ -match numbers -body { set xcoord {1 2 3 4 5} set ycoord {1 4 9 16 25} set coeffs [::math::interpolate::prepare-cubic-splines $xcoord $ycoord] set yvalues {} foreach x $xcoord { lappend yvalues [::math::interpolate::interp-cubic-splines $coeffs $x] } set yvalues } -result {1 4 9 16 25} test "cubic-splines-1.2" "Interpolate arbitrary function" \ -match numbers -body { set coeffs [::math::interpolate::prepare-cubic-splines \ {0.1 0.3 0.4 0.8 1.0} \ {1.0 2.1 2.2 4.11 4.12}] set yvalues {} foreach x {0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 1.0} { lappend yvalues [::math::interpolate::interp-cubic-splines $coeffs $x] } set yvalues } -result {1.0 1.6804411764705884 2.1 2.2 2.5380974264705882 3.1041911764705885 3.695689338235294 4.11 4.2099448529411765 4.12} test "cubic-splines-2.1" "Too few data" \ -match glob -body { set xcoord {1 2} set ycoord {1 4} set coeffs [::math::interpolate::prepare-cubic-splines $xcoord $ycoord] } -result "At least *" -returnCodes error test "cubic-splines-2.2" "Unequal lengths" \ -match glob -body { set xcoord {1 2 4 5} set ycoord {1 4 5 5 6} set coeffs [::math::interpolate::prepare-cubic-splines $xcoord $ycoord] } -result "Equal number *" -returnCodes error test "cubic-splines-2.3" "Not-ascending x-coordinates" \ -match glob -body { set xcoord {1 2 1.5} set ycoord {1 4 5} set coeffs [::math::interpolate::prepare-cubic-splines $xcoord $ycoord] } -result "* ascending" -returnCodes error test "cubic-splines-2.4" "X too small" \ -match glob -body { set xcoord {1 2 3} set ycoord {1 4 5} set coeffs [::math::interpolate::prepare-cubic-splines $xcoord $ycoord] set yvalue [::math::interpolate::interp-cubic-splines $coeffs -1] } -result "* too small" -returnCodes error test "cubic-splines-2.5" "X too large" \ -match glob -body { set xcoord {1 2 3} set ycoord {1 4 5} set coeffs [::math::interpolate::prepare-cubic-splines $xcoord $ycoord] set yvalue [::math::interpolate::interp-cubic-splines $coeffs 6] } -result "* too large" -returnCodes error # ------------------------------------------------------------------------- testsuiteCleanup # Local Variables: # mode: tcl # End: tcllib-1.15/modules/math/polynomials.man0000755000175000017500000001266112077663116017715 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin math::polynomials n 1.0.1] [copyright {2004 Arjen Markus }] [moddesc {Tcl Math Library}] [titledesc {Polynomial functions}] [category Mathematics] [require Tcl [opt 8.3]] [require math::polynomials [opt 1.0.1]] [description] [para] This package deals with polynomial functions of one variable: [list_begin itemized] [item] the basic arithmetic operations are extended to polynomials [item] computing the derivatives and primitives of these functions [item] evaluation through a general procedure or via specific procedures) [list_end] [section "PROCEDURES"] The package defines the following public procedures: [list_begin definitions] [call [cmd ::math::polynomials::polynomial] [arg coeffs]] Return an (encoded) list that defines the polynomial. A polynomial [example { f(x) = a + b.x + c.x**2 + d.x**3 }] can be defined via: [example { set f [::math::polynomials::polynomial [list $a $b $c $d] }] [list_begin arguments] [arg_def list coeffs] Coefficients of the polynomial (in ascending order) [list_end] [para] [call [cmd ::math::polynomials::polynCmd] [arg coeffs]] Create a new procedure that evaluates the polynomial. The name of the polynomial is automatically generated. Useful if you need to evualuate the polynomial many times, as the procedure consists of a single [lb]expr[rb] command. [list_begin arguments] [arg_def list coeffs] Coefficients of the polynomial (in ascending order) or the polynomial definition returned by the [emph polynomial] command. [list_end] [para] [call [cmd ::math::polynomials::evalPolyn] [arg polynomial] [arg x]] Evaluate the polynomial at x. [list_begin arguments] [arg_def list polynomial] The polynomial's definition (as returned by the polynomial command). order) [arg_def float x] The coordinate at which to evaluate the polynomial [list_end] [para] [call [cmd ::math::polynomials::addPolyn] [arg polyn1] [arg polyn2]] Return a new polynomial which is the sum of the two others. [list_begin arguments] [arg_def list polyn1] The first polynomial operand [arg_def list polyn2] The second polynomial operand [list_end] [para] [call [cmd ::math::polynomials::subPolyn] [arg polyn1] [arg polyn2]] Return a new polynomial which is the difference of the two others. [list_begin arguments] [arg_def list polyn1] The first polynomial operand [arg_def list polyn2] The second polynomial operand [list_end] [para] [call [cmd ::math::polynomials::multPolyn] [arg polyn1] [arg polyn2]] Return a new polynomial which is the product of the two others. If one of the arguments is a scalar value, the other polynomial is simply scaled. [list_begin arguments] [arg_def list polyn1] The first polynomial operand or a scalar [arg_def list polyn2] The second polynomial operand or a scalar [list_end] [para] [call [cmd ::math::polynomials::divPolyn] [arg polyn1] [arg polyn2]] Divide the first polynomial by the second polynomial and return the result. The remainder is dropped [list_begin arguments] [arg_def list polyn1] The first polynomial operand [arg_def list polyn2] The second polynomial operand [list_end] [para] [call [cmd ::math::polynomials::remainderPolyn] [arg polyn1] [arg polyn2]] Divide the first polynomial by the second polynomial and return the remainder. [list_begin arguments] [arg_def list polyn1] The first polynomial operand [arg_def list polyn2] The second polynomial operand [list_end] [para] [call [cmd ::math::polynomials::derivPolyn] [arg polyn]] Differentiate the polynomial and return the result. [list_begin arguments] [arg_def list polyn] The polynomial to be differentiated [list_end] [para] [call [cmd ::math::polynomials::primitivePolyn] [arg polyn]] Integrate the polynomial and return the result. The integration constant is set to zero. [list_begin arguments] [arg_def list polyn] The polynomial to be integrated [list_end] [para] [call [cmd ::math::polynomials::degreePolyn] [arg polyn]] Return the degree of the polynomial. [list_begin arguments] [arg_def list polyn] The polynomial to be examined [list_end] [para] [call [cmd ::math::polynomials::coeffPolyn] [arg polyn] [arg index]] Return the coefficient of the term of the index'th degree of the polynomial. [list_begin arguments] [arg_def list polyn] The polynomial to be examined [arg_def int index] The degree of the term [list_end] [para] [call [cmd ::math::polynomials::allCoeffsPolyn] [arg polyn]] Return the coefficients of the polynomial (in ascending order). [list_begin arguments] [arg_def list polyn] The polynomial in question [list_end] [list_end] [section "REMARKS ON THE IMPLEMENTATION"] The implementation for evaluating the polynomials at some point uses Horn's rule, which guarantees numerical stability and a minimum of arithmetic operations. To recognise that a polynomial definition is indeed a correct definition, it consists of a list of two elements: the keyword "POLYNOMIAL" and the list of coefficients in descending order. The latter makes it easier to implement Horner's rule. [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph {math :: polynomials}] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords math "polynomial functions"] [manpage_end] tcllib-1.15/modules/math/interpolate.man0000755000175000017500000001777612077663116017711 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin math::interpolate n 1.0.2] [copyright {2004 Arjen Markus }] [copyright {2004 Kevn B. Kenny }] [moddesc {Tcl Math Library}] [titledesc {Interpolation routines}] [category Mathematics] [require Tcl [opt 8.4]] [require struct] [require math::interpolate [opt 1.0.2]] [description] [para] This package implements several interpolation algorithms: [list_begin itemized] [item] Interpolation into a table (one or two independent variables), this is useful for example, if the data are static, like with tables of statistical functions. [item] Linear interpolation into a given set of data (organised as (x,y) pairs). [item] Lagrange interpolation. This is mainly of theoretical interest, because there is no guarantee about error bounds. One possible use: if you need a line or a parabola through given points (it will calculate the values, but not return the coefficients). [para] A variation is Neville's method which has better behaviour and error bounds. [item] Spatial interpolation using a straightforward distance-weight method. This procedure allows any number of spatial dimensions and any number of dependent variables. [item] Interpolation in one dimension using cubic splines. [list_end] [para] This document describes the procedures and explains their usage. [section "PROCEDURES"] The interpolation package defines the following public procedures: [list_begin definitions] [call [cmd ::math::interpolate::defineTable] [arg name] [arg colnames] [arg values]] Define a table with one or two independent variables (the distinction is implicit in the data). The procedure returns the name of the table - this name is used whenever you want to interpolate the values. [emph Note:] this procedure is a convenient wrapper for the struct::matrix procedure. Therefore you can access the data at any location in your program. [list_begin arguments] [arg_def string name in] Name of the table to be created [arg_def list colnames in] List of column names [arg_def list values in] List of values (the number of elements should be a multiple of the number of columns. See [sectref EXAMPLES] for more information on the interpretation of the data. [para] The values must be sorted with respect to the independent variable(s). [list_end] [para] [call [cmd ::math::interpolate::interp-1d-table] [arg name] [arg xval]] Interpolate into the one-dimensional table "name" and return a list of values, one for each dependent column. [list_begin arguments] [arg_def string name in] Name of an existing table [arg_def float xval in] Value of the independent [emph row] variable [list_end] [para] [call [cmd ::math::interpolate::interp-table] [arg name] [arg xval] [arg yval]] Interpolate into the two-dimensional table "name" and return the interpolated value. [list_begin arguments] [arg_def string name in] Name of an existing table [arg_def float xval in] Value of the independent [emph row] variable [arg_def float yval in] Value of the independent [emph column] variable [list_end] [para] [call [cmd ::math::interpolate::interp-linear] [arg xyvalues] [arg xval]] Interpolate linearly into the list of x,y pairs and return the interpolated value. [list_begin arguments] [arg_def list xyvalues in] List of pairs of (x,y) values, sorted to increasing x. They are used as the breakpoints of a piecewise linear function. [arg_def float xval in] Value of the independent variable for which the value of y must be computed. [list_end] [para] [call [cmd ::math::interpolate::interp-lagrange] [arg xyvalues] [arg xval]] Use the list of x,y pairs to construct the unique polynomial of lowest degree that passes through all points and return the interpolated value. [list_begin arguments] [arg_def list xyvalues in] List of pairs of (x,y) values [arg_def float xval in] Value of the independent variable for which the value of y must be computed. [list_end] [para] [call [cmd ::math::interpolate::prepare-cubic-splines] [arg xcoord] [arg ycoord]] Returns a list of coefficients for the second routine [emph interp-cubic-splines] to actually interpolate. [list_begin arguments] [arg_def list xcoord] List of x-coordinates for the value of the function to be interpolated is known. The coordinates must be strictly ascending. At least three points are required. [arg_def list ycoord] List of y-coordinates (the values of the function at the given x-coordinates). [list_end] [para] [call [cmd ::math::interpolate::interp-cubic-splines] [arg coeffs] [arg x]] Returns the interpolated value at coordinate x. The coefficients are computed by the procedure [emph prepare-cubic-splines]. [list_begin arguments] [arg_def list coeffs] List of coefficients as returned by prepare-cubic-splines [arg_def float x] x-coordinate at which to estimate the function. Must be between the first and last x-coordinate for which values were given. [list_end] [para] [call [cmd ::math::interpolate::interp-spatial] [arg xyvalues] [arg coord]] Use a straightforward interpolation method with weights as function of the inverse distance to interpolate in 2D and N-dimensional space [para] The list xyvalues is a list of lists: [example { { {x1 y1 z1 {v11 v12 v13 v14}} {x2 y2 z2 {v21 v22 v23 v24}} ... } }] The last element of each inner list is either a single number or a list in itself. In the latter case the return value is a list with the same number of elements. [para] The method is influenced by the search radius and the power of the inverse distance [list_begin arguments] [arg_def list xyvalues in] List of lists, each sublist being a list of coordinates and of dependent values. [arg_def list coord in] List of coordinates for which the values must be calculated [list_end] [para] [call [cmd ::math::interpolate::interp-spatial-params] [arg max_search] [arg power]] Set the parameters for spatial interpolation [list_begin arguments] [arg_def float max_search in] Search radius (data points further than this are ignored) [arg_def integer power in] Power for the distance (either 1 or 2; defaults to 2) [list_end] [call [cmd ::math::interpolate::neville] [arg xlist] [arg ylist] [arg x]] Interpolates between the tabulated values of a function whose abscissae are [arg xlist] and whose ordinates are [arg ylist] to produce an estimate for the value of the function at [arg x]. The result is a two-element list; the first element is the function's estimated value, and the second is an estimate of the absolute error of the result. Neville's algorithm for polynomial interpolation is used. Note that a large table of values will use an interpolating polynomial of high degree, which is likely to result in numerical instabilities; one is better off using only a few tabulated values near the desired abscissa. [list_end] [section EXAMPLES] [emph TODO] Example of using the cubic splines: [para] Suppose the following values are given: [example { x y 0.1 1.0 0.3 2.1 0.4 2.2 0.8 4.11 1.0 4.12 }] Then to estimate the values at 0.1, 0.2, 0.3, ... 1.0, you can use: [example { set coeffs [::math::interpolate::prepare-cubic-splines \ {0.1 0.3 0.4 0.8 1.0} \ {1.0 2.1 2.2 4.11 4.12}] foreach x {0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 1.0} { puts "$x: [::math::interpolate::interp-cubic-splines $coeffs $x]" } }] to get the following output: [example { 0.1: 1.0 0.2: 1.68044117647 0.3: 2.1 0.4: 2.2 0.5: 3.11221507353 0.6: 4.25242647059 0.7: 5.41804227941 0.8: 4.11 0.9: 3.95675857843 1.0: 4.12 }] As you can see, the values at the abscissae are reproduced perfectly. [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph {math :: interpolate}] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords math interpolation "spatial interpolation"] [manpage_end] tcllib-1.15/modules/math/bigfloat2.test0000644000175000017500000005144412077663116017423 0ustar sergeisergei# -*- tcl -*- ######################################################################## # BigFloat for Tcl # Copyright (C) 2003-2005 ARNOLD Stephane # This software is covered by tcllib's license terms. # See the "license.terms" provided with tcllib. ######################################################################## # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 support { useLocal math.tcl math } testing { useLocal bigfloat2.tcl math::bigfloat } # ------------------------------------------------------------------------- namespace import ::math::bigfloat::* # ------------------------------------------------------------------------- proc assert {name version code result} { tcltest::test bigfloat-$name-$version "Some integer computations related to command $name" {uplevel 1 $code} $result return } interp alias {} zero {} string repeat 0 # S.ARNOLD 08/01/2005 # trying to set the precision of the comparisons to 15 digits set old_precision $::tcl_precision set ::tcl_precision 15 proc Zero {x} { global tcl_precision set x [expr {abs($x)}] set epsilon 10.0e-$tcl_precision return [expr {$x<$epsilon}] } proc fassert {name version code result} { #puts -nonewline $version, set tested [uplevel 1 $code] if {[Zero $tested]} { tcltest::test bigfloat-$name-$version "Some floating-point computations related to command $name" {return [Zero $result]} 1 return } set resultat [Zero [expr {($tested-$result)/((abs($tested)>1)?($tested):1.0)}]] tcltest::test bigfloat-$name-$version "Some floating-point computations related to command $name" {return $resultat} 1 return } # preprocessing is done #set n ###################################################### # Begin testsuite ###################################################### proc testSuite {} { # adds 999..9 and 1 -> 1000..0 for {set i 1} {$i<15} {incr i} { assert add 1.0 {tostr [add \ [fromstr [string repeat 999 $i]] [fromstr 1]] } 1[string repeat 000 $i] } # sub 1000..0 1 -> 999..9 for {set i 1} {$i<15} {incr i} { assert sub 1.1 {tostr [sub [fromstr 1[string repeat 000 $i]] [fromstr 1]]} \ [string repeat 999 $i] } # mul 10001000..1000 with 1..9 for {set i 1} {$i<15} {incr i} { foreach j {1 2 3 4 5 6 7 8 9} { assert mul 1.2 {tostr [mul [fromstr [string repeat 1000 $i]] [fromstr $j]]} \ [string repeat ${j}000 $i] } } # div 10^8 by 1 .. 9 for {set i 1} {$i<=9} {incr i} { assert div 1.3 {tostr [div [fromstr 100000000] [fromstr $i]]} [expr {wide(100000000)/$i}] } # 10^8 modulo 1 .. 9 for {set i 1} {$i<=9} {incr i} { assert mod 1.4 {tostr [mod [fromstr 100000000] [fromstr $i]]} [expr {wide(100000000)%$i}] } ################################################################################ # fromstr problem with octal exponents ################################################################################ fassert fromstr 2.0 {todouble [fromstr 1.0e+099]} 1.0e+099 fassert fromstr 2.0a {todouble [fromstr 1.0e99]} 1.0e99 fassert fromstr 2.0b {todouble [fromstr 1.0e-99]} 1.0e-99 fassert fromstr 2.0c {todouble [fromstr 1.0e-099]} 1.0e-99 ################################################################################ # fromdouble with precision ################################################################################ assert fromdouble 2.1 {tostr [ceil [fromdouble 1.0e99 100]]} 1[zero 99] assert fromdouble 2.1a {tostr [fromdouble 1.11 3]} 1.11 assert fromdouble 2.1b {tostr [fromdouble +1.11 3]} 1.11 assert fromdouble 2.1c {tostr [fromdouble -1.11 3]} -1.11 assert fromdouble 2.1d {tostr [fromdouble +01.11 3]} 1.11 assert fromdouble 2.1e {tostr [fromdouble -01.11 3]} -1.11 # more to come... fassert fromdouble 2.1f {compare [fromdouble [expr {atan(1.0)*4}]] [pi $::tcl_precision]} 0 ################################################################################ # abs() ################################################################################ proc absTest {version x {int 0}} { if {!$int} { fassert abs $version { tostr [abs [fromstr $x]] } [expr {abs($x)}] } else { assert abs $version { tostr [abs [fromstr $x]] } [expr {($x<0)?(-$x):$x}] } } absTest 2.2a 1.000 absTest 2.2b -1.000 absTest 2.2c -0.10 absTest 2.2d 0 1 absTest 2.2e 1 1 absTest 2.2f 10000 1 absTest 2.2g -1 1 absTest 2.2h -10000 1 rename absTest "" ################################################################################ # opposite ################################################################################ proc oppTest {version x {int 0}} { if {$int} { assert opp $version {tostr [opp [fromstr $x]]} [expr {-$x}] } else { fassert opp $version {tostr [opp [fromstr $x]]} [expr {-$x}] } } oppTest 2.3a 1.00 oppTest 2.3b -1.00 oppTest 2.3c 0.10 oppTest 2.3d -0.10 oppTest 2.3e 0.00 oppTest 2.3f 1 1 oppTest 2.3g -1 1 oppTest 2.3h 0 1 oppTest 2.3i 100000000 1 oppTest 2.3j -100000000 1 rename oppTest "" ################################################################################ # equal ################################################################################ proc equalTest {x y} { equal [fromstr $x] [fromstr $y] } assert equal 2.4a {equalTest 0.0 0.1} 1 assert equal 2.4b {equalTest 0.00 0.10} 0 assert equal 2.4c {equalTest 0.0 -0.1} 1 assert equal 2.4d {equalTest 0.00 -0.10} 0 rename equalTest "" ################################################################################ # compare ################################################################################ proc compareTest {x y} { compare [fromstr $x] [fromstr $y] } assert cmp 2.5a {compareTest 0.00 0.10} -1 assert cmp 2.5b {compareTest 0.1 0.4} -1 assert cmp 2.5c {compareTest 0.0 -1.0} 1 assert cmp 2.5d {compareTest -1.0 0.0} -1 assert cmp 2.5e {compareTest 0.00 0.10} -1 # cleanup rename compareTest "" ################################################################################ # round ################################################################################ proc roundTest {version x rounded} { assert round $version {tostr [round [fromstr $x]]} $rounded } roundTest 2.6a 0.10 0 roundTest 2.6b 0.0 0 roundTest 2.6c 0.50 1 roundTest 2.6d 0.40 0 roundTest 2.6e 1.0 1 roundTest 2.6d -0.40 0 roundTest 2.6e -0.50 -1 roundTest 2.6f -1.0 -1 roundTest 2.6g -1.50 -2 roundTest 2.6h 1.50 2 roundTest 2.6i 0.49 0 roundTest 2.6j -0.49 0 roundTest 2.6k 1.49 1 roundTest 2.6l -1.49 -1 # cleanup rename roundTest "" ################################################################################ # floor ################################################################################ proc floorTest {version x} { assert floor $version {tostr [floor [fromstr $x]]} [expr {int(floor($x))}] } floorTest 2.7a 0.10 floorTest 2.7b 0.90 floorTest 2.7c 1.0 floorTest 2.7d -0.10 floorTest 2.7e -1.0 # cleanup rename floorTest "" ################################################################################ # ceil ################################################################################ proc ceilTest {version x} { assert ceil $version {tostr [ceil [fromstr $x]]} [expr {int(ceil($x))}] } ceilTest 2.8a 0.10 ceilTest 2.8b 0.90 ceilTest 2.8c 1.0 ceilTest 2.8d -0.10 ceilTest 2.8e -1.0 ceilTest 2.8f 0.0 # cleanup rename ceilTest "" ################################################################################ # BigInt to BigFloat conversion ################################################################################ proc convTest {version x {decimals 1}} { assert int2float $version {tostr [int2float [fromstr $x] $decimals]} \ $x.[string repeat 0 [expr {$decimals-1}]] } set subversion 0 foreach decimals {1 2 5 10 100} { set version 2.9.$subversion fassert int2float $version.0 {tostr [int2float [fromstr 0] $decimals]} 0.0 convTest $version.1 1 $decimals convTest $version.2 5 $decimals convTest $version.3 5000000000 $decimals incr subversion } #cleanup rename convTest "" ################################################################################ # addition ################################################################################ proc addTest {version x y} { fassert add $version {todouble [add [fromstr $x] [fromstr $y]]} [expr {$x+$y}] } addTest 3.0a 1.00 2.00 addTest 3.0b -1.00 2.00 addTest 3.0c 1.00 -2.00 addTest 3.0d -1.00 -2.00 addTest 3.0e 0.00 1.00 addTest 3.0f 0.00 -1.00 addTest 3.0g 1 2.00 addTest 3.0h 1 -2.00 addTest 3.0i 0 1.00 addTest 3.0j 0 -1.00 addTest 3.0k 2.00 1 addTest 3.0l -2.00 1 addTest 3.0m 1.00 0 addTest 3.0n -1.00 0 #cleanup rename addTest "" ################################################################################ # substraction ################################################################################ proc subTest {version x y} { fassert sub $version {todouble [sub [fromstr $x] [fromstr $y]]} [expr {$x-$y}] } subTest 3.1a 1.00 2.00 subTest 3.1b -1.00 2.00 subTest 3.1c 1.00 -2.00 subTest 3.1d -1.00 -2.00 subTest 3.1e 0.00 1.00 subTest 3.1f 0.00 -1.00 subTest 3.1g 1 2.00 subTest 3.1h 1 -2.00 subTest 3.1i 0 2.00 subTest 3.1j 0 -2.00 subTest 3.1k 2 0.00 subTest 3.1l 2.00 1 subTest 3.1m 1.00 2 subTest 3.1n -1.00 1 subTest 3.1o 0.00 2 subTest 3.1p 2.00 0 # cleanup rename subTest "" ################################################################################ # multiplication ################################################################################ proc mulTest {version x y} { fassert mul $version {todouble [mul [fromstr $x] [fromstr $y]]} [expr {$x*$y}] } proc mulInt {version x y} { mulTest $version.0 $x $y mulTest $version.1 $y $x } mulTest 3.2a 1.00 2.00 mulTest 3.2b -1.00 2.00 mulTest 3.2c 1.00 -2.00 mulTest 3.2d -1.00 -2.00 mulTest 3.2e 0.00 1.00 mulTest 3.2f 0.00 -1.00 mulTest 3.2g 1.00 10.0 mulInt 3.2h 1 2.00 mulInt 3.2i 1 -2.00 mulInt 3.2j 0 2.00 mulInt 3.2k 0 -2.00 mulInt 3.2l 10 2.00 mulInt 3.2m 10 -2.00 mulInt 3.2n 1 0.00 # cleanup rename mulTest "" rename mulInt "" ################################################################################ # division ################################################################################ proc divTest {version x y} { fassert div $version { string trimright [todouble [div [fromstr $x] [fromstr $y]]] 0 } [string trimright [expr {$x/$y}] 0] } divTest 3.3a 1.00 2.00 divTest 3.3b 2.00 1.00 divTest 3.3c -1.00 2.00 divTest 3.3d 1.00 -2.00 divTest 3.3e 2.00 -1.00 divTest 3.3f -2.00 1.00 divTest 3.3g -1.00 -2.00 divTest 3.3h -2.00 -1.00 divTest 3.3i 0.0 1.0 divTest 3.3j 0.0 -1.0 # cleanup rename divTest "" ################################################################################ # rest of the division ################################################################################ proc modTest {version x y} { fassert mod $version { todouble [mod [fromstr $x] [fromstr $y]] } [expr {fmod($x,$y)}] } modTest 3.4a 1.00 2.00 modTest 3.4b 2.00 1.00 modTest 3.4c -1.00 2.00 modTest 3.4d 1.00 -2.00 modTest 3.4e 2.00 -1.00 modTest 3.4f -2.00 1.00 modTest 3.4g -1.00 -2.00 modTest 3.4h -2.00 -1.00 modTest 3.4i 0.0 1.0 modTest 3.4j 0.0 -1.0 modTest 3.4k 1.00 2 modTest 3.4l 2.00 1 modTest 3.4m -1.00 2 modTest 3.4n -2.00 1 modTest 3.4o 0.0 1 modTest 3.4p 1.50 1 # cleanup rename modTest "" ################################################################################ # divide a BigFloat by an integer ################################################################################ proc divTest {version x y} { fassert div $version {todouble [div [fromstr $x] [fromstr $y]]} \ [expr {double(round(1000*$x/$y))/1000.0}] } set subversion 0 foreach a {1.0000 -1.0000} { foreach b {2 3} { divTest 3.5.$subversion $a $b incr subversion } } # cleanup rename divTest "" ################################################################################ # pow : takes a float to an integer power (>0) ################################################################################ proc powTest {version x y {int 0}} { if {!$int} { fassert pow $version {todouble [pow [fromstr $x 14] [fromstr $y]]}\ [expr [join [string repeat "[string trimright $x 0] " $y] *]] } else { assert pow $version {tostr [pow [fromstr $x] [fromstr $y]]}\ [expr [join [string repeat "$x " $y] *]] } } set subversion 0 foreach a {1 -1 2 -2 5 -5} { foreach b {2 3 7 16} { powTest 3.6.$subversion $a. $b incr subversion } } set subversion 0 foreach a {1 2 3} { foreach b {2 3 5 8} { powTest 3.7.$subversion $a $b 1 incr subversion } } # cleanup rename powTest "" ################################################################################ # pi constant and angles conversion ################################################################################ fassert pi 3.8.0 {todouble [pi 16]} [expr {atan(1)*4}] # converts Pi -> 180° fassert rad2deg 3.8.1 {todouble [rad2deg [pi 20]]} 180.0 # converts 180° -> Pi fassert deg2rad 3.8.2 {todouble [deg2rad [fromstr 180.0 20]]} [expr {atan(1.0)*4}] ################################################################################ # iszero : the precision is too small to determinate the number ################################################################################ assert iszero 4.0a {iszero [fromstr 0]} 1 assert iszero 4.0b {iszero [fromstr 0.0]} 1 assert iszero 4.0c {iszero [fromstr 1]} 0 assert iszero 4.0d {iszero [fromstr 1.0]} 0 assert iszero 4.0e {iszero [fromstr -1]} 0 assert iszero 4.0f {iszero [fromstr -1.0]} 0 ################################################################################ # sqrt : square root ################################################################################ proc sqrtTest {version x} { fassert sqrt $version {todouble [sqrt [fromstr $x 18]]} [expr {sqrt($x)}] } sqrtTest 4.1a 1. sqrtTest 4.1b 0.001 sqrtTest 4.1c 0.004 sqrtTest 4.1d 4. # cleanup rename sqrtTest "" ################################################################################ # expTest : exponential function ################################################################################ proc expTest {version x} { fassert exp $version {todouble [exp [fromstr $x 17]]} [expr {exp($x)}] } expTest 4.2a 1. expTest 4.2b 0.001 expTest 4.2c 0.004 expTest 4.2d 40. expTest 4.2e -0.001 # cleanup rename expTest "" ################################################################################ # logTest : logarithm ################################################################################ proc logTest {version x} { fassert log $version {todouble [log [fromstr $x 17]]} [expr {log($x)}] } logTest 4.3a 1.0 logTest 4.3b 0.001 logTest 4.3c 0.004 logTest 4.3d 40. logTest 4.3e 1[zero 10].0 # cleanup rename logTest "" ################################################################################ # cos & sin : trigonometry ################################################################################ proc cosEtSin {version quartersOfPi} { set x [div [mul [pi 18] [fromstr $quartersOfPi]] [fromstr 4]] #fassert cos {todouble [cos $x]} [expr {cos(atan(1)*$quartersOfPi)}] #fassert sin {todouble [sin $x]} [expr {sin(atan(1)*$quartersOfPi)}] fassert cos $version.0 {todouble [cos $x]} [expr {cos([todouble $x])}] fassert sin $version.1 {todouble [sin $x]} [expr {sin([todouble $x])}] } fassert cos 4.4.0.0 {todouble [cos [fromstr 0. 17]]} [expr {cos(0)}] fassert sin 4.4.0.1 {todouble [sin [fromstr 0. 17]]} [expr {sin(0)}] foreach i {1 2 3 4 5 6 7 8} { cosEtSin 4.4.$i $i } # cleanup rename cosEtSin "" ################################################################################ # tan & cotan : trigonometry ################################################################################ proc tanCotan {version i} { upvar pi pi set x [div [mul $pi [fromstr $i]] [fromstr 10]] set double [expr {atan(1)*(double($i)*0.4)}] fassert cos $version.0 {todouble [cos $x]} [expr {cos($double)}] fassert sin $version.1 {todouble [sin $x]} [expr {sin($double)}] fassert tan $version.2 {todouble [tan $x]} [expr {tan($double)}] fassert cotan $version.3 {todouble [cotan $x]} [expr {double(1.0)/tan($double)}] } set pi [pi 20] set subversion 0 foreach i {1 2 3 6 7 8 9} { tanCotan 4.5.$subversion $i incr subversion } # cleanup rename tanCotan "" ################################################################################ # atan , asin & acos : trigonometry (inverse functions) ################################################################################ proc atanTest {version x} { set f [fromstr $x 20] fassert atan $version.0 {todouble [atan $f]} [expr {atan($x)}] if {abs($x)<=1.0} { fassert acos $version.1 {todouble [acos $f]} [expr {acos($x)}] fassert asin $version.2 {todouble [asin $f]} [expr {asin($x)}] } } set subversion 0 atanTest 4.6.0.0 0.0 foreach i {1 2 3 4 5 6 7 8 9} { atanTest 4.6.1.$subversion 0.$i atanTest 4.6.2.$subversion $i.0 atanTest 4.6.3.$subversion -0.$i atanTest 4.6.4.$subversion -$i.0 incr subversion } # cleanup rename atanTest "" ################################################################################ # cosh , sinh & tanh : hyperbolic functions ################################################################################ proc hyper {version x} { set f [fromstr $x 18] fassert cosh $version.0 {todouble [cosh $f]} [expr {cosh($x)}] fassert sinh $version.1 {todouble [sinh $f]} [expr {sinh($x)}] fassert tanh $version.2 {todouble [tanh $f]} [expr {tanh($x)}] } hyper 4.7.0 0.0 set subversion 0 foreach i {1 2 3 4 5 6 7 8 9} { hyper 4.7.1.$subversion 0.$i hyper 4.7.2.$subversion $i.0 hyper 4.7.3.$subversion -0.$i hyper 4.7.4.$subversion -$i.0 } # cleanup rename hyper "" ################################################################################ # tostr with -nosci option ################################################################################ set version 5.0 fassert tostr-nosci $version.0 {tostr -nosci [fromstr 23450.e+7]} 234500000000. fassert tostr-nosci $version.1 {tostr -nosci [fromstr 23450.e-7]} 0.002345 fassert tostr-nosci $version.2 {tostr -nosci [fromstr 23450000]} 23450000. fassert tostr-nosci $version.3 {tostr -nosci [fromstr 2345.0]} 2345. } testSuite ################################################################################ # end of testsuite for bigfloat 1.0 ################################################################################ # cleanup global procs rename assert "" rename fassert "" rename Zero "" testsuiteCleanup set ::tcl_precision $old_precision tcllib-1.15/modules/math/machineparameters.test0000755000175000017500000000173512077663116021243 0ustar sergeisergei# machineparameters.test -- # Unit tests for machineparameters.tcl # # # Copyright 2008 Michael Baudin # # # Startup unit tests # package require tcltest tcltest::configure -verbose {start body error pass} set basedir [file dirname [info script]] lappend ::auto_path $basedir package require math::machineparameters # # Check all parameters are there # tcltest::test checkall {check epsilon, rounding mode} { set pp [machineparameters create %AUTO%] $pp configure -verbose 0 $pp compute set epsilon [$pp get -epsilon] set rounding [$pp get -rounding] set basis [$pp get -basis] set mantissa [$pp get -mantissa] set emax [$pp get -exponentmax] #$pp print $pp destroy set res {} # The following property on epsilon must hold false (yes : epsilon is THAT small !) lappend res [expr {1.0+$epsilon>1.0}] lappend res [expr {$rounding!=""}] lappend res [expr {$basis> 1}] lappend res [expr {$mantissa> 1}] } {0 1 1 1} # # Shutdown tests # tcltest::cleanupTests tcllib-1.15/modules/math/interpolate.tcl0000755000175000017500000004047312077663116017706 0ustar sergeisergei# interpolate.tcl -- # # Package for interpolation methods (one- and two-dimensional) # # Remarks: # None of the methods deal gracefully with missing values # # To do: # Add B-splines as methods # For spatial interpolation in two dimensions also quadrant method? # Method for destroying a table # Proper documentation # Proper test cases # # version 0.1: initial implementation, january 2003 # version 0.2: added linear and Lagrange interpolation, straightforward # spatial interpolation, april 2004 # version 0.3: added Neville algorithm. # version 1.0: added cubic splines, september 2004 # # Copyright (c) 2004 by Arjen Markus. All rights reserved. # Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: interpolate.tcl,v 1.10 2009/10/22 18:19:52 arjenmarkus Exp $ # #---------------------------------------------------------------------- package require Tcl 8.4 package require struct::matrix # ::math::interpolate -- # Namespace holding the procedures and variables # namespace eval ::math::interpolate { variable search_radius {} variable inv_dist_pow 2 namespace export interp-1d-table interp-table interp-linear \ interp-lagrange namespace export neville } # defineTable -- # Define a two-dimensional table of data # # Arguments: # name Name of the table to be created # cols Names of the columns (for convenience and for counting) # values List of values to fill the table with (must be sorted # w.r.t. first column or first column and first row) # # Results: # Name of the new command # # Side effects: # Creates a new command, which is used in subsequent calls # proc ::math::interpolate::defineTable { name cols values } { set table ::math::interpolate::__$name ::struct::matrix $table $table add columns [llength $cols] $table add row $table set row 0 $cols set row 1 set first 0 set nocols [llength $cols] set novals [llength $values] while { $first < $novals } { set last [expr {$first+$nocols-1}] $table add row $table set row $row [lrange $values $first $last] incr first $nocols incr row } return $table } # inter-1d-table -- # Interpolate in a one-dimensional table # (first column is independent variable, all others dependent) # # Arguments: # table Name of the table # xval Value of the independent variable # # Results: # List of interpolated values, including the x-variable # proc ::math::interpolate::interp-1d-table { table xval } { # # Search for the records that enclose the x-value # set xvalues [lrange [$table get column 0] 1 end] foreach {row row2} [FindEnclosingEntries $xval $xvalues] break set prev_values [$table get row $row] set next_values [$table get row $row2] set xprev [lindex $prev_values 0] set xnext [lindex $next_values 0] if { $row == $row2 } { return [concat $xval [lrange $prev_values 1 end]] } else { set wprev [expr {($xnext-$xval)/($xnext-$xprev)}] set wnext [expr {1.0-$wprev}] set results {} foreach vprev $prev_values vnext $next_values { set vint [expr {$vprev*$wprev+$vnext*$wnext}] lappend results $vint } return $results } } # interp-table -- # Interpolate in a two-dimensional table # (first column and first row are independent variables) # # Arguments: # table Name of the table # xval Value of the independent row-variable # yval Value of the independent column-variable # # Results: # Interpolated value # # Note: # Use bilinear interpolation # proc ::math::interpolate::interp-table { table xval yval } { # # Search for the records that enclose the x-value # set xvalues [lrange [$table get column 0] 2 end] foreach {row row2} [FindEnclosingEntries $xval $xvalues] break incr row incr row2 # # Search for the columns that enclose the y-value # set yvalues [lrange [$table get row 1] 1 end] foreach {col col2} [FindEnclosingEntries $yval $yvalues] break set yvalues [concat "." $yvalues] ;# Prepend a dummy column! set prev_values [$table get row $row] set next_values [$table get row $row2] set x1 [lindex $prev_values 0] set x2 [lindex $next_values 0] set y1 [lindex $yvalues $col] set y2 [lindex $yvalues $col2] set v11 [lindex $prev_values $col] set v12 [lindex $prev_values $col2] set v21 [lindex $next_values $col] set v22 [lindex $next_values $col2] # # value = v0 + a*(x-x1) + b*(y-y1) + c*(x-x1)*(y-y1) # if x == x1 and y == y1: value = v11 # if x == x1 and y == y2: value = v12 # if x == x2 and y == y1: value = v21 # if x == x2 and y == y2: value = v22 # set a 0.0 if { $x1 != $x2 } { set a [expr {($v21-$v11)/($x2-$x1)}] } set b 0.0 if { $y1 != $y2 } { set b [expr {($v12-$v11)/($y2-$y1)}] } set c 0.0 if { $x1 != $x2 && $y1 != $y2 } { set c [expr {($v11+$v22-$v12-$v21)/($x2-$x1)/($y2-$y1)}] } set result \ [expr {$v11+$a*($xval-$x1)+$b*($yval-$y1)+$c*($xval-$x1)*($yval-$y1)}] return $result } # FindEnclosingEntries -- # Search within a sorted list # # Arguments: # val Value to be searched # values List of values to be examined # # Results: # Returns a list of the previous and next indices # proc FindEnclosingEntries { val values } { set found 0 set row2 1 foreach v $values { if { $val <= $v } { set row [expr {$row2-1}] set found 1 break } incr row2 } # # Border cases: extrapolation needed # if { ! $found } { incr row2 -1 set row $row2 } if { $row == 0 } { set row $row2 } return [list $row $row2] } # interp-linear -- # Use linear interpolation # # Arguments: # xyvalues List of x/y values to be interpolated # xval x-value for which a value is sought # # Results: # Estimated value at $xval # # Note: # The list xyvalues must be sorted w.r.t. the x-value # proc ::math::interpolate::interp-linear { xyvalues xval } { # # Border cases first # if { [lindex $xyvalues 0] > $xval } { return [lindex $xyvalues 1] } if { [lindex $xyvalues end-1] < $xval } { return [lindex $xyvalues end] } # # The ordinary case # set idxx -2 set idxy -1 foreach { x y } $xyvalues { if { $xval < $x } { break } incr idxx 2 incr idxy 2 } set x2 [lindex $xyvalues $idxx] set y2 [lindex $xyvalues $idxy] if { $x2 != $x } { set yval [expr {$y+($y2-$y)*($xval-$x)/($x2-$x)}] } else { set yval $y } return $yval } # interp-lagrange -- # Use the Lagrange interpolation method # # Arguments: # xyvalues List of x/y values to be interpolated # xval x-value for which a value is sought # # Results: # Estimated value at $xval # # Note: # The list xyvalues must be sorted w.r.t. the x-value # Furthermore the Lagrange method is not a very practical # method, as potentially the errors are unbounded # proc ::math::interpolate::interp-lagrange { xyvalues xval } { # # Border case: xval equals one of the "nodes" # foreach { x y } $xyvalues { if { $x == $xval } { return $y } } # # Ordinary case # set nonodes2 [llength $xyvalues] set yval 0.0 for { set i 0 } { $i < $nonodes2 } { incr i 2 } { set idxn 0 set xn [lindex $xyvalues $i] set yn [lindex $xyvalues [expr {$i+1}]] foreach { x y } $xyvalues { if { $idxn != $i } { set yn [expr {$yn*($x-$xval)/($x-$xn)}] } incr idxn 2 } set yval [expr {$yval+$yn}] } return $yval } # interp-spatial -- # Use a straightforward interpolation method with weights as # function of the inverse distance to interpolate in 2D and N-D # space # # Arguments: # xyvalues List of coordinates and values at these coordinates # coord List of coordinates for which a value is sought # # Results: # Estimated value(s) at $coord # # Note: # The list xyvalues is a list of lists: # { {x1 y1 z1 {v11 v12 v13 v14} # {x2 y2 z2 {v21 v22 v23 v24} # ... # } # The last element of each inner list is either a single number # or a list in itself. In the latter case the return value is # a list with the same number of elements. # # The method is influenced by the search radius and the # power of the inverse distance # proc ::math::interpolate::interp-spatial { xyvalues coord } { variable search_radius variable inv_dist_pow set result {} foreach v [lindex [lindex $xyvalues 0] end] { lappend result 0.0 } set total_weight 0.0 if { $search_radius != {} } { set max_radius2 [expr {$search_radius*$search_radius}] } else { set max_radius2 {} } foreach point $xyvalues { set dist 0.0 foreach c [lrange $point 0 end-1] cc $coord { set dist [expr {$dist+($c-$cc)*($c-$cc)}] } if { $max_radius2 == {} || $dist <= $max_radius2 } { if { $inv_dist_pow == 1 } { set dist [expr {sqrt($dist)}] } set total_weight [expr {$total_weight+1.0/$dist}] set idx 0 foreach v [lindex $point end] r $result { lset result $idx [expr {$r+$v/$dist}] incr idx } } } if { $total_weight == 0.0 } { set idx 0 foreach r $result { lset result $idx {} incr idx } } else { set idx 0 foreach r $result { lset result $idx [expr {$r/$total_weight}] incr idx } } return $result } # interp-spatial-params -- # Set the parameters for spatial interpolation # # Arguments: # max_search Search radius (if none: use {} or "") # power Power for the inverse distance (1 or 2, defaults to 2) # # Results: # None # proc ::math::interpolate::interp-spatial-params { max_search {power 2} } { variable search_radius variable inv_dist_pow set search_radius $max_search if { $power == 1 } { set inv_dist_pow 1 } else { set inv_dist_pow 2 } } #---------------------------------------------------------------------- # # neville -- # # Interpolate a function between tabulated points using Neville's # algorithm. # # Parameters: # xtable - Table of abscissae. # ytable - Table of ordinates. Must be a list of the same # length as 'xtable.' # x - Abscissa for which the function value is desired. # # Results: # Returns a two-element list. The first element is the # requested ordinate. The second element is a rough estimate # of the absolute error, that is, the magnitude of the first # neglected term of a power series. # # Side effects: # None. # #---------------------------------------------------------------------- proc ::math::interpolate::neville { xtable ytable x } { set n [llength $xtable] # Initialization. Set c and d to the ordinates, and set ns to the # index of the nearest abscissa. Set y to the zero-order approximation # of the nearest ordinate, and dif to the difference between x # and the nearest tabulated abscissa. set c [list] set d [list] set i 0 set ns 0 set dif [expr { abs( $x - [lindex $xtable 0] ) }] set y [lindex $ytable 0] foreach xi $xtable yi $ytable { set dift [expr { abs ( $x - $xi ) }] if { $dift < $dif } { set ns $i set y $yi set dif $dift } lappend c $yi lappend d $yi incr i } # Compute successively higher-degree approximations to the fit # function by using the recurrence: # d_m[i] = ( c_{m-1}[i+1] - d{m-1}[i] ) * (x[i+m]-x) / # (x[i] - x[i+m]) # c_m[i] = ( c_{m-1}[i+1] - d{m-1}[i] ) * (x[i]-x) / # (x[i] - x[i+m]) for { set m 1 } { $m < $n } { incr m } { for { set i 0 } { $i < $n - $m } { set i $ip1 } { set ip1 [expr { $i + 1 }] set ipm [expr { $i + $m }] set ho [expr { [lindex $xtable $i] - $x }] set hp [expr { [lindex $xtable $ipm] - $x }] set w [expr { [lindex $c $ip1] - [lindex $d $i] }] set q [expr { $w / ( $ho - $hp ) }] lset d $i [expr { $hp * $q }] lset c $i [expr { $ho * $q }] } # Take the straighest path possible through the tableau of c # and d approximations back to the tabulated value if { 2 * $ns < $n - $m } { set dy [lindex $c $ns] } else { incr ns -1 set dy [lindex $d $ns] } set y [expr { $y + $dy }] } # Return the approximation and the highest-order correction term. return [list $y [expr { abs($dy) }]] } # prepare-cubic-splines -- # Prepare interpolation based on cubic splines # # Arguments: # xcoord The x-coordinates # ycoord Y-values for these x-coordinates # Result: # Intermediate parameters describing the spline function, # to be used in the second step, interp-cubic-splines. # Note: # Implicitly it is assumed that the function decribed by xcoord # and ycoord has a second derivative 0 at the end points. # To minimise the work if more than one value is needed, the # algorithm is divided in two steps # (Derived from the routine SPLINT in Davis and Rabinowitz: # Methods for Numerical Integration, AP, 1984) # proc ::math::interpolate::prepare-cubic-splines {xcoord ycoord} { if { [llength $xcoord] < 3 } { return -code error "At least three points are required" } if { [llength $xcoord] != [llength $ycoord] } { return -code error "Equal number of x and y values required" } set m2 [expr {[llength $xcoord]-1}] set s 0.0 set h {} set c {} for { set i 0 } { $i < $m2 } { incr i } { set ip1 [expr {$i+1}] set h1 [expr {[lindex $xcoord $ip1]-[lindex $xcoord $i]}] lappend h $h1 if { $h1 <= 0.0 } { return -code error "X values must be strictly ascending" } set r [expr {([lindex $ycoord $ip1]-[lindex $ycoord $i])/$h1}] lappend c [expr {$r-$s}] set s $r } set s 0.0 set r 0.0 set t {--} lset c 0 0.0 for { set i 1 } { $i < $m2 } { incr i } { set ip1 [expr {$i+1}] set im1 [expr {$i-1}] set y2 [expr {[lindex $c $i]+$r*[lindex $c $im1]}] set t1 [expr {2.0*([lindex $xcoord $im1]-[lindex $xcoord $ip1])-$r*$s}] set s [lindex $h $i] set r [expr {$s/$t1}] lset c $i $y2 lappend t $t1 } lappend c 0.0 for { set j 1 } { $j < $m2 } { incr j } { set i [expr {$m2-$j}] set ip1 [expr {$i+1}] set h1 [lindex $h $i] set yp1 [lindex $c $ip1] set y1 [lindex $c $i] set t1 [lindex $t $i] lset c $i [expr {($h1*$yp1-$y1)/$t1}] } set b {} set d {} for { set i 0 } { $i < $m2 } { incr i } { set ip1 [expr {$i+1}] set s [lindex $h $i] set yp1 [lindex $c $ip1] set y1 [lindex $c $i] set r [expr {$yp1-$y1}] lappend d [expr {$r/$s}] set y1 [expr {3.0*$y1}] lset c $i $y1 lappend b [expr {([lindex $ycoord $ip1]-[lindex $ycoord $i])/$s -($y1+$r)*$s}] } lappend d 0.0 lappend b 0.0 return [list $d $c $b $ycoord $xcoord] } # interp-cubic-splines -- # Interpolate based on cubic splines # # Arguments: # coeffs Coefficients resulting from the preparation step # x The x-coordinate for which to estimate the value # Result: # Interpolated value at x # proc ::math::interpolate::interp-cubic-splines {coeffs x} { foreach {dcoef ccoef bcoef acoef xcoord} $coeffs {break} # # Check the bounds - no extrapolation # if { $x < [lindex $xcoord 0] } {error "X value too small"} if { $x > [lindex $xcoord end] } {error "X value too large"} # # Which interval? # set idx -1 foreach xv $xcoord { if { $xv > $x } { break } incr idx } set a [lindex $acoef $idx] set b [lindex $bcoef $idx] set c [lindex $ccoef $idx] set d [lindex $dcoef $idx] set dx [expr {$x-[lindex $xcoord $idx]}] return [expr {(($d*$dx+$c)*$dx+$b)*$dx+$a}] } # # Announce our presence # package provide math::interpolate 1.0.3 tcllib-1.15/modules/math/fourier.test0000755000175000017500000000717512077663116017232 0ustar sergeisergei# -*- tcl -*- # fourier.test -- # Test cases for the Fourier transforms in the # ::math::fourier package # # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.2 testsNeedTcltest 2.1 support { useLocal math.tcl math } testing { useLocal fourier.tcl math::fourier } # ------------------------------------------------------------------------- namespace import ::math::fourier::* # ------------------------------------------------------------------------- proc matchComplex {expected actual} { set match 1 foreach a $actual e $expected { foreach {are aim} $a break foreach {ere eim} $e break if {abs($are-$ere) > 0.1e-8 || abs($aim-$eim) > 0.1e-8} { set match 0 break } } return $match } customMatch numbers matchComplex # ------------------------------------------------------------------------- test "dft-1.0" "Four numbers" \ -match numbers -body { dft {1 2 3 4} } -result {{10 0.0} {-2.0 2.0} {-2 0.0} {-2.0 -2.0}} test "dft-1.1" "Five numbers" \ -match numbers -body { dft {1 2 3 4 5} } -result {{15.0 0.0} {-2.5 3.44095480118} {-2.5 0.812299240582} {-2.5 -0.812299240582} {-2.5 -3.44095480118}} test "dft-1.2" "Four numbers - inverse" \ -match numbers -body { inverse_dft {{10 0.0} {-2.0 2.0} {-2 0.0} {-2.0 -2.0}} } -result {{1.0 0.0} {2.0 0.0} {3.0 0.0} {4.0 0.0}} test "dft-1.3" "Five numbers - inverse" \ -match numbers -body { inverse_dft {{15.0 0.0} {-2.5 3.44095480118} {-2.5 0.812299240582} {-2.5 -0.812299240582} {-2.5 -3.44095480118}} } -result {{1.0 0.0} {2.0 8.881784197e-17} {3.0 4.4408920985e-17} {4.0 4.4408920985e-17} {5.0 -8.881784197e-17}} # Testing to and from DFT # proc test_DFT {points {real 0} {iterations 20}} { set in_dataL [list] for {set k 0} {$k < $points} {incr k} { if {$real} then { lappend in_dataL [expr {2*rand()-1}] } else { lappend in_dataL [list [expr {2*rand()-1}] [expr {2*rand()-1}]] } } set time1 [time { set conv_dataL [dft $in_dataL] } $iterations] set time2 [time { set out_dataL [inverse_dft $conv_dataL] } $iterations] set err 0.0 foreach iz $in_dataL oz $out_dataL { if {$real} then { foreach {o1 o2} $oz {break} set err [expr {$err + ($i-$o1)*($i-$o1) + $o2*$o2}] } else { foreach i $iz o $oz { set err [expr {$err + ($i-$o)*($i-$o)}] } } } return [list $time1 $time2 [expr {sqrt($err/$points)}]] } test "dft-2.1" "10 numbers - to and from" \ -body { foreach {t1 t2 err} [test_DFT 10] break set small_error [expr {$err < 1.0e-10}] } -result 1 test "dft-2.2" "100 numbers - to and from" \ -body { foreach {t1 t2 err} [test_DFT 100] break set small_error [expr {$err < 1.0e-10}] } -result 1 test "dft-2.3" "DFT versus FFT" \ -body { foreach {dft1 dft2 err} [test_DFT 100] break foreach {fft1 fft2 err} [test_DFT 128] break set dft1 [lindex $dft1 0] set dft2 [lindex $dft2 0] set fft1 [lindex $fft1 0] set fft2 [lindex $fft2 0] # Expect a dramatic difference - at least factor 3! set fft_used [expr {$dft1 > 3.0*$fft1 && $dft2 > 3.0*$fft2}] } -result 1 test "dft-2.4" "1024 numbers - to and from" \ -body { foreach {t1 t2 err} [test_DFT 1024 0 1] break set small_error [expr {$err < 1.0e-10}] } -result 1 # TODO: tests for lowpass and highpass filters # End of test cases testsuiteCleanup tcllib-1.15/modules/math/numtheory.man0000644000175000017500000000402112077663116017365 0ustar sergeisergei[manpage_begin math::numtheory n 1.0] [copyright "2010 Lars Hellstr\u00F6m\ "] [moddesc {Tcl Math Library}] [titledesc {Number Theory}] [category Mathematics] [require Tcl [opt 8.5]] [require math::numtheory [opt 1.0]] [description] [para] This package is for collecting various number-theoretic operations, though at the moment it only provides that of testing whether an integer is a prime. [list_begin definitions] [call [cmd math::numtheory::isprime] [arg N] [ opt "[arg option] [arg value] ..." ]] The [cmd isprime] command tests whether the integer [arg N] is a prime, returning a boolean true value for prime [arg N] and a boolean false value for non-prime [arg N]. The formal definition of 'prime' used is the conventional, that the number being tested is greater than 1 and only has trivial divisors. [para] To be precise, the return value is one of [const 0] (if [arg N] is definitely not a prime), [const 1] (if [arg N] is definitely a prime), and [const on] (if [arg N] is probably prime); the latter two are both boolean true values. The case that an integer may be classified as "probably prime" arises because the Miller-Rabin algorithm used in the test implementation is basically probabilistic, and may if we are unlucky fail to detect that a number is in fact composite. Options may be used to select the risk of such "false positives" in the test. [const 1] is returned for "small" [arg N] (which currently means [arg N] < 118670087467), where it is known that no false positives are possible. [para] The only option currently defined is: [list_begin options] [opt_def -randommr [arg repetitions]] which controls how many times the Miller-Rabin test should be repeated with randomly chosen bases. Each repetition reduces the probability of a false positive by a factor at least 4. The default for [arg repetitions] is 4. [list_end] Unknown options are silently ignored. [list_end] [keywords {number theory} prime] [manpage_end] tcllib-1.15/modules/math/bigfloat2.tcl0000644000175000017500000024051612077663116017226 0ustar sergeisergei######################################################################## # BigFloat for Tcl # Copyright (C) 2003-2005 ARNOLD Stephane # It is published with the terms of tcllib's BSD-style license. # See the file named license.terms. ######################################################################## package require Tcl 8.5 # this line helps when I want to source this file again and again catch {namespace delete ::math::bigfloat} # private namespace # this software works only with Tcl v8.4 and higher # it is using the package math::bignum namespace eval ::math::bigfloat { # cached constants # ln(2) with arbitrary precision variable Log2 # Pi with arb. precision variable Pi variable _pi0 } ################################################################################ # procedures that handle floating-point numbers # these procedures are sorted by name (after eventually removing the underscores) # # BigFloats are internally represented as a list : # {"F" Mantissa Exponent Delta} where "F" is a character which determins # the datatype, Mantissa and Delta are two big integers and Exponent another integer. # # The BigFloat value equals to (Mantissa +/- Delta)*2^Exponent # So the internal representation is binary, but trying to get as close as possible to # the decimal one when converted to a string. # When calling [fromstr], the Delta parameter is set to the value of 1 at the position # of the last decimal digit. # Example : 1.50 belongs to [1.49,1.51], but internally Delta may not equal to 1. # Because of the binary representation, it is between 1 and 1+(2^-15). # # So Mantissa and Delta are not limited in size, but in practice Delta is kept under # 2^32 by the 'normalize' procedure, to avoid a never-ended growth of memory used. # Indeed, when you perform some computations, the Delta parameter (which represent # the uncertainty on the value of the Mantissa) may increase. # Exponent, as an integer, is limited to 32 bits, and this limit seems fair. # The exponent is indeed involved in logarithmic computations, so it may be # a mistake to give it a too large value. # Retrieving the parameters of a BigFloat is often done with that command : # foreach {dummy int exp delta} $bigfloat {break} # (dummy is not used, it is just used to get the "F" marker). # The isInt, isFloat, checkNumber and checkFloat procedures are used # to check data types # # Taylor development are often used to compute the analysis functions (like exp(),log()...) # To learn how it is done in practice, take a look at ::math::bigfloat::_asin # While doing computation on Mantissas, we do not care about the last digit, # because if we compute correctly Deltas, the digits that remain will be exact. ################################################################################ ################################################################################ # returns the absolute value ################################################################################ proc ::math::bigfloat::abs {number} { checkNumber $number if {[isInt $number]} { # set sign to positive for a BigInt return [expr {abs($number)}] } # set sign to positive for a BigFloat into the Mantissa (index 1) lset number 1 [expr {abs([lindex $number 1])}] return $number } ################################################################################ # arccosinus of a BigFloat ################################################################################ proc ::math::bigfloat::acos {x} { # handy proc for checking datatype checkFloat $x foreach {dummy entier exp delta} $x {break} set precision [expr {($exp<0)?(-$exp):1}] # acos(0.0)=Pi/2 # 26/07/2005 : changed precision from decimal to binary # with the second parameter of pi command set piOverTwo [floatRShift [pi $precision 1]] if {[iszero $x]} { # $x is too close to zero -> acos(0)=PI/2 return $piOverTwo } # acos(-x)= Pi/2 + asin(x) if {$entier<0} { return [add $piOverTwo [asin [abs $x]]] } # we always use _asin to compute the result # but as it is a Taylor development, the value given to [_asin] # has to be a bit smaller than 1 ; by using that trick : acos(x)=asin(sqrt(1-x^2)) # we can limit the entry of the Taylor development below 1/sqrt(2) if {[compare $x [fromstr 0.7071]]>0} { # x > sqrt(2)/2 : trying to make _asin converge quickly # creating 0 and 1 with the same precision as the entry set fzero [list F 0 -$precision 1] # 1.000 with $precision zeros set fone [list F [expr {1<<$precision}] -$precision 1] # when $x is close to 1 (acos(1.0)=0.0) if {[equal $fone $x]} { return $fzero } if {[compare $fone $x]<0} { # the behavior assumed because acos(x) is not defined # when |x|>1 error "acos on a number greater than 1" } # acos(x) = asin(sqrt(1 - x^2)) # since 1 - cos(x)^2 = sin(x)^2 # x> sqrt(2)/2 so x^2 > 1/2 so 1-x^2<1/2 set x [sqrt [sub $fone [mul $x $x]]] # the parameter named x is smaller than sqrt(2)/2 return [_asin $x] } # acos(x) = Pi/2 - asin(x) # x$expB} { set diff [expr {$expA-$expB}] set integerA [expr {$integerA<<$diff}] set deltaA [expr {$deltaA<<$diff}] incr integerA $integerB incr deltaA $deltaB return [normalize [list F $integerA $expB $deltaA]] } elseif {$expA==$expB} { # nothing to shift left return [normalize [list F [incr integerA $integerB] $expA [incr deltaA $deltaB]]] } else { error "internal error" } } ################################################################################ # returns the sum A(BigFloat) + B(BigInt) # the greatest advantage of this method is that the uncertainty # of the result remains unchanged, in respect to the entry's uncertainty (deltaA) ################################################################################ proc ::math::bigfloat::addInt2Float {a b} { # type checking checkFloat $a if {![isInt $b]} { error "second argument is not an integer" } # retrieving data from $a foreach {dummy integerA expA deltaA} $a {break} # to add an int to a BigFloat,... if {$expA>0} { # we have to put the integer integerA # to the level of zero exponent : 1e8 --> 100000000e0 set shift $expA set integerA [expr {($integerA<<$shift)+$b}] set deltaA [expr {$deltaA<<$shift}] # we have to normalize, because we have shifted the mantissa # and the uncertainty left return [normalize [list F $integerA 0 $deltaA]] } elseif {$expA==0} { # integerA is already at integer level : float=(integerA)e0 return [normalize [list F [incr integerA $b] \ 0 $deltaA]] } else { # here we have something like 234e-2 + 3 # we have to shift the integer left by the exponent |$expA| incr integerA [expr {$b<<(-$expA)}] return [normalize [list F $integerA $expA $deltaA]] } } ################################################################################ # arcsinus of a BigFloat ################################################################################ proc ::math::bigfloat::asin {x} { # type checking checkFloat $x foreach {dummy entier exp delta} $x {break} if {$exp>-1} { error "not enough precision on input (asin)" } set precision [expr {-$exp}] # when x=0, return 0 at the same precision as the input was if {[iszero $x]} { return [list F 0 -$precision 1] } # asin(-x)=-asin(x) if {$entier<0} { return [opp [asin [abs $x]]] } # 26/07/2005 : changed precision from decimal to binary set piOverTwo [floatRShift [pi $precision 1]] # now a little trick : asin(x)=Pi/2-asin(sqrt(1-x^2)) # so we can limit the entry of the Taylor development # to 1/sqrt(2)~0.7071 # the comparison is : if x>0.7071 then ... if {[compare $x [fromstr 0.7071]]>0} { set fone [list F [expr {1<<$precision}] -$precision 1] # asin(1)=Pi/2 (with the same precision as the entry has) if {[equal $fone $x]} { return $piOverTwo } if {[compare $x $fone]>0} { error "asin on a number greater than 1" } # asin(x)=Pi/2-asin(sqrt(1-x^2)) set x [sqrt [sub $fone [mul $x $x]]] return [sub $piOverTwo [_asin $x]] } return [normalize [_asin $x]] } ################################################################################ # _asin : arcsinus of numbers between 0 and +1 ################################################################################ proc ::math::bigfloat::_asin {x} { # Taylor development # asin(x)=x + 1/2 x^3/3 + 3/2.4 x^5/5 + 3.5/2.4.6 x^7/7 + ... # into this iterative form : # asin(x)=x * (1 + 1/2 * x^2 * (1/3 + 3/4 *x^2 * (... # ...* (1/(2n-1) + (2n-1)/2n * x^2 / (2n+1))...))) # we show how is really computed the development : # we don't need to set a var with x^n or a product of integers # all we need is : x^2, 2n-1, 2n, 2n+1 and a few variables foreach {dummy mantissa exp delta} $x {break} set precision [expr {-$exp}] if {$precision+1<[bits $mantissa]} { error "sinus greater than 1" } # precision is the number of after-dot digits set result $mantissa set delta_final $delta # resultat is the final result, and delta_final # will contain the uncertainty of the result # square is the square of the mantissa set square [expr {$mantissa*$mantissa>>$precision}] # dt is the uncertainty of Mantissa set dt [expr {$mantissa*$delta>>($precision-1)}] incr dt set num 1 # two will be used into the loop set i 3 set denom 2 # the nth factor equals : $num/$denom* $mantissa/$i set delta [expr {$delta*$square + $dt*($delta+$mantissa)}] set delta [expr {($delta*$num)/ $denom >>$precision}] incr delta # we do not multiply the Mantissa by $num right now because it is 1 ! # but we have Mantissa=$x # and we want Mantissa*$x^2 * $num / $denom / $i set mantissa [expr {($mantissa*$square>>$precision)/$denom}] # do not forget the modified Taylor development : # asin(x)=x * (1 + 1/2*x^2*(1/3 + 3/4*x^2*(...*(1/(2n-1) + (2n-1)/2n*x^2/(2n+1))...))) # all we need is : x^2, 2n-1, 2n, 2n+1 and a few variables # $num=2n-1 $denom=2n $square=x^2 and $i=2n+1 set mantissa_temp [expr {$mantissa/$i}] set delta_temp [expr {1+$delta/$i}] # when the Mantissa increment is smaller than the Delta increment, # we would not get much precision by continuing the development while {$mantissa_temp!=0} { # Mantissa = Mantissa * $num/$denom * $square # Add Mantissa/$i, which is stored in $mantissa_temp, to the result incr result $mantissa_temp incr delta_final $delta_temp # here we have $two instead of [fromstr 2] (optimization) # num=num+2,i=i+2,denom=denom+2 # because num=2n-1 denom=2n and i=2n+1 incr num 2 incr i 2 incr denom 2 # computes precisly the future Delta parameter set delta [expr {$delta*$square+$dt*($delta+$mantissa)}] set delta [expr {($delta*$num)/$denom>>$precision}] incr delta set mantissa [expr {$mantissa*$square>>$precision}] set mantissa [expr {($mantissa*$num)/$denom}] set mantissa_temp [expr {$mantissa/$i}] set delta_temp [expr {1+$delta/$i}] } return [normalize [list F $result $exp $delta_final]] } ################################################################################ # arctangent : returns atan(x) ################################################################################ proc ::math::bigfloat::atan {x} { checkFloat $x foreach {dummy mantissa exp delta} $x {break} if {$exp>=0} { error "not enough precision to compute atan" } set precision [expr {-$exp}] # atan(0)=0 if {[iszero $x]} { return [list F 0 -$precision $delta] } # atan(-x)=-atan(x) if {$mantissa<0} { return [opp [atan [abs $x]]] } # now x is strictly positive # at this moment, we are trying to limit |x| to a fair acceptable number # to ensure that Taylor development will converge quickly set float1 [list F [expr {1<<$precision}] -$precision 1] if {[compare $float1 $x]<0} { # compare x to 2.4142 if {[compare $x [fromstr 2.4142]]<0} { # atan(x)=Pi/4 + atan((x-1)/(x+1)) # as 10} { # atan(x)=Pi/4 + atan((x-1)/(x+1)) # x>0.420 so (x-1)/(x+1)=1 - 2/(x+1) > 1-2/1.414 # > -0.414 # x<1 so (x-1)/(x+1)<0 set pi_sur_quatre [floatRShift [pi $precision 1] 2] return [add $pi_sur_quatre [atan \ [div [sub $x $float1] [add $x $float1]]]] } # precision increment : to have less uncertainty # we add a little more precision so that the result would be more accurate # Taylor development : x - x^3/3 + x^5/5 - ... + (-1)^(n+1)*x^(2n-1)/(2n-1) # when we have n steps in Taylor development : the nth term is : # x^(2n-1)/(2n-1) # and the loss of precision is of 2n (n sums and n divisions) # this command is called with x(precision-3/2)*log(2)-log(2n-1) # hence log(2n-1)<2n-1 # n*sqrt(2)>(precision-1.5)*log(2)+1-2n # n*(sqrt(2)+2)>(precision-1.5)*log(2)+1 set n [expr {int((log(2)*($precision-1.5)+1)/(sqrt(2)+2)+1)}] incr precision $n set mantissa [expr {$mantissa<<$n}] set delta [expr {$delta<<$n}] # end of adding precision increment # now computing Taylor development : # atan(x)=x - x^3/3 + x^5/5 - x^7/7 ... + (-1)^n*x^(2n+1)/(2n+1) # atan(x)=x * (1 - x^2 * (1/3 - x^2 * (1/5 - x^2 * (...*(1/(2n-1) - x^2 / (2n+1))...)))) # what do we need to compute this ? # x^2 ($square), 2n+1 ($divider), $result, the nth term of the development ($t) # and the nth term multiplied by 2n+1 ($temp) # then we do this (with care keeping as much precision as possible): # while ($t <>0) : # $result=$result+$t # $temp=$temp * $square # $divider = $divider+2 # $t=$temp/$divider # end-while set result $mantissa set delta_end $delta # we store the square of the integer (mantissa) # Delta of Mantissa^2 = Delta * 2 = Delta << 1 set delta_square [expr {$delta<<1}] set square [expr {$mantissa*$mantissa>>$precision}] # the (2n+1) divider set divider 3 # computing precisely the uncertainty set delta [expr {1+($delta_square*$mantissa+$delta*$square>>$precision)}] # temp contains (-1)^n*x^(2n+1) set temp [expr {-$mantissa*$square>>$precision}] set t [expr {$temp/$divider}] set dt [expr {1+$delta/$divider}] while {$t!=0} { incr result $t incr delta_end $dt incr divider 2 set delta [expr {1+($delta_square*abs($temp)+$delta*($delta_square+$square)>>$precision)}] set temp [expr {-$temp*$square>>$precision}] set t [expr {$temp/$divider}] set dt [expr {1+$delta/$divider}] } # we have to normalize because the uncertainty might be greater than 2**16 # moreover it is the most often case return [normalize [list F $result [expr {$exp-$n}] $delta_end]] } ################################################################################ # compute atan(1/integer) at a given precision # this proc is only used to compute Pi # it is using the same Taylor development as [atan] ################################################################################ proc ::math::bigfloat::_atanfract {integer precision} { # Taylor development : x - x^3/3 + x^5/5 - ... + (-1)^(n+1)*x^(2n-1)/(2n-1) # when we have n steps in Taylor development : the nth term is : # 1/denom^(2n+1)/(2n+1) # and the loss of precision is of 2n (n sums and n divisions) # this command is called with integer>=5 # # We do not want to compute the Delta parameter, so we just # can increment precision (with lshift) in order for the result to be precise. # Remember : we compute atan2(1,$integer) with $precision bits # $integer has no Delta parameter as it is a BigInt, of course, so # theorically we could compute *any* number of digits. # # if we add an increment to the precision, say n: # (1/5)^(2n-1)/(2n-1) has to be lower than (1/2)^(precision+n-1) # Calculus : # log(left term) < log(right term) # log(1/left term) > log(1/right term) # (2n-1)*log(5)+log(2n-1)>(precision+n-1)*log(2) # n(2log(5)-log(2))>(precision-1)*log(2)-log(2n-1)+log(5) # -log(2n-1)>-(2n-1) # n(2log(5)-log(2)+2)>(precision-1)*log(2)+1+log(5) set n [expr {int((($precision-1)*log(2)+1+log(5))/(2*log(5)-log(2)+2)+1)}] incr precision $n # first term of the development : 1/integer set a [expr {(1<<$precision)/$integer}] # 's' will contain the result set s $a # Taylor development : x - x^3/3 + x^5/5 - ... + (-1)^(n+1)*x^(2n-1)/(2n-1) # equals x (1 - x^2 * (1/3 + x^2 * (... * (1/(2n-3) + (-1)^(n+1) * x^2 / (2n-1))...))) # all we need to store is : 2n-1 ($denom), x^(2n+1) and x^2 ($square) and two results : # - the nth term => $u # - the nth term * (2n-1) => $t # + of course, the result $s set square [expr {$integer*$integer}] set denom 3 # $t is (-1)^n*x^(2n+1) set t [expr {-$a/$square}] set u [expr {$t/$denom}] # we break the loop when the current term of the development is null while {$u!=0} { incr s $u # denominator= (2n+1) incr denom 2 # div $t by x^2 set t [expr {-$t/$square}] set u [expr {$t/$denom}] } # go back to the initial precision return [expr {$s>>$n}] } # # bits : computes the number of bits of an integer, approx. # proc ::math::bigfloat::bits {int} { set l [string length [set int [expr {abs($int)}]]] # int<10**l -> log_2(int)=l*log_2(10) set l [expr {int($l*log(10)/log(2))+1}] if {$int>>$l!=0} { error "bad result: $l bits" } while {($int>>($l-1))==0} { incr l -1 } return $l } ################################################################################ # returns the integer part of a BigFloat, as a BigInt # the result is the same one you would have # if you had called [expr {ceil($x)}] ################################################################################ proc ::math::bigfloat::ceil {number} { checkFloat $number set number [normalize $number] if {[iszero $number]} { return 0 } foreach {dummy integer exp delta} $number {break} if {$exp>=0} { error "not enough precision to perform rounding (ceil)" } # saving the sign ... set sign [expr {$integer<0}] set integer [expr {abs($integer)}] # integer part set try [expr {$integer>>(-$exp)}] if {$sign} { return [opp $try] } # fractional part if {($try<<(-$exp))!=$integer} { return [incr try] } return $try } ################################################################################ # checks each variable to be a BigFloat # arguments : each argument is the name of a variable to be checked ################################################################################ proc ::math::bigfloat::checkFloat {number} { if {![isFloat $number]} { error "BigFloat expected" } } ################################################################################ # checks if each number is either a BigFloat or a BigInt # arguments : each argument is the name of a variable to be checked ################################################################################ proc ::math::bigfloat::checkNumber {x} { if {![isFloat $x] && ![isInt $x]} { error "input is not an integer, nor a BigFloat" } } ################################################################################ # returns 0 if A and B are equal, else returns 1 or -1 # accordingly to the sign of (A - B) ################################################################################ proc ::math::bigfloat::compare {a b} { if {[isInt $a] && [isInt $b]} { set diff [expr {$a-$b}] if {$diff>0} {return 1} elseif {$diff<0} {return -1} return 0 } checkFloat $a checkFloat $b if {[equal $a $b]} {return 0} if {[lindex [sub $a $b] 1]<0} {return -1} return 1 } ################################################################################ # gets cos(x) # throws an error if there is not enough precision on the input ################################################################################ proc ::math::bigfloat::cos {x} { checkFloat $x foreach {dummy integer exp delta} $x {break} if {$exp>-2} { error "not enough precision on floating-point number" } set precision [expr {-$exp}] # cos(2kPi+x)=cos(x) foreach {n integer} [divPiQuarter $integer $precision] {break} # now integer>=0 and exp (multiplied by -1) #idebug break lset l 1 [expr {-([lindex $l 1])}] # set the sign if {$signe} { lset l 0 [expr {-[lindex $l 0]}] } #idebug break return [normalize [linsert $l 0 F]] } ################################################################################ # compute cos(x) where 0<=x>1}] set pis4 [expr {$pis2>>1}] if {$x>=$pis4} { # cos(Pi/2-x)=sin(x) set x [expr {$pis2-$x}] incr delta return [_sin $x $precision $delta] } #idebug break return [_cos $x $precision $delta] } ################################################################################ # compute cos(x) where 0<=x>$precision)}] # x=x^2 (because in this Taylor development, there are only even powers of x) set x [expr {$x*$x>>$precision}] set denom1 1 set denom2 2 set t [expr {-($x>>1)}] set dt $d while {$t!=0} { incr s $t incr delta $dt incr denom1 2 incr denom2 2 set dt [expr {$x*$dt+($t+$dt)*$d>>$precision}] incr dt set t [expr {$x*$t>>$precision}] set t [expr {-$t/($denom1*$denom2)}] } return [list $s $precision $delta] } ################################################################################ # cotangent : the trivial algorithm is used ################################################################################ proc ::math::bigfloat::cotan {x} { return [::math::bigfloat::div [::math::bigfloat::cos $x] [::math::bigfloat::sin $x]] } ################################################################################ # converts angles from degrees to radians # deg/180=rad/Pi ################################################################################ proc ::math::bigfloat::deg2rad {x} { checkFloat $x set xLen [expr {-[lindex $x 2]}] if {$xLen<3} { error "number too loose to convert to radians" } set pi [pi $xLen 1] return [div [mul $x $pi] 180] } ################################################################################ # private proc to get : x modulo Pi/2 # and the quotient (x divided by Pi/2) # used by cos , sin & others ################################################################################ proc ::math::bigfloat::divPiQuarter {integer precision} { incr precision 2 set integer [expr {$integer<<1}] #idebug break set P [_pi $precision] # modulo 2Pi set integer [expr {$integer%$P}] # end modulo 2Pi # 2Pi>>1 = Pi of course! set P [expr {$P>>1}] set n [expr {$integer/$P}] set integer [expr {$integer%$P}] # now divide by Pi/2 # multiply n by 2 set n [expr {$n<<1}] # pi/2=Pi>>1 set P [expr {$P>>1}] return [list [incr n [expr {$integer/$P}]] [expr {($integer%$P)>>1}]] } ################################################################################ # divide A by B and returns the result # throw error : divide by zero ################################################################################ proc ::math::bigfloat::div {a b} { checkNumber $a checkNumber $b # dispatch to an appropriate procedure if {[isInt $a]} { if {[isInt $b]} { return [expr {$a/$b}] } error "trying to divide an integer by a BigFloat" } if {[isInt $b]} {return [divFloatByInt $a $b]} foreach {dummy integerA expA deltaA} $a {break} foreach {dummy integerB expB deltaB} $b {break} # computes the limits of the doubt (or uncertainty) interval set BMin [expr {$integerB-$deltaB}] set BMax [expr {$integerB+$deltaB}] if {$BMin>$BMax} { # swap BMin and BMax set temp $BMin set BMin $BMax set BMax $temp } # multiply by zero gives zero if {$integerA==0} { # why not return any number or the integer 0 ? # because there is an exponent that might be different between two BigFloats # 0.00 --> exp = -2, 0.000000 -> exp = -6 return $a } # test of the division by zero if {$BMin*$BMax<0 || $BMin==0 || $BMax==0} { error "divide by zero" } # shift A because we need accuracy set l [bits $integerB] set integerA [expr {$integerA<<$l}] set deltaA [expr {$deltaA<<$l}] set exp [expr {$expA-$l-$expB}] # relative uncertainties (dX/X) are added # to give the relative uncertainty of the result # i.e. 3% on A + 2% on B --> 5% on the quotient # d(A/B)/(A/B)=dA/A + dB/B # Q=A/B # dQ=dA/B + dB*A/B*B # dQ is "delta" set delta [expr {($deltaB*abs($integerA))/abs($integerB)}] set delta [expr {([incr delta]+$deltaA)/abs($integerB)}] set quotient [expr {$integerA/$integerB}] if {$integerB*$integerA<0} { incr quotient -1 } return [normalize [list F $quotient $exp [incr delta]]] } ################################################################################ # divide a BigFloat A by a BigInt B # throw error : divide by zero ################################################################################ proc ::math::bigfloat::divFloatByInt {a b} { # type check checkFloat $a if {![isInt $b]} { error "second argument is not an integer" } foreach {dummy integer exp delta} $a {break} # zero divider test if {$b==0} { error "divide by zero" } # shift left for accuracy ; see other comments in [div] procedure set l [bits $b] set integer [expr {$integer<<$l}] set delta [expr {$delta<<$l}] incr exp -$l set integer [expr {$integer/$b}] # the uncertainty is always evaluated to the ceil value # and as an absolute value set delta [expr {$delta/abs($b)+1}] return [normalize [list F $integer $exp $delta]] } ################################################################################ # returns 1 if A and B are equal, 0 otherwise # IN : a, b (BigFloats) ################################################################################ proc ::math::bigfloat::equal {a b} { if {[isInt $a] && [isInt $b]} { return [expr {$a==$b}] } # now a & b should only be BigFloats checkFloat $a checkFloat $b foreach {dummy aint aexp adelta} $a {break} foreach {dummy bint bexp bdelta} $b {break} # set all Mantissas and Deltas to the same level (exponent) # with lshift set diff [expr {$aexp-$bexp}] if {$diff<0} { set diff [expr {-$diff}] set bint [expr {$bint<<$diff}] set bdelta [expr {$bdelta<<$diff}] } elseif {$diff>0} { set aint [expr {$aint<<$diff}] set adelta [expr {$adelta<<$diff}] } # compute limits of the number's doubt range set asupInt [expr {$aint+$adelta}] set ainfInt [expr {$aint-$adelta}] set bsupInt [expr {$bint+$bdelta}] set binfInt [expr {$bint-$bdelta}] # A & B are equal # if their doubt ranges overlap themselves if {$bint==$aint} { return 1 } if {$bint>$aint} { set r [expr {$asupInt>=$binfInt}] } else { set r [expr {$bsupInt>=$ainfInt}] } return $r } ################################################################################ # returns exp(X) where X is a BigFloat ################################################################################ proc ::math::bigfloat::exp {x} { checkFloat $x foreach {dummy integer exp delta} $x {break} if {$exp>=0} { # shift till exp<0 with respect to the internal representation # of the number incr exp set integer [expr {$integer<<$exp}] set delta [expr {$delta<<$exp}] set exp -1 } # add 8 bits of precision for safety set precision [expr {8-$exp}] set integer [expr {$integer<<8}] set delta [expr {$delta<<8}] set Log2 [_log2 $precision] set new_exp [expr {$integer/$Log2}] set integer [expr {$integer%$Log2}] # $new_exp = integer part of x/log(2) # $integer = remainder # exp(K.log(2)+r)=2^K.exp(r) # so we just have to compute exp(r), r is small so # the Taylor development will converge quickly incr delta $new_exp foreach {integer delta} [_exp $integer $precision $delta] {break} set delta [expr {$delta>>8}] incr precision -8 # multiply by 2^K , and take care of the sign # example : X=-6.log(2)+0.01 # exp(X)=exp(0.01)*2^-6 # if {abs($new_exp)>>30!=0} { # error "floating-point overflow due to exp" # } set exp [expr {$new_exp-$precision}] incr delta return [normalize [list F [expr {$integer>>8}] $exp $delta]] } ################################################################################ # private procedure to compute exponentials # using Taylor development of exp(x) : # exp(x)=1+ x + x^2/2 + x^3/3! +...+x^n/n! # input : integer (the mantissa) # precision (the number of decimals) # delta (the doubt limit, or uncertainty) # returns a list : 1. the mantissa of the result # 2. the doubt limit, or uncertainty ################################################################################ proc ::math::bigfloat::_exp {integer precision delta} { if {$integer==0} { # exp(0)=1 return [list [expr {1<<$precision}] $delta] } set s [expr {(1<<$precision)+$integer}] set d [expr {1+$delta/2}] incr delta $delta # dt = uncertainty on x^2 set dt [expr {1+($d*$integer>>$precision)}] # t= x^2/2 = x^2>>1 set t [expr {$integer*$integer>>$precision+1}] set denom 2 while {$t!=0} { # the sum is called 's' incr s $t incr delta $dt # we do not have to keep trace of the factorial, we just iterate divisions incr denom # add delta set d [expr {1+$d/$denom}] incr dt $d # get x^n from x^(n-1) set t [expr {($integer*$t>>$precision)/$denom}] } return [list $s $delta] } ################################################################################ # divide a BigFloat by 2 power 'n' ################################################################################ proc ::math::bigfloat::floatRShift {float {n 1}} { return [lset float 2 [expr {[lindex $float 2]-$n}]] } ################################################################################ # procedure floor : identical to [expr floor($x)] in functionality # arguments : number IN (a BigFloat) # returns : the floor value as a BigInt ################################################################################ proc ::math::bigfloat::floor {number} { checkFloat $number if {[iszero $number]} { # returns the BigInt 0 return 0 } foreach {dummy integer exp delta} $number {break} if {$exp>=0} { error "not enough precision to perform rounding (floor)" } # floor(n.xxxx)=n when n is positive if {$integer>0} {return [expr {$integer>>(-$exp)}]} set integer [expr {abs($integer)}] # integer part set try [expr {$integer>>(-$exp)}] # floor(-n.xxxx)=-(n+1) when xxxx!=0 if {$try<<(-$exp)!=$integer} { incr try } return [expr {-$try}] } ################################################################################ # returns a list formed by an integer and an exponent # x = (A +/- C) * 10 power B # return [list "F" A B C] (where F is the BigFloat tag) # A and C are BigInts, B is a raw integer # return also a BigInt when there is neither a dot, nor a 'e' exponent # # arguments : -base base integer # or integer # or float # or float trailingZeros ################################################################################ proc ::math::bigfloat::fromstr {number {addzeros 0}} { if {$addzeros<0} { error "second argument has to be a positive integer" } # eliminate the sign problem # added on 05/08/2005 # setting '$signe' to the sign of the number set number [string trimleft $number +] if {[string index $number 0]=="-"} { set signe 1 set string [string range $number 1 end] } else { set signe 0 set string $number } # integer case (not a floating-point number) if {[string is digit $string]} { if {$addzeros!=0} { error "second argument not allowed with an integer" } # we have completed converting an integer to a BigInt # please note that most math::bigfloat procs accept BigInts as arguments return $number } # floating-point number : check for an exponent # scientific notation set tab [split $string e] if {[llength $tab]>2} { # there are more than one 'e' letter in the number error "syntax error in number : $string" } if {[llength $tab]==2} { set exp [lindex $tab 1] # now exp can look like +099 so you need to handle octal numbers # too bad... # find the sign (if any?) regexp {^[\+\-]?} $exp expsign # trim the number with left-side 0's set found [string length $expsign] set exp $expsign[string trimleft [string range $exp $found end] 0] set mantissa [lindex $tab 0] } else { set exp 0 set mantissa [lindex $tab 0] } # a floating-point number may have a dot set tab [split [string trimleft $mantissa 0] .] if {[llength $tab]>2} {error "syntax error in number : $string"} if {[llength $tab]==2} { set mantissa [join $tab ""] # increment by the number of decimals (after the dot) incr exp -[string length [lindex $tab 1]] } # this is necessary to ensure we can call fromstr (recursively) with # the mantissa ($number) if {![string is digit $mantissa]} { error "$number is not a number" } # take account of trailing zeros incr exp -$addzeros # multiply $number by 10^$trailingZeros append mantissa [string repeat 0 $addzeros] # add the sign # here we avoid octal numbers by trimming the leading zeros! # 2005-10-28 S.ARNOLD if {$signe} {set mantissa [expr {-[string trimleft $mantissa 0]}]} # the F tags a BigFloat # a BigInt is like any other integer since Tcl 8.5, # because expr now supports arbitrary length integers return [_fromstr $mantissa $exp] } ################################################################################ # private procedure to transform decimal floats into binary ones # IN : # - number : a BigInt representing the Mantissa # - exp : the decimal exponent (a simple integer) # OUT : # $number * 10^$exp, as the internal binary representation of a BigFloat ################################################################################ proc ::math::bigfloat::_fromstr {number exp} { set number [string trimleft $number 0] if {$number==""} { return [list F 0 [expr {int($exp*log(10)/log(2))-15}] [expr {1<<15}]] } if {$exp==0} { return [list F $number 0 1] } if {$exp>0} { # mul by 10^exp, then normalize set power [expr {10**$exp}] set number [expr {$number*$power}] return [normalize [list F $number 0 $power]] } # now exp is negative or null # the closest power of 2 to the 'exp'th power of ten, but greater than it # 10**$exp<2**$binaryExp # $binaryExp>$exp*log(10)/log(2) set binaryExp [expr {int(-$exp*log(10)/log(2))+1+16}] # then compute n * 2^binaryExp / 10^(-exp) # (exp is negative) # equals n * 2^(binaryExp+exp) / 5^(-exp) set diff [expr {$binaryExp+$exp}] if {$diff<0} { error "internal error" } set power [expr {5**(-$exp)}] set number [expr {($number<<$diff)/$power}] set delta [expr {(1<<$diff)/$power}] return [normalize [list F $number [expr {-$binaryExp}] [incr delta]]] } ################################################################################ # fromdouble : # like fromstr, but for a double scalar value # arguments : # double - the number to convert to a BigFloat # exp (optional) - the total number of digits ################################################################################ proc ::math::bigfloat::fromdouble {double {exp {}}} { set mantissa [lindex [split $double e] 0] # line added by SArnold on 05/08/2005 set mantissa [string trimleft [string map {+ "" - ""} $mantissa] 0] set precision [string length [string map {. ""} $mantissa]] if { $exp != {} && [incr exp]>$precision } { return [fromstr $double [expr {$exp-$precision}]] } else { # tests have failed : not enough precision or no exp argument return [fromstr $double] } } ################################################################################ # converts a BigInt into a BigFloat with a given decimal precision ################################################################################ proc ::math::bigfloat::int2float {int {decimals 1}} { # it seems like we need some kind of type handling # very odd in this Tcl world :-( if {![isInt $int]} { error "first argument is not an integer" } if {$decimals<1} { error "non-positive decimals number" } # the lowest number of decimals is 1, because # [tostr [fromstr 10.0]] returns 10. # (we lose 1 digit when converting back to string) set int [expr {$int*10**$decimals}] return [_fromstr $int [expr {-$decimals}]] } ################################################################################ # multiplies 'leftop' by 'rightop' and rshift the result by 'shift' ################################################################################ proc ::math::bigfloat::intMulShift {leftop rightop shift} { return [::math::bignum::rshift [::math::bignum::mul $leftop $rightop] $shift] } ################################################################################ # returns 1 if x is a BigFloat, 0 elsewhere ################################################################################ proc ::math::bigfloat::isFloat {x} { # a BigFloat is a list of : "F" mantissa exponent delta if {[llength $x]!=4} { return 0 } # the marker is the letter "F" if {[string equal [lindex $x 0] F]} { return 1 } return 0 } ################################################################################ # checks that n is a BigInt (a number create by math::bignum::fromstr) ################################################################################ proc ::math::bigfloat::isInt {n} { if {[llength $n]>1} { return 0 } # if {[string is digit $n]} { # return 1 # } return 1 } ################################################################################ # returns 1 if x is null, 0 otherwise ################################################################################ proc ::math::bigfloat::iszero {x} { if {[isInt $x]} { return [expr {$x==0}] } checkFloat $x # now we do some interval rounding : if a number's interval englobs 0, # it is considered to be equal to zero foreach {dummy integer exp delta} $x {break} if {$delta>=abs($integer)} {return 1} return 0 } ################################################################################ # compute log(X) ################################################################################ proc ::math::bigfloat::log {x} { checkFloat $x foreach {dummy integer exp delta} $x {break} if {$integer<=0} { error "zero logarithm error" } if {[iszero $x]} { error "number equals zero" } set precision [bits $integer] # uncertainty of the logarithm set delta [_logOnePlusEpsilon $delta $integer $precision] incr delta # we got : x = 1xxxxxx (binary number with 'precision' bits) * 2^exp # we need : x = 0.1xxxxxx(binary) *2^(exp+precision) incr exp $precision foreach {integer deltaIncr} [_log $integer] {break} incr delta $deltaIncr # log(a * 2^exp)= log(a) + exp*log(2) # result = log(x) + exp*log(2) # as x<1 log(x)<0 but 'integer' (result of '_log') is the absolute value # that is why we substract $integer to log(2)*$exp set integer [expr {[_log2 $precision]*$exp-$integer}] incr delta [expr {abs($exp)}] return [normalize [list F $integer -$precision $delta]] } ################################################################################ # compute log(1-epsNum/epsDenom)=log(1-'epsilon') # Taylor development gives -x -x^2/2 -x^3/3 -x^4/4 ... # used by 'log' command because log(x+/-epsilon)=log(x)+log(1+/-(epsilon/x)) # so the uncertainty equals abs(log(1-epsilon/x)) # ================================================ # arguments : # epsNum IN (the numerator of epsilon) # epsDenom IN (the denominator of epsilon) # precision IN (the number of bits after the dot) # # 'epsilon' = epsNum*2^-precision/epsDenom ################################################################################ proc ::math::bigfloat::_logOnePlusEpsilon {epsNum epsDenom precision} { if {$epsNum>=$epsDenom} { error "number is null" } set s [expr {($epsNum<<$precision)/$epsDenom}] set divider 2 set t [expr {$s*$epsNum/$epsDenom}] set u [expr {$t/$divider}] # when u (the current term of the development) is zero, we have reached our goal # it has converged while {$u!=0} { incr s $u # divider = order of the term = 'n' incr divider # t = (epsilon)^n set t [expr {$t*$epsNum/$epsDenom}] # u = t/n = (epsilon)^n/n and is the nth term of the Taylor development set u [expr {$t/$divider}] } return $s } ################################################################################ # compute log(0.xxxxxxxx) : log(1-epsilon)=-eps-eps^2/2-eps^3/3...-eps^n/n ################################################################################ proc ::math::bigfloat::_log {integer} { # the uncertainty is nbSteps with nbSteps<=nbBits # take nbSteps=nbBits (the worse case) and log(nbBits+increment)=increment set precision [bits $integer] set n [expr {int(log($precision+2*log($precision)))}] set integer [expr {$integer<<$n}] incr precision $n set delta 3 # 1-epsilon=integer set integer [expr {(1<<$precision)-$integer}] set s $integer # t=x^2 set t [expr {$integer*$integer>>$precision}] set denom 2 # u=x^2/2 (second term) set u [expr {$t/$denom}] while {$u!=0} { # while the current term is not zero, it has not converged incr s $u incr delta # t=x^n set t [expr {$t*$integer>>$precision}] # denom = n (the order of the current development term) # u = x^n/n (the nth term of Taylor development) set u [expr {$t/[incr denom]}] } # shift right to restore the precision set delta return [list [expr {$s>>$n}] [expr {($delta>>$n)+1}]] } ################################################################################ # computes log(num/denom) with 'precision' bits # used to compute some analysis constants with a given accuracy # you might not call this procedure directly : it assumes 'num/denom'>4/5 # and 'num/denom'<1 ################################################################################ proc ::math::bigfloat::__log {num denom precision} { # Please Note : we here need a precision increment, in order to # keep accuracy at $precision digits. If we just hold $precision digits, # each number being precise at the last digit +/- 1, # we would lose accuracy because small uncertainties add to themselves. # Example : 0.0001 + 0.0010 = 0.0011 +/- 0.0002 # This is quite the same reason that made tcl_precision defaults to 12 : # internally, doubles are computed with 17 digits, but to keep precision # we need to limit our results to 12. # The solution : given a precision target, increment precision with a # computed value so that all digits of he result are exacts. # # p is the precision # pk is the precision increment # 2 power pk is also the maximum number of iterations # for a number close to 1 but lower than 1, # (denom-num)/denum is (in our case) lower than 1/5 # so the maximum nb of iterations is for: # 1/5*(1+1/5*(1/2+1/5*(1/3+1/5*(...)))) # the last term is 1/n*(1/5)^n # for the last term to be lower than 2^(-p-pk) # the number of iterations has to be # 2^(-pk).(1/5)^(2^pk) < 2^(-p-pk) # log(1/5).2^pk < -p # 2^pk > p/log(5) # pk > log(2)*log(p/log(5)) # now set the variable n to the precision increment i.e. pk set n [expr {int(log(2)*log($precision/log(5)))+1}] incr precision $n # log(num/denom)=log(1-(denom-num)/denom) # log(1+x) = x + x^2/2 + x^3/3 + ... + x^n/n # = x(1 + x(1/2 + x(1/3 + x(...+ x(1/(n-1) + x/n)...)))) set num [expr {$denom-$num}] # $s holds the result set s [expr {($num<<$precision)/$denom}] # $t holds x^n set t [expr {$s*$num/$denom}] set d 2 # $u holds x^n/n set u [expr {$t/$d}] while {$u!=0} { incr s $u # get x^n * x set t [expr {$t*$num/$denom}] # get n+1 incr d # then : $u = x^(n+1)/(n+1) set u [expr {$t/$d}] } # see head of the proc : we return the value with its target precision return [expr {$s>>$n}] } ################################################################################ # computes log(2) with 'precision' bits and caches it into a namespace variable ################################################################################ proc ::math::bigfloat::__logbis {precision} { set increment [expr {int(log($precision)/log(2)+1)}] incr precision $increment # ln(2)=3*ln(1-4/5)+ln(1-125/128) set a [__log 125 128 $precision] set b [__log 4 5 $precision] set r [expr {$b*3+$a}] set ::math::bigfloat::Log2 [expr {$r>>$increment}] # formerly (when BigFloats were stored in ten radix) we had to compute log(10) # ln(10)=10.ln(1-4/5)+3*ln(1-125/128) } ################################################################################ # retrieves log(2) with 'precision' bits ; the result is cached ################################################################################ proc ::math::bigfloat::_log2 {precision} { variable Log2 if {![info exists Log2]} { __logbis $precision } else { # the constant is cached and computed again when more precision is needed set l [bits $Log2] if {$precision>$l} { __logbis $precision } } # return log(2) with 'precision' bits even when the cached value has more bits return [_round $Log2 $precision] } ################################################################################ # returns A modulo B (like with fmod() math function) ################################################################################ proc ::math::bigfloat::mod {a b} { checkNumber $a checkNumber $b if {[isInt $a] && [isInt $b]} {return [expr {$a%$b}]} if {[isInt $a]} {error "trying to divide an integer by a BigFloat"} set quotient [div $a $b] # examples : fmod(3,2)=1 quotient=1.5 # fmod(1,2)=1 quotient=0.5 # quotient>0 and b>0 : get floor(quotient) # fmod(-3,-2)=-1 quotient=1.5 # fmod(-1,-2)=-1 quotient=0.5 # quotient>0 and b<0 : get floor(quotient) # fmod(-3,2)=-1 quotient=-1.5 # fmod(-1,2)=-1 quotient=-0.5 # quotient<0 and b>0 : get ceil(quotient) # fmod(3,-2)=1 quotient=-1.5 # fmod(1,-2)=1 quotient=-0.5 # quotient<0 and b<0 : get ceil(quotient) if {[sign $quotient]} { set quotient [ceil $quotient] } else { set quotient [floor $quotient] } return [sub $a [mul $quotient $b]] } ################################################################################ # returns A times B ################################################################################ proc ::math::bigfloat::mul {a b} { checkNumber $a checkNumber $b # dispatch the command to appropriate commands regarding types (BigInt & BigFloat) if {[isInt $a]} { if {[isInt $b]} { return [expr {$a*$b}] } return [mulFloatByInt $b $a] } if {[isInt $b]} {return [mulFloatByInt $a $b]} # now we are sure that 'a' and 'b' are BigFloats foreach {dummy integerA expA deltaA} $a {break} foreach {dummy integerB expB deltaB} $b {break} # 2^expA * 2^expB = 2^(expA+expB) set exp [expr {$expA+$expB}] # mantissas are multiplied set integer [expr {$integerA*$integerB}] # compute precisely the uncertainty set delta [expr {$deltaA*(abs($integerB)+$deltaB)+abs($integerA)*$deltaB+1}] # we have to normalize because 'delta' may be too big return [normalize [list F $integer $exp $delta]] } ################################################################################ # returns A times B, where B is a positive integer ################################################################################ proc ::math::bigfloat::mulFloatByInt {a b} { checkFloat $a foreach {dummy integer exp delta} $a {break} if {$b==0} { return [list F 0 $exp $delta] } # Mantissa and Delta are simply multplied by $b set integer [expr {$integer*$b}] set delta [expr {$delta*$b}] # We normalize because Delta could have seriously increased return [normalize [list F $integer $exp $delta]] } ################################################################################ # normalizes a number : Delta (accuracy of the BigFloat) # has to be limited, because the memory use increase # quickly when we do some computations, as the Mantissa and Delta # increase together # The solution : limit the size of Delta to 16 bits ################################################################################ proc ::math::bigfloat::normalize {number} { checkFloat $number foreach {dummy integer exp delta} $number {break} set l [bits $delta] if {$l>16} { incr l -16 # $l holds the supplementary size (in bits) # now we can shift right by $l bits # always round upper the Delta set delta [expr {$delta>>$l}] incr delta set integer [expr {$integer>>$l}] incr exp $l } return [list F $integer $exp $delta] } ################################################################################ # returns -A (the opposite) ################################################################################ proc ::math::bigfloat::opp {a} { checkNumber $a if {[iszero $a]} { return $a } if {[isInt $a]} { return [expr {-$a}] } # recursive call lset a 1 [expr {-[lindex $a 1]}] return $a } ################################################################################ # gets Pi with precision bits # after the dot (after you call [tostr] on the result) ################################################################################ proc ::math::bigfloat::pi {precision {binary 0}} { if {![isInt $precision]} { error "'$precision' expected to be an integer" } if {!$binary} { # convert decimal digit length into bit length set precision [expr {int(ceil($precision*log(10)/log(2)))}] } return [list F [_pi $precision] -$precision 1] } # # Procedure that resets the stored cached Pi constant # proc ::math::bigfloat::reset {} { variable _pi0 if {[info exists _pi0]} {unset _pi0} } proc ::math::bigfloat::_pi {precision} { # the constant Pi begins with 3.xxx # so we need 2 digits to store the digit '3' # and then we will have precision+2 bits in the mantissa variable _pi0 if {![info exists _pi0]} { set _pi0 [__pi $precision] } set lenPiGlobal [bits $_pi0] if {$lenPiGlobal<$precision} { set _pi0 [__pi $precision] } return [expr {$_pi0 >> [bits $_pi0]-2-$precision}] } ################################################################################ # computes an integer representing Pi in binary radix, with precision bits ################################################################################ proc ::math::bigfloat::__pi {precision} { set safetyLimit 8 # for safety and for the better precision, we do so ... incr precision $safetyLimit # formula found in the Math litterature (on Wikipedia # Pi/4 = 44.atan(1/57) + 7.atan(1/239) - 12.atan(1/682) + 24.atan(1/12943) set a [expr {[_atanfract 57 $precision]*44}] incr a [expr {[_atanfract 239 $precision]*7}] set a [expr {$a - [_atanfract 682 $precision]*12}] incr a [expr {[_atanfract 12943 $precision]*24}] return [expr {$a>>$safetyLimit-2}] } ################################################################################ # shift right an integer until it haves $precision bits # round at the same time ################################################################################ proc ::math::bigfloat::_round {integer precision} { set shift [expr {[bits $integer]-$precision}] if {$shift==0} { return $integer } # $result holds the shifted integer set result [expr {$integer>>$shift}] # $shift-1 is the bit just rights the last bit of the result # Example : integer=1000010 shift=2 # => result=10000 and the tested bit is '1' if {$integer & (1<<($shift-1))} { # we round to the upper limit return [incr result] } return $result } ################################################################################ # returns A power B, where B is a positive integer ################################################################################ proc ::math::bigfloat::pow {a b} { checkNumber $a if {$b<0} { error "pow : exponent is not a positive integer" } # case where it is obvious that we should use the appropriate command # from math::bignum (added 5th March 2005) if {[isInt $a]} { return [expr {$a**$b}] } # algorithm : exponent=$b = Sum(i=0..n) b(i)2^i # $a^$b = $a^( b(0) + 2b(1) + 4b(2) + ... + 2^n*b(n) ) # we have $a^(x+y)=$a^x * $a^y # then $a^$b = Product(i=0...n) $a^(2^i*b(i)) # b(i) is boolean so $a^(2^i*b(i))= 1 when b(i)=0 and = $a^(2^i) when b(i)=1 # then $a^$b = Product(i=0...n and b(i)=1) $a^(2^i) and 1 when $b=0 if {$b==0} {return 1} # $res holds the result set res 1 while {1} { # at the beginning i=0 # $remainder is b(i) set remainder [expr {$b&1}] # $b 'rshift'ed by 1 bit : i=i+1 # so next time we will test bit b(i+1) set b [expr {$b>>1}] # if b(i)=1 if {$remainder} { # mul the result by $a^(2^i) # if i=0 we multiply by $a^(2^0)=$a^1=$a set res [mul $res $a] } # no more bits at '1' in $b : $res is the result if {$b==0} { return [normalize $res] } # i=i+1 : $a^(2^(i+1)) = square of $a^(2^i) set a [mul $a $a] } } ################################################################################ # converts angles for radians to degrees ################################################################################ proc ::math::bigfloat::rad2deg {x} { checkFloat $x set xLen [expr {-[lindex $x 2]}] if {$xLen<3} { error "number too loose to convert to degrees" } # $rad/Pi=$deg/180 # so result in deg = $radians*180/Pi return [div [mul $x 180] [pi $xLen 1]] } ################################################################################ # retourne la partie entière (ou 0) du nombre "number" ################################################################################ proc ::math::bigfloat::round {number} { checkFloat $number #set number [normalize $number] # fetching integers (or BigInts) from the internal representation foreach {dummy integer exp delta} $number {break} if {$integer==0} { return 0 } if {$exp>=0} { error "not enough precision to round (in round)" } set exp [expr {-$exp}] # saving the sign, ... set sign [expr {$integer<0}] set integer [expr {abs($integer)}] # integer part of the number set try [expr {$integer>>$exp}] # first bit after the dot set way [expr {$integer>>($exp-1)&1}] # delta is shifted so it gives the integer part of 2*delta set delta [expr {$delta>>($exp-1)}] # when delta is too big to compute rounded value ( if {$delta!=0} { error "not enough precision to round (in round)" } if {$way} { incr try } # ... restore the sign now if {$sign} {return [expr {-$try}]} return $try } ################################################################################ # round and divide by 10^n ################################################################################ proc ::math::bigfloat::roundshift {integer n} { # $exp= 10^$n incr n -1 set exp [expr {10**$n}] set toround [expr {$integer/$exp}] if {$toround%10>=5} { return [expr {$toround/10+1}] } return [expr {$toround/10}] } ################################################################################ # gets the sign of either a bignum, or a BitFloat # we keep the bignum convention : 0 for positive, 1 for negative ################################################################################ proc ::math::bigfloat::sign {n} { if {[isInt $n]} { return [expr {$n<0}] } checkFloat $n # sign of 0=0 if {[iszero $n]} {return 0} # the sign of the Mantissa, which is a BigInt return [sign [lindex $n 1]] } ################################################################################ # gets sin(x) ################################################################################ proc ::math::bigfloat::sin {x} { checkFloat $x foreach {dummy integer exp delta} $x {break} if {$exp>-2} { error "sin : not enough precision" } set precision [expr {-$exp}] # sin(2kPi+x)=sin(x) # $integer is now the modulo of the division of the mantissa by Pi/4 # and $n is the quotient foreach {n integer} [divPiQuarter $integer $precision] {break} incr delta $n set d [expr {$n%4}] # now integer>=0 # x = $n*Pi/4 + $integer and $n belongs to [0,3] # sin(2Pi-x)=-sin(x) # sin(Pi-x)=sin(x) # sin(Pi/2+x)=cos(x) set sign 0 switch -- $d { 0 {set l [_sin2 $integer $precision $delta]} 1 {set l [_cos2 $integer $precision $delta]} 2 {set sign 1;set l [_sin2 $integer $precision $delta]} 3 {set sign 1;set l [_cos2 $integer $precision $delta]} default {error "internal error"} } # $l is a list : {Mantissa Precision Delta} # precision --> the opposite of the exponent # 1.000 = 1000*10^-3 so exponent=-3 and precision=3 digits lset l 1 [expr {-([lindex $l 1])}] # the sign depends on the switch statement below #::math::bignum::setsign integer $sign if {$sign} { lset l 0 [expr {-[lindex $l 0]}] } # we insert the Bigfloat tag (F) and normalize the final result return [normalize [linsert $l 0 F]] } proc ::math::bigfloat::_sin2 {x precision delta} { set pi [_pi $precision] # shift right by 1 = divide by 2 # shift right by 2 = divide by 4 set pis2 [expr {$pi>>1}] set pis4 [expr {$pis2>>1}] if {$x>=$pis4} { # sin(Pi/2-x)=cos(x) incr delta set x [expr {$pis2-$x}] return [_cos $x $precision $delta] } return [_sin $x $precision $delta] } ################################################################################ # sin(x) with 'x' lower than Pi/4 and positive # 'x' is the Mantissa - 'delta' is Delta # 'precision' is the opposite of the exponent ################################################################################ proc ::math::bigfloat::_sin {x precision delta} { # $s holds the result set s $x # sin(x) = x - x^3/3! + x^5/5! - ... + (-1)^n*x^(2n+1)/(2n+1)! # = x * (1 - x^2/(2*3) * (1 - x^2/(4*5) * (...* (1 - x^2/(2n*(2n+1)) )...))) # The second expression allows us to compute the less we can # $double holds the uncertainty (Delta) of x^2 : 2*(Mantissa*Delta) + Delta^2 # (Mantissa+Delta)^2=Mantissa^2 + 2*Mantissa*Delta + Delta^2 set double [expr {$x*$delta>>$precision-1}] incr double [expr {1+$delta*$delta>>$precision}] # $x holds the Mantissa of x^2 set x [expr {$x*$x>>$precision}] set dt [expr {$x*$delta+$double*($s+$delta)>>$precision}] incr dt # $t holds $s * -(x^2) / (2n*(2n+1)) # mul by x^2 set t [expr {$s*$x>>$precision}] set denom2 2 set denom3 3 # mul by -1 (opp) and divide by 2*3 set t [expr {-$t/($denom2*$denom3)}] while {$t!=0} { incr s $t incr delta $dt # incr n => 2n --> 2n+2 and 2n+1 --> 2n+3 incr denom2 2 incr denom3 2 # $dt is the Delta corresponding to $t # $double "" "" "" "" $x (x^2) # ($t+$dt) * ($x+$double) = $t*$x + ($dt*$x + $t*$double) + $dt*$double # Mantissa^ ^--------Delta-------------------^ set dt [expr {$x*$dt+($t+$dt)*$double>>$precision}] set t [expr {$t*$x>>$precision}] # removed 2005/08/31 by sarnold75 #set dt [::math::bignum::add $dt $double] set denom [expr {$denom2*$denom3}] # now computing : div by -2n(2n+1) set dt [expr {1+$dt/$denom}] set t [expr {-$t/$denom}] } return [list $s $precision $delta] } ################################################################################ # procedure for extracting the square root of a BigFloat ################################################################################ proc ::math::bigfloat::sqrt {x} { checkFloat $x foreach {dummy integer exp delta} $x {break} # if x=0, return 0 if {[iszero $x]} { # return zero, taking care of its precision ($exp) return [list F 0 $exp $delta] } # we cannot get sqrt(x) if x<0 if {[lindex $integer 0]<0} { error "negative sqrt input" } # (1+epsilon)^p = 1 + epsilon*(p-1) + epsilon^2*(p-1)*(p-2)/2! + ... # + epsilon^n*(p-1)*...*(p-n)/n! # sqrt(1 + epsilon) = (1 + epsilon)^(1/2) # = 1 - epsilon/2 - epsilon^2*3/(4*2!) - ... # - epsilon^n*(3*5*..*(2n-1))/(2^n*n!) # sqrt(1 - epsilon) = 1 + Sum(i=1..infinity) epsilon^i*(3*5*...*(2i-1))/(i!*2^i) # sqrt(n +/- delta)=sqrt(n) * sqrt(1 +/- delta/n) # so the uncertainty on sqrt(n +/- delta) equals sqrt(n) * (sqrt(1 - delta/n) - 1) # sqrt(1+eps) < sqrt(1-eps) because their logarithm compare as : # -ln(2)(1+eps) < -ln(2)(1-eps) # finally : # Delta = sqrt(n) * Sum(i=1..infinity) (delta/n)^i*(3*5*...*(2i-1))/(i!*2^i) # here we compute the second term of the product by _sqrtOnePlusEpsilon set delta [_sqrtOnePlusEpsilon $delta $integer] set intLen [bits $integer] # removed 2005/08/31 by sarnold75, readded 2005/08/31 set precision $intLen # intLen + exp = number of bits before the dot #set precision [expr {-$exp}] # square root extraction set integer [expr {$integer<<$intLen}] incr exp -$intLen incr intLen $intLen # there is an exponent 2^$exp : when $exp is odd, we would need to compute sqrt(2) # so we decrement $exp, in order to get it even, and we do not need sqrt(2) anymore ! if {$exp&1} { incr exp -1 set integer [expr {$integer<<1}] incr intLen incr precision } # using a low-level (taken from math::bignum) root extraction procedure # using binary operators set integer [_sqrt $integer] # delta has to be multiplied by the square root set delta [expr {$delta*$integer>>$precision}] # round to the ceiling the uncertainty (worst precision, the fastest to compute) incr delta # we are sure that $exp is even, see above return [normalize [list F $integer [expr {$exp/2}] $delta]] } ################################################################################ # compute abs(sqrt(1-delta/integer)-1) # the returned value is a relative uncertainty ################################################################################ proc ::math::bigfloat::_sqrtOnePlusEpsilon {delta integer} { # sqrt(1-x) - 1 = x/2 + x^2*3/(2^2*2!) + x^3*3*5/(2^3*3!) + ... # = x/2 * (1 + x*3/(2*2) * ( 1 + x*5/(2*3) * # (...* (1 + x*(2n-1)/(2n) ) )...))) set l [bits $integer] # to compute delta/integer we have to shift left to keep the same precision level # we have a better accuracy computing (delta << lg(integer))/integer # than computing (delta/integer) << lg(integer) set x [expr {($delta<<$l)/$integer}] # denom holds 2n set denom 4 # x/2 set result [expr {$x>>1}] # x^2*3/(2!*2^2) # numerator holds 2n-1 set numerator 3 set temp [expr {($result*$delta*$numerator)/($integer*$denom)}] incr temp while {$temp!=0} { incr result $temp incr numerator 2 incr denom 2 # n = n+1 ==> num=num+2 denom=denom+2 # num=2n+1 denom=2n+2 set temp [expr {($temp*$delta*$numerator)/($integer*$denom)}] } return $result } # # Computes the square root of an integer # Returns an integer # proc ::math::bigfloat::_sqrt {n} { set i [expr {(([bits $n]-1)/2)+1}] set b [expr {$i*2}] ; # Bit to set to get 2^i*2^i set r 0 ; # guess set x 0 ; # guess^2 set s 0 ; # guess^2 backup set t 0 ; # intermediate result for {} {$i >= 0} {incr i -1; incr b -2} { set x [expr {$s+($t|(1<<$b))}] if {abs($x)<= abs($n)} { set s $x set r [expr {$r|(1<<$i)}] set t [expr {$t|(1<<$b+1)}] } set t [expr {$t>>1}] } return $r } ################################################################################ # substracts B to A ################################################################################ proc ::math::bigfloat::sub {a b} { checkNumber $a checkNumber $b if {[isInt $a] && [isInt $b]} { # the math::bignum::sub proc is designed to work with BigInts return [expr {$a-$b}] } return [add $a [opp $b]] } ################################################################################ # tangent (trivial algorithm) ################################################################################ proc ::math::bigfloat::tan {x} { return [::math::bigfloat::div [::math::bigfloat::sin $x] [::math::bigfloat::cos $x]] } ################################################################################ # returns a power of ten ################################################################################ proc ::math::bigfloat::tenPow {n} { return [expr {10**$n}] } ################################################################################ # converts a BigInt to a double (basic floating-point type) # with respect to the global variable 'tcl_precision' ################################################################################ proc ::math::bigfloat::todouble {x} { global tcl_precision set precision $tcl_precision if {$precision==0} { # this is a cheat, I must admit, for Tcl 8.5 set precision 16 } checkFloat $x # get the string repr of x without the '+' sign # please note: here we call math::bigfloat::tostr set result [string trimleft [tostr $x] +] set minus "" if {[string index $result 0]=="-"} { set minus - set result [string range $result 1 end] } set l [split $result e] set exp 0 if {[llength $l]==2} { # exp : x=Mantissa*2^Exp set exp [lindex $l 1] } # caution with octal numbers : we have to remove heading zeros # but count them as digits regexp {^0*} $result zeros incr exp -[string length $zeros] # Mantissa = integerPart.fractionalPart set l [split [lindex $l 0] .] set integerPart [lindex $l 0] set integerLen [string length $integerPart] set fractionalPart [lindex $l 1] # The number of digits in Mantissa, excluding the dot and the leading zeros, of course set integer [string trimleft $integerPart$fractionalPart 0] if {$integer eq ""} { set integer 0 } set len [string length $integer] # Now Mantissa is stored in $integer if {$len>$precision} { set lenDiff [expr {$len-$precision}] # true when the number begins with a zero set zeroHead 0 if {[string index $integer 0]==0} { incr lenDiff -1 set zeroHead 1 } set integer [roundshift $integer $lenDiff] if {$zeroHead} { set integer 0$integer } set len [string length $integer] if {$len<$integerLen} { set exp [expr {$integerLen-$len}] # restore the true length set integerLen $len } } # number = 'sign'*'integer'*10^'exp' if {$exp==0} { # no scientific notation set exp "" } else { # scientific notation set exp e$exp } # place the dot just before the index $integerLen in the Mantissa set result [string range $integer 0 [expr {$integerLen-1}]] append result .[string range $integer $integerLen end] # join the Mantissa with the sign before and the exponent after return $minus$result$exp } ################################################################################ # converts a number stored as a list to a string in which all digits are true ################################################################################ proc ::math::bigfloat::tostr {args} { if {[llength $args]==2} { if {![string equal [lindex $args 0] -nosci]} {error "unknown option: should be -nosci"} set nosci yes set number [lindex $args 1] } else { if {[llength $args]!=1} {error "syntax error: should be tostr ?-nosci? number"} set nosci no set number [lindex $args 0] } if {[isInt $number]} { return $number } checkFloat $number foreach {dummy integer exp delta} $number {break} if {[iszero $number]} { # we do matter how much precision $number has : # it can be 0.0000000 or 0.0, the result is not the same zero #return 0 } if {$exp>0} { # the power of ten the closest but greater than 2^$exp # if it was lower than the power of 2, we would have more precision # than existing in the number set newExp [expr {int(ceil($exp*log(2)/log(10)))}] # 'integer' <- 'integer' * 2^exp / 10^newExp # equals 'integer' * 2^(exp-newExp) / 5^newExp set binExp [expr {$exp-$newExp}] if {$binExp<0} { # it cannot happen error "internal error" } # 5^newExp set fivePower [expr {5**$newExp}] # 'lshift'ing $integer by $binExp bits is like multiplying it by 2^$binExp # but much, much faster set integer [expr {($integer<<$binExp)/$fivePower}] # $integer is the Mantissa - Delta should follow the same operations set delta [expr {($delta<<$binExp)/$fivePower}] set exp $newExp } elseif {$exp<0} { # the power of ten the closest but lower than 2^$exp # same remark about the precision set newExp [expr {int(floor(-$exp*log(2)/log(10)))}] # 'integer' <- 'integer' * 10^newExp / 2^(-exp) # equals 'integer' * 5^(newExp) / 2^(-exp-newExp) set binShift [expr {-$exp-$newExp}] set fivePower [expr {5**$newExp}] # rshifting is like dividing by 2^$binShift, but faster as we said above about lshift set integer [expr {$integer*$fivePower>>$binShift}] set delta [expr {$delta*$fivePower>>$binShift}] set exp -$newExp } # saving the sign, to restore it into the result set result [expr {abs($integer)}] set sign [expr {$integer<0}] # rounded 'integer' +/- 'delta' set up [expr {$result+$delta}] set down [expr {$result-$delta}] if {($up<0 && $down>0)||($up>0 && $down<0)} { # $up>0 and $down<0 or vice-versa : then the number is considered equal to zero set isZero yes # delta <= 2**n (n = bits(delta)) # 2**n <= 10**exp , then # exp >= n.log(2)/log(10) # delta <= 10**(n.log(2)/log(10)) incr exp [expr {int(ceil([bits $delta]*log(2)/log(10)))}] set result 0 } else { # iterate until the convergence of the rounding # we incr $shift until $up and $down are rounded to the same number # at each pass we lose one digit of precision, so necessarly it will success for {set shift 1} { [roundshift $up $shift]!=[roundshift $down $shift] } { incr shift } {} incr exp $shift set result [roundshift $up $shift] set isZero no } set l [string length $result] # now formatting the number the most nicely for having a clear reading # would'nt we allow a number being constantly displayed # as : 0.2947497845e+012 , would we ? if {$nosci} { if {$exp >= 0} { append result [string repeat 0 $exp]. } elseif {$l + $exp > 0} { set result [string range $result 0 end-[expr {-$exp}]].[string range $result end-[expr {-1-$exp}] end] } else { set result 0.[string repeat 0 [expr {-$exp-$l}]]$result } } else { if {$exp>0} { # we display 423*10^6 as : 4.23e+8 # Length of mantissa : $l # Increment exp by $l-1 because the first digit is placed before the dot, # the other ($l-1) digits following the dot. incr exp [incr l -1] set result [string index $result 0].[string range $result 1 end] append result "e+$exp" } elseif {$exp==0} { # it must have a dot to be a floating-point number (syntaxically speaking) append result . } else { set exp [expr {-$exp}] if {$exp < $l} { # we can display the number nicely as xxxx.yyyy* # the problem of the sign is solved finally at the bottom of the proc set n [string range $result 0 end-$exp] incr exp -1 append n .[string range $result end-$exp end] set result $n } elseif {$l==$exp} { # we avoid to use the scientific notation # because it is harder to read set result "0.$result" } else { # ... but here there is no choice, we should not represent a number # with more than one leading zero set result [string index $result 0].[string range $result 1 end]e-[expr {$exp-$l+1}] } } } # restore the sign : we only put a minus on numbers that are different from zero if {$sign==1 && !$isZero} {set result "-$result"} return $result } ################################################################################ # PART IV # HYPERBOLIC FUNCTIONS ################################################################################ ################################################################################ # hyperbolic cosinus ################################################################################ proc ::math::bigfloat::cosh {x} { # cosh(x) = (exp(x)+exp(-x))/2 # dividing by 2 is done faster by 'rshift'ing return [floatRShift [add [exp $x] [exp [opp $x]]] 1] } ################################################################################ # hyperbolic sinus ################################################################################ proc ::math::bigfloat::sinh {x} { # sinh(x) = (exp(x)-exp(-x))/2 # dividing by 2 is done faster by 'rshift'ing return [floatRShift [sub [exp $x] [exp [opp $x]]] 1] } ################################################################################ # hyperbolic tangent ################################################################################ proc ::math::bigfloat::tanh {x} { set up [exp $x] set down [exp [opp $x]] # tanh(x)=sinh(x)/cosh(x)= (exp(x)-exp(-x))/2/ [(exp(x)+exp(-x))/2] # =(exp(x)-exp(-x))/(exp(x)+exp(-x)) # =($up-$down)/($up+$down) return [div [sub $up $down] [add $up $down]] } # exporting public interface namespace eval ::math::bigfloat { foreach function { add mul sub div mod pow iszero compare equal fromstr tostr fromdouble todouble int2float isInt isFloat exp log sqrt round ceil floor sin cos tan cotan asin acos atan cosh sinh tanh abs opp pi deg2rad rad2deg } { namespace export $function } } # (AM) No "namespace import" - this should be left to the user! #namespace import ::math::bigfloat::* package provide math::bigfloat 2.0.1 tcllib-1.15/modules/math/ChangeLog0000644000175000017500000013065412104363437016416 0ustar sergeisergei2013-02-01 Andreas Kupries * * Released and tagged Tcllib 1.15 ======================== * 2012-06-25 Arjen Markus * statistics.tcl: Add procedures for Wilcoxon test and Spearman rank correlation to the export list 2012-06-24 Arjen Markus * decimal.man: Correct documentation (namespace) for decimal package * statistics.tcl: Add Wilcoxon test and Spearman rank correlation Bumped version to 0.8 * statistics.test: Add test cases for Wilcoxon test and Spearman rank correlation * statistics.man: Describe procs for Wilcoxon test and Spearman rank correlation * wilcoxon.tcl: Added this file - contains implementation of the new procs 2011-12-13 Andreas Kupries * * Released and tagged Tcllib 1.14 ======================== * 2011-11-09 Andreas Kupries * decimal.test: More fixes, now the test succeeds as well. 'Simply' required the proper conversions for arguments and results as most commands do not take regular numbers. 2011-11-07 Andreas Kupries * decimal.test: Fixed the testsuite to be at least properly executable, i.e. bad file names and broken Tcl syntax. The single test still but that sahall be a problem for the actual maintainer. 2011-08-09 Andreas Kupries * decimal.man: [Bug 3383039]: Fixed syntax errors in the documentation of math::decimal, reported by Thomas Perschak 2011-03-29 Andreas Kupries * linalg.man: Documentation tweak, added keyword 'matrix'. 2011-01-24 Andreas Kupries * * Released and tagged Tcllib 1.13 ======================== * 2011-01-12 Andreas Kupries * symdiff.test: Fixed setup (added std boilerplate). * pkgIndex.tcl: Moved symdiff to correct section, requires 8.5, not 8.4. 2010-05-24 Andreas Kupries * geometry.man: [Bug 3110860]: Renamed this file to avoid the * math_geometry.man: conflict with Tcl 8.6's new geometry manpage. Thanks to Reinhard Max for reporting. 2010-10-19 Kevin B. Kenny * symdiff.man: * symdiff.tcl: Added a math::calculus::symdiff package that * symdiff.test: performs symbolic differentiation of Tcl math * pkgIndex.tcl: exprs. 2010-09-27 Lars Hellstr\"om * numtheory.test: Fixed bug #3076576. * numtheory.dtx: 2010-09-22 Arjen Markus * kruskal.tcl: Added header to the file 2010-09-21 Arjen Markus * kruskal.tcl: One-sided test according to Kruskal-Wallis * statistics.tcl: Added test Kruskal-Wallis * statistics.man: Describe Kruskal-Wallis * statistics.test: Added simple test case * pkgIndex.tcl: Bumped version to 0.7.0 2010-09-20 Lars Hellstr\"om * numtheory.dtx: New package math::numtheory (v1.0) * numtheory.man: with command math::numtheory::isprime. * numtheory.stitch: See numtheory.dtx for all the gory * numtheory.tcl: details of the implementation of * numtheory.test: package and tests. * pkgIndex.tcl: 2010-08-22 Andreas Kupries * linalg.tcl: Corrected bug #3036124 (shape of U matrix) - should probably include an extra command for truncated output of S and V 2010-05-24 Andreas Kupries * geometry.man: A bit more commands, bumped to version 1.1.2. * geometry.tcl: * pkgIndex.tcl: 2010-04-06 Andreas Kupries * geometry.tcl (findLineIntersection): Fixed numerical * geometry.man: instability in the algorithm by replacing * geometry.test: it with Kevin's parametric code. Updated * pkgIndex.tcl: documentation, testsuite. Bumped to version 1.1.1. 2010-04-05 Andreas Kupries * geometry.tcl: Extended API with a number of basic point * geometry.man: and vector operations (+, -, scale, ...). * geometry.test: Updated documentation, testsuite. * pkgIndex.tcl: Bumped to version 1.1. 2010-01-17 Arjen Markus * fuzzy.tcl: [Bug 2933130]. Fixed procedure tlt * fuzzy.test: [Bug 2933130]. Added test for this bug * pkgIndex.tcl: Version increased to 0.2.1 2009-12-07 Andreas Kupries * * Released and tagged Tcllib 1.12 ======================== * 2009-12-04 Andreas Kupries * math.man: [Bug 1998628]. Accepted fix by Arjen Markus, with * math.tcl: modifications. Extended testsuite. Bumped version * math.test: to 1.2.5. * pkgIndex.tcl: 2009-11-17 Arjen Markus * statistics.tcl: Bumped version to 0.6.3 * geometry.tcl: Solved bug #1623653 - corner case in pointInsidePolygon * geometry.test: Added two tests for the corner case * pkgIndex.tcl: Updated version numbers 2009-11-16 Arjen Markus * pdf_stat.tcl: Fix bug #2897419 - very small numbers with beta distribution 2009-10-22 Arjen Markus * interpolate.tcl: Fix bug #2881739 in cubic interpolation 2009-09-28 Andreas Kupries * linalg.test: Switched the test setup back to 'regular' and also fixed the version information in the non-regular branch of the setup. 2009-08-21 Arjen Markus * statistics.tcl: Remove a local variable from interval-mean-stdev 2009-08-12 Arjen Markus * statistics.tcl: Solve bug 2835712 regarding interval-mean-stdev 2009-07-13 Arjen Markus * statistics.tcl: Implement more robust computation of basic statistics Fixes bug 2812832; simplified the code (as indicated by akupries) * statistics.test: Added test for this more robust computation * linalg.tcl: Corrected dim and shape procedures for scalars (version now 1.1.3; Fixes bug 2818958 * linalg.test: Corrected result of dim and shape procedures for scalars * pkgIndex.tcl: Updated version numbers 2009-03-20 Arjen Markus * linalg.tcl: Solving bugs with test matrices (bugs #2695513, 2695564, 2695618) * linalg.test: Added test cases for border matrix and Wilkinson W- and W+ * pkgIndex.tcl: Version of linear algebra package increased to 1.1.1 2009-02-18 Arjen Markus * machineparameters.man: Replaced deprecated markup (bug #2597454) 2009-02-06 Arjen Markus * pkgIndex.tcl: Added machineparameters package * machineparameters.tcl: New package by Michael Baudin * machineparameters.test: Test for the new package * machineparameters.man: Man page for the new package 2008-12-12 Andreas Kupries * * Released and tagged Tcllib 1.11.1 ======================== * 2008-12-01 Andreas Kupries * linalg.man: New commands in last checkin means extended API. * linalg.tcl: Bumping minor version, to 1.1. * pkgIndex.tcl: 2008-12-01 Arjen Markus * linalg.man: changed int to integer, documented new procedures by Michael Baudin * linalg.test: incorporated new tests by Michael Baudin * linalg.tcl: incorporated new procedures, extensions and several bug fixes by Michael Baudin 2008-11-09 Arjen Markus * optimize.man: corrected names of minimum and maximum procedures 2008-10-16 Andreas Kupries * * Released and tagged Tcllib 1.11 ======================== * 2008-10-06 Andreas Kupries * calculus.tcl: Bumped version to 0.7.1, for the commit on * calculus.man: 2008-06-25 by Arjen. Was a bugfix, should * pkgIndex.tcl: have bumped the version then. 2008-08-12 Arjen Markus * special.tcl: bumped version to 0.2.2 (because of previous change) * pkgIndex.tcl: bumped version of "special" to 0.2.2 2008-08-11 Arjen Markus * special.tcl: Replaced old algorithm for erf() and erfc(). Bug #2024843. 2008-07-01 Arjen Markus * roman.man: corrected wrong mark-up command 2008-06-25 Arjen Markus * calculus.tcl: solved problem with solveTriDiagonal (bug 2001539) * calculus.tcl: repaired hidden problem with boundaryValueSecondOrder * calculus.test: added test case for solveTriDiagonal 2008-05-19 Arjen Markus * roman.man: correct namespace ::math::roman, was ::roman. 2008-03-24 Andreas Kupries * pkgIndex.tcl: Synchronized indexed and provided versions of * bigfloat.man: math::bigfloat. 2008-03-22 Andreas Kupries * constants.test: Fixed declaration of package under test, was wrongly declared as support. 2008-03-14 Andreas Kupries * statistics.man: Cleaned up a bit, replaced deprecated [nl] usage with [para]. 2008-02-27 Andreas Kupries * linalg.test (eigenvectors-1.0): Moved brace to correct location. 2008-02-27 Andreas Kupries * linalg.test (eigenvectors-1.0): Fixed missing closing brace. 2008-02-21 Arjen Markus * elliptic.tcl: Error in expression (missing )) 2008-01-18 Arjen Markus * statistics.man: Update manual; added beta distribution * statistics.test: Added tests for beta distribution * pdf-stat.tcl: Added procedures for beta distirbution (Improved implementation by Eric K. Benedict) 2008-01-13 Arjen Markus * statistics.man: Update manual; added description of various new procedures * statistics.test: Added tests for chi square and Student's t distributions * pdf-stat.tcl: Added procedures for chi square and Student's t distributions (Next batch of feature requests by Eric K. Benedict) 2008-01-11 Arjen Markus * statistics.man: Update manual; added description of various new procedures * statistics.test: Added tests for Gamma and Poisson distributions * pdf-stat.tcl: Added procedures for Gamma and Poission distributions (Feature requests by Eric K. Benedict) 2007-12-22 Arjen Markus * linalg.tcl: Corrected bug #1805912 (eigenvectorsSVD) by means of path #1852519 * linalg.test: Added simple test case for eigenvectorsSVD * pkgIndex.tcl: Increased version number for linear algebra (1.0.3 now) 2007-12-11 Arjen Markus * special.tcl: Corrected implementation of Gamma function (reported by EKB) 2007-09-12 Andreas Kupries * * Released and tagged Tcllib 1.10 ======================== * 2007-09-11 Arjen Markus * linalg.test: Corrected test that was linked to SF bug 1784637 * linalg.tcl: Corrected case in matmul that was linked to SF bug 1784637 2007-09-06 Arjen Markus * linalg.tcl: Solved bug with matmul (SF bug 1784637) 2007-08-21 Andreas Kupries * math.test (matchTolerant): Changed to not use tcltest 2.0+ features in a testsuite for tcltest 1.0. Rewritten the tests using this custom comparison command to be tcltest 1.0 compliant. * pkgIndex.tcl: With permission from Arjen moved math::statistics * bessel.test: into the 8.4 section. Due to its new dependency on * elliptic.test: math::linearalgebra via multi-variate linear * statistics.test: regression it now depends on Tcl 8.4+ too. * special.test: Updated the tests using math::statistics for this as well. 2007-08-20 Andreas Kupries * bessel.test: Added missing dependency on math::linearalgebra. * elliptic.test: (For math::statistics). This not fully ok yet, the Tcl core requirements are out of whack too. 2007-07-10 Arjen Markus * statistics.tcl: Corrected a spelling mistake in name of Zachariadis * linalg.test: Removed temporary reference to ferri/ferri.test 2007-07-07 Arjen Markus * math.test: Added a small tolerance for two tests * statistics.man: Added pvar and pstdev, difference between var and pvar documented * statistics.tcl: Added population stdev and variance * statistics.test: Added tests for pvar and pstdev * special.test: Added dependency on math::linearalgebra 2007-06-26 Kevin B. Kenny * elliptic.tcl: Removed a spurious 'puts' in the computation of Jacobian elliptic functions. * special.tcl: Advanced patchlevel to 0.2.1. 2007-03-22 Andreas Kupries * bigfloat.man: Fixed all warnings due to use of now deprecated * bignum.man: commands. Added a section about how to give * calculus.man: feedback. * combinatorics.man: * constants.man: * fourier.man: * fuzzy.man: * geometry.man: * interpolate.man: * linalg.man: * math.man: * optimize.man: * polynomials.man: * qcomplex.man: * rational_funcs.man: * roman.man: * romberg.man: * special.man: * statistics.man: 2007-03-20 Arjen Markus * mvlinreg.tcl : changed the API to make it more robust (no eval needed) * statistics.man : updated description of mv-ols and mv-wls * statistics.test : updated the API 2007-03-18 Arjen Markus * statistics.man : updated description of tstat * statistics.test : converted the example into a test 2007-03-05 Arjen Markus * mvlinreg.tcl : polished the source code (adding standard headers) Still to do: test cases 2007-02-27 Arjen Markus * statistics.man : added description of multivariate linear regression procedures (contribution by Eric Kemp-Benedict) * statistics.tcl : sources "mvlinreg.tcl" now * mvlinreg.tcl : original source code from Eric, still needs some polishing (the test case needs to be integrated too) 2006-11-06 Arjen Markus * fuzzy.test : fixed a dependency on Tcl 8.4 behaviour in one test case (the value of tcl_precision) 2006-10-03 Andreas Kupries * * Released and tagged Tcllib 1.9 ======================== * 2006-09-26 Andreas Kupries * bigfloat.tcl: Bumped version to 1.2.1 * pkgIndex.tcl: 2006-09-26 Stephane Arnold * bigfloat.man : fixed a bug in [math::bigfloat::tostr] * bigfloat.tcl : when a number is close to zero, * bigfloat.test it takes the precision into account, * bigfloat2.tcl so instead of getting '0' we get '0.e-4'. * bigfloat2.test [math::bigfloat::iszero] is not impacted 2006-09-20 Andreas Kupries * math.tcl: Bumped version to 1.2.4 * math.man: * qcomplex.man: Bumped version to 1.0.2 * qcomplex.tcl: * fourier.man: Bumped version to 1.0.2 * fourier.tcl: * interpolate.man: Bumped version to 1.0.2 * interpolate.tcl: * linalg.tcl: Bumped version to 1.0.1 * linalg.man: * pkgIndex.tcl: 2006-09-19 Arjen Markus * linalg.tcl: removed print statement (left over from testing leastSquares) 2006-09-15 Arjen Markus * linalg.man: added remark on name conflict with Tk added missing descriptions of several procedures * linalg.tcl: added crossproduct to the exported commands implemented normalizeStat corrected error in leastSquaresSVD * linalg.test: added test for normalizeStat added test for leastSquaresSVD 2006-06-13 Arjen Markus * pdf_stat.tcl: check for existence of argv0 - child interpreters * plotstat.tcl: ditto * statistics.tcl: ditto 2006-03-29 Andreas Kupries * math.man: Fixed name of romberg package, resorted the list, slight reformatting of items with regard to right margin. 2006-03-28 Andreas Kupries * math.man: Added a bit of markup to the package list for better cross-referencing. * statistics.man: Fixed unclosed bracket. 2006-03-28 Arjen Markus * calculus.tcl (integral2D and integral3D): Fixed a bug concerning intervals that do not start at 0.0 * calculus.tcl (integral2D and integral3D): Added accurate versions for integration over rectangles and blocks (exact for polynomials of degree 3 or less). * statistics.tcl (test-normal): Added implementation of normality test by Torsten Reincke (as it appeared on the Wiki) 2006-03-02 Andreas Kupries * pkgIndex.tcl: Resynchronized the ifneeded/provide version information for math::bignum. 2006-02-21 Arjen Markus * linalg.tcl (matmul): Fixed [SF Tcllib Bug xxxxxxx]. The bug concerns the possibility of using row vectors. Because I did not think they were possible/practical, I regarded all vectors as column vectors or row vectors whenever suitable. Row vectors are however practical, so I needed to add these cases, at least for [matmul]. 2006-02-13 Arjen Markus * bignum.tcl (rshift): Fixed [SF Tcllib Bug 1098051]. (Solution provided by Lars Hellstrom. Added tests for both rshift and lshift) 2006-01-30 Andreas Kupries * bignum.tcl (testbit): Fixed [SF Tcllib Bug 1085562]. Thanks to aubinroy for the report, bugfix, and his patience while waiting for us to apply the fix. * bignum.test: Extended the testsuite. 2006-01-29 Andreas Kupries * bigfloat.test: Fixed use of duplicate test names. * calculus.test: * linalg.test: * statistics.test: 2006-01-23 Andreas Kupries * bessel.test: More boilerplate simplified via use of test support. * bigfloat.test: * bigfloat2.test: * bignum.test: * calculus.test: * combinatorics.test: * constants.test: * elliptic.test: * fourier.test: * fuzzy.test: * geometry.test: * interpolate.test: * linalg.test: * math.test: * optimize.test: * polynomials.test: * qcomplex.test: * roman.test: * special.test: * statistics.test: 2006-01-19 Andreas Kupries * bessel.test: Hooked into the new common test support code. * bigfloat.test: * bigfloat2.test: * bignum.test: * calculus.test: * combinatorics.test: * constants.test: * elliptic.test: * fourier.test: * fuzzy.test: * geometry.test: * interpolate.test: * linalg.test: * math.test: * optimize.test: * polynomials.test: * qcomplex.test: * roman.test: * special.test: * statistics.test: 2006-01-11 Andreas Kupries * fourier.tcl (::math::fourier::lowpass): Changed package * fourier.tcl (::math::fourier::highpass): reference "complexnumbers" to the correct "math::complexnumbers". 2006-01-10 Arjen Markus * linalg.tcl: Fixed bug in procedure angle Added a procedure crossproduct * linalg.man: Added documentation on crossproduct 2005-11-13 Stephane Arnold * bigfloat2.tcl : bug fix in trigonometry, functions may have return a number more precise than the input * bignum.tcl : a little performance enhancement by avoiding the use of [upvar] in [_treat] * bigfloat2.test : minor changes * bigfloat.man : rewriting 40% of the documentation that now covers both 1.2 and 2.0 versions 2005-11-14 Andreas Kupries * pkgIndex.tcl: Reworked the extended package index a bit to keep the general existing structure. 2005-11-13 Stephane Arnold * bigfloat2.tcl,bigfloat2.test : two files forming the math::bigfloat package for Tcl 8.5 * pkgIndex.tcl : updated to handle the different Tcl versions Tcl 8.4 still has math::bigfloat 1.2 2005-11-04 Arjen Markus * roman.test: removed extraneous messages 2005-10-26 Arjen Markus * qcomplex.tcl: error in the computation of the complex cosine. Found by Oscar Andreas Lopez. 2005-10-21 Andreas Kupries * interpolate.test: Reduced requirement for struct down to * interpolate.tcl: struct::matrix, as that is the only structure used by this package. This means that we are loading 272 KB less (344 KB - 72 KB). Also fixed the testsuite header code. 2005-10-10 Arjen Markus * fixed one bug regarding cov in misc.tcl 2005-10-06 Andreas Kupries * * Released and tagged Tcllib 1.8 ======================== * 2005-10-05 Andreas Kupries * pkgIndex.tcl: Updated all version numbers to be in sync with the * bignum.man: changes made to the various packages in this module. * bignum.tcl: * calculus.man: * calculus.tcl: * combinatorics.man: * constants.man: * constants.tcl: * fourier.man: * fourier.tcl: * interpolate.man: * interpolate.tcl: * math.man: * math.tcl: * polynomials.man: * polynomials.tcl: * qcomplex.man: * qcomplex.tcl: * rational_funcs.man: * rational_funcs.tcl: * special.man: * special.tcl: * statistics.man: * statistics.tcl: 2005-10-04 Andreas Kupries * geometry.man: Fixed bad reversals of geometry version * geometry.tcl: numbers. Bumped version to reflect the documentation change. * pkgIndex.tcl: Added new 'math::roman' to package index. 2005-10-04 Arjen Markus * Added roman numerals package by Kenneth Green * geometry.man: Completed the description of the current procedures 2005-09-28 Arjen Markus * optimize.man: Removed note on linear programming. It is working now (not fully, perhaps though) 2005-09-20 Andreas Kupries * pkgIndex.tcl: Declared 8.4 dependency of packages * optimize.man: math::optimize, math::calculus, and * optimize.tcl: math::interpolate in package index, code, and * optimize.test: testsuite. * interpolate.man: * interpolate.tcl: * interpolate.test: * calculus.man: * calculus.tcl: * calculus.test: 2005-09-19 Andreas Kupries * pkgIndex.tcl: Declared 8.4 dependency of linalg package in * linalg.tcl: package index, code, and testsuite. * linalg.test: * bessel.test: Fixed a number of typos in the abort messages. * bigfloat.test: Indented abort messages for better visibility * bignum.test: in the log. * calculus.test: Declared 8.4 dependency of bignum/bigfloat in * constants.test: package index, code, and testsuite. * elliptic.test: Removed 8.4isms from testsuites for packages * fourier.test: allowing use with Tcl 8.2+ * interpolate.test: * linalg.test: * math.test: * optimize.test: * polynomials.test: * qcomplex.test: * special.test: * statistics.test: * bigfloat.tcl: * bignum.tcl: * pkgIndex.tcl: 2005-09-09 Stephane Arnold * bigfloat.tcl : went back to the old algorithm to compute Pi after having done much benchmarks 2005-09-06 Stephane Arnold * bigfloat.tcl : new and faster algorithm to compute Pi 2005-08-31 Stephane Arnold * bigfloat.tcl : added many comments and fixed some minor bugs (possibly following to inexact last digits) * bigfloat.test : fixed a bug that causes the version number of some tests to be replaced by 1.0 or by the string "version" 2005-08-30 Andreas Kupries * bignum.tcl: Fixed code exporting the bignum commands, it was done in the wrong namespace. This fixes [Tcllib SF Bug 1276680]. 2005-08-29 Kevin Kenny * combinatorics.test (combinatorics-2.7,3.10): Revised a few test cases * math.test (math-7.4): to handle Infinity in the interim (pre-TIP#237) 8.5 configuration as well as kennykb-numerics-branch. 2005-08-29 Arjen Markus * Fixed bug #1272910: due to the different rounding of 0.5 in Tcl 8.5, the Quantiles-1.0 test failed. Using different levels steers the test away from this odd edge case. 2005-08-29 Stephane Arnold * bigfloat.tcl : added comments to make code easier to understand 2005-08-28 Stephane Arnold * bigfloat.tcl : many optimizations around the fromstr command and all kind of constants (mainly integer) * bigfloat.test : updated test labels to more significant labels * Bug #1272836 : the math round() function has changed in Tcl 8.5a4 (intentionally) - now the round tests do no more rely upon this function. 2005-08-26 Stephane Arnold * Feature Request 1261101 : automatically convert the strings "0" and "1" to bignums * modified files : bignum.man,bignum.tcl,bignum.test * Bug 1273403 : fixed in bigfloat.test (all tests shared the same version number) 2005-08-25 Kevin Kenny * combinatorics.test (combinatorics-2.7,3.10): Revised a few test cases * math.test (math-7.4): to handle Infinity as well as "overflow" and "division by zero" as an error result. 2005-08-24 Arjen Markus * optimize.man: Corrected a few typos 2005-08-23 Stephane Arnold * bigfloat.tcl : Fixed a small bug in [fromstr]. * bigfloat.man : Trying to make it more clear about accuracy and interval computations. 2005-08-17 Kevin Kenny * optimize.tcl (nelderMead): Added ::math::optimize::nelderMead, * optimize.test (nelderMead-*): an implementation of multidimensional * optimize.man: optimization using the downhill simplex method of Nelder and Mead. (Addition includes test cases and rudimentary documentation.) * exponential.tcl: Changed the demo script not to error out. 2005-08-09 Arjen Markus * Added the linear programming routines that were described in the man page, but not actually there * Updated the test file and man page for this * Updated the pkgIndex.tcl file (optimize now at 1.0) 2005-08-05 Stephane Arnold * bigfloat.tcl : Fixed a bug in [fromstr] when a number began with '+' ; another bug, in [fromdouble], when a number began with '+' or '-'. * bigfloat.test : Added tests for fromdouble. 2005-08-04 Andreas Kupries * bigfloat.man: Replaced a number of ?...? occurences to markup optional arguments with the more correct [opt ...]. 2005-08-04 Stephane Arnold * bigfloat : Fixed a bug in [fromstr] when a number with an exponent beginning by 0 was given (like 1.1e+099) * bigfloat : Added a [fromdouble] new proc. 2005-08-01 Arjen Markus * Changed the credits for Ed Hume at his request (anti-spam measure) 2005-07-26 Stephane Arnold * Changed in many places : '[pi $precision]' to '[pi $precision 1]' in which $precision is treated as binary digit length (instead of decimals) since the internal representation of the mantissa is binary 2005-07-01 Stephane Arnold * bigfloat.man,bigfloat.test,bigfloat.tcl : updated copyright 2005 * bigfloat.man : put the correct package version (1.2) 2005-07-01 Stephane Arnold * bigfloat.tcl : new [int2float] conversion procedure * bigfloat.test : updated test suite for the new procedure * bigfloat.man : updated documentation and added a new EXAMPLES section 2005-06-23 Arjen Markus * bigfloat.tcl: Removed the namespace import statement * bigfloat.test: Explicitly import the bigfloat procedures * qcomplex.test: Force the import of complex number procedures (conflict with bigfloat's sqrt) 2005-06-22 Andreas Kupries * statistics.test: Corrected typos in the test suite for the new commands. 2005-06-22 Arjen Markus * statistics.tcl/test/man: Added several methods: 2x2 tables and two quality control charts * elliptic.tcl/man: Added functions cn, dn and sn. Test cases still needed. 2005-06-07 Kevin Kenny * constants.tcl: Corrected ::math::constants::find_huge and ::math::constants::find_tiny to not go into an infinite loop when overflow is not an error. 2005-05-04 Arjen Markus * Removed reference to argv0 in optimize.tcl (in response to a complaint by Bob Techentin) 2005-04-25 Arjen Markus * Corrected documentation of math::product (was math::prod) 2005-03-16 Andreas Kupries * bigfloat.tcl: Added package require math::bignum. If we use the package we should load it as well. * rational_funcs.tcl: Redone entry '2004-11-22 Andreas Kupries '. Somehow the source command came back. 2005-03-11 Arjen Markus * Corrected problem with exponential_Ei - doubly defined 2005-01-14 Arjen Markus * Added version 1.0 of Stephane Arnold's bigfloat package (newer versions will come later on) 2005-01-10 Andreas Kupries * bignum.tcl: Integrated [Tcllib SF Bug 1093414]. Basic bit * bignum.test: operations (and, or, xor) on big numbers. Correct * bignum.man: operation is limited to positive numbers (including zero). The basic code was provided by Aamer Aakther , modifications of docs, and small testsuite by myself. 2005-01-05 Arjen Markus * Added tests for matmul (and corrected the implementation) 2005-01-04 Arjen Markus * Expanded the documentation (it should now describe all public procedures) * Expanded the tests (not complete, but it should cover most more complicated procedures) * Expanded the set of procedures (only a few algorithms await implementation) 2005-01-03 Arjen Markus * Added modified Gram-Schmidt method to the linear algebra package 2004-12-06 Arjen Markus * Fixed bug in rungeKuttaStep (calculus.tcl) found by Mark Stucky. (Also moved the empty lines upward to better reflect the steps) 2004-11-25 Andreas Kupries * linalg.man: Fixed a formatting bug in the file, found by a regular run of the SAK tool. 2004-11-25 Arjen Markus * Added descriptions of various linear algebra procedures * Updated the code and expanded test cases 2004-11-22 Andreas Kupries * rational_funcs.tcl: Removed bad source'ing of file polynomials.tcl. Depended on current working directory in the right place, and superfluous as well, as immediately after a 'package require' of the package loaded it in the proper manner. Disabled the test code at the end as well. 2004-11-08 Arjen Markus * Added preliminary versions of a linear algebra module (revision of Hume's LA). No documentation yet * Removed the initialisation of CDF (that was left in there) 2004-11-01 Arjen Markus * Moved initialisation of CDF in statistics module to first call 2004-10-05 Andreas Kupries * * Released and tagged Tcllib 1.7 ======================== * 2004-10-02 Arjen Markus * Added preliminary documentation for the geometry module * Added procedure areaPolygon to the geometry module * Added Fourier transform module 2004-09-30 Andreas Kupries * bignum.test: Boilerplate reading file under test. 2004-09-30 Arjen Markus * Added a first set of test cases for the bignum module * Corrected the namespace for the bignum module 2004-09-29 Arjen Markus * Added the bignum module by Salvatore Sanfilippo. No test cases yet 2004-09-23 Andreas Kupries * pdf_stat.tcl: Braced expr'essions, removed duplicated error message. * constants.tcl (find_eps): Fixed expr'essions without braces. * statistics.tcl: * exponential.tcl (proc): Removes superfluous no-op [append]. 2004-09-22 Arjen Markus * *.test: Made sure the test files check for version 2.1 of the tcltest package * *.tcl: Updated the package versions and consistently put the "package provide" statement at the end * interpolate.*: Added cubic splines as interpolation method 2004-09-17 Arjen Markus * bessel.tcl: Better implementation of Bessel functions of integer order. 2004-09-09 Andreas Kupries * calculus.man: Fixed problems in the calculus manpage introduced by the last commit done yesterday. 2004-09-08 Arjen Markus * calculus.tcl: added regula falsi method for finding roots 2004-07-19 Andreas Kupries * combinatorics.man: Polished minimally, name of manpage. * qcomplex.tcl: Polished minimally, changed package name * qcomplex.man: to math::complexnumbers. 2004-07-07 Arjen Markus * bessel,tcl: Indentation adjusted to conform to * bessel.test: the _Tcl Style Guide._ Errors * constants.test: corrected in the documentation of * elliptic.tcl: Romberg integration. * elliptic.text: * qcomplex.tcl: * romberg.man: * special.test: 2004-07-05 Kevin Kenny * calculus.man: Added Romberg integration to * romberg.man: the library. The procedures should * calculus.tcl (romberg*): provide a "production quality" * calculus.test (romberg-*): library for integrating functions * math.tcl: of one variable, including functions * misc.tcl (expectInteger): that have integrable singularities and integrals over half-infinite intervals. * constants.tcl: Changes so that constants get defined in the * constants.test: correct namespace. Changed tests so that they * elliptic.test: don't fail when other tests have already run. * special.tcl: Changed the definition of Gamma to the correct * special.test: one. Also added copyright notices and CVS IDs in several files that lacked them, and corrected indentation in several files. 2004-06-19 Kevin Kenny * interpolate.man: Added polynomial interpolation with Neville's * interpolate.tcl: algorithm; this procedure will be needed in * interpolate.test: Romberg integration, which is the next project. 2004-06-18 Kevin Kenny * bessel.test: Fixed several problems that were causing tests * combinatorics.test: to fail or to run noisily. Corrected inconsistent * interpolate.tcl: package version number in interpolate.tcl. * interpolate.test: * qcomplex.test: * optimize.man: Added min_bound_1d and min_unbound_1d functions * optimize.tcl: to do one-dimensional function minimization, * optimize.test: constrained and unconstrained, respectively, without derivatives. 2004-06-16 Andreas Kupries * interpolate.man: Added a missing list_end before section examples. Fixed usage of braces in the example as well. 2004-06-16 Arjen Markus * added the modules complexnumbers, special, interpolate, constants 2004-05-23 Andreas Kupries * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * 2004-02-09 Jeff Hobbs * combinatorics.tcl (::math::factorial): correct fac 171 off-by-one and use of -strict in string is int|double. 2003-12-22 Joe English * calculus.man (rungeKuttaStep): Add missing argument in function synopsis (bug report from Richard Body). 2003-10-29 Arjen Markus * statistics.tcl (BasicStat): Applied fix for [SF Tcllib Bug 820807]. Uniform data may cause a small negative value when computing the base value for a standard deviation, instead of the correct 0.0. The fix now enforces 0.0 when encountering this situation. This entry in the ChangeLog by Andreas Kupries. 2003-05-05 Andreas Kupries * * Released and tagged Tcllib 1.4 ======================== * 2003-04-24 Andreas Kupries * pkgIndex.tcl: Found math::optimize missing in index. * optimize.man: Version number inconsistent with code, corrected. * calculus.test: Converted [puts] into log statements, and suppress them by default. Reduces the noise when running the testsuite. * math.test: Added output listing the version of the * statistics.test: package we are testing. * calculus.test: * geometry.test: * combinatorics.test: * optimize.test: 2003-04-24 Arjen Markus * liststat.tcl: Corrected the handling of the expression in the list manipulation procedures. This solves the scope problem (bug 725231). AK: Lifted from the 'cvs log'. This passes the testsuite. 2003-04-23 Andreas Kupries * fuzzy.test: Re-applied bug fixes I did before (See 2003-04-13) to the newly committed version, which was not merged, but simply overwrote my changes. 2003-04-21 Andreas Kupries * optimize.test: Corrected errors in loading the functionality under test, and of accessing tcltest. Now functional. 2003-04-18 Joe English * pkgIndex.tcl: Added math::statistics after yesterday's commit by Arjen Markus. * statistics.test: Changed to conform to standard of importing tcltest, changed import of tested functionality, added checks that actually tcltest 1.2 or higher is used (Aborting if not). * statistics.tcl: * liststat.tcl * pdf_stat.tcl: * plotstat.tcl: Reformatted a bit to be more near to the style-guide with regard to indentation. 2003-04-13 Andreas Kupries * pkgIndex.tcl: * fuzzy.tcl: Committed new code (see #535216), this also updates the package to version 0.2 * fuzzy.man: * fuzzy.test: New files for fuzzy comparisons, documentation and testsuite. Fixed some bugs in them. NOTE: There are failures in the testsuite. 2003-04-11 Andreas Kupries * combinatorics.man: * math.man: * math.tcl: * pkgIndex.tcl: Set version of the package to to 1.2.2. 2003-01-16 Andreas Kupries * combinatorics.man: More semantic markup, less visual one. * calculus.man: 2002-06-03 Andreas Kupries * pkgIndex.tcl: updated calculus to version 0.5. * calculus.man: Added [require] declarations. * calculus.README: * calculus.CHANGES: * calculus.tcl: * calculus.test: * calculus.man: Applied changes for #553773 on behalf of Arjen Markus . 2002-05-08 Don Porter * calculus.test: Corrected testing problems by namespace-ifying the file. 2002-04-15 Andreas Kupries * combinatorics.man: Added doctools manpage. * math.man: Added doctools manpage. 2002-03-25 Andreas Kupries * calculus.man: Fixed formatting errors in the doctools manpage. 2002-02-15 Andreas Kupries * Update of calculus. #528434 * calculus.man: New file, calculus documentation in doctools format. * calculus.test: New file, beginnings of testsuite * calculus.CHANGES: * calculus.README: * calculus.tcl: * pkgIndex.tcl: updated to calculus 0.3 2002-02-14 Andreas Kupries * combinatorics.tcl * geometry.tcl (proc): Frink run * math::geometry: Version is now 1.0.1 to distinguish this from the code in tcllib release 1.2 * math: Version is now 1.2.1 to distinguish this from the code in tcllib release 1.2 2002-01-18 Don Porter * math.tcl: [namespace export Beta] got out of sync with the command name. * misc.tcl: removed [package provide math]; duplicated in math.tcl, a sync problem waiting to happen. 2002-01-18 Andreas Kupries * Bumped version to 1.2. 2002-01-18 Andreas Kupries * Added calculus functionality and fuzzy FP comparison as provided by Arjen Markus as is. This code currently has neither true testsuite nor good documentation but was considered important enough to get in now. Polish has to come in the subsequent patch releases. 2002-01-11 Kevin Kenny * combinatorics.tcl: Removed incorrect 'package provide'. 2002-01-11 Kevin Kenny * math.tcl: * misc.tcl: * pkgIndex.tcl: * tclIndex: Reorganized so that math.tcl is a top-level 'package provide' script and loads a tclIndex. The code from 'math.tcl' moves into 'misc.tcl'. * combinatorics.n: * combinatorics.tcl: * combinatorics.test: Added a 'combinatorics' module containing the Gamma function and several related functions (factorial, binomial coefficient, and Beta). (Feature request #484850). 2001-06-21 Andreas Kupries * math.tcl: Fixed dubious code reported by frink. 2000-10-06 Eric Melski * math.test: * math.n: * math.tcl: Added ::math::fibonacci function, to compute numbers in the Fibonacci sequence. 2000-09-08 Eric Melski * math.test: * math.n: * math.tcl: Added ::math::random function. * pkgIndex.tcl: Bumped version number to 1.1. 2000-06-15 Eric Melski * math.n: * math.test: * math.tcl: Incorporated sigma, cov, stats, integrate functions (from Philip Ehrens ). [RFE: 5060] 2000-03-27 Eric Melski * math.n: * math.test: * math.tcl: Added sum, mean, and product functions (from Philip Ehrens ). 2000-03-09 Eric Melski * math.test: Adapted tests for use in/out of tcllib test framework. 2000-03-07 Eric Melski * pkgIndex.tcl: * math.tcl: * math.test: * math.n: Initial versions of files for math library. tcllib-1.15/modules/math/constants.tcl0000755000175000017500000001304612077663116017370 0ustar sergeisergei# constants.tcl -- # Module defining common mathematical and numerical constants # # Copyright (c) 2004 by Arjen Markus. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: constants.tcl,v 1.9 2011/01/18 07:49:53 arjenmarkus Exp $ # #---------------------------------------------------------------------- package require Tcl 8.2 package provide math::constants 1.0.1 # namespace constants # Create a convenient namespace for the constants # namespace eval ::math::constants { # # List of constants and their description # variable constants { pi 3.14159265358979323846 "ratio of circle circumference and diameter" e 2.71828182845904523536 "base for natural logarithm" ln10 2.30258509299404568402 "natural logarithm of 10" phi 1.61803398874989484820 "golden ratio" gamma 0.57721566490153286061 "Euler's constant" sqrt2 1.41421356237309504880 "Square root of 2" thirdrt2 1.25992104989487316477 "One-third power of 2" sqrt3 1.73205080756887729533 "Square root of 3" radtodeg 57.2957795131 "Conversion from radians to degrees" degtorad 0.017453292519943 "Conversion from degrees to radians" onethird 1.0/3.0 "One third (0.3333....)" twothirds 2.0/3.0 "Two thirds (0.3333....)" onesixth 1.0/6.0 "One sixth (0.1666....)" huge [find_huge] "(Approximately) largest number" tiny [find_tiny] "(Approximately) smallest number not equal zero" eps [find_eps] "Smallest number such that 1+eps != 1" } namespace export constants print-constants } # constants -- # Expose the constants in the caller's routine or namespace # # Arguments: # args List of constants to be exposed # Result: # None # proc ::math::constants::constants {args} { foreach const $args { uplevel 1 [list variable $const [set ::math::constants::$const]] } } # print-constants -- # Print the selected or all constants to the screen # # Arguments: # args List of constants to be exposed # Result: # None # proc ::math::constants::print-constants {args} { variable constants if { [llength $args] != 0 } { foreach const $args { set idx [lsearch $constants $const] if { $idx >= 0 } { set descr [lindex $constants [expr {$idx+2}]] puts "$const = [set ::math::constants::$const] = $descr" } else { puts "*** $const unknown ***" } } } else { foreach {const value descr} $constants { puts "$const = [set ::math::constants::$const] = $descr" } } } # find_huge -- # Find the largest possible number # # Arguments: # None # Result: # Estimate of the largest possible number # proc ::math::constants::find_huge {} { set result 1.0 set Inf Inf while {1} { if {[catch {expr {2.0 * $result}} result]} { break } if { $result == $Inf } { break } set prev_result $result } set result $prev_result set adder [expr { $result / 2. }] while { $adder != 0.0 } { if {![catch {expr {$adder + $prev_result}} result]} { if { $result == $prev_result } break if { $result != $Inf } { set prev_result $result } } set adder [expr { $adder / 2. }] } return $prev_result } # find_tiny -- # Find the smallest possible number # # Arguments: # None # Result: # Estimate of the smallest possible number # proc ::math::constants::find_tiny {} { set result 1.0 while { ! [catch {set result [expr {$result/2.0}]}] && $result > 0.0 } { set prev_result $result } return $prev_result } # find_eps -- # Find the smallest number eps such that 1+eps != 1 # # Arguments: # None # Result: # Estimate of the machine epsilon # proc ::math::constants::find_eps { } { set eps 1.0 while { [expr {1.0+$eps}] != 1.0 } { set prev_eps $eps set eps [expr {0.5*$eps}] } return $prev_eps } # Create the variables from the list: # - By using expr we ensure that the best double precision # approximation is assigned to the variable, rather than # just the string # - It also allows us to rely on IEEE arithmetic if available, # so that for instance 3.0*(1.0/3.0) is exactly 1.0 # namespace eval ::math::constants { foreach {const value descr} $constants { # FRINK: nocheck set [namespace current]::$const [expr 0.0+$value] } unset value unset const unset descr rename find_eps {} rename find_tiny {} rename find_huge {} } # some tests -- # if { [info exists ::argv0] && [string equal $::argv0 [info script]] } { ::math::constants::constants pi e ln10 onethird eps set prec $::tcl_precision if {![package vsatisfies [package provide Tcl] 8.5]} { set ::tcl_precision 17 } else { set ::tcl_precision 0 } puts "$pi - [expr {1.0/$pi}]" puts $e puts $ln10 puts "onethird: [expr {3.0*$onethird}]" ::math::constants::print-constants onethird pi e puts "All defined constants:" ::math::constants::print-constants if { 1.0+$eps == 1.0 } { puts "Something went wrong with eps!" } else { puts "Difference: [set ee [expr {1.0+$eps}]] - 1.0 = [expr {$ee-1.0}]" } set ::tcl_precision $prec } tcllib-1.15/modules/math/polynomials.tcl0000755000175000017500000003700512077663116017723 0ustar sergeisergei# polynomials.tcl -- # Implement procedures to deal with polynomial functions # namespace eval ::math::polynomials { variable count 0 ;# Count the number of specific commands namespace eval v {} namespace export polynomial polynCmd evalPolyn \ degreePolyn coeffPolyn allCoeffsPolyn \ derivPolyn primitivePolyn \ addPolyn subPolyn multPolyn \ divPolyn remainderPolyn } # polynomial -- # Return a polynomial definition # # Arguments: # coeffs The coefficients of the polynomial # Result: # Polynomial definition # proc ::math::polynomials::polynomial {coeffs} { set rev_coeffs {} set degree -1 set index 0 foreach coeff $coeffs { if { ! [string is double -strict $coeff] } { return -code error "Coefficients must be real numbers" } set rev_coeffs [concat $coeff $rev_coeffs] if { $coeff != 0.0 } { set degree $index } incr index } # # The leading coefficient must be non-zero # return [list POLYNOMIAL [lrange $rev_coeffs end-$degree end]] } # polynCmd -- # Return a procedure that implements a polynomial evaluation # # Arguments: # coeffs The coefficients of the polynomial (or a definition) # Result: # New procedure # proc ::math::polynomials::polynCmd {coeffs} { variable count if { [lindex $coeffs 0] == "POLYNOMIAL" } { set coeffs [allCoeffsPolyn $coeffs] } set degree [expr {[llength $coeffs]-1}] set body "expr \{[join $coeffs +\$x*(][string repeat ) $degree]\}" incr count set name "::math::polynomials::v::POLYN$count" proc $name {x} $body return $name } # evalPolyn -- # Evaluate a polynomial at a given coordinate # # Arguments: # polyn Polynomial definition # x Coordinate # Result: # Value at x # proc ::math::polynomials::evalPolyn {polyn x} { if { [lindex $polyn 0] != "POLYNOMIAL" } { return -code error "Not a polynomial" } if { ! [string is double $x] } { return -code error "Coordinate must be a real number" } set result 0.0 foreach c [lindex $polyn 1] { set result [expr {$result*$x+$c}] } return $result } # degreePolyn -- # Return the degree of the polynomial # # Arguments: # polyn Polynomial definition # Result: # The degree # proc ::math::polynomials::degreePolyn {polyn} { if { [lindex $polyn 0] != "POLYNOMIAL" } { return -code error "Not a polynomial" } return [expr {[llength [lindex $polyn 1]]-1}] } # coeffPolyn -- # Return the coefficient of the index'th degree of the polynomial # # Arguments: # polyn Polynomial definition # index Degree for which to return the coefficient # Result: # The coefficient of degree "index" # proc ::math::polynomials::coeffPolyn {polyn index} { if { [lindex $polyn 0] != "POLYNOMIAL" } { return -code error "Not a polynomial" } set coeffs [lindex $polyn 1] if { $index < 0 || $index > [llength $coeffs] } { return -code error "Index must be between 0 and [llength $coeffs]" } return [lindex $coeffs end-$index] } # allCoeffsPolyn -- # Return the coefficients of the polynomial # # Arguments: # polyn Polynomial definition # Result: # The coefficients in ascending order # proc ::math::polynomials::allCoeffsPolyn {polyn} { if { [lindex $polyn 0] != "POLYNOMIAL" } { return -code error "Not a polynomial" } set rev_coeffs [lindex $polyn 1] set coeffs {} foreach c $rev_coeffs { set coeffs [concat $c $coeffs] } return $coeffs } # derivPolyn -- # Return the derivative of the polynomial # # Arguments: # polyn Polynomial definition # Result: # The new polynomial # proc ::math::polynomials::derivPolyn {polyn} { if { [lindex $polyn 0] != "POLYNOMIAL" } { return -code error "Not a polynomial" } set coeffs [lindex $polyn 1] set new_coeffs {} set idx [degreePolyn $polyn] foreach c [lrange $coeffs 0 end-1] { lappend new_coeffs [expr {$idx*$c}] incr idx -1 } return [list POLYNOMIAL $new_coeffs] } # primitivePolyn -- # Return the primitive of the polynomial # # Arguments: # polyn Polynomial definition # Result: # The new polynomial # proc ::math::polynomials::primitivePolyn {polyn} { if { [lindex $polyn 0] != "POLYNOMIAL" } { return -code error "Not a polynomial" } set coeffs [lindex $polyn 1] set new_coeffs {} set idx [llength $coeffs] foreach c [lrange $coeffs 0 end] { lappend new_coeffs [expr {$c/double($idx)}] incr idx -1 } return [list POLYNOMIAL [concat $new_coeffs 0.0]] } # addPolyn -- # Add two polynomials and return the result # # Arguments: # polyn1 First polynomial or a scalar # polyn2 Second polynomial or a scalar # Result: # The sum of the two polynomials # Note: # Make sure that the first coefficient is not zero # proc ::math::polynomials::addPolyn {polyn1 polyn2} { if { [llength $polyn1] == 1 && [string is double -strict $polyn1] } { set polyn1 [polynomial $polyn1] } if { [llength $polyn2] == 1 && [string is double -strict $polyn2] } { set polyn2 [polynomial $polyn2] } if { [lindex $polyn1 0] != "POLYNOMIAL" || [lindex $polyn2 0] != "POLYNOMIAL" } { return -code error "Both arguments must be polynomials or a real number" } set coeffs1 [lindex $polyn1 1] set coeffs2 [lindex $polyn2 1] set extra1 [expr {[llength $coeffs2]-[llength $coeffs1]}] while { $extra1 > 0 } { set coeffs1 [concat 0.0 $coeffs1] incr extra1 -1 } set extra2 [expr {[llength $coeffs1]-[llength $coeffs2]}] while { $extra2 > 0 } { set coeffs2 [concat 0.0 $coeffs2] incr extra2 -1 } set new_coeffs {} foreach c1 $coeffs1 c2 $coeffs2 { lappend new_coeffs [expr {$c1+$c2}] } while { [lindex $new_coeffs 0] == 0.0 } { set new_coeffs [lrange $new_coeffs 1 end] } return [list POLYNOMIAL $new_coeffs] } # subPolyn -- # Subtract two polynomials and return the result # # Arguments: # polyn1 First polynomial or a scalar # polyn2 Second polynomial or a scalar # Result: # The difference of the two polynomials # Note: # Make sure that the first coefficient is not zero # proc ::math::polynomials::subPolyn {polyn1 polyn2} { if { [llength $polyn1] == 1 && [string is double -strict $polyn1] } { set polyn1 [polynomial $polyn1] } if { [llength $polyn2] == 1 && [string is double -strict $polyn2] } { set polyn2 [polynomial $polyn2] } if { [lindex $polyn1 0] != "POLYNOMIAL" || [lindex $polyn2 0] != "POLYNOMIAL" } { return -code error "Both arguments must be polynomials or a real number" } set coeffs1 [lindex $polyn1 1] set coeffs2 [lindex $polyn2 1] set extra1 [expr {[llength $coeffs2]-[llength $coeffs1]}] while { $extra1 > 0 } { set coeffs1 [concat 0.0 $coeffs1] incr extra1 -1 } set extra2 [expr {[llength $coeffs1]-[llength $coeffs2]}] while { $extra2 > 0 } { set coeffs2 [concat 0.0 $coeffs2] incr extra2 -1 } set new_coeffs {} foreach c1 $coeffs1 c2 $coeffs2 { lappend new_coeffs [expr {$c1-$c2}] } while { [lindex $new_coeffs 0] == 0.0 } { set new_coeffs [lrange $new_coeffs 1 end] } return [list POLYNOMIAL $new_coeffs] } # multPolyn -- # Multiply two polynomials and return the result # # Arguments: # polyn1 First polynomial or a scalar # polyn2 Second polynomial or a scalar # Result: # The difference of the two polynomials # Note: # Make sure that the first coefficient is not zero # proc ::math::polynomials::multPolyn {polyn1 polyn2} { if { [llength $polyn1] == 1 && [string is double -strict $polyn1] } { set polyn1 [polynomial $polyn1] } if { [llength $polyn2] == 1 && [string is double -strict $polyn2] } { set polyn2 [polynomial $polyn2] } if { [lindex $polyn1 0] != "POLYNOMIAL" || [lindex $polyn2 0] != "POLYNOMIAL" } { return -code error "Both arguments must be polynomials or a real number" } set coeffs1 [lindex $polyn1 1] set coeffs2 [lindex $polyn2 1] # # Take care of the null polynomial # if { $coeffs1 == {} || $coeffs2 == {} } { return [polynomial {}] } set zeros {} foreach c $coeffs1 { lappend zeros 0.0 } set new_coeffs [lrange $zeros 1 end] foreach c $coeffs2 { lappend new_coeffs 0.0 } set idx 0 foreach c $coeffs1 { set term_coeffs {} foreach c2 $coeffs2 { lappend term_coeffs [expr {$c*$c2}] } set term_coeffs [concat [lrange $zeros 0 [expr {$idx-1}]] \ $term_coeffs \ [lrange $zeros [expr {$idx+1}] end]] set sum_coeffs {} foreach t $term_coeffs n $new_coeffs { lappend sum_coeffs [expr {$t+$n}] } set new_coeffs $sum_coeffs incr idx } return [list POLYNOMIAL $new_coeffs] } # divPolyn -- # Divide two polynomials and return the quotient # # Arguments: # polyn1 First polynomial or a scalar # polyn2 Second polynomial or a scalar # Result: # The difference of the two polynomials # Note: # Make sure that the first coefficient is not zero # proc ::math::polynomials::divPolyn {polyn1 polyn2} { if { [llength $polyn1] == 1 && [string is double -strict $polyn1] } { set polyn1 [polynomial $polyn1] } if { [llength $polyn2] == 1 && [string is double -strict $polyn2] } { set polyn2 [polynomial $polyn2] } if { [lindex $polyn1 0] != "POLYNOMIAL" || [lindex $polyn2 0] != "POLYNOMIAL" } { return -code error "Both arguments must be polynomials or a real number" } set coeffs1 [lindex $polyn1 1] set coeffs2 [lindex $polyn2 1] # # Take care of the null polynomial # if { $coeffs1 == {} } { return [polynomial {}] } if { $coeffs2 == {} } { return -code error "Denominator can not be zero" } foreach {quotient remainder} [DivRemPolyn $polyn1 $polyn2] {break} return $quotient } # remainderPolyn -- # Divide two polynomials and return the remainder # # Arguments: # polyn1 First polynomial or a scalar # polyn2 Second polynomial or a scalar # Result: # The difference of the two polynomials # Note: # Make sure that the first coefficient is not zero # proc ::math::polynomials::remainderPolyn {polyn1 polyn2} { if { [llength $polyn1] == 1 && [string is double -strict $polyn1] } { set polyn1 [polynomial $polyn1] } if { [llength $polyn2] == 1 && [string is double -strict $polyn2] } { set polyn2 [polynomial $polyn2] } if { [lindex $polyn1 0] != "POLYNOMIAL" || [lindex $polyn2 0] != "POLYNOMIAL" } { return -code error "Both arguments must be polynomials or a real number" } set coeffs1 [lindex $polyn1 1] set coeffs2 [lindex $polyn2 1] # # Take care of the null polynomial # if { $coeffs1 == {} } { return [polynomial {}] } if { $coeffs2 == {} } { return -code error "Denominator can not be zero" } foreach {quotient remainder} [DivRemPolyn $polyn1 $polyn2] {break} return $remainder } # DivRemPolyn -- # Divide two polynomials and return the quotient and remainder # # Arguments: # polyn1 First polynomial or a scalar # polyn2 Second polynomial or a scalar # Result: # The difference of the two polynomials # Note: # Make sure that the first coefficient is not zero # proc ::math::polynomials::DivRemPolyn {polyn1 polyn2} { set coeffs1 [lindex $polyn1 1] set coeffs2 [lindex $polyn2 1] set steps [expr { [degreePolyn $polyn1] - [degreePolyn $polyn2] + 1 }] # # Special case: polynomial 1 has lower degree than polynomial 2 # if { $steps <= 0 } { return [list [polynomial 0.0] $polyn1] } else { set extra_coeffs {} for { set i 1 } { $i < $steps } { incr i } { lappend extra_coeffs 0.0 } lappend extra_coeffs 1.0 } set c2 [lindex $coeffs2 0] set quot_coeffs {} for { set i 0 } { $i < $steps } { incr i } { set c1 [lindex $coeffs1 0] set factor [expr {$c1/$c2}] set fpolyn [multPolyn $polyn2 \ [polynomial [lrange $extra_coeffs $i end]]] set newpol [subPolyn $polyn1 [multPolyn $fpolyn $factor]] # # Due to rounding errors, a very small, parasitical # term may still exist. Remove it # if { [degreePolyn $newpol] == [degreePolyn $polyn1] } { set new_coeffs [lrange [allCoeffsPolyn $newpol] 0 end-1] set newpol [polynomial $new_coeffs] } set polyn1 $newpol set coeffs1 [lindex $polyn1 1] set quot_coeffs [concat $factor $quot_coeffs] } set quotient [polynomial $quot_coeffs] return [list $quotient $polyn1] } # # Announce our presence # package provide math::polynomials 1.0.1 # some tests -- # if { 0 } { set prec $::tcl_precision if {![package vsatisfies [package provide Tcl] 8.5]} { set ::tcl_precision 17 } else { set ::tcl_precision 0 } set f1 [::math::polynomials::polynomial {1 2 3}] set f2 [::math::polynomials::polynomial {1 2 3 0}] set f3 [::math::polynomials::polynomial {0 0 0 0}] set f4 [::math::polynomials::polynomial {5 7}] set cmdf1 [::math::polynomials::polynCmd {1 2 3}] foreach x {0 1 2 3 4 5} { puts "[::math::polynomials::evalPolyn $f1 $x] -- \ [expr {1.0+2.0*$x+3.0*$x*$x}] -- \ [$cmdf1 $x] -- [::math::polynomials::evalPolyn $f3 $x]" } puts "Degree: [::math::polynomials::degreePolyn $f1] (expected: 2)" puts "Degree: [::math::polynomials::degreePolyn $f2] (expected: 2)" foreach d {0 1 2} { puts "Coefficient $d = [::math::polynomials::coeffPolyn $f2 $d]" } puts "All coefficients = [::math::polynomials::allCoeffsPolyn $f2]" puts "Derivative = [::math::polynomials::derivPolyn $f1]" puts "Primitive = [::math::polynomials::primitivePolyn $f1]" puts "Add: [::math::polynomials::addPolyn $f1 $f4]" puts "Add: [::math::polynomials::addPolyn $f4 $f1]" puts "Subtract: [::math::polynomials::subPolyn $f1 $f4]" puts "Multiply: [::math::polynomials::multPolyn $f1 $f4]" set f1 [::math::polynomials::polynomial {1 2 3}] set f2 [::math::polynomials::polynomial {0 1}] puts "Divide: [::math::polynomials::divPolyn $f1 $f2]" puts "Remainder: [::math::polynomials::remainderPolyn $f1 $f2]" set f1 [::math::polynomials::polynomial {1 2 3}] set f2 [::math::polynomials::polynomial {1 1}] puts "Divide: [::math::polynomials::divPolyn $f1 $f2]" puts "Remainder: [::math::polynomials::remainderPolyn $f1 $f2]" set f1 [::math::polynomials::polynomial {1 2 3}] set f2 [::math::polynomials::polynomial {0 1}] set f3 [::math::polynomials::divPolyn $f2 $f1] set coeffs [::math::polynomials::allCoeffsPolyn $f3] puts "Coefficients: $coeffs" set f3 [::math::polynomials::divPolyn $f1 $f2] set coeffs [::math::polynomials::allCoeffsPolyn $f3] puts "Coefficients: $coeffs" set f1 [::math::polynomials::polynomial {1 2 3}] set f2 [::math::polynomials::polynomial {0}] set f3 [::math::polynomials::divPolyn $f2 $f1] set coeffs [::math::polynomials::allCoeffsPolyn $f3] puts "Coefficients: $coeffs" set ::tcl_precision $prec } tcllib-1.15/modules/math/calculus.README0000755000175000017500000000135712077663116017344 0ustar sergeisergeiPackage: math::calculus ----------------------- The math::calculus package is an all-Tcl package that implements several basic numerical algorithms, such as the integration of functions of one variable or the integration of ordinary differential equations. The directory contains the following files: README - This file CHANGES - Changes made since the previous version(s) calculus.tcl - The source code for the package calculus.test - Several simple tests calculus.html - Documentation of the package The current version is: 0.5, may 2002 This package is available as part of Tcllib at: http://tcllib.sourceforge.net Please contact Arjen Markus (arjen.markus@wldelft.nl) for questions, bug reports, enhancements and so on. tcllib-1.15/modules/math/bigfloat.test0000755000175000017500000005107512077663116017344 0ustar sergeisergei# -*- tcl -*- ######################################################################## # BigFloat for Tcl # Copyright (C) 2003-2005 ARNOLD Stephane # # BIGFLOAT LICENSE TERMS # # This software is copyrighted by Stephane ARNOLD, (stephanearnold yahoo.fr). # 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. # # GOVERNMENT USE: If you are acquiring this software on behalf of the # U.S. government, the Government shall have only "Restricted Rights" # in the software and related documentation as defined in the Federal # Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you # are acquiring the software on behalf of the Department of Defense, the # software shall be classified as "Commercial Computer Software" and the # Government shall have only "Restricted Rights" as defined in Clause # 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the # authors grant the U.S. Government and others acting in its behalf # permission to use and distribute the software in accordance with the # terms specified in this license. # ######################################################################## source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.4 testsNeedTcltest 1.0 support { useLocal math.tcl math useLocal bignum.tcl math::bignum } testing { useLocal bigfloat.tcl math::bigfloat } # ------------------------------------------------------------------------- namespace import ::math::bigfloat::* # ------------------------------------------------------------------------- proc assert {name version code result} { #puts -nonewline $version, test bigfloat-$name-$version \ "Some integer computations related to command $name" { uplevel 1 $code } $result ; # {} return } interp alias {} zero {} string repeat 0 # S.ARNOLD 08/01/2005 # trying to set the precision of the comparisons to 15 digits set old_precision $::tcl_precision set ::tcl_precision 15 proc Zero {x} { global tcl_precision set x [expr {abs($x)}] set epsilon 10.0e-$tcl_precision return [expr {$x<$epsilon}] } proc fassert {name version code result} { #puts -nonewline $version, set tested [uplevel 1 $code] if {[Zero $tested]} { tcltest::test bigfloat-$name-$version \ "Some floating-point computations related to command $name" { return [Zero $result] } 1 ; # {} return } set resultat [Zero [expr {($tested-$result)/((abs($tested)>1)?($tested):1.0)}]] tcltest::test bigfloat-$name-$version \ "Some floating-point computations related to command $name" { return $resultat } 1 ; # {} return } # preprocessing is done #set n ###################################################### # Begin testsuite ###################################################### # adds 999..9 and 1 -> 1000..0 for {set i 1} {$i<15} {incr i} { assert add 1.0.$i { tostr [add \ [fromstr [string repeat 999 $i]] [fromstr 1]] } 1[string repeat 000 $i] ; # {} } # sub 1000..0 1 -> 999..9 for {set i 1} {$i<15} {incr i} { assert sub 1.1.$i { tostr [sub [fromstr 1[string repeat 000 $i]] [fromstr 1]] } [string repeat 999 $i] ; # {} } # mul 10001000..1000 with 1..9 for {set i 1} {$i<15} {incr i} { foreach j {1 2 3 4 5 6 7 8 9} { assert mul 1.2.$i.$j {tostr [mul [fromstr [string repeat 1000 $i]] [fromstr $j]]} \ [string repeat ${j}000 $i] } } # div 10^8 by 1 .. 9 for {set i 1} {$i<=9} {incr i} { assert div 1.3.$i {tostr [div [fromstr 100000000] [fromstr $i]]} [expr {wide(100000000)/$i}] } # 10^8 modulo 1 .. 9 for {set i 1} {$i<=9} {incr i} { assert mod 1.4.$i {tostr [mod [fromstr 100000000] [fromstr $i]]} [expr {wide(100000000)%$i}] } ################################################################################ # fromstr problem with octal exponents ################################################################################ fassert fromstr 2.0 {todouble [fromstr 1.0e+099]} 1.0e+099 fassert fromstr 2.0a {todouble [fromstr 1.0e99]} 1.0e99 fassert fromstr 2.0b {todouble [fromstr 1.0e-99]} 1.0e-99 fassert fromstr 2.0c {todouble [fromstr 1.0e-099]} 1.0e-99 ################################################################################ # fromdouble with precision ################################################################################ assert fromdouble 2.1 {tostr [ceil [fromdouble 1.0e99 100]]} 1[zero 99] assert fromdouble 2.1a {tostr [fromdouble 1.11 3]} 1.11 assert fromdouble 2.1b {tostr [fromdouble +1.11 3]} 1.11 assert fromdouble 2.1c {tostr [fromdouble -1.11 3]} -1.11 assert fromdouble 2.1d {tostr [fromdouble +01.11 3]} 1.11 assert fromdouble 2.1e {tostr [fromdouble -01.11 3]} -1.11 # more to come... fassert fromdouble 2.1f {compare [fromdouble [expr {atan(1.0)*4}]] [pi $::tcl_precision]} 0 ################################################################################ # abs() ################################################################################ proc absTest {version x {int 0}} { if {!$int} { fassert abs $version { tostr [abs [fromstr $x]] } [expr {abs($x)}] ; # {} } else { assert abs $version { tostr [abs [fromstr $x]] } [expr {($x<0)?(-$x):$x}] ; # {} } } absTest 2.2a 1.000 absTest 2.2b -1.000 absTest 2.2c -0.10 absTest 2.2d 0 1 absTest 2.2e 1 1 absTest 2.2f 10000 1 absTest 2.2g -1 1 absTest 2.2h -10000 1 rename absTest "" ################################################################################ # opposite ################################################################################ proc oppTest {version x {int 0}} { if {$int} { assert opp $version {tostr [opp [fromstr $x]]} [expr {-$x}] } else { fassert opp $version {tostr [opp [fromstr $x]]} [expr {-$x}] } } oppTest 2.3a 1.00 oppTest 2.3b -1.00 oppTest 2.3c 0.10 oppTest 2.3d -0.10 oppTest 2.3e 0.00 oppTest 2.3f 1 1 oppTest 2.3g -1 1 oppTest 2.3h 0 1 oppTest 2.3i 100000000 1 oppTest 2.3j -100000000 1 rename oppTest "" ################################################################################ # equal ################################################################################ proc equalTest {x y} { equal [fromstr $x] [fromstr $y] } assert equal 2.4a {equalTest 0.0 0.1} 1 assert equal 2.4b {equalTest 0.00 0.10} 0 assert equal 2.4c {equalTest 0.0 -0.1} 1 assert equal 2.4d {equalTest 0.00 -0.10} 0 rename equalTest "" ################################################################################ # compare ################################################################################ proc compareTest {x y} { compare [fromstr $x] [fromstr $y] } assert cmp 2.5a {compareTest 0.00 0.10} -1 assert cmp 2.5b {compareTest 0.1 0.4} -1 assert cmp 2.5c {compareTest 0.0 -1.0} 1 assert cmp 2.5d {compareTest -1.0 0.0} -1 assert cmp 2.5e {compareTest 0.00 0.10} -1 # cleanup rename compareTest "" ################################################################################ # round ################################################################################ proc roundTest {version x rounded} { assert round $version {tostr [round [fromstr $x]]} $rounded } roundTest 2.6.0 0.10 0 roundTest 2.6.1 0.0 0 roundTest 2.6.2 0.50 1 roundTest 2.6.3 0.40 0 roundTest 2.6.4 1.0 1 roundTest 2.6.5 -0.40 0 roundTest 2.6.6 -0.50 -1 roundTest 2.6.7 -1.0 -1 roundTest 2.6.8 -1.50 -2 roundTest 2.6.9 1.50 2 # cleanup rename roundTest "" ################################################################################ # floor ################################################################################ proc floorTest {version x} { assert floor $version {tostr [floor [fromstr $x]]} [expr {int(floor($x))}] } floorTest 2.7a 0.10 floorTest 2.7b 0.90 floorTest 2.7c 1.0 floorTest 2.7d -0.10 floorTest 2.7e -1.0 # cleanup rename floorTest "" ################################################################################ # ceil ################################################################################ proc ceilTest {version x} { assert ceil $version {tostr [ceil [fromstr $x]]} [expr {int(ceil($x))}] } ceilTest 2.8a 0.10 ceilTest 2.8b 0.90 ceilTest 2.8c 1.0 ceilTest 2.8d -0.10 ceilTest 2.8e -1.0 ceilTest 2.8f 0.0 # cleanup rename ceilTest "" ################################################################################ # BigInt to BigFloat conversion ################################################################################ proc convTest {version x {decimals 1}} { assert int2float $version {tostr [int2float [fromstr $x] $decimals]} \ $x.[string repeat 0 [expr {$decimals-1}]] } set subversion 0 foreach decimals {1 2 5 10 100} { set version 2.9.$subversion fassert int2float $version.0 {tostr [int2float [fromstr 0] $decimals]} 0.0 convTest $version.1 1 $decimals convTest $version.2 5 $decimals convTest $version.3 5000000000 $decimals incr subversion } #cleanup rename convTest "" ################################################################################ # addition ################################################################################ proc addTest {version x y} { fassert add $version {todouble [add [fromstr $x] [fromstr $y]]} [expr {$x+$y}] } addTest 3.0a 1.00 2.00 addTest 3.0b -1.00 2.00 addTest 3.0c 1.00 -2.00 addTest 3.0d -1.00 -2.00 addTest 3.0e 0.00 1.00 addTest 3.0f 0.00 -1.00 addTest 3.0g 1 2.00 addTest 3.0h 1 -2.00 addTest 3.0i 0 1.00 addTest 3.0j 0 -1.00 addTest 3.0k 2.00 1 addTest 3.0l -2.00 1 addTest 3.0m 1.00 0 addTest 3.0n -1.00 0 #cleanup rename addTest "" ################################################################################ # substraction ################################################################################ proc subTest {version x y} { fassert sub $version {todouble [sub [fromstr $x] [fromstr $y]]} [expr {$x-$y}] } subTest 3.1a 1.00 2.00 subTest 3.1b -1.00 2.00 subTest 3.1c 1.00 -2.00 subTest 3.1d -1.00 -2.00 subTest 3.1e 0.00 1.00 subTest 3.1f 0.00 -1.00 subTest 3.1g 1 2.00 subTest 3.1h 1 -2.00 subTest 3.1i 0 2.00 subTest 3.1j 0 -2.00 subTest 3.1k 2 0.00 subTest 3.1l 2.00 1 subTest 3.1m 1.00 2 subTest 3.1n -1.00 1 subTest 3.1o 0.00 2 subTest 3.1p 2.00 0 # cleanup rename subTest "" ################################################################################ # multiplication ################################################################################ proc mulTest {version x y} { fassert mul $version {todouble [mul [fromstr $x] [fromstr $y]]} [expr {$x*$y}] } proc mulInt {version x y} { mulTest $version.0 $x $y mulTest $version.1 $y $x } mulTest 3.2a 1.00 2.00 mulTest 3.2b -1.00 2.00 mulTest 3.2c 1.00 -2.00 mulTest 3.2d -1.00 -2.00 mulTest 3.2e 0.00 1.00 mulTest 3.2f 0.00 -1.00 mulTest 3.2g 1.00 10.0 mulInt 3.2h 1 2.00 mulInt 3.2i 1 -2.00 mulInt 3.2j 0 2.00 mulInt 3.2k 0 -2.00 mulInt 3.2l 10 2.00 mulInt 3.2m 10 -2.00 mulInt 3.2n 1 0.00 # cleanup rename mulTest "" rename mulInt "" ################################################################################ # division ################################################################################ proc divTest {version x y} { fassert div $version { string trimright [todouble [div [fromstr $x] [fromstr $y]]] 0 } [string trimright [expr {$x/$y}] 0] ; # {} } divTest 3.3a 1.00 2.00 divTest 3.3b 2.00 1.00 divTest 3.3c -1.00 2.00 divTest 3.3d 1.00 -2.00 divTest 3.3e 2.00 -1.00 divTest 3.3f -2.00 1.00 divTest 3.3g -1.00 -2.00 divTest 3.3h -2.00 -1.00 divTest 3.3i 0.0 1.0 divTest 3.3j 0.0 -1.0 # cleanup rename divTest "" ################################################################################ # rest of the division ################################################################################ proc modTest {version x y} { fassert mod $version { todouble [mod [fromstr $x] [fromstr $y]] } [expr {fmod($x,$y)}] ; # {} } modTest 3.4a 1.00 2.00 modTest 3.4b 2.00 1.00 modTest 3.4c -1.00 2.00 modTest 3.4d 1.00 -2.00 modTest 3.4e 2.00 -1.00 modTest 3.4f -2.00 1.00 modTest 3.4g -1.00 -2.00 modTest 3.4h -2.00 -1.00 modTest 3.4i 0.0 1.0 modTest 3.4j 0.0 -1.0 modTest 3.4k 1.00 2 modTest 3.4l 2.00 1 modTest 3.4m -1.00 2 modTest 3.4n -2.00 1 modTest 3.4o 0.0 1 modTest 3.4p 1.50 1 # cleanup rename modTest "" ################################################################################ # divide a BigFloat by an integer ################################################################################ proc divTest {version x y} { fassert div $version {todouble [div [fromstr $x] [fromstr $y]]} \ [expr {double(round(1000*$x/$y))/1000.0}] } set subversion 0 foreach a {1.0000 -1.0000} { foreach b {2 3} { divTest 3.5.$subversion $a $b incr subversion } } # cleanup rename divTest "" ################################################################################ # pow : takes a float to an integer power (>0) ################################################################################ proc powTest {version x y {int 0}} { if {!$int} { fassert pow $version {todouble [pow [fromstr $x 14] [fromstr $y]]}\ [expr [join [string repeat "[string trimright $x 0] " $y] *]] } else { assert pow $version {tostr [pow [fromstr $x] [fromstr $y]]}\ [expr [join [string repeat "$x " $y] *]] } } set subversion 0 foreach a {1 -1 2 -2 5 -5} { foreach b {2 3 7 16} { powTest 3.6.$subversion $a. $b incr subversion } } set subversion 0 foreach a {1 2 3} { foreach b {2 3 5 8} { powTest 3.7.$subversion $a $b 1 incr subversion } } # cleanup rename powTest "" ################################################################################ # pi constant and angles conversion ################################################################################ fassert pi 3.8.0 {todouble [pi 16]} [expr {atan(1)*4}] # converts Pi -> 180° fassert rad2deg 3.8.1 {todouble [rad2deg [pi 20]]} 180.0 # converts 180° -> Pi fassert deg2rad 3.8.2 {todouble [deg2rad [fromstr 180.0 20]]} [expr {atan(1.0)*4}] ################################################################################ # iszero : the precision is too small to determinate the number ################################################################################ assert iszero 4.0a {iszero [fromstr 0]} 1 assert iszero 4.0b {iszero [fromstr 0.0]} 1 assert iszero 4.0c {iszero [fromstr 1]} 0 assert iszero 4.0d {iszero [fromstr 1.0]} 0 assert iszero 4.0e {iszero [fromstr -1]} 0 assert iszero 4.0f {iszero [fromstr -1.0]} 0 ################################################################################ # sqrt : square root ################################################################################ proc sqrtTest {version x} { fassert sqrt $version {todouble [sqrt [fromstr $x 18]]} [expr {sqrt($x)}] } sqrtTest 4.1a 1. sqrtTest 4.1b 0.001 sqrtTest 4.1c 0.004 sqrtTest 4.1d 4. # cleanup rename sqrtTest "" ################################################################################ # expTest : exponential function ################################################################################ proc expTest {version x} { fassert exp $version {todouble [exp [fromstr $x 17]]} [expr {exp($x)}] } expTest 4.2a 1. expTest 4.2b 0.001 expTest 4.2c 0.004 expTest 4.2d 40. expTest 4.2e -0.001 # cleanup rename expTest "" ################################################################################ # logTest : logarithm ################################################################################ proc logTest {version x} { fassert log $version {todouble [log [fromstr $x 17]]} [expr {log($x)}] } logTest 4.3a 1.0 logTest 4.3b 0.001 logTest 4.3c 0.004 logTest 4.3d 40. logTest 4.3e 1[zero 10].0 # cleanup rename logTest "" ################################################################################ # cos & sin : trigonometry ################################################################################ proc cosEtSin {version quartersOfPi} { set x [div [mul [pi 18] [fromstr $quartersOfPi]] [fromstr 4]] #fassert cos {todouble [cos $x]} [expr {cos(atan(1)*$quartersOfPi)}] #fassert sin {todouble [sin $x]} [expr {sin(atan(1)*$quartersOfPi)}] fassert cos $version.0 {todouble [cos $x]} [expr {cos([todouble $x])}] fassert sin $version.1 {todouble [sin $x]} [expr {sin([todouble $x])}] } fassert cos 4.4.0.0 {todouble [cos [fromstr 0. 17]]} [expr {cos(0)}] fassert sin 4.4.0.1 {todouble [sin [fromstr 0. 17]]} [expr {sin(0)}] foreach i {1 2 3 4 5 6 7 8} { cosEtSin 4.4.$i $i } # cleanup rename cosEtSin "" ################################################################################ # tan & cotan : trigonometry ################################################################################ proc tanCotan {version i} { upvar pi pi set x [div [mul $pi [fromstr $i]] [fromstr 10]] set double [expr {atan(1)*(double($i)*0.4)}] fassert cos $version.0 {todouble [cos $x]} [expr {cos($double)}] fassert sin $version.1 {todouble [sin $x]} [expr {sin($double)}] fassert tan $version.2 {todouble [tan $x]} [expr {tan($double)}] fassert cotan $version.3 {todouble [cotan $x]} [expr {double(1.0)/tan($double)}] } set pi [pi 20] set subversion 0 foreach i {1 2 3 6 7 8 9} { tanCotan 4.5.$subversion $i incr subversion } # cleanup rename tanCotan "" ################################################################################ # atan , asin & acos : trigonometry (inverse functions) ################################################################################ proc atanTest {version x} { set f [fromstr $x 20] fassert atan $version.0 {todouble [atan $f]} [expr {atan($x)}] if {abs($x)<=1.0} { fassert acos $version.1 {todouble [acos $f]} [expr {acos($x)}] fassert asin $version.2 {todouble [asin $f]} [expr {asin($x)}] } } set subversion 0 atanTest 4.6.0.0 0.0 foreach i {1 2 3 4 5 6 7 8 9} { atanTest 4.6.1.$subversion 0.$i atanTest 4.6.2.$subversion $i.0 atanTest 4.6.3.$subversion -0.$i atanTest 4.6.4.$subversion -$i.0 incr subversion } # cleanup rename atanTest "" ################################################################################ # cosh , sinh & tanh : hyperbolic functions ################################################################################ proc hyper {version x} { set f [fromstr $x 18] fassert cosh $version.0 {todouble [cosh $f]} [expr {cosh($x)}] fassert sinh $version.1 {todouble [sinh $f]} [expr {sinh($x)}] fassert tanh $version.2 {todouble [tanh $f]} [expr {tanh($x)}] } hyper 4.7.0 0.0 set subversion 0 foreach i {1 2 3 4 5 6 7 8 9} { hyper 4.7.1.$subversion.$i 0.$i hyper 4.7.2.$subversion.$i $i.0 hyper 4.7.3.$subversion.$i -0.$i hyper 4.7.4.$subversion.$i -$i.0 } # cleanup rename hyper "" ################################################################################ # tostr with -nosci option ################################################################################ set version 5.0 fassert tostr-nosci $version.0 {tostr -nosci [fromstr 23450.e+7]} 234500000000. fassert tostr-nosci $version.1 {tostr -nosci [fromstr 23450.e-7]} 0.002345 fassert tostr-nosci $version.2 {tostr -nosci [fromstr 23450000]} 23450000. fassert tostr-nosci $version.3 {tostr -nosci [fromstr 2345.0]} 2345. ################################################################################ # end of testsuite for bigfloat 1.0 ################################################################################ # cleanup global procs rename assert "" rename fassert "" rename Zero "" testsuiteCleanup set ::tcl_precision $old_precision tcllib-1.15/modules/math/linalg.man0000755000175000017500000007312312077663116016615 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin math::linearalgebra n 1.1] [copyright {2004-2008 Arjen Markus }] [copyright {2004 Ed Hume }] [copyright {2008 Michael Buadin }] [moddesc {Tcl Math Library}] [titledesc {Linear Algebra}] [category Mathematics] [require Tcl [opt 8.4]] [require math::linearalgebra [opt 1.1]] [keywords math {linear algebra} vectors matrices {least squares}] [keywords matrix {linear equations}] [description] [para] This package offers both low-level procedures and high-level algorithms to deal with linear algebra problems: [list_begin itemized] [item] robust solution of linear equations or least squares problems [item] determining eigenvectors and eigenvalues of symmetric matrices [item] various decompositions of general matrices or matrices of a specific form [item] (limited) support for matrices in band storage, a common type of sparse matrices [list_end] It arose as a re-implementation of Hume's LA package and the desire to offer low-level procedures as found in the well-known BLAS library. Matrices are implemented as lists of lists rather linear lists with reserved elements, as in the original LA package, as it was found that such an implementation is actually faster. [para] It is advisable, however, to use the procedures that are offered, such as [emph setrow] and [emph getrow], rather than rely on this representation explicitly: that way it is to switch to a possibly even faster compiled implementation that supports the same API. [para] [emph Note:] When using this package in combination with Tk, there may be a naming conflict, as both this package and Tk define a command [emph scale]. See the [sectref "NAMING CONFLICT"] section below. [section "PROCEDURES"] The package defines the following public procedures (several exist as specialised procedures, see below): [para] [emph "Constructing matrices and vectors"] [list_begin definitions] [call [cmd ::math::linearalgebra::mkVector] [arg ndim] [arg value]] Create a vector with ndim elements, each with the value [emph value]. [list_begin arguments] [arg_def integer ndim] Dimension of the vector (number of components) [arg_def double value] Uniform value to be used (default: 0.0) [list_end] [para] [call [cmd ::math::linearalgebra::mkUnitVector] [arg ndim] [arg ndir]] Create a unit vector in [emph ndim]-dimensional space, along the [emph ndir]-th direction. [list_begin arguments] [arg_def integer ndim] Dimension of the vector (number of components) [arg_def integer ndir] Direction (0, ..., ndim-1) [list_end] [para] [call [cmd ::math::linearalgebra::mkMatrix] [arg nrows] [arg ncols] [arg value]] Create a matrix with [emph nrows] rows and [emph ncols] columns. All elements have the value [emph value]. [list_begin arguments] [arg_def integer nrows] Number of rows [arg_def integer ncols] Number of columns [arg_def double value] Uniform value to be used (default: 0.0) [list_end] [para] [call [cmd ::math::linearalgebra::getrow] [arg matrix] [arg row] [opt imin] [opt imax]] Returns a single row of a matrix as a list [list_begin arguments] [arg_def list matrix] Matrix in question [arg_def integer row] Index of the row to return [arg_def integer imin] Minimum index of the column (default: 0) [arg_def integer imax] Maximum index of the column (default: ncols-1) [list_end] [para] [call [cmd ::math::linearalgebra::setrow] [arg matrix] [arg row] [arg newvalues] [opt imin] [opt imax]] Set a single row of a matrix to new values (this list must have the same number of elements as the number of [emph columns] in the matrix) [list_begin arguments] [arg_def list matrix] [emph name] of the matrix in question [arg_def integer row] Index of the row to update [arg_def list newvalues] List of new values for the row [arg_def integer imin] Minimum index of the column (default: 0) [arg_def integer imax] Maximum index of the column (default: ncols-1) [list_end] [para] [call [cmd ::math::linearalgebra::getcol] [arg matrix] [arg col] [opt imin] [opt imax]] Returns a single column of a matrix as a list [list_begin arguments] [arg_def list matrix] Matrix in question [arg_def integer col] Index of the column to return [arg_def integer imin] Minimum index of the row (default: 0) [arg_def integer imax] Maximum index of the row (default: nrows-1) [list_end] [para] [call [cmd ::math::linearalgebra::setcol] [arg matrix] [arg col] [arg newvalues] [opt imin] [opt imax]] Set a single column of a matrix to new values (this list must have the same number of elements as the number of [emph rows] in the matrix) [list_begin arguments] [arg_def list matrix] [emph name] of the matrix in question [arg_def integer col] Index of the column to update [arg_def list newvalues] List of new values for the column [arg_def integer imin] Minimum index of the row (default: 0) [arg_def integer imax] Maximum index of the row (default: nrows-1) [list_end] [para] [call [cmd ::math::linearalgebra::getelem] [arg matrix] [arg row] [arg col]] Returns a single element of a matrix/vector [list_begin arguments] [arg_def list matrix] Matrix or vector in question [arg_def integer row] Row of the element [arg_def integer col] Column of the element (not present for vectors) [list_end] [para] [call [cmd ::math::linearalgebra::setelem] [arg matrix] [arg row] [opt col] [arg newvalue]] Set a single element of a matrix (or vector) to a new value [list_begin arguments] [arg_def list matrix] [emph name] of the matrix in question [arg_def integer row] Row of the element [arg_def integer col] Column of the element (not present for vectors) [list_end] [para] [call [cmd ::math::linearalgebra::swaprows] [arg matrix] [arg irow1] [arg irow2] [opt imin] [opt imax]] Swap two rows in a matrix completely or only a selected part [list_begin arguments] [arg_def list matrix] [emph name] of the matrix in question [arg_def integer irow1] Index of first row [arg_def integer irow2] Index of second row [arg_def integer imin] Minimum column index (default: 0) [arg_def integer imin] Maximum column index (default: ncols-1) [list_end] [para] [call [cmd ::math::linearalgebra::swapcols] [arg matrix] [arg icol1] [arg icol2] [opt imin] [opt imax]] Swap two columns in a matrix completely or only a selected part [list_begin arguments] [arg_def list matrix] [emph name] of the matrix in question [arg_def integer irow1] Index of first column [arg_def integer irow2] Index of second column [arg_def integer imin] Minimum row index (default: 0) [arg_def integer imin] Maximum row index (default: nrows-1) [list_end] [list_end] [para] [emph "Querying matrices and vectors"] [list_begin definitions] [call [cmd ::math::linearalgebra::show] [arg obj] [opt format] [opt rowsep] [opt colsep]] Return a string representing the vector or matrix, for easy printing. (There is currently no way to print fixed sets of columns) [list_begin arguments] [arg_def list obj] Matrix or vector in question [arg_def string format] Format for printing the numbers (default: %6.4f) [arg_def string rowsep] String to use for separating rows (default: newline) [arg_def string colsep] String to use for separating columns (default: space) [list_end] [para] [call [cmd ::math::linearalgebra::dim] [arg obj]] Returns the number of dimensions for the object (either 0 for a scalar, 1 for a vector and 2 for a matrix) [list_begin arguments] [arg_def any obj] Scalar, vector, or matrix [list_end] [para] [call [cmd ::math::linearalgebra::shape] [arg obj]] Returns the number of elements in each dimension for the object (either an empty list for a scalar, a single number for a vector and a list of the number of rows and columns for a matrix) [list_begin arguments] [arg_def any obj] Scalar, vector, or matrix [list_end] [para] [call [cmd ::math::linearalgebra::conforming] [arg type] [arg obj1] [arg obj2]] Checks if two objects (vector or matrix) have conforming shapes, that is if they can be applied in an operation like addition or matrix multiplication. [list_begin arguments] [arg_def string type] Type of check: [list_begin itemized] [item] "shape" - the two objects have the same shape (for all element-wise operations) [item] "rows" - the two objects have the same number of rows (for use as A and b in a system of linear equations [emph "Ax = b"] [item] "matmul" - the first object has the same number of columns as the number of rows of the second object. Useful for matrix-matrix or matrix-vector multiplication. [list_end] [arg_def list obj1] First vector or matrix (left operand) [arg_def list obj2] Second vector or matrix (right operand) [list_end] [para] [call [cmd ::math::linearalgebra::symmetric] [arg matrix] [opt eps]] Checks if the given (square) matrix is symmetric. The argument eps is the tolerance. [list_begin arguments] [arg_def list matrix] Matrix to be inspected [arg_def float eps] Tolerance for determining approximate equality (defaults to 1.0e-8) [list_end] [list_end] [para] [emph "Basic operations"] [list_begin definitions] [call [cmd ::math::linearalgebra::norm] [arg vector] [arg type]] Returns the norm of the given vector. The type argument can be: 1, 2, inf or max, respectively the sum of absolute values, the ordinary Euclidean norm or the max norm. [list_begin arguments] [arg_def list vector] Vector, list of coefficients [arg_def string type] Type of norm (default: 2, the Euclidean norm) [list_end] [call [cmd ::math::linearalgebra::norm_one] [arg vector]] Returns the L1 norm of the given vector, the sum of absolute values [list_begin arguments] [arg_def list vector] Vector, list of coefficients [list_end] [call [cmd ::math::linearalgebra::norm_two] [arg vector]] Returns the L2 norm of the given vector, the ordinary Euclidean norm [list_begin arguments] [arg_def list vector] Vector, list of coefficients [list_end] [call [cmd ::math::linearalgebra::norm_max] [arg vector] [opt index]] Returns the Linf norm of the given vector, the maximum absolute coefficient [list_begin arguments] [arg_def list vector] Vector, list of coefficients [arg_def integer index] (optional) if non zero, returns a list made of the maximum value and the index where that maximum was found. if zero, returns the maximum value. [list_end] [para] [call [cmd ::math::linearalgebra::normMatrix] [arg matrix] [arg type]] Returns the norm of the given matrix. The type argument can be: 1, 2, inf or max, respectively the sum of absolute values, the ordinary Euclidean norm or the max norm. [list_begin arguments] [arg_def list matrix] Matrix, list of row vectors [arg_def string type] Type of norm (default: 2, the Euclidean norm) [list_end] [para] [call [cmd ::math::linearalgebra::dotproduct] [arg vect1] [arg vect2]] Determine the inproduct or dot product of two vectors. These must have the same shape (number of dimensions) [list_begin arguments] [arg_def list vect1] First vector, list of coefficients [arg_def list vect2] Second vector, list of coefficients [list_end] [para] [call [cmd ::math::linearalgebra::unitLengthVector] [arg vector]] Return a vector in the same direction with length 1. [list_begin arguments] [arg_def list vector] Vector to be normalized [list_end] [para] [call [cmd ::math::linearalgebra::normalizeStat] [arg mv]] Normalize the matrix or vector in a statistical sense: the mean of the elements of the columns of the result is zero and the standard deviation is 1. [list_begin arguments] [arg_def list mv] Vector or matrix to be normalized in the above sense [list_end] [para] [call [cmd ::math::linearalgebra::axpy] [arg scale] [arg mv1] [arg mv2]] Return a vector or matrix that results from a "daxpy" operation, that is: compute a*x+y (a a scalar and x and y both vectors or matrices of the same shape) and return the result. [para] Specialised variants are: axpy_vect and axpy_mat (slightly faster, but no check on the arguments) [list_begin arguments] [arg_def double scale] The scale factor for the first vector/matrix (a) [arg_def list mv1] First vector or matrix (x) [arg_def list mv2] Second vector or matrix (y) [list_end] [para] [call [cmd ::math::linearalgebra::add] [arg mv1] [arg mv2]] Return a vector or matrix that is the sum of the two arguments (x+y) [para] Specialised variants are: add_vect and add_mat (slightly faster, but no check on the arguments) [list_begin arguments] [arg_def list mv1] First vector or matrix (x) [arg_def list mv2] Second vector or matrix (y) [list_end] [para] [call [cmd ::math::linearalgebra::sub] [arg mv1] [arg mv2]] Return a vector or matrix that is the difference of the two arguments (x-y) [para] Specialised variants are: sub_vect and sub_mat (slightly faster, but no check on the arguments) [list_begin arguments] [arg_def list mv1] First vector or matrix (x) [arg_def list mv2] Second vector or matrix (y) [list_end] [para] [call [cmd ::math::linearalgebra::scale] [arg scale] [arg mv]] Scale a vector or matrix and return the result, that is: compute a*x. [para] Specialised variants are: scale_vect and scale_mat (slightly faster, but no check on the arguments) [list_begin arguments] [arg_def double scale] The scale factor for the vector/matrix (a) [arg_def list mv] Vector or matrix (x) [list_end] [para] [call [cmd ::math::linearalgebra::rotate] [arg c] [arg s] [arg vect1] [arg vect2]] Apply a planar rotation to two vectors and return the result as a list of two vectors: c*x-s*y and s*x+c*y. In algorithms you can often easily determine the cosine and sine of the angle, so it is more efficient to pass that information directly. [list_begin arguments] [arg_def double c] The cosine of the angle [arg_def double s] The sine of the angle [arg_def list vect1] First vector (x) [arg_def list vect2] Seocnd vector (x) [list_end] [para] [call [cmd ::math::linearalgebra::transpose] [arg matrix]] Transpose a matrix [list_begin arguments] [arg_def list matrix] Matrix to be transposed [list_end] [para] [call [cmd ::math::linearalgebra::matmul] [arg mv1] [arg mv2]] Multiply a vector/matrix with another vector/matrix. The result is a matrix, if both x and y are matrices or both are vectors, in which case the "outer product" is computed. If one is a vector and the other is a matrix, then the result is a vector. [list_begin arguments] [arg_def list mv1] First vector/matrix (x) [arg_def list mv2] Second vector/matrix (y) [list_end] [para] [call [cmd ::math::linearalgebra::angle] [arg vect1] [arg vect2]] Compute the angle between two vectors (in radians) [list_begin arguments] [arg_def list vect1] First vector [arg_def list vect2] Second vector [list_end] [para] [call [cmd ::math::linearalgebra::crossproduct] [arg vect1] [arg vect2]] Compute the cross product of two (three-dimensional) vectors [list_begin arguments] [arg_def list vect1] First vector [arg_def list vect2] Second vector [list_end] [para] [call [cmd ::math::linearalgebra::matmul] [arg mv1] [arg mv2]] Multiply a vector/matrix with another vector/matrix. The result is a matrix, if both x and y are matrices or both are vectors, in which case the "outer product" is computed. If one is a vector and the other is a matrix, then the result is a vector. [list_begin arguments] [arg_def list mv1] First vector/matrix (x) [arg_def list mv2] Second vector/matrix (y) [list_end] [list_end] [para] [emph "Common matrices and test matrices"] [list_begin definitions] [call [cmd ::math::linearalgebra::mkIdentity] [arg size]] Create an identity matrix of dimension [emph size]. [list_begin arguments] [arg_def integer size] Dimension of the matrix [list_end] [para] [call [cmd ::math::linearalgebra::mkDiagonal] [arg diag]] Create a diagonal matrix whose diagonal elements are the elements of the vector [emph diag]. [list_begin arguments] [arg_def list diag] Vector whose elements are used for the diagonal [list_end] [para] [call [cmd ::math::linearalgebra::mkRandom] [arg size]] Create a square matrix whose elements are uniformly distributed random numbers between 0 and 1 of dimension [emph size]. [list_begin arguments] [arg_def integer size] Dimension of the matrix [list_end] [para] [call [cmd ::math::linearalgebra::mkTriangular] [arg size] [opt uplo] [opt value]] Create a triangular matrix with non-zero elements in the upper or lower part, depending on argument [emph uplo]. [list_begin arguments] [arg_def integer size] Dimension of the matrix [arg_def string uplo] Fill the upper (U) or lower part (L) [arg_def double value] Value to fill the matrix with [list_end] [para] [call [cmd ::math::linearalgebra::mkHilbert] [arg size]] Create a Hilbert matrix of dimension [emph size]. Hilbert matrices are very ill-conditioned with respect to eigenvalue/eigenvector problems. Therefore they are good candidates for testing the accuracy of algorithms and implementations. [list_begin arguments] [arg_def integer size] Dimension of the matrix [list_end] [para] [call [cmd ::math::linearalgebra::mkDingdong] [arg size]] Create a "dingdong" matrix of dimension [emph size]. Dingdong matrices are imprecisely represented, but have the property of being very stable in such algorithms as Gauss elimination. [list_begin arguments] [arg_def integer size] Dimension of the matrix [list_end] [para] [call [cmd ::math::linearalgebra::mkOnes] [arg size]] Create a square matrix of dimension [emph size] whose entries are all 1. [list_begin arguments] [arg_def integer size] Dimension of the matrix [list_end] [para] [call [cmd ::math::linearalgebra::mkMoler] [arg size]] Create a Moler matrix of size [emph size]. (Moler matrices have a very simple Choleski decomposition. It has one small eigenvalue and it can easily upset elimination methods for systems of linear equations.) [list_begin arguments] [arg_def integer size] Dimension of the matrix [list_end] [para] [call [cmd ::math::linearalgebra::mkFrank] [arg size]] Create a Frank matrix of size [emph size]. (Frank matrices are fairly well-behaved matrices) [list_begin arguments] [arg_def integer size] Dimension of the matrix [list_end] [para] [call [cmd ::math::linearalgebra::mkBorder] [arg size]] Create a bordered matrix of size [emph size]. (Bordered matrices have a very low rank and can upset certain specialised algorithms.) [list_begin arguments] [arg_def integer size] Dimension of the matrix [list_end] [para] [call [cmd ::math::linearalgebra::mkWilkinsonW+] [arg size]] Create a Wilkinson W+ of size [emph size]. This kind of matrix has pairs of eigenvalues that are very close together. Usually the order (size) is odd. [list_begin arguments] [arg_def integer size] Dimension of the matrix [list_end] [para] [call [cmd ::math::linearalgebra::mkWilkinsonW-] [arg size]] Create a Wilkinson W- of size [emph size]. This kind of matrix has pairs of eigenvalues with opposite signs, when the order (size) is odd. [list_begin arguments] [arg_def integer size] Dimension of the matrix [list_end] [list_end] [para] [emph "Common algorithms"] [list_begin definitions] [call [cmd ::math::linearalgebra::solveGauss] [arg matrix] [arg bvect]] Solve a system of linear equations (Ax=b) using Gauss elimination. Returns the solution (x) as a vector or matrix of the same shape as bvect. [list_begin arguments] [arg_def list matrix] Square matrix (matrix A) [arg_def list bvect] Vector or matrix whose columns are the individual b-vectors [list_end] [call [cmd ::math::linearalgebra::solvePGauss] [arg matrix] [arg bvect]] Solve a system of linear equations (Ax=b) using Gauss elimination with partial pivoting. Returns the solution (x) as a vector or matrix of the same shape as bvect. [list_begin arguments] [arg_def list matrix] Square matrix (matrix A) [arg_def list bvect] Vector or matrix whose columns are the individual b-vectors [list_end] [para] [call [cmd ::math::linearalgebra::solveTriangular] [arg matrix] [arg bvect] [opt uplo]] Solve a system of linear equations (Ax=b) by backward substitution. The matrix is supposed to be upper-triangular. [list_begin arguments] [arg_def list matrix] Lower or upper-triangular matrix (matrix A) [arg_def list bvect] Vector or matrix whose columns are the individual b-vectors [arg_def string uplo] Indicates whether the matrix is lower-triangular (L) or upper-triangular (U). Defaults to "U". [list_end] [call [cmd ::math::linearalgebra::solveGaussBand] [arg matrix] [arg bvect]] Solve a system of linear equations (Ax=b) using Gauss elimination, where the matrix is stored as a band matrix ([emph cf.] [sectref STORAGE]). Returns the solution (x) as a vector or matrix of the same shape as bvect. [list_begin arguments] [arg_def list matrix] Square matrix (matrix A; in band form) [arg_def list bvect] Vector or matrix whose columns are the individual b-vectors [list_end] [para] [call [cmd ::math::linearalgebra::solveTriangularBand] [arg matrix] [arg bvect]] Solve a system of linear equations (Ax=b) by backward substitution. The matrix is supposed to be upper-triangular and stored in band form. [list_begin arguments] [arg_def list matrix] Upper-triangular matrix (matrix A) [arg_def list bvect] Vector or matrix whose columns are the individual b-vectors [list_end] [para] [call [cmd ::math::linearalgebra::determineSVD] [arg A] [arg eps]] Determines the Singular Value Decomposition of a matrix: A = U S Vtrans. Returns a list with the matrix U, the vector of singular values S and the matrix V. [list_begin arguments] [arg_def list A] Matrix to be decomposed [arg_def float eps] Tolerance (defaults to 2.3e-16) [list_end] [para] [call [cmd ::math::linearalgebra::eigenvectorsSVD] [arg A] [arg eps]] Determines the eigenvectors and eigenvalues of a real [emph symmetric] matrix, using SVD. Returns a list with the matrix of normalized eigenvectors and their eigenvalues. [list_begin arguments] [arg_def list A] Matrix whose eigenvalues must be determined [arg_def float eps] Tolerance (defaults to 2.3e-16) [list_end] [para] [call [cmd ::math::linearalgebra::leastSquaresSVD] [arg A] [arg y] [arg qmin] [arg eps]] Determines the solution to a least-sqaures problem Ax ~ y via singular value decomposition. The result is the vector x. [para] Note that if you add a column of 1s to the matrix, then this column will represent a constant like in: y = a*x1 + b*x2 + c. To force the intercept to be zero, simply leave it out. [list_begin arguments] [arg_def list A] Matrix of independent variables [arg_def list y] List of observed values [arg_def float qmin] Minimum singular value to be considered (defaults to 0.0) [arg_def float eps] Tolerance (defaults to 2.3e-16) [list_end] [para] [call [cmd ::math::linearalgebra::choleski] [arg matrix]] Determine the Choleski decomposition of a symmetric positive semidefinite matrix (this condition is not checked!). The result is the lower-triangular matrix L such that L Lt = matrix. [list_begin arguments] [arg_def list matrix] Matrix to be decomposed [list_end] [para] [call [cmd ::math::linearalgebra::orthonormalizeColumns] [arg matrix]] Use the modified Gram-Schmidt method to orthogonalize and normalize the [emph columns] of the given matrix and return the result. [list_begin arguments] [arg_def list matrix] Matrix whose columns must be orthonormalized [list_end] [para] [call [cmd ::math::linearalgebra::orthonormalizeRows] [arg matrix]] Use the modified Gram-Schmidt method to orthogonalize and normalize the [emph rows] of the given matrix and return the result. [list_begin arguments] [arg_def list matrix] Matrix whose rows must be orthonormalized [list_end] [para] [call [cmd ::math::linearalgebra::dger] [arg matrix] [arg alpha] [arg x] [arg y] [opt scope]] Perform the rank 1 operation A + alpha*x*y' inline (that is: the matrix A is adjusted). For convenience the new matrix is also returned as the result. [list_begin arguments] [arg_def list matrix] Matrix whose rows must be adjusted [arg_def double alpha] Scale factor [arg_def list x] A column vector [arg_def list y] A column vector [arg_def list scope] If not provided, the operation is performed on all rows/columns of A if provided, it is expected to be the list {imin imax jmin jmax} where: [list_begin itemized] [item] [term imin] Minimum row index [item] [term imax] Maximum row index [item] [term jmin] Minimum column index [item] [term jmax] Maximum column index [list_end] [list_end] [para] [call [cmd ::math::linearalgebra::dgetrf] [arg matrix]] Computes an LU factorization of a general matrix, using partial, pivoting with row interchanges. Returns the permutation vector. [para] The factorization has the form [example { P * A = L * U }] where P is a permutation matrix, L is lower triangular with unit diagonal elements, and U is upper triangular. Returns the permutation vector, as a list of length n-1. The last entry of the permutation is not stored, since it is implicitely known, with value n (the last row is not swapped with any other row). At index #i of the permutation is stored the index of the row #j which is swapped with row #i at step #i. That means that each index of the permutation gives the permutation at each step, not the cumulated permutation matrix, which is the product of permutations. [list_begin arguments] [arg_def list matrix] On entry, the matrix to be factored. On exit, the factors L and U from the factorization P*A = L*U; the unit diagonal elements of L are not stored. [list_end] [para] [call [cmd ::math::linearalgebra::det] [arg matrix]] Returns the determinant of the given matrix, based on PA=LU decomposition, i.e. Gauss partial pivotal. [list_begin arguments] [arg_def list matrix] Square matrix (matrix A) [arg_def list ipiv] The pivots (optionnal). If the pivots are not provided, a PA=LU decomposition is performed. If the pivots are provided, we assume that it contains the pivots and that the matrix A contains the L and U factors, as provided by dgterf. b-vectors [list_end] [para] [call [cmd ::math::linearalgebra::largesteigen] [arg matrix] [arg tolerance] [arg maxiter]] Returns a list made of the largest eigenvalue (in magnitude) and associated eigenvector. Uses iterative Power Method as provided as algorithm #7.3.3 of Golub & Van Loan. This algorithm is used here for a dense matrix (but is usually used for sparse matrices). [list_begin arguments] [arg_def list matrix] Square matrix (matrix A) [arg_def double tolerance] The relative tolerance of the eigenvalue (default:1.e-8). [arg_def integer maxiter] The maximum number of iterations (default:10). [list_end] [list_end] [para] [emph "Compability with the LA package"] Two procedures are provided for compatibility with Hume's LA package: [list_begin definitions] [call [cmd ::math::linearalgebra::to_LA] [arg mv]] Transforms a vector or matrix into the format used by the original LA package. [list_begin arguments] [arg_def list mv] Matrix or vector [list_end] [call [cmd ::math::linearalgebra::from_LA] [arg mv]] Transforms a vector or matrix from the format used by the original LA package into the format used by the present implementation. [list_begin arguments] [arg_def list mv] Matrix or vector as used by the LA package [list_end] [list_end] [para] [section "STORAGE"] While most procedures assume that the matrices are given in full form, the procedures [emph solveGaussBand] and [emph solveTriangularBand] assume that the matrices are stored as [emph "band matrices"]. This common type of "sparse" matrices is related to ordinary matrices as follows: [list_begin itemized] [item] "A" is a full-size matrix with N rows and M columns. [item] "B" is a band matrix, with m upper and lower diagonals and n rows. [item] "B" can be stored in an ordinary matrix of (2m+1) columns (one for each off-diagonal and the main diagonal) and n rows. [item] Element i,j (i = -m,...,m; j =1,...,n) of "B" corresponds to element k,j of "A" where k = M+i-1 and M is at least (!) n, the number of rows in "B". [item] To set element (i,j) of matrix "B" use: [example { setelem B $j [expr {$N+$i-1}] $value }] [list_end] (There is no convenience procedure for this yet) [section "REMARKS ON THE IMPLEMENTATION"] There is a difference between the original LA package by Hume and the current implementation. Whereas the LA package uses a linear list, the current package uses lists of lists to represent matrices. It turns out that with this representation, the algorithms are faster and easier to implement. [para] The LA package was used as a model and in fact the implementation of, for instance, the SVD algorithm was taken from that package. The set of procedures was expanded using ideas from the well-known BLAS library and some algorithms were updated from the second edition of J.C. Nash's book, Compact Numerical Methods for Computers, (Adam Hilger, 1990) that inspired the LA package. [para] Two procedures are provided to make the transition between the two implementations easier: [emph to_LA] and [emph from_LA]. They are described above. [section TODO] Odds and ends: the following algorithms have not been implemented yet: [list_begin itemized] [item] determineQR [item] certainlyPositive, diagonallyDominant [list_end] [section "NAMING CONFLICT"] If you load this package in a Tk-enabled shell like wish, then the command [example {namespace import ::math::linearalgebra}] results in an error message about "scale". This is due to the fact that Tk defines all its commands in the global namespace. The solution is to import the linear algebra commands in a namespace that is not the global one: [example { package require math::linearalgebra namespace eval compute { namespace import ::math::linearalgebra::* ... use the linear algebra version of scale ... } }] To use Tk's scale command in that same namespace you can rename it: [example { namespace eval compute { rename ::scale scaleTk scaleTk .scale ... } }] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph {math :: linearalgebra}] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [manpage_end] tcllib-1.15/modules/math/combinatorics.test0000644000175000017500000002304112077663116020376 0ustar sergeisergei# Tests for combinatorics functions in math library -*- tcl -*- # # This file contains a collection of tests for one or more of the Tcllib # procedures. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 2001 by Kevin B. Kenny # All rights reserved. # # RCS: @(#) $Id: combinatorics.test,v 1.14 2006/10/09 21:41:41 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.2 testsNeedTcltest 1.0 testing { useLocal math.tcl math } # ------------------------------------------------------------------------- # Fake [lset] for Tcl releases that don't have it. We need only # lset into a flat list. if { [string compare lset [info commands lset]] } { proc K { x y } { set x } proc lset { listVar index var } { upvar 1 $listVar list set list [lreplace [K $list [set list {}]] $index $index $var] } } # ------------------------------------------------------------------------- test combinatorics-1.1 { math::ln_Gamma, wrong num args } { catch { math::ln_Gamma } msg set msg } [tcltest::wrongNumArgs math::ln_Gamma x 0] test combinatorics-1.2 { math::ln_Gamma, main line code } { set maxerror 0. set f 1. for { set i 1 } { $i < 171 } { set i $ip1 } { set f [expr { $f * $i }] set ip1 [expr { $i + 1 }] set f2 [expr { exp( [math::ln_Gamma $ip1] ) }] set error [expr { abs( $f2 - $f ) / $f }] if { $error > $maxerror } { set maxerror $error } } if { $maxerror > 5e-10 } { error "max error of factorials computed using math::ln_Gamma\ specified to be 5e-10, was $maxerror" } concat } {} test combinatorics-1.3 { math::ln_Gamma, half integer args } { set maxerror 0. set z 0.5 set pi 3.1415926535897932 set g [expr { sqrt( $pi ) }] while { $z < 170. } { set g2 [expr { exp( [::math::ln_Gamma $z] ) }] set error [expr { abs( $g2 - $g ) / $g }] if { $error > $maxerror } { set maxerror $error } set g [expr { $g * $z }] set z [expr { $z + 1. }] } if { $maxerror > 5e-10 } { error "max error of half integer gamma computed using math::ln_Gamma\ specified to be 5e-10, was $maxerror" } concat } {} test combinatorics-1.4 { math::ln_Gamma, bogus arg } { catch { math::ln_Gamma bogus } msg set msg } {expected a floating-point number but found "bogus"} test combinatorics-1.5 { math::ln_Gamma, evaluate at pole } { catch { math::ln_Gamma 0.0 } msg list $msg $::errorCode } {{argument to math::ln_Gamma must be positive} {ARITH DOMAIN {argument to math::ln_Gamma must be positive}}} test combinatorics-1.6 { math::ln_Gamma, exponent overflow } { catch { math::ln_Gamma 2.556348163871691e+305 } msg list $msg $::errorCode } {{floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}} test combinatorics-2.1 { math::factorial, wrong num args } { catch { math::factorial } msg set msg } [tcltest::wrongNumArgs math::factorial x 0] test combinatorics-2.2 { math::factorial 0 } { math::factorial 0 } 1 test combinatorics-2.3 { math::factorial, main line } { set maxerror 0. set f 1. for { set i 1 } { $i < 171 } { set i $ip1 } { set f [expr { $f * $i }] set ip1 [expr { $i + 1 }] set f2 [math::factorial $i] set error [expr { abs( $f2 - $f ) / $f }] if { $error > $maxerror } { set maxerror $error } } if { $maxerror > 1e-16 } { error "max error of factorials computed using math::factorial\ specified to be 1e-16, was $maxerror" } concat } {} test combinatorics-2.4 { math::factorial, half integer args } { set maxerror 0. set z -0.5 set pi 3.1415926535897932 set g [expr { sqrt( $pi ) }] while { $z < 169. } { set g2 [math::factorial $z] set error [expr { abs( $g2 - $g ) / $g }] if { $error > $maxerror } { set maxerror $error } set z [expr { $z + 1. }] set g [expr { $g * $z }] } if { $maxerror > 1e-9 } { error "max error of half integer factorial\ specified to be 1e-9, was $maxerror" } concat } {} test combinatorics-2.5 { math::factorial, bogus arg } { catch { math::factorial bogus } msg set msg } {expected a floating-point number but found "bogus"} test combinatorics-2.6 { math::factorial, evaluate at pole } { catch { math::factorial -1.0 } msg list $msg $::errorCode } {{argument to math::factorial must be greater than -1.0} {ARITH DOMAIN {argument to math::factorial must be greater than -1.0}}} test combinatorics-2.7 { math::factorial, exponent overflow } { if {![catch { math::factorial 171 } msg]} { if { [string equal $msg Infinity] || [string equal $msg Inf] } { set result ok } else { set result "result of factorial was [list $msg],\ should be Infinity" } } else { if { [string equal [lrange $::errorCode 0 1] {ARITH OVERFLOW}] } { set result ok } else { set result "error from factorial was [list $::errorCode],\ should be {ARITH IOVERFLOW *}" } } set result } ok test combinatorics-2.8 { math::factorial, "" arg } { catch { math::factorial "" } msg list $msg } {{expected a floating-point number but found ""}} test combinatorics-3.1 { math::choose, wrong num args } { catch { math::choose } msg set msg } [tcltest::wrongNumArgs math::choose {n k} 0] test combinatorics-3.2 { math::choose, wrong num args } { catch { math::choose 1 } msg set msg } [tcltest::wrongNumArgs math::choose {n k} 1] test combinatorics-3.3 { math::choose, precomputed table and gamma evals } { set maxError 0 set l {} for { set n 0 } { $n < 100 } { incr n } { lappend l 1. for { set k [expr { $n - 1 }] } { $k > 0 } { set k $km1 } { set km1 [expr { $k - 1 }] set cnk [expr { [lindex $l $k] + [lindex $l $km1] }] lset l $k $cnk set ccnk [math::choose $n $k] set error [expr { abs( $ccnk - $cnk ) / $cnk }] if { $error > $maxError } { set maxError $error } } } if { $maxError > 5e-10 } { error "max error in math::choose was $maxError, specified to be 5e-10" } concat } {} test combinatorics-3.4 { math::choose, bogus n } { catch { math::choose bogus 0 } msg set msg } {expected a floating-point number but found "bogus"} test combinatorics-3.5 { math::choose bogus k } { catch { math::choose 0 bogus } msg set msg } {expected a floating-point number but found "bogus"} test combinatorics-3.6 { match::choose negative n } { catch { math::choose -1 0 } msg list $msg $::errorCode } {{first argument to math::choose must be non-negative} {ARITH DOMAIN {first argument to math::choose must be non-negative}}} test combinatorics-3.7 { math::choose negative k } { math::choose 17 -1 } 0 test combinatorics-3.8 { math::choose excess k } { math::choose 17 18 } 0 test combinatorics-3.9 {math::choose negative fraction } { catch { math::choose 17 -0.5 } msg list $msg $::errorCode } {{second argument to math::choose must be non-negative, or both must be integers} {ARITH DOMAIN {second argument to math::choose must be non-negative, or both must be integers}}} test combinatorics-3.10 { math::choose big args } { if {![catch { math::choose 1500 750 } msg]} { if { [string equal $msg Infinity] || [string equal $msg Inf] } { set result ok } else { set result "result of choose was [list $msg],\ should be Infinity" } } else { if { [string equal [lrange $::errorCode 0 1] {ARITH OVERFLOW}] } { set result ok } else { set result "error from choose was [list $::errorCode],\ should be {ARITH IOVERFLOW *}" } } set result } ok test combinatorics-4.1 { math::Beta, wrong num args } { catch { math::Beta } msg set msg } [tcltest::wrongNumArgs math::Beta {z w} 0] test combinatorics-4.2 { math::Beta, wrong num args } { catch { math::Beta 1 } msg set msg } [tcltest::wrongNumArgs math::Beta {z w} 1] test combinatorics-4.3 { math::Beta, bogus z } { catch { math::Beta bogus 1 } msg set msg } {expected a floating-point number but found "bogus"} test combinatorics-4.4 { math::Beta, bogus w } { catch { math::Beta 1 bogus } msg set msg } {expected a floating-point number but found "bogus"} test combinatorics-4.5 { math::Beta, negative z } { catch { math::Beta 0 1 } msg list $msg $::errorCode } {{first argument to math::Beta must be positive} {ARITH DOMAIN {first argument to math::Beta must be positive}}} test combinatorics-4.6 { math::Beta, negative w } { catch { math::Beta 1 0 } msg list $msg $::errorCode } {{second argument to math::Beta must be positive} {ARITH DOMAIN {second argument to math::Beta must be positive}}} test combinatorics-4.7 { math::Beta, test with Pascal } { set maxError 0 set l {} for { set n 0 } { $n < 100 } { incr n } { lappend l 1. for { set k [expr { $n - 1 }] } { $k > 0 } { set k $km1 } { set km1 [expr { $k - 1 }] set cnk [expr { [lindex $l $k] + [lindex $l $km1] }] lset l $k $cnk set w [expr { $k + 1 }] set z [expr { $n - $k + 1 }] set beta [expr { 1.0 / $cnk / ( $z + $w - 1 )}] set cbeta [math::Beta $z $w] set error [expr { abs( $cbeta - $beta ) / $beta }] if { $error > $maxError } { set maxError $error } } } if { $maxError > 5e-10 } { error "max error in math::Beta was $maxError, specified to be 5e-10" } concat } {} testsuiteCleanup tcllib-1.15/modules/math/calculus.doc0000755000175000017500000002635112077663116017155 0ustar sergeisergei[pageheader "Package: Calculus"] [synopsis \ {package require Tcl 8.2 package require math::calculus 0.5 ::math::calculus::integral begin end nosteps func ::math::calculus::integralExpr begin end nosteps expression ::math::calculus::integral2D xinterval yinterval func ::math::calculus::integral3D xinterval yinterval zinterval func ::math::calculus::eulerStep t tstep xvec func ::math::calculus::heunStep t tstep xvec func ::math::calculus::rungeKuttaStep tstep xvec func ::math::calculus::boundaryValueSecondOrder coeff_func force_func leftbnd rightbnd nostep}] ::math::calculus::newtonRaphson func deriv initval ::math::calculus::newtonRaphsonParameters maxiter tolerance [section "Introduction"] The package Calculus implements several simple mathematical algorithms, such as the integration of a function over an interval and the numerical integration of a system of ordinary differential equations. [par] It is fully implemented in Tcl. No particular attention has been paid to the accuracy of the calculations. Instead, well-known algorithms have been used in a straightforward manner. [par] This document describes the procedures and explains their usage. [section "Version and copyright"] This document describes [italic ::math::calculus], version 0.5, may 2002. [par] Usage of Calculus is free, as long as you acknowledge the author, Arjen Markus (e-mail: arjen.markus@wldelft.nl). [par] There is no guarantee nor claim that the results are accurate. [section "Procedures"] The Calculus package defines the following public procedures: [ulist] [item][italic "integral begin end nosteps func"] [break] Determine the integral of the given function using the Simpson rule. The interval for the integration is [lb]begin,end[rb]. [break] Other arguments: [break] [italic nosteps] - Number of steps in which the interval is divided. [break] [italic func] - Function to be integrated. It should take one single argument. [par] [item][italic "integralExpr begin end nosteps expression"] [break] Similar to the previous proc, this one determines the integral of the given [italic expression] using the Simpson rule. The interval for the integration is [lb]begin,end[rb]. [break] Other arguments: [break] [italic nosteps] - Number of steps in which the interval is divided. [break] [italic expression] - Expression to be integrated. It should use the variable "x" as the only variable (the "integrate") [par] [item][italic "integral2D xinterval yinterval func"] [break] The [italic integral2D] procedure calculates the integral of a function of two variables over the rectangle given by the first two arguments, each a list of three items, the start and stop interval for the variable and the number of steps. [break] The currently implemented integration is simple: the function is evaluated at the centre of each rectangle and the content of this block is added to the integral. In future this will be replaced by a bilinear interpolation. [break] The function must take two arguments and return the function value. [par] [item][italic "integral3D xinterval yinterval zinterval func"] [break] The [italic integral3D] procedure is the three-dimensional equivalent of [italic intergral2D]. The function taking three arguments is integrated over the block in 3D space given by the intervals. [par] [item][italic "eulerStep t tstep xvec func"] [break] Set a single step in the numerical integration of a system of differential equations. The method used is Euler's. [break] [italic t] - Value of the independent variable (typically time) at the beginning of the step. [break] [italic tstep] - Step size for the independent variable. [break] [italic xvec] - List (vector) of dependent values [break] [italic func] - Function of t and the dependent values, returning a list of the derivatives of the dependent values. (The lengths of xvec and the return value of "func" must match). [par] [item][italic "heunStep t tstep xvec func"] [break] Set a single step in the numerical integration of a system of differential equations. The method used is Heun's. [break] [italic t] - Value of the independent variable (typically time) at the beginning of the step. [break] [italic tstep] - Step size for the independent variable. [break] [italic xvec] - List (vector) of dependent values [break] [italic func] - Function of t and the dependent values, returning a list of the derivatives of the dependent values. (The lengths of xvec and the return value of "func" must match). [par] [item][italic "rungeKuttaStep tstep xvec func"] [break] Set a single step in the numerical integration of a system of differential equations. The method used is Runge-Kutta 4th order. [break] [italic t] - Value of the independent variable (typically time) at the beginning of the step. [break] [italic tstep] - Step size for the independent variable. [break] [italic xvec] - List (vector) of dependent values [break] [italic func] - Function of t and the dependent values, returning a list of the derivatives of the dependent values. (The lengths of xvec and the return value of "func" must match). [par] [item][italic "boundaryValueSecondOrder coeff_func force_func leftbnd rightbnd nostep"] [break] Solve a second order linear differential equation with boundary values at two sides. The equation has to be of the form: [preserve] d dy d -- A(x)-- + -- B(x)y + C(x)y = D(x) dx dx dx [endpreserve] Ordinarily, such an equation would be written as: [preserve] d2y dy a(x)--- + b(x)-- + c(x) y = D(x) dx2 dx [endpreserve] The first form is easier to discretise (by integrating over a finite volume) than the second form. The relation between the two forms is fairly straightforward: [preserve] A(x) = a(x) B(x) = b(x) - a'(x) C(x) = c(x) - B'(x) = c(x) - b'(x) + a''(x) [endpreserve] Because of the differentiation, however, it is much easier to ask the user to provide the functions A, B and C directly. [break] [italic coeff_func] - Procedure returning the three coefficients (A, B, C) of the equation, taking as its one argument the x-coordinate. [italic force_func] - Procedure returning the right-hand side (D) as a function of the x-coordinate. [italic leftbnd] - A list of two values: the x-coordinate of the left boundary and the value at that boundary. [italic rightbnd] - A list of two values: the x-coordinate of the right boundary and the value at that boundary. [italic nostep] - Number of steps by which to discretise the interval. The procedure returns a list of x-coordinates and the approximated values of the solution. [par] [item][italic "solveTriDiagonal acoeff bcoeff ccoeff dvalue"] [break] Solve a system of linear equations Ax = b with A a tridiagonal matrix. Returns the solution as a list. [break] [italic acoeff] - List of values on the lower diagonal [italic bcoeff] - List of values on the main diagonal [italic ccoeff] - List of values on the upper diagonal [italic dvalue] - List of values on the righthand-side [par] [item][italic "newtonRaphson func deriv initval"] [break] Determine the root of an equation given by [italic "f(x) = 0"], using the Newton-Raphson method. [break] [italic func] - Name of the procedure that calculates the function value [italic deriv - Name of the procedure that calculates the derivative of the function [italic initval] - Initial value for the iteration [par] [item][italic "newtonRaphsonParameters maxiter tolerance"] [break] Set new values for the two parameters that gouvern the Newton-Raphson method. [break] [italic maxiter] - Maximum number of iterations [italic tolerance] - Relative error in the calculation [par] [endlist] [italic Notes:] [break] Several of the above procedures take the [italic names] of procedures as arguments. To avoid problems with the [italic visibility] of these procedures, the fully-qualified name of these procedures is determined inside the calculus routines. For the user this has only one consequence: the named procedure must be visible in the calling procedure. For instance: [preserve] namespace eval ::mySpace { namespace export calcfunc proc calcfunc { x } { return $x } } # # Use a fully-qualified name # namespace eval ::myCalc { proc detIntegral { begin end } { return [lb]integral $begin $end 100 ::mySpace::calcfunc[rb] } } # # Import the name # namespace eval ::myCalc { namespace import ::mySpace::calcfunc proc detIntegral { begin end } { return [lb]integral $begin $end 100 calcfunc[rb] } } [endpreserve] [par] Enhancements for the second-order boundary value problem: [ulist] [item]Other types of boundary conditions (zero gradient, zero flux) [item]Other schematisation of the first-order term (now central differences are used, but upstream differences might be useful too). [endlist] [section Examples] Let us take a few simple examples: [par] Integrate x over the interval [lb]0,100[rb] (20 steps): [preserve] proc linear_func { x } { return $x } puts "Integral: [lb]::math::calculus::Integral 0 100 20 linear_func[rb]" [endpreserve] For simple functions, the alternative could be: [preserve] puts "Integral: [lb]::math::calculus::IntegralExpr 0 100 20 {$x}[rb]" [endpreserve] Do not forget the braces! [par] The differential equation for a dampened oscillator: [preserve] x'' + rx' + wx = 0 [endpreserve] can be split into a system of first-order equations: [preserve] x' = y y' = -ry - wx [endpreserve] Then this system can be solved with code like this: [preserve] proc dampened_oscillator { t xvec } { set x [lb]lindex \$xvec 0[rb] set x1 [lb]lindex \$xvec 1[rb] return [lb]list \$x1 [lb]expr {-\$x1-\$x}[rb][rb] } set xvec { 1.0 0.0 } set t 0.0 set tstep 0.1 for { set i 0 } { \$i < 20 } { incr i } { set result [lb]::math::calculus::eulerStep \$t \$tstep \$xvec dampened_oscillator[rb] puts "Result (\$t): \$result" set t [lb]expr {\$t+\$tstep}[rb] set xvec \$result } [endpreserve] Suppose we have the boundary value problem: [preserve] Dy'' + ky = 0 x = 0: y = 1 x = L: y = 0 [endpreserve] This boundary value problem could originate from the diffusion of a decaying substance. [par] It can be solved with the following fragment: [preserve] proc coeffs { x } { return [lb]list \$::Diff 0.0 \$::decay[rb] } proc force { x } { return 0.0 } set Diff 1.0e-2 set decay 0.0001 set length 100.0 set y [lb]::math::calculus::boundaryValueSecondOrder coeffs force {0.0 1.0} \ [lb]list \$length 0.0[rb] 100[rb] [endpreserve] tcllib-1.15/modules/math/numtheory.stitch0000644000175000017500000000070112077663116020111 0ustar sergeisergei# -*- tcl -*- # Stitch definition for docstrip files, used by SAK. input numtheory.dtx options -metaprefix \# -preamble {In other words: ************************************** * This Source is not the True Source * ************************************** the true source is the file from which this one was generated. } stitch numtheory.tcl pkg stitch numtheory.test test options -nopreamble -nopostamble stitch numtheory.man man tcllib-1.15/modules/math/pdf_stat.tcl0000755000175000017500000011346712077663116017170 0ustar sergeisergei# pdf_stat.tcl -- # # Collection of procedures for evaluating probability and # cumulative density functions # Part of "math::statistics" # # january 2008: added procedures by Eric Kemp Benedict for # Gamma, Poisson and t-distributed variables. # Replacing some older versions. # # ::math::statistics -- # Namespace holding the procedures and variables # namespace eval ::math::statistics { namespace export pdf-normal pdf-uniform \ pdf-exponential \ cdf-normal cdf-uniform \ cdf-exponential \ cdf-students-t \ random-normal random-uniform \ random-exponential \ histogram-uniform \ pdf-gamma pdf-poisson pdf-chisquare pdf-students-t pdf-beta \ cdf-gamma cdf-poisson cdf-chisquare cdf-beta \ random-gamma random-poisson random-chisquare random-students-t random-beta \ incompleteGamma incompleteBeta variable cdf_normal_prob {} variable cdf_normal_x {} variable cdf_toms322_cached {} variable initialised_cdf 0 variable twopi [expr {2.0*acos(-1.0)}] variable pi [expr {acos(-1.0)}] } # pdf-normal -- # Return the probabilities belonging to a normal distribution # # Arguments: # mean Mean of the distribution # stdev Standard deviation # x Value for which the probability must be determined # # Result: # Probability of value x under the given distribution # proc ::math::statistics::pdf-normal { mean stdev x } { variable NEGSTDEV variable factorNormalPdf if { $stdev <= 0.0 } { return -code error -errorcode ARG -errorinfo $NEGSTDEV $NEGSTDEV } set xn [expr {($x-$mean)/$stdev}] set prob [expr {exp(-$xn*$xn/2.0)/$stdev/$factorNormalPdf}] return $prob } # pdf-uniform -- # Return the probabilities belonging to a uniform distribution # (parameters as minimum/maximum) # # Arguments: # pmin Minimum of the distribution # pmax Maximum of the distribution # x Value for which the probability must be determined # # Result: # Probability of value x under the given distribution # proc ::math::statistics::pdf-uniform { pmin pmax x } { if { $pmin >= $pmax } { return -code error -errorcode ARG \ -errorinfo "Wrong order or zero range" \ "Wrong order or zero range" } set prob [expr {1.0/($pmax-$min)}] if { $x < $pmin || $x > $pmax } { return 0.0 } return $prob } # pdf-exponential -- # Return the probabilities belonging to an exponential # distribution # # Arguments: # mean Mean of the distribution # x Value for which the probability must be determined # # Result: # Probability of value x under the given distribution # proc ::math::statistics::pdf-exponential { mean x } { variable NEGSTDEV variable OUTOFRANGE if { $stdev <= 0.0 } { return -code error -errorcode ARG -errorinfo $NEGSTDEV $NEGSTDEV } if { $mean <= 0.0 } { return -code error -errorcode ARG -errorinfo $OUTOFRANGE \ "$OUTOFRANGE: mean must be positive" } if { $x < 0.0 } { return 0.0 } if { $x > 700.0*$mean } { return 0.0 } set prob [expr {exp(-$x/$mean)/$mean}] return $prob } # cdf-normal -- # Return the cumulative probability belonging to a normal distribution # # Arguments: # mean Mean of the distribution # stdev Standard deviation # x Value for which the probability must be determined # # Result: # Cumulative probability of value x under the given distribution # proc ::math::statistics::cdf-normal { mean stdev x } { variable NEGSTDEV if { $stdev <= 0.0 } { return -code error -errorcode ARG -errorinfo $NEGSTDEV $NEGSTDEV } set xn [expr {($x-$mean)/$stdev}] set prob1 [Cdf-toms322 1 5000 [expr {$xn*$xn}]] if { $xn > 0.0 } { set prob [expr {0.5+0.5*$prob1}] } else { set prob [expr {0.5-0.5*$prob1}] } return $prob } # cdf-students-t -- # Return the cumulative probability belonging to the # Student's t distribution # # Arguments: # degrees Number of degrees of freedom # x Value for which the probability must be determined # # Result: # Cumulative probability of value x under the given distribution # proc ::math::statistics::cdf-students-t { degrees x } { if { $degrees <= 0 } { return -code error -errorcode ARG -errorinfo \ "Number of degrees of freedom must be positive" \ "Number of degrees of freedom must be positive" } set prob1 [Cdf-toms322 1 $degrees [expr {$x*$x}]] set prob [expr {0.5+0.5*$prob1}] return $prob } # cdf-uniform -- # Return the cumulative probabilities belonging to a uniform # distribution (parameters as minimum/maximum) # # Arguments: # pmin Minimum of the distribution # pmax Maximum of the distribution # x Value for which the probability must be determined # # Result: # Cumulative probability of value x under the given distribution # proc ::math::statistics::cdf-uniform { pmin pmax x } { if { $pmin >= $pmax } { return -code error -errorcode ARG \ -errorinfo "Wrong order or zero range" \ } set prob [expr {($x-$pmin)/($pmax-$min)}] if { $x < $pmin } { return 0.0 } if { $x > $pmax } { return 1.0 } return $prob } # cdf-exponential -- # Return the cumulative probabilities belonging to an exponential # distribution # # Arguments: # mean Mean of the distribution # x Value for which the probability must be determined # # Result: # Cumulative probability of value x under the given distribution # proc ::math::statistics::cdf-exponential { mean x } { variable NEGSTDEV variable OUTOFRANGE if { $mean <= 0.0 } { return -code error -errorcode ARG -errorinfo $OUTOFRANGE \ "$OUTOFRANGE: mean must be positive" } if { $x < 0.0 } { return 0.0 } if { $x > 30.0*$mean } { return 1.0 } set prob [expr {1.0-exp(-$x/$mean)}] return $prob } # Inverse-cdf-uniform -- # Return the argument belonging to the cumulative probability # for a uniform distribution (parameters as minimum/maximum) # # Arguments: # pmin Minimum of the distribution # pmax Maximum of the distribution # prob Cumulative probability for which the "x" value must be # determined # # Result: # X value that gives the cumulative probability under the # given distribution # proc ::math::statistics::Inverse-cdf-uniform { pmin pmax prob } { if {0} { if { $pmin >= $pmax } { return -code error -errorcode ARG \ -errorinfo "Wrong order or zero range" \ "Wrong order or zero range" } } set x [expr {$pmin+$prob*($pmax-$pmin)}] if { $x < $pmin } { return $pmin } if { $x > $pmax } { return $pmax } return $x } # Inverse-cdf-exponential -- # Return the argument belonging to the cumulative probability # for an exponential distribution # # Arguments: # mean Mean of the distribution # prob Cumulative probability for which the "x" value must be # determined # # Result: # X value that gives the cumulative probability under the # given distribution # proc ::math::statistics::Inverse-cdf-exponential { mean prob } { if {0} { if { $mean <= 0.0 } { return -code error -errorcode ARG \ -errorinfo "Mean must be positive" \ "Mean must be positive" } } set x [expr {-$mean*log(1.0-$prob)}] return $x } # Inverse-cdf-normal -- # Return the argument belonging to the cumulative probability # for a normal distribution # # Arguments: # mean Mean of the distribution # stdev Standard deviation of the distribution # prob Cumulative probability for which the "x" value must be # determined # # Result: # X value that gives the cumulative probability under the # given distribution # proc ::math::statistics::Inverse-cdf-normal { mean stdev prob } { variable cdf_normal_prob variable cdf_normal_x variable initialised_cdf if { $initialised_cdf == 0 } { Initialise-cdf-normal } # Look for the proper probability level first, # then interpolate # # Note: the numerical data are connected to the length of # the lists - see Initialise-cdf-normal # set size 32 set idx 64 for { set i 0 } { $i <= 7 } { incr i } { set upper [lindex $cdf_normal_prob $idx] if { $prob > $upper } { set idx [expr {$idx+$size}] } else { set idx [expr {$idx-$size}] } set size [expr {$size/2}] } # # We have found a value that is close to the one we need, # now find the enclosing interval # if { $upper < $prob } { incr idx } set p1 [lindex $cdf_normal_prob [expr {$idx-1}]] set p2 [lindex $cdf_normal_prob $idx] set x1 [lindex $cdf_normal_x [expr {$idx-1}]] set x2 [lindex $cdf_normal_x $idx ] set x [expr {$x1+($x2-$x1)*($prob-$p1)/($p2-$p1)}] return [expr {$mean+$stdev*$x}] } # Initialise-cdf-normal -- # Initialise the private data for the normal cdf # # Arguments: # None # Result: # None # Side effect: # Variable cdf_normal_prob and cdf_normal_x are filled # so that we can use these as a look-up table # proc ::math::statistics::Initialise-cdf-normal { } { variable cdf_normal_prob variable cdf_normal_x variable initialised_cdf set initialised_cdf 1 set dx [expr {10.0/128.0}] set cdf_normal_prob 0.5 set cdf_normal_x 0.0 for { set i 1 } { $i <= 64 } { incr i } { set x [expr {$i*$dx}] if { $x != 0.0 } { set prob [Cdf-toms322 1 5000 [expr {$x*$x}]] } else { set prob 0.0 } set cdf_normal_x [concat [expr {-$x}] $cdf_normal_x $x] set cdf_normal_prob \ [concat [expr {0.5-0.5*$prob}] $cdf_normal_prob \ [expr {0.5+0.5*$prob}]] } } # random-uniform -- # Return a list of random numbers satisfying a uniform # distribution (parameters as minimum/maximum) # # Arguments: # pmin Minimum of the distribution # pmax Maximum of the distribution # number Number of values to generate # # Result: # List of random numbers # proc ::math::statistics::random-uniform { pmin pmax number } { if { $pmin >= $pmax } { return -code error -errorcode ARG \ -errorinfo "Wrong order or zero range" \ "Wrong order or zero range" } set result {} for { set i 0 } {$i < $number } { incr i } { lappend result [Inverse-cdf-uniform $pmin $pmax [expr {rand()}]] } return $result } # random-exponential -- # Return a list of random numbers satisfying an exponential # distribution # # Arguments: # mean Mean of the distribution # number Number of values to generate # # Result: # List of random numbers # proc ::math::statistics::random-exponential { mean number } { if { $mean <= 0.0 } { return -code error -errorcode ARG \ -errorinfo "Mean must be positive" \ "Mean must be positive" } set result {} for { set i 0 } {$i < $number } { incr i } { lappend result [Inverse-cdf-exponential $mean [expr {rand()}]] } return $result } # random-normal -- # Return a list of random numbers satisfying a normal # distribution # # Arguments: # mean Mean of the distribution # stdev Standard deviation of the distribution # number Number of values to generate # # Result: # List of random numbers # # Note: # This version uses the Box-Muller transformation, # a quick and robust method for generating normally- # distributed numbers. # proc ::math::statistics::random-normal { mean stdev number } { variable twopi if { $stdev <= 0.0 } { return -code error -errorcode ARG \ -errorinfo "Standard deviation must be positive" \ "Standard deviation must be positive" } # set result {} # for { set i 0 } {$i < $number } { incr i } { # lappend result [Inverse-cdf-normal $mean $stdev [expr {rand()}]] # } set result {} for { set i 0 } {$i < $number } { incr i 2 } { set angle [expr {$twopi * rand()}] set rad [expr {sqrt(-2.0*log(rand()))}] set xrand [expr {$rad * cos($angle)}] set yrand [expr {$rad * sin($angle)}] lappend result [expr {$mean + $stdev * $xrand}] if { $i < $number-1 } { lappend result [expr {$mean + $stdev * $yrand}] } } return $result } # Cdf-toms322 -- # Calculate the cumulative density function for several distributions # according to TOMS322 # # Arguments: # m First number of degrees of freedom # n Second number of degrees of freedom # x Value for which the cdf must be calculated # # Result: # Cumulatve density at x - details depend on distribution # # Notes: # F-ratios: # m - degrees of freedom for numerator # n - degrees of freedom for denominator # x - F-ratio # Student's t (two-tailed): # m - 1 # n - degrees of freedom # x - square of t # Normal deviate (two-tailed): # m - 1 # n - 5000 # x - square of deviate # Chi-square: # m - degrees of freedom # n - 5000 # x - chi-square/m # The original code can be found at # proc ::math::statistics::Cdf-toms322 { m n x } { if { $x == 0.0 } { return 0.0 } set m [expr {$m < 300? int($m) : 300}] set n [expr {$n < 5000? int($n) : 5000}] if { $m < 1 || $n < 1 } { return -code error -errorcode ARG \ -errorinfo "Arguments m anf n must be greater/equal 1" } set a [expr {2*($m/2)-$m+2}] set b [expr {2*($n/2)-$n+2}] set w [expr {$x*double($m)/double($n)}] set z [expr {1.0/(1.0+$w)}] if { $a == 1 } { if { $b == 1 } { set p [expr {sqrt($w)}] set y 0.3183098862 set d [expr {$y*$z/$p}] set p [expr {2.0*$y*atan($p)}] } else { set p [expr {sqrt($w*$z)}] set d [expr {$p*$z/(2.0*$w)}] } } else { if { $b == 1 } { set p [expr {sqrt($z)}] set d [expr {$z*$p/2.0}] set p [expr {1.0-$p}] } else { set d [expr {$z*$z}] set p [expr {$z*$w}] } } set y [expr {2.0*$w/$z}] if { $a == 1 } { for { set j [expr {$b+2}] } { $j <= $n } { incr j 2 } { set d [expr {(1.0+double($a)/double($j-2)) * $d*$z}] set p [expr {$p+$d*$y/double($j-1)}] } } else { set power [expr {($n-1)/2}] set zk [expr {pow($z,$power)}] set d [expr {($d*$zk*$n)/$b}] set p [expr {$p*$zk + $w*$z * ($zk-1.0)/($z-1.0)}] } set y [expr {$w*$z}] set z [expr {2.0/$z}] set b [expr {$n-2}] for { set i [expr {$a+2}] } { $i <= $m } { incr i 2 } { set j [expr {$i+$b}] set d [expr {$y*$d*double($j)/double($i-2)}] set p [expr {$p-$z*$d/double($j)}] } set prob $p if { $prob < 0.0 } { set prob 0.0 } if { $prob > 1.0 } { set prob 1.0 } return $prob } # Inverse-cdf-toms322 -- # Return the argument belonging to the cumulative probability # for an F, chi-square or t distribution # # Arguments: # m First number of degrees of freedom # n Second number of degrees of freedom # prob Cumulative probability for which the "x" value must be # determined # # Result: # X value that gives the cumulative probability under the # given distribution # # Note: # See the procedure Cdf-toms322 for more details # proc ::math::statistics::Inverse-cdf-toms322 { m n prob } { variable cdf_toms322_cached variable OUTOFRANGE if { $prob <= 0 || $prob >= 1 } { return -code error -errorcode $OUTOFRANGE $OUTOFRANGE } # Is the combination in cache? Then we can simply rely # on that # foreach {m1 n1 prob1 x1} $cdf_toms322_cached { if { $m1 == $m && $n1 == $n && $prob1 == $prob } { return $x1 } } # # Otherwise first find a value of x for which Cdf(x) exceeds prob # set x1 1.0 set dx1 1.0 while { [Cdf-toms322 $m $n $x1] < $prob } { set x1 [expr {$x1+$dx1}] set dx1 [expr {2.0*$dx1}] } # # Now, look closer # while { $dx1 > 0.0001 } { set p1 [Cdf-toms322 $m $n $x1] if { $p1 > $prob } { set x1 [expr {$x1-$dx1}] } else { set x1 [expr {$x1+$dx1}] } set dx1 [expr {$dx1/2.0}] } # # Cache the result # set last end if { [llength $cdf_toms322_cached] > 27 } { set last 26 } set cdf_toms322_cached \ [concat [list $m $n $prob $x1] [lrange $cdf_toms322_cached 0 $last]] return $x1 } # HistogramMake -- # Distribute the "observations" according to the cdf # # Arguments: # cdf-values Values for the cdf (relative number of observations) # number Total number of "observations" in the histogram # # Result: # List of numbers, distributed over the buckets # proc ::math::statistics::HistogramMake { cdf-values number } { set assigned 0 set result {} set residue 0.0 foreach cdfv $cdf-values { set sum [expr {$number*($cdfv + $residue)}] set bucket [expr {int($sum)}] set residue [expr {$sum-$bucket}] set assigned [expr {$assigned-$bucket}] lappend result $bucket } set remaining [expr {$number-$assigned}] if { $remaining > 0 } { lappend result $remaining } else { lappend result 0 } return $result } # histogram-uniform -- # Return the expected histogram for a uniform distribution # # Arguments: # min Minimum the distribution # max Maximum the distribution # limits upper limits for the histogram buckets # number Total number of "observations" in the histogram # # Result: # List of expected number of observations # proc ::math::statistics::histogram-uniform { min max limits number } { if { $min >= $max } { return -code error -errorcode ARG \ -errorinfo "Wrong order or zero range" \ "Wrong order or zero range" } set cdf_result {} foreach limit $limits { lappend cdf_result [cdf-uniform $min $max $limit] } return [HistogramMake $cdf_result $number] } # incompleteGamma -- # Evaluate the incomplete Gamma function Gamma(p,x) # # Arguments: # x X-value # p Parameter # # Result: # Value of Gamma(p,x) # # Note: # Implementation by Eric K. Benedict (2007) # Adapted from Fortran code in the Royal Statistical Society's StatLib # library (http://lib.stat.cmu.edu/apstat/), algorithm AS 32 (with # some modifications from AS 239) # # Calculate normalized incomplete gamma function # # 1 / x p-1 # P(p,x) = -------- | dt exp(-t) * t # Gamma(p) / 0 # # Tested some values against R's pgamma function # proc ::math::statistics::incompleteGamma {x p {tol 1.0e-9}} { set overflow 1.0e37 if {$x < 0} { return -code error -errorcode ARG -errorinfo "x must be positive" } if {$p <= 0} { return -code error -errorcode ARG -errorinfo "p must be greater than or equal to zero" } # If x is zero, incGamma is zero if {$x == 0.0} { return 0.0 } # Use normal approx is p > 1000 if {$p > 1000} { set pn1 [expr {3.0 * sqrt($p) * (pow(1.0 * $x/$p, 1.0/3.0) + 1.0/(9.0 * $p) - 1.0)}] # pnorm is not robust enough for this calculation (overflows); cdf-normal could also be used return [::math::statistics::pnorm_quicker $pn1] } # If x is extremely large compared to a (and now know p < 1000), then return 1.0 if {$x > 1.e8} { return 1.0 } set factor [expr {exp($p * log($x) -$x - [::math::ln_Gamma $p])}] # Use series expansion (first option) or continued fraction if {$x <= 1.0 || $x < $p} { set gin 1.0 set term 1.0 set rn $p while {1} { set rn [expr {$rn + 1.0}] set term [expr {1.0 * $term * $x/$rn}] set gin [expr {$gin + $term}] if {$term < $tol} { set gin [expr {1.0 * $gin * $factor/$p}] break } } } else { set a [expr {1.0 - $p}] set b [expr {$a + $x + 1.0}] set term 0.0 set pn1 1.0 set pn2 $x set pn3 [expr {$x + 1.0}] set pn4 [expr {$x * $b}] set gin [expr {1.0 * $pn3/$pn4}] while {1} { set a [expr {$a + 1.0}] set b [expr {$b + 2.0}] set term [expr {$term + 1.0}] set an [expr {$a * $term}] set pn5 [expr {$b * $pn3 - $an * $pn1}] set pn6 [expr {$b * $pn4 - $an * $pn2}] if {$pn6 != 0.0} { set rn [expr {1.0 * $pn5/$pn6}] set dif [expr {abs($gin - $rn)}] if {$dif <= $tol && $dif <= $tol * $rn} { break } set gin $rn } set pn1 $pn3 set pn2 $pn4 set pn3 $pn5 set pn4 $pn6 # Too big? Rescale if {abs($pn5) >= $overflow} { set pn1 [expr {$pn1 / $overflow}] set pn2 [expr {$pn2 / $overflow}] set pn3 [expr {$pn3 / $overflow}] set pn4 [expr {$pn4 / $overflow}] } } set gin [expr {1.0 - $factor * $gin}] } return $gin } # pdf-gamma -- # Return the probabilities belonging to a gamma distribution # # Arguments: # alpha Shape parameter # beta Rate parameter # x Value of variate # # Result: # Probability density of the given value of x to occur # # Note: # Implemented by Eric Kemp-Benedict, 2007 # # This uses the following parameterization for the gamma: # GammaDist(x) = beta * (beta * x)^(alpha-1) e^(-beta * x) / GammaFunc(alpha) # Here, alpha is the shape parameter, and beta is the rate parameter # Alternatively, a "scale parameter" theta = 1/beta is sometimes used # proc ::math::statistics::pdf-gamma { alpha beta x } { if {$beta < 0} { return -code error -errorcode ARG -errorinfo "Rate parameter 'beta' must be positive" } if {$x < 0.0} { return 0.0 } set prod [expr {1.0 * $x * $beta}] set Galpha [expr {exp([::math::ln_Gamma $alpha])}] expr {(1.0 * $beta/$Galpha) * pow($prod, ($alpha - 1.0)) * exp(-$prod)} } # pdf-poisson -- # Return the probabilities belonging to a Poisson # distribution # # Arguments: # mu Mean of the distribution # k Number of occurrences # # Result: # Probability of k occurrences under the given distribution # # Note: # Implemented by Eric Kemp-Benedict, 2007 # proc ::math::statistics::pdf-poisson { mu k } { set intk [expr {int($k)}] expr {exp(-$mu + floor($k) * log($mu) - [::math::ln_Gamma [incr intk]])} } # pdf-chisquare -- # Return the probabilities belonging to a chi square distribution # # Arguments: # df Degree of freedom # x Value of variate # # Result: # Probability density of the given value of x to occur # # Note: # Implemented by Eric Kemp-Benedict, 2007 # proc ::math::statistics::pdf-chisquare { df x } { if {$df <= 0} { return -code error -errorcode ARG -errorinfo "Degrees of freedom must be positive" } return [pdf-gamma [expr {0.5*$df}] 0.5 $x] } # pdf-students-t -- # Return the probabilities belonging to a Student's t distribution # # Arguments: # degrees Degree of freedom # x Value of variate # # Result: # Probability density of the given value of x to occur # # Note: # Implemented by Eric Kemp-Benedict, 2007 # proc ::math::statistics::pdf-students-t { degrees x } { variable pi if {$degrees <= 0} { return -code error -errorcode ARG -errorinfo "Degrees of freedom must be positive" } set nplus1over2 [expr {0.5 * ($degrees + 1)}] set f1 [expr {exp([::math::ln_Gamma $nplus1over2] - \ [::math::ln_Gamma [expr {$nplus1over2 - 0.5}]])}] set f2 [expr {1.0/sqrt($degrees * $pi)}] expr {$f1 * $f2 * pow(1.0 + $x * $x/double($degrees), -$nplus1over2)} } # pdf-beta -- # Return the probabilities belonging to a Beta distribution # # Arguments: # a First parameter of the Beta distribution # b Second parameter of the Beta distribution # x Value of variate # # Result: # Probability density of the given value of x to occur # # Note: # Implemented by Eric Kemp-Benedict, 2008 # proc ::math::statistics::pdf-beta { a b x } { if {$x < 0.0 || $x > 1.0} { return -code error "Value out of range in Beta density: x = $x, not in \[0, 1\]" } if {$a <= 0.0} { return -code error "Value out of range in Beta density: a = $a, must be > 0" } if {$b <= 0.0} { return -code error "Value out of range in Beta density: b = $b, must be > 0" } # # Corner cases ... need to check these! # if {$x == 0.0} { return 0.0 } if {$x == 1.0} { return 0.0 } set aplusb [expr {$a + $b}] set term1 [expr {[::math::ln_Gamma $aplusb]- [::math::ln_Gamma $a] - [::math::ln_Gamma $b]}] set term2 [expr {($a - 1.0) * log($x) + ($b - 1.0) * log(1.0 - $x)}] set term [expr {$term1 + $term2}] if { $term > -200.0 } { return [expr {exp($term)}] } else { return 0.0 } } # incompleteBeta -- # Evaluate the incomplete Beta integral # # Arguments: # a First parameter of the Beta integral # b Second parameter of the Beta integral # x Integration limit # tol (Optional) error tolerance (defaults to 1.0e-9) # # Result: # Probability density of the given value of x to occur # # Note: # Implemented by Eric Kemp-Benedict, 2008 # proc ::math::statistics::incompleteBeta {a b x {tol 1.0e-9}} { if {$x < 0.0 || $x > 1.0} { return -code error "Value out of range in incomplete Beta function: x = $x, not in \[0, 1\]" } if {$a <= 0.0} { return -code error "Value out of range in incomplete Beta function: a = $a, must be > 0" } if {$b <= 0.0} { return -code error "Value out of range in incomplete Beta function: b = $b, must be > 0" } if {$x < $tol} { return 0.0 } if {$x > 1.0 - $tol} { return 1.0 } # Rearrange if necessary to get continued fraction to behave if {$x < 0.5} { return [beta_cont_frac $a $b $x $tol] } else { set z [beta_cont_frac $b $a [expr {1.0 - $x}] $tol] return [expr {1.0 - $z}] } } # beta_cont_frac -- # Evaluate the incomplete Beta integral via a continued fraction # # Arguments: # a First parameter of the Beta integral # b Second parameter of the Beta integral # x Integration limit # tol (Optional) error tolerance (defaults to 1.0e-9) # # Result: # Probability density of the given value of x to occur # # Note: # Implemented by Eric Kemp-Benedict, 2008 # # Continued fraction for Ix(a,b) # Abramowitz & Stegun 26.5.9 # proc ::math::statistics::beta_cont_frac {a b x {tol 1.0e-9}} { set max_iter 512 set aplusb [expr {$a + $b}] set amin1 [expr {$a - 1}] set lnGapb [::math::ln_Gamma $aplusb] set term1 [expr {$lnGapb- [::math::ln_Gamma $a] - [::math::ln_Gamma $b]}] set term2 [expr {$a * log($x) + ($b - 1.0) * log(1.0 - $x)}] set pref [expr {exp($term1 + $term2)/$a}] set z [expr {$x / (1.0 - $x)}] set v 1.0 set h_1 1.0 set h_2 0.0 set k_1 1.0 set k_2 1.0 for {set m 1} {$m < $max_iter} {incr m} { set f1 [expr {$amin1 + 2 * $m}] set e2m [expr {-$z * double(($amin1 + $m) * ($b - $m))/ \ double(($f1 - 1) * $f1)}] set e2mp1 [expr {$z * double($m * ($aplusb - 1 + $m)) / \ double($f1 * ($f1 + 1))}] set h_2m [expr {$h_1 + $e2m * $h_2}] set k_2m [expr {$k_1 + $e2m * $k_2}] set h_2 $h_2m set k_2 $k_2m set h_1 [expr {$h_2m + $e2mp1 * $h_1}] set k_1 [expr {$k_2m + $e2mp1 * $k_1}] set vprime [expr {$h_1/$k_1}] if {abs($v - $vprime) < $tol} { break } set v $vprime } if {$m == $max_iter} { return -code error "beta_cont_frac: Exceeded maximum number of iterations" } set retval [expr {$pref * $v}] # Because of imprecision in underlying Tcl calculations, may fall out of bounds if {$retval < 0.0} { set retval 0.0 } elseif {$retval > 1.0} { set retval 1.0 } return $retval } # cdf-gamma -- # Return the cumulative probabilities belonging to a gamma distribution # # Arguments: # alpha Shape parameter # beta Rate parameter # x Value of variate # # Result: # Cumulative probability of the given value of x to occur # # Note: # Implemented by Eric Kemp-Benedict, 2007 # proc ::math::statistics::cdf-gamma { alpha beta x } { if { $x <= 0 } { return 0.0 } incompleteGamma [expr {$beta * $x}] $alpha } # cdf-poisson -- # Return the cumulative probabilities belonging to a Poisson # distribution # # Arguments: # mu Mean of the distribution # x Number of occurrences # # Result: # Probability of k occurrences under the given distribution # # Note: # Implemented by Eric Kemp-Benedict, 2007 # proc ::math::statistics::cdf-poisson { mu x } { return [expr {1.0 - [incompleteGamma $mu [expr {floor($x) + 1}]]}] } # cdf-chisquare -- # Return the cumulative probabilities belonging to a chi square distribution # # Arguments: # df Degree of freedom # x Value of variate # # Result: # Cumulative probability of the given value of x to occur # # Note: # Implemented by Eric Kemp-Benedict, 2007 # proc ::math::statistics::cdf-chisquare { df x } { if {$df <= 0} { return -code error -errorcode ARG -errorinfo "Degrees of freedom must be positive" } return [cdf-gamma [expr {0.5*$df}] 0.5 $x] } # cdf-beta -- # Return the cumulative probabilities belonging to a Beta distribution # # Arguments: # a First parameter of the Beta distribution # b Second parameter of the Beta distribution # x Value of variate # # Result: # Cumulative probability of the given value of x to occur # # Note: # Implemented by Eric Kemp-Benedict, 2008 # proc ::math::statistics::cdf-beta { a b x } { incompleteBeta $a $b $x } # random-gamma -- # Generate a list of gamma-distributed deviates # # Arguments: # alpha Shape parameter # beta Rate parameter # x Value of variate # # Result: # List of random values # # Note: # Implemented by Eric Kemp-Benedict, 2007 # Generate a list of gamma-distributed random deviates # Use Cheng's envelope rejection method, as documented in: # Dagpunar, J.S. 2007 # "Simulation and Monte Carlo: With Applications in Finance and MCMC" # proc ::math::statistics::random-gamma {alpha beta number} { if {$alpha <= 1} { set lambda $alpha } else { set lambda [expr {sqrt(2.0 * $alpha - 1.0)}] } set retval {} for {set i 0} {$i < $number} {incr i} { while {1} { # Two rands: one for deviate, one for acceptance/rejection set r1 [expr {rand()}] set r2 [expr {rand()}] # Calculate deviate from enveloping proposal distribution (a Lorenz distribution) set lnxovera [expr {(1.0/$lambda) * (log(1.0 - $r1) - log($r1))}] if {![catch {expr {$alpha * exp($lnxovera)}} x]} { # Apply acceptance criterion if {log(4.0*$r1*$r1*$r2) < ($alpha - $lambda) * $lnxovera + $alpha - $x} { break } } } lappend retval [expr {1.0 * $x/$beta}] } return $retval } # random-poisson -- # Generate a list of Poisson-distributed deviates # # Arguments: # mu Mean value # number Number of deviates to return # # Result: # List of random values # # Note: # Implemented by Eric Kemp-Benedict, 2007 # proc ::math::statistics::random-poisson {mu number} { if {$mu < 20} { return [Randp_invert $mu $number] } else { return [Randp_PTRS $mu $number] } } # random-chisquare -- # Return a list of random numbers according to a chi square distribution # # Arguments: # df Degree of freedom # number Number of values to return # # Result: # List of random numbers # # Note: # Implemented by Eric Kemp-Benedict, 2007 # proc ::math::statistics::random-chisquare { df number } { if {$df <= 0} { return -code error -errorcode ARG -errorinfo "Degrees of freedom must be positive" } return [random-gamma [expr {0.5*$df}] 0.5 $number] } # random-students-t -- # Return a list of random numbers according to a chi square distribution # # Arguments: # degrees Degree of freedom # number Number of values to return # # Result: # List of random numbers # # Note: # Implemented by Eric Kemp-Benedict, 2007 # # Use method from Appendix 4.3 in Dagpunar, J.S., # "Simulation and Monte Carlo: With Applications in Finance and MCMC" # proc ::math::statistics::random-students-t { degrees number } { variable pi if {$degrees < 1} { return -code error -errorcode ARG -errorinfo "Degrees of freedom must be at least 1" } set dd [expr {double($degrees)}] set k [expr {2.0/($dd - 1.0)}] for {set i 0} {$i < $number} {incr i} { set r1 [expr {rand()}] if {$degrees > 1} { set r2 [expr {rand()}] set c [expr {cos(2.0 * $pi * $r2)}] lappend retval [expr {sqrt($dd/ \ (1.0/(1.0 - pow($r1, $k)) \ - $c * $c)) * $c}] } else { lappend retval [expr {tan(0.5 * $pi * ($r1 + $r1 - 1))}] } } set retval } # random-beta -- # Return a list of random numbers according to a Beta distribution # # Arguments: # a First parameter of the Beta distribution # b Second parameter of the Beta distribution # number Number of values to return # # Result: # Cumulative probability of the given value of x to occur # # Note: # Implemented by Eric Kemp-Benedict, 2008 # # Use trick from J.S. Dagpunar, "Simulation and # Monte Carlo: With Applications in Finance # and MCMC", Section 4.5 # proc ::math::statistics::random-beta { a b number } { set retval {} foreach w [random-gamma $a 1.0 $number] y [random-gamma $b 1.0 $number] { lappend retval [expr {$w / ($w + $y)}] } return $retval } # Random_invert -- # Generate a list of Poisson-distributed deviates - method 1 # # Arguments: # mu Mean value # number Number of deviates to return # # Result: # List of random values # # Note: # Implemented by Eric Kemp-Benedict, 2007 # # Generate a poisson-distributed random deviate # Use algorithm in section 4.9 of Dagpunar, J.S, # "Simulation and Monte Carlo: With Applications # in Finance and MCMC", pub. 2007 by Wiley # This inverts the cdf using a "chop-down" search # to avoid storing an extra intermediate value. # It is only good for small mu. # proc ::math::statistics::Randp_invert {mu number} { set W0 [expr {exp(-$mu)}] set retval {} for {set i 0} {$i < $number} {incr i} { set W $W0 set R [expr {rand()}] set X 0 while {$R > $W} { set R [expr {$R - $W}] incr X set W [expr {$W * $mu/double($X)}] } lappend retval $X } return $retval } # Random_PTRS -- # Generate a list of Poisson-distributed deviates - method 2 # # Arguments: # mu Mean value # number Number of deviates to return # # Result: # List of random values # # Note: # Implemented by Eric Kemp-Benedict, 2007 # Generate a poisson-distributed random deviate # Use the transformed rejection method with # squeeze of Hoermann: # Wolfgang Hoermann, "The Transformed Rejection Method # for Generating Poisson Random Variables," # Preprint #2, Dept of Applied Statistics and # Data Processing, Wirtshcaftsuniversitaet Wien, # http://statistik.wu-wien.ac.at/ # This method works for mu >= 10. # proc ::math::statistics::Randp_PTRS {mu number} { set smu [expr {sqrt($mu)}] set b [expr {0.931 + 2.53 * $smu}] set a [expr {-0.059 + 0.02483 * $b}] set vr [expr {0.9277 - 3.6224/($b - 2.0)}] set invalpha [expr {1.1239 + 1.1328/($b - 3.4)}] set lnmu [expr {log($mu)}] set retval {} for {set i 0} {$i < $number} {incr i} { while 1 { set U [expr {rand() - 0.5}] set V [expr {rand()}] set us [expr {0.5 - abs($U)}] set k [expr {int(floor((2.0 * $a/$us + $b) * $U + $mu + 0.43))}] if {$us >= 0.07 && $V <= $vr} { break } if {$k < 0} { continue } if {$us < 0.013 && $V > $us} { continue } set kp1 [expr {$k+1}] if {log($V * $invalpha / ($a/($us * $us) + $b)) <= -$mu + $k * $lnmu - [::math::ln_Gamma $kp1]} { break } } lappend retval $k } return $retval } # # Simple numerical tests # if { [info exists ::argv0] && ([file tail [info script]] == [file tail $::argv0]) } { # # Apparent accuracy: at least one digit more than the ones in the # given numbers # puts "Normal distribution - two-tailed" foreach z {4.417 3.891 3.291 2.576 2.241 1.960 1.645 1.150 0.674 0.319 0.126 0.063 0.0125} \ pexp {1.e-5 1.e-4 1.e-3 1.e-2 0.025 0.050 0.100 0.250 0.500 0.750 0.900 0.950 0.990 } { set prob [::math::statistics::Cdf-toms322 1 5000 [expr {$z*$z}]] puts "$z - $pexp - [expr {1.0-$prob}]" } puts "Normal distribution (inverted; one-tailed)" foreach p {0.001 0.01 0.1 0.25 0.5 0.75 0.9 0.99 0.999} { puts "$p - [::math::statistics::Inverse-cdf-normal 0.0 1.0 $p]" } puts "Normal random variables" set rndvars [::math::statistics::random-normal 1.0 2.0 20] puts $rndvars puts "Normal uniform variables" set rndvars [::math::statistics::random-uniform 1.0 2.0 20] puts $rndvars puts "Normal exponential variables" set rndvars [::math::statistics::random-exponential 2.0 20] puts $rndvars } tcllib-1.15/modules/math/fourier.tcl0000755000175000017500000003017712077663116017033 0ustar sergeisergei# fourier.tcl -- # Package for discrete (ordinary) and fast fourier transforms # # Author: Lars Hellstrom (...) # # The two top-level procedures defined are # # dft data-list # inverse_dft data-list # # which take a list of complex numbers and apply a Discrete Fourier # Transform (DFT) or its inverse respectively to these lists of numbers. # A "complex number" in this case is either (i) a pair (two element # list) of numbers, interpreted as the real and imaginary parts of the # complex number, or (ii) a single number, interpreted as the real # part of a complex number whose imaginary part is zero. The return # value is always in the first format. (The DFT generally produces # complex results even if the input is purely real.) Applying first # one and then the other of these procedures to a list of complex # numbers will (modulo rounding errors due to floating point # arithmetic) return the original list of numbers. # # If the input length N is a power of two then these procedures will # utilize the O(N log N) Fast Fourier Transform algorithm. If input # length is not a power of two then the DFT will instead be computed # using a the naive quadratic algorithm. # # Some examples: # # % dft {1 2 3 4} # {10 0.0} {-2.0 2.0} {-2 0.0} {-2.0 -2.0} # % inverse_dft {{10 0.0} {-2.0 2.0} {-2 0.0} {-2.0 -2.0}} # {1.0 0.0} {2.0 0.0} {3.0 0.0} {4.0 0.0} # % dft {1 2 3 4 5} # {15.0 0.0} {-2.5 3.44095480118} {-2.5 0.812299240582} {-2.5 -0.812299240582} {-2.5 -3.44095480118} # % inverse_dft {{15.0 0.0} {-2.5 3.44095480118} {-2.5 0.812299240582} {-2.5 -0.812299240582} {-2.5 -3.44095480118}} # {1.0 0.0} {2.0 8.881784197e-17} {3.0 4.4408920985e-17} {4.0 4.4408920985e-17} {5.0 -8.881784197e-17} # # In the last case, the imaginary parts <1e-16 would have been zero in # exact arithmetic, but aren't here due to rounding errors. # # Internally, the procedures use a flat list format where every even # index element of a list is a real part and every odd index element is # an imaginary part. This is reflected in the variable names by Re_ and # Im_ prefixes. # namespace eval ::math::fourier { #::math::constants pi namespace export dft inverse_dft lowpass highpass } # dft -- # Return the discrete fourier transform as a list of complex numbers # # Arguments: # in_data List of data (either real or complex) # Returns: # List of complex amplitudes for the Fourier components # Note: # The procedure uses an ordinary DFT if the number of data is # not a power of 2, otherwise it uses FFT. # proc ::math::fourier::dft {in_data} { # First convert to internal format set dataL [list] set n 0 foreach datum $in_data { if {[llength $datum] == 1} then { lappend dataL $datum 0.0 } else { lappend dataL [lindex $datum 0] [lindex $datum 1] } incr n } # Then compute a list of n'th roots of unity (explanation below) set rootL [DFT_make_roots $n -1] # Check if the input length is a power of two. set p 1 while {$p < $n} {set p [expr {$p << 1}]} # By construction, $p is a power of two. If $n==$p then $n is too. # Finally compute the transform using Fast_DFT or Slow_DFT, # and convert back to the input format. set res [list] foreach {Re Im} [ if {$p == $n} then { Fast_DFT $dataL $rootL } else { Slow_DFT $dataL $rootL } ] { lappend res [list $Re $Im] } return $res } # inverse_dft -- # Invert the discrete fourier transform and return the restored data # as complex numbers # # Arguments: # in_data List of fourier coefficients (either real or complex) # Returns: # List of complex amplitudes for the Fourier components # Note: # The procedure uses an ordinary DFT if the number of data is # not a power of 2, otherwise it uses FFT. # proc ::math::fourier::inverse_dft {in_data} { # First convert to internal format set dataL [list] set n 0 foreach datum $in_data { if {[llength $datum] == 1} then { lappend dataL $datum 0.0 } else { lappend dataL [lindex $datum 0] [lindex $datum 1] } incr n } # Then compute a list of n'th roots of unity (explanation below) set rootL [DFT_make_roots $n 1] # Check if the input length is a power of two. set p 1 while {$p < $n} {set p [expr {$p << 1}]} # By construction, $p is a power of two. If $n==$p then $n is too. # Finally compute the transform using Fast_DFT or Slow_DFT, # divide by input data length to correct the amplitudes, # and convert back to the input format. set res [list] foreach {Re Im} [ # $p is power of two. If $n==$p then $n is too. if {$p == $n} then { Fast_DFT $dataL $rootL } else { Slow_DFT $dataL $rootL } ] { lappend res [list [expr {$Re/$n}] [expr {$Im/$n}]] } return $res } # DFT_make_roots -- # Return a list of the complex roots of unity or of -1 # # Arguments: # n Order of the roots # sign Whether to use 1 or -1 (for inverse transform) # Returns: # List of complex roots of unity or -1 # proc ::math::fourier::DFT_make_roots {n sign} { set res [list] for {set k 0} {2*$k < $n} {incr k} { set alpha [expr {2*3.1415926535897931*$sign*$k/$n}] lappend res [expr {cos($alpha)}] [expr {sin($alpha)}] } return $res } # Fast_DFT -- # Perform the fast Fourier transform # # Arguments: # dataL List of data # rootL Roots of unity or -1 to use in the transform # Returns: # List of complex numbers # proc ::math::fourier::Fast_DFT {dataL rootL} { if {[llength $dataL] == 8} then { foreach {Re_z0 Im_z0 Re_z1 Im_z1 Re_z2 Im_z2 Re_z3 Im_z3} $dataL {break} if {[lindex $rootL 3] > 0} then { return [list\ [expr {$Re_z0 + $Re_z1 + $Re_z2 + $Re_z3}] [expr {$Im_z0 + $Im_z1 + $Im_z2 + $Im_z3}]\ [expr {$Re_z0 - $Im_z1 - $Re_z2 + $Im_z3}] [expr {$Im_z0 + $Re_z1 - $Im_z2 - $Re_z3}]\ [expr {$Re_z0 - $Re_z1 + $Re_z2 - $Re_z3}] [expr {$Im_z0 - $Im_z1 + $Im_z2 - $Im_z3}]\ [expr {$Re_z0 + $Im_z1 - $Re_z2 - $Im_z3}] [expr {$Im_z0 - $Re_z1 - $Im_z2 + $Re_z3}]] } else { return [list\ [expr {$Re_z0 + $Re_z1 + $Re_z2 + $Re_z3}] [expr {$Im_z0 + $Im_z1 + $Im_z2 + $Im_z3}]\ [expr {$Re_z0 + $Im_z1 - $Re_z2 - $Im_z3}] [expr {$Im_z0 - $Re_z1 - $Im_z2 + $Re_z3}]\ [expr {$Re_z0 - $Re_z1 + $Re_z2 - $Re_z3}] [expr {$Im_z0 - $Im_z1 + $Im_z2 - $Im_z3}]\ [expr {$Re_z0 - $Im_z1 - $Re_z2 + $Im_z3}] [expr {$Im_z0 + $Re_z1 - $Im_z2 - $Re_z3}]] } } elseif {[llength $dataL] > 8} then { set evenL [list] set oddL [list] foreach {Re_z0 Im_z0 Re_z1 Im_z1} $dataL { lappend evenL $Re_z0 $Im_z0 lappend oddL $Re_z1 $Im_z1 } set squarerootL [list] foreach {Re_omega0 Im_omega0 Re_omega1 Im_omega1} $rootL { lappend squarerootL $Re_omega0 $Im_omega0 } set lowL [list] set highL [list] foreach\ {Re_y0 Im_y0} [Fast_DFT $evenL $squarerootL]\ {Re_y1 Im_y1} [Fast_DFT $oddL $squarerootL]\ {Re_omega Im_omega} $rootL { set Re_y1t [expr {$Re_y1 * $Re_omega - $Im_y1 * $Im_omega}] set Im_y1t [expr {$Im_y1 * $Re_omega + $Re_y1 * $Im_omega}] lappend lowL [expr {$Re_y0 + $Re_y1t}] [expr {$Im_y0 + $Im_y1t}] lappend highL [expr {$Re_y0 - $Re_y1t}] [expr {$Im_y0 - $Im_y1t}] } return [concat $lowL $highL] } elseif {[llength $dataL] == 4} then { foreach {Re_z0 Im_z0 Re_z1 Im_z1} $dataL {break} return [list\ [expr {$Re_z0 + $Re_z1}] [expr {$Im_z0 + $Im_z1}]\ [expr {$Re_z0 - $Re_z1}] [expr {$Im_z0 - $Im_z1}]] } else { return $dataL } } # Slow_DFT -- # Perform the ordinary discrete (slow) Fourier transform # # Arguments: # dataL List of data # rootL Roots of unity or -1 to use in the transform # Returns: # List of complex numbers # proc ::math::fourier::Slow_DFT {dataL rootL} { set n [expr {[llength $dataL] / 2}] # The missing roots are computed by complex conjugating the given # roots. If $n is even then -1 is also needed; it is inserted explicitly. set k [llength $rootL] if {$n % 2 == 0} then { lappend rootL -1.0 0.0 } for {incr k -2} {$k > 0} {incr k -2} { lappend rootL [lindex $rootL $k]\ [expr {-[lindex $rootL [expr {$k+1}]]}] } # This is strictly following the naive formula. # The product jk is kept as a separate counter variable. set res [list] for {set k 0} {$k < $n} {incr k} { set Re_sum 0.0 set Im_sum 0.0 set jk 0 foreach {Re_z Im_z} $dataL { set Re_omega [lindex $rootL [expr {2*$jk}]] set Im_omega [lindex $rootL [expr {2*$jk+1}]] set Re_sum [expr {$Re_sum + $Re_z * $Re_omega - $Im_z * $Im_omega}] set Im_sum [expr {$Im_sum + $Im_z * $Re_omega + $Re_z * $Im_omega}] incr jk $k if {$jk >= $n} then {set jk [expr {$jk - $n}]} } lappend res $Re_sum $Im_sum } return $res } # lowpass -- # Apply a low-pass filter to the Fourier transform # # Arguments: # cutoff Cut-off frequency # in_data Input transform (complex data) # Returns: # Filtered transform # proc ::math::fourier::lowpass {cutoff in_data} { package require math::complexnumbers set res [list] set cutoff [list $cutoff 0.0] set f 0.0 foreach a $in_data { set an [::math::complexnumbers::/ $a \ [::math::complexnumbers::+ {1.0 0.0} \ [::math::complexnumbers::/ [list 0.0 $f] $cutoff]]] lappend res $an set f [expr {$f+1.0}] } return $res } # highpass -- # Apply a high-pass filter to the Fourier transform # # Arguments: # cutoff Cut-off frequency # in_data Input transform (complex data) # Returns: # Filtered transform (high-pass) # proc ::math::fourier::highpass {cutoff in_data} { package require math::complexnumbers set res [list] set cutoff [list $cutoff 0.0] set f 0.0 foreach a $in_data { set ff [::math::complexnumbers::/ [list 0.0 $f] $cutoff] set an [::math::complexnumbers::/ $ff \ [::math::complexnumbers::+ {1.0 0.0} $ff]] lappend res $an set f [expr {$f+1.0}] } return $res } # # Announce the package # package provide math::fourier 1.0.2 # test -- # proc test_dft {points {real 0} {iterations 20}} { set in_dataL [list] for {set k 0} {$k < $points} {incr k} { if {$real} then { lappend in_dataL [expr {2*rand()-1}] } else { lappend in_dataL [list [expr {2*rand()-1}] [expr {2*rand()-1}]] } } set time1 [time { set conv_dataL [::math::fourier::dft $in_dataL] } $iterations] set time2 [time { set out_dataL [::math::fourier::inverse_dft $conv_dataL] } $iterations] set err 0.0 foreach iz $in_dataL oz $out_dataL { if {$real} then { foreach {o1 o2} $oz {break} set err [expr {$err + ($i-$o1)*($i-$o1) + $o2*$o2}] } else { foreach i $iz o $oz { set err [expr {$err + ($i-$o)*($i-$o)}] } } } return [format "Forward: %s\nInverse: %s\nAverage error: %g"\ $time1 $time2 [expr {sqrt($err/$points)}]] } # Note: # Add simple filters if { 0 } { puts [::math::fourier::dft {1 2 3 4}] puts [::math::fourier::inverse_dft {{10 0.0} {-2.0 2.0} {-2 0.0} {-2.0 -2.0}}] puts [::math::fourier::dft {1 2 3 4 5}] puts [::math::fourier::inverse_dft {{15.0 0.0} {-2.5 3.44095480118} {-2.5 0.812299240582} {-2.5 -0.812299240582} {-2.5 -3.44095480118}}] puts [test_dft 10] puts [test_dft 16] puts [test_dft 100] puts [test_dft 128] puts [::math::fourier::dft {1 2 3 4}] puts [::math::fourier::lowpass 1.5 [::math::fourier::dft {1 2 3 4}]] } tcllib-1.15/modules/math/bignum.tcl0000755000175000017500000007072512077663116016644 0ustar sergeisergei# bignum library in pure Tcl [VERSION 7Sep2004] # Copyright (C) 2004 Salvatore Sanfilippo # Copyright (C) 2004 Arjen Markus # # LICENSE # # This software is: # Copyright (C) 2004 Salvatore Sanfilippo # Copyright (C) 2004 Arjen Markus # 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. # # GOVERNMENT USE: If you are acquiring this software on behalf of the # U.S. government, the Government shall have only "Restricted Rights" # in the software and related documentation as defined in the Federal # Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you # are acquiring the software on behalf of the Department of Defense, the # software shall be classified as "Commercial Computer Software" and the # Government shall have only "Restricted Rights" as defined in Clause # 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the # authors grant the U.S. Government and others acting in its behalf # permission to use and distribute the software in accordance with the # terms specified in this license. # TODO # - pow and powm should check if the exponent is zero in order to return one package require Tcl 8.4 namespace eval ::math::bignum {} #################################### Misc ###################################### # Don't change atombits define if you don't know what you are doing. # Note that it must be a power of two, and that 16 is too big # because expr may overflow in the product of two 16 bit numbers. set ::math::bignum::atombits 16 set ::math::bignum::atombase [expr {1 << $::math::bignum::atombits}] set ::math::bignum::atommask [expr {$::math::bignum::atombase-1}] # Note: to change 'atombits' is all you need to change the # library internal representation base. # Return the max between a and b (not bignums) proc ::math::bignum::max {a b} { expr {($a > $b) ? $a : $b} } # Return the min between a and b (not bignums) proc ::math::bignum::min {a b} { expr {($a < $b) ? $a : $b} } ############################ Basic bignum operations ########################### # Returns a new bignum initialized to the value of 0. # # The big numbers are represented as a Tcl lists # The all-is-a-string representation does not pay here # bignums in Tcl are already slow, we can't slow-down it more. # # The bignum representation is [list bignum ... ] # Where the atom0 is the least significant. Atoms are the digits # of a number in base 2^$::math::bignum::atombits # # The sign is 0 if the number is positive, 1 for negative numbers. # Note that the function accepts an argument used in order to # create a bignum of atoms. For default zero is # represented as a single zero atom. # # The function is designed so that "set b [zero [atoms $a]]" will # produce 'b' with the same number of atoms as 'a'. proc ::math::bignum::zero {{value 0}} { set v [list bignum 0 0] while { $value > 1 } { lappend v 0 incr value -1 } return $v } # Get the bignum sign proc ::math::bignum::sign bignum { lindex $bignum 1 } # Get the number of atoms in the bignum proc ::math::bignum::atoms bignum { expr {[llength $bignum]-2} } # Get the i-th atom out of a bignum. # If the bignum is shorter than i atoms, the function # returns 0. proc ::math::bignum::atom {bignum i} { if {[::math::bignum::atoms $bignum] < [expr {$i+1}]} { return 0 } else { lindex $bignum [expr {$i+2}] } } # Set the i-th atom out of a bignum. If the bignum # has less than 'i+1' atoms, add zero atoms to reach i. proc ::math::bignum::setatom {bignumvar i atomval} { upvar 1 $bignumvar bignum while {[::math::bignum::atoms $bignum] < [expr {$i+1}]} { lappend bignum 0 } lset bignum [expr {$i+2}] $atomval } # Set the bignum sign proc ::math::bignum::setsign {bignumvar sign} { upvar 1 $bignumvar bignum lset bignum 1 $sign } # Remove trailing atoms with a value of zero # The normalized bignum is returned proc ::math::bignum::normalize bignumvar { upvar 1 $bignumvar bignum set atoms [expr {[llength $bignum]-2}] set i [expr {$atoms+1}] while {$atoms && [lindex $bignum $i] == 0} { set bignum [lrange $bignum 0 end-1] incr atoms -1 incr i -1 } if {!$atoms} { set bignum [list bignum 0 0] } return $bignum } # Return the absolute value of N proc ::math::bignum::abs n { ::math::bignum::setsign n 0 return $n } ################################# Comparison ################################### # Compare by absolute value. Called by ::math::bignum::cmp after the sign check. # # Returns 1 if |a| > |b| # 0 if a == b # -1 if |a| < |b| # proc ::math::bignum::abscmp {a b} { if {[llength $a] > [llength $b]} { return 1 } elseif {[llength $a] < [llength $b]} { return -1 } set j [expr {[llength $a]-1}] while {$j >= 2} { if {[lindex $a $j] > [lindex $b $j]} { return 1 } elseif {[lindex $a $j] < [lindex $b $j]} { return -1 } incr j -1 } return 0 } # High level comparison. Return values: # # 1 if a > b # -1 if a < b # 0 if a == b # proc ::math::bignum::cmp {a b} { ; # same sign case set a [_treat $a] set b [_treat $b] if {[::math::bignum::sign $a] == [::math::bignum::sign $b]} { if {[::math::bignum::sign $a] == 0} { ::math::bignum::abscmp $a $b } else { expr {-([::math::bignum::abscmp $a $b])} } } else { ; # different sign case if {[::math::bignum::sign $a]} {return -1} return 1 } } # Return true if 'z' is zero. proc ::math::bignum::iszero z { set z [_treat $z] expr {[llength $z] == 3 && [lindex $z 2] == 0} } # Comparison facilities proc ::math::bignum::lt {a b} {expr {[::math::bignum::cmp $a $b] < 0}} proc ::math::bignum::le {a b} {expr {[::math::bignum::cmp $a $b] <= 0}} proc ::math::bignum::gt {a b} {expr {[::math::bignum::cmp $a $b] > 0}} proc ::math::bignum::ge {a b} {expr {[::math::bignum::cmp $a $b] >= 0}} proc ::math::bignum::eq {a b} {expr {[::math::bignum::cmp $a $b] == 0}} proc ::math::bignum::ne {a b} {expr {[::math::bignum::cmp $a $b] != 0}} ########################### Addition / Subtraction ############################# # Add two bignums, don't care about the sign. proc ::math::bignum::rawAdd {a b} { while {[llength $a] < [llength $b]} {lappend a 0} while {[llength $b] < [llength $a]} {lappend b 0} set r [::math::bignum::zero [expr {[llength $a]-1}]] set car 0 for {set i 2} {$i < [llength $a]} {incr i} { set sum [expr {[lindex $a $i]+[lindex $b $i]+$car}] set car [expr {$sum >> $::math::bignum::atombits}] set sum [expr {$sum & $::math::bignum::atommask}] lset r $i $sum } if {$car} { lset r $i $car } ::math::bignum::normalize r } # Subtract two bignums, don't care about the sign. a > b condition needed. proc ::math::bignum::rawSub {a b} { set atoms [::math::bignum::atoms $a] set r [::math::bignum::zero $atoms] while {[llength $b] < [llength $a]} {lappend b 0} ; # b padding set car 0 incr atoms 2 for {set i 2} {$i < $atoms} {incr i} { set sub [expr {[lindex $a $i]-[lindex $b $i]-$car}] set car 0 if {$sub < 0} { incr sub $::math::bignum::atombase set car 1 } lset r $i $sub } # Note that if a > b there is no car in the last for iteration ::math::bignum::normalize r } # Higher level addition, care about sign and call rawAdd or rawSub # as needed. proc ::math::bignum::add {a b} { set a [_treat $a] set b [_treat $b] # Same sign case if {[::math::bignum::sign $a] == [::math::bignum::sign $b]} { set r [::math::bignum::rawAdd $a $b] ::math::bignum::setsign r [::math::bignum::sign $a] } else { # Different sign case set cmp [::math::bignum::abscmp $a $b] # 's' is the sign, set accordingly to A or B negative set s [expr {[::math::bignum::sign $a] == 1}] switch -- $cmp { 0 {return [::math::bignum::zero]} 1 { set r [::math::bignum::rawSub $a $b] ::math::bignum::setsign r $s return $r } -1 { set r [::math::bignum::rawSub $b $a] ::math::bignum::setsign r [expr {!$s}] return $r } } } return $r } # Higher level subtraction, care about sign and call rawAdd or rawSub # as needed. proc ::math::bignum::sub {a b} { set a [_treat $a] set b [_treat $b] # Different sign case if {[::math::bignum::sign $a] != [::math::bignum::sign $b]} { set r [::math::bignum::rawAdd $a $b] ::math::bignum::setsign r [::math::bignum::sign $a] } else { # Same sign case set cmp [::math::bignum::abscmp $a $b] # 's' is the sign, set accordingly to A and B both negative or positive set s [expr {[::math::bignum::sign $a] == 1}] switch -- $cmp { 0 {return [::math::bignum::zero]} 1 { set r [::math::bignum::rawSub $a $b] ::math::bignum::setsign r $s return $r } -1 { set r [::math::bignum::rawSub $b $a] ::math::bignum::setsign r [expr {!$s}] return $r } } } return $r } ############################### Multiplication ################################# set ::math::bignum::karatsubaThreshold 32 # Multiplication. Calls Karatsuba that calls Base multiplication under # a given threshold. proc ::math::bignum::mul {a b} { set a [_treat $a] set b [_treat $b] set r [::math::bignum::kmul $a $b] # The sign is the xor between the two signs ::math::bignum::setsign r [expr {[::math::bignum::sign $a]^[::math::bignum::sign $b]}] } # Karatsuba Multiplication proc ::math::bignum::kmul {a b} { set n [expr {[::math::bignum::max [llength $a] [llength $b]]-2}] set nmin [expr {[::math::bignum::min [llength $a] [llength $b]]-2}] if {$nmin < $::math::bignum::karatsubaThreshold} {return [::math::bignum::bmul $a $b]} set m [expr {($n+($n&1))/2}] set x0 [concat [list bignum 0] [lrange $a 2 [expr {$m+1}]]] set y0 [concat [list bignum 0] [lrange $b 2 [expr {$m+1}]]] set x1 [concat [list bignum 0] [lrange $a [expr {$m+2}] end]] set y1 [concat [list bignum 0] [lrange $b [expr {$m+2}] end]] if {0} { puts "m: $m" puts "x0: $x0" puts "x1: $x1" puts "y0: $y0" puts "y1: $y1" } set p1 [::math::bignum::kmul $x1 $y1] set p2 [::math::bignum::kmul $x0 $y0] set p3 [::math::bignum::kmul [::math::bignum::add $x1 $x0] [::math::bignum::add $y1 $y0]] set p3 [::math::bignum::sub $p3 $p1] set p3 [::math::bignum::sub $p3 $p2] set p1 [::math::bignum::lshiftAtoms $p1 [expr {$m*2}]] set p3 [::math::bignum::lshiftAtoms $p3 $m] set p3 [::math::bignum::add $p3 $p1] set p3 [::math::bignum::add $p3 $p2] return $p3 } # Base Multiplication. proc ::math::bignum::bmul {a b} { set r [::math::bignum::zero [expr {[llength $a]+[llength $b]-3}]] for {set j 2} {$j < [llength $b]} {incr j} { set car 0 set t [list bignum 0 0] for {set i 2} {$i < [llength $a]} {incr i} { # note that A = B * C + D + E # with A of N*2 bits and C,D,E of N bits # can't overflow since: # (2^N-1)*(2^N-1)+(2^N-1)+(2^N-1) == 2^(2*N)-1 set t0 [lindex $a $i] set t1 [lindex $b $j] set t2 [lindex $r [expr {$i+$j-2}]] set mul [expr {wide($t0)*$t1+$t2+$car}] set car [expr {$mul >> $::math::bignum::atombits}] set mul [expr {$mul & $::math::bignum::atommask}] lset r [expr {$i+$j-2}] $mul } if {$car} { lset r [expr {$i+$j-2}] $car } } ::math::bignum::normalize r } ################################## Shifting #################################### # Left shift 'z' of 'n' atoms. Low-level function used by ::math::bignum::lshift # Exploit the internal representation to go faster. proc ::math::bignum::lshiftAtoms {z n} { while {$n} { set z [linsert $z 2 0] incr n -1 } return $z } # Right shift 'z' of 'n' atoms. Low-level function used by ::math::bignum::lshift # Exploit the internal representation to go faster. proc ::math::bignum::rshiftAtoms {z n} { set z [lreplace $z 2 [expr {$n+1}]] } # Left shift 'z' of 'n' bits. Low-level function used by ::math::bignum::lshift. # 'n' must be <= $::math::bignum::atombits proc ::math::bignum::lshiftBits {z n} { set atoms [llength $z] set car 0 for {set j 2} {$j < $atoms} {incr j} { set t [lindex $z $j] lset z $j \ [expr {wide($car)|((wide($t)<<$n)&$::math::bignum::atommask)}] set car [expr {wide($t)>>($::math::bignum::atombits-$n)}] } if {$car} { lappend z 0 lset z $j $car } return $z ; # No normalization needed } # Right shift 'z' of 'n' bits. Low-level function used by ::math::bignum::rshift. # 'n' must be <= $::math::bignum::atombits proc ::math::bignum::rshiftBits {z n} { set atoms [llength $z] set car 0 for {set j [expr {$atoms-1}]} {$j >= 2} {incr j -1} { set t [lindex $z $j] lset z $j [expr {wide($car)|(wide($t)>>$n)}] set car \ [expr {(wide($t)<<($::math::bignum::atombits-$n))&$::math::bignum::atommask}] } ::math::bignum::normalize z } # Left shift 'z' of 'n' bits. proc ::math::bignum::lshift {z n} { set z [_treat $z] set atoms [expr {$n / $::math::bignum::atombits}] set bits [expr {$n & ($::math::bignum::atombits-1)}] ::math::bignum::lshiftBits [math::bignum::lshiftAtoms $z $atoms] $bits } # Right shift 'z' of 'n' bits. proc ::math::bignum::rshift {z n} { set z [_treat $z] set atoms [expr {$n / $::math::bignum::atombits}] set bits [expr {$n & ($::math::bignum::atombits-1)}] # # Correct for "arithmetic shift" - signed integers # set corr 0 if { [::math::bignum::sign $z] == 1 } { for {set j [expr {$atoms+1}]} {$j >= 2} {incr j -1} { set t [lindex $z $j] if { $t != 0 } { set corr 1 } } if { $corr == 0 } { set t [lindex $z [expr {$atoms+2}]] if { ( $t & ~($::math::bignum::atommask<<($bits)) ) != 0 } { set corr 1 } } } set newz [::math::bignum::rshiftBits [math::bignum::rshiftAtoms $z $atoms] $bits] if { $corr } { set newz [::math::bignum::sub $newz 1] } return $newz } ############################## Bit oriented ops ################################ # Set the bit 'n' of 'bignumvar' proc ::math::bignum::setbit {bignumvar n} { upvar 1 $bignumvar z set atom [expr {$n / $::math::bignum::atombits}] set bit [expr {1 << ($n & ($::math::bignum::atombits-1))}] incr atom 2 while {$atom >= [llength $z]} {lappend z 0} lset z $atom [expr {[lindex $z $atom]|$bit}] } # Clear the bit 'n' of 'bignumvar' proc ::math::bignum::clearbit {bignumvar n} { upvar 1 $bignumvar z set atom [expr {$n / $::math::bignum::atombits}] incr atom 2 if {$atom >= [llength $z]} {return $z} set mask [expr {$::math::bignum::atommask^(1 << ($n & ($::math::bignum::atombits-1)))}] lset z $atom [expr {[lindex $z $atom]&$mask}] ::math::bignum::normalize z } # Test the bit 'n' of 'z'. Returns true if the bit is set. proc ::math::bignum::testbit {z n} { set atom [expr {$n / $::math::bignum::atombits}] incr atom 2 if {$atom >= [llength $z]} {return 0} set mask [expr {1 << ($n & ($::math::bignum::atombits-1))}] expr {([lindex $z $atom] & $mask) != 0} } # does bitwise and between a and b proc ::math::bignum::bitand {a b} { # The internal number rep is little endian. Appending zeros is # equivalent to adding leading zeros to a regular big-endian # representation. The two numbers are extended to the same length, # then the operation is applied to the absolute value. set a [_treat $a] set b [_treat $b] while {[llength $a] < [llength $b]} {lappend a 0} while {[llength $b] < [llength $a]} {lappend b 0} set r [::math::bignum::zero [expr {[llength $a]-1}]] for {set i 2} {$i < [llength $a]} {incr i} { set or [expr {[lindex $a $i] & [lindex $b $i]}] lset r $i $or } ::math::bignum::normalize r } # does bitwise XOR between a and b proc ::math::bignum::bitxor {a b} { # The internal number rep is little endian. Appending zeros is # equivalent to adding leading zeros to a regular big-endian # representation. The two numbers are extended to the same length, # then the operation is applied to the absolute value. set a [_treat $a] set b [_treat $b] while {[llength $a] < [llength $b]} {lappend a 0} while {[llength $b] < [llength $a]} {lappend b 0} set r [::math::bignum::zero [expr {[llength $a]-1}]] for {set i 2} {$i < [llength $a]} {incr i} { set or [expr {[lindex $a $i] ^ [lindex $b $i]}] lset r $i $or } ::math::bignum::normalize r } # does bitwise or between a and b proc ::math::bignum::bitor {a b} { # The internal number rep is little endian. Appending zeros is # equivalent to adding leading zeros to a regular big-endian # representation. The two numbers are extended to the same length, # then the operation is applied to the absolute value. set a [_treat $a] set b [_treat $b] while {[llength $a] < [llength $b]} {lappend a 0} while {[llength $b] < [llength $a]} {lappend b 0} set r [::math::bignum::zero [expr {[llength $a]-1}]] for {set i 2} {$i < [llength $a]} {incr i} { set or [expr {[lindex $a $i] | [lindex $b $i]}] lset r $i $or } ::math::bignum::normalize r } # Return the number of bits needed to represent 'z'. proc ::math::bignum::bits z { set atoms [::math::bignum::atoms $z] set bits [expr {($atoms-1)*$::math::bignum::atombits}] set atom [lindex $z [expr {$atoms+1}]] while {$atom} { incr bits set atom [expr {$atom >> 1}] } return $bits } ################################## Division #################################### # Division. Returns [list n/d n%d] # # I got this algorithm from PGP 2.6.3i (see the mp_udiv function). # Here is how it works: # # Input: N=(Nn,...,N2,N1,N0)radix2 # D=(Dn,...,D2,D1,D0)radix2 # Output: Q=(Qn,...,Q2,Q1,Q0)radix2 = N/D # R=(Rn,...,R2,R1,R0)radix2 = N%D # # Assume: N >= 0, D > 0 # # For j from 0 to n # Qj <- 0 # Rj <- 0 # For j from n down to 0 # R <- R*2 # if Nj = 1 then R0 <- 1 # if R => D then R <- (R - D), Qn <- 1 # # Note that the doubling of R is usually done leftshifting one position. # The only operations needed are bit testing, bit setting and subtraction. # # This is the "raw" version, don't care about the sign, returns both # quotient and rest as a two element list. # This procedure is used by divqr, div, mod, rem. proc ::math::bignum::rawDiv {n d} { set bit [expr {[::math::bignum::bits $n]-1}] set r [list bignum 0 0] set q [::math::bignum::zero [expr {[llength $n]-2}]] while {$bit >= 0} { set b_atom [expr {($bit / $::math::bignum::atombits) + 2}] set b_bit [expr {1 << ($bit & ($::math::bignum::atombits-1))}] set r [::math::bignum::lshiftBits $r 1] if {[lindex $n $b_atom]&$b_bit} { lset r 2 [expr {[lindex $r 2] | 1}] } if {[::math::bignum::abscmp $r $d] >= 0} { set r [::math::bignum::rawSub $r $d] lset q $b_atom [expr {[lindex $q $b_atom]|$b_bit}] } incr bit -1 } ::math::bignum::normalize q list $q $r } # Divide by single-atom immediate. Used to speedup bignum -> string conversion. # The procedure returns a two-elements list with the bignum quotient and # the remainder (that's just a number being <= of the max atom value). proc ::math::bignum::rawDivByAtom {n d} { set atoms [::math::bignum::atoms $n] set t 0 set j $atoms incr j -1 for {} {$j >= 0} {incr j -1} { set t [expr {($t << $::math::bignum::atombits)+[lindex $n [expr {$j+2}]]}] lset n [expr {$j+2}] [expr {$t/$d}] set t [expr {$t % $d}] } ::math::bignum::normalize n list $n $t } # Higher level division. Returns a list with two bignums, the first # is the quotient of n/d, the second the remainder n%d. # Note that if you want the *modulo* operator you should use ::math::bignum::mod # # The remainder sign is always the same as the divident. proc ::math::bignum::divqr {n d} { set n [_treat $n] set d [_treat $d] if {[::math::bignum::iszero $d]} { error "Division by zero" } foreach {q r} [::math::bignum::rawDiv $n $d] break ::math::bignum::setsign q [expr {[::math::bignum::sign $n]^[::math::bignum::sign $d]}] ::math::bignum::setsign r [::math::bignum::sign $n] list $q $r } # Like divqr, but only the quotient is returned. proc ::math::bignum::div {n d} { lindex [::math::bignum::divqr $n $d] 0 } # Like divqr, but only the remainder is returned. proc ::math::bignum::rem {n d} { lindex [::math::bignum::divqr $n $d] 1 } # Modular reduction. Returns N modulo M proc ::math::bignum::mod {n m} { set n [_treat $n] set m [_treat $m] set r [lindex [::math::bignum::divqr $n $m] 1] if {[::math::bignum::sign $m] != [::math::bignum::sign $r]} { set r [::math::bignum::add $r $m] } return $r } # Returns true if n is odd proc ::math::bignum::isodd n { expr {[lindex $n 2]&1} } # Returns true if n is even proc ::math::bignum::iseven n { expr {!([lindex $n 2]&1)} } ############################# Power and Power mod N ############################ # Returns b^e proc ::math::bignum::pow {b e} { set b [_treat $b] set e [_treat $e] if {[::math::bignum::iszero $e]} {return [list bignum 0 1]} # The power is negative is the base is negative and the exponent is odd set sign [expr {[::math::bignum::sign $b] && [::math::bignum::isodd $e]}] # Set the base to it's abs value, i.e. make it positive ::math::bignum::setsign b 0 # Main loop set r [list bignum 0 1]; # Start with result = 1 while {[::math::bignum::abscmp $e [list bignum 0 1]] > 0} { ;# While the exp > 1 if {[::math::bignum::isodd $e]} { set r [::math::bignum::mul $r $b] } set e [::math::bignum::rshiftBits $e 1] ;# exp = exp / 2 set b [::math::bignum::mul $b $b] } set r [::math::bignum::mul $r $b] ::math::bignum::setsign r $sign return $r } # Returns b^e mod m proc ::math::bignum::powm {b e m} { set b [_treat $b] set e [_treat $e] set m [_treat $m] if {[::math::bignum::iszero $e]} {return [list bignum 0 1]} # The power is negative is the base is negative and the exponent is odd set sign [expr {[::math::bignum::sign $b] && [::math::bignum::isodd $e]}] # Set the base to it's abs value, i.e. make it positive ::math::bignum::setsign b 0 # Main loop set r [list bignum 0 1]; # Start with result = 1 while {[::math::bignum::abscmp $e [list bignum 0 1]] > 0} { ;# While the exp > 1 if {[::math::bignum::isodd $e]} { set r [::math::bignum::mod [::math::bignum::mul $r $b] $m] } set e [::math::bignum::rshiftBits $e 1] ;# exp = exp / 2 set b [::math::bignum::mod [::math::bignum::mul $b $b] $m] } set r [::math::bignum::mul $r $b] ::math::bignum::setsign r $sign set r [::math::bignum::mod $r $m] return $r } ################################## Square Root ################################# # SQRT using the 'binary sqrt algorithm'. # # The basic algoritm consists in starting from the higer-bit # the real square root may have set, down to the bit zero, # trying to set every bit and checking if guess*guess is not # greater than 'n'. If it is greater we don't set the bit, otherwise # we set it. In order to avoid to compute guess*guess a trick # is used, so only addition and shifting are really required. proc ::math::bignum::sqrt n { if {[lindex $n 1]} { error "Square root of a negative number" } set i [expr {(([::math::bignum::bits $n]-1)/2)+1}] set b [expr {$i*2}] ; # Bit to set to get 2^i*2^i set r [::math::bignum::zero] ; # guess set x [::math::bignum::zero] ; # guess^2 set s [::math::bignum::zero] ; # guess^2 backup set t [::math::bignum::zero] ; # intermediate result for {} {$i >= 0} {incr i -1; incr b -2} { ::math::bignum::setbit t $b set x [::math::bignum::rawAdd $s $t] ::math::bignum::clearbit t $b if {[::math::bignum::abscmp $x $n] <= 0} { set s $x ::math::bignum::setbit r $i ::math::bignum::setbit t [expr {$b+1}] } set t [::math::bignum::rshiftBits $t 1] } return $r } ################################## Random Number ############################### # Returns a random number in the range [0,2^n-1] proc ::math::bignum::rand bits { set atoms [expr {($bits+$::math::bignum::atombits-1)/$::math::bignum::atombits}] set shift [expr {($atoms*$::math::bignum::atombits)-$bits}] set r [list bignum 0] while {$atoms} { lappend r [expr {int(rand()*(1<<$::math::bignum::atombits))}] incr atoms -1 } set r [::math::bignum::rshiftBits $r $shift] return $r } ############################ Convertion to/from string ######################### # The string representation charset. Max base is 36 set ::math::bignum::cset "0123456789abcdefghijklmnopqrstuvwxyz" # Convert 'z' to a string representation in base 'base'. # Note that this is missing a simple but very effective optimization # that's to divide by the biggest power of the base that fits # in a Tcl plain integer, and then to perform divisions with [expr]. proc ::math::bignum::tostr {z {base 10}} { if {[string length $::math::bignum::cset] < $base} { error "base too big for string convertion" } if {[::math::bignum::iszero $z]} {return 0} set sign [::math::bignum::sign $z] set str {} while {![::math::bignum::iszero $z]} { foreach {q r} [::math::bignum::rawDivByAtom $z $base] break append str [string index $::math::bignum::cset $r] set z $q } if {$sign} {append str -} # flip the resulting string set flipstr {} set i [string length $str] incr i -1 while {$i >= 0} { append flipstr [string index $str $i] incr i -1 } return $flipstr } # Create a bignum from a string representation in base 'base'. proc ::math::bignum::fromstr {str {base 0}} { set z [::math::bignum::zero] set str [string trim $str] set sign 0 if {[string index $str 0] eq {-}} { set str [string range $str 1 end] set sign 1 } if {$base == 0} { switch -- [string tolower [string range $str 0 1]] { 0x {set base 16; set str [string range $str 2 end]} ox {set base 8 ; set str [string range $str 2 end]} bx {set base 2 ; set str [string range $str 2 end]} default {set base 10} } } if {[string length $::math::bignum::cset] < $base} { error "base too big for string convertion" } set bigbase [list bignum 0 $base] ; # Build a bignum with the base value set basepow [list bignum 0 1] ; # multiply every digit for a succ. power set i [string length $str] incr i -1 while {$i >= 0} { set digitval [string first [string index $str $i] $::math::bignum::cset] if {$digitval == -1} { error "Illegal char '[string index $str $i]' for base $base" } set bigdigitval [list bignum 0 $digitval] set z [::math::bignum::rawAdd $z [::math::bignum::mul $basepow $bigdigitval]] set basepow [::math::bignum::mul $basepow $bigbase] incr i -1 } if {![::math::bignum::iszero $z]} { ::math::bignum::setsign z $sign } return $z } # # Pre-treatment of some constants : 0 and 1 # Updated 19/11/2005 : abandon the 'upvar' command and its cost # proc ::math::bignum::_treat {num} { if {[llength $num]<2} { if {[string equal $num 0]} { # set to the bignum 0 return {bignum 0 0} } elseif {[string equal $num 1]} { # set to the bignum 1 return {bignum 0 1} } } return $num } namespace eval ::math::bignum { namespace export * } # Announce the package package provide math::bignum 3.1.1 tcllib-1.15/modules/math/roman.man0000755000175000017500000000411112077663116016452 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin math::roman "" 1.0] [copyright {2005 Kenneth Green }] [moddesc {Tcl Math Library}] [titledesc {Tools for creating and manipulating roman numerals}] [category Mathematics] [require Tcl 8.3] [require math::roman [opt 1.0]] [description] [para] [cmd ::math::roman] is a pure-Tcl library for converting between integers and roman numerals. It also provides utility functions for sorting and performing arithmetic on roman numerals. [para] This code was originally harvested from the Tcler's wiki at http://wiki.tcl.tk/1823 and as such is free for any use for any purpose. Many thanks to the ingeneous folk who devised these clever routines and generously contributed them to the Tcl community. [para] While written and tested under Tcl 8.3, I expect this library will work under all 8.x versions of Tcl. [section {COMMANDS}] [list_begin definitions] [call [cmd ::math::roman::toroman] [arg i]] Convert an integer to roman numerals. The result is always in upper case. The value zero is converted to an empty string. [call [cmd ::math::roman::tointeger] [arg r]] Convert a roman numeral into an integer. [call [cmd ::math::roman::sort] [arg list]] Sort a list of roman numerals from smallest to largest. [call [cmd ::math::roman::expr] [arg args]] Evaluate an expression where the operands are all roman numerals. [list_end] Of these commands both [emph toroman] and [emph tointeger] are exported for easier use. The other two are not, as they could interfer or be confused with existing Tcl commands. [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph {math :: roman}] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords conversion integer "roman numeral"] [manpage_end] tcllib-1.15/modules/math/bigfloat.man0000755000175000017500000003767612077663116017153 0ustar sergeisergei[manpage_begin math::bigfloat n 2.0.1] [copyright {2004-2008, by Stephane Arnold }] [moddesc {Tcl Math Library}] [titledesc {Arbitrary precision floating-point numbers}] [category Mathematics] [require Tcl 8.5] [require math::bigfloat [opt 2.0.1]] [description] The bigfloat package provides arbitrary precision floating-point math capabilities to the Tcl language. It is designed to work with Tcl 8.5, but for Tcl 8.4 is provided an earlier version of this package. See [sectref "WHAT ABOUT TCL 8.4 ?"] for more explanations. By convention, we will talk about the numbers treated in this library as : [list_begin itemized] [item]BigFloat for floating-point numbers of arbitrary length. [item]integers for arbitrary length signed integers, just as basic integers since Tcl 8.5. [list_end] Each BigFloat is an interval, namely [lb][emph "m-d, m+d"][rb], where [emph m] is the mantissa and [emph d] the uncertainty, representing the limitation of that number's precision. This is why we call such mathematics [emph "interval computations"]. Just take an example in physics : when you measure a temperature, not all digits you read are [emph significant]. Sometimes you just cannot trust all digits - not to mention if doubles (f.p. numbers) can handle all these digits. BigFloat can handle this problem - trusting the digits you get - plus the ability to store numbers with an arbitrary precision. BigFloats are internally represented at Tcl lists: this package provides a set of procedures operating against the internal representation in order to : [list_begin itemized] [item] perform math operations on BigFloats and (optionnaly) with integers. [item] convert BigFloats from their internal representations to strings, and vice versa. [list_end] [section "INTRODUCTION"] [list_begin definitions] [call [cmd fromstr] [arg number] [opt [arg trailingZeros]]] Converts [emph number] into a BigFloat. Its precision is at least the number of digits provided by [emph number]. If the [arg number] contains only digits and eventually a minus sign, it is considered as an integer. Subsequently, no conversion is done at all. [para] [arg trailingZeros] - the number of zeros to append at the end of the floating-point number to get more precision. It cannot be applied to an integer. [example_begin] # x and y are BigFloats : the first string contained a dot, and the second an e sign set x [lb]fromstr -1.000000[rb] set y [lb]fromstr 2000e30[rb] # let's see how we get integers set t 20000000000000 # the old way (package 1.2) is still supported for backwards compatibility : set m [lb]fromstr 10000000000[rb] # but we do not need fromstr for integers anymore set n -39 # t, m and n are integers [example_end] [para] The [emph number]'s last digit is considered by the procedure to be true at +/-1, For example, 1.00 is the interval [lb]0.99, 1.01[rb], and 0.43 the interval [lb]0.42, 0.44[rb]. The Pi constant may be approximated by the number "3.1415". This string could be considered as the interval [lb]3.1414 , 3.1416[rb] by [cmd fromstr]. So, when you mean 1.0 as a double, you may have to write 1.000000 to get enough precision. To learn more about this subject, see [sectref PRECISION]. [para] For example : [example_begin] set x [lb]fromstr 1.0000000000[rb] # the next line does the same, but smarter set y [lb]fromstr 1. 10[rb] [example_end] [call [cmd tostr] [opt [option -nosci]] [arg number]] Returns a string form of a BigFloat, in which all digits are exacts. [emph "All exact digits"] means a rounding may occur, for example to zero, if the uncertainty interval does not clearly show the true digits. [emph number] may be an integer, causing the command to return exactly the input argument. With the [option -nosci] option, the number returned is never shown in scientific notation, i.e. not like '3.4523e+5' but like '345230.'. [example_begin] puts [lb]tostr [lb]fromstr 0.99999[rb][rb] ;# 1.0000 puts [lb]tostr [lb]fromstr 1.00001[rb][rb] ;# 1.0000 puts [lb]tostr [lb]fromstr 0.002[rb][rb] ;# 0.e-2 [example_end] See [sectref PRECISION] for that matter. See also [cmd iszero] for how to detect zeros, which is useful when performing a division. [call [cmd fromdouble] [arg double] [opt [arg decimals]]] Converts a double (a simple floating-point value) to a BigFloat, with exactly [arg decimals] digits. Without the [arg decimals] argument, it behaves like [cmd fromstr]. Here, the only important feature you might care of is the ability to create BigFloats with a fixed number of [arg decimals]. [example_begin] tostr [lb]fromstr 1.111 4[rb] # returns : 1.111000 (3 zeros) tostr [lb]fromdouble 1.111 4[rb] # returns : 1.111 [example_end] [call [cmd todouble] [arg number]] Returns a double, that may be used in [emph expr], from a BigFloat. [call [cmd isInt] [arg number]] Returns 1 if [emph number] is an integer, 0 otherwise. [call [cmd isFloat] [arg number]] Returns 1 if [emph number] is a BigFloat, 0 otherwise. [call [cmd int2float] [arg integer] [opt [arg decimals]]] Converts an integer to a BigFloat with [emph decimals] trailing zeros. The default, and minimal, number of [emph decimals] is 1. When converting back to string, one decimal is lost: [example_begin] set n 10 set x [lb]int2float $n[rb]; # like fromstr 10.0 puts [lb]tostr $x[rb]; # prints "10." set x [lb]int2float $n 3[rb]; # like fromstr 10.000 puts [lb]tostr $x[rb]; # prints "10.00" [example_end] [list_end] [section "ARITHMETICS"] [list_begin definitions] [call [cmd add] [arg x] [arg y]] [call [cmd sub] [arg x] [arg y]] [call [cmd mul] [arg x] [arg y]] Return the sum, difference and product of [emph x] by [emph y]. [arg x] - may be either a BigFloat or an integer [arg y] - may be either a BigFloat or an integer When both are integers, these commands behave like [cmd expr]. [call [cmd div] [arg x] [arg y]] [call [cmd mod] [arg x] [arg y]] Return the quotient and the rest of [emph x] divided by [emph y]. Each argument ([emph x] and [emph y]) can be either a BigFloat or an integer, but you cannot divide an integer by a BigFloat Divide by zero throws an error. [call [cmd abs] [arg x]] Returns the absolute value of [emph x] [call [cmd opp] [arg x]] Returns the opposite of [emph x] [call [cmd pow] [arg x] [arg n]] Returns [emph x] taken to the [emph n]th power. It only works if [emph n] is an integer. [emph x] might be a BigFloat or an integer. [list_end] [section COMPARISONS] [list_begin definitions] [call [cmd iszero] [arg x]] Returns 1 if [emph x] is : [list_begin itemized] [item]a BigFloat close enough to zero to raise "divide by zero". [item]the integer 0. [list_end] See here how numbers that are close to zero are converted to strings: [example_begin] tostr [lb]fromstr 0.001[rb] ; # -> 0.e-2 tostr [lb]fromstr 0.000000[rb] ; # -> 0.e-5 tostr [lb]fromstr -0.000001[rb] ; # -> 0.e-5 tostr [lb]fromstr 0.0[rb] ; # -> 0. tostr [lb]fromstr 0.002[rb] ; # -> 0.e-2 set a [lb]fromstr 0.002[rb] ; # uncertainty interval : 0.001, 0.003 tostr $a ; # 0.e-2 iszero $a ; # false set a [lb]fromstr 0.001[rb] ; # uncertainty interval : 0.000, 0.002 tostr $a ; # 0.e-2 iszero $a ; # true [example_end] [call [cmd equal] [arg x] [arg y]] Returns 1 if [emph x] and [emph y] are equal, 0 elsewhere. [call [cmd compare] [arg x] [arg y]] Returns 0 if both BigFloat arguments are equal, 1 if [emph x] is greater than [emph y], and -1 if [emph x] is lower than [emph y]. You would not be able to compare an integer to a BigFloat : the operands should be both BigFloats, or both integers. [list_end] [section ANALYSIS] [list_begin definitions] [call [cmd sqrt] [arg x]] [call [cmd log] [arg x]] [call [cmd exp] [arg x]] [call [cmd cos] [arg x]] [call [cmd sin] [arg x]] [call [cmd tan] [arg x]] [call [cmd cotan] [arg x]] [call [cmd acos] [arg x]] [call [cmd asin] [arg x]] [call [cmd atan] [arg x]] [call [cmd cosh] [arg x]] [call [cmd sinh] [arg x]] [call [cmd tanh] [arg x]] The above functions return, respectively, the following : square root, logarithm, exponential, cosine, sine, tangent, cotangent, arc cosine, arc sine, arc tangent, hyperbolic cosine, hyperbolic sine, hyperbolic tangent, of a BigFloat named [emph x]. [call [cmd pi] [arg n]] Returns a BigFloat representing the Pi constant with [emph n] digits after the dot. [emph n] is a positive integer. [call [cmd rad2deg] [arg radians]] [call [cmd deg2rad] [arg degrees]] [arg radians] - angle expressed in radians (BigFloat) [para] [arg degrees] - angle expressed in degrees (BigFloat) [para] Convert an angle from radians to degrees, and [emph "vice versa"]. [list_end] [section ROUNDING] [list_begin definitions] [call [cmd round] [arg x]] [call [cmd ceil] [arg x]] [call [cmd floor] [arg x]] The above functions return the [emph x] BigFloat, rounded like with the same mathematical function in [emph expr], and returns it as an integer. [list_end] [section PRECISION] How do conversions work with precision ? [list_begin itemized] [item] When a BigFloat is converted from string, the internal representation holds its uncertainty as 1 at the level of the last digit. [item] During computations, the uncertainty of each result is internally computed the closest to the reality, thus saving the memory used. [item] When converting back to string, the digits that are printed are not subject to uncertainty. However, some rounding is done, as not doing so causes severe problems. [list_end] Uncertainties are kept in the internal representation of the number ; it is recommended to use [cmd tostr] only for outputting data (on the screen or in a file), and NEVER call [cmd fromstr] with the result of [cmd tostr]. It is better to always keep operands in their internal representation. Due to the internals of this library, the uncertainty interval may be slightly wider than expected, but this should not cause false digits. [para] Now you may ask this question : What precision am I going to get after calling add, sub, mul or div? First you set a number from the string representation and, by the way, its uncertainty is set: [example_begin] set a [lb]fromstr 1.230[rb] # $a belongs to [lb]1.229, 1.231[rb] set a [lb]fromstr 1.000[rb] # $a belongs to [lb]0.999, 1.001[rb] # $a has a relative uncertainty of 0.1% : 0.001(the uncertainty)/1.000(the medium value) [example_end] The uncertainty of the sum, or the difference, of two numbers, is the sum of their respective uncertainties. [example_begin] set a [lb]fromstr 1.230[rb] set b [lb]fromstr 2.340[rb] set sum [lb]add $a $b[rb][rb] # the result is : [lb]3.568, 3.572[rb] (the last digit is known with an uncertainty of 2) tostr $sum ; # 3.57 [example_end] But when, for example, we add or substract an integer to a BigFloat, the relative uncertainty of the result is unchanged. So it is desirable not to convert integers to BigFloats: [example_begin] set a [lb]fromstr 0.999999999[rb] # now something dangerous set b [lb]fromstr 2.000[rb] # the result has only 3 digits tostr [lb]add $a $b[rb] # how to keep precision at its maximum puts [lb]tostr [lb]add $a 2[rb][rb] [example_end] [para] For multiplication and division, the relative uncertainties of the product or the quotient, is the sum of the relative uncertainties of the operands. Take care of division by zero : check each divider with [cmd iszero]. [example_begin] set num [lb]fromstr 4.00[rb] set denom [lb]fromstr 0.01[rb] puts [lb]iszero $denom[rb];# true set quotient [lb]div $num $denom[rb];# error : divide by zero # opposites of our operands puts [lb]compare $num [lb]opp $num[rb][rb]; # 1 puts [lb]compare $denom [lb]opp $denom[rb][rb]; # 0 !!! # No suprise ! 0 and its opposite are the same... [example_end] Effects of the precision of a number considered equal to zero to the cos function: [example_begin] puts [lb]tostr [lb]cos [lb]fromstr 0. 10[rb][rb][rb]; # -> 1.000000000 puts [lb]tostr [lb]cos [lb]fromstr 0. 5[rb][rb][rb]; # -> 1.0000 puts [lb]tostr [lb]cos [lb]fromstr 0e-10[rb][rb][rb]; # -> 1.000000000 puts [lb]tostr [lb]cos [lb]fromstr 1e-10[rb][rb][rb]; # -> 1.000000000 [example_end] BigFloats with different internal representations may be converted to the same string. [para] For most analysis functions (cosine, square root, logarithm, etc.), determining the precision of the result is difficult. It seems however that in many cases, the loss of precision in the result is of one or two digits. There are some exceptions : for example, [example_begin] tostr [lb]exp [lb]fromstr 100.0 10[rb][rb] # returns : 2.688117142e+43 which has only 10 digits of precision, although the entry # has 14 digits of precision. [example_end] [section "WHAT ABOUT TCL 8.4 ?"] If your setup do not provide Tcl 8.5 but supports 8.4, the package can still be loaded, switching back to [emph math::bigfloat] 1.2. Indeed, an important function introduced in Tcl 8.5 is required - the ability to handle bignums, that we can do with [cmd expr]. Before 8.5, this ability was provided by several packages, including the pure-Tcl [emph math::bignum] package provided by [emph tcllib]. In this case, all you need to know, is that arguments to the commands explained here, are expected to be in their internal representation. So even with integers, you will need to call [cmd fromstr] and [cmd tostr] in order to convert them between string and internal representations. [example_begin] # # with Tcl 8.5 # ============ set a [lb]pi 20[rb] # round returns an integer and 'everything is a string' applies to integers # whatever big they are puts [lb]round [lb]mul $a 10000000000[rb][rb] # # the same with Tcl 8.4 # ===================== set a [lb]pi 20[rb] # bignums (arbitrary length integers) need a conversion hook set b [lb]fromstr 10000000000[rb] # round returns a bignum: # before printing it, we need to convert it with 'tostr' puts [lb]tostr [lb]round [lb]mul $a $b[rb][rb][rb] [example_end] [section "NAMESPACES AND OTHER PACKAGES"] We have not yet discussed about namespaces because we assumed that you had imported public commands into the global namespace, like this: [example_begin] namespace import ::math::bigfloat::* [example_end] If you matter much about avoiding names conflicts, I considere it should be resolved by the following : [example_begin] package require math::bigfloat # beware: namespace ensembles are not available in Tcl 8.4 namespace eval ::math::bigfloat {namespace ensemble create -command ::bigfloat} # from now, the bigfloat command takes as subcommands all original math::bigfloat::* commands set a [lb]bigfloat sub [lb]bigfloat fromstr 2.000[rb] [lb]bigfloat fromstr 0.530[rb][rb] puts [lb]bigfloat tostr $a[rb] [example_end] [section "EXAMPLES"] Guess what happens when you are doing some astronomy. Here is an example : [example_begin] # convert acurrate angles with a millisecond-rated accuracy proc degree-angle {degrees minutes seconds milliseconds} { set result 0 set div 1 foreach factor {1 1000 60 60} var [lb]list $milliseconds $seconds $minutes $degrees[rb] { # we convert each entry var into milliseconds set div [lb]expr {$div*$factor}[rb] incr result [lb]expr {$var*$div}[rb] } return [lb]div [lb]int2float $result[rb] $div[rb] } # load the package package require math::bigfloat namespace import ::math::bigfloat::* # work with angles : a standard formula for navigation (taking bearings) set angle1 [lb]deg2rad [lb]degree-angle 20 30 40 0[rb][rb] set angle2 [lb]deg2rad [lb]degree-angle 21 0 50 500[rb][rb] set opposite3 [lb]deg2rad [lb]degree-angle 51 0 50 500[rb][rb] set sinProduct [lb]mul [lb]sin $angle1[rb] [lb]sin $angle2[rb][rb] set cosProduct [lb]mul [lb]cos $angle1[rb] [lb]cos $angle2[rb][rb] set angle3 [lb]asin [lb]add [lb]mul $sinProduct [lb]cos $opposite3[rb][rb] $cosProduct[rb][rb] puts "angle3 : [lb]tostr [lb]rad2deg $angle3[rb][rb]" [example_end] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph {math :: bignum :: float}] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords tcl multiprecision math floating-point interval computations] [manpage_end] tcllib-1.15/modules/math/classic_polyns.tcl0000755000175000017500000001142712077663116020402 0ustar sergeisergei# classic_polyns.tcl -- # Implement procedures for the classic orthogonal polynomials # package require math::polynomials namespace eval ::math::special { if {[info commands addPolyn] == {} } { namespace import ::math::polynomials::* } } # legendre -- # Return the nth degree Legendre polynomial # # Arguments: # n The degree of the polynomial # Result: # Polynomial definition # proc ::math::special::legendre {n} { if { ! [string is integer -strict $n] || $n < 0 } { return -code error "Degree must be a non-negative integer" } set pnm1 [polynomial 1.0] set pn [polynomial {0.0 1.0}] if { $n == 0 } {return $pnm1} if { $n == 1 } {return $pn} set degree 1 while { $degree < $n } { set an [expr {(2.0*$degree+1.0)/($degree+1.0)}] set bn 0.0 set cn [expr {$degree/($degree+1.0)}] set factor_n [polynomial [list $bn $an]] set term_nm1 [multPolyn $pnm1 [expr {-1.0*$cn}]] set term_n [multPolyn $factor_n $pn] set pnp1 [addPolyn $term_n $term_nm1] set pnm1 $pn set pn $pnp1 incr degree } return $pnp1 } # chebyshev -- # Return the nth degree Chebeyshev polynomial of the first kind # # Arguments: # n The degree of the polynomial # Result: # Polynomial definition # proc ::math::special::chebyshev {n} { if { ! [string is integer -strict $n] || $n < 0 } { return -code error "Degree must be a non-negative integer" } set pnm1 [polynomial 1.0] set pn [polynomial {0.0 1.0}] if { $n == 0 } {return $pnm1} if { $n == 1 } {return $pn} set degree 1 while { $degree < $n } { set an 2.0 set bn 0.0 set cn 1.0 set factor_n [polynomial [list $bn $an]] set term_nm1 [multPolyn $pnm1 [expr {-1.0*$cn}]] set term_n [multPolyn $factor_n $pn] set pnp1 [addPolyn $term_n $term_nm1] set pnm1 $pn set pn $pnp1 incr degree } return $pnp1 } # laguerre -- # Return the nth degree Laguerre polynomial with parameter alpha # # Arguments: # alpha The parameter for the polynomial # n The degree of the polynomial # Result: # Polynomial definition # proc ::math::special::laguerre {alpha n} { if { ! [string is double -strict $alpha] } { return -code error "Parameter must be a double" } if { ! [string is integer -strict $n] || $n < 0 } { return -code error "Degree must be a non-negative integer" } set pnm1 [polynomial 1.0] set pn [polynomial [list [expr {1.0-$alpha}] -1.0]] if { $n == 0 } {return $pnm1} if { $n == 1 } {return $pn} set degree 1 while { $degree < $n } { set an [expr {-1.0/($degree+1.0)}] set bn [expr {(2.0*$degree+$alpha+1)/($degree+1.0)}] set cn [expr {($degree+$alpha)/($degree+1.0)}] set factor_n [polynomial [list $bn $an]] set term_nm1 [multPolyn $pnm1 [expr {-1.0*$cn}]] set term_n [multPolyn $factor_n $pn] set pnp1 [addPolyn $term_n $term_nm1] set pnm1 $pn set pn $pnp1 incr degree } return $pnp1 } # hermite -- # Return the nth degree Hermite polynomial # # Arguments: # n The degree of the polynomial # Result: # Polynomial definition # proc ::math::special::hermite {n} { if { ! [string is integer -strict $n] || $n < 0 } { return -code error "Degree must be a non-negative integer" } set pnm1 [polynomial 1.0] set pn [polynomial {0.0 2.0}] if { $n == 0 } {return $pnm1} if { $n == 1 } {return $pn} set degree 1 while { $degree < $n } { set an 2.0 set bn 0.0 set cn [expr {2.0*$degree}] set factor_n [polynomial [list $bn $an]] set term_n [multPolyn $factor_n $pn] set term_nm1 [multPolyn $pnm1 [expr {-1.0*$cn}]] set pnp1 [addPolyn $term_n $term_nm1] set pnm1 $pn set pn $pnp1 incr degree } return $pnp1 } # some tests -- # if { 0 } { set prec $::tcl_precision if {![package vsatisfies [package provide Tcl] 8.5]} { set ::tcl_precision 17 } else { set ::tcl_precision 0 } puts "Legendre:" foreach n {0 1 2 3 4} { puts [::math::special::legendre $n] } puts "Chebyshev:" foreach n {0 1 2 3 4} { puts [::math::special::chebyshev $n] } puts "Laguerre (alpha=0):" foreach n {0 1 2 3 4} { puts [::math::special::laguerre 0.0 $n] } puts "Laguerre (alpha=1):" foreach n {0 1 2 3 4} { puts [::math::special::laguerre 1.0 $n] } puts "Hermite:" foreach n {0 1 2 3 4} { puts [::math::special::hermite $n] } set ::tcl_precision $prec } tcllib-1.15/modules/math/combinatorics.man0000644000175000017500000000551512077663116020200 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin math::combinatorics n 1.2.3] [moddesc {Tcl Math Library}] [titledesc {Combinatorial functions in the Tcl Math Library}] [category Mathematics] [require Tcl 8.2] [require math [opt 1.2.3]] [description] [para] The [package math] package contains implementations of several functions useful in combinatorial problems. [section COMMANDS] [list_begin definitions] [call [cmd ::math::ln_Gamma] [arg z]] Returns the natural logarithm of the Gamma function for the argument [arg z]. [para] The Gamma function is defined as the improper integral from zero to positive infinity of [example { t**(x-1)*exp(-t) dt }] [para] The approximation used in the Tcl Math Library is from Lanczos, [emph {ISIAM J. Numerical Analysis, series B,}] volume 1, p. 86. For "[var x] > 1", the absolute error of the result is claimed to be smaller than 5.5*10**-10 -- that is, the resulting value of Gamma when [example { exp( ln_Gamma( x) ) }] is computed is expected to be precise to better than nine significant figures. [call [cmd ::math::factorial] [arg x]] Returns the factorial of the argument [arg x]. [para] For integer [arg x], 0 <= [arg x] <= 12, an exact integer result is returned. [para] For integer [arg x], 13 <= [arg x] <= 21, an exact floating-point result is returned on machines with IEEE floating point. [para] For integer [arg x], 22 <= [arg x] <= 170, the result is exact to 1 ULP. [para] For real [arg x], [arg x] >= 0, the result is approximated by computing [term Gamma(x+1)] using the [cmd ::math::ln_Gamma] function, and the result is expected to be precise to better than nine significant figures. [para] It is an error to present [arg x] <= -1 or [arg x] > 170, or a value of [arg x] that is not numeric. [call [cmd ::math::choose] [arg {n k}]] Returns the binomial coefficient [term {C(n, k)}] [example { C(n,k) = n! / k! (n-k)! }] If both parameters are integers and the result fits in 32 bits, the result is rounded to an integer. [para] Integer results are exact up to at least [arg n] = 34. Floating point results are precise to better than nine significant figures. [call [cmd ::math::Beta] [arg {z w}]] Returns the Beta function of the parameters [arg z] and [arg w]. [example { Beta(z,w) = Beta(w,z) = Gamma(z) * Gamma(w) / Gamma(z+w) }] Results are returned as a floating point number precise to better than nine significant digits provided that [arg w] and [arg z] are both at least 1. [list_end] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph math] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [manpage_end] tcllib-1.15/modules/math/math_geometry.man0000644000175000017500000003136712077663116020214 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin math::geometry n 1.1.2] [copyright {2001 by Ideogramic ApS and other parties}] [copyright {2004 by Arjen Markus}] [copyright {2010 by Andreas Kupries}] [copyright {2010 by Kevin Kenny}] [moddesc {Tcl Math Library}] [titledesc {Geometrical computations}] [category Mathematics] [require Tcl [opt 8.3]] [require math::geometry [opt 1.1.2]] [description] [para] The [package math::geometry] package is a collection of functions for computations and manipulations on two-dimensional geometrical objects, such as points, lines and polygons. [para] The geometrical objects are implemented as plain lists of coordinates. For instance a line is defined by a list of four numbers, the x- and y-coordinate of a first point and the x- and y-coordinates of a second point on the line. [para] The various types of object are recognised by the number of coordinate pairs and the context in which they are used: a list of four elements can be regarded as an infinite line, a finite line segment but also as a polyline of one segment and a point set of two points. [para] Currently the following types of objects are distinguished: [list_begin itemized] [item] [emph point] - a list of two coordinates representing the x- and y-coordinates respectively. [item] [emph line] - a list of four coordinates, interpreted as the x- and y-coordinates of two distinct points on the line. [item] [emph "line segment"] - a list of four coordinates, interpreted as the x- and y-coordinates of the first and the last points on the line segment. [item] [emph "polyline"] - a list of an even number of coordinates, interpreted as the x- and y-coordinates of an ordered set of points. [item] [emph "polygon"] - like a polyline, but the implicit assumption is that the polyline is closed (if the first and last points do not coincide, the missing segment is automatically added). [item] [emph "point set"] - again a list of an even number of coordinates, but the points are regarded without any ordering. [list_end] [section "PROCEDURES"] The package defines the following public procedures: [list_begin definitions] [call [cmd ::math::geometry::+] [arg point1] [arg point2]] Compute the sum of the two vectors given as points and return it. The result is a vector as well. [call [cmd ::math::geometry::-] [arg point1] [arg point2]] Compute the difference (point1 - point2) of the two vectors given as points and return it. The result is a vector as well. [call [cmd ::math::geometry::p] [arg x] [arg y]] Construct a point from its coordinates and return it as the result of the command. [call [cmd ::math::geometry::distance] [arg point1] [arg point2]] Compute the distance between the two points and return it as the result of the command. This is in essence the same as [example { math::geometry::length [math::geomtry::- point1 point2] }] [call [cmd ::math::geometry::length] [arg point]] Compute the length of the vector and return it as the result of the command. [call [cmd ::math::geometry::s*] [arg factor] [arg point]] Scale the vector by the factor and return it as the result of the command. This is a vector as well. [call [cmd ::math::geometry::direction] [arg angle]] Given the angle in degrees this command computes and returns the unit vector pointing into this direction. The vector for angle == 0 points to the right (up), and for angle == 90 up (north). [call [cmd ::math::geometry::h] [arg length]] Returns a horizontal vector on the X-axis of the specified length. Positive lengths point to the right (east). [call [cmd ::math::geometry::v] [arg length]] Returns a vertical vector on the Y-axis of the specified length. Positive lengths point down (south). [call [cmd ::math::geometry::between] [arg point1] [arg point2] [arg s]] Compute the point which is at relative distance [arg s] between the two points and return it as the result of the command. A relative distance of [const 0] returns [arg point1], the distance [const 1] returns [arg point2]. Distances < 0 or > 1 extrapolate along the line between the two point. [call [cmd ::math::geometry::octant] [arg point]] Compute the octant of the circle the point is in and return it as the result of the command. The possible results are [list_begin enum] [enum] east [enum] northeast [enum] north [enum] northwest [enum] west [enum] southwest [enum] south [enum] southeast [list_end] Each octant is the arc of the circle +/- 22.5 degrees from the cardinal direction the octant is named for. [call [cmd ::math::geometry::rect] [arg nw] [arg se]] Construct a rectangle from its northwest and southeast corners and return it as the result of the command. [call [cmd ::math::geometry::nwse] [arg rect]] Extract the northwest and southeast corners of the rectangle and return them as the result of the command (a 2-element list containing the points, in the named order). [call [cmd ::math::geometry::angle] [arg line]] Calculate the angle from the positive x-axis to a given line (in two dimensions only). [list_begin arguments] [arg_def list line] Coordinates of the line [list_end] [para] [call [cmd ::math::geometry::calculateDistanceToLine] [arg P] [arg line]] Calculate the distance of point P to the (infinite) line and return the result [list_begin arguments] [arg_def list P] List of two numbers, the coordinates of the point [arg_def list line] List of four numbers, the coordinates of two points on the line [list_end] [para] [call [cmd ::math::geometry::calculateDistanceToLineSegment] [arg P] [arg linesegment]] Calculate the distance of point P to the (finite) line segment and return the result. [list_begin arguments] [arg_def list P] List of two numbers, the coordinates of the point [arg_def list linesegment] List of four numbers, the coordinates of the first and last points of the line segment [list_end] [para] [para] [call [cmd ::math::geometry::calculateDistanceToPolyline] [arg P] [arg polyline]] Calculate the distance of point P to the polyline and return the result. [list_begin arguments] [arg_def list P] List of two numbers, the coordinates of the point [arg_def list polyline] List of numbers, the coordinates of the vertices of the polyline [list_end] [para] [call [cmd ::math::geometry::findClosestPointOnLine] [arg P] [arg line]] Return the point on a line which is closest to a given point. [list_begin arguments] [arg_def list P] List of two numbers, the coordinates of the point [arg_def list line] List of four numbers, the coordinates of two points on the line [list_end] [para] [call [cmd ::math::geometry::findClosestPointOnLineSegment] [arg P] [arg linesegment]] Return the point on a [emph "line segment"] which is closest to a given point. [list_begin arguments] [arg_def list P] List of two numbers, the coordinates of the point [arg_def list linesegment] List of four numbers, the first and last points on the line segment [list_end] [para] [call [cmd ::math::geometry::findClosestPointOnPolyline] [arg P] [arg polyline]] Return the point on a [emph "polyline"] which is closest to a given point. [list_begin arguments] [arg_def list P] List of two numbers, the coordinates of the point [arg_def list polyline] List of numbers, the vertices of the polyline [list_end] [para] [call [cmd ::math::geometry::lengthOfPolyline] [arg polyline]] Return the length of the [emph "polyline"] (note: it not regarded as a polygon) [list_begin arguments] [arg_def list polyline] List of numbers, the vertices of the polyline [list_end] [para] [call [cmd ::math::geometry::movePointInDirection] [arg P] [arg direction] [arg dist]] Move a point over a given distance in a given direction and return the new coordinates (in two dimensions only). [list_begin arguments] [arg_def list P] Coordinates of the point to be moved [arg_def double direction] Direction (in degrees; 0 is to the right, 90 upwards) [arg_def list dist] Distance over which to move the point [list_end] [para] [call [cmd ::math::geometry::lineSegmentsIntersect] [arg linesegment1] [arg linesegment2]] Check if two line segments intersect or coincide. Returns 1 if that is the case, 0 otherwise (in two dimensions only). [list_begin arguments] [arg_def list linesegment1] First line segment [arg_def list linesegment2] Second line segment [list_end] [para] [call [cmd ::math::geometry::findLineSegmentIntersection] [arg linesegment1] [arg linesegment2]] Find the intersection point of two line segments. Return the coordinates or the keywords "coincident" or "none" if the line segments coincide or have no points in common (in two dimensions only). [list_begin arguments] [arg_def list linesegment1] First line segment [arg_def list linesegment2] Second line segment [list_end] [para] [call [cmd ::math::geometry::findLineIntersection] [arg line1] [arg line2]] Find the intersection point of two (infinite) lines. Return the coordinates or the keywords "coincident" or "none" if the lines coincide or have no points in common (in two dimensions only). [list_begin arguments] [arg_def list line1] First line [arg_def list line2] Second line [list_end] See section [sectref References] for details on the algorithm and math behind it. [para] [call [cmd ::math::geometry::polylinesIntersect] [arg polyline1] [arg polyline2]] Check if two polylines intersect or not (in two dimensions only). [list_begin arguments] [arg_def list polyline1] First polyline [arg_def list polyline2] Second polyline [list_end] [para] [call [cmd ::math::geometry::polylinesBoundingIntersect] [arg polyline1] [arg polyline2] [arg granularity]] Check whether two polylines intersect, but reduce the correctness of the result to the given granularity. Use this for faster, but weaker, intersection checking. [para] How it works: [para] Each polyline is split into a number of smaller polylines, consisting of granularity points each. If a pair of those smaller lines' bounding boxes intersect, then this procedure returns 1, otherwise it returns 0. [list_begin arguments] [arg_def list polyline1] First polyline [arg_def list polyline2] Second polyline [arg_def int granularity] Number of points in each part (<=1 means check every edge) [list_end] [para] [call [cmd ::math::geometry::intervalsOverlap] [arg y1] [arg y2] [arg y3] [arg y4] [arg strict]] Check if two intervals overlap. [list_begin arguments] [arg_def double y1,y2] Begin and end of first interval [arg_def double y3,y4] Begin and end of second interval [arg_def logical strict] Check for strict or non-strict overlap [list_end] [para] [call [cmd ::math::geometry::rectanglesOverlap] [arg P1] [arg P2] [arg Q1] [arg Q2] [arg strict]] Check if two rectangles overlap. [list_begin arguments] [arg_def list P1] upper-left corner of the first rectangle [arg_def list P2] lower-right corner of the first rectangle [arg_def list Q1] upper-left corner of the second rectangle [arg_def list Q2] lower-right corner of the second rectangle [arg_def list strict] choosing strict or non-strict interpretation [list_end] [para] [call [cmd ::math::geometry::bbox] [arg polyline]] Calculate the bounding box of a polyline. Returns a list of four coordinates: the upper-left and the lower-right corner of the box. [list_begin arguments] [arg_def list polyline] The polyline to be examined [list_end] [para] [call [cmd ::math::geometry::pointInsidePolygon] [arg P] [arg polyline]] Determine if a point is completely inside a polygon. If the point touches the polygon, then the point is not completely inside the polygon. [list_begin arguments] [arg_def list P] Coordinates of the point [arg_def list polyline] The polyline to be examined [list_end] [para] [call [cmd ::math::geometry::rectangleInsidePolygon] [arg P1] [arg P2] [arg polyline]] Determine if a rectangle is completely inside a polygon. If polygon touches the rectangle, then the rectangle is not complete inside the polygon. [list_begin arguments] [arg_def list P1] Upper-left corner of the rectangle [arg_def list P2] Lower-right corner of the rectangle [para] [arg_def list polygon] The polygon in question [list_end] [para] [call [cmd ::math::geometry::areaPolygon] [arg polygon]] Calculate the area of a polygon. [list_begin arguments] [arg_def list polygon] The polygon in question [list_end] [list_end] [section References] [list_begin enumerated] [enum] [uri http:/wiki.tcl.tk/12070 {Polygon Intersection}] [enum] [uri http://en.wikipedia.org/wiki/Line-line_intersection] [enum] [uri http://local.wasp.uwa.edu.au/~pbourke/geometry/lineline2d/] [list_end] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph {math :: geometry}] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords math "plane geometry" "point" "line" "distance" "angle"] [manpage_end] tcllib-1.15/modules/math/statistics.test0000755000175000017500000005324012077663116017743 0ustar sergeisergei# -*- tcl -*- # statistics.test -- # Test cases for the ::math::statistics package # # Note: # The tests assume tcltest 2.1, in order to compare # floating-point results # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.4;# statistics,linalg! testsNeedTcltest 2.1 support { useLocal math.tcl math useLocal linalg.tcl math::linearalgebra } testing { useLocal statistics.tcl math::statistics } # ------------------------------------------------------------------------- set ::data_uniform [list 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0] set ::data_missing [list 1.0 1.0 1.0 {} 1.0 {} {} 1.0 1.0 1.0 1.0 1.0 1.0] set ::data_linear [list 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 10.0] set ::data_empty [list {} {} {}] set ::data_missing2 [list 1.0 2.0 3.0 {} 4.0 5.0 6.0 7.0 8.0 9.0 10.0] # # Create and register (in that order!) custom matching procedures # proc matchTolerant { expected actual } { set match 1 foreach a $actual e $expected { if { abs($e-$a)>0.0001*abs($e) && abs($e-$a)>0.0001*abs($a) } { set match 0 break } } return $match } proc matchTolerant2 { expected actual } { set match 1 foreach a $actual e $expected { if { abs($e-$a)>0.025*abs($e) && abs($e-$a)>0.025*abs($a) } { set match 0 break } } return $match } proc matchAlmostZero { expected actual } { set match 1 foreach a $actual { if { abs($a)>1.0e-6 } { set match 0 break } } return $match } customMatch tolerant matchTolerant customMatch tolerant2 matchTolerant2 customMatch almostzero matchAlmostZero # # Test cases # test "BasicStats-1.0" "Basic statistics - uniform data" -match tolerant -body { set all_data [::math::statistics::BasicStats all $::data_uniform] } -result [list 1.0 1.0 1.0 [llength $::data_uniform] 0.0 0.0 0.0 0.0] test "BasicStats-1.1" "Basic statistics - empty data" -match glob -body { catch { set all_data [::math::statistics::BasicStats all $::data_empty] } msg set msg } -result "Too*" # # Result must be the same as for 1.0! Hence ::data_empty and ::data_uniform # test "BasicStats-1.2" "Basic statistics - missing data" -match tolerant -body { set all_data [::math::statistics::BasicStats all $::data_missing] } -result [list 1.0 1.0 1.0 [llength $::data_uniform] 0.0 0.0 0.0 0.0] test "BasicStats-1.3" "Basic statistics - linear data - mean" -match tolerant -body { set value [::math::statistics::mean $::data_linear] } -result 5.5 test "BasicStats-1.4" "Basic statistics - linear data - min" -match tolerant -body { set value [::math::statistics::min $::data_linear] } -result 1.0 test "BasicStats-1.5" "Basic statistics - linear data - max" -match tolerant -body { set value [::math::statistics::max $::data_linear] } -result 10.0 test "BasicStats-1.6" "Basic statistics - linear data - number" -match tolerant -body { set value [::math::statistics::number $::data_linear] } -result 10 test "BasicStats-1.7" "Basic statistics - missing data - number" -match tolerant -body { set value [::math::statistics::number $::data_missing2] } -result 10 test "BasicStats-1.8" "Basic statistics - missing data - stdev" -match almostzero -body { set value1 [::math::statistics::stdev $::data_linear] set value2 [::math::statistics::stdev $::data_missing2] expr {abs($value1-$value2)} } -result 0.001 ;# Zero is impossible test "BasicStats-1.9" "Basic statistics - missing data - var" -match almostzero -body { set value1 [::math::statistics::stdev $::data_linear] set value2 [::math::statistics::var $::data_missing2] expr {$value1*$value1-$value2} } -result 0.001 ;# Zero is impossible test "BasicStats-1.10" "Basic statistics - missing data - pstdev" -match almostzero -body { set value1 [::math::statistics::pstdev $::data_linear] set value2 [::math::statistics::pstdev $::data_missing2] expr {abs($value1-$value2)} } -result 0.001 ;# Zero is impossible test "BasicStats-1.11" "Basic statistics - missing data - pvar" -match almostzero -body { set value1 [::math::statistics::pstdev $::data_linear] set value2 [::math::statistics::pvar $::data_missing2] expr {$value1*$value1-$value2} } -result 0.001 ;# Zero is impossible # # This test was added because the calculation of the standard deviation # could fail with uniform data (the difference of two almost equal # values became a small negative number) # # Further extension: more stable computation if the values are very # close together. Due to this change the variance should be independent # of the mean, however large (up to a point) # test "BasicStats-2.1" "Basic statistics - uniform data caused sqrt domain error" -body { set values [list] set count 0 for { set i 0 } { $i < 20 } { incr i } { lappend values 0.6 set value2 [::math::statistics::mean $values] incr count } set count } -result 20 ;# We can finish the loop test "BasicStats-2.2" "Basic statistics - large almost identical values" -match glob -body { catch { set data [list 100001 100002 100003 100004] set result_large [::math::statistics::BasicStats all $data] set data [list 1 2 3 4] set result_small [::math::statistics::BasicStats all $data] matchTolerant [lrange $result_small 3 end] [lrange $result_large 3 end] } msg set msg } -result 1 # # Histograms # test "Histogram-1.0" "Histogram - uniform data" -match glob -body { set values [::math::statistics::histogram {0 2} $::data_uniform] } -result [list 0 [llength $::data_uniform] 0] test "Histogram-1.1" "Histogram - missing data" -match glob -body { set values [::math::statistics::histogram {0 2} $::data_missing] } -result [list 0 [::math::statistics::number $::data_missing] 0] test "Histogram-1.2" "Histogram - linear data" -match glob -body { set values [::math::statistics::histogram {1.5 4.5 9.5} $::data_linear] } -result {1 3 5 1} test "Histogram-1.3" "Histogram - linear data 2" -match glob -body { set values [::math::statistics::histogram {1.5 2.5 10.5} $::data_linear] } -result {1 1 8 0} # # Quantiles # Bug #1272910: related to rounding 0.5 - use different levels instead # because another bug was fixed, return to the original # levels again # test "Quantiles-1.0" "Quantiles - raw data" -match tolerant -body { set values [::math::statistics::quantiles $::data_linear {0.25 0.55 0.95}] } -result {3.0 6.0 10.0} test "Quantiles-1.1" "Quantiles - histogram" -match tolerant -body { set limits {1.0 2.0 3.0 4.0} set data_hist {0 10 20 10 0} set values [::math::statistics::quantiles $limits $data_hist {0.25 0.5 0.9}] } -result {2.0 2.5 3.6} # # Generate histogram limits # test "Limits-1.0" "Limits - based on mean/stdev" -match tolerant -body { set values [::math::statistics::mean-histogram-limits 1.0 1.0 4] } -result {0.0 0.75 1.25 2.0} test "Limits-1.1" "Limits - based on mean/stdev" -match tolerant -body { set values [::math::statistics::mean-histogram-limits 1.0 1.0 9] } -result {-2.0 -1.0 0.0 0.75 1.0 1.25 2.0 3.0 4.0} test "Limits-1.2" "Limits - based on mean/stdev" -match tolerant -body { set values [::math::statistics::mean-histogram-limits 0.0 1.0 11] } -result {-3.0 -2.4 -1.8 -1.2 -0.6 0.0 0.6 1.2 1.8 2.4 3.0} test "Limits-2.0" "Limits - based on min/max" -match tolerant -body { set values [::math::statistics::minmax-histogram-limits -2.0 2.0 9] } -result {-2.0 -1.5 -1.0 -0.5 0.0 0.5 1.0 1.5 2.0} test "Limits-2.1" "Limits - based on min/max" -match tolerant -body { set values [::math::statistics::minmax-histogram-limits -2.0 2.0 2] } -result {-2.0 2.0} # # To do: design test cases for the following functions: # - t-test-mean # - estimate-mean-stdev # - autocorr # - crosscorr # - linear-model # - linear-residuals # - pdf-* # - cdf-* # - random-* # - histogram-* # # Crude test cases for Student's t test # test "Students-t-test-1.0" "Student's t - same sample" -match glob -body { set sample [::math::statistics::random-normal 0.0 1.0 40] set mean 0.0 set stdev 1.0 set confidence 0.95 set result [::math::statistics::t-test-mean $sample $mean $stdev $confidence] } -result 1 test "Students-t-test-1.1" "Student's t - different sample" -match glob -body { set sample [::math::statistics::random-normal 0.0 1.0 40] set mean 10.0 set stdev 1.0 set confidence 0.95 set result [::math::statistics::t-test-mean $sample $mean $stdev $confidence] } -result 0 test "Students-t-test-1.2" "Student's t - small sample" -match glob -body { set sample [::math::statistics::random-normal 0.0 1.0 2] set mean 2.0 set stdev 1.0 set confidence 0.90 set result [::math::statistics::t-test-mean $sample $mean $stdev $confidence] } -result 1 # # Test private procedures # test "Cdf-toms322-1.0" "TOMS322 - erf(x)" -match tolerant2 -body { set result {} foreach z {4.417 3.891 3.291 2.576 2.241 1.960 1.645 1.150 0.674 0.319 0.126 0.063 0.0125} { set prob [::math::statistics::Cdf-toms322 1 5000 [expr {$z*$z}]] lappend result [expr {1.0-$prob}] } set result } -result {1.e-5 1.e-4 1.e-3 1.e-2 0.025 0.050 0.100 0.250 0.500 0.750 0.900 0.950 0.990 } test "Cdf-toms322-2.0" "TOMS322 - inverse erf(x)" -match tolerant2 -body { set result {} foreach p {0.5120 0.5948 0.7019 0.7996 0.8997 0.9505 0.9901 0.9980 } { set z [::math::statistics::Inverse-cdf-normal 0.0 1.0 $p] lappend result $z } set result } -result {0.03 0.24 0.53 0.84 1.28 1.65 2.33 2.88 } # # Correlation coefficients # test "Correlation-1.0" "Correlation - linear data" -match tolerant -body { set corr [::math::statistics::corr $::data_linear $::data_linear] } -result 1.0 test "Correlation-1.1" "Correlation - linear/uniform" -match almostzero -body { set corr [::math::statistics::corr $::data_linear $::data_uniform] } -result 0.0 # # Test list procedures # proc matchListElements { expected actual } { if { [llength $expected] != [llength $actual] } { return 0 } else { set match 1 foreach a $actual e $expected { if { $a != $e } { set match 0 break } } } return $match } customMatch matchList matchListElements set ::data_list {1 2 3 4 5 6 7 8 9 10} set ::data_pairs {{1 2} {3 4} {5 6} {7 8} {9 10}} test "Filter-1.0" "True filter" -match matchList -body { set data [::math::statistics::filter x $::data_list 1] } -result $::data_list test "Filter-1.1" "False filter" -match matchList -body { set data [::math::statistics::filter x $::data_list 0] } -result {} test "Filter-1.2" "Even filter" -match matchList -body { set data [::math::statistics::filter x $::data_list {$x%2==0}] } -result {2 4 6 8 10} test "Filter-2.1" "filter with parameter" -match matchList -body { set param 3.0 set data [::math::statistics::filter x $::data_list {$x > $param}] } -result {4 5 6 7 8 9 10} test "Map-1.0" "Identity map" -match matchList -body { set data [::math::statistics::map x $::data_list {$x}] } -result $::data_list test "Map-1.1" "Is-even map" -match matchList -body { set data [::math::statistics::map x $::data_list {$x%2==0}] } -result {0 1 0 1 0 1 0 1 0 1} test "Map-1.2" "Double map" -match matchList -body { set data [::math::statistics::map x $::data_list {$x*2}] } -result {2 4 6 8 10 12 14 16 18 20} test "Map-2.1" "map with parameter" -match matchList -body { set param 3.0 set data [::math::statistics::map x $::data_list {$x + $param}] } -result {4.0 5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0} test "Samplescount-1.0" "Single sublist" -match matchList -body { set data [::math::statistics::samplescount x [list $::data_list]] } -result {10} test "Samplescount-1.1" "List of singleton sublist" -match matchList -body { set data [::math::statistics::samplescount x $::data_list] } -result {1 1 1 1 1 1 1 1 1 1} test "Samplescount-1.2" "Pairs sublist" -match matchList -body { set data [::math::statistics::samplescount x $::data_pairs] } -result {2 2 2 2 2} test "Samplescount-1.3" "Select uneven sublist" -match matchList -body { set data [::math::statistics::samplescount x $::data_pairs {$x%2}] } -result {1 1 1 1 1} test "Samplescount-2.1" "Count with parameter" -match matchList -body { set param 3.0 set data [::math::statistics::samplescount x $::data_pairs {$x>$param}] } -result {0 1 2 2 2} test "Median-1.1" "Median - odd number of data" -body { set data {1.0 3.0 2.0} set median [::math::statistics::median $data] } -result 2.0 test "Median-1.2" "Median - even number of data" -body { set data {1.0 3.0 2.0 1.0} set median [::math::statistics::median $data] } -result 1.5 test "Median-1.3" "Median - missing data" -body { set data {1.0 {} 3.0 2.0 1.0 {}} set median [::math::statistics::median $data] } -result 1.5 test "test-2x2-1.0" "Test 2x2" -match tolerant -body { set data [::math::statistics::test-2x2 170 94 30 6] } -result 5.1136364 test "test-xbar-1.0" "Test xbar procedure" -match exact -body { set data {} for { set i 0 } { $i < 500 } { incr i } { lappend data [expr {rand()}] } set limits [::math::statistics::control-xbar $data] set newdata {1.0 1.0 1.0 1.0 0.5 0.5 0.5 0.5 10.0 10.0 10.0 10.0} set result [::math::statistics::test-xbar $limits $newdata] } -result {0 2} test "test-Rchart-1.0" "Test Rchart procedure" -match exact -body { set data {} for { set i 0 } { $i < 500 } { incr i } { lappend data [expr {rand()}] } set limits [::math::statistics::control-Rchart $data] set newdata {0.0 1.0 2.0 1.0 0.4 0.5 0.6 0.5 10.0 0.0 10.0 10.0} set result [::math::statistics::test-Rchart $limits $newdata] } -result {0 2} # # Testing for normal distribution # test "Testnormal-1.0" "Determine normality statistic for birth weight data" -match tolerant -body { ::math::statistics::lillieforsFit {72 112 111 107 119 92 126 80 81 84 115 118 128 128 123 116 125 126 122 126 127 86 142 132 87 123 133 106 103 118 114 94} } -result 0.82827415657 test "Testnormal-1.0" "Test birthweight data for normality - 80%" -match tolerant -body { ::math::statistics::test-normal {72 112 111 107 119 92 126 80 81 84 115 118 128 128 123 116 125 126 122 126 127 86 142 132 87 123 133 106 103 118 114 94} 0.80 } -result 1 test "Testnormal-1.0" "Test birthweight data for normality - 95%" -match tolerant -body { ::math::statistics::test-normal {72 112 111 107 119 92 126 80 81 84 115 118 128 128 123 116 125 126 122 126 127 86 142 132 87 123 133 106 103 118 114 94} 0.95 } -result 0 # # Testing multivariate linear regression # # Provide some data test "Testmultivar-1.0" "Ordinary multivariate regression - three independent variables" \ -match tolerant -body { set data { { -.67 14.18 60.03 -7.5} { 36.97 15.52 34.24 14.61} {-29.57 21.85 83.36 -7.} {-16.9 11.79 51.67 -6.56} { 14.09 16.24 36.97 -12.84} { 31.52 20.93 45.99 -25.4} { 24.05 20.69 50.27 17.27} { 22.23 16.91 45.07 -4.3} { 40.79 20.49 38.92 -.73} {-10.35 17.24 58.77 18.78}} # Call the ols routine set results [::math::statistics::mv-ols $data] # Flatten the result (so that we can use the tolerant comparison method) eval concat [eval concat $results] } -result {0.887239767929 0.830859651893 3.33854942057 -1.58346976987 0.0362328113288 32.571621244 1.03305463908 0.237943867401 0.234143883673 19.4700016828 0.810755783819 5.86634305732 -2.16569743834 -1.00124210139 -0.536696631937 0.609162254594 -15.0697565684 80.2129990564} # # pdf/cdf tests - transformed from the contributions by Eric K. Benedict # Cf. the examples. # test "gamma-distribution-1.0" "Test pdf-gamma" -match tolerant -body { set x [list \ [::math::statistics::pdf-gamma 1.5 2.7 3.0] \ [::math::statistics::pdf-gamma 7.5 0.2 30.0] \ [::math::statistics::pdf-gamma 15.0 1.2 2.0]] } -result {0.00263194027271168 0.0302770403110644 2.62677891379834e-07} test "gamma-distribution-1.1" "Test cdf-gamma" -match tolerant -body { set x [list \ [::math::statistics::cdf-gamma 1.9 0.45 2.5] \ [::math::statistics::cdf-gamma 45.0 2.2 32.7]] } -result {0.340299345090375 0.999731419881902} test "poisson-distribution-1.0" "Test pdf-poisson" -match tolerant -body { set x [list \ [::math::statistics::pdf-poisson 100 130] \ [::math::statistics::pdf-poisson 27.2 37] \ [::math::statistics::pdf-poisson 7.3 11.2]] } -result {0.000575252683815462 0.0134122817590761 0.0530940708960824} test "poisson-distribution-1.1" "Test cdf-poisson" -match tolerant -body { set x [list \ [::math::statistics::cdf-poisson 4 7] \ [::math::statistics::cdf-poisson 80 70] \ [::math::statistics::cdf-poisson 4.9 6.2]] } -result {0.948866384207153 0.14338996716003 0.77665467292263} test "chisquare-distribution-1.0" "Test pdf-chisquare" -match tolerant -body { set x [list \ [::math::statistics::pdf-chisquare 3 1.75] \ [::math::statistics::pdf-chisquare 10 2.9] \ [::math::statistics::pdf-chisquare 4 17.45] \ [::math::statistics::pdf-chisquare 2.5 1.8]] } -result {0.219999360547348 0.0216024880121444 0.000708787557977144 0.218446210041615} test "chisquare-distribution-1.1" "Test cdf-chisquare" -match tolerant -body { set x [list \ [::math::statistics::cdf-chisquare 2 3.5] \ [::math::statistics::cdf-chisquare 5 2.2] \ [::math::statistics::cdf-chisquare 5 100] \ [::math::statistics::cdf-chisquare 3.9 4.2] \ [::math::statistics::cdf-chisquare 1 2.0] \ [::math::statistics::cdf-chisquare 3 -2.0]] } -result {0.826226056549555 0.179164030785504 1.0 0.634682741547709 0.842700792949715 0.0} test "students-t-distribution-1.0" "Test pdf-students-t" -match tolerant -body { set x [list \ [::math::statistics::pdf-students-t 1 0.1] \ [::math::statistics::pdf-students-t 0.5 0.1] \ [::math::statistics::pdf-students-t 4 3.2] \ [::math::statistics::pdf-students-t 3 2.0] \ [::math::statistics::pdf-students-t 3 7.5]] } -result {0.315158303152268 0.265700672177405 0.0156821741652879 0.0675096606638929 0.000942291548015668} test "beta-distribution-1.0" "Test pdf-beta" -match tolerant -body { set x [list \ [::math::statistics::pdf-beta 1.3 2.4 0.2] \ [::math::statistics::pdf-beta 1 1 0.5] \ [::math::statistics::pdf-beta 3.7 0.9 0.0] \ [::math::statistics::pdf-beta 1.8 4.2 1.0] \ [::math::statistics::pdf-beta 320 400 0.4] \ [::math::statistics::pdf-beta 500 1 0.2] \ [::math::statistics::pdf-beta 1000 1000 0.50]] } -result {1.68903180472449 1.0 0.0 0.0 1.18192376783860 0.0 35.6780222917086} test "beta-distribution-1.1" "Test cdf-beta" -match tolerant -body { set x [list \ [::math::statistics::cdf-beta 2.1 3.0 0.2] \ [::math::statistics::cdf-beta 4.2 17.3 0.5] \ [::math::statistics::cdf-beta 500 375 0.7] \ [::math::statistics::cdf-beta 250 760 0.2] \ [::math::statistics::cdf-beta 43.2 19.7 0.6] \ [::math::statistics::cdf-beta 500 640 0.3] \ [::math::statistics::cdf-beta 400 640 0.3] \ [::math::statistics::cdf-beta 0.1 30 0.1] \ [::math::statistics::cdf-beta 0.01 0.03 0.9] \ [::math::statistics::cdf-beta 2 3 0.9999] \ [::math::statistics::cdf-beta 249.9999 759.99999 0.2] \ [::math::statistics::cdf-beta 1000 1000 0.4] \ [::math::statistics::cdf-beta 1000 1000 0.499] \ [::math::statistics::cdf-beta 1000 1000 0.5] \ [::math::statistics::cdf-beta 1000 1000 0.7] \ [::math::statistics::cdf-beta 2 3 0.6]] } -result {0.16220409275804 0.998630771123192 1.0 0.000125234318666948 0.0728881294218269 2.99872547567313e-23 3.07056696205524e-09 0.998641008671625 0.765865005703006 0.999999999996 0.000125237075575121 8.23161135486914e-20 0.464369443974288 0.5 1.0 0.8208} test "kruskal-wallis-1.0" "Test analysis Kruskal-Wallis" -match tolerant -body { ::math::statistics::analyse-Kruskal-Wallis {6.4 6.8 7.2 8.3 8.4 9.1 9.4 9.7} {2.5 3.7 4.9 5.4 5.9 8.1 8.2} {1.3 4.1 4.9 5.2 5.5 8.2} } -result {9.83627087199 0.00731275323967} test "kruskal-wallis-1.1" "Test test Kruskal-Wallis" -match tolerant -body { ::math::statistics::test-Kruskal-Wallis 0.95 {6.4 6.8 7.2 8.3 8.4 9.1 9.4 9.7} {2.5 3.7 4.9 5.4 5.9 8.1 8.2} {1.3 4.1 4.9 5.2 5.5 8.2} } -result 1 # Data from Statistical methods in Engineering and Quality Assurance by Peter W.M. John test "wilcoxon-1.0" "Test test Wilcoxon" -match tolerant -body { ::math::statistics::test-Wilcoxon {71.1 68.3 74.8 72.1 71.2 70.4 73.6 66.3 72.7 74.1 70.1 68.5} \ {73.3 70.9 74.6 72.1 72.8 74.2 74.7 69.2 75.5 75.8 70.0 72.1} } -result -1.67431578065 # Data from the Wikipedia page on Spearman's rank correlation coefficient test "spearman-rank-1.0" "Test Spearman rank correlation" -match tolerant -body { ::math::statistics::spearman-rank {106 86 100 101 99 103 97 113 112 110} \ { 7 0 27 50 28 29 20 12 6 17} } -result -0.175757575758 test "spearman-rank-extended-1.0" "Test extended Spearman rank correlation procedure" -match tolerant -body { ::math::statistics::spearman-rank-extended {106 86 100 101 99 103 97 113 112 110} \ { 7 0 27 50 28 29 20 12 6 17} } -result {-0.175757575758 10 -0.456397284} # End of test cases testsuiteCleanup tcllib-1.15/modules/math/statistics.man0000755000175000017500000011613512077663116017542 0ustar sergeisergei[manpage_begin math::statistics n 0.8] [moddesc {Tcl Math Library}] [titledesc {Basic statistical functions and procedures}] [category Mathematics] [require Tcl 8.4] [require math::statistics 0.8] [description] [para] The [package math::statistics] package contains functions and procedures for basic statistical data analysis, such as: [list_begin itemized] [item] Descriptive statistical parameters (mean, minimum, maximum, standard deviation) [item] Estimates of the distribution in the form of histograms and quantiles [item] Basic testing of hypotheses [item] Probability and cumulative density functions [list_end] It is meant to help in developing data analysis applications or doing ad hoc data analysis, it is not in itself a full application, nor is it intended to rival with full (non-)commercial statistical packages. [para] The purpose of this document is to describe the implemented procedures and provide some examples of their usage. As there is ample literature on the algorithms involved, we refer to relevant text books for more explanations. The package contains a fairly large number of public procedures. They can be distinguished in three sets: general procedures, procedures that deal with specific statistical distributions, list procedures to select or transform data and simple plotting procedures (these require Tk). [emph Note:] The data that need to be analyzed are always contained in a simple list. Missing values are represented as empty list elements. [section "GENERAL PROCEDURES"] The general statistical procedures are: [list_begin definitions] [call [cmd ::math::statistics::mean] [arg data]] Determine the [term mean] value of the given list of data. [list_begin arguments] [arg_def list data] - List of data [list_end] [para] [call [cmd ::math::statistics::min] [arg data]] Determine the [term minimum] value of the given list of data. [list_begin arguments] [arg_def list data] - List of data [list_end] [para] [call [cmd ::math::statistics::max] [arg data]] Determine the [term maximum] value of the given list of data. [list_begin arguments] [arg_def list data] - List of data [list_end] [para] [call [cmd ::math::statistics::number] [arg data]] Determine the [term number] of non-missing data in the given list [list_begin arguments] [arg_def list data] - List of data [list_end] [para] [call [cmd ::math::statistics::stdev] [arg data]] Determine the [term "sample standard deviation"] of the data in the given list [list_begin arguments] [arg_def list data] - List of data [list_end] [para] [call [cmd ::math::statistics::var] [arg data]] Determine the [term "sample variance"] of the data in the given list [list_begin arguments] [arg_def list data] - List of data [list_end] [para] [call [cmd ::math::statistics::pstdev] [arg data]] Determine the [term "population standard deviation"] of the data in the given list [list_begin arguments] [arg_def list data] - List of data [list_end] [para] [call [cmd ::math::statistics::pvar] [arg data]] Determine the [term "population variance"] of the data in the given list [list_begin arguments] [arg_def list data] - List of data [list_end] [para] [call [cmd ::math::statistics::median] [arg data]] Determine the [term median] of the data in the given list (Note that this requires sorting the data, which may be a costly operation) [list_begin arguments] [arg_def list data] - List of data [list_end] [para] [call [cmd ::math::statistics::basic-stats] [arg data]] Determine a list of all the descriptive parameters: mean, minimum, maximum, number of data, sample standard deviation, sample variance, population standard deviation and population variance. [para] (This routine is called whenever either or all of the basic statistical parameters are required. Hence all calculations are done and the relevant values are returned.) [list_begin arguments] [arg_def list data] - List of data [list_end] [para] [call [cmd ::math::statistics::histogram] [arg limits] [arg values]] Determine histogram information for the given list of data. Returns a list consisting of the number of values that fall into each interval. (The first interval consists of all values lower than the first limit, the last interval consists of all values greater than the last limit. There is one more interval than there are limits.) [list_begin arguments] [arg_def list limits] - List of upper limits (in ascending order) for the intervals of the histogram. [arg_def list values] - List of data [list_end] [para] [call [cmd ::math::statistics::corr] [arg data1] [arg data2]] Determine the correlation coefficient between two sets of data. [list_begin arguments] [arg_def list data1] - First list of data [arg_def list data2] - Second list of data [list_end] [para] [call [cmd ::math::statistics::interval-mean-stdev] [arg data] [arg confidence]] Return the interval containing the mean value and one containing the standard deviation with a certain level of confidence (assuming a normal distribution) [list_begin arguments] [arg_def list data] - List of raw data values (small sample) [arg_def float confidence] - Confidence level (0.95 or 0.99 for instance) [list_end] [para] [call [cmd ::math::statistics::t-test-mean] [arg data] [arg est_mean] \ [arg est_stdev] [arg confidence]] Test whether the mean value of a sample is in accordance with the estimated normal distribution with a certain level of confidence. Returns 1 if the test succeeds or 0 if the mean is unlikely to fit the given distribution. [list_begin arguments] [arg_def list data] - List of raw data values (small sample) [arg_def float est_mean] - Estimated mean of the distribution [arg_def float est_stdev] - Estimated stdev of the distribution [arg_def float confidence] - Confidence level (0.95 or 0.99 for instance) [list_end] [para] [call [cmd ::math::statistics::test-normal] [arg data] [arg confidence]] Test whether the given data follow a normal distribution with a certain level of confidence. Returns 1 if the data are normally distributed within the level of confidence, returns 0 if not. The underlying test is the Lilliefors test. [list_begin arguments] [arg_def list data] - List of raw data values [arg_def float confidence] - Confidence level (one of 0.80, 0.90, 0.95 or 0.99) [list_end] [para] [call [cmd ::math::statistics::lillieforsFit] [arg data]] Returns the goodness of fit to a normal distribution according to Lilliefors. The higher the number, the more likely the data are indeed normally distributed. The test requires at least [emph five] data points. [list_begin arguments] [arg_def list data] - List of raw data values [list_end] [para] [call [cmd ::math::statistics::quantiles] [arg data] [arg confidence]] Return the quantiles for a given set of data [list_begin arguments] [para] [arg_def list data] - List of raw data values [para] [arg_def float confidence] - Confidence level (0.95 or 0.99 for instance) [para] [list_end] [para] [call [cmd ::math::statistics::quantiles] [arg limits] [arg counts] [arg confidence]] Return the quantiles based on histogram information (alternative to the call with two arguments) [list_begin arguments] [arg_def list limits] - List of upper limits from histogram [arg_def list counts] - List of counts for for each interval in histogram [arg_def float confidence] - Confidence level (0.95 or 0.99 for instance) [list_end] [para] [call [cmd ::math::statistics::autocorr] [arg data]] Return the autocorrelation function as a list of values (assuming equidistance between samples, about 1/2 of the number of raw data) [para] The correlation is determined in such a way that the first value is always 1 and all others are equal to or smaller than 1. The number of values involved will diminish as the "time" (the index in the list of returned values) increases [list_begin arguments] [arg_def list data] - Raw data for which the autocorrelation must be determined [list_end] [para] [call [cmd ::math::statistics::crosscorr] [arg data1] [arg data2]] Return the cross-correlation function as a list of values (assuming equidistance between samples, about 1/2 of the number of raw data) [para] The correlation is determined in such a way that the values can never exceed 1 in magnitude. The number of values involved will diminish as the "time" (the index in the list of returned values) increases. [list_begin arguments] [arg_def list data1] - First list of data [arg_def list data2] - Second list of data [list_end] [para] [call [cmd ::math::statistics::mean-histogram-limits] [arg mean] \ [arg stdev] [arg number]] Determine reasonable limits based on mean and standard deviation for a histogram Convenience function - the result is suitable for the histogram function. [list_begin arguments] [arg_def float mean] - Mean of the data [arg_def float stdev] - Standard deviation [arg_def int number] - Number of limits to generate (defaults to 8) [list_end] [para] [call [cmd ::math::statistics::minmax-histogram-limits] [arg min] \ [arg max] [arg number]] Determine reasonable limits based on a minimum and maximum for a histogram [para] Convenience function - the result is suitable for the histogram function. [list_begin arguments] [arg_def float min] - Expected minimum [arg_def float max] - Expected maximum [arg_def int number] - Number of limits to generate (defaults to 8) [list_end] [para] [call [cmd ::math::statistics::linear-model] [arg xdata] \ [arg ydata] [arg intercept]] Determine the coefficients for a linear regression between two series of data (the model: Y = A + B*X). Returns a list of parameters describing the fit [list_begin arguments] [arg_def list xdata] - List of independent data [arg_def list ydata] - List of dependent data to be fitted [arg_def boolean intercept] - (Optional) compute the intercept (1, default) or fit to a line through the origin (0) [para] The result consists of the following list: [list_begin itemized] [item] (Estimate of) Intercept A [item] (Estimate of) Slope B [item] Standard deviation of Y relative to fit [item] Correlation coefficient R2 [item] Number of degrees of freedom df [item] Standard error of the intercept A [item] Significance level of A [item] Standard error of the slope B [item] Significance level of B [list_end] [list_end] [para] [call [cmd ::math::statistics::linear-residuals] [arg xdata] [arg ydata] \ [arg intercept]] Determine the difference between actual data and predicted from the linear model. [para] Returns a list of the differences between the actual data and the predicted values. [list_begin arguments] [arg_def list xdata] - List of independent data [arg_def list ydata] - List of dependent data to be fitted [arg_def boolean intercept] - (Optional) compute the intercept (1, default) or fit to a line through the origin (0) [list_end] [para] [call [cmd ::math::statistics::test-2x2] [arg n11] [arg n21] [arg n12] [arg n22]] Determine if two set of samples, each from a binomial distribution, differ significantly or not (implying a different parameter). [para] Returns the "chi-square" value, which can be used to the determine the significance. [list_begin arguments] [arg_def int n11] - Number of outcomes with the first value from the first sample. [arg_def int n21] - Number of outcomes with the first value from the second sample. [arg_def int n12] - Number of outcomes with the second value from the first sample. [arg_def int n22] - Number of outcomes with the second value from the second sample. [list_end] [para] [call [cmd ::math::statistics::print-2x2] [arg n11] [arg n21] [arg n12] [arg n22]] Determine if two set of samples, each from a binomial distribution, differ significantly or not (implying a different parameter). [para] Returns a short report, useful in an interactive session. [list_begin arguments] [arg_def int n11] - Number of outcomes with the first value from the first sample. [arg_def int n21] - Number of outcomes with the first value from the second sample. [arg_def int n12] - Number of outcomes with the second value from the first sample. [arg_def int n22] - Number of outcomes with the second value from the second sample. [list_end] [para] [call [cmd ::math::statistics::control-xbar] [arg data] [opt nsamples]] Determine the control limits for an xbar chart. The number of data in each subsample defaults to 4. At least 20 subsamples are required. [para] Returns the mean, the lower limit, the upper limit and the number of data per subsample. [list_begin arguments] [arg_def list data] - List of observed data [arg_def int nsamples] - Number of data per subsample [list_end] [para] [call [cmd ::math::statistics::control-Rchart] [arg data] [opt nsamples]] Determine the control limits for an R chart. The number of data in each subsample (nsamples) defaults to 4. At least 20 subsamples are required. [para] Returns the mean range, the lower limit, the upper limit and the number of data per subsample. [list_begin arguments] [arg_def list data] - List of observed data [arg_def int nsamples] - Number of data per subsample [list_end] [para] [call [cmd ::math::statistics::test-xbar] [arg control] [arg data]] Determine if the data exceed the control limits for the xbar chart. [para] Returns a list of subsamples (their indices) that indeed violate the limits. [list_begin arguments] [arg_def list control] - Control limits as returned by the "control-xbar" procedure [arg_def list data] - List of observed data [list_end] [para] [call [cmd ::math::statistics::test-Rchart] [arg control] [arg data]] Determine if the data exceed the control limits for the R chart. [para] Returns a list of subsamples (their indices) that indeed violate the limits. [list_begin arguments] [arg_def list control] - Control limits as returned by the "control-Rchart" procedure [arg_def list data] - List of observed data [list_end] [para] [list_end] [section "MULTIVARIATE LINEAR REGRESSION"] Besides the linear regression with a single independent variable, the statistics package provides two procedures for doing ordinary least squares (OLS) and weighted least squares (WLS) linear regression with several variables. They were written by Eric Kemp-Benedict. [para] In addition to these two, it provides a procedure (tstat) for calculating the value of the t-statistic for the specified number of degrees of freedom that is required to demonstrate a given level of significance. [para] Note: These procedures depend on the math::linearalgebra package. [para] [emph "Description of the procedures"] [list_begin definitions] [call [cmd ::math::statistics::tstat] [arg dof] [opt alpha]] Returns the value of the t-distribution t* satisfying [example { P(t*) = 1 - alpha/2 P(-t*) = alpha/2 }] for the number of degrees of freedom dof. [para] Given a sample of normally-distributed data x, with an estimate xbar for the mean and sbar for the standard deviation, the alpha confidence interval for the estimate of the mean can be calculated as [example { ( xbar - t* sbar , xbar + t* sbar) }] The return values from this procedure can be compared to an estimated t-statistic to determine whether the estimated value of a parameter is significantly different from zero at the given confidence level. [list_begin arguments] [arg_def int dof] Number of degrees of freedom [arg_def float alpha] Confidence level of the t-distribution. Defaults to 0.05. [list_end] [para] [call [cmd ::math::statistics::mv-wls] [arg wt1] [arg weights_and_values]] Carries out a weighted least squares linear regression for the data points provided, with weights assigned to each point. [para] The linear model is of the form [example { y = b0 + b1 * x1 + b2 * x2 ... + bN * xN + error }] and each point satisfies [example { yi = b0 + b1 * xi1 + b2 * xi2 + ... + bN * xiN + Residual_i }] [para] The procedure returns a list with the following elements: [list_begin itemized] [item] The r-squared statistic [item] The adjusted r-squared statistic [item] A list containing the estimated coefficients b1, ... bN, b0 (The constant b0 comes last in the list.) [item] A list containing the standard errors of the coefficients [item] A list containing the 95% confidence bounds of the coefficients, with each set of bounds returned as a list with two values [list_end] Arguments: [list_begin arguments] [arg_def list weights_and_values] A list consisting of: the weight for the first observation, the data for the first observation (as a sublist), the weight for the second observation (as a sublist) and so on. The sublists of data are organised as lists of the value of the dependent variable y and the independent variables x1, x2 to xN. [list_end] [para] [call [cmd ::math::statistics::mv-ols] [arg values]] Carries out an ordinary least squares linear regression for the data points provided. [para] This procedure simply calls ::mvlinreg::wls with the weights set to 1.0, and returns the same information. [list_end] [emph "Example of the use:"] [example { # Store the value of the unicode value for the "+/-" character set pm "\u00B1" # Provide some data set data {{ -.67 14.18 60.03 -7.5 } { 36.97 15.52 34.24 14.61 } {-29.57 21.85 83.36 -7. } {-16.9 11.79 51.67 -6.56 } { 14.09 16.24 36.97 -12.84} { 31.52 20.93 45.99 -25.4 } { 24.05 20.69 50.27 17.27} { 22.23 16.91 45.07 -4.3 } { 40.79 20.49 38.92 -.73 } {-10.35 17.24 58.77 18.78}} # Call the ols routine set results [::math::statistics::mv-ols $data] # Pretty-print the results puts "R-squared: [lindex $results 0]" puts "Adj R-squared: [lindex $results 1]" puts "Coefficients $pm s.e. -- \[95% confidence interval\]:" foreach val [lindex $results 2] se [lindex $results 3] bounds [lindex $results 4] { set lb [lindex $bounds 0] set ub [lindex $bounds 1] puts " $val $pm $se -- \[$lb to $ub\]" } }] [section "STATISTICAL DISTRIBUTIONS"] In the literature a large number of probability distributions can be found. The statistics package supports: [list_begin itemized] [item] The normal or Gaussian distribution [item] The uniform distribution - equal probability for all data within a given interval [item] The exponential distribution - useful as a model for certain extreme-value distributions. [item] The gamma distribution - based on the incomplete Gamma integral [item] The chi-square distribution [item] The student's T distribution [item] The Poisson distribution [item] PM - binomial,F. [list_end] In principle for each distribution one has procedures for: [list_begin itemized] [item] The probability density (pdf-*) [item] The cumulative density (cdf-*) [item] Quantiles for the given distribution (quantiles-*) [item] Histograms for the given distribution (histogram-*) [item] List of random values with the given distribution (random-*) [list_end] The following procedures have been implemented: [list_begin definitions] [call [cmd ::math::statistics::pdf-normal] [arg mean] [arg stdev] [arg value]] Return the probability of a given value for a normal distribution with given mean and standard deviation. [list_begin arguments] [arg_def float mean] - Mean value of the distribution [arg_def float stdev] - Standard deviation of the distribution [arg_def float value] - Value for which the probability is required [list_end] [para] [call [cmd ::math::statistics::pdf-exponential] [arg mean] [arg value]] Return the probability of a given value for an exponential distribution with given mean. [list_begin arguments] [arg_def float mean] - Mean value of the distribution [arg_def float value] - Value for which the probability is required [list_end] [para] [call [cmd ::math::statistics::pdf-uniform] [arg xmin] [arg xmax] [arg value]] Return the probability of a given value for a uniform distribution with given extremes. [list_begin arguments] [arg_def float xmin] - Minimum value of the distribution [arg_def float xmin] - Maximum value of the distribution [arg_def float value] - Value for which the probability is required [list_end] [para] [call [cmd ::math::statistics::pdf-gamma] [arg alpha] [arg beta] [arg value]] Return the probability of a given value for a Gamma distribution with given shape and rate parameters [list_begin arguments] [arg_def float alpha] - Shape parameter [arg_def float beta] - Rate parameter [arg_def float value] - Value for which the probability is required [list_end] [para] [call [cmd ::math::statistics::pdf-poisson] [arg mu] [arg k]] Return the probability of a given number of occurrences in the same interval (k) for a Poisson distribution with given mean (mu) [list_begin arguments] [arg_def float mu] - Mean number of occurrences [arg_def int k] - Number of occurences [list_end] [para] [call [cmd ::math::statistics::pdf-chisquare] [arg df] [arg value]] Return the probability of a given value for a chi square distribution with given degrees of freedom [list_begin arguments] [arg_def float df] - Degrees of freedom [arg_def float value] - Value for which the probability is required [list_end] [para] [call [cmd ::math::statistics::pdf-student-t] [arg df] [arg value]] Return the probability of a given value for a Student's t distribution with given degrees of freedom [list_begin arguments] [arg_def float df] - Degrees of freedom [arg_def float value] - Value for which the probability is required [list_end] [para] [call [cmd ::math::statistics::pdf-beta] [arg a] [arg b] [arg value]] Return the probability of a given value for a Beta distribution with given shape parameters [list_begin arguments] [arg_def float a] - First shape parameter [arg_def float b] - First shape parameter [arg_def float value] - Value for which the probability is required [list_end] [para] [call [cmd ::math::statistics::cdf-normal] [arg mean] [arg stdev] [arg value]] Return the cumulative probability of a given value for a normal distribution with given mean and standard deviation, that is the probability for values up to the given one. [list_begin arguments] [arg_def float mean] - Mean value of the distribution [arg_def float stdev] - Standard deviation of the distribution [arg_def float value] - Value for which the probability is required [list_end] [para] [call [cmd ::math::statistics::cdf-exponential] [arg mean] [arg value]] Return the cumulative probability of a given value for an exponential distribution with given mean. [list_begin arguments] [arg_def float mean] - Mean value of the distribution [arg_def float value] - Value for which the probability is required [list_end] [para] [call [cmd ::math::statistics::cdf-uniform] [arg xmin] [arg xmax] [arg value]] Return the cumulative probability of a given value for a uniform distribution with given extremes. [list_begin arguments] [arg_def float xmin] - Minimum value of the distribution [arg_def float xmin] - Maximum value of the distribution [arg_def float value] - Value for which the probability is required [list_end] [para] [call [cmd ::math::statistics::cdf-students-t] [arg degrees] [arg value]] Return the cumulative probability of a given value for a Student's t distribution with given number of degrees. [list_begin arguments] [arg_def int degrees] - Number of degrees of freedom [arg_def float value] - Value for which the probability is required [list_end] [para] [call [cmd ::math::statistics::cdf-gamma] [arg alpha] [arg beta] [arg value]] Return the cumulative probability of a given value for a Gamma distribution with given shape and rate parameters [list_begin arguments] [arg_def float alpha] - Shape parameter [arg_def float beta] - Rate parameter [arg_def float value] - Value for which the cumulative probability is required [list_end] [para] [call [cmd ::math::statistics::cdf-poisson] [arg mu] [arg k]] Return the cumulative probability of a given number of occurrences in the same interval (k) for a Poisson distribution with given mean (mu) [list_begin arguments] [arg_def float mu] - Mean number of occurrences [arg_def int k] - Number of occurences [list_end] [para] [call [cmd ::math::statistics::cdf-beta] [arg a] [arg b] [arg value]] Return the cumulative probability of a given value for a Beta distribution with given shape parameters [list_begin arguments] [arg_def float a] - First shape parameter [arg_def float b] - First shape parameter [arg_def float value] - Value for which the probability is required [list_end] [para] [call [cmd ::math::statistics::random-normal] [arg mean] [arg stdev] [arg number]] Return a list of "number" random values satisfying a normal distribution with given mean and standard deviation. [list_begin arguments] [arg_def float mean] - Mean value of the distribution [arg_def float stdev] - Standard deviation of the distribution [arg_def int number] - Number of values to be returned [list_end] [para] [call [cmd ::math::statistics::random-exponential] [arg mean] [arg number]] Return a list of "number" random values satisfying an exponential distribution with given mean. [list_begin arguments] [arg_def float mean] - Mean value of the distribution [arg_def int number] - Number of values to be returned [list_end] [para] [call [cmd ::math::statistics::random-uniform] [arg xmin] [arg xmax] [arg number]] Return a list of "number" random values satisfying a uniform distribution with given extremes. [list_begin arguments] [arg_def float xmin] - Minimum value of the distribution [arg_def float xmax] - Maximum value of the distribution [arg_def int number] - Number of values to be returned [list_end] [para] [call [cmd ::math::statistics::random-gamma] [arg alpha] [arg beta] [arg number]] Return a list of "number" random values satisfying a Gamma distribution with given shape and rate parameters [list_begin arguments] [arg_def float alpha] - Shape parameter [arg_def float beta] - Rate parameter [arg_def int number] - Number of values to be returned [list_end] [para] [call [cmd ::math::statistics::random-chisquare] [arg df] [arg number]] Return a list of "number" random values satisfying a chi square distribution with given degrees of freedom [list_begin arguments] [arg_def float df] - Degrees of freedom [arg_def int number] - Number of values to be returned [list_end] [para] [call [cmd ::math::statistics::random-student-t] [arg df] [arg number]] Return a list of "number" random values satisfying a Student's t distribution with given degrees of freedom [list_begin arguments] [arg_def float df] - Degrees of freedom [arg_def int number] - Number of values to be returned [list_end] [para] [call [cmd ::math::statistics::random-beta] [arg a] [arg b] [arg number]] Return a list of "number" random values satisfying a Beta distribution with given shape parameters [list_begin arguments] [arg_def float a] - First shape parameter [arg_def float b] - Second shape parameter [arg_def int number] - Number of values to be returned [list_end] [para] [call [cmd ::math::statistics::histogram-uniform] [arg xmin] [arg xmax] [arg limits] [arg number]] Return the expected histogram for a uniform distribution. [list_begin arguments] [arg_def float xmin] - Minimum value of the distribution [arg_def float xmax] - Maximum value of the distribution [arg_def list limits] - Upper limits for the buckets in the histogram [arg_def int number] - Total number of "observations" in the histogram [list_end] [para] [call [cmd ::math::statistics::incompleteGamma] [arg x] [arg p] [opt tol]] Evaluate the incomplete Gamma integral [example { 1 / x p-1 P(p,x) = -------- | dt exp(-t) * t Gamma(p) / 0 }] [list_begin arguments] [arg_def float x] - Value of x (limit of the integral) [arg_def float p] - Value of p in the integrand [arg_def float tol] - Required tolerance (default: 1.0e-9) [list_end] [para] [call [cmd ::math::statistics::incompleteBeta] [arg a] [arg b] [arg x] [opt tol]] Evaluate the incomplete Beta integral [list_begin arguments] [arg_def float a] - First shape parameter [arg_def float b] - Second shape parameter [arg_def float x] - Value of x (limit of the integral) [arg_def float tol] - Required tolerance (default: 1.0e-9) [list_end] [para] [list_end] TO DO: more function descriptions to be added [section "DATA MANIPULATION"] The data manipulation procedures act on lists or lists of lists: [list_begin definitions] [call [cmd ::math::statistics::filter] [arg varname] [arg data] [arg expression]] Return a list consisting of the data for which the logical expression is true (this command works analogously to the command [cmd foreach]). [list_begin arguments] [arg_def string varname] - Name of the variable used in the expression [arg_def list data] - List of data [arg_def string expression] - Logical expression using the variable name [list_end] [para] [call [cmd ::math::statistics::map] [arg varname] [arg data] [arg expression]] Return a list consisting of the data that are transformed via the expression. [list_begin arguments] [arg_def string varname] - Name of the variable used in the expression [arg_def list data] - List of data [arg_def string expression] - Expression to be used to transform (map) the data [list_end] [para] [call [cmd ::math::statistics::samplescount] [arg varname] [arg list] [arg expression]] Return a list consisting of the [term counts] of all data in the sublists of the "list" argument for which the expression is true. [list_begin arguments] [arg_def string varname] - Name of the variable used in the expression [arg_def list data] - List of sublists, each containing the data [arg_def string expression] - Logical expression to test the data (defaults to "true"). [list_end] [para] [call [cmd ::math::statistics::subdivide]] Routine [emph PM] - not implemented yet [para] [call [cmd ::math::statistics::test-Kruskal-Wallis] [arg confidence] [arg args]] Check if the population medians of two or more groups are equal with a given confidence level, using the Kruskal-Wallis test. [list_begin arguments] [arg_def float confidence] - Confidence level to be used (0-1) [arg_def list args] - Two or more lists of data [list_end] [para] [call [cmd ::math::statistics::analyse-Kruskal-Wallis] [arg args]] Compute the statistical parameters for the Kruskal-Wallis test. Returns the Kruskal-Wallis statistic and the probability that that value would occur assuming the medians of the populations are equal. [list_begin arguments] [arg_def list args] - Two or more lists of data [list_end] [para] [call [cmd ::math::statistics::group-rank] [arg args]] Rank the groups of data with respect to the complete set. Returns a list consisting of the group ID, the value and the rank (possibly a rational number, in case of ties) for each data item. [list_begin arguments] [arg_def list args] - Two or more lists of data [list_end] [para] [call [cmd ::math::statistics::test-Wilcoxon] [arg sample_a] [arg sample_b]] Compute the Wilcoxon test statistic to determine if two samples have the same median or not. (The statistic can be regarded as standard normal, if the sample sizes are both larger than 10. Returns the value of this statistic. [list_begin arguments] [arg_def list sample_a] - List of data comprising the first sample [arg_def list sample_b] - List of data comprising the second sample [list_end] [para] [call [cmd ::math::statistics::spearman-rank] [arg sample_a] [arg sample_b]] Return the Spearman rank correlation as an alternative to the ordinary (Pearson's) correlation coefficient. The two samples should have the same number of data. [list_begin arguments] [arg_def list sample_a] - First list of data [arg_def list sample_b] - Second list of data [list_end] [para] [call [cmd ::math::statistics::spearman-rank-extended] [arg sample_a] [arg sample_b]] Return the Spearman rank correlation as an alternative to the ordinary (Pearson's) correlation coefficient as well as additional data. The two samples should have the same number of data. The procedure returns the correlation coefficient, the number of data pairs used and the z-score, an approximately standard normal statistic, indicating the significance of the correlation. [list_begin arguments] [arg_def list sample_a] - First list of data [arg_def list sample_b] - Second list of data [list_end] [list_end] [section "PLOT PROCEDURES"] The following simple plotting procedures are available: [list_begin definitions] [call [cmd ::math::statistics::plot-scale] [arg canvas] \ [arg xmin] [arg xmax] [arg ymin] [arg ymax]] Set the scale for a plot in the given canvas. All plot routines expect this function to be called first. There is no automatic scaling provided. [list_begin arguments] [arg_def widget canvas] - Canvas widget to use [arg_def float xmin] - Minimum x value [arg_def float xmax] - Maximum x value [arg_def float ymin] - Minimum y value [arg_def float ymax] - Maximum y value [list_end] [para] [call [cmd ::math::statistics::plot-xydata] [arg canvas] \ [arg xdata] [arg ydata] [arg tag]] Create a simple XY plot in the given canvas - the data are shown as a collection of dots. The tag can be used to manipulate the appearance. [list_begin arguments] [arg_def widget canvas] - Canvas widget to use [arg_def float xdata] - Series of independent data [arg_def float ydata] - Series of dependent data [arg_def string tag] - Tag to give to the plotted data (defaults to xyplot) [list_end] [para] [call [cmd ::math::statistics::plot-xyline] [arg canvas] \ [arg xdata] [arg ydata] [arg tag]] Create a simple XY plot in the given canvas - the data are shown as a line through the data points. The tag can be used to manipulate the appearance. [list_begin arguments] [arg_def widget canvas] - Canvas widget to use [arg_def list xdata] - Series of independent data [arg_def list ydata] - Series of dependent data [arg_def string tag] - Tag to give to the plotted data (defaults to xyplot) [list_end] [para] [call [cmd ::math::statistics::plot-tdata] [arg canvas] \ [arg tdata] [arg tag]] Create a simple XY plot in the given canvas - the data are shown as a collection of dots. The horizontal coordinate is equal to the index. The tag can be used to manipulate the appearance. This type of presentation is suitable for autocorrelation functions for instance or for inspecting the time-dependent behaviour. [list_begin arguments] [arg_def widget canvas] - Canvas widget to use [arg_def list tdata] - Series of dependent data [arg_def string tag] - Tag to give to the plotted data (defaults to xyplot) [list_end] [para] [call [cmd ::math::statistics::plot-tline] [arg canvas] \ [arg tdata] [arg tag]] Create a simple XY plot in the given canvas - the data are shown as a line. See plot-tdata for an explanation. [list_begin arguments] [arg_def widget canvas] - Canvas widget to use [arg_def list tdata] - Series of dependent data [arg_def string tag] - Tag to give to the plotted data (defaults to xyplot) [list_end] [para] [call [cmd ::math::statistics::plot-histogram] [arg canvas] \ [arg counts] [arg limits] [arg tag]] Create a simple histogram in the given canvas [list_begin arguments] [arg_def widget canvas] - Canvas widget to use [arg_def list counts] - Series of bucket counts [arg_def list limits] - Series of upper limits for the buckets [arg_def string tag] - Tag to give to the plotted data (defaults to xyplot) [list_end] [para] [list_end] [section {THINGS TO DO}] The following procedures are yet to be implemented: [list_begin itemized] [item] F-test-stdev [item] interval-mean-stdev [item] histogram-normal [item] histogram-exponential [item] test-histogram [item] test-corr [item] quantiles-* [item] fourier-coeffs [item] fourier-residuals [item] onepar-function-fit [item] onepar-function-residuals [item] plot-linear-model [item] subdivide [list_end] [section EXAMPLES] The code below is a small example of how you can examine a set of data: [para] [example_begin] # Simple example: # - Generate data (as a cheap way of getting some) # - Perform statistical analysis to describe the data # package require math::statistics # # Two auxiliary procs # proc pause {time} { set wait 0 after [lb]expr {$time*1000}[rb] {set ::wait 1} vwait wait } proc print-histogram {counts limits} { foreach count $counts limit $limits { if { $limit != {} } { puts [lb]format "<%12.4g\t%d" $limit $count[rb] set prev_limit $limit } else { puts [lb]format ">%12.4g\t%d" $prev_limit $count[rb] } } } # # Our source of arbitrary data # proc generateData { data1 data2 } { upvar 1 $data1 _data1 upvar 1 $data2 _data2 set d1 0.0 set d2 0.0 for { set i 0 } { $i < 100 } { incr i } { set d1 [lb]expr {10.0-2.0*cos(2.0*3.1415926*$i/24.0)+3.5*rand()}[rb] set d2 [lb]expr {0.7*$d2+0.3*$d1+0.7*rand()}[rb] lappend _data1 $d1 lappend _data2 $d2 } return {} } # # The analysis session # package require Tk console show canvas .plot1 canvas .plot2 pack .plot1 .plot2 -fill both -side top generateData data1 data2 puts "Basic statistics:" set b1 [lb]::math::statistics::basic-stats $data1[rb] set b2 [lb]::math::statistics::basic-stats $data2[rb] foreach label {mean min max number stdev var} v1 $b1 v2 $b2 { puts "$label\t$v1\t$v2" } puts "Plot the data as function of \"time\" and against each other" ::math::statistics::plot-scale .plot1 0 100 0 20 ::math::statistics::plot-scale .plot2 0 20 0 20 ::math::statistics::plot-tline .plot1 $data1 ::math::statistics::plot-tline .plot1 $data2 ::math::statistics::plot-xydata .plot2 $data1 $data2 puts "Correlation coefficient:" puts [lb]::math::statistics::corr $data1 $data2] pause 2 puts "Plot histograms" .plot2 delete all ::math::statistics::plot-scale .plot2 0 20 0 100 set limits [lb]::math::statistics::minmax-histogram-limits 7 16[rb] set histogram_data [lb]::math::statistics::histogram $limits $data1[rb] ::math::statistics::plot-histogram .plot2 $histogram_data $limits puts "First series:" print-histogram $histogram_data $limits pause 2 set limits [lb]::math::statistics::minmax-histogram-limits 0 15 10[rb] set histogram_data [lb]::math::statistics::histogram $limits $data2[rb] ::math::statistics::plot-histogram .plot2 $histogram_data $limits d2 .plot2 itemconfigure d2 -fill red puts "Second series:" print-histogram $histogram_data $limits puts "Autocorrelation function:" set autoc [lb]::math::statistics::autocorr $data1[rb] puts [lb]::math::statistics::map $autoc {[lb]format "%.2f" $x]}[rb] puts "Cross-correlation function:" set crossc [lb]::math::statistics::crosscorr $data1 $data2[rb] puts [lb]::math::statistics::map $crossc {[lb]format "%.2f" $x[rb]}[rb] ::math::statistics::plot-scale .plot1 0 100 -1 4 ::math::statistics::plot-tline .plot1 $autoc "autoc" ::math::statistics::plot-tline .plot1 $crossc "crossc" .plot1 itemconfigure autoc -fill green .plot1 itemconfigure crossc -fill yellow puts "Quantiles: 0.1, 0.2, 0.5, 0.8, 0.9" puts "First: [lb]::math::statistics::quantiles $data1 {0.1 0.2 0.5 0.8 0.9}[rb]" puts "Second: [lb]::math::statistics::quantiles $data2 {0.1 0.2 0.5 0.8 0.9}[rb]" [example_end] If you run this example, then the following should be clear: [list_begin itemized] [item] There is a strong correlation between two time series, as displayed by the raw data and especially by the correlation functions. [item] Both time series show a significant periodic component [item] The histograms are not very useful in identifying the nature of the time series - they do not show the periodic nature. [list_end] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph {math :: statistics}] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords mathematics "data analysis" statistics] [manpage_end] tcllib-1.15/modules/math/elliptic.tcl0000755000175000017500000001212112077663116017152 0ustar sergeisergei# elliptic.tcl -- # Compute elliptic functions and integrals # # Computation of elliptic functions cn, dn and sn # adapted from: # Michael W. Pashea # Numerical computation of elliptic functions # Doctor Dobbs' Journal, May 2005 # # namespace ::math::special # namespace eval ::math::special { namespace export cn sn dn ::math::constants::constants pi variable halfpi [expr {$pi/2.0}] variable tol set tol 1.0e-10 } # elliptic_K -- # Compute the complete elliptic integral of the first kind # # Arguments: # k Parameter of the integral # Result: # Value of K(k) # Note: # This relies on the arithmetic-geometric mean # proc ::math::special::elliptic_K {k} { variable halfpi if { $k < 0.0 || $k >= 1.0 } { error "Domain error: must be between 0 (inclusive) and 1 (not inclusive)" } if { $k == 0.0 } { return $halfpi } set a 1.0 set b [expr {sqrt(1.0-$k*$k)}] for {set i 0} {$i < 10} {incr i} { set anew [expr {($a+$b)/2.0}] set bnew [expr {sqrt($a*$b)}] set a $anew set b $bnew #puts "$a $b" } return [expr {$halfpi/$a}] } # elliptic_E -- # Compute the complete elliptic integral of the second kind # # Arguments: # k Parameter of the integral # Result: # Value of E(k) # Note: # This relies on the arithmetic-geometric mean # proc ::math::special::elliptic_E {k} { variable halfpi if { $k < 0.0 || $k >= 1.0 } { error "Domain error: must be between 0 (inclusive) and 1 (not inclusive)" } if { $k == 0.0 } { return $halfpi } if { $k == 1.0 } { return 1.0 } set a 1.0 set b [expr {sqrt(1.0-$k*$k)}] set sumc [expr {$k*$k/2.0}] set factor 0.25 for {set i 0} {$i < 10} {incr i} { set anew [expr {($a+$b)/2.0}] set bnew [expr {sqrt($a*$b)}] set sumc [expr {$sumc+$factor*($a-$b)*($a-$b)}] set factor [expr {$factor*2.0}] set a $anew set b $bnew #puts "$a $b" } set Kk [expr {$halfpi/$a}] return [expr {(1.0-$sumc)*$Kk}] } namespace eval ::math::special { } # Nextk -- # Auxiliary function for computing next value of k # # Arguments: # k Parameter # Return value: # Next value to be used # proc ::math::special::Nextk { k } { set ksq [expr {sqrt(1.0-$k*$k)}] return [expr {(1.0-$ksq)/(1+$ksq)}] } # IterateUK -- # Auxiliary function to compute the raw value (phi) # # Arguments: # u Independent variable # k Parameter # Return value: # phi # proc ::math::special::IterateUK { u k } { variable tol set kvalues {} set nmax 1 while { $k > $tol } { set k [Nextk $k] set kvalues [concat $k $kvalues] set u [expr {$u*2.0/(1.0+$k)}] incr nmax #puts "$nmax -$u - $k" } foreach k $kvalues { set u [expr {( $u + asin($k*sin($u)) )/2.0}] } return $u } # cn -- # Compute the elliptic function cn # # Arguments: # u Independent variable # k Parameter # Return value: # cn(u,k) # Note: # If k == 1, then the iteration does not stop # proc ::math::special::cn { u k } { if { $k > 1.0 } { return -code error "Parameter out of range - must be <= 1.0" } if { $k == 1.0 } { return [expr {1.0/cosh($u)}] } else { set u [IterateUK $u $k] return [expr {cos($u)}] } } # sn -- # Compute the elliptic function sn # # Arguments: # u Independent variable # k Parameter # Return value: # sn(u,k) # Note: # If k == 1, then the iteration does not stop # proc ::math::special::sn { u k } { if { $k > 1.0 } { return -code error "Parameter out of range - must be <= 1.0" } if { $k == 1.0 } { return [expr {tanh($u)}] } else { set u [IterateUK $u $k] return [expr {sin($u)}] } } # dn -- # Compute the elliptic function sn # # Arguments: # u Independent variable # k Parameter # Return value: # dn(u,k) # Note: # If k == 1, then the iteration does not stop # proc ::math::special::sn { u k } { if { $k > 1.0 } { return -code error "Parameter out of range - must be <= 1.0" } if { $k == 1.0 } { return [expr {1.0/cosh($u)}] } else { set u [IterateUK $u $k] return [expr {sqrt(1.0-$k*$k*sin($u))}] } } # main -- # Simple tests # if { 0 } { puts "Special cases:" puts "cos(1): [::math::special::cn 1.0 0.0] -- [expr {cos(1.0)}]" puts "1/cosh(1): [::math::special::cn 1.0 0.999] -- [expr {1.0/cosh(1.0)}]" } # some tests -- # if { 0 } { set prec $::tcl_precision if {![package vsatisfies [package provide Tcl] 8.5]} { set ::tcl_precision 17 } else { set ::tcl_precision 0 } #foreach k {0.0 0.1 0.2 0.4 0.6 0.8 0.9} { # puts "$k: [::math::special::elliptic_K $k]" #} foreach k2 {0.0 0.1 0.2 0.4 0.6 0.8 0.9} { set k [expr {sqrt($k2)}] puts "$k2: [::math::special::elliptic_K $k] \ [::math::special::elliptic_E $k]" } set ::tcl_precision $prec } tcllib-1.15/modules/math/qcomplex.tcl0000755000175000017500000001073712077663116017210 0ustar sergeisergei# qcomplex.tcl -- # Small module for dealing with complex numbers # The design goal was to make the operations as fast # as possible, not to offer a nice interface. So: # - complex numbers are represented as lists of two elements # - there is hardly any error checking, all arguments are assumed # to be complex numbers already (with a few obvious exceptions) # Missing: # the inverse trigonometric functions and the hyperbolic functions # namespace eval ::math::complexnumbers { namespace export + - / * conj exp sin cos tan real imag mod arg log pow sqrt tostring } # complex -- # Create a new complex number # Arguments: # real The real part # imag The imaginary part # Result: # New complex number # proc ::math::complexnumbers::complex {real imag} { return [list $real $imag] } # binary operations -- # Implement the basic binary operations # Arguments: # z1 First argument # z2 Second argument # Result: # New complex number # proc ::math::complexnumbers::+ {z1 z2} { set result {} foreach c $z1 d $z2 { lappend result [expr {$c+$d}] } return $result } proc ::math::complexnumbers::- {z1 {z2 {}}} { if { $z2 == {} } { set z2 $z1 set z1 {0.0 0.0} } set result {} foreach c $z1 d $z2 { lappend result [expr {$c-$d}] } return $result } proc ::math::complexnumbers::* {z1 z2} { set result {} foreach {c1 d1} $z1 {break} foreach {c2 d2} $z2 {break} return [list [expr {$c1*$c2-$d1*$d2}] [expr {$c1*$d2+$c2*$d1}]] } proc ::math::complexnumbers::/ {z1 z2} { set result {} foreach {c1 d1} $z1 {break} foreach {c2 d2} $z2 {break} set denom [expr {$c2*$c2+$d2*$d2}] return [list [expr {($c1*$c2+$d1*$d2)/$denom}] \ [expr {(-$c1*$d2+$c2*$d1)/$denom}]] } # unary operations -- # Implement the basic unary operations # Arguments: # z1 Argument # Result: # New complex number # proc ::math::complexnumbers::conj {z1} { foreach {c d} $z1 {break} return [list $c [expr {-$d}]] } proc ::math::complexnumbers::real {z1} { foreach {c d} $z1 {break} return $c } proc ::math::complexnumbers::imag {z1} { foreach {c d} $z1 {break} return $d } proc ::math::complexnumbers::mod {z1} { foreach {c d} $z1 {break} return [expr {hypot($c,$d)}] } proc ::math::complexnumbers::arg {z1} { foreach {c d} $z1 {break} if { $c != 0.0 || $d != 0.0 } { return [expr {atan2($d,$c)}] } else { return 0.0 } } # elementary functions -- # Implement the elementary functions # Arguments: # z1 Argument # z2 Second argument (if any) # Result: # New complex number # proc ::math::complexnumbers::exp {z1} { foreach {c d} $z1 {break} return [list [expr {exp($c)*cos($d)}] [expr {exp($c)*sin($d)}]] } proc ::math::complexnumbers::cos {z1} { foreach {c d} $z1 {break} return [list [expr {cos($c)*cosh($d)}] [expr {-sin($c)*sinh($d)}]] } proc ::math::complexnumbers::sin {z1} { foreach {c d} $z1 {break} return [list [expr {sin($c)*cosh($d)}] [expr {cos($c)*sinh($d)}]] } proc ::math::complexnumbers::tan {z1} { return [/ [sin $z1] [cos $z1]] } proc ::math::complexnumbers::log {z1} { return [list [expr {log([mod $z1])}] [arg $z1]] } proc ::math::complexnumbers::sqrt {z1} { set argz [expr {0.5*[arg $z1]}] set modz [expr {sqrt([mod $z1])}] return [list [expr {$modz*cos($argz)}] [expr {$modz*sin($argz)}]] } proc ::math::complexnumbers::pow {z1 z2} { return [exp [* [log $z1] $z2]] } # transformational functions -- # Implement transformational functions # Arguments: # z1 Argument # Result: # String like 1+i # proc ::math::complexnumbers::tostring {z1} { foreach {c d} $z1 {break} if { $d == 0.0 } { return "$c" } else { if { $c == 0.0 } { if { $d == 1.0 } { return "i" } elseif { $d == -1.0 } { return "-i" } else { return "${d}i" } } else { if { $d > 0.0 } { if { $d == 1.0 } { return "$c+i" } else { return "$c+${d}i" } } else { if { $d == -1.0 } { return "$c-i" } else { return "$c${d}i" } } } } } # # Announce our presence # package provide math::complexnumbers 1.0.2 tcllib-1.15/modules/math/geometry.tcl0000644000175000017500000010630012077663116017200 0ustar sergeisergei# geometry.tcl -- # # Collection of geometry functions. # # Copyright (c) 2001 by Ideogramic ApS and other parties. # Copyright (c) 2004 Arjen Markus # Copyright (c) 2010 Andreas Kupries # Copyright (c) 2010 Kevin Kenny # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: geometry.tcl,v 1.12 2010/05/24 21:44:16 andreas_kupries Exp $ namespace eval ::math::geometry {} package require math ### # # POINTS # # A point P consists of an x-coordinate, Px, and a y-coordinate, Py, # and both coordinates are floating point values. # # Points are usually denoted by A, B, C, P, or Q. # ### # # LINES # # There are basically three types of lines: # line A line is defined by two points A and B as the # _infinite_ line going through these two points. # Often a line is given as a list of 4 coordinates # instead of 2 points. # line segment A line segment is defined by two points A and B # as the _finite_ that starts in A and ends in B. # Often a line segment is given as a list of 4 # coordinates instead of 2 points. # polyline A polyline is a sequence of connected line segments. # # Please note that given a point P, the closest point on a line is given # by the projection of P onto the line. The closest point on a line segment # may be the projection, but it may also be one of the end points of the # line segment. # ### # # DISTANCES # # The distances in this package are all floating point values. # ### # Point constructor proc ::math::geometry::p {x y} { return [list $x $y] } # Vector addition proc ::math::geometry::+ {pa pb} { foreach {ax ay} $pa break foreach {bx by} $pb break return [list [expr {$ax + $bx}] [expr {$ay + $by}]] } # Vector difference proc ::math::geometry::- {pa pb} { foreach {ax ay} $pa break foreach {bx by} $pb break return [list [expr {$ax - $bx}] [expr {$ay - $by}]] } # Distance between 2 points proc ::math::geometry::distance {pa pb} { foreach {ax ay} $pa break foreach {bx by} $pb break return [expr {hypot($bx-$ax,$by-$ay)}] } # Length of a vector proc ::math::geometry::length {v} { foreach {x y} $v break return [expr {hypot($x,$y)}] } # Scaling a vector by a factor proc ::math::geometry::s* {factor p} { foreach {x y} $p break return [list [expr {$x * $factor}] [expr {$y * $factor}]] } # Unit vector into specific direction given by angle (degrees) proc ::math::geometry::direction {angle} { variable torad set x [expr { cos($angle * $torad)}] set y [expr {- sin($angle * $torad)}] return [list $x $y] } # Vertical vector of specified length. proc ::math::geometry::v {h} { return [list 0 $h] } # Horizontal vector of specified length. proc ::math::geometry::h {w} { return [list $w 0] } # Find point on a line between 2 points at a distance # distance 0 => a, distance 1 => b proc ::math::geometry::between {pa pb s} { return [+ $pa [s* $s [- $pb $pa]]] } # Find direction octant the point (vector) lies in. proc ::math::geometry::octant {p} { variable todeg foreach {x y} $p break set a [expr {(atan2(-$y,$x)*$todeg)}] while {$a > 360} {set a [expr {$a - 360}]} while {$a < -360} {set a [expr {$a + 360}]} if {$a < 0} {set a [expr {360 + $a}]} #puts "p ($x, $y) @ angle $a | [expr {atan2($y,$x)}] | [expr {atan2($y,$x)*$todeg}]" # XXX : Add outer conditions to make a log2 tree of checks. if {$a <= 157.5} { if {$a <= 67.5} { if {$a <= 22.5} { return east } return northeast } if {$a <= 112.5} { return north } return northwest } else { if {$a <= 247.5} { if {$a <= 202.5} { return west } return southwest } if {$a <= 337.5} { if {$a <= 292.5} { return south } return southeast } return east ; # a <= 360.0 } } # Return the NW and SE corners of the rectangle. proc ::math::geometry::nwse {rect} { foreach {xnw ynw xse yse} $rect break return [list [p $xnw $ynw] [p $xse $yse]] } # Construct rectangle from NW and SE corners. proc ::math::geometry::rect {pa pb} { foreach {ax ay} $pa break foreach {bx by} $pb break return [list $ax $ay $bx $by] } proc ::math::geometry::conjx {p} { foreach {x y} $p break return [list [expr {- $x}] $y] } proc ::math::geometry::conjy {p} { foreach {x y} $p break return [list $x [expr {- $y}]] } proc ::math::geometry::x {p} { foreach {x y} $p break return $x } proc ::math::geometry::y {p} { foreach {x y} $p break return $y } # ::math::geometry::calculateDistanceToLine # # Calculate the distance between a point and a line. # # Arguments: # P a point # line a line # # Results: # dist the smallest distance between P and the line # # Examples: # - calculateDistanceToLine {5 10} {0 0 10 10} # Result: 3.53553390593 # - calculateDistanceToLine {-10 0} {0 0 10 10} # Result: 7.07106781187 # proc ::math::geometry::calculateDistanceToLine {P line} { # solution based on FAQ 1.02 on comp.graphics.algorithms # L = sqrt( (Bx-Ax)^2 + (By-Ay)^2 ) # (Ay-Cy)(Bx-Ax)-(Ax-Cx)(By-Ay) # s = ----------------------------- # L^2 # dist = |s|*L # # => # # | (Ay-Cy)(Bx-Ax)-(Ax-Cx)(By-Ay) | # dist = --------------------------------- # L set Ax [lindex $line 0] set Ay [lindex $line 1] set Bx [lindex $line 2] set By [lindex $line 3] set Cx [lindex $P 0] set Cy [lindex $P 1] if {$Ax==$Bx && $Ay==$By} { return [lengthOfPolyline [concat $P [lrange $line 0 1]]] } else { set L [expr {sqrt(pow($Bx-$Ax,2) + pow($By-$Ay,2))}] return [expr {abs(($Ay-$Cy)*($Bx-$Ax)-($Ax-$Cx)*($By-$Ay)) / $L}] } } # ::math::geometry::findClosestPointOnLine # # Return the point on a line which is closest to a given point. # # Arguments: # P a point # line a line # # Results: # Q the point on the line that has the smallest # distance to P # # Examples: # - findClosestPointOnLine {5 10} {0 0 10 10} # Result: 7.5 7.5 # - findClosestPointOnLine {-10 0} {0 0 10 10} # Result: -5.0 -5.0 # proc ::math::geometry::findClosestPointOnLine {P line} { return [lindex [findClosestPointOnLineImpl $P $line] 0] } # ::math::geometry::findClosestPointOnLineImpl # # PRIVATE FUNCTION USED BY OTHER FUNCTIONS. # Find the point on a line that is closest to a given point. # # Arguments: # P a point # line a line defined by points A and B # # Results: # Q the point on the line that has the smallest # distance to P # r r has the following meaning: # r=0 P = A # r=1 P = B # r<0 P is on the backward extension of AB # r>1 P is on the forward extension of AB # 01} { return [lengthOfPolyline [concat $P [lrange $linesegment 2 3]]] } else { return $distToLine } } # ::math::geometry::calculateDistanceToLineSegmentImpl # # PRIVATE FUNCTION USED BY OTHER FUNCTIONS. # Find the distance between a point and a line. # # Arguments: # P a point # linesegment a line segment A->B # # Results: # dist the smallest distance between P and the line # r r has the following meaning: # r=0 P = A # r=1 P = B # r<0 P is on the backward extension of AB # r>1 P is on the forward extension of AB # 0 # # | (Ay-Cy)(Bx-Ax)-(Ax-Cx)(By-Ay) | # dist = --------------------------------- # L set Ax [lindex $linesegment 0] set Ay [lindex $linesegment 1] set Bx [lindex $linesegment 2] set By [lindex $linesegment 3] set Cx [lindex $P 0] set Cy [lindex $P 1] if {$Ax==$Bx && $Ay==$By} { return [list [lengthOfPolyline [concat $P [lrange $linesegment 0 1]]] 0] } else { set L [expr {sqrt(pow($Bx-$Ax,2) + pow($By-$Ay,2))}] set r [expr {(($Cx-$Ax)*($Bx-$Ax) + ($Cy-$Ay)*($By-$Ay))/pow($L,2)}] return [list [expr {abs(($Ay-$Cy)*($Bx-$Ax)-($Ax-$Cx)*($By-$Ay)) / $L}] $r] } } # ::math::geometry::findClosestPointOnLineSegment # # Return the point on a line segment which is closest to a given point. # # Arguments: # P a point # linesegment a line segment # # Results: # Q the point on the line segment that has the # smallest distance to P # # Examples: # - findClosestPointOnLineSegment {5 10} {0 0 10 10} # Result: 7.5 7.5 # - findClosestPointOnLineSegment {-10 0} {0 0 10 10} # Result: 0 0 # proc ::math::geometry::findClosestPointOnLineSegment {P linesegment} { set result [findClosestPointOnLineImpl $P $linesegment] set Q [lindex $result 0] set r [lindex $result 1] if {$r<0} { return [lrange $linesegment 0 1] } elseif {$r>1} { return [lrange $linesegment 2 3] } else { return $Q } } # ::math::geometry::calculateDistanceToPolyline # # Calculate the distance between a point and a polyline. # # Arguments: # P a point # polyline a polyline # # Results: # dist the smallest distance between P and any point # on the polyline # # Examples: # - calculateDistanceToPolyline {10 10} {0 0 10 5 20 0} # Result: 5.0 # - calculateDistanceToPolyline {5 10} {0 0 10 5 20 0} # Result: 6.7082039325 # proc ::math::geometry::calculateDistanceToPolyline {P polyline} { set minDist "none" foreach {Ax Ay} [lrange $polyline 0 end-2] {Bx By} [lrange $polyline 2 end] { set dist [calculateDistanceToLineSegment $P [list $Ax $Ay $Bx $By]] if {$minDist=="none" || $dist < $minDist} { set minDist $dist } } return $minDist } # ::math::geometry::findClosestPointOnPolyline # # Return the point on a polyline which is closest to a given point. # # Arguments: # P a point # polyline a polyline # # Results: # Q the point on the polyline that has the smallest # distance to P # # Examples: # - findClosestPointOnPolyline {10 10} {0 0 10 5 20 0} # Result: 10 5 # - findClosestPointOnPolyline {5 10} {0 0 10 5 20 0} # Result: 8.0 4.0 # proc ::math::geometry::findClosestPointOnPolyline {P polyline} { set closestPoint "none" foreach {Ax Ay} [lrange $polyline 0 end-2] {Bx By} [lrange $polyline 2 end] { set Q [findClosestPointOnLineSegment $P [list $Ax $Ay $Bx $By]] set dist [lengthOfPolyline [concat $P $Q]] if {$closestPoint=="none" || $dist<$closestDistance} { set closestPoint $Q set closestDistance $dist } } return $closestPoint } # ::math::geometry::lengthOfPolyline # # Find the length of a polyline, i.e., the sum of the # lengths of the individual line segments. # # Arguments: # polyline a polyline # # Results: # length the length of the polyline # # Examples: # - lengthOfPolyline {0 0 5 0 5 10} # Result: 15.0 # proc ::math::geometry::lengthOfPolyline {polyline} { set length 0 foreach {x1 y1} [lrange $polyline 0 end-2] {x2 y2} [lrange $polyline 2 end] { set length [expr {$length + sqrt(pow($x1-$x2,2) + pow($y1-$y2,2))}] #set length [expr {$length + sqrt(($x1-$x2)*($x1-$x2) + ($y1-$y2)*($y1-$y2))}] } return $length } # ::math::geometry::movePointInDirection # # Move a point in a given direction. # # Arguments: # P the starting point # direction the direction from P # The direction is in 360-degrees going counter-clockwise, # with "straight right" being 0 degrees # dist the distance from P # # Results: # Q the point which is found by starting in P and going # in the given direction, until the distance between # P and Q is dist # # Examples: # - movePointInDirection {0 0} 45.0 10 # Result: 7.07106781187 7.07106781187 # proc ::math::geometry::movePointInDirection {P direction dist} { set x [lindex $P 0] set y [lindex $P 1] set pi [expr {4*atan(1)}] set xt [expr {$x + $dist*cos(($direction*$pi)/180)}] set yt [expr {$y + $dist*sin(($direction*$pi)/180)}] return [list $xt $yt] } # ::math::geometry::angle # # Calculates angle from the horizon (0,0)->(1,0) to a line. # # Arguments: # line a line defined by two points A and B # # Results: # angle the angle between the line (0,0)->(1,0) and (Ax,Ay)->(Bx,By). # Angle is in 360-degrees going counter-clockwise # # Examples: # - angle {10 10 15 13} # Result: 30.9637565321 # proc ::math::geometry::angle {line} { set x1 [lindex $line 0] set y1 [lindex $line 1] set x2 [lindex $line 2] set y2 [lindex $line 3] # - handle vertical lines if {$x1==$x2} {if {$y1<$y2} {return 90} else {return 270}} # - handle other lines set a [expr {atan(abs((1.0*$y1-$y2)/(1.0*$x1-$x2)))}] ; # a is between 0 and pi/2 set pi [expr {4*atan(1)}] if {$y1<=$y2} { # line is going upwards if {$x1<$x2} {set b $a} else {set b [expr {$pi-$a}]} } else { # line is going downwards if {$x1<$x2} {set b [expr {2*$pi-$a}]} else {set b [expr {$pi+$a}]} } return [expr {$b/$pi*180}] ; # convert b to degrees } ### # # Intersection procedures # ### # ::math::geometry::lineSegmentsIntersect # # Checks whether two line segments intersect. # # Arguments: # linesegment1 the first line segment # linesegment2 the second line segment # # Results: # dointersect a boolean saying whether the line segments intersect # (i.e., have any points in common) # # Examples: # - lineSegmentsIntersect {0 0 10 10} {0 10 10 0} # Result: 1 # - lineSegmentsIntersect {0 0 10 10} {20 20 20 30} # Result: 0 # - lineSegmentsIntersect {0 0 10 10} {10 10 15 15} # Result: 1 # proc ::math::geometry::lineSegmentsIntersect {linesegment1 linesegment2} { # Algorithm based on Sedgewick. set l1x1 [lindex $linesegment1 0] set l1y1 [lindex $linesegment1 1] set l1x2 [lindex $linesegment1 2] set l1y2 [lindex $linesegment1 3] set l2x1 [lindex $linesegment2 0] set l2y1 [lindex $linesegment2 1] set l2x2 [lindex $linesegment2 2] set l2y2 [lindex $linesegment2 3] return [expr {([ccw [list $l1x1 $l1y1] [list $l1x2 $l1y2] [list $l2x1 $l2y1]]\ *[ccw [list $l1x1 $l1y1] [list $l1x2 $l1y2] [list $l2x2 $l2y2]] <= 0) \ && ([ccw [list $l2x1 $l2y1] [list $l2x2 $l2y2] [list $l1x1 $l1y1]]\ *[ccw [list $l2x1 $l2y1] [list $l2x2 $l2y2] [list $l1x2 $l1y2]] <= 0)}] } # ::math::geometry::findLineSegmentIntersection # # Returns the intersection point of two line segments. # Note: may also return "coincident" and "none". # # Arguments: # linesegment1 the first line segment # linesegment2 the second line segment # # Results: # P the intersection point of linesegment1 and linesegment2. # If linesegment1 and linesegment2 have an infinite number # of points in common, the procedure returns "coincident". # If there are no intersection points, the procedure # returns "none". # # Examples: # - findLineSegmentIntersection {0 0 10 10} {0 10 10 0} # Result: 5.0 5.0 # - findLineSegmentIntersection {0 0 10 10} {20 20 20 30} # Result: none # - findLineSegmentIntersection {0 0 10 10} {10 10 15 15} # Result: 10.0 10.0 # - findLineSegmentIntersection {0 0 10 10} {5 5 15 15} # Result: coincident # proc ::math::geometry::findLineSegmentIntersection {linesegment1 linesegment2} { if {[lineSegmentsIntersect $linesegment1 $linesegment2]} { set lineintersect [findLineIntersection $linesegment1 $linesegment2] switch -- $lineintersect { "coincident" { # lines are coincident set l1x1 [lindex $linesegment1 0] set l1y1 [lindex $linesegment1 1] set l1x2 [lindex $linesegment1 2] set l1y2 [lindex $linesegment1 3] set l2x1 [lindex $linesegment2 0] set l2y1 [lindex $linesegment2 1] set l2x2 [lindex $linesegment2 2] set l2y2 [lindex $linesegment2 3] # check if the line SEGMENTS overlap # (NOT enough to check if the x-intervals overlap (vertical lines!)) set overlapx [intervalsOverlap $l1x1 $l1x2 $l2x1 $l2x2 0] set overlapy [intervalsOverlap $l1y1 $l1y2 $l2y1 $l2y2 0] if {$overlapx && $overlapy} { return "coincident" } else { return "none" } } "none" { # should never happen, because we call "lineSegmentsIntersect" first puts stderr "::math::geometry::findLineSegmentIntersection: suddenly no intersection?" return "none" } default { # lineintersect = the intersection point return $lineintersect } } } else { return "none" } } # ::math::geometry::findLineIntersection {line1 line2} # # Returns the intersection point of two lines. # Note: may also return "coincident" and "none". # # Arguments: # line1 the first line # line2 the second line # # Results: # P the intersection point of line1 and line2. # If line1 and line2 have an infinite number of points # in common, the procedure returns "coincident". # If there are no intersection points, the procedure # returns "none". # # Examples: # - findLineIntersection {0 0 10 10} {0 10 10 0} # Result: 5.0 5.0 # - findLineIntersection {0 0 10 10} {20 20 20 30} # Result: 20.0 20.0 # - findLineIntersection {0 0 10 10} {10 10 15 15} # Result: coincident # - findLineIntersection {0 0 10 10} {5 5 15 15} # Result: coincident # - findLineIntersection {0 0 10 10} {0 1 10 11} # Result: none # proc ::math::geometry::findLineIntersection {line1 line2} { # References: # http://wiki.tcl.tk/12070 (Kevin Kenny) # http://local.wasp.uwa.edu.au/~pbourke/geometry/lineline2d/ set l1x1 [lindex $line1 0] set l1y1 [lindex $line1 1] set l1x2 [lindex $line1 2] set l1y2 [lindex $line1 3] set l2x1 [lindex $line2 0] set l2y1 [lindex $line2 1] set l2x2 [lindex $line2 2] set l2y2 [lindex $line2 3] set d [expr {($l2y2 - $l2y1) * ($l1x2 - $l1x1) - ($l2x2 - $l2x1) * ($l1y2 - $l1y1)}] set na [expr {($l2x2 - $l2x1) * ($l1y1 - $l2y1) - ($l2y2 - $l2y1) * ($l1x1 - $l2x1)}] # http://local.wasp.uwa.edu.au/~pbourke/geometry/lineline2d/ if {$d == 0} { if {$na == 0} { return "coincident" } else { return "none" } } set r [list \ [expr {$l1x1 + $na * ($l1x2 - $l1x1) / $d}] \ [expr {$l1y1 + $na * ($l1y2 - $l1y1) / $d}]] return $r } # ::math::geometry::polylinesIntersect # # Checks whether two polylines intersect. # # Arguments; # polyline1 the first polyline # polyline2 the second polyline # # Results: # dointersect a boolean saying whether the polylines intersect # # Examples: # - polylinesIntersect {0 0 10 10 10 20} {0 10 10 0} # Result: 1 # - polylinesIntersect {0 0 10 10 10 20} {5 4 10 4} # Result: 0 # proc ::math::geometry::polylinesIntersect {polyline1 polyline2} { return [polylinesBoundingIntersect $polyline1 $polyline2 0] } # ::math::geometry::polylinesBoundingIntersect # # Check whether two polylines intersect, but reduce # the correctness of the result to the given granularity. # Use this for faster, but weaker, intersection checking. # # How it works: # Each polyline is split into a number of smaller polylines, # consisting of granularity points each. If a pair of those smaller # lines' bounding boxes intersect, then this procedure returns 1, # otherwise it returns 0. # # Arguments: # polyline1 the first polyline # polyline2 the second polyline # granularity the number of points in each part-polyline # granularity<=1 means full correctness # # Results: # dointersect a boolean saying whether the polylines intersect # # Examples: # - polylinesBoundingIntersect {0 0 10 10 10 20} {0 10 10 0} 2 # Result: 1 # - polylinesBoundingIntersect {0 0 10 10 10 20} {5 4 10 4} 2 # Result: 1 # proc ::math::geometry::polylinesBoundingIntersect {polyline1 polyline2 granularity} { if {$granularity<=1} { # Use perfect intersect # => first pin down where an intersection point may be, and then # call MultilinesIntersectPerfect on those parts set granularity 10 ; # optimal search granularity? set perfectmatch 1 } else { set perfectmatch 0 } # split the lines into parts consisting of $granularity points set polyline1parts {} for {set i 0} {$i<[llength $polyline1]} {incr i [expr {2*$granularity-2}]} { lappend polyline1parts [lrange $polyline1 $i [expr {$i+2*$granularity-1}]] } set polyline2parts {} for {set i 0} {$i<[llength $polyline2]} {incr i [expr {2*$granularity-2}]} { lappend polyline2parts [lrange $polyline2 $i [expr {$i+2*$granularity-1}]] } # do any of the parts overlap? foreach part1 $polyline1parts { foreach part2 $polyline2parts { set part1bbox [bbox $part1] set part2bbox [bbox $part2] if {[rectanglesOverlap [lrange $part1bbox 0 1] [lrange $part1bbox 2 3] \ [lrange $part2bbox 0 1] [lrange $part2bbox 2 3] 0]} { # the lines' bounding boxes intersect if {$perfectmatch} { foreach {l1x1 l1y1} [lrange $part1 0 end-2] {l1x2 l1y2} [lrange $part1 2 end] { foreach {l2x1 l2y1} [lrange $part2 0 end-2] {l2x2 l2y2} [lrange $part2 2 end] { if {[lineSegmentsIntersect [list $l1x1 $l1y1 $l1x2 $l1y2] \ [list $l2x1 $l2y1 $l2x2 $l2y2]]} { # two line segments overlap return 1 } } } return 0 } else { return 1 } } } } return 0 } # ::math::geometry::ccw # # PRIVATE FUNCTION USED BY OTHER FUNCTIONS. # Returns whether traversing from A to B to C is CounterClockWise # Algorithm by Sedgewick. # # Arguments: # A first point # B second point # C third point # # Reeults: # ccw a boolean saying whether traversing from A to B to C # is CounterClockWise # proc ::math::geometry::ccw {A B C} { set Ax [lindex $A 0] set Ay [lindex $A 1] set Bx [lindex $B 0] set By [lindex $B 1] set Cx [lindex $C 0] set Cy [lindex $C 1] set dx1 [expr {$Bx - $Ax}] set dy1 [expr {$By - $Ay}] set dx2 [expr {$Cx - $Ax}] set dy2 [expr {$Cy - $Ay}] if {$dx1*$dy2 > $dy1*$dx2} {return 1} if {$dx1*$dy2 < $dy1*$dx2} {return -1} if {($dx1*$dx2 < 0) || ($dy1*$dy2 < 0)} {return -1} if {($dx1*$dx1 + $dy1*$dy1) < ($dx2*$dx2+$dy2*$dy2)} {return 1} return 0 } ### # # Overlap procedures # ### # ::math::geometry::intervalsOverlap # # Check whether two intervals overlap. # Examples: # - (2,4) and (5,3) overlap with strict=0 and strict=1 # - (2,4) and (1,2) overlap with strict=0 but not with strict=1 # # Arguments: # y1,y2 the first interval # y3,y4 the second interval # strict choosing strict or non-strict interpretation # # Results: # dooverlap a boolean saying whether the intervals overlap # # Examples: # - intervalsOverlap 2 4 4 6 1 # Result: 0 # - intervalsOverlap 2 4 4 6 0 # Result: 1 # - intervalsOverlap 4 2 3 5 0 # Result: 1 # proc ::math::geometry::intervalsOverlap {y1 y2 y3 y4 strict} { if {$y1>$y2} { set temp $y1 set y1 $y2 set y2 $temp } if {$y3>$y4} { set temp $y3 set y3 $y4 set y4 $temp } if {$strict} { return [expr {$y2>$y3 && $y4>$y1}] } else { return [expr {$y2>=$y3 && $y4>=$y1}] } } # ::math::geometry::rectanglesOverlap # # Check whether two rectangles overlap (see also intervalsOverlap). # # Arguments: # P1 upper-left corner of the first rectangle # P2 lower-right corner of the first rectangle # Q1 upper-left corner of the second rectangle # Q2 lower-right corner of the second rectangle # strict choosing strict or non-strict interpretation # # Results: # dooverlap a boolean saying whether the rectangles overlap # # Examples: # - rectanglesOverlap {0 10} {10 0} {10 10} {20 0} 1 # Result: 0 # - rectanglesOverlap {0 10} {10 0} {10 10} {20 0} 0 # Result: 1 # proc ::math::geometry::rectanglesOverlap {P1 P2 Q1 Q2 strict} { set b1x1 [lindex $P1 0] set b1y1 [lindex $P1 1] set b1x2 [lindex $P2 0] set b1y2 [lindex $P2 1] set b2x1 [lindex $Q1 0] set b2y1 [lindex $Q1 1] set b2x2 [lindex $Q2 0] set b2y2 [lindex $Q2 1] # ensure b1x1<=b1x2 etc. if {$b1x1 > $b1x2} { set temp $b1x1 set b1x1 $b1x2 set b1x2 $temp } if {$b1y1 > $b1y2} { set temp $b1y1 set b1y1 $b1y2 set b1y2 $temp } if {$b2x1 > $b2x2} { set temp $b2x1 set b2x1 $b2x2 set b2x2 $temp } if {$b2y1 > $b2y2} { set temp $b2y1 set b2y1 $b2y2 set b2y2 $temp } # Check if the boxes intersect # (From: Cormen, Leiserson, and Rivests' "Algorithms", page 889) if {$strict} { return [expr {($b1x2>$b2x1) && ($b2x2>$b1x1) \ && ($b1y2>$b2y1) && ($b2y2>$b1y1)}] } else { return [expr {($b1x2>=$b2x1) && ($b2x2>=$b1x1) \ && ($b1y2>=$b2y1) && ($b2y2>=$b1y1)}] } } # ::math::geometry::bbox # # Calculate the bounding box of a polyline. # # Arguments: # polyline a polyline # # Results: # x1,y1,x2,y2 four coordinates where (x1,y1) is the upper-left corner # of the bounding box, and (x2,y2) is the lower-right corner # # Examples: # - bbox {0 10 4 1 6 23 -12 5} # Result: -12 1 6 23 # proc ::math::geometry::bbox {polyline} { set minX [lindex $polyline 0] set maxX $minX set minY [lindex $polyline 1] set maxY $minY foreach {x y} $polyline { if {$x < $minX} {set minX $x} if {$x > $maxX} {set maxX $x} if {$y < $minY} {set minY $y} if {$y > $maxY} {set maxY $y} } return [list $minX $minY $maxX $maxY] } # ::math::geometry::ClosedPolygon # # Return a closed polygon - used internally # # Arguments: # polygon a polygon # # Results: # closedpolygon a polygon whose first and last vertices # coincide # proc ::math::geometry::ClosedPolygon {polygon} { if { [lindex $polygon 0] != [lindex $polygon end-1] || [lindex $polygon 1] != [lindex $polygon end] } { return [concat $polygon [lrange $polygon 0 1]] } else { return $polygon } } # ::math::geometry::pointInsidePolygon # # Determine if a point is completely inside a polygon. If the point # touches the polygon, then the point is not complete inside the # polygon. # # Arguments: # P a point # polygon a polygon # # Results: # isinside a boolean saying whether the point is # completely inside the polygon or not # # Examples: # - pointInsidePolygon {5 5} {4 4 4 6 6 6 6 4} # Result: 1 # - pointInsidePolygon {5 5} {6 6 6 7 7 7} # Result: 0 # proc ::math::geometry::pointInsidePolygon {P polygon} { # check if P is on one of the polygon's sides (if so, P is not # inside the polygon) set closedPolygon [ClosedPolygon $polygon] foreach {x1 y1} [lrange $closedPolygon 0 end-2] {x2 y2} [lrange $closedPolygon 2 end] { if {[calculateDistanceToLineSegment $P [list $x1 $y1 $x2 $y2]]<0.0000001} { return 0 } } # Algorithm # # Consider a straight line going from P to a point far away from both # P and the polygon (in particular outside the polygon). # - If the line intersects with 0 of the polygon's sides, then # P must be outside the polygon. # - If the line intersects with 1 of the polygon's sides, then # P must be inside the polygon (since the other end of the line # is outside the polygon). # - If the line intersects with 2 of the polygon's sides, then # the line must pass into one polygon area and out of it again, # and hence P is outside the polygon. # - In general: if the line intersects with the polygon's sides an odd # number of times, then P is inside the polygon. Note: we also have # to check whether the line crosses one of the polygon's # bend points for the same reason. # get point far away and define the line set polygonBbox [bbox $polygon] set pointFarAway [list \ [expr {[lindex $polygonBbox 0]-[lindex $polygonBbox 2]}] \ [expr {[lindex $polygonBbox 1]-0.1*[lindex $polygonBbox 3]}]] set infinityLine [concat $pointFarAway $P] # calculate number of intersections set noOfIntersections 0 # 1. count intersections between the line and the polygon's sides foreach {x1 y1} [lrange $closedPolygon 0 end-2] {x2 y2} [lrange $closedPolygon 2 end] { if {[lineSegmentsIntersect $infinityLine [list $x1 $y1 $x2 $y2]]} { incr noOfIntersections } } # 2. count intersections between the line and the polygon's points foreach {x1 y1} $closedPolygon { if {[calculateDistanceToLineSegment [list $x1 $y1] $infinityLine]<0.0000001} { incr noOfIntersections } } return [expr {$noOfIntersections % 2}] } # ::math::geometry::rectangleInsidePolygon # # Determine if a rectangle is completely inside a polygon. If polygon # touches the rectangle, then the rectangle is not complete inside the # polygon. # # Arguments: # P1 upper-left corner of the rectangle # P2 lower-right corner of the rectangle # polygon a polygon # # Results: # isinside a boolean saying whether the rectangle is # completely inside the polygon or not # # Examples: # - rectangleInsidePolygon {0 10} {10 0} {-10 -10 0 11 11 11 11 0} # Result: 1 # - rectangleInsidePolygon {0 0} {0 0} {-16 14 5 -16 -16 -25 -21 16 -19 24} # Result: 1 # - rectangleInsidePolygon {0 0} {0 0} {2 2 2 4 4 4 4 2} # Result: 0 # proc ::math::geometry::rectangleInsidePolygon {P1 P2 polygon} { # get coordinates of rectangle set bx1 [lindex $P1 0] set by1 [lindex $P1 1] set bx2 [lindex $P2 0] set by2 [lindex $P2 1] # if rectangle does not overlap with the bbox of polygon, then the # rectangle cannot be inside the polygon (this is a quick way to # get an answer in many cases) set polygonBbox [bbox $polygon] set polygonP1x [lindex $polygonBbox 0] set polygonP1y [lindex $polygonBbox 1] set polygonP2x [lindex $polygonBbox 2] set polygonP2y [lindex $polygonBbox 3] if {![rectanglesOverlap [list $bx1 $by1] [list $bx2 $by2] \ [list $polygonP1x $polygonP1y] [list $polygonP2x $polygonP2y] 0]} { return 0 } # 1. if one of the points of the polygon is inside the rectangle, # then the rectangle cannot be inside the polygon foreach {x y} $polygon { if {$bx1<$x && $x<$bx2 && $by1<$y && $y<$by2} { return 0 } } # 2. if one of the line segments of the polygon intersect with the # rectangle, then the rectangle cannot be inside the polygon set rectanglePolyline [list $bx1 $by1 $bx2 $by1 $bx2 $by2 $bx1 $by2 $bx1 $by1] set closedPolygon [ClosedPolygon $polygon] if {[polylinesIntersect $closedPolygon $rectanglePolyline]} { return 0 } # at this point we know that: # 1. the polygon has no points inside the rectangle # 2. the polygon's sides don't intersect with the rectangle # therefore: # either the rectangle is (completely) inside the polygon, or # the rectangle is (completely) outside the polygon # final test: if one of the points on the rectangle is inside the # polygon, then the whole rectangle must be inside the rectangle return [pointInsidePolygon [list $bx1 $by1] $polygon] } # ::math::geometry::areaPolygon # # Determine the area enclosed by a (non-complex) polygon # # Arguments: # polygon a polygon # # Results: # area the area enclosed by the polygon # # Examples: # - areaPolygon {-10 -10 10 -10 10 10 -10 10} # Result: 400 # proc ::math::geometry::areaPolygon {polygon} { foreach {a1 a2 b1 b2} $polygon {break} set area 0.0 foreach {c1 c2} [lrange $polygon 4 end] { set area [expr {$area + $b1*$c2 - $b2*$c1}] set b1 $c1 set b2 $c2 } expr {0.5*abs($area)} } # # ## ### ##### ############# namespace eval ::math::geometry { variable pi [expr { 4 * atan(1) }] variable torad [expr { (4 * atan(1)) / 180.0 }] variable todeg [expr { 180.0 / (4 * atan(1)) }] namespace export \ + - s* direction v h p between distance length \ nwse rect octant findLineSegmentIntersection \ findLineIntersection bbox x y conjx conjy } package provide math::geometry 1.1.2 tcllib-1.15/modules/math/misc.tcl0000644000175000017500000002143612077663116016306 0ustar sergeisergei# math.tcl -- # # Collection of math functions. # # Copyright (c) 1998-2000 by Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: misc.tcl,v 1.6 2005/10/10 14:02:47 arjenmarkus Exp $ package require Tcl 8.2 ;# uses [lindex $l end-$integer] namespace eval ::math { } # ::math::cov -- # # Return the coefficient of variation of three or more values # # Arguments: # val1 first value # val2 second value # args other values # # Results: # cov coefficient of variation expressed as percent value proc ::math::cov {val1 val2 args} { set sum [ expr { $val1+$val2 } ] set N [ expr { [ llength $args ] + 2 } ] foreach val $args { set sum [ expr { $sum+$val } ] } set mean [ expr { $sum/$N } ] set sigma_sq 0 foreach val [ concat $val1 $val2 $args ] { set sigma_sq [ expr { $sigma_sq+pow(($val-$mean),2) } ] } set sigma_sq [ expr { $sigma_sq/($N-1) } ] set sigma [ expr { sqrt($sigma_sq) } ] if { $mean != 0.0 } { set cov [ expr { ($sigma/$mean)*100 } ] } else { return -code error -errorinfo "Cov undefined for data with zero mean" -errorcode {ARITH DOMAIN} } set cov } # ::math::fibonacci -- # # Return the n'th fibonacci number. # # Arguments: # n The index in the sequence to compute. # # Results: # fib The n'th fibonacci number. proc ::math::fibonacci {n} { if { $n == 0 } { return 0 } else { set prev0 0 set prev1 1 for {set i 1} {$i < $n} {incr i} { set tmp $prev1 incr prev1 $prev0 set prev0 $tmp } return $prev1 } } # ::math::integrate -- # # calculate the area under a curve defined by a set of (x,y) data pairs. # the x data must increase monotonically throughout the data set for the # calculation to be meaningful, therefore the monotonic condition is # tested, and an error is thrown if the x value is found to be # decreasing. # # Arguments: # xy_pairs list of x y pairs (eg, 0 0 10 10 20 20 ...); at least 5 # data pairs are required, and if the number of data # pairs is even, a padding value of (x0, 0) will be # added. # # Results: # result A two-element list consisting of the area and error # bound (calculation is "Simpson's rule") proc ::math::integrate { xy_pairs } { set length [ llength $xy_pairs ] if { $length < 10 } { return -code error "at least 5 x,y pairs must be given" } ;## are we dealing with x,y pairs? if { [ expr {$length % 2} ] } { return -code error "unmatched xy pair in input" } ;## are there an even number of pairs? Augment. if { ! [ expr {$length % 4} ] } { set xy_pairs [ concat [ lindex $xy_pairs 0 ] 0 $xy_pairs ] } set x0 [ lindex $xy_pairs 0 ] set x1 [ lindex $xy_pairs 2 ] set xn [ lindex $xy_pairs end-1 ] set xnminus1 [ lindex $xy_pairs end-3 ] if { $x1 < $x0 } { return -code error "monotonicity broken by x1" } if { $xn < $xnminus1 } { return -code error "monotonicity broken by xn" } ;## handle the assymetrical elements 0, n, and n-1. set sum [ expr {[ lindex $xy_pairs 1 ] + [ lindex $xy_pairs end ]} ] set sum [ expr {$sum + (4*[ lindex $xy_pairs end-2 ])} ] set data [ lrange $xy_pairs 2 end-4 ] set xmax $x1 set i 1 foreach {x1 y1 x2 y2} $data { incr i if { $x1 < $xmax } { return -code error "monotonicity broken by x$i" } set xmax $x1 incr i if { $x2 < $xmax } { return -code error "monotonicity broken by x$i" } set xmax $x2 set sum [ expr {$sum + (4*$y1) + (2*$y2)} ] } if { $xmax > $xnminus1 } { return -code error "monotonicity broken by xn-1" } set h [ expr { ( $xn - $x0 ) / $i } ] set area [ expr { ( $h / 3.0 ) * $sum } ] set err_bound [ expr { ( ( $xn - $x0 ) / 180.0 ) * pow($h,4) * $xn } ] return [ list $area $err_bound ] } # ::math::max -- # # Return the maximum of two or more values # # Arguments: # val first value # args other values # # Results: # max maximum value proc ::math::max {val args} { set max $val foreach val $args { if { $val > $max } { set max $val } } set max } # ::math::mean -- # # Return the mean of two or more values # # Arguments: # val first value # args other values # # Results: # mean arithmetic mean value proc ::math::mean {val args} { set sum $val set N [ expr { [ llength $args ] + 1 } ] foreach val $args { set sum [ expr { $sum + $val } ] } set mean [expr { double($sum) / $N }] } # ::math::min -- # # Return the minimum of two or more values # # Arguments: # val first value # args other values # # Results: # min minimum value proc ::math::min {val args} { set min $val foreach val $args { if { $val < $min } { set min $val } } set min } # ::math::product -- # # Return the product of one or more values # # Arguments: # val first value # args other values # # Results: # prod product of multiplying all values in the list proc ::math::product {val args} { set prod $val foreach val $args { set prod [ expr { $prod*$val } ] } set prod } # ::math::random -- # # Return a random number in a given range. # # Arguments: # args optional arguments that specify the range within which to # choose a number: # (null) choose a number between 0 and 1 # val choose a number between 0 and val # val1 val2 choose a number between val1 and val2 # # Results: # num a random number in the range. proc ::math::random {args} { set num [expr {rand()}] if { [llength $args] == 0 } { return $num } elseif { [llength $args] == 1 } { return [expr {int($num * [lindex $args 0])}] } elseif { [llength $args] == 2 } { foreach {lower upper} $args break set range [expr {$upper - $lower}] return [expr {int($num * $range) + $lower}] } else { set fn [lindex [info level 0] 0] error "wrong # args: should be \"$fn ?value1? ?value2?\"" } } # ::math::sigma -- # # Return the standard deviation of three or more values # # Arguments: # val1 first value # val2 second value # args other values # # Results: # sigma population standard deviation value proc ::math::sigma {val1 val2 args} { set sum [ expr { $val1+$val2 } ] set N [ expr { [ llength $args ] + 2 } ] foreach val $args { set sum [ expr { $sum+$val } ] } set mean [ expr { $sum/$N } ] set sigma_sq 0 foreach val [ concat $val1 $val2 $args ] { set sigma_sq [ expr { $sigma_sq+pow(($val-$mean),2) } ] } set sigma_sq [ expr { $sigma_sq/($N-1) } ] set sigma [ expr { sqrt($sigma_sq) } ] set sigma } # ::math::stats -- # # Return the mean, standard deviation, and coefficient of variation as # percent, as a list. # # Arguments: # val1 first value # val2 first value # args all other values # # Results: # {mean stddev coefvar} proc ::math::stats {val1 val2 args} { set sum [ expr { $val1+$val2 } ] set N [ expr { [ llength $args ] + 2 } ] foreach val $args { set sum [ expr { $sum+$val } ] } set mean [ expr { $sum/$N } ] set sigma_sq 0 foreach val [ concat $val1 $val2 $args ] { set sigma_sq [ expr { $sigma_sq+pow(($val-$mean),2) } ] } set sigma_sq [ expr { $sigma_sq/($N-1) } ] set sigma [ expr { sqrt($sigma_sq) } ] set cov [ expr { ($sigma/$mean)*100 } ] return [ list $mean $sigma $cov ] } # ::math::sum -- # # Return the sum of one or more values # # Arguments: # val first value # args all other values # # Results: # sum arithmetic sum of all values in args proc ::math::sum {val args} { set sum $val foreach val $args { set sum [ expr { $sum+$val } ] } set sum } #---------------------------------------------------------------------- # # ::math::expectDouble -- # # Format an error message that an argument was expected to be # double and wasn't # # Parameters: # arg -- Misformatted argument # # Results: # Returns an appropriate error message # # Side effects: # None. # #---------------------------------------------------------------------- proc ::math::expectDouble { arg } { return [format "expected a floating-point number but found \"%.50s\"" $arg] } #---------------------------------------------------------------------- # # ::math::expectInteger -- # # Format an error message that an argument was expected to be # integer and wasn't # # Parameters: # arg -- Misformatted argument # # Results: # Returns an appropriate error message # # Side effects: # None. # #---------------------------------------------------------------------- proc ::math::expectInteger { arg } { return [format "expected an integer but found \"%.50s\"" $arg] } tcllib-1.15/modules/math/rational_funcs.tcl0000755000175000017500000002577212077663116020374 0ustar sergeisergei# rational_funcs.tcl -- # Implement procedures to deal with rational functions # package require math::polynomials namespace eval ::math::rationalfunctions { variable count 0 ;# Count the number of specific commands namespace eval v {} namespace export rationalFunction ratioCmd evalRatio \ coeffsNumerator coeffsDenominator \ derivRatio \ addRatio subRatio multRatio \ divRatio namespace import ::math::polynomials::* } # rationalFunction -- # Return a rational function definition # # Arguments: # num The coefficients of the numerator # den The coefficients of the denominator # Result: # Rational function definition # proc ::math::rationalfunctions::rationalFunction {num den} { foreach coeffs [list $num $den] { foreach coeff $coeffs { if { ! [string is double -strict $coeff] } { return -code error "Coefficients must be real numbers" } } } # # The leading coefficient must be non-zero # return [list RATIONAL_FUNCTION [polynomial $num] [polynomial $den]] } # ratioCmd -- # Return a procedure that implements a rational function evaluation # # Arguments: # num The coefficients of the numerator # den The coefficients of the denominator # Result: # New procedure # proc ::math::rationalfunctions::ratioCmd {num {den {}}} { variable count if { [llength $den] == 0 } { if { [lindex $num 0] == "RATIONAL_FUNCTION" } { set den [lindex $num 2] set num [lindex $num 1] } } set degree1 [expr {[llength $num]-1}] set degree2 [expr {[llength $num]-1}] set body "expr \{([join $num +\$x*(][string repeat ) $degree1])/\ (double([join $den +\$x*(][string repeat ) $degree2])\}" incr count set name "::math::rationalfunctions::v::RATIO$count" proc $name {x} $body return $name } # evalRatio -- # Evaluate a rational function at a given coordinate # # Arguments: # ratio Rational function definition # x Coordinate # Result: # Value at x # proc ::math::rationalfunctions::evalRatio {ratio x} { if { [lindex $ratio 0] != "RATIONAL_FUNCTION" } { return -code error "Not a rational function" } if { ! [string is double $x] } { return -code error "Coordinate must be a real number" } set num 0.0 foreach c [lindex [lindex $ratio 1] 1] { set num [expr {$num*$x+$c}] } set den 0.0 foreach c [lindex [lindex $ratio 2] 1] { set den [expr {$den*$x+$c}] } return [expr {$num/double($den)}] } # coeffsNumerator -- # Return the coefficients of the numerator # # Arguments: # ratio Rational function definition # Result: # The coefficients in ascending order # proc ::math::rationalfunctions::coeffsNumerator {ratio} { if { [lindex $ratio 0] != "RATIONAL_FUNCTION" } { return -code error "Not a rational function" } set polyn [lindex $ratio 1] return [allCoeffsPolyn $polyn] } # coeffsDenominator -- # Return the coefficients of the denominator # # Arguments: # ratio Rational function definition # Result: # The coefficients in ascending order # proc ::math::rationalfunctions::coeffsDenominator {ratio} { if { [lindex $ratio 0] != "RATIONAL_FUNCTION" } { return -code error "Not a rational function" } set polyn [lindex $ratio 2] return [allCoeffsPolyn $polyn] } # derivRatio -- # Return the derivative of the rational function # # Arguments: # polyn Polynomial definition # Result: # The new polynomial # proc ::math::rationalfunctions::derivRatio {ratio} { if { [lindex $ratio 0] != "RATIONAL_FUNCTION" } { return -code error "Not a rational function" } set num_polyn [lindex $ratio 1] set den_polyn [lindex $ratio 2] set num_deriv [derivPolyn $num_polyn] set den_deriv [derivPolyn $den_polyn] set num [subPolyn [multPolyn $num_deriv $den_polyn] \ [multPolyn $den_deriv $num_polyn] ] set den [multPolyn $den_polyn $den_polyn] return [list RATIONAL_FUNCTION $num $den] } # addRatio -- # Add two rational functions and return the result # # Arguments: # ratio1 First rational function or a scalar # ratio2 Second rational function or a scalar # Result: # The sum of the two functions # Note: # TODO: Check for the same denominator # proc ::math::rationalfunctions::addRatio {ratio1 ratio2} { if { [llength $ratio1] == 1 && [string is double -strict $ratio1] } { set polyn1 [rationalFunction $ratio1 1.0] } if { [llength $ratio2] == 1 && [string is double -strict $ratio2] } { set ratio2 [rationalFunction $ratio1 1.0] } if { [lindex $ratio1 0] != "RATIONAL_FUNCTION" || [lindex $ratio2 0] != "RATIONAL_FUNCTION" } { return -code error "Both arguments must be rational functions or a real number" } set num1 [lindex $ratio1 1] set den1 [lindex $ratio1 2] set num2 [lindex $ratio2 1] set den2 [lindex $ratio2 2] set newnum [addPolyn [multPolyn $num1 $den2] \ [multPolyn $num2 $den1] ] set newden [multPolyn $den1 $den2] return [list RATIONAL_FUNCTION $newnum $newden] } # subRatio -- # Subtract two rational functions and return the result # # Arguments: # ratio1 First rational function or a scalar # ratio2 Second rational function or a scalar # Result: # The difference of the two functions # Note: # TODO: Check for the same denominator # proc ::math::rationalfunctions::subRatio {ratio1 ratio2} { if { [llength $ratio1] == 1 && [string is double -strict $ratio1] } { set polyn1 [rationalFunction $ratio1 1.0] } if { [llength $ratio2] == 1 && [string is double -strict $ratio2] } { set ratio2 [rationalFunction $ratio1 1.0] } if { [lindex $ratio1 0] != "RATIONAL_FUNCTION" || [lindex $ratio2 0] != "RATIONAL_FUNCTION" } { return -code error "Both arguments must be rational functions or a real number" } set num1 [lindex $ratio1 1] set den1 [lindex $ratio1 2] set num2 [lindex $ratio2 1] set den2 [lindex $ratio2 2] set newnum [subPolyn [multPolyn $num1 $den2] \ [multPolyn $num2 $den1] ] set newden [multPolyn $den1 $den2] return [list RATIONAL_FUNCTION $newnum $newden] } # multRatio -- # Multiply two rational functions and return the result # # Arguments: # ratio1 First rational function or a scalar # ratio2 Second rational function or a scalar # Result: # The product of the two functions # Note: # TODO: Check for the same denominator # proc ::math::rationalfunctions::multRatio {ratio1 ratio2} { if { [llength $ratio1] == 1 && [string is double -strict $ratio1] } { set polyn1 [rationalFunction $ratio1 1.0] } if { [llength $ratio2] == 1 && [string is double -strict $ratio2] } { set ratio2 [rationalFunction $ratio1 1.0] } if { [lindex $ratio1 0] != "RATIONAL_FUNCTION" || [lindex $ratio2 0] != "RATIONAL_FUNCTION" } { return -code error "Both arguments must be rational functions or a real number" } set num1 [lindex $ratio1 1] set den1 [lindex $ratio1 2] set num2 [lindex $ratio2 1] set den2 [lindex $ratio2 2] set newnum [multPolyn $num1 $num2] set newden [multPolyn $den1 $den2] return [list RATIONAL_FUNCTION $newnum $newden] } # divRatio -- # Divide two rational functions and return the result # # Arguments: # ratio1 First rational function or a scalar # ratio2 Second rational function or a scalar # Result: # The quotient of the two functions # Note: # TODO: Check for the same denominator # proc ::math::rationalfunctions::divRatio {ratio1 ratio2} { if { [llength $ratio1] == 1 && [string is double -strict $ratio1] } { set polyn1 [rationalFunction $ratio1 1.0] } if { [llength $ratio2] == 1 && [string is double -strict $ratio2] } { set ratio2 [rationalFunction $ratio1 1.0] } if { [lindex $ratio1 0] != "RATIONAL_FUNCTION" || [lindex $ratio2 0] != "RATIONAL_FUNCTION" } { return -code error "Both arguments must be rational functions or a real number" } set num1 [lindex $ratio1 1] set den1 [lindex $ratio1 2] set num2 [lindex $ratio2 1] set den2 [lindex $ratio2 2] set newnum [multPolyn $num1 $den2] set newden [multPolyn $num2 $den1] return [list RATIONAL_FUNCTION $newnum $newden] } # # Announce our presence # package provide math::rationalfunctions 1.0.1 # some tests -- # if { 0 } { set prec $::tcl_precision if {![package vsatisfies [package provide Tcl] 8.5]} { set ::tcl_precision 17 } else { set ::tcl_precision 0 } set f1 [::math::rationalfunctions::rationalFunction {1 2 3} {1 4}] set f2 [::math::rationalfunctions::rationalFunction {1 2 3 0} {1 4}] set f3 [::math::rationalfunctions::rationalFunction {0 0 0 0} {1}] set f4 [::math::rationalfunctions::rationalFunction {5 7} {1}] set cmdf1 [::math::rationalfunctions::ratioCmd {1 2 3} {1 4}] foreach x {0 1 2 3 4 5} { puts "[::math::rationalfunctions::evalRatio $f1 $x] -- \ [expr {(1.0+2.0*$x+3.0*$x*$x)/double(1.0+4.0*$x)}] -- \ [$cmdf1 $x] -- [::math::rationalfunctions::evalRatio $f3 $x]" } puts "All coefficients = [::math::rationalfunctions::coeffsNumerator $f2]" puts " [::math::rationalfunctions::coeffsDenominator $f2]" puts "Derivative = [::math::rationalfunctions::derivRatio $f1]" puts "Add: [::math::rationalfunctions::addRatio $f1 $f4]" puts "Add: [::math::rationalfunctions::addRatio $f4 $f1]" puts "Subtract: [::math::rationalfunctions::subRatio $f1 $f4]" puts "Multiply: [::math::rationalfunctions::multRatio $f1 $f4]" set f1 [::math::rationalfunctions::rationalFunction {1 2 3} 1] set f2 [::math::rationalfunctions::rationalFunction {0 1} 1] puts "Divide: [::math::rationalfunctions::divRatio $f1 $f2]" set f1 [::math::rationalfunctions::rationalFunction {1 2 3} 1] set f2 [::math::rationalfunctions::rationalFunction {1 1} {1 2}] puts "Divide: [::math::rationalfunctions::divRatio $f1 $f2]" set f1 [::math::rationalfunctions::rationalFunction {1 2 3} 1] set f2 [::math::rationalfunctions::rationalFunction {0 1} {0 0 1}] set f3 [::math::rationalfunctions::divRatio $f2 $f1] set coeffs [::math::rationalfunctions::coeffsNumerator $f3] puts "Coefficients: $coeffs" set f3 [::math::rationalfunctions::divRatio $f1 $f2] set coeffs [::math::rationalfunctions::coeffsNumerator $f3] puts "Coefficients: $coeffs" set f1 [::math::rationalfunctions::rationalFunction {1 2 3} {1 2}] set f2 [::math::rationalfunctions::rationalFunction {0} {1}] set f3 [::math::rationalfunctions::divRatio $f2 $f1] set coeffs [::math::rationalfunctions::coeffsNumerator $f3] puts "Coefficients: $coeffs" puts "Eval null function: [::math::rationalfunctions::evalRatio $f2 1]" set ::tcl_precision $prec } tcllib-1.15/modules/math/kruskal.tcl0000755000175000017500000001012612077663116017024 0ustar sergeisergei# kruskal.tcl -- # Procedures related to ranking and the Kruskal-Wallis test # # test-Kruskal-Wallis -- # Perform a one-way analysis of variance according # to Kruskal-Wallis # # Arguments: # confidence Confidence level (between 0 and 1) # args Two or more lists of data # # Result: # 0 if the medians of the groups differ, 1 if they # are the same (accept the null hypothesis) # proc ::math::statistics::test-Kruskal-Wallis {confidence args} { foreach {H p} [eval analyse-Kruskal-Wallis $args] {break} expr {$p < 1.0 - $confidence} } # analyse-Kruskal-Wallis -- # Perform a one-way analysis of variance according # to Kruskal-Wallis and return the details # # Arguments: # args Two or more lists of data # # Result: # Kruskal-Wallis statistic H and the probability p # that this value occurs if the # proc ::math::statistics::analyse-Kruskal-Wallis {args} { set setCount [llength $args] # # Rank the data with respect to the whole set # set rankList [eval group-rank $args] set length [llength $rankList] # # Re-establish original sets of values, but using the ranks # foreach item $rankList { lappend rankValues([lindex $item 0]) [lindex $item 2] } # # Now compute H # set H 0 for {set i 0} {$i < $setCount} {incr i} { set total [expr [join $rankValues($i) +]] set count [llength $rankValues($i)] set H [expr {$H + pow($total,2)/double($count)}] } set H [expr {$H*(12.0/($length*($length + 1))) - (3*($length + 1))}] incr setCount -1 set p [expr {1 - [::math::statistics::cdf-chisquare $setCount $H]}] return [list $H $p] } # group-rank -- # Rank groups of data with respect to the whole set # # Arguments: # args Two or more lists of data # # Result: # List of ranking data: for each data item, the group-ID, # the value and the rank (may be a fraction, in case of ties) # proc ::math::statistics::group-rank {args} { set index 0 set rankList [list] set setCount [llength $args] # # Read lists of values # foreach item $args { set values($index) [lindex $args $index] # # Prepare ranking with rank=0 # foreach value $values($index) { lappend rankList [list $index $value 0] } incr index 1 } # # Sort the values # set rankList [lsort -real -index 1 $rankList] # # Assign the ranks (disregarding ties) # set length [llength $rankList] for {set i 0} {$i < $length} {incr i} { lset rankList $i 2 [expr {$i + 1}] } # # Value of the previous list element # set prevValue {} # # List of indices of list elements having the same value (ties) # set equalIndex [list] # # Test for ties and re-assign mean ranks for tied values # for {set i 0} {$i < $length} {incr i} { set value [lindex $rankList $i 1] if {($value != $prevValue) && ($i > 0) && ([llength $equalIndex] > 0)} { # # We are still missing the first tied value # set j [lindex $equalIndex 0] incr j -1 set equalIndex [linsert $equalIndex 0 $j] # # Re-assign rank as mean rank of tied values # set firstRank [lindex $rankList [lindex $equalIndex 0] 2] set lastRank [lindex $rankList [lindex $equalIndex end] 2] set newRank [expr {($firstRank+$lastRank)/2.0}] foreach j $equalIndex { lset rankList $j 2 $newRank } # # Clear list of equal elements # set equalIndex [list] } elseif {$value == $prevValue} { # # Remember index of equal value element # lappend equalIndex $i } set prevValue $value } return $rankList } tcllib-1.15/modules/math/liststat.tcl0000755000175000017500000000470412077663116017224 0ustar sergeisergei# liststat.tcl -- # # Set of operations on lists, meant for the statistics package # # version 0.1: initial implementation, january 2003 namespace eval ::math::statistics {} # filter -- # Filter a list based on whether an expression is true for # an element or not # # Arguments: # varname Name of the variable that represents the data in the # expression # data List to be filtered # expression (Logical) expression that is to be evaluated # # Result: # List of those elements for which the expression is true # TODO: # Substitute local variables in caller # proc ::math::statistics::filter { varname data expression } { upvar $varname _x_ set result {} set _x_ \$_x_ set expression [uplevel subst -nocommands [list $expression]] foreach _x_ $data { # FRINK: nocheck if $expression { lappend result $_x_ } } return $result } # map -- # Map the elements of a list according to an expression # # Arguments: # varname Name of the variable that represents the data in the # expression # data List whose elements must be transformed (mapped) # expression Expression that is evaluated with $varname an # element in the list # # Result: # List of transformed elements # proc ::math::statistics::map { varname data expression } { upvar $varname _x_ set result {} set _x_ \$_x_ set expression [uplevel subst -nocommands [list $expression]] foreach _x_ $data { # FRINK: nocheck lappend result [expr $expression] } return $result } # samplescount -- # Count the elements in each sublist and return a list of counts # # Arguments: # varname Name of the variable that represents the data in the # expression # list List of lists # expression Expression in that is evaluated with $varname an # element in the sublist (defaults to "true") # # Result: # List of transformed elements # proc ::math::statistics::samplescount { varname list {expression 1} } { upvar $varname _x_ set result {} set _x_ \$_x_ set expression [uplevel subst -nocommands [list $expression]] foreach data $list { set number 0 foreach _x_ $data { # FRINK: nocheck if $expression { incr number } } lappend result $number } return $result } # End of list procedures tcllib-1.15/modules/math/qcomplex.test0000755000175000017500000001514012077663116017376 0ustar sergeisergei# -*- tcl -*- # Tests for complex number functions in math library -*- tcl -*- # # This file contains a collection of tests for one or more of the Tcllib # procedures. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # $Id: qcomplex.test,v 1.10 2006/10/09 21:41:41 andreas_kupries Exp $ # # Copyright (c) 2004 by Arjen Markus # All rights reserved. # # Note: # By evaluating the tests in a different namespace than global, # we assure that the namespace issue (Bug #...) is checked. # # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.2 testsNeedTcltest 2.1 support { useLocal math.tcl math } testing { useLocal qcomplex.tcl math::complexnumbers } # ------------------------------------------------------------------------- namespace import -force ::math::complexnumbers::* proc matchNumbers { expected actual } { set match 1 foreach a $actual e $expected { if { abs($a-$e) > 1.0e-10 } { set match 0 break } } return $match } customMatch numbers matchNumbers # ------------------------------------------------------------------------- # # Test cases: arithmetical operations # test "Complex-1.1" "Arithmetic - add 1" -match numbers -body { set a [complex 1 0] set b [complex 0 1] set c [+ $a $b] } -result [complex 1 1] test "Complex-1.2" "Arithmetic - add 2" -match numbers -body { set a [complex 1.1 -1.1] set b [complex 1.1 1.1] set c [+ $a $b] } -result [complex 2.2 0] test "Complex-1.3" "Arithmetic - subtract 1" -match numbers -body { set a [complex 1 0] set b [complex 0 1] set c [- $a $b] } -result [complex 1 -1] test "Complex-1.4" "Arithmetic - subtract 2" -match numbers -body { set a [complex 1.1 -1.1] set b [complex 1.1 1.1] set c [- $a $b] } -result [complex 0 -2.2] test "Complex-1.5" "Arithmetic - multiply 1" -match numbers -body { set a [complex 1 -1] set b [complex 0 1] set c [* $a $b] } -result [complex 1 1] test "Complex-1.6" "Arithmetic - multiply 2" -match numbers -body { set a [complex 0 1] set b [complex 0 1] set c [* $a $b] } -result [complex -1 0] test "Complex-1.7" "Arithmetic - divide 1" -match numbers -body { set a [complex 1.1 1] set b [complex 1.1 1] set c [/ $a $b] } -result [complex 1 0] test "Complex-1.8" "Arithmetic - divide 2" -match numbers -body { set a [complex 1 1] set b [complex 0 1] set c [/ $a $b] } -result [complex 1 -1] test "Complex-1.9" "Arithmetic - conjugate 1" -match numbers -body { set a [complex 0 1] set c [conj $a] } -result [complex 0 -1] test "Complex-1.10" "Arithmetic - conjugate 2" -match numbers -body { set a [complex 1 0] set c [conj $a] } -result [complex 1 0] test "Complex-2.1" "Conversion - real 1" -match numbers -body { set a [complex 1 2] set c [real $a] } -result 1 test "Complex-2.2" "Conversion - real 2" -match numbers -body { set a [complex 0 2] set c [real $a] } -result 0 test "Complex-2.3" "Conversion - imag 1" -match numbers -body { set a [complex 1 2] set c [imag $a] } -result 2 test "Complex-2.4" "Conversion - imag 2" -match numbers -body { set a [complex 0 2] set c [imag $a] } -result 2 test "Complex-2.5" "Conversion - mod 1" -match numbers -body { set a [complex 0 1] set c [mod $a] } -result 1 test "Complex-2.6" "Conversion - mod 2" -match numbers -body { set a [complex 3 4] set c [mod $a] } -result 5 test "Complex-2.7" "Conversion - arg 1" -match numbers -body { set a [complex 0 1] set c [arg $a] } -result [expr {2.0*atan(1.0)}] test "Complex-2.8" "Conversion - arg 2" -match numbers -body { set a [complex 1 1] set c [arg $a] } -result [expr {atan(1.0)}] test "Complex-2.9" "Conversion - tostring" -body { set c "[tostring [complex 1 0]] " append c "[tostring [complex 0 1]] " append c "[tostring [complex 1 1]] " append c "[tostring [complex 1 -1]] " append c "[tostring [complex 0 -1]] " append c "[tostring [complex 2 -3]] " } -result "1 i 1+i 1-i -i 2-3i " test "Complex-3.1" "Elementary - exp 1" -match numbers -body { set a [complex 1 0] set c [exp $a] } -result [complex [expr {exp(1.0)}] 0.0] test "Complex-3.2" "Elementary - exp 2" -match numbers -body { set a [complex 0 1] set c [exp $a] } -result [complex [expr {cos(1.0)}] [expr {sin(1.0)}]] test "Complex-3.3" "Elementary - sin 1" -match numbers -body { set a [complex 1 0] set c [sin $a] } -result [complex [expr {sin(1.0)}] 0.0] test "Complex-3.4" "Elementary - sin 2" -match numbers -body { set a [complex 0 1] set c [sin $a] # # Calculate from the (complex) definition # set d1 [exp [complex -1 0]] set d2 [exp [complex 1 0]] set e [/ [- $d1 $d2] [complex 0 2]] set diff [- $c $e] } -result [complex 0 0] test "Complex-3.5" "Elementary - cos 1" -match numbers -body { set a [complex 1 0] set c [cos $a] } -result [complex [expr {cos(1.0)}] 0.0] test "Complex-3.6" "Elementary - cos 2" -match numbers -body { set a [complex 0 1] set c [cos $a] set d1 [exp [complex -1 0]] set d2 [exp [complex 1 0]] set e [/ [+ $d1 $d2] [complex 2 0]] set diff [- $c $e] } -result [complex 0 0] test "Complex-3.7" "Elementary - tan 1" -match numbers -body { set a [complex 1 0] set c [tan $a] } -result [complex [expr {tan(1.0)}] 0] test "Complex-3.8" "Elementary - tan 2" -match numbers -body { set a [complex 0 1] set c [tan $a] set d1 [sin $a] set d2 [cos $a] set e [/ $d1 $d2] set diff [- $c $e] } -result [complex 0 0] test "Complex-3.9" "Elementary - log 1" -match numbers -body { set a [complex 1 0] set c [log $a] } -result [complex 0 0] test "Complex-3.10" "Elementary - log 2" -match numbers -body { set a [complex 0 1] set c [log $a] } -result [complex 0 [expr {2.0*atan(1.0)}]] test "Complex-3.11" "Elementary - sqrt 1" -match numbers -body { set a [complex -1 0] set c [sqrt $a] } -result [complex 0 1] test "Complex-3.12" "Elementary - sqrt 2" -match numbers -body { set a [complex 0 4] set c [sqrt $a] } -result [complex [expr {sqrt(2)}] [expr {sqrt(2)}]] test "Complex-3.13" "Elementary - pow 1" -match numbers -body { set a [complex -1 0] set b [complex 0.5 0] set c [pow $a $b] } -result [complex 0 1] test "Complex-3.14" "Elementary - pow 2" -match numbers -body { set a [complex [expr {exp(1.0)}] 0] set b [complex 0 [expr {4.0*atan(1.0)}]] set c [pow $a $b] } -result [complex -1 0] testsuiteCleanup tcllib-1.15/modules/math/geometry.test0000644000175000017500000005026712077663116017407 0ustar sergeisergei# -*- tcl -*- # Tests for geometry library. # # Copyright (c) 2001 by Ideogramic ApS and other parties. # All rights reserved. # # RCS: @(#) $Id: geometry.test,v 1.13 2010/04/06 17:02:25 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.2 testsNeedTcltest 1.0 support { useLocal math.tcl math } testing { useLocal geometry.tcl math::geometry } # ------------------------------------------------------------------------- proc withFourDecimals {args} { set res {} foreach arg $args {lappend res [expr (round(10000*$arg))/10000.0]} return $res } # ------------------------------------------------------------------------- ### # calculateDistanceToLine ### test geometry-1.1 {geometry::calculateDistanceToLine, simple} { eval withFourDecimals [::math::geometry::calculateDistanceToLine {6 4} {1 1 7 1}] } 3.0 test geometry-1.2 {geometry::calculateDistanceToLine, on line segment} { eval withFourDecimals [::math::geometry::calculateDistanceToLine {3 2} {1 1 5 3}] } 0.0 test geometry-1.3 {geometry::calculateDistanceToLine, on first end} { eval withFourDecimals [::math::geometry::calculateDistanceToLine {1 1} {1 1 7 1}] } 0.0 test geometry-1.4 {geometry::calculateDistanceToLine, on second end} { eval withFourDecimals [::math::geometry::calculateDistanceToLine {7 1} {1 1 7 1}] } 0.0 test geometry-1.5 {geometry::calculateDistanceToLine, not on line segment, between line segment ends} { eval withFourDecimals [::math::geometry::calculateDistanceToLine {3 1} {1 1 7 3}] } 0.6325 test geometry-1.6 {geometry::calculateDistanceToLine, not on infinite line, beyond first line segment end} { eval withFourDecimals [::math::geometry::calculateDistanceToLine {0 -2} {1 1 7 3}] } 2.5298 test geometry-1.7 {geometry::calculateDistanceToLine, not on infinite line, beyond second line segment end} { eval withFourDecimals [::math::geometry::calculateDistanceToLine {10 2} {1 1 7 3}] } 1.8974 test geometry-1.8 {geometry::calculateDistanceToLine, on infinite line, beyond first line segment end} { eval withFourDecimals [::math::geometry::calculateDistanceToLine {-1 0} {1 1 5 3}] } 0.0 test geometry-1.9 {geometry::calculateDistanceToLine, on infinite line, beyond second line segment end} { eval withFourDecimals [::math::geometry::calculateDistanceToLine {9 5} {1 1 5 3}] } 0.0 ### # calculateDistanceToLineSegment ### test geometry-2.1 {geometry::calculateDistanceToLineSegment, simple} { eval withFourDecimals [::math::geometry::calculateDistanceToLineSegment {6 4} {1 1 7 1}] } 3.0 test geometry-2.2 {geometry::calculateDistanceToLineSegment, on linesegment} { eval withFourDecimals [::math::geometry::calculateDistanceToLineSegment {3 2} {1 1 5 3}] } 0.0 test geometry-2.3 {geometry::calculateDistanceToLineSegment, on first end} { eval withFourDecimals [::math::geometry::calculateDistanceToLineSegment {1 1} {1 1 7 1}] } 0.0 test geometry-2.4 {geometry::calculateDistanceToLineSegment, on second end} { eval withFourDecimals [::math::geometry::calculateDistanceToLineSegment {7 1} {1 1 7 1}] } 0.0 test geometry-2.5 {geometry::calculateDistanceToLineSegment, not on linesegment, between linesegment ends} { eval withFourDecimals [::math::geometry::calculateDistanceToLineSegment {3 1} {1 1 7 3}] } 0.6325 test geometry-2.6 {geometry::calculateDistanceToLineSegment, not on infinite line, beyond first line segment end} { eval withFourDecimals [::math::geometry::calculateDistanceToLineSegment {0 -2} {1 1 7 3}] } 3.1623 test geometry-2.7 {geometry::calculateDistanceToLineSegment, not on infinite line, beyond second line segment end} { eval withFourDecimals [::math::geometry::calculateDistanceToLineSegment {10 2} {1 1 7 3}] } 3.1623 test geometry-2.8 {geometry::calculateDistanceToLineSegment, on infinite line, beyond first line segment end} { eval withFourDecimals [::math::geometry::calculateDistanceToLineSegment {-1 0} {1 1 5 3}] } 2.2361 test geometry-2.9 {geometry::calculateDistanceToLineSegment, on infinite line, beyond second line segment end} { eval withFourDecimals [::math::geometry::calculateDistanceToLineSegment {9 5} {1 1 5 3}] } 4.4721 ### # findClosestPointOnLine ### test geometry-3.1 {geometry::findClosestPointOnLine, between end points} { eval withFourDecimals [::math::geometry::findClosestPointOnLine {5 10} {0 0 10 10}] } {7.5 7.5} test geometry-3.2 {geometry::findClosestPointOnLine, before first point} { eval withFourDecimals [::math::geometry::findClosestPointOnLine {-10 0} {0 0 10 10}] } {-5.0 -5.0} ### # findClosestPointOnLineSegment ### ### # findClosestPointOnPolyline ### test geometry-5.1 {geometry::findClosestPointOnPolyline, one linesegment} { eval withFourDecimals [::math::geometry::findClosestPointOnPolyline {6 4} {1 1 7 1}] } {6.0 1.0} test geometry-5.2 {geometry::findClosestPointOnPolyline, two linesegments} { eval withFourDecimals [::math::geometry::findClosestPointOnPolyline {5 5} {1 1 1 5 14 10}] } {4.4845 6.3402} test geometry-5.3 {geometry::findClosestPointOnPolyline, point lies on a linesegment} { eval withFourDecimals [::math::geometry::findClosestPointOnPolyline {5 5} {1 1 8 8}] } {5.0 5.0} ### # calculateDistanceToPolyline ### test geometry-6.1 {geometry::calculateDistanceToPolyline, one line segment} { eval withFourDecimals [::math::geometry::calculateDistanceToPolyline {6 4} {4 6 1 2}] } 2.8 test geometry-6.2 {geometry::calculateDistanceToPolyline, two line segments} { eval withFourDecimals [::math::geometry::calculateDistanceToPolyline {6 9} {4 6 1 2 4 12}] } 2.7777 test geometry-6.3 {geometry::calculateDistanceToPolyline, three line segments} { eval withFourDecimals [::math::geometry::calculateDistanceToPolyline {6 4} {4 6 1 2 10 8 12 4}] } 1.1094 test geometry-6.4 {geometry::calculateDistanceToPolyline, on first point} { eval withFourDecimals [::math::geometry::calculateDistanceToPolyline {4 6} {4 6 1 2 5 1}] } 0.0 test geometry-6.5 {geometry::calculateDistanceToPolyline, on second point} { eval withFourDecimals [::math::geometry::calculateDistanceToPolyline {1 2} {4 6 1 2 5 1}] } 0.0 test geometry-6.6 {geometry::calculateDistanceToPolyline, on third point} { eval withFourDecimals [::math::geometry::calculateDistanceToPolyline {5 1} {4 6 1 2 5 1}] } 0.0 test geometry-6.7 {geometry::calculateDistanceToPolyline, on first line segment} { eval withFourDecimals [::math::geometry::calculateDistanceToPolyline {2 2} {4 6 1 0 5 4}] } 0.0 test geometry-6.8 {geometry::calculateDistanceToPolyline, on second line segment} { eval withFourDecimals [::math::geometry::calculateDistanceToPolyline {3 2} {4 6 1 0 5 4}] } 0.0 ### # lineSegmentsIntersect ### test geometry-7.1 {geometry::lineSegmentsIntersect, } { ::math::geometry::lineSegmentsIntersect {0 0 10 10} {0 10 10 0} } 1 ### # polylinesIntersect ### test geometry-8.1 {geometry::polylinesIntersect, } { ::math::geometry::polylinesIntersect {0 0 0 2 10 10} {0 10 2 10 10 0} } 1 ### # findLineIntersection ### test geometry-9.1 {geometry::findLineIntersection, first line vertical} { eval withFourDecimals [::math::geometry::findLineIntersection {7 8 7 28} {3 14 17 21}] } {7.0 16.0} test geometry-9.2 {geometry::findLineIntersection, second line vertical} { eval withFourDecimals [::math::geometry::findLineIntersection {3 14 17 21} {7 8 7 28}] } {7.0 16.0} test geometry-9.3 {geometry::findLineIntersection, both lines vertical - coincident} { ::math::geometry::findLineIntersection {7 8 7 28} {7 14 7 21} } "coincident" test geometry-9.4 {geometry::findLineIntersection, both lines vertical - no intersection} { ::math::geometry::findLineIntersection {7 8 7 28} {8 14 8 21} } "none" test geometry-9.5 {geometry::findLineIntersection, first line horizontal} { eval withFourDecimals [::math::geometry::findLineIntersection {2 3 10 3} {4 5 7 2}] } {6.0 3.0} test geometry-9.6 {geometry::findLineIntersection, second line horizontal} { eval withFourDecimals [::math::geometry::findLineIntersection {4 5 7 2} {2 3 10 3}] } {6.0 3.0} test geometry-9.7 {geometry::findLineIntersection, both lines horizontal - coincident} { ::math::geometry::findLineIntersection {8 7 28 7} {14 7 21 7} } "coincident" test geometry-9.8 {geometry::findLineIntersection, both lines horizontal - no intersection} { ::math::geometry::findLineIntersection {8 7 28 7} {14 8 21 8} } "none" test geometry-9.9 {geometry::findLineIntersection, both lines skaeve - with intersection} { eval withFourDecimals [::math::geometry::findLineIntersection {3 2 9 4} {4 5 7 2}] } {6.0 3.0} test geometry-9.10 {geometry::findLineIntersection, both lines skaeve - coincident} { ::math::geometry::findLineIntersection {3 2 9 4} {6 3 12 5} } "coincident" test geometry-9.11 {geometry::findLineIntersection, both lines skaeve - no intersection} { ::math::geometry::findLineIntersection {3 2 9 4} {3 12 9 14} } "none" test geometry-9.12 {geometry::findLineIntersection, vertical} { eval withFourDecimals [::math::geometry::findLineIntersection {110.0 130.0 110.0 30.0} {180.0 200.0 280.0 200.0}] } {110.0 200.0} test geometry-9.13 {geometry::findLineIntersection, vertical, ints} { eval withFourDecimals [::math::geometry::findLineIntersection {110 130 110 30} {180 200 280 200}] } {110.0 200.0} test geometry-9.14 {geometry::findLineIntersection, very near vertical, flipped direction} { # This test checks the numerical stability of the algorithm eval withFourDecimals [::math::geometry::findLineIntersection {110.0 130.0 109.99999999999999 230.0} {180.0 200.0 280.0 200.0}] } {110.0 200.0} test geometry-9.15 {geometry::findLineIntersection, vertical, flipped direction} { eval withFourDecimals [::math::geometry::findLineIntersection {110 130 110 230} {180 200 280 200}] } {110.0 200.0} ### # findLineSegmentIntersection ### test geometry-10.1 {geometry::findLineSegmentIntersection, both lines vertical - no overlap} { ::math::geometry::findLineSegmentIntersection {1 1 1 2} {1 3 1 4} } "none" test geometry-10.2 {geometry::findLineSegmentIntersection, both lines vertical - with overlap} { ::math::geometry::findLineSegmentIntersection {1 1 1 2} {1 1.5 1 19} } "coincident" test geometry-10.3 {geometry::findLineSegmentIntersection, both lines skaeve - with intersection} { eval withFourDecimals [::math::geometry::findLineSegmentIntersection {3 2 9 4} {4 5 7 2}] } {6.0 3.0} test geometry-10.4 {geometry::findLineSegmentIntersection, both lines skaeve - coincident} { ::math::geometry::findLineSegmentIntersection {3 2 9 4} {6 3 12 5} } "coincident" test geometry-10.5 {geometry::findLineSegmentIntersection, both lines skaeve - parallel but not coincident} { ::math::geometry::findLineSegmentIntersection {3 2 6 3} {9 4 12 5} } "none" test geometry-10.6 {geometry::findLineSegmentIntersection, both lines skaeve - no intersection} { ::math::geometry::findLineSegmentIntersection {3 2 9 4} {4 5 5 4} } "none" ### # movePointInDirection ### test geometry-11.1 {geometry::movePointInDirection, going up} { eval withFourDecimals [::math::geometry::movePointInDirection {0 0} 90 1] } {0.0 1.0} test geometry-11.2 {geometry::movePointInDirection, going up 2} { eval withFourDecimals [::math::geometry::movePointInDirection {0 0} 90 5.7] } {0.0 5.7} test geometry-11.3 {geometry::movePointInDirection, going down} { eval withFourDecimals [::math::geometry::movePointInDirection {0 0} 270 5.7] } {0.0 -5.7} test geometry-11.4 {geometry::movePointInDirection, going left} { eval withFourDecimals [::math::geometry::movePointInDirection {0 0} 180 5.7] } {-5.7 0.0} test geometry-11.5 {geometry::movePointInDirection, going right} { eval withFourDecimals [::math::geometry::movePointInDirection {0 0} 0 5.7] } {5.7 0.0} test geometry-11.6 {geometry::movePointInDirection, going up and right} { eval withFourDecimals [::math::geometry::movePointInDirection {0 0} 45 5.7] } {4.0305 4.0305} test geometry-11.7 {geometry::movePointInDirection, going up and left} { eval withFourDecimals [::math::geometry::movePointInDirection {0 0} 135 5.7] } {-4.0305 4.0305} test geometry-11.8 {geometry::movePointInDirection, (3,4,5)-triangle} { set pi [expr 4*atan(1)] set angleInRadians [expr asin(0.6)] set angleInDegrees [expr $angleInRadians/$pi*180] eval withFourDecimals [::math::geometry::movePointInDirection {0 0} $angleInDegrees 5] } {4.0 3.0} test geometry-11.9 {geometry::movePointInDirection, going up and left from (3,6)} { eval withFourDecimals [::math::geometry::movePointInDirection {3 6} 135 5.7] } {-1.0305 10.0305} test geometry-11.10 {geometry::movePointInDirection, negative angle} { eval withFourDecimals [::math::geometry::movePointInDirection {0 0} -90 5.7] } {0.0 -5.7} test geometry-11.11 {geometry::movePointInDirection, negative angle 2} { eval withFourDecimals [::math::geometry::movePointInDirection {0 0} -135 5.7] } {-4.0305 -4.0305} test geometry-11.12 {geometry::movePointInDirection, big angle (>360)} { eval withFourDecimals [::math::geometry::movePointInDirection {0 0} 450 5.7] } {0.0 5.7} ### # Angle ### test geometry-12.1 {geometry::angle, going right} { withFourDecimals [::math::geometry::angle {0 0 10 0}] } 0.0 test geometry-12.2 {geometry::angle, going up} { withFourDecimals [::math::geometry::angle {0 0 0 10}] } 90.0 test geometry-12.3 {geometry::angle, going left} { withFourDecimals [::math::geometry::angle {0 0 -10 0}] } 180.0 test geometry-12.4 {geometry::angle, going down} { withFourDecimals [::math::geometry::angle {0 0 0 -10}] } 270.0 test geometry-12.5 {geometry::angle, going up and right} { withFourDecimals [::math::geometry::angle {0 0 10 10}] } 45.0 test geometry-12.6 {geometry::angle, going up and left} { withFourDecimals [::math::geometry::angle {0 0 -10 10}] } 135.0 test geometry-12.7 {geometry::angle, going down and left} { withFourDecimals [::math::geometry::angle {0 0 -10 -10}] } 225.0 test geometry-12.8 {geometry::angle, going down and right} { withFourDecimals [::math::geometry::angle {0 0 10 -10}] } 315.0 test geometry-12.9 {geometry::angle, going up and right from (3,6)} { withFourDecimals [::math::geometry::angle {3 6 10 9}] } 23.1986 ### # intervalsOverlap ### test geometry-13.1 {geometry::intervalsOverlap, strict, overlap} { math::geometry::intervalsOverlap 2 4 3 6 1 } 1 test geometry-13.2 {geometry::intervalsOverlap, strict, no overlap} { math::geometry::intervalsOverlap 2 4 4 6 1 } 0 test geometry-13.3 {geometry::intervalsOverlap, not strict, overlap} { math::geometry::intervalsOverlap 2 4 3 6 0 } 1 test geometry-13.4 {geometry::intervalsOverlap, not strict, no overlap} { math::geometry::intervalsOverlap 2 4 5 6 0 } 0 test geometry-13.5 {geometry::intervalsOverlap, first interval wrong order} { math::geometry::intervalsOverlap 4 2 3 5 0 } 1 test geometry-13.6 {geometry::intervalsOverlap, second interval wrong order} { math::geometry::intervalsOverlap 2 4 5 3 0 } 1 test geometry-13.7 {geometry::intervalsOverlap, both interval wrong order} { math::geometry::intervalsOverlap 4 2 5 3 0 } 1 ### # rectanglesOverlap ### test geometry-14.1 {geometry::rectanglesOverlap, strict, overlap} { math::geometry::rectanglesOverlap {0 10} {10 0} {5 10} {20 0} 1 } 1 test geometry-14.2 {geometry::rectanglesOverlap, strict, no overlap} { math::geometry::rectanglesOverlap {0 10} {10 0} {10 10} {20 0} 1 } 0 test geometry-14.3 {geometry::rectanglesOverlap, not strict, overlap} { math::geometry::rectanglesOverlap {0 10} {10 0} {5 10} {20 0} 0 } 1 test geometry-14.4 {geometry::rectanglesOverlap, not strict, no overlap} { math::geometry::rectanglesOverlap {0 10} {10 0} {12 10} {20 0} 0 } 0 ### # pointInsidePolygon ### test geometry-15.1 {geometry::pointInsidePolygon, simple inside} { math::geometry::pointInsidePolygon {5 5} {4 4 4 6 6 6 6 4} } 1 test geometry-15.2 {geometry::pointInsidePolygon, simple not inside} { math::geometry::pointInsidePolygon {5 5} {6 6 6 7 7 7} } 0 test geometry-15.3 {geometry::pointInsidePolygon, point on polygon's sides} { math::geometry::pointInsidePolygon {5 5} {5 4 5 6 7 7} } 0 test geometry-15.4 {geometry::pointInsidePolygon, point identical with one of polygon's points} { math::geometry::pointInsidePolygon {5 5} {5 4 5 5 7 7} } 0 test geometry-15.5 {geometry::pointInsidePolygon, point not in polygon's bbox} { math::geometry::pointInsidePolygon {5 5} {8 8 8 9 9 9 9 8} } 0 test geometry-15.6 {geometry::pointInsidePolygon, hour-glass with center on point} { math::geometry::pointInsidePolygon {5 5} {4 4 6 6 6 4 4 6} } 0 test geometry-15.7 {geometry::pointInsidePolygon, hour-glass with point inside one of the areas} { math::geometry::pointInsidePolygon {5 5} {3 2 5 11 3 11 11 6} } 1 test geometry-15.8 {geometry::pointInsidePolygon, hour-glass with point on left side} { math::geometry::pointInsidePolygon {5 5} {4 1 8 8 6 8 8 1} } 0 test geometry-15.9 {geometry::pointInsidePolygon, hour-glass with point on right side} { math::geometry::pointInsidePolygon {5 5} {2 4 6 9 2 9 5 4} } 0 test geometry-15.10 {geometry::pointInsidePolygon, infinityLine crosses point instead of line segment} { math::geometry::pointInsidePolygon {5 5} {4 4 4 7 7 7 7 4} } 1 test geometry-15.11 {geometry::pointInsidePolygon, polygon already closed} { math::geometry::pointInsidePolygon {5 5} {4 4 4 6 6 6 6 4 4 4} } 1 test geometry-15.12 {geometry::pointInsidePolygon, polygon with zero-length side} { math::geometry::pointInsidePolygon {5 5} {4 4 4 6 6 6 6 6 6 4} } 1 ### # rectangleInsidePolygon ### test geometry-16.1 {geometry::rectangleInsidePolygon, simple} { math::geometry::rectangleInsidePolygon {0 10} {10 0} {-10 -10 0 11 11 11 11 0} } 1 test geometry-16.2 {geometry::rectangleInsidePolygon, rectangle and polygon identical} { math::geometry::rectangleInsidePolygon {5 5} {7 7} {5 5 5 7 7 7 7 5} } 0 test geometry-16.3 {geometry::rectangleInsidePolygon, bboxes don't overlap} { math::geometry::rectangleInsidePolygon {5 5} {7 7} {8 8 8 9 9 9 9 8} } 0 test geometry-16.4 {geometry::rectangleInsidePolygon, polygon point is inside the rectangle} { math::geometry::rectangleInsidePolygon {5 5} {7 7} {4 4 4 8 6 6} } 0 test geometry-16.5 {geometry::rectangleInsidePolygon, hour-glass with center inside rectangle} { math::geometry::rectangleInsidePolygon {5 5} {7 7} {5 3 7 9 5 9 7 3} } 0 test geometry-16.6 {geometry::rectangleInsidePolygon, hour-glass with rectangle inside one of the areas} { math::geometry::rectangleInsidePolygon {5 5} {7 7} {3 2 5 11 3 11 11 6} } 1 test geometry-16.7 {geometry::rectangleInsidePolygon, hour-glass with rectangle on left side} { math::geometry::rectangleInsidePolygon {5 5} {6 6} {4 1 8 8 6 8 8 1} } 0 test geometry-16.8 {geometry::rectangleInsidePolygon, hour-glass with rectangle on right side} { math::geometry::rectangleInsidePolygon {5 5} {6 6} {2 4 6 9 2 9 5 4} } 0 test geometry-16.9 {geometry::rectangleInsidePolygon, infinityLine crosses point instead of line segment} { math::geometry::rectangleInsidePolygon {5 5} {6 6} {4 4 4 7 7 7 7 4} } 1 ### ### test geometry-17.0 {point constructor} { math::geometry::p 1 4 } {1 4} test geometry-17.1 {vector addition} { math::geometry::+ {1 4} {5 3} } {6 7} test geometry-17.2 {vector difference} { math::geometry::- {6 7} {5 3} } {1 4} test geometry-17.3 {vector distance} { withFourDecimals [math::geometry::distance {6 7} {5 3}] } 4.1231 test geometry-17.4 {vector length} { withFourDecimals [math::geometry::length {1 1}] } 1.4142 test geometry-17.5 {vector scale} { math::geometry::s* 5 {1 1} } {5 5} test geometry-17.6 {vector direction} { eval withFourDecimals [math::geometry::direction 0] } {1.0 0.0} test geometry-17.7 {vector direction} { eval withFourDecimals [math::geometry::direction 90] } {0.0 -1.0} test geometry-17.8 {vector vertical} { math::geometry::v 90 } {0 90} test geometry-17.9 {vector horizontal} { math::geometry::h 90 } {90 0} test geometry-17.10 {point between} { math::geometry::between {0 0} {4 4} 0 } {0 0} test geometry-17.11 {point between} { math::geometry::between {0 0} {4 4} 1 } {4 4} test geometry-17.12 {point between} { math::geometry::between {0 0} {4 4} 0.5 } {2.0 2.0} test geometry-17.13 {octant} { math::geometry::octant {-10 -12} } northwest ### testsuiteCleanup tcllib-1.15/modules/math/pkgIndex.tcl0000644000175000017500000000445312077663116017124 0ustar sergeisergeiif {![package vsatisfies [package provide Tcl] 8.2]} {return} package ifneeded math 1.2.5 [list source [file join $dir math.tcl]] package ifneeded math::geometry 1.1.2 [list source [file join $dir geometry.tcl]] package ifneeded math::fuzzy 0.2.1 [list source [file join $dir fuzzy.tcl]] package ifneeded math::complexnumbers 1.0.2 [list source [file join $dir qcomplex.tcl]] package ifneeded math::special 0.2.2 [list source [file join $dir special.tcl]] package ifneeded math::constants 1.0.1 [list source [file join $dir constants.tcl]] package ifneeded math::polynomials 1.0.1 [list source [file join $dir polynomials.tcl]] package ifneeded math::rationalfunctions 1.0.1 [list source [file join $dir rational_funcs.tcl]] package ifneeded math::fourier 1.0.2 [list source [file join $dir fourier.tcl]] if {![package vsatisfies [package provide Tcl] 8.3]} {return} package ifneeded math::roman 1.0 [list source [file join $dir romannumerals.tcl]] if {![package vsatisfies [package provide Tcl] 8.4]} {return} # statistics depends on linearalgebra (for multi-variate linear regression). package ifneeded math::statistics 0.8.0 [list source [file join $dir statistics.tcl]] package ifneeded math::optimize 1.0 [list source [file join $dir optimize.tcl]] package ifneeded math::calculus 0.7.1 [list source [file join $dir calculus.tcl]] package ifneeded math::interpolate 1.0.3 [list source [file join $dir interpolate.tcl]] package ifneeded math::linearalgebra 1.1.4 [list source [file join $dir linalg.tcl]] package ifneeded math::bignum 3.1.1 [list source [file join $dir bignum.tcl]] package ifneeded math::bigfloat 1.2.2 [list source [file join $dir bigfloat.tcl]] package ifneeded math::machineparameters 0.1 [list source [file join $dir machineparameters.tcl]] if {![package vsatisfies [package provide Tcl] 8.5]} {return} package ifneeded math::calculus::symdiff 1.0 [list source [file join $dir symdiff.tcl]] package ifneeded math::bigfloat 2.0.1 [list source [file join $dir bigfloat2.tcl]] package ifneeded math::numtheory 1.0 [list source [file join $dir numtheory.tcl]] package ifneeded math::decimal 1.0.2 [list source [file join $dir decimal.tcl]] tcllib-1.15/modules/math/math.tcl0000644000175000017500000000247212077663116016303 0ustar sergeisergei# math.tcl -- # # Main 'package provide' script for the package 'math'. # # Copyright (c) 1998-2000 by Ajuba Solutions. # Copyright (c) 2002 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: math.tcl,v 1.23 2009/12/04 17:37:47 andreas_kupries Exp $ package require Tcl 8.2 ;# uses [lindex $l end-$integer] # @mdgen OWNER: tclIndex # @mdgen OWNER: misc.tcl # @mdgen OWNER: combinatorics.tcl namespace eval ::math { variable version 1.2.5 # misc.tcl namespace export cov fibonacci integrate namespace export max mean min namespace export product random sigma namespace export stats sum namespace export expectDouble expectInteger # combinatorics.tcl namespace export ln_Gamma factorial choose namespace export Beta # Set up for auto-loading if { ![interp issafe {}]} { variable home [file join [pwd] [file dirname [info script]]] if {[lsearch -exact $::auto_path $home] == -1} { lappend ::auto_path $home } } else { source [file join [file dirname [info script]] misc.tcl] source [file join [file dirname [info script]] combinatorics.tcl] } package provide [namespace tail [namespace current]] $version } tcllib-1.15/modules/math/fourier.man0000755000175000017500000001206712077663116017022 0ustar sergeisergei[manpage_begin math::fourier n 1.0.2] [moddesc {Tcl Math Library}] [titledesc {Discrete and fast fourier transforms}] [category Mathematics] [require Tcl 8.4] [require math::fourier 1.0.2] [description] [para] The [package math::fourier] package implements two versions of discrete Fourier transforms, the ordinary transform and the fast Fourier transform. It also provides a few simple filter procedures as an illustrations of how such filters can be implemented. [para] The purpose of this document is to describe the implemented procedures and provide some examples of their usage. As there is ample literature on the algorithms involved, we refer to relevant text books for more explanations. We also refer to the original Wiki page on the subject which describes some of the considerations behind the current implementation. [section "GENERAL INFORMATION"] The two top-level procedures defined are [list_begin itemized] [item] dft data-list [item] inverse_dft data-list [list_end] Both take a list of [emph "complex numbers"] and apply a Discrete Fourier Transform (DFT) or its inverse respectively to these lists of numbers. A "complex number" in this case is either (i) a pair (two element list) of numbers, interpreted as the real and imaginary parts of the complex number, or (ii) a single number, interpreted as the real part of a complex number whose imaginary part is zero. The return value is always in the first format. (The DFT generally produces complex results even if the input is purely real.) Applying first one and then the other of these procedures to a list of complex numbers will (modulo rounding errors due to floating point arithmetic) return the original list of numbers. [para] If the input length N is a power of two then these procedures will utilize the O(N log N) Fast Fourier Transform algorithm. If input length is not a power of two then the DFT will instead be computed using a the naive quadratic algorithm. [para] Some examples: [example { % dft {1 2 3 4} {10 0.0} {-2.0 2.0} {-2 0.0} {-2.0 -2.0} % inverse_dft {{10 0.0} {-2.0 2.0} {-2 0.0} {-2.0 -2.0}} {1.0 0.0} {2.0 0.0} {3.0 0.0} {4.0 0.0} % dft {1 2 3 4 5} {15.0 0.0} {-2.5 3.44095480118} {-2.5 0.812299240582} {-2.5 -0.812299240582} {-2.5 -3.44095480118} % inverse_dft {{15.0 0.0} {-2.5 3.44095480118} {-2.5 0.812299240582} {-2.5 -0.812299240582} {-2.5 -3.44095480118}} {1.0 0.0} {2.0 8.881784197e-17} {3.0 4.4408920985e-17} {4.0 4.4408920985e-17} {5.0 -8.881784197e-17} }] [para] In the last case, the imaginary parts <1e-16 would have been zero in exact arithmetic, but aren't here due to rounding errors. [para] Internally, the procedures use a flat list format where every even index element of a list is a real part and every odd index element is an imaginary part. This is reflected in the variable names by Re_ and Im_ prefixes. [para] The package includes two simple filters. They have an analogue equivalent in a simple electronic circuit, a resistor and a capacitance in series. Using these filters requires the [package math::complexnumbers] package. [section "PROCEDURES"] The public Fourier transform procedures are: [list_begin definitions] [call [cmd ::math::fourier::dft] [arg in_data]] Determine the [emph "Fourier transform"] of the given list of complex numbers. The result is a list of complex numbers representing the (complex) amplitudes of the Fourier components. [list_begin arguments] [arg_def list in_data] List of data [list_end] [para] [call [cmd ::math::fourier::inverse_dft] [arg in_data]] Determine the [emph "inverse Fourier transform"] of the given list of complex numbers (interpreted as amplitudes). The result is a list of complex numbers representing the original (complex) data [list_begin arguments] [arg_def list in_data] List of data (amplitudes) [list_end] [para] [call [cmd ::math::fourier::lowpass] [arg cutoff] [arg in_data]] Filter the (complex) amplitudes so that high-frequency components are suppressed. The implemented filter is a first-order low-pass filter, the discrete equivalent of a simple electronic circuit with a resistor and a capacitance. [list_begin arguments] [arg_def float cutoff] Cut-off frequency [arg_def list in_data] List of data (amplitudes) [list_end] [para] [call [cmd ::math::fourier::highpass] [arg cutoff] [arg in_data]] Filter the (complex) amplitudes so that low-frequency components are suppressed. The implemented filter is a first-order low-pass filter, the discrete equivalent of a simple electronic circuit with a resistor and a capacitance. [list_begin arguments] [arg_def float cutoff] Cut-off frequency [arg_def list in_data] List of data (amplitudes) [list_end] [para] [list_end] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph {math :: fourier}] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords mathematics "FFT" "Fourier transform" "complex numbers"] [manpage_end] tcllib-1.15/modules/math/bessel.tcl0000755000175000017500000001057112077663116016631 0ustar sergeisergei# bessel.tcl -- # Evaluate the most common Bessel functions # # TODO: # Yn - finding decent approximations seems tough # Jnu - for arbitrary values of the parameter # J'n - first derivative (from recurrence relation) # Kn - forward application of recurrence relation? # # namespace special # Create a convenient namespace for the "special" mathematical functions # namespace eval ::math::special { # # Define a number of common mathematical constants # ::math::constants::constants pi # # Export the functions # namespace export J0 J1 Jn J1/2 J-1/2 I_n } # J0 -- # Zeroth-order Bessel function # # Arguments: # x Value of the x-coordinate # Result: # Value of J0(x) # proc ::math::special::J0 {x} { Jn 0 $x } # J1 -- # First-order Bessel function # # Arguments: # x Value of the x-coordinate # Result: # Value of J1(x) # proc ::math::special::J1 {x} { Jn 1 $x } # Jn -- # Compute the Bessel function of the first kind of order n # Arguments: # n Order of the function (must be integer) # x Value of the argument # Result: # Jn(x) # Note: # This relies on the integral representation for # the Bessel functions of integer order: # 1 I pi # Jn(x) = -- I cos(x sin t - nt) dt # pi 0 I # # For this kind of integrands the trapezoidal rule is # very efficient according to Davis and Rabinowitz # (Methods of numerical integration, 1984). # proc ::math::special::Jn {n x} { variable pi if { ![string is integer -strict $n] } { return -code error "Order argument must be integer" } # # Integrate over the interval [0,pi] using a small # enough step - 40 points should do a good job # with |x| < 20, n < 20 (an accuracy of 1.0e-8 # is reported by Davis and Rabinowitz) # set number 40 set step [expr {$pi/double($number)}] set result 0.0 for { set i 0 } { $i <= $number } { incr i } { set t [expr {double($i)*$step}] set f [expr {cos($x * sin($t) - $n * $t)}] if { $i == 0 || $i == $number } { set f [expr {$f/2.0}] } set result [expr {$result+$f}] } expr {$result*$step/$pi} } # J1/2 -- # Half-order Bessel function # # Arguments: # x Value of the x-coordinate # Result: # Value of J1/2(x) # proc ::math::special::J1/2 {x} { variable pi # # This Bessel function can be expressed in terms of elementary # functions. Therefore use the explicit formula # if { $x != 0.0 } { expr {sqrt(2.0/$pi/$x)*sin($x)} } else { return 0.0 } } # J-1/2 -- # Compute the Bessel function of the first kind of order -1/2 # Arguments: # x Value of the argument (!= 0.0) # Result: # J-1/2(x) # proc ::math::special::J-1/2 {x} { variable pi if { $x == 0.0 } { return -code error "Argument must not be zero (singularity)" } else { return [expr {-cos($x)/sqrt($pi*$x/2.0)}] } } # I_n -- # Compute the modified Bessel function of the first kind # # Arguments: # n Order of the function (must be positive integer or zero) # x Abscissa at which to compute it # Result: # Value of In(x) # Note: # This relies on Miller's algorithm for finding minimal solutions # namespace eval ::math::special {} proc ::math::special::I_n {n x} { if { ! [string is integer $n] || $n < 0 } { error "Wrong order: must be positive integer or zero" } set n2 [expr {$n+8}] ;# Note: just a guess that this will be enough set ynp1 0.0 set yn 1.0 set sum 1.0 while { $n2 > 0 } { set ynm1 [expr {$ynp1+2.0*$n2*$yn/$x}] set sum [expr {$sum+$ynm1}] if { $n2 == $n+1 } { set result $ynm1 } set ynp1 $yn set yn $ynm1 incr n2 -1 } set quotient [expr {(2.0*$sum-$ynm1)/exp($x)}] expr {$result/$quotient} } # # some tests -- # if { 0 } { set prec $::tcl_precision if {![package vsatisfies [package provide Tcl] 8.5]} { set ::tcl_precision 17 } else { set ::tcl_precision 0 } foreach x {0.0 2.0 4.4 6.0 10.0 11.0 12.0 13.0 14.0} { puts "J0($x) = [::math::special::J0 $x] - J1($x) = [::math::special::J1 $x] \ - J1/2($x) = [::math::special::J1/2 $x]" } foreach n {0 1 2 3 4 5} { puts [::math::special::I_n $n 1.0] } set ::tcl_precision $prec } tcllib-1.15/modules/math/machineparameters.man0000755000175000017500000001330112077663116021027 0ustar sergeisergei[comment {-*- tclrep -*- doctools manpage}] [manpage_begin tclrep/machineparameters n 1.0] [copyright {2008 Michael Baudin }] [moddesc tclrep] [require snit] [titledesc {Compute double precision machine parameters.}] [description] The [emph math::machineparameters] package is the Tcl equivalent of the DLAMCH LAPACK function. In floating point systems, a floating point number is represented by [example { x = +/- d1 d2 ... dt basis^e }] where digits satisfy [example { 0 <= di <= basis - 1, i = 1, t }] with the convention : [list_begin itemized] [item] t is the size of the mantissa [item] basis is the basis (the "radix") [list_end] [para] The [method compute] method computes all machine parameters. Then, the [method get] method can be used to get each parameter. The [method print] method prints a report on standard output. [section EXAMPLE] In the following example, one compute the parameters of a desktop under Linux with the following Tcl 8.4.19 properties : [example { % parray tcl_platform tcl_platform(byteOrder) = littleEndian tcl_platform(machine) = i686 tcl_platform(os) = Linux tcl_platform(osVersion) = 2.6.24-19-generic tcl_platform(platform) = unix tcl_platform(tip,268) = 1 tcl_platform(tip,280) = 1 tcl_platform(user) = tcl_platform(wordSize) = 4 }] The following example creates a machineparameters object, computes the properties and displays it. [example { set pp [machineparameters create %AUTO%] $pp compute $pp print $pp destroy }] This prints out : [example { Machine parameters Epsilon : 1.11022302463e-16 Beta : 2 Rounding : proper Mantissa : 53 Maximum exponent : 1024 Minimum exponent : -1021 Overflow threshold : 8.98846567431e+307 Underflow threshold : 2.22507385851e-308 }] That compares well with the results produced by Lapack 3.1.1 : [example { Epsilon = 1.11022302462515654E-016 Safe minimum = 2.22507385850720138E-308 Base = 2.0000000000000000 Precision = 2.22044604925031308E-016 Number of digits in mantissa = 53.000000000000000 Rounding mode = 1.00000000000000000 Minimum exponent = -1021.0000000000000 Underflow threshold = 2.22507385850720138E-308 Largest exponent = 1024.0000000000000 Overflow threshold = 1.79769313486231571E+308 Reciprocal of safe minimum = 4.49423283715578977E+307 }] The following example creates a machineparameters object, computes the properties and gets the epsilon for the machine. [example { set pp [machineparameters create %AUTO%] $pp compute set eps [$pp get -epsilon] $pp destroy }] [section REFERENCES] [list_begin itemized] [item] "Algorithms to Reveal Properties of Floating-Point Arithmetic", Michael A. Malcolm, Stanford University, Communications of the ACM, Volume 15 , Issue 11 (November 1972), Pages: 949 - 951 [item] "More on Algorithms that Reveal Properties of Floating, Point Arithmetic Units", W. Morven Gentleman, University of Waterloo, Scott B. Marovich, Purdue University, Communications of the ACM, Volume 17 , Issue 5 (May 1974), Pages: 276 - 277 [list_end] [section {CLASS API}] [list_begin definitions] [call [cmd machineparameters] create [arg objectname] [opt [arg options]...]] The command creates a new machineparameters object and returns the fully qualified name of the object command as its result. [list_begin options] [opt_def -verbose [arg verbose]] Set this option to 1 to enable verbose logging. This option is mainly for debug purposes. The default value of [arg verbose] is 0. [list_end] [list_end] [section {OBJECT API}] [list_begin definitions] [call [arg objectname] [method configure] [opt [arg options]...]] The command configure the options of the object [arg objectname]. The options are the same as the static method [method create]. [call [arg objectname] [method cget] [arg opt]] Returns the value of the option which name is [arg opt]. The options are the same as the method [method create] and [method configure]. [call [arg objectname] [method destroy]] Destroys the object [arg objectname]. [call [arg objectname] [method compute]] Computes the machine parameters. [call [arg objectname] [method get] [arg key]] Returns the value corresponding with given key. The following is the list of available keys. [list_begin itemized] [item] -epsilon : smallest value so that 1+epsilon>1 is false [item] -rounding : The rounding mode used on the machine. The rounding occurs when more than t digits would be required to represent the number. Two modes can be determined with the current system : "chop" means than only t digits are kept, no matter the value of the number "proper" means that another rounding mode is used, be it "round to nearest", "round up", "round down". [item] -basis : the basis of the floating-point representation. The basis is usually 2, i.e. binary representation (for example IEEE 754 machines), but some machines (like HP calculators for example) uses 10, or 16, etc... [item] -mantissa : the number of bits in the mantissa [item] -exponentmax : the largest positive exponent before overflow occurs [item] -exponentmin : the largest negative exponent before (gradual) underflow occurs [item] -vmax : largest positive value before overflow occurs [item] -vmin : largest negative value before (gradual) underflow occurs [list_end] [call [arg objectname] [method tostring]] Return a report for machine parameters. [call [arg objectname] [method print]] Print machine parameters on standard output. [list_end] [manpage_end] tcllib-1.15/modules/math/optimize.test0000755000175000017500000003377212077663116017421 0ustar sergeisergei# -*- tcl -*- # Tests for 1-d optimisation functions in math library -*- tcl -*- # # This file contains a collection of tests for one or more of the Tcllib # procedures. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # $Id: optimize.test,v 1.17 2011/01/18 07:49:53 arjenmarkus Exp $ # # Copyright (c) 2004 by Arjen Markus # Copyright (c) 2004, 2005 by Kevin B. Kenny # All rights reserved. # # Note: # By evaluating the tests in a different namespace than global, # we assure that the namespace issue (Bug #...) is checked. # # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.4 testsNeedTcltest 2.1 support { useLocal math.tcl math } testing { useLocal optimize.tcl math::optimize } # ------------------------------------------------------------------------- namespace eval optimizetest { namespace import ::math::optimize::* set old_precision $::tcl_precision if {![package vsatisfies [package present Tcl] 8.5]} { set ::tcl_precision 17 } else { set ::tcl_precision 0 } # # Simple test functions # proc const_func { x } { return 1.0 } proc ffunc { x } { expr {$x*(1.0-$x*$x)} } proc minfunc { x } { expr {-$x*(1.0-$x*$x)} } proc absfunc { x } { expr {abs($x*(1.0-$x*$x))} } proc within_range { result min max } { #puts "Within range? $result $min $max" #puts "[expr {2.0*abs($result-$min)/abs($max+$min)}]" if { $result >= $min && $result <= $max } { set ok 1 } else { set ok 0 } return $ok } # # Test the minimum procedure # # Note about the uneven and even functions: # the initial interval is chosen symmetrical, so that the # three function values are equal. # test optimize-1.1 "Minimum of constant function" { set result [minimum -1.0 1.0 ::optimizetest::const_func] within_range $result -1.0 1.0 } 1 test optimize-1.2 "Minimum of odd function, case 1" { set result [minimum -1.0 1.0 ::optimizetest::ffunc] set xmin [expr {-sqrt(1.0/3.0)-0.0001}] set xmax [expr {-sqrt(1.0/3.0)+0.0001}] within_range $result $xmin $xmax } 1 test optimize-1.3 "Minimum of odd function, asymmetric interval" { set result [minimum -0.8 1.2 ::optimizetest::ffunc] set xmin [expr {-sqrt(1.0/3.0)-0.0001}] set xmax [expr {-sqrt(1.0/3.0)+0.0001}] within_range $result $xmin $xmax } 1 test optimize-1.4 "Minimum of odd function, case 2" { set result [minimum -1.0 1.0 ::optimizetest::minfunc] set xmin [expr {sqrt(1.0/3.0)-0.0001}] set xmax [expr {sqrt(1.0/3.0)+0.0001}] within_range $result $xmin $xmax } 1 test optimize-1.5 "Minimum of even function" { set result [minimum -1.0 1.0 ::optimizetest::absfunc] set xmin -0.0001 set xmax 0.0001 within_range $result $xmin $xmax } 1 # # Test the maximum procedure # # Note about the uneven and even functions: # the initial interval is chosen symmetrical, so that the # three function values are equal. # test optimize-2.1 "Maximum of constant function" { set result [maximum -1.0 1.0 ::optimizetest::const_func] within_range $result -1.0 1.0 } 1 test optimize-2.2 "Maximum of odd function, case 1" { set result [maximum -1.0 1.0 ::optimizetest::ffunc] set xmin [expr {sqrt(1.0/3.0)-0.0001}] set xmax [expr {sqrt(1.0/3.0)+0.0001}] within_range $result $xmin $xmax } 1 test optimize-2.3 "Maximum of odd function, case 2" { set result [maximum -1.0 1.0 ::optimizetest::minfunc] set xmin [expr {-sqrt(1.0/3.0)-0.0001}] set xmax [expr {-sqrt(1.0/3.0)+0.0001}] within_range $result $xmin $xmax } 1 # # Either of the two maxima will do # test optimize-2.4 "Maximum of even function" { set result [maximum -1.0 1.0 ::optimizetest::absfunc] set xmin [expr {-sqrt(1.0/3.0)-0.0001}] set xmax [expr {-sqrt(1.0/3.0)+0.0001}] set ok [within_range $result $xmin $xmax] set xmin [expr {sqrt(1.0/3.0)-0.0001}] set xmax [expr {sqrt(1.0/3.0)+0.0001}] incr ok [within_range $result $xmin $xmax] } 1 # Custom match procedure for approximate results proc withinEpsilon { shouldBe is } { expr { [string is double $is] && abs( $is - $shouldBe ) < 1.e-07 * abs($shouldBe) } } ::tcltest::customMatch withinEpsilon [namespace code withinEpsilon] test linmin-1.1 {find minimum of a parabola - constrained} \ -setup { proc f x { expr { ($x + 3.) * ($x - 1.) } } } \ -body { foreach {x y} [min_bound_1d f 10. -10.] break set x } \ -cleanup { rename f {} } \ -result -1. \ -match withinEpsilon test linmin-1.2 {find minimum of cosine} \ -setup { proc f x { expr { cos($x) } } } \ -body { foreach { x y } [min_bound_1d f 0. 6.28318] break set x } \ -cleanup { rename f {} } \ -result 3.1415926535897932 \ -match withinEpsilon test linmin-1.3 {find minimum of a bell-shaped function} \ -setup { proc f x { set t [expr { $x - 3. }] return [expr { -exp ( -$t * $t / 2 ) }] } } \ -body { foreach { x y } [min_bound_1d f 0 30.] break set x } \ -cleanup { rename f {} } \ -result 3. \ -match withinEpsilon test linmin-1.4 {function where parabolic extrapolation never works} \ -setup { proc f x { expr { -1. / ( 0.01 + abs( $x - 5.) ) } } } \ -body { foreach {x y} [min_bound_1d f 0 20.] break set x } \ -cleanup { rename f {} } \ -result 5. \ -match withinEpsilon test linmin-2.1 {wrong \# args} \ -body { min_bound_1d f } \ -returnCodes 1 \ -result [tcltest::wrongNumArgs min_bound_1d {f x1 x2 args} 1] test linmin-2.2 {wrong \# args} \ -body { min_bound_1d f 0 1 -bad } \ -returnCodes 1 \ -result "wrong # args, should be \"min_bound_1d f x1 x2 ?-option value?...\"" test linmin-2.3 {bad arg} \ -body { min_bound_1d f 0 1 -bad option } \ -returnCodes 1 \ -result "unknown option \"-bad\", should be -abserror,\ -fguess, -guess, -initial,\ -maxiter, -relerror, or -trace" test linmin-2.4 {iteration limit} \ -setup { proc f x { expr { -1. / ( 0.01 + abs( $x - 5.) ) } } } \ -body { min_bound_1d f 20. 0 -maxiter 10 } \ -cleanup { rename f {} } \ -returnCodes 1 \ -result "min_bound_1d failed to converge after \\d* steps" \ -match regexp test linmin-3.1 {minimise cos(x), unbounded} \ -setup { proc f x { expr { cos($x) } } } -body { foreach { x y } [min_unbound_1d f 3. 3.01] break set x } \ -cleanup { rename f {} } \ -result 3.1415926535897932 \ -match withinEpsilon test linmin-3.2 {minimise cos(x), unbounded, too eager} \ -setup { proc f x { expr { cos($x) } } } -body { foreach { x y } [min_unbound_1d f 0.1 0.15] break set x } \ -cleanup { rename f {} } \ -result [expr { 3. * 3.1415926535897932 }] \ -match withinEpsilon test linmin-3.3 {near underflow in parabolic extrapolation} \ -setup { proc f x { expr { ( 1.12712e-22 * $x * $x * $x - 1e-15 ) * $x + 1e-15 } } } \ -body { foreach { x y } [min_unbound_1d f 1. 0.] break set x } \ -cleanup { rename f {} } \ -result 130.41372 \ -match withinEpsilon test linmin-3.4 {near underflow in parabolic extrapolation} \ -setup { proc f x { expr { ( ( 1e-30 * $x * $x - 1.12712e-22 ) * $x * $x * $x - 1e-15 ) * $x + 1e-15 } } } \ -body { foreach { x y } [min_unbound_1d f 1. 0. -relerror 1e-08] break set x } \ -cleanup { rename f {} } \ -result 8668.4248 \ -match withinEpsilon test linmin-3.5 {parabolic interpolation finds a minimum - case 1} \ -setup { proc f x { expr { ( ( ( 1e-5 * $x - 2.69672 ) * $x + 10.0902 ) * $x - 8.39345 ) * $x + 1. } } } \ -body { foreach { x y } [min_unbound_1d f 1. 0. -relerror 1e-08] break set x } \ -cleanup { rename f {} } \ -result 0.527450252 \ -match withinEpsilon test linmin-3.6 {parabolic interpolation finds a minimum - case 2} \ -setup { proc f x { expr { ( ( 0.125669 * $x * $x - 0.982687 ) * $x - 0.142982 ) * $x + 1 } } } \ -body { foreach { x y } [min_unbound_1d f 1. 0. -relerror 1e-08] break set x } \ -cleanup { rename f {} } \ -result 2.0127451 \ -match withinEpsilon test linmin-3.7 {parabolic interpolation is useless} \ -setup { proc f x { expr { ( ( ( 1e-5 * $x - 6.79171 ) * $x + 24.8107 ) * $x - 19.019 ) * $x + 1. } } } \ -body { foreach { x y } [min_unbound_1d f 1 0 -relerror 1e-8] break set x } \ -cleanup { rename f {} } \ -result 509375.81 \ -match withinEpsilon test linmin-4.1 {wrong \# args} \ -body { min_unbound_1d f } \ -returnCodes 1 \ -result [tcltest::wrongNumArgs min_unbound_1d {f x1 x2 args} 1] test linmin-4.2 {wrong \# args} \ -body { min_unbound_1d f 0 1 -bad } \ -returnCodes 1 \ -result "wrong # args, should be \"min_unbound_1d f x1 x2 ?-option value?...\"" test linmin-4.3 {bad arg} \ -body { min_unbound_1d f 0 1 -bad option } \ -returnCodes 1 \ -result "unknown option \"-bad\", should be -trace" # # Test the solveLinearProgram procedure # set ::symm_constraints { { 1.0 2.0 1.0 } { 2.0 1.0 1.0 } } test linprog-1.0 "Symmetric constraints, case 1" \ -body { set result [solveLinearProgram {1.0 1.0} $::symm_constraints] set ok 1 if { ! [within_range [lindex $result 0] 0.333300 0.333360] || ! [within_range [lindex $result 1] 0.333300 0.333360] } { set ok 0 } set ok } \ -result 1 test linprog-1.1 "Symmetric constraints, case 2" \ -body { set result [solveLinearProgram {1.0 0.0} $::symm_constraints] set ok 1 if { ! [within_range [lindex $result 0] 0.49900 0.50100] || ! [within_range [lindex $result 1] -0.00100 0.00100] } { set ok 0 } set ok } \ -result 1 test linprog-1.2 "Symmetric constraints, case 3" \ -body { set result [solveLinearProgram {0.0 1.0} $::symm_constraints] set ok 1 if { ! [within_range [lindex $result 1] 0.499900 0.500100] || ! [within_range [lindex $result 0] -0.000100 0.000100] } { set ok 0 } set ok } \ -result 1 test linprog-1.3 "Symmetric constraints, case 4" \ -body { set result [solveLinearProgram {3.0 4.0} $::symm_constraints] set ok 1 if { ! [within_range [lindex $result 0] 0.333300 0.333360] || ! [within_range [lindex $result 1] 0.333300 0.333360] } { set ok 0 } set ok } \ -result 1 # # TODO: Current algorithm makes no difference between infeasible # and unbounded # test linprog-2.1 "Unbounded program" \ -body { set result [solveLinearProgram {3.0 4.0} {{1.0 -2.0 1.0} {-2.0 1.0 1.0}} ] } \ -result "infeasible" test linprog-3.1 "Simple 3D program" \ -body { set result [solveLinearProgram \ {1.0 1.0 1.0} \ {{1.0 1.0 2.0 1.0} {1.0 2.0 1.0 1.0} {2.0 1.0 1.0 1.0}}] set ok 1 if { ! [within_range [lindex $result 0] 0.249900 0.250100] || ! [within_range [lindex $result 1] 0.249900 0.250100] || ! [within_range [lindex $result 2] 0.249900 0.250100] } { set ok 0 } set ok } \ -result 1 test nelderMead-1.1 "Nelder-Mead - wrong \# args" \ -body { ::math::optimize::nelderMead f {0.0 0.0} -bogus } \ -returnCodes error \ -match glob \ -result "wrong \# args*" test nelderMead-1.2 "Nelder-Mead - bad param" \ -body { ::math::optimize::nelderMead f {0.0 0.0} -bogus 1 } \ -returnCodes error \ -match glob \ -result {unknown option "-bogus"*} test nelderMead-1.3 "Nelder-Mead - bad size of scale" \ -body { ::math::optimize::nelderMead f {0.0 0.0} -scale {0 0 0} } \ -returnCodes error \ -result {-scale vector must be of same size as starting x vector} # Easy case - minimize in a paraboloid test nelderMead-2.1 "Nelder-Mead - easy" \ -setup { proc f {x y} { expr {($x-3.)*($x-3.) + ($y-2.)*($y-2.) + 1.} } } \ -body { array set dd [::math::optimize::nelderMead f {1. 1.}] foreach {x y} $dd(x) break expr { abs($x-3.) < 0.001 && abs($y-2.) < 0.001 } } \ -cleanup { rename f {}; unset dd } \ -result 1 test nelderMead-2.2 "Nelder-Mead - easy" \ -setup { proc f {x y} { expr {($x-3.)*($x-3.) + ($y-2.)*($y-2.) + 1.} } } \ -body { array set dd [::math::optimize::nelderMead f {0. 0.}] foreach {x y} $dd(x) break expr { abs($x-3.) < 0.001 && abs($y-2.) < 0.001 } } \ -cleanup { rename f {}; unset dd } \ -result 1 # Slalom down a sinuous valley - exercises most of the code test nelderMead-2.3 "Nelder-Mead - sinuous valley" \ -setup { set pi 3.1415926535897932 proc f {x y} { set xx [expr { $x - 3.1415926535897932 / 2. }] set v1 [expr { 0.3 * exp( -$xx*$xx / 2. ) }] set d [expr { 10. * $y - sin(9. * $x) }] set v2 [expr { exp(-10.*$d*$d)}] set rv [expr { -$v1 - $v2 }] return $rv } } \ -body { array set dd [::math::optimize::nelderMead f {1. 0.} -scale {0.1 0.01}] foreach {x y} $dd(x) break expr { abs($x-$pi/2) < 0.001 && abs($y-0.1) < 0.001 } } \ -cleanup {rename f {}; unset dd} \ -result 1 # Exercise the difficult case where the simplex has to contract about the # low point because all else has failed. test nelderMead-2.4 "Nelder-Mead - simplex contracts about the minimum" \ -setup { proc g {a b} { set x1 [expr {0.1 - $a + $b}] set x2 [expr {$a + $b - 1.}] set x3 [expr {3.-8.*$a+8.*$a*$a-8.*$b+8.*$b*$b}] set x4 [expr {$a/10. + $b/10. + $x1*$x1/3. + $x2*$x2 - $x2 * exp(1-$x3*$x3)}] return $x4 } } \ -body { array set dd [::math::optimize::nelderMead g {0. 0.} \ -scale {1. 1.} -ftol 1e-10] foreach {x y} $dd(x) break expr { abs($x-0.774561) < 0.00005 && abs($y-0.755644) < 0.00005 } } \ -cleanup { rename g {}; unset dd } \ -result 1 testsuiteCleanup # Restore precision set ::tcl_precision $old_precision # Local Variables: # mode: tcl # End: } ;# End of optimizetest namespace tcllib-1.15/modules/math/statistics.tcl0000755000175000017500000012012712077663116017545 0ustar sergeisergei# statistics.tcl -- # # Package for basic statistical analysis # # version 0.1: initial implementation, january 2003 # version 0.1.1: added linear regression, june 2004 # version 0.1.2: border case in stdev taken care of # version 0.1.3: moved initialisation of CDF to first call, november 2004 # version 0.3: added test for normality (as implemented by Torsten Reincke), march 2006 # (also fixed an error in the export list) # version 0.4: added the multivariate linear regression procedures by # Eric Kemp-Benedict, february 2007 # version 0.5: added the population standard deviation and variance, # as suggested by Dimitrios Zachariadis # version 0.6: added pdf and cdf procedures for various distributions # (provided by Eric Kemp-Benedict) # version 0.7: added Kruskal-Wallis test (by Torsten Berg) # version 0.8: added Wilcoxon test and Spearman rank correlation package provide math::statistics 0.8.0 package require math # ::math::statistics -- # Namespace holding the procedures and variables # namespace eval ::math::statistics { # # Safer: change to short procedures # namespace export mean min max number var stdev pvar pstdev basic-stats corr \ histogram interval-mean-stdev t-test-mean quantiles \ test-normal lillieforsFit \ autocorr crosscorr filter map samplescount median \ test-2x2 print-2x2 control-xbar test_xbar \ control-Rchart test-Rchart \ test-Kruskal-Wallis analyse-Kruskal-Wallis group-rank \ test-Wilcoxon spearman-rank spearman-rank-extended # # Error messages # variable NEGSTDEV {Zero or negative standard deviation} variable TOOFEWDATA {Too few or invalid data} variable OUTOFRANGE {Argument out of range} # # Coefficients involved # variable factorNormalPdf set factorNormalPdf [expr {sqrt(8.0*atan(1.0))}] # xbar/R-charts: # Data from: # Peter W.M. John: # Statistical methods in engineering and quality assurance # Wiley and Sons, 1990 # variable control_factors { A2 {1.880 1.093 0.729 0.577 0.483 0.419 0.419} D3 {0.0 0.0 0.0 0.0 0.0 0.076 0.076} D4 {3.267 2.574 2.282 2.114 2.004 1.924 1.924} } } # mean, min, max, number, var, stdev, pvar, pstdev -- # Return the mean (minimum, maximum) value of a list of numbers # or number of non-missing values # # Arguments: # type Type of value to be returned # values List of values to be examined # # Results: # Value that was required # # namespace eval ::math::statistics { foreach type {mean min max number stdev var pstdev pvar} { proc $type { values } "BasicStats $type \$values" } proc basic-stats { values } "BasicStats all \$values" } # BasicStats -- # Return the one or all of the basic statistical properties # # Arguments: # type Type of value to be returned # values List of values to be examined # # Results: # Value that was required # proc ::math::statistics::BasicStats { type values } { variable TOOFEWDATA if { [lsearch {all mean min max number stdev var pstdev pvar} $type] < 0 } { return -code error \ -errorcode ARG -errorinfo [list unknown type of statistic -- $type] \ [list unknown type of statistic -- $type] } set min {} set max {} set mean {} set stdev {} set var {} set sum 0.0 set sumsq 0.0 set number 0 set first {} foreach value $values { if { $value == {} } { continue } set value [expr {double($value)}] if { $first == {} } { set first $value } incr number set sum [expr {$sum+$value}] set sumsq [expr {$sumsq+($value-$first)*($value-$first)}] if { $min == {} || $value < $min } { set min $value } if { $max == {} || $value > $max } { set max $value } } if { $number > 0 } { set mean [expr {$sum/$number}] } else { return -code error -errorcode DATA -errorinfo $TOOFEWDATA $TOOFEWDATA } if { $number > 1 } { set var [expr {($sumsq-($mean-$first)*($sum-$number*$first))/double($number-1)}] # # Take care of a rare situation: uniform data might # cause a tiny negative difference # if { $var < 0.0 } { set var 0.0 } set stdev [expr {sqrt($var)}] } set pvar [expr {($sumsq-($mean-$first)*($sum-$number*$first))/double($number)}] # # Take care of a rare situation: uniform data might # cause a tiny negative difference # if { $pvar < 0.0 } { set pvar 0.0 } set pstdev [expr {sqrt($pvar)}] set all [list $mean $min $max $number $stdev $var $pstdev $pvar] # # Return the appropriate value # set $type } # histogram -- # Return histogram information from a list of numbers # # Arguments: # limits Upper limits for the buckets (in increasing order) # values List of values to be examined # # Results: # List of number of values in each bucket (length is one more than # the number of limits) # # proc ::math::statistics::histogram { limits values } { if { [llength $limits] < 1 } { return -code error -errorcode ARG -errorinfo {No limits given} {No limits given} } set limits [lsort -real -increasing $limits] for { set index 0 } { $index <= [llength $limits] } { incr index } { set buckets($index) 0 } set last [llength $limits] foreach value $values { if { $value == {} } { continue } set index 0 set found 0 foreach limit $limits { if { $value <= $limit } { set found 1 incr buckets($index) break } incr index } if { $found == 0 } { incr buckets($last) } } set result {} for { set index 0 } { $index <= $last } { incr index } { lappend result $buckets($index) } return $result } # corr -- # Return the correlation coefficient of two sets of data # # Arguments: # data1 List with the first set of data # data2 List with the second set of data # # Result: # Correlation coefficient of the two # proc ::math::statistics::corr { data1 data2 } { variable TOOFEWDATA set number 0 set sum1 0.0 set sum2 0.0 set sumsq1 0.0 set sumsq2 0.0 set sumprod 0.0 foreach value1 $data1 value2 $data2 { if { $value1 == {} || $value2 == {} } { continue } set value1 [expr {double($value1)}] set value2 [expr {double($value2)}] set sum1 [expr {$sum1+$value1}] set sum2 [expr {$sum2+$value2}] set sumsq1 [expr {$sumsq1+$value1*$value1}] set sumsq2 [expr {$sumsq2+$value2*$value2}] set sumprod [expr {$sumprod+$value1*$value2}] incr number } if { $number > 0 } { set numerator [expr {$number*$sumprod-$sum1*$sum2}] set denom1 [expr {sqrt($number*$sumsq1-$sum1*$sum1)}] set denom2 [expr {sqrt($number*$sumsq2-$sum2*$sum2)}] if { $denom1 != 0.0 && $denom2 != 0.0 } { set corr_coeff [expr {$numerator/$denom1/$denom2}] } elseif { $denom1 != 0.0 || $denom2 != 0.0 } { set corr_coeff 0.0 ;# Uniform against non-uniform } else { set corr_coeff 1.0 ;# Both uniform } } else { return -code error -errorcode DATA -errorinfo $TOOFEWDATA $TOOFEWDATA } return $corr_coeff } # lillieforsFit -- # Calculate the goodness of fit according to Lilliefors # (goodness of fit to a normal distribution) # # Arguments: # values List of values to be tested for normality # # Result: # Value of the statistic D # proc ::math::statistics::lillieforsFit {values} { # # calculate the goodness of fit according to Lilliefors # (goodness of fit to a normal distribution) # # values -> list of values to be tested for normality # (these values are sampled counts) # # calculate standard deviation and mean of the sample: set n [llength $values] if { $n < 5 } { return -code error "Insufficient number of data (at least five required)" } set sd [stdev $values] set mean [mean $values] # sort the sample for further processing: set values [lsort -real $values] # standardize the sample data (Z-scores): foreach x $values { lappend stdData [expr {($x - $mean)/double($sd)}] } # compute the value of the distribution function at every sampled point: foreach x $stdData { lappend expData [pnorm $x] } # compute D+: set i 0 foreach x $expData { incr i lappend dplus [expr {$i/double($n)-$x}] } set dplus [lindex [lsort -real $dplus] end] # compute D-: set i 0 foreach x $expData { incr i lappend dminus [expr {$x-($i-1)/double($n)}] } set dminus [lindex [lsort -real $dminus] end] # Calculate the test statistic D # by finding the maximal vertical difference # between the sample and the expectation: # set D [expr {$dplus > $dminus ? $dplus : $dminus}] # We now use the modified statistic Z, # because D is only reliable # if the p-value is smaller than 0.1 return [expr {$D * (sqrt($n) - 0.01 + 0.831/sqrt($n))}] } # pnorm -- # Calculate the cumulative distribution function (cdf) # for the standard normal distribution like in the statistical # software 'R' (mean=0 and sd=1) # # Arguments: # x Value fro which the cdf should be calculated # # Result: # Value of the statistic D # proc ::math::statistics::pnorm {x} { # # cumulative distribution function (cdf) # for the standard normal distribution like in the statistical software 'R' # (mean=0 and sd=1) # # x -> value for which the cdf should be calculated # set sum [expr {double($x)}] set oldSum 0.0 set i 1 set denom 1.0 while {$sum != $oldSum} { set oldSum $sum incr i 2 set denom [expr {$denom*$i}] #puts "$i - $denom" set sum [expr {$oldSum + pow($x,$i)/$denom}] } return [expr {0.5 + $sum * exp(-0.5 * $x*$x - 0.91893853320467274178)}] } # pnorm_quicker -- # Calculate the cumulative distribution function (cdf) # for the standard normal distribution - quicker alternative # (less accurate) # # Arguments: # x Value for which the cdf should be calculated # # Result: # Value of the statistic D # proc ::math::statistics::pnorm_quicker {x} { set n [expr {abs($x)}] set n [expr {1.0 + $n*(0.04986735 + $n*(0.02114101 + $n*(0.00327763 \ + $n*(0.0000380036 + $n*(0.0000488906 + $n*0.000005383)))))}] set n [expr {1.0/pow($n,16)}] # if {$x >= 0} { return [expr {1 - $n/2.0}] } else { return [expr {$n/2.0}] } } # test-normal -- # Test for normality (using method Lilliefors) # # Arguments: # data Values that need to be tested # confidence ... # # Result: # 1 if of the statistic D # proc ::math::statistics::test-normal {data confidence} { set D [lillieforsFit $data] set Dcrit -- if { abs($confidence-0.80) < 0.0001 } { set Dcrit 0.741 } if { abs($confidence-0.85) < 0.0001 } { set Dcrit 0.775 } if { abs($confidence-0.90) < 0.0001 } { set Dcrit 0.819 } if { abs($confidence-0.95) < 0.0001 } { set Dcrit 0.895 } if { abs($confidence-0.99) < 0.0001 } { set Dcrit 1.035 } if { $Dcrit != "--" } { return [expr {$D > $Dcrit ? 1 : 0 }] } else { return -code error "Confidence level must be one of: 0.80, 0.85, 0.90, 0.95 or 0.99" } } # t-test-mean -- # Test whether the mean value of a sample is in accordance with the # estimated normal distribution with a certain level of confidence # (Student's t test) # # Arguments: # data List of raw data values (small sample) # est_mean Estimated mean of the distribution # est_stdev Estimated stdev of the distribution # confidence Confidence level (0.95 or 0.99 for instance) # # Result: # 1 if the test is positive, 0 otherwise. If there are too few data, # returns an empty string # proc ::math::statistics::t-test-mean { data est_mean est_stdev confidence } { variable NEGSTDEV variable TOOFEWDATA if { $est_stdev <= 0.0 } { return -code error -errorcode ARG -errorinfo $NEGSTDEV $NEGSTDEV } set allstats [BasicStats all $data] set conf2 [expr {(1.0+$confidence)/2.0}] set sample_mean [lindex $allstats 0] set sample_number [lindex $allstats 3] if { $sample_number > 1 } { set tzero [expr {abs($sample_mean-$est_mean)/$est_stdev * \ sqrt($sample_number-1)}] set degrees [expr {$sample_number-1}] set prob [cdf-students-t $degrees $tzero] return [expr {$prob<$conf2}] } else { return -code error -errorcode DATA -errorinfo $TOOFEWDATA $TOOFEWDATA } } # interval-mean-stdev -- # Return the interval containing the mean value and one # containing the standard deviation with a certain # level of confidence (assuming a normal distribution) # # Arguments: # data List of raw data values # confidence Confidence level (0.95 or 0.99 for instance) # # Result: # List having the following elements: lower and upper bounds of # mean, lower and upper bounds of stdev # # proc ::math::statistics::interval-mean-stdev { data confidence } { variable TOOFEWDATA set allstats [BasicStats all $data] set conf2 [expr {(1.0+$confidence)/2.0}] set mean [lindex $allstats 0] set number [lindex $allstats 3] set stdev [lindex $allstats 4] if { $number > 1 } { set degrees [expr {$number-1}] set student_t [expr {sqrt([Inverse-cdf-toms322 1 $degrees $conf2])}] set mean_lower [expr {$mean-$student_t*$stdev/sqrt($number)}] set mean_upper [expr {$mean+$student_t*$stdev/sqrt($number)}] set stdev_lower {} set stdev_upper {} return [list $mean_lower $mean_upper $stdev_lower $stdev_upper] } else { return -code error -errorcode DATA -errorinfo $TOOFEWDATA $TOOFEWDATA } } # quantiles -- # Return the quantiles for a given set of data or histogram # # Arguments: # (two arguments) # data List of raw data values # confidence Confidence level (0.95 or 0.99 for instance) # (three arguments) # limits List of upper limits from histogram # counts List of counts for for each interval in histogram # confidence Confidence level (0.95 or 0.99 for instance) # # Result: # List of quantiles # proc ::math::statistics::quantiles { arg1 arg2 {arg3 {}} } { variable TOOFEWDATA if { [catch { if { $arg3 == {} } { set result \ [::math::statistics::QuantilesRawData $arg1 $arg2] } else { set result \ [::math::statistics::QuantilesHistogram $arg1 $arg2 $arg3] } } msg] } { return -code error -errorcode $msg $msg } return $result } # QuantilesRawData -- # Return the quantiles based on raw data # # Arguments: # data List of raw data values # confidence Confidence level (0.95 or 0.99 for instance) # # Result: # List of quantiles # proc ::math::statistics::QuantilesRawData { data confidence } { variable TOOFEWDATA variable OUTOFRANGE if { [llength $confidence] <= 0 } { return -code error -errorcode ARG "$TOOFEWDATA - quantiles" } if { [llength $data] <= 0 } { return -code error -errorcode ARG "$TOOFEWDATA - raw data" } foreach cond $confidence { if { $cond <= 0.0 || $cond >= 1.0 } { return -code error -errorcode ARG "$OUTOFRANGE - quantiles" } } # # Sort the data first # set sorted_data [lsort -real -increasing $data] # # Determine the list element lower or equal to the quantile # and return the corresponding value # set result {} set number_data [llength $sorted_data] foreach cond $confidence { set elem [expr {round($number_data*$cond)-1}] if { $elem < 0 } { set elem 0 } lappend result [lindex $sorted_data $elem] } return $result } # QuantilesHistogram -- # Return the quantiles based on histogram information only # # Arguments: # limits Upper limits for histogram intervals # counts Counts for each interval # confidence Confidence level (0.95 or 0.99 for instance) # # Result: # List of quantiles # proc ::math::statistics::QuantilesHistogram { limits counts confidence } { variable TOOFEWDATA variable OUTOFRANGE if { [llength $confidence] <= 0 } { return -code error -errorcode ARG "$TOOFEWDATA - quantiles" } if { [llength $confidence] <= 0 } { return -code error -errorcode ARG "$TOOFEWDATA - histogram limits" } if { [llength $counts] <= [llength $limits] } { return -code error -errorcode ARG "$TOOFEWDATA - histogram counts" } foreach cond $confidence { if { $cond <= 0.0 || $cond >= 1.0 } { return -code error -errorcode ARG "$OUTOFRANGE - quantiles" } } # # Accumulate the histogram counts first # set sum 0 set accumulated_counts {} foreach count $counts { set sum [expr {$sum+$count}] lappend accumulated_counts $sum } set total_counts $sum # # Determine the list element lower or equal to the quantile # and return the corresponding value (use interpolation if # possible) # set result {} foreach cond $confidence { set found 0 set bound [expr {round($total_counts*$cond)}] set lower_limit {} set lower_count 0 foreach acc_count $accumulated_counts limit $limits { if { $acc_count >= $bound } { set found 1 break } set lower_limit $limit set lower_count $acc_count } if { $lower_limit == {} || $limit == {} || $found == 0 } { set quant $limit if { $limit == {} } { set quant $lower_limit } } else { set quant [expr {$limit+($lower_limit-$limit) * ($acc_count-$bound)/($acc_count-$lower_count)}] } lappend result $quant } return $result } # autocorr -- # Return the autocorrelation function (assuming equidistance between # samples) # # Arguments: # data Raw data for which the autocorrelation must be determined # # Result: # List of autocorrelation values (about 1/2 the number of raw data) # proc ::math::statistics::autocorr { data } { variable TOOFEWDATA if { [llength $data] <= 1 } { return -code error -errorcode ARG "$TOOFEWDATA" } return [crosscorr $data $data] } # crosscorr -- # Return the cross-correlation function (assuming equidistance # between samples) # # Arguments: # data1 First set of raw data # data2 Second set of raw data # # Result: # List of cross-correlation values (about 1/2 the number of raw data) # # Note: # The number of data pairs is not kept constant - because tests # showed rather awkward results when it was kept constant. # proc ::math::statistics::crosscorr { data1 data2 } { variable TOOFEWDATA if { [llength $data1] <= 1 || [llength $data2] <= 1 } { return -code error -errorcode ARG "$TOOFEWDATA" } # # First determine the number of data pairs # set number1 [llength $data1] set number2 [llength $data2] set basic_stat1 [basic-stats $data1] set basic_stat2 [basic-stats $data2] set vmean1 [lindex $basic_stat1 0] set vmean2 [lindex $basic_stat2 0] set vvar1 [lindex $basic_stat1 end] set vvar2 [lindex $basic_stat2 end] set number_pairs $number1 if { $number1 > $number2 } { set number_pairs $number2 } set number_values $number_pairs set number_delays [expr {$number_values/2.0}] set scale [expr {sqrt($vvar1*$vvar2)}] set result {} for { set delay 0 } { $delay < $number_delays } { incr delay } { set sumcross 0.0 set no_cross 0 for { set idx 0 } { $idx < $number_values } { incr idx } { set value1 [lindex $data1 $idx] set value2 [lindex $data2 [expr {$idx+$delay}]] if { $value1 != {} && $value2 != {} } { set sumcross \ [expr {$sumcross+($value1-$vmean1)*($value2-$vmean2)}] incr no_cross } } lappend result [expr {$sumcross/($no_cross*$scale)}] incr number_values -1 } return $result } # mean-histogram-limits # Determine reasonable limits based on mean and standard deviation # for a histogram # # Arguments: # mean Mean of the data # stdev Standard deviation # number Number of limits to generate (defaults to 8) # # Result: # List of limits # proc ::math::statistics::mean-histogram-limits { mean stdev {number 8} } { variable NEGSTDEV if { $stdev <= 0.0 } { return -code error -errorcode ARG "$NEGSTDEV" } if { $number < 1 } { return -code error -errorcode ARG "Number of limits must be positive" } # # Always: between mean-3.0*stdev and mean+3.0*stdev # number = 2: -0.25, 0.25 # number = 3: -0.25, 0, 0.25 # number = 4: -1, -0.25, 0.25, 1 # number = 5: -1, -0.25, 0, 0.25, 1 # number = 6: -2, -1, -0.25, 0.25, 1, 2 # number = 7: -2, -1, -0.25, 0, 0.25, 1, 2 # number = 8: -3, -2, -1, -0.25, 0.25, 1, 2, 3 # switch -- $number { "1" { set limits {0.0} } "2" { set limits {-0.25 0.25} } "3" { set limits {-0.25 0.0 0.25} } "4" { set limits {-1.0 -0.25 0.25 1.0} } "5" { set limits {-1.0 -0.25 0.0 0.25 1.0} } "6" { set limits {-2.0 -1.0 -0.25 0.25 1.0 2.0} } "7" { set limits {-2.0 -1.0 -0.25 0.0 0.25 1.0 2.0} } "8" { set limits {-3.0 -2.0 -1.0 -0.25 0.25 1.0 2.0 3.0} } "9" { set limits {-3.0 -2.0 -1.0 -0.25 0.0 0.25 1.0 2.0 3.0} } default { set dlim [expr {6.0/double($number-1)}] for {set i 0} {$i <$number} {incr i} { lappend limits [expr {$dlim*($i-($number-1)/2.0)}] } } } set result {} foreach limit $limits { lappend result [expr {$mean+$limit*$stdev}] } return $result } # minmax-histogram-limits # Determine reasonable limits based on minimum and maximum bounds # for a histogram # # Arguments: # min Estimated minimum # max Estimated maximum # number Number of limits to generate (defaults to 8) # # Result: # List of limits # proc ::math::statistics::minmax-histogram-limits { min max {number 8} } { variable NEGSTDEV if { $number < 1 } { return -code error -errorcode ARG "Number of limits must be positive" } if { $min >= $max } { return -code error -errorcode ARG "Minimum must be lower than maximum" } set result {} set dlim [expr {($max-$min)/double($number-1)}] for {set i 0} {$i <$number} {incr i} { lappend result [expr {$min+$dlim*$i}] } return $result } # linear-model # Determine the coefficients for a linear regression between # two series of data (the model: Y = A + B*X) # # Arguments: # xdata Series of independent (X) data # ydata Series of dependent (Y) data # intercept Whether to use an intercept or not (optional) # # Result: # List of the following items: # - (Estimate of) Intercept A # - (Estimate of) Slope B # - Standard deviation of Y relative to fit # - Correlation coefficient R2 # - Number of degrees of freedom df # - Standard error of the intercept A # - Significance level of A # - Standard error of the slope B # - Significance level of B # # proc ::math::statistics::linear-model { xdata ydata {intercept 1} } { variable TOOFEWDATA if { [llength $xdata] < 3 } { return -code error -errorcode ARG "$TOOFEWDATA: not enough independent data" } if { [llength $ydata] < 3 } { return -code error -errorcode ARG "$TOOFEWDATA: not enough dependent data" } if { [llength $xdata] != [llength $ydata] } { return -code error -errorcode ARG "$TOOFEWDATA: number of dependent data differs from number of independent data" } set sumx 0.0 set sumy 0.0 set sumx2 0.0 set sumy2 0.0 set sumxy 0.0 set df 0 foreach x $xdata y $ydata { if { $x != "" && $y != "" } { set sumx [expr {$sumx+$x}] set sumy [expr {$sumy+$y}] set sumx2 [expr {$sumx2+$x*$x}] set sumy2 [expr {$sumy2+$y*$y}] set sumxy [expr {$sumxy+$x*$y}] incr df } } if { $df <= 2 } { return -code error -errorcode ARG "$TOOFEWDATA: too few valid data" } if { $sumx2 == 0.0 } { return -code error -errorcode ARG "$TOOFEWDATA: independent values are all the same" } # # Calculate the intermediate quantities # set sx [expr {$sumx2-$sumx*$sumx/$df}] set sy [expr {$sumy2-$sumy*$sumy/$df}] set sxy [expr {$sumxy-$sumx*$sumy/$df}] # # Calculate the coefficients # if { $intercept } { set B [expr {$sxy/$sx}] set A [expr {($sumy-$B*$sumx)/$df}] } else { set B [expr {$sumxy/$sumx2}] set A 0.0 } # # Calculate the error estimates # set stdevY 0.0 set varY 0.0 if { $intercept } { set ve [expr {$sy-$B*$sxy}] if { $ve >= 0.0 } { set varY [expr {$ve/($df-2)}] } } else { set ve [expr {$sumy2-$B*$sumxy}] if { $ve >= 0.0 } { set varY [expr {$ve/($df-1)}] } } set seY [expr {sqrt($varY)}] if { $intercept } { set R2 [expr {$sxy*$sxy/($sx*$sy)}] set seA [expr {$seY*sqrt(1.0/$df+$sumx*$sumx/($sx*$df*$df))}] set seB [expr {sqrt($varY/$sx)}] set tA {} set tB {} if { $seA != 0.0 } { set tA [expr {$A/$seA*sqrt($df-2)}] } if { $seB != 0.0 } { set tB [expr {$B/$seB*sqrt($df-2)}] } } else { set R2 [expr {$sumxy*$sumxy/($sumx2*$sumy2)}] set seA {} set tA {} set tB {} set seB [expr {sqrt($varY/$sumx2)}] if { $seB != 0.0 } { set tB [expr {$B/$seB*sqrt($df-1)}] } } # # Return the list of parameters # return [list $A $B $seY $R2 $df $seA $tA $seB $tB] } # linear-residuals # Determine the difference between actual data and predicted from # the linear model # # Arguments: # xdata Series of independent (X) data # ydata Series of dependent (Y) data # intercept Whether to use an intercept or not (optional) # # Result: # List of differences # proc ::math::statistics::linear-residuals { xdata ydata {intercept 1} } { variable TOOFEWDATA if { [llength $xdata] < 3 } { return -code error -errorcode ARG "$TOOFEWDATA: no independent data" } if { [llength $ydata] < 3 } { return -code error -errorcode ARG "$TOOFEWDATA: no dependent data" } if { [llength $xdata] != [llength $ydata] } { return -code error -errorcode ARG "$TOOFEWDATA: number of dependent data differs from number of independent data" } foreach {A B} [linear-model $xdata $ydata $intercept] {break} set result {} foreach x $xdata y $ydata { set residue [expr {$y-$A-$B*$x}] lappend result $residue } return $result } # median # Determine the median from a list of data # # Arguments: # data (Unsorted) list of data # # Result: # Median (either the middle value or the mean of two values in the # middle) # # Note: # Adapted from the Wiki page "Stats", code provided by JPS # proc ::math::statistics::median { data } { set org_data $data set data {} foreach value $org_data { if { $value != {} } { lappend data $value } } set len [llength $data] set data [lsort -real $data] if { $len % 2 } { lindex $data [expr {($len-1)/2}] } else { expr {([lindex $data [expr {($len / 2) - 1}]] \ + [lindex $data [expr {$len / 2}]]) / 2.0} } } # test-2x2 -- # Compute the chi-square statistic for a 2x2 table # # Arguments: # a Element upper-left # b Element upper-right # c Element lower-left # d Element lower-right # Return value: # Chi-square # Note: # There is only one degree of freedom - this is important # when comparing the value to the tabulated values # of chi-square # proc ::math::statistics::test-2x2 { a b c d } { set ab [expr {$a+$b}] set ac [expr {$a+$c}] set bd [expr {$b+$d}] set cd [expr {$c+$d}] set N [expr {$a+$b+$c+$d}] set det [expr {$a*$d-$b*$c}] set result [expr {double($N*$det*$det)/double($ab*$cd*$ac*$bd)}] } # print-2x2 -- # Print a 2x2 table # # Arguments: # a Element upper-left # b Element upper-right # c Element lower-left # d Element lower-right # Return value: # Printed version with marginals # proc ::math::statistics::print-2x2 { a b c d } { set ab [expr {$a+$b}] set ac [expr {$a+$c}] set bd [expr {$b+$d}] set cd [expr {$c+$d}] set N [expr {$a+$b+$c+$d}] set chisq [test-2x2 $a $b $c $d] set line [string repeat - 10] set result [format "%10d%10d | %10d\n" $a $b $ab] append result [format "%10d%10d | %10d\n" $c $d $cd] append result [format "%10s%10s + %10s\n" $line $line $line] append result [format "%10d%10d | %10d\n" $ac $bd $N] append result "Chisquare = $chisq\n" append result "Difference is significant?\n" append result " at 95%: [expr {$chisq<3.84146? "no":"yes"}]\n" append result " at 99%: [expr {$chisq<6.63490? "no":"yes"}]" } # control-xbar -- # Determine the control lines for an x-bar chart # # Arguments: # data List of observed values (at least 20*nsamples) # nsamples Number of data per subsamples (default: 4) # Return value: # List of: mean, lower limit, upper limit, number of data per # subsample. Can be used in the test-xbar procedure # proc ::math::statistics::control-xbar { data {nsamples 4} } { variable TOOFEWDATA variable control_factors # # Check the number of data # if { $nsamples <= 1 } { return -code error -errorcode DATA -errorinfo $OUTOFRANGE \ "Number of data per subsample must be at least 2" } if { [llength $data] < 20*$nsamples } { return -code error -errorcode DATA -errorinfo $TOOFEWDATA $TOOFEWDATA } set nogroups [expr {[llength $data]/$nsamples}] set mrange 0.0 set xmeans 0.0 for { set i 0 } { $i < $nogroups } { incr i } { set subsample [lrange $data [expr {$i*$nsamples}] [expr {$i*$nsamples+$nsamples-1}]] set xmean 0.0 set xmin [lindex $subsample 0] set xmax $xmin foreach d $subsample { set xmean [expr {$xmean+$d}] set xmin [expr {$xmin<$d? $xmin : $d}] set xmax [expr {$xmax>$d? $xmax : $d}] } set xmean [expr {$xmean/double($nsamples)}] set xmeans [expr {$xmeans+$xmean}] set mrange [expr {$mrange+($xmax-$xmin)}] } # # Determine the control lines # set xmeans [expr {$xmeans/double($nogroups)}] set mrange [expr {$mrange/double($nogroups)}] set A2 [lindex [lindex $control_factors 1] $nsamples] if { $A2 == "" } { set A2 [lindex [lindex $control_factors 1] end] } return [list $xmeans [expr {$xmeans-$A2*$mrange}] \ [expr {$xmeans+$A2*$mrange}] $nsamples] } # test-xbar -- # Determine if any data points lie outside the x-bar control limits # # Arguments: # control List returned by control-xbar with control data # data List of observed values # Return value: # Indices of any subsamples that violate the control limits # proc ::math::statistics::test-xbar { control data } { foreach {xmean xlower xupper nsamples} $control {break} if { [llength $data] < 1 } { return -code error -errorcode DATA -errorinfo $TOOFEWDATA $TOOFEWDATA } set nogroups [expr {[llength $data]/$nsamples}] if { $nogroups <= 0 } { set nogroup 1 set nsamples [llength $data] } set result {} for { set i 0 } { $i < $nogroups } { incr i } { set subsample [lrange $data [expr {$i*$nsamples}] [expr {$i*$nsamples+$nsamples-1}]] set xmean 0.0 foreach d $subsample { set xmean [expr {$xmean+$d}] } set xmean [expr {$xmean/double($nsamples)}] if { $xmean < $xlower } { lappend result $i } if { $xmean > $xupper } { lappend result $i } } return $result } # control-Rchart -- # Determine the control lines for an R chart # # Arguments: # data List of observed values (at least 20*nsamples) # nsamples Number of data per subsamples (default: 4) # Return value: # List of: mean range, lower limit, upper limit, number of data per # subsample. Can be used in the test-Rchart procedure # proc ::math::statistics::control-Rchart { data {nsamples 4} } { variable TOOFEWDATA variable control_factors # # Check the number of data # if { $nsamples <= 1 } { return -code error -errorcode DATA -errorinfo $OUTOFRANGE \ "Number of data per subsample must be at least 2" } if { [llength $data] < 20*$nsamples } { return -code error -errorcode DATA -errorinfo $TOOFEWDATA $TOOFEWDATA } set nogroups [expr {[llength $data]/$nsamples}] set mrange 0.0 for { set i 0 } { $i < $nogroups } { incr i } { set subsample [lrange $data [expr {$i*$nsamples}] [expr {$i*$nsamples+$nsamples-1}]] set xmin [lindex $subsample 0] set xmax $xmin foreach d $subsample { set xmin [expr {$xmin<$d? $xmin : $d}] set xmax [expr {$xmax>$d? $xmax : $d}] } set mrange [expr {$mrange+($xmax-$xmin)}] } # # Determine the control lines # set mrange [expr {$mrange/double($nogroups)}] set D3 [lindex [lindex $control_factors 3] $nsamples] set D4 [lindex [lindex $control_factors 5] $nsamples] if { $D3 == "" } { set D3 [lindex [lindex $control_factors 3] end] } if { $D4 == "" } { set D4 [lindex [lindex $control_factors 5] end] } return [list $mrange [expr {$D3*$mrange}] \ [expr {$D4*$mrange}] $nsamples] } # test-Rchart -- # Determine if any data points lie outside the R-chart control limits # # Arguments: # control List returned by control-xbar with control data # data List of observed values # Return value: # Indices of any subsamples that violate the control limits # proc ::math::statistics::test-Rchart { control data } { foreach {rmean rlower rupper nsamples} $control {break} # # Check the number of data # if { [llength $data] < 1 } { return -code error -errorcode DATA -errorinfo $TOOFEWDATA $TOOFEWDATA } set nogroups [expr {[llength $data]/$nsamples}] set result {} for { set i 0 } { $i < $nogroups } { incr i } { set subsample [lrange $data [expr {$i*$nsamples}] [expr {$i*$nsamples+$nsamples-1}]] set xmin [lindex $subsample 0] set xmax $xmin foreach d $subsample { set xmin [expr {$xmin<$d? $xmin : $d}] set xmax [expr {$xmax>$d? $xmax : $d}] } set range [expr {$xmax-$xmin}] if { $range < $rlower } { lappend result $i } if { $range > $rupper } { lappend result $i } } return $result } # # Load the auxiliary scripts # source [file join [file dirname [info script]] pdf_stat.tcl] source [file join [file dirname [info script]] plotstat.tcl] source [file join [file dirname [info script]] liststat.tcl] source [file join [file dirname [info script]] mvlinreg.tcl] source [file join [file dirname [info script]] kruskal.tcl] source [file join [file dirname [info script]] wilcoxon.tcl] # # Define the tables # namespace eval ::math::statistics { variable student_t_table # set student_t_table [::math::interpolation::defineTable student_t # {X 80% 90% 95% 98% 99%} # {X 0.80 0.90 0.95 0.98 0.99 # 1 3.078 6.314 12.706 31.821 63.657 # 2 1.886 2.920 4.303 6.965 9.925 # 3 1.638 2.353 3.182 4.541 5.841 # 5 1.476 2.015 2.571 3.365 4.032 # 10 1.372 1.812 2.228 2.764 3.169 # 15 1.341 1.753 2.131 2.602 2.947 # 20 1.325 1.725 2.086 2.528 2.845 # 30 1.310 1.697 2.042 2.457 2.750 # 60 1.296 1.671 2.000 2.390 2.660 # 1.0e9 1.282 1.645 1.960 2.326 2.576 }] # PM #set chi_squared_table [::math::interpolation::defineTable chi_square # ... } # # Simple test code # if { [info exists ::argv0] && ([file tail [info script]] == [file tail $::argv0]) } { console show puts [interp aliases] set values {1 1 1 1 {}} puts [::math::statistics::basic-stats $values] set values {1 2 3 4} puts [::math::statistics::basic-stats $values] set values {1 -1 1 -2} puts [::math::statistics::basic-stats $values] puts [::math::statistics::mean $values] puts [::math::statistics::min $values] puts [::math::statistics::max $values] puts [::math::statistics::number $values] puts [::math::statistics::stdev $values] puts [::math::statistics::var $values] set novals 100 #set maxvals 100001 set maxvals 1001 while { $novals < $maxvals } { set values {} for { set i 0 } { $i < $novals } { incr i } { lappend values [expr {rand()}] } puts [::math::statistics::basic-stats $values] puts [::math::statistics::histogram {0.0 0.2 0.4 0.6 0.8 1.0} $values] set novals [expr {$novals*10}] } puts "Normal distribution:" puts "X=0: [::math::statistics::pdf-normal 0.0 1.0 0.0]" puts "X=1: [::math::statistics::pdf-normal 0.0 1.0 1.0]" puts "X=-1: [::math::statistics::pdf-normal 0.0 1.0 -1.0]" set data1 {0.0 1.0 3.0 4.0 100.0 -23.0} set data2 {1.0 2.0 4.0 5.0 101.0 -22.0} set data3 {0.0 2.0 6.0 8.0 200.0 -46.0} set data4 {2.0 6.0 8.0 200.0 -46.0 1.0} set data5 {100.0 99.0 90.0 93.0 5.0 123.0} puts "Correlation data1 and data1: [::math::statistics::corr $data1 $data1]" puts "Correlation data1 and data2: [::math::statistics::corr $data1 $data2]" puts "Correlation data1 and data3: [::math::statistics::corr $data1 $data3]" puts "Correlation data1 and data4: [::math::statistics::corr $data1 $data4]" puts "Correlation data1 and data5: [::math::statistics::corr $data1 $data5]" # set data {1.0 2.0 2.3 4.0 3.4 1.2 0.6 5.6} # puts [::math::statistics::basicStats $data] # puts [::math::statistics::interval-mean-stdev $data 0.90] # puts [::math::statistics::interval-mean-stdev $data 0.95] # puts [::math::statistics::interval-mean-stdev $data 0.99] # puts "\nTest mean values:" # puts [::math::statistics::test-mean $data 2.0 0.1 0.90] # puts [::math::statistics::test-mean $data 2.0 0.5 0.90] # puts [::math::statistics::test-mean $data 2.0 1.0 0.90] # puts [::math::statistics::test-mean $data 2.0 2.0 0.90] set rc [catch { set m [::math::statistics::mean {}] } msg ] ; # {} puts "Result: $rc $msg" puts "\nTest quantiles:" set data {1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 10.0} set quantiles {0.11 0.21 0.51 0.91 0.99} set limits {2.1 4.1 6.1 8.1} puts [::math::statistics::quantiles $data $quantiles] set histogram [::math::statistics::histogram $limits $data] puts [::math::statistics::quantiles $limits $histogram $quantiles] puts "\nTest autocorrelation:" set data {1.0 -1.0 1.0 -1.0 1.0 -1.0 1.0 -1.0 1.0} puts [::math::statistics::autocorr $data] set data {1.0 -1.1 2.0 -0.6 3.0 -4.0 0.5 0.9 -1.0} puts [::math::statistics::autocorr $data] puts "\nTest histogram limits:" puts [::math::statistics::mean-histogram-limits 1.0 1.0] puts [::math::statistics::mean-histogram-limits 1.0 1.0 4] puts [::math::statistics::minmax-histogram-limits 1.0 10.0 10] } # # Test xbar/R-chart procedures # if { 0 } { set data {} for { set i 0 } { $i < 500 } { incr i } { lappend data [expr {rand()}] } set limits [::math::statistics::control-xbar $data] puts $limits puts "Outliers? [::math::statistics::test-xbar $limits $data]" set newdata {1.0 1.0 1.0 1.0 0.5 0.5 0.5 0.5 10.0 10.0 10.0 10.0} puts "Outliers? [::math::statistics::test-xbar $limits $newdata] -- 0 2" set limits [::math::statistics::control-Rchart $data] puts $limits puts "Outliers? [::math::statistics::test-Rchart $limits $data]" set newdata {0.0 1.0 2.0 1.0 0.4 0.5 0.6 0.5 10.0 0.0 10.0 10.0} puts "Outliers? [::math::statistics::test-Rchart $limits $newdata] -- 0 2" } tcllib-1.15/modules/math/decimal.man0000755000175000017500000002121212077663116016735 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin ::math::decimal n 1.0.2] [copyright {2011 Mark Alston }] [moddesc {Tcl Decimal Arithmetic Library}] [titledesc {General decimal arithmetic}] [category Mathematics] [require Tcl [opt 8.5]] [description] [para] The decimal package provides decimal arithmetic support for both limited precision floating point and arbitrary precision floating point. Additionally, integer arithmetic is supported. [para] More information and the specifications on which this package depends can be found on the general decimal arithmetic page at http://speleotrove.com/decimal This package provides for: [list_begin itemized] [item] A new data type decimal which is represented as a list containing sign, mantissa and exponent. [item] Arithmetic operations on those decimal numbers such as addition, subtraction, multiplication, etc... [list_end] [para] Numbers are converted to decimal format using the operation ::math::decimal::fromstr. [para] Numbers are converted back to string format using the operation ::math::decimal::tostr. [para] [section "EXAMPLES"] This section shows some simple examples. Since the purpose of this library is to perform decimal math operations, examples may be the simplest way to learn how to work with it and to see the difference between using this package and sticking with expr. Consult the API section of this man page for information about individual procedures. [para] [example_begin] package require decimal # Various operations on two numbers. # We first convert them to decimal format. set a [lb]::math::decimal::fromstr 8.2[rb] set b [lb]::math::decimal::fromstr .2[rb] # Then we perform our operations. Here we multiply set c [lb]::math::decimal::* $a $b[rb] # Finally we convert back to string format for presentation to the user. puts [lb]::math::decimal::tostr $c[rb] ; # => will output 8.4 # Other examples # # Subtraction set c [lb]::math::decimal::- $a $b[rb] puts [lb]::math::decimal::tostr $c[rb] ; # => will output 8.0 # Why bother using this instead of simply expr? puts [expr {8.2 + .2}] ; # => will output 8.399999999999999 puts [expr {8.2 - .2}] ; # => will output 7.999999999999999 # See http://speleotrove.com/decimal to learn more about why this happens. [example_end] [section "API"] [list_begin definitions] [call [cmd ::math::decimal::fromstr] [arg string]] Convert [emph string] into a decimal. [call [cmd ::math::decimal::tostr] [arg decimal]] Convert [emph decimal] into a string representing the number in base 10. [call [cmd ::math::decimal::setVariable] [arg variable] [arg setting]] Sets the [emph variable] to [emph setting]. Valid variables are: [list_begin itemized] [item][arg rounding] - Method of rounding to use during rescale. Valid methods are round_half_even, round_half_up, round_half_down, round_down, round_up, round_floor, round_ceiling. [item][arg precision] - Maximum number of digits allowed in mantissa. [item][arg extended] - Set to 1 for extended mode. 0 for simplified mode. [item][arg maxExponent] - Maximum value for the exponent. Defaults to 999. [item][arg minExponent] - Minimum value for the exponent. Default to -998. [list_end] [call [cmd ::math::decimal::add] [arg a] [arg b]] [call [cmd ::math::decimal::+] [arg a] [arg b]] Return the sum of the two decimals [emph a] and [emph b]. [call [cmd ::math::decimal::subtract] [arg a] [arg b]] [call [cmd ::math::decimal::-] [arg a] [arg b]] Return the differnece of the two decimals [emph a] and [emph b]. [call [cmd ::math::decimal::multiply] [arg a] [arg b]] [call [cmd ::math::decimal::*] [arg a] [arg b]] Return the product of the two decimals [emph a] and [emph b]. [call [cmd ::math::decimal::divide] [arg a] [arg b]] [call [cmd ::math::decimal::/] [arg a] [arg b]] Return the quotient of the division between the two decimals [emph a] and [emph b]. [call [cmd ::math::decimal::divideint] [arg a] [arg b]] Return a the integer portion of the quotient of the division between decimals [emph a] and [emph b] [call [cmd ::math::decimal::remainder] [arg a] [arg b]] Return the remainder of the division between the two decimals [emph a] and [emph b]. [call [cmd ::math::decimal::abs] [arg decimal]] Return the absolute value of the decimal. [call [cmd ::math::decimal::compare] [arg a] [arg b]] Compare the two decimals a and b, returning [emph 0] if [emph {a == b}], [emph 1] if [emph {a > b}], and [emph -1] if [emph {a < b}]. [call [cmd ::math::decimal::max] [arg a] [arg b]] Compare the two decimals a and b, and return [emph a] if [emph {a >= b}], and [emph b] if [emph {a < b}]. [call [cmd ::math::decimal::maxmag] [arg a] [arg b]] Compare the two decimals a and b while ignoring their signs, and return [emph a] if [emph {abs(a) >= abs(b)}], and [emph b] if [emph {abs(a) < abs(b)}]. [call [cmd ::math::decimal::min] [arg a] [arg b]] Compare the two decimals a and b, and return [emph a] if [emph {a <= b}], and [emph b] if [emph {a > b}]. [call [cmd ::math::decimal::minmag] [arg a] [arg b]] Compare the two decimals a and b while ignoring their signs, and return [emph a] if [emph {abs(a) <= abs(b)}], and [emph b] if [emph {abs(a) > abs(b)}]. [call [cmd ::math::decimal::plus] [arg a]] Return the result from [emph {::math::decimal::+ 0 $a}]. [call [cmd ::math::decimal::minus] [arg a]] Return the result from [emph {::math::decimal::- 0 $a}]. [call [cmd ::math::decimal::copynegate] [arg a]] Returns [emph a] with the sign flipped. [call [cmd ::math::decimal::copysign] [arg a] [arg b]] Returns [emph a] with the sign set to the sign of the [emph b]. [call [cmd ::math::decimal::is-signed] [arg decimal]] Return the sign of the decimal. The procedure returns 0 if the number is positive, 1 if it's negative. [call [cmd ::math::decimal::is-zero] [arg decimal]] Return true if [emph decimal] value is zero, otherwise false is returned. [call [cmd ::math::decimal::is-NaN] [arg decimal]] Return true if [emph decimal] value is NaN (not a number), otherwise false is returned. [call [cmd ::math::decimal::is-infinite] [arg decimal]] Return true if [emph decimal] value is Infinite, otherwise false is returned. [call [cmd ::math::decimal::is-finite] [arg decimal]] Return true if [emph decimal] value is finite, otherwise false is returned. [call [cmd ::math::decimal::fma] [arg a] [arg b] [arg c]] Return the result from first multiplying [emph a] by [emph b] and then adding [emph c]. Rescaling only occurs after completion of all operations. In this way the result may vary from that returned by performing the operations individually. [call [cmd ::math::decimal::round_half_even] [arg decimal] [arg digits]] Rounds [emph decimal] to [emph digits] number of decimal points with the following rules: Round to the nearest. If equidistant, round so the final digit is even. [call [cmd ::math::decimal::round_half_up] [arg decimal] [arg digits]] Rounds [emph decimal] to [emph digits] number of decimal points with the following rules: Round to the nearest. If equidistant, round up. [call [cmd ::math::decimal::round_half_down] [arg decimal] [arg digits]] Rounds [emph decimal] to [emph digits] number of decimal points with the following rules: Round to the nearest. If equidistant, round down. [call [cmd ::math::decimal::round_down] [arg decimal] [arg digits]] Rounds [emph decimal] to [emph digits] number of decimal points with the following rules: Round toward 0. (Truncate) [call [cmd ::math::decimal::round_up] [arg decimal] [arg digits]] Rounds [emph decimal] to [emph digits] number of decimal points with the following rules: Round away from 0 [call [cmd ::math::decimal::round_floor] [arg decimal] [arg digits]] Rounds [emph decimal] to [emph digits] number of decimal points with the following rules: Round toward -Infinity. [call [cmd ::math::decimal::round_ceiling] [arg decimal] [arg digits]] Rounds [emph decimal] to [emph digits] number of decimal points with the following rules: Round toward Infinity [call [cmd ::math::decimal::round_05up] [arg decimal] [arg digits]] Rounds [emph decimal] to [emph digits] number of decimal points with the following rules: Round zero or five away from 0. The same as round-up, except that rounding up only occurs if the digit to be rounded up is 0 or 5, and after overflow the result is the same as for round-down. [list_end] [para] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph {Decimal}] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords tcl decimal math] [manpage_end] tcllib-1.15/modules/math/numtheory.dtx0000755000175000017500000011356012077663116017425 0ustar sergeisergei% % \iffalse % %<*pkg> %% Copyright (c) 2010 by Lars Hellstrom. All rights reserved. %% See the file "license.terms" for information on usage and redistribution %% of this file, and for a DISCLAIMER OF ALL WARRANTIES. % %<*driver> \documentclass{tclldoc} \usepackage{amsmath,amsfonts} \usepackage{url} \newcommand{\Tcl}{\Tcllogo} \begin{document} \DocInput{numtheory.dtx} \end{document} % % \fi % % \title{Number theory package} % \author{Lars Hellstr\"om} % \date{30 May 2010} % \maketitle % % \begin{abstract} % This package provides a command to test whether an integer is a % prime, but may in time come to house also other number-theoretic % operations. % \end{abstract} % % \tableofcontents % % \section*{Preliminaries} % % \begin{tcl} %<*pkg> package require Tcl 8.5 % \end{tcl} % \Tcl~8.4 is seriously broken with respect to arithmetic overflow, % so we require 8.5. There are (as yet) no explicit 8.5-isms in the % code, however. % \begin{tcl} package provide math::numtheory 1.0 namespace eval ::math::numtheory { namespace export isprime } % % \end{tcl} % \setnamespace{math::numtheory} % % \Tcl lib has its own test file boilerplate. % \begin{tcl} %<*test> source [file join\ [file dirname [file dirname [file join [pwd] [info script]]]]\ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2 testing {useLocal numtheory.tcl math::numtheory} % % \end{tcl} % % And the same is true for the manpage. % \begin{tcl} %<*man> [manpage_begin math::numtheory n 1.0] [copyright "2010 Lars Hellstr\u00F6m\ "] [moddesc {Tcl Math Library}] [titledesc {Number Theory}] [category Mathematics] [require Tcl [opt 8.5]] [require math::numtheory [opt 1.0]] [description] [para] This package is for collecting various number-theoretic operations, though at the moment it only provides that of testing whether an integer is a prime. [list_begin definitions] % % \end{tcl} % % % \section{Primes} % % The first (and so far only) operation provided is |isprime|, which % tests if an integer is a prime. % \begin{tcl} %<*man> [call [cmd math::numtheory::isprime] [arg N] [ opt "[arg option] [arg value] ..." ]] The [cmd isprime] command tests whether the integer [arg N] is a prime, returning a boolean true value for prime [arg N] and a boolean false value for non-prime [arg N]. The formal definition of 'prime' used is the conventional, that the number being tested is greater than 1 and only has trivial divisors. [para] To be precise, the return value is one of [const 0] (if [arg N] is definitely not a prime), [const 1] (if [arg N] is definitely a prime), and [const on] (if [arg N] is probably prime); the latter two are both boolean true values. The case that an integer may be classified as "probably prime" arises because the Miller-Rabin algorithm used in the test implementation is basically probabilistic, and may if we are unlucky fail to detect that a number is in fact composite. Options may be used to select the risk of such "false positives" in the test. [const 1] is returned for "small" [arg N] (which currently means [arg N] < 118670087467), where it is known that no false positives are possible. [para] The only option currently defined is: [list_begin options] [opt_def -randommr [arg repetitions]] which controls how many times the Miller-Rabin test should be repeated with randomly chosen bases. Each repetition reduces the probability of a false positive by a factor at least 4. The default for [arg repetitions] is 4. [list_end] Unknown options are silently ignored. % % \end{tcl} % % % \subsection{Trial division} % % As most books on primes will tell you, practical primality % testing algorithms typically start with trial division by a list % of small known primes to weed out the low hanging fruit. This is % also an opportunity to handle special cases that might arise for % very low numbers (e.g.\ $2$ is a prime despite being even). % % \begin{proc}{prime_trialdivision} % This procedure is meant to be called as % \begin{quote} % |prime_trialdivision| \word{$n$} % \end{quote} % from \emph{within} a procedure that returns |1| if $n$ is a prime % and |0| if it is not. It does not return anything particular, but % \emph{it causes its caller to return provided} it is able to % decide what its result should be. This means one can slap it in % as the first line of a primality checker procedure, and then on % lines two and forth worry only about the nontrivial cases. % \begin{tcl} %<*pkg> proc ::math::numtheory::prime_trialdivision {n} { if {$n<2} then {return -code return 0} % \end{tcl} % Integers less than $2$ aren't primes.\footnote{ % Well, at least as one usually defines the term for integers. % When considering the concept of prime in more general rings, % one may have to settle with accepting all associates of primes % as primes as well. % } This saves us many worries by excluding negative numbers from % further considerations. % \begin{tcl} if {$n<4} then {return -code return 1} % \end{tcl} % Everything else below \(2^2 = 4\) (i.e., $2$ and $3$) are primes. % \begin{tcl} if {$n%2 == 0} then {return -code return 0} % \end{tcl} % Remaining even numbers are then composite. % \begin{tcl} if {$n<9} then {return -code return 1} % \end{tcl} % Now everything left below \(3^2 = 9\) (i.e., $5$ and $7$) are % primes. Having decided those, we can now do trial division with % $3$, $5$, and $7$ in one go. % \begin{tcl} if {$n%3 == 0} then {return -code return 0} if {$n%5 == 0} then {return -code return 0} if {$n%7 == 0} then {return -code return 0} % \end{tcl} % Any numbers less that \(11^2 = 121\) not yet eliminated are % primes; above that we know nothing. % \begin{tcl} if {$n<121} then {return -code return 1} } % % \end{tcl} % This procedure could be extended with more primes, pushing the % limit of what can be decided further up, but the returns are % diminishing, so we might be better off with a different method % for testing primality. No analysis of where the cut-off point % lies have been conducted (i.e., $7$ as last prime for trial % division was picked arbitrarily), but note that the optimum % probably depends on what distribution the input values will have. % % \begin{tcl} %<*test> test prime_trialdivision-1 "Trial division of 1" -body { ::math::numtheory::prime_trialdivision 1 } -returnCodes 2 -result 0 test prime_trialdivision-2 "Trial division of 2" -body { ::math::numtheory::prime_trialdivision 2 } -returnCodes 2 -result 1 test prime_trialdivision-3 "Trial division of 6" -body { ::math::numtheory::prime_trialdivision 6 } -returnCodes 2 -result 0 test prime_trialdivision-4 "Trial division of 7" -body { ::math::numtheory::prime_trialdivision 7 } -returnCodes 2 -result 1 test prime_trialdivision-5 "Trial division of 101" -body { ::math::numtheory::prime_trialdivision 101 } -returnCodes 2 -result 1 test prime_trialdivision-6 "Trial division of 105" -body { ::math::numtheory::prime_trialdivision 105 } -returnCodes 2 -result 0 % \end{tcl} % Note that extending the number of primes for trial division is % likely to change the results in the following two tests ($121$ % is composite, $127$ is prime). % \begin{tcl} test prime_trialdivision-7 "Trial division of 121" -body { ::math::numtheory::prime_trialdivision 121 } -returnCodes 0 -result "" test prime_trialdivision-8 "Trial division of 127" -body { ::math::numtheory::prime_trialdivision 127 } -returnCodes 0 -result "" % % \end{tcl} % \end{proc} % % % \subsection{Pseudoprimality tests} % % After trial division, the next thing tried is usually to test the % claim of Fermat's little theorem: if $n$ is a prime, then \(a^{n-1} % \equiv 1 \pmod{n}\) for all integers $a$ that are not multiples of % $n$, in particular those \(0 < a < n\); one picks such an $a$ (more % or less at random) and computes $a^{n-1} \bmod n$. Numbers that % pass are said to be \emph{(Fermat) pseudoprimes (to base $a$)}. % Most composite numbers quickly fail this test. % (One particular class that fails are the powers of primes, since % the group of invertible elements in $\mathbb{Z}_n$ for \(n = p^{k+1}\) % is cyclic\footnote{ % The easiest way to see that it is cyclic is probably to exhibit % an element of order $(p -\nobreak 1) p^k$. A good start is to % pick a primitive root $a$ of $\mathbb{Z}_p$ and compute its order % modulo $p^{k+1}$; this has to be a number on the form $(p % -\nobreak 1) p^r$. If \(r=k\) then $a$ is a primitive root and we're % done, otherwise $(p +\nobreak 1) a$ will be a primitive root % because $p+1$ can be shown to have order $p^k$ modulo $n$ and the % least common multiple of $(p -\nobreak 1) p^r$ and $p^k$ is % $(p -\nobreak 1) p^k$. To exhibit the order of $p+1$, one may % use induction on $k$ to show that \( (1 +\nobreak p)^N \equiv 1 % \pmod{p^{k+1}}\) implies \(p^k \mid N\); in \((1 +\nobreak p)^N = % \sum_{i=0}^N \binom{N}{i} p^i\), the induction hypothesis implies % all terms with \(i>1\) vanish modulo $p^{k+1}$, leaving just % \(1+Np \equiv 1 \pmod{p^{k+1}}\). % } of order $(p -\nobreak 1) p^k$ rather than order $p^{k+1}-1$. % Therefore it is only to bases $a$ of order dividing $p-1$ (i.e., a % total of $p-1$ out of $p^{k+1}-1$) that prime powers are % pseudoprimes. The chances of picking one of these are generally % rather slim.) % % Unfortunately, there are also numbers (the so-called \emph{Carmichael % numbers}) which are pseudoprimes to every base $a$ they are coprime % with. While the above trial division by $2$, $3$, $5$, and $7$ would % already have eliminated all Carmichael numbers below \(29341 = 13 % \cdot 37 \cdot 61\), their existence means that there is a % population of nonprimes which a Fermat pseudoprimality test is very % likely to mistake for primes; this would usually not be acceptable. % % \begin{proc}{Miller--Rabin} % The Miller--Rabin test is a slight variation on the Fermat test, % where the computation of $a^{n-1} \bmod n$ is structured so that % additional consequences of $n$ being a prime can be tested. % Rabin~\cite{Rabin} % proved that any composite $n$ will for this test be revealed as % such by at least $3/4$ of all bases $a$, thus making it a valid % probabilistic test. (Miller~\cite{Miller} had first designed it as % a deterministic polynomial algorithm, but in that case the proof % that it works relies on the generalised Riemann hypothesis.) % % Given natural numbers $s$ and $d$ such that \(n-1 = 2^s d\), the % computation of $a^{n-1}$ is organised as $(a^d)^{2^s}$, where the % $s$ part is conveniently performed by squaring $s$ times. This is % of little consequence when $n$ is not a pseudoprime since one % will simply arrive at some \(a^{n-1} \not\equiv 1 \pmod{n}\), but % in the case that $n$ is a pseudoprime these repeated squarings will % exhibit some $x$ such that \(x^2 \equiv 1 \pmod{n}\), and this % makes it possible to test another property $n$ must have if it is % prime, namely that such an \(x \equiv \pm 1 \pmod{n}\). % % That implication is of course well known for real (and complex) % numbers, but even though what we're dealing with here is rather % residue classes modulo an integer, the proof that it holds is % basically the same. If $n$ is a prime, then the residue class % ring $\mathbb{Z}_n$ is a field, and hence the ring % $\mathbb{Z}_n[x]$ of polynomials over that field is a Unique % Factorisation Domain. As it happens, \(x^2 \equiv 1 \pmod{n}\) is % a polynomial equation, and $x^2-1$ has the known factorisation % \((x -\nobreak 1) (x +\nobreak 1)\). Since factorisations are % unique, and any zero $a$ of $x^2-1$ would give rise to a factor % $x-a$, it follows that \(x^2 \equiv 1 \pmod{n}\) implies \(x % \equiv 1 \pmod{n}\) or \(x \equiv -1 \pmod{n}\), as claimed. % But this assumes $n$ is a prime. % % If instead \(n = pq\) where \(p,q > 2\) are coprime, then there % will be additional solutions to \(x^2 \equiv 1 \pmod{n}\). % For example, if \(x \equiv 1 \pmod{p}\) and \(x \equiv -1 % \pmod{q}\) (and such $x$ exist by the Chinese Remainder Theorem), % then \(x^2 \equiv 1 \pmod{p}\) and \(x^2 \equiv 1 \pmod{q}\), % from which follows \(x^2 \equiv 1 \pmod{pq}\), but \(x \not\equiv % 1 \pmod{n}\) since \(x-1 \equiv -2 \not\equiv 0 \pmod{q}\), and % \(x \not\equiv -1 \pmod{n}\) since \(x+1 \equiv 2 \not\equiv 0 % \pmod{p}\). The same argument applies when \(x \equiv -1 \pmod{p}\) % and \(x \equiv 1 \pmod{q}\), and in general, if $n$ has $k$ % distinct odd prime factors then one may construct $2^k$ distinct % solutions \(0 proc ::math::numtheory::Miller--Rabin {n s d a} { set x 1 while {$d>1} { if {$d & 1} then {set x [expr {$x*$a % $n}]} set a [expr {$a*$a % $n}] set d [expr {$d >> 1}] } set x [expr {$x*$a % $n}] % \end{tcl} % The second part will $s-1$ times square $x$, while checking each % value for being \(\equiv \pm 1 \pmod{n}\). For most part, $-1$ % means everything is OK (any subsequent square would only % yield~$1$) whereas $1$ arrived at without a previous $-1$ signals % that $n$ cannot be prime. The only exception to the latter is % that $1$ before the first squaring (already \(a^d \equiv 1 % \pmod{n}\)) is OK as well. % \begin{tcl} if {$x == 1} then {return 0} for {} {$s>1} {incr s -1} { if {$x == $n-1} then {return 0} set x [expr {$x*$x % $n}] if {$x == 1} then {return 1} } % \end{tcl} % There is no need to square $x$ the $s$th time, because if at this % point \(x \not\equiv -1 \pmod{n}\) then $n$ cannot be a prime; if % \(x^2 \not\equiv 1 \pmod{n}\) it would fail to be a pseudoprime % and if \(x^2 \equiv 1 \pmod{n}\) then $x$ would be a nonstandard % square root of $1 \pmod{n}$, but it is not necessary to find out % which of these cases is at hand. % \begin{tcl} return [expr {$x != $n-1}] } % % \end{tcl} % % As for testing, the minimal allowed value of $n$ is $3$, which % is a prime. % \begin{tcl} %<*test> test Miller--Rabin-1.1 "Miller--Rabin 3" -body { list [::math::numtheory::Miller--Rabin 3 1 1 1]\ [::math::numtheory::Miller--Rabin 3 1 1 2] } -result {0 0} % \end{tcl} % To exercise the first part of the procedure, one may consider the % case \(s=1\) and \(d = 2^2+2^0 = 5\), i.e., \(n=11\). Here, \(2^5 % \equiv -1 \pmod{11}\) whereas \(4^5 \equiv 1^5 \equiv 1 % \pmod{11}\). A bug on the lines of not using the right factors in % the computation of $a^d$ would most likely end up with something % different here. % \begin{tcl} test Miller--Rabin-1.2 "Miller--Rabin 11" -body { list [::math::numtheory::Miller--Rabin 11 1 5 1]\ [::math::numtheory::Miller--Rabin 11 1 5 2]\ [::math::numtheory::Miller--Rabin 11 1 5 4] } -result {0 0 0} % \end{tcl} % $27$ will on the other hand be exposed as composite by most bases, % but $1$ and $-1$ do not spot it. It is known from the argument % about prime powers above that at least one of $2$ and \(8 = (3 % +\nobreak 1) \cdot 2\) is a primitive root of $1$ in % $\mathbb{Z}_{27}$; it turns out to be $2$. % \begin{tcl} test Miller--Rabin-1.3 "Miller--Rabin 27" -body { list [::math::numtheory::Miller--Rabin 27 1 13 1]\ [::math::numtheory::Miller--Rabin 27 1 13 2]\ [::math::numtheory::Miller--Rabin 27 1 13 3]\ [::math::numtheory::Miller--Rabin 27 1 13 4]\ [::math::numtheory::Miller--Rabin 27 1 13 8]\ [::math::numtheory::Miller--Rabin 27 1 13 26] } -result {0 1 1 1 1 0} % \end{tcl} % Taking \(n = 65 = 1 + 2^6 = 5 \cdot 13\) instead focuses on the % second part of the procedure. By carefully choosing the base, it % is possible to force the result to come from: % \begin{tcl} test Miller--Rabin-1.4 "Miller--Rabin 65" -body { % \end{tcl} % The first |return| % \begin{tcl} list [::math::numtheory::Miller--Rabin 65 6 1 1]\ % \end{tcl} % the second |return|, first iteration % \begin{tcl} [::math::numtheory::Miller--Rabin 65 6 1 64]\ % \end{tcl} % the third |return|, first iteration---\(14 \equiv 1 \pmod{13}\) % but \(14 \equiv -1 \pmod{5}\) % \begin{tcl} [::math::numtheory::Miller--Rabin 65 6 1 14]\ % \end{tcl} % the second |return|, second iteration % \begin{tcl} [::math::numtheory::Miller--Rabin 65 6 1 8]\ % \end{tcl} % the third |return|, second iteration---\(27 \equiv 1 \pmod{13}\) % but \(27^2 \equiv 2^2 \equiv -1 \pmod{5}\) % \begin{tcl} [::math::numtheory::Miller--Rabin 65 6 1 27]\ % \end{tcl} % the final |return| % \begin{tcl} [::math::numtheory::Miller--Rabin 65 6 1 2] } -result {0 0 1 0 1 1} % \end{tcl} % There does however not seem to be any \(n=65\) choice of $a$ which % would get a |0| out of the final |return|. % % An $n$ which allows fully exercising the second part of the % procedure is \(17 \cdot 257 = 4369\), for which \(s=4\) % and \(d=273\). In order to have \(x^{2^{s-1}} \equiv -1 % \pmod{n}\), it is necessary to have \(x^8 \equiv -1\) modulo both % $17$ and $257$, which is possible since the invertible elements % of $\mathbb{Z}_{17}$ form a cyclic group of order $16$ and the % invertible elements of $\mathbb{Z}_{257}$ form a cyclic group of % order $256$. Modulo $17$, an element of order $16$ is $3$, % whereas modulo $257$, an element of order $16$ is $2$. % % There is an extra complication in that what the caller can % specify is not the $x$ to be repeatedly squared, but the $a$ % which satisfies \(x \equiv a^d \pmod{n}\). Since \(d=273\) is % odd, raising something to that power is an invertible operation % modulo both $17$ and $257$, but it is necessary to figure out % what the inverse is. Since \(273 \equiv 1 \pmod{16}\), it turns % out that \(a^d \equiv a \pmod{17}\), and \(x=3\) becomes \(a=3\). % From \(273 \equiv 17 \pmod{256}\), it instead follows that \(x % \equiv a^d \pmod{257}\) is equivalent to \(a \equiv x^e % \pmod{257}\), where \(17e \equiv 1 \pmod{256}\). This has the % solution \(e = 241\), so the $a$ which makes \(x=2\) is \(a % = 2^{241} \bmod 257\). However, since \(x=2\) was picked on % account of having order $16$, hence \(2^{16} \equiv 1 % \pmod{257}\), and \(241 \equiv 1 \pmod{16}\), it again turns out % that \(x=2\) becomes \(a=2\). % % For \(a = 2\), one may observe that \(a^{2^1} \equiv 4 % \pmod{257}\), \(a^{2^2} \equiv 16 \pmod{257}\), \(a^{2^3} \equiv % -1 \pmod{257}\), and \(a^{2^4} \equiv 1 \pmod{257}\). For % \(a=3\), one may observe that \(a^{2^1} \equiv 9 \pmod{17}\), % \(a^{2^2} \equiv 13 \pmod{17}\), \(a^{2^3} \equiv -1 \pmod{17}\), % and \(a^{2^4} \equiv 1 \pmod{17}\). For solving simultaneous % equivalences, it is furthermore useful to observe that \(2057 % \equiv 1 \pmod{257}\) and \(2057 \equiv 0 \pmod{17}\) whereas % \(2313 \equiv 1 \pmod{17}\) and \(2313 \equiv 0 \pmod{257}\). % \begin{tcl} test Miller--Rabin-1.5 "Miller--Rabin 17*257" -body { % \end{tcl} % In order to end up at the first |return|, it is necessary to take % \(a \equiv 1 \pmod{17}\) and \(a \equiv 1 \pmod{257}\); the % solution \(a=1\) is pretty obvious. % \begin{tcl} list [::math::numtheory::Miller--Rabin 4369 4 273 1]\ % \end{tcl} % In order to end up at the second |return| of the first iteration, % it is necessary to take \(a \equiv -1 \pmod{17}\) and % \(a \equiv -1 \pmod{257}\); the solution \(a \equiv -1 \pmod{n}\) % is again pretty obvious. % \begin{tcl} [::math::numtheory::Miller--Rabin 4369 4 273 4368]\ % \end{tcl} % Hitting the third |return| at the first iteration can be achieved % with \(a \equiv -1 \pmod{17}\) and \(a \equiv 1 \pmod{257}\); % now a solution is \(a \equiv 2057 - 2313 \equiv 4113 \pmod{n}\). % \begin{tcl} [::math::numtheory::Miller--Rabin 4369 4 273 4113]\ % \end{tcl} % Hitting the second |return| at the second iteration happens if % \(a^2 \equiv -1\) modulo both prime factors, i.e., for \(a \equiv % 16 \pmod{257}\) and \(a \equiv 13 \pmod{17}\). This has the % solution \(a \equiv 16 \cdot 2057 + 13 \cdot 2313 \equiv 1815 % \pmod{n}\). % \begin{tcl} [::math::numtheory::Miller--Rabin 4369 4 273 1815]\ % \end{tcl} % To hit the third |return| at the second iteration, one may keep % \(a \equiv 16 \pmod{257}\) but take \(a \equiv 1 \pmod{17}\). This % has the solution \(a \equiv 16 \cdot 2057 + 1 \cdot 2313 \equiv 273 % \pmod{n}\). % \begin{tcl} [::math::numtheory::Miller--Rabin 4369 4 273 273]\ % \end{tcl} % Hitting the second |return| at the third and final iteration happens % if \(a^4 \equiv -1\) modulo both prime factors, i.e., for \(a \equiv % 4 \pmod{257}\) and \(a \equiv 9 \pmod{17}\). This has the % solution \(a \equiv 4 \cdot 2057 + 9 \cdot 2313 \equiv 2831 % \pmod{n}\). % \begin{tcl} [::math::numtheory::Miller--Rabin 4369 4 273 2831]\ % \end{tcl} % And as before, to hit the third |return| at the third and final % iteration one may keep the above \(a \equiv 9 \pmod{17}\) but % change the other to \(a \equiv 1 \pmod{257}\). This has the % solution \(a \equiv 1 \cdot 2057 + 9 \cdot 2313 \equiv 1029 % \pmod{n}\). % \begin{tcl} [::math::numtheory::Miller--Rabin 4369 4 273 1029]\ % \end{tcl} % To get a |0| out of the fourth |return|, one takes \(a \equiv % 2 \pmod{257}\) and \(a \equiv 3 \pmod{17}\); this means \(a \equiv % 2 \cdot 2057 + 3 \cdot 2313 \equiv 2315 \pmod{n}\). % \begin{tcl} [::math::numtheory::Miller--Rabin 4369 4 273 2315]\ % \end{tcl} % Finally, to get a |1| out of the fourth |return|, one may take % \(a \equiv 1 \pmod{257}\) and \(a \equiv 3 \pmod{17}\); this means % \(a \equiv 1 \cdot 2057 + 3 \cdot 2313 \equiv 258 \pmod{n}\). % \begin{tcl} [::math::numtheory::Miller--Rabin 4369 4 273 258] } -result {0 0 1 0 1 0 1 0 1} % \end{tcl} % It would have been desirable from a testing point of view to also % find a value of $a$ that would make \(a^{n-1} \equiv -1 % \pmod{n}\), since such an $a$ would catch an implementation error % of running the squaring loop one step too far, but that does not % seem possible; picking \(n=pq\) such that both $p-1$ and $q-1$ % are divisible by some power of $2$ implies that $n-1$ is % divisible by the same power of $2$. % \end{proc} % % A different kind of test is to verify some exceptional numbers and % boundaries that the |isprime| procedure relies on. First, $1373653$ % appears prime when \(a=2\) or \(a=3\), but \(a=5\) is a witness to % its compositeness. % \begin{tcl} test Miller--Rabin-2.1 "Miller--Rabin 1373653" -body { list\ [::math::numtheory::Miller--Rabin 1373653 2 343413 2]\ [::math::numtheory::Miller--Rabin 1373653 2 343413 3]\ [::math::numtheory::Miller--Rabin 1373653 2 343413 5] } -result {0 0 1} % \end{tcl} % $25326001$ is looking like a prime also to \(a=5\), but \(a=7\) % exposes it. % \begin{tcl} test Miller--Rabin-2.2 "Miller--Rabin 25326001" -body { list\ [::math::numtheory::Miller--Rabin 25326001 4 1582875 2]\ [::math::numtheory::Miller--Rabin 25326001 4 1582875 3]\ [::math::numtheory::Miller--Rabin 25326001 4 1582875 5]\ [::math::numtheory::Miller--Rabin 25326001 4 1582875 7] } -result {0 0 0 1} % \end{tcl} % $3215031751$ is a tricky composite that isn't exposed even by % \(a=7\), but \(a=11\) will see through it. % \begin{tcl} test Miller--Rabin-2.3 "Miller--Rabin 3215031751" -body { list\ [::math::numtheory::Miller--Rabin 3215031751 1 1607515875 2]\ [::math::numtheory::Miller--Rabin 3215031751 1 1607515875 3]\ [::math::numtheory::Miller--Rabin 3215031751 1 1607515875 5]\ [::math::numtheory::Miller--Rabin 3215031751 1 1607515875 7]\ [::math::numtheory::Miller--Rabin 3215031751 1 1607515875 11] } -result {0 0 0 0 1} % \end{tcl} % Otherwise the lowest composite that these four will fail for is % $118670087467$. % \begin{tcl} test Miller--Rabin-2.4 "Miller--Rabin 118670087467" -body { list\ [::math::numtheory::Miller--Rabin 118670087467 1 59335043733 2]\ [::math::numtheory::Miller--Rabin 118670087467 1 59335043733 3]\ [::math::numtheory::Miller--Rabin 118670087467 1 59335043733 5]\ [::math::numtheory::Miller--Rabin 118670087467 1 59335043733 7]\ [::math::numtheory::Miller--Rabin 118670087467 1 59335043733 11] } -result {0 0 0 0 1} % % \end{tcl} % % % \subsection{Putting it all together} % % \begin{proc}{isprime} % The user level command for testing primality of an integer $n$ is % |isprime|. It has the call syntax % \begin{quote} % |math::numtheory::isprime| \word{n} % \begin{regblock}[\regstar]\word{option} % \word{value}\end{regblock} % \end{quote} % where the options may be used to influence the exact algorithm % being used. The call returns % \begin{description} % \item[0] if $n$ is found to be composite, % \item[1] if $n$ is found to be prime, and % \item[on] if $n$ is probably prime. % \end{description} % The reason there might be \emph{some} uncertainty is that the % primality test used is basically a probabilistic test for % compositeness---it may fail to find a witness for the % compositeness of a composite number $n$, even if the probability % of doing so is fairly low---and to be honest with the user, the % outcomes of ``definitely prime'' and ``probably prime'' return % different results. Since |on| is true when used as a boolean, you % usually need not worry about this fine detail. Also, for \(n < % 10^{11}\) (actually a little more) the primality test is % deterministic, so you only encounter the ``probably prime'' % result for fairly high $n$. % % At present, the only option that is implemented is |-randommr|, % which controls how many rounds (by default 4) of the |Miller--Rabin| % test with random bases are run before returing |on|. Other options % are silently ignored. % % \begin{tcl} %<*pkg> proc ::math::numtheory::isprime {n args} { prime_trialdivision $n % \end{tcl} % Implementation-wise, |isprime| begins with |prime_trialdivision|, % but relies on the Miller--Rabin test after that. To that end, it % must compute $s$ and $d$ such that \(n = d 2^s + 1\); while this % is fairly quick, it's nice not having to do it more than once, % which is why this step wasn't made part of the |Miller--Rabin| % procedure. % \begin{tcl} set d [expr {$n-1}]; set s 0 while {($d&1) == 0} { incr s set d [expr {$d>>1}] } % \end{tcl} % The deterministic sequence of Miller--Rabin tests combines % information from \cite{PSW80,Jaeschke}, but most of these % numbers may also be found on Wikipedia~\cite{Wikipedia}. % \begin{tcl} if {[Miller--Rabin $n $s $d 2]} then {return 0} if {$n < 2047} then {return 1} if {[Miller--Rabin $n $s $d 3]} then {return 0} if {$n < 1373653} then {return 1} if {[Miller--Rabin $n $s $d 5]} then {return 0} if {$n < 25326001} then {return 1} if {[Miller--Rabin $n $s $d 7] || $n==3215031751} then {return 0} if {$n < 118670087467} then {return 1} % \end{tcl} % \(3215031751 = 151 \cdot 751 \cdot 28351\) is a Carmichael % number~\cite[p.\,1022]{PSW80}. % % Having exhausted this list of limits below which |Miller--Rabin| % for \(a=2,3,5,7\) detects all composite numbers, we now have to % resort to picking bases at random and hoping we find one which % would reveal a composite $n$. In the future, one might want to % add the possibility of using a deterministic test (such as the % AKR~\cite{CL84} or AKS~\cite{AKS04} test) here instead. % % \begin{tcl} array set O {-randommr 4} array set O $args for {set i $O(-randommr)} {$i >= 1} {incr i -1} { if {[Miller--Rabin $n $s $d [expr {( % \end{tcl} % % The probabilistic sequence of Miller--Rabin tests employs % \Tcl's built-in pseudorandom number generator |rand()| for % choosing bases, as this does not seem to be an application that % requires high quality randomness. It may however be observed % that since by now \(n > 10^{11}\), the space of possible bases $a$ % is always several times larger than the state space of |rand()|, % so there may be a point in tweaking the PRNG to avoid some less % useful values of $a$. % % It is a trivial observation that the intermediate $x$ values % computed by |Miller--Rabin| for \(a=a_1a_2\) are simply the % products of the corresponding values computed for \(a=a_1\) and % \(a=a_2\) respectively---hence chances are that if no % compositeness was detected for \(a=a_1\) or \(a=a_2\) then it % won't be detected for \(a=a_1a_2\) either. There is a slight % chance that something interesting could happen if \(a_1^{d2^k} % \equiv -1 \equiv a_2^{d2^k} \pmod{n}\) for some \(k>0\), since in % that case \((a_1a_2)^{d2^k} \equiv 1 \pmod{n}\) whereas no direct % conclusion can be reached about $(a_1a_2)^{d2^{k-1}}$, but this % seems a rather special case (and cannot even occur if \(n % \equiv 3 \pmod{4}\) since in that case \(s=1\)), so it seems % natural to prefer $a$ that are primes. Generating only prime $a$ % would be much work, but avoiding numbers divisible by $2$ or $3$ % is feasible. % % First turn |rand()| back into the integer it internally is, and % adjust it to be from $0$ and up. % \begin{tcl} (round(rand()*0x100000000)-1) % \end{tcl} % Then multiply by $3$ and set the last bit. This has the effect % that the range of the PRNG is now $\{1,3,7,9,13,15,\dotsb, % 6n +\nobreak 1, 6n +\nobreak 3, \dotsb \}$. % \begin{tcl} *3 | 1) % \end{tcl} % Finally add $10$ so that we get $11$, $13$, $17$, $19$, \dots % \begin{tcl} + 10 }]]} then {return 0} } % \end{tcl} % That ends the |for| loop for |Miller--Rabin| with random bases. % At this point, since the number in question passed the requested % number of Miller--Rabin rounds, it is proclaimed to be ``probably % prime''. % \begin{tcl} return on } % % \end{tcl} % % Tests of |isprime| would mostly be asking ``is $n$ a prime'' for % various interesting $n$. Several values of $n$ should be the same % as the previous tests: % \begin{tcl} %<*test> test isprime-1.1 "1 is not prime" -body { ::math::numtheory::isprime 1 } -result 0 test isprime-1.2 "0 is not prime" -body { ::math::numtheory::isprime 0 } -result 0 test isprime-1.3 "-2 is not prime" -body { ::math::numtheory::isprime -2 } -result 0 test isprime-1.4 "2 is prime" -body { ::math::numtheory::isprime 2 } -result 1 test isprime-1.5 "6 is not prime" -body { ::math::numtheory::isprime 6 } -result 0 test isprime-1.6 "7 is prime" -body { ::math::numtheory::isprime 7 } -result 1 test isprime-1.7 "101 is prime" -body { ::math::numtheory::isprime 101 } -result 1 test isprime-1.8 "105 is not prime" -body { ::math::numtheory::isprime 105 } -result 0 test isprime-1.9 "121 is not prime" -body { ::math::numtheory::isprime 121 } -result 0 test isprime-1.10 "127 is prime" -body { ::math::numtheory::isprime 127 } -result 1 test isprime-1.11 "4369 is not prime" -body { ::math::numtheory::isprime 4369 } -result 0 test isprime-1.12 "1373653 is not prime" -body { ::math::numtheory::isprime 1373653 } -result 0 test isprime-1.13 "25326001 is not prime" -body { ::math::numtheory::isprime 25326001 } -result 0 test isprime-1.14 "3215031751 is not prime" -body { ::math::numtheory::isprime 3215031751 } -result 0 % \end{tcl} % To get consistent results for large non-primes, it is necessary % to reduce the number of random rounds and\slash or reset the PRNG. % \begin{tcl} test isprime-1.15 "118670087467 may appear prime, but isn't" -body { expr srand(1) list\ [::math::numtheory::isprime 118670087467 -randommr 0]\ [::math::numtheory::isprime 118670087467 -randommr 1] } -result {on 0} % \end{tcl} % However, a few new can be added. On~\cite[p.\,925]{Jaeschke} we % can read that \(p=22 \mkern1mu 754 \mkern1mu 930 \mkern1mu 352 % \mkern1mu 733\) is a prime, and $p (3p -\nobreak 2)\) is a % composite number that looks prime to |Miller--Rabin| for all % \(a \in \{2,3,5,7,11,13,17,19,23,29\}\). % \begin{tcl} test isprime-1.16 "Jaeschke psi_10" -body { expr srand(1) set p 22754930352733 set n [expr {$p * (3*$p-2)}] list\ [::math::numtheory::isprime $p -randommr 25]\ [::math::numtheory::isprime $n -randommr 0]\ [::math::numtheory::isprime $n -randommr 1] } -result {on on 0} % \end{tcl} % On the same page it is stated that \(p=137 \mkern1mu 716 \mkern1mu % 125 \mkern1mu 329 \mkern1mu 053\) is a prime such that % $p (3p -\nobreak 2)\) is a composite number that looks prime to % |Miller--Rabin| for all \(a \in % \{2,3,5,7,11,13,17,19,23,29,31\}\). % \begin{tcl} test isprime-1.17 "Jaeschke psi_11" -body { expr srand(1) set p 137716125329053 set n [expr {$p * (3*$p-2)}] list\ [::math::numtheory::isprime $p -randommr 25]\ [::math::numtheory::isprime $n -randommr 0]\ [::math::numtheory::isprime $n -randommr 1]\ [::math::numtheory::isprime $n -randommr 2] } -result {on on on 0} % \end{tcl} % RFC~2409~\cite{RFC2409} lists a number of primes (and primitive % generators of their respective multiplicative groups). The % smallest of these is defined as \(p = 2^{768} - 2^{704} - 1 + % 2^{64} \cdot \left( [2^{638} \pi] + 149686 \right)\) (where the % brackets probably denote rounding to the nearest integer), but % since high precision (roughly $200$ decimal digits would be % required) values of \(\pi = 3.14159\dots\) are a bit awkward to % get hold of, we might as well use the stated hexadecimal digit % expansion for~$p$. It might also be a good idea to verify that % this is given with most significant digit first. % \begin{tcl} test isprime-1.18 "OAKLEY group 1 prime" -body { set digits [join { FFFFFFFF FFFFFFFF C90FDAA2 2168C234 C4C6628B 80DC1CD1 29024E08 8A67CC74 020BBEA6 3B139B22 514A0879 8E3404DD EF9519B3 CD3A431B 302B0A6D F25F1437 4FE1356D 6D51C245 E485B576 625E7EC6 F44C42E9 A63A3620 FFFFFFFF FFFFFFFF } ""] expr srand(1) list\ [::math::numtheory::isprime 0x$digits]\ [::math::numtheory::isprime 0x[string reverse $digits]] } -result {on 0} % \end{tcl} % % A quite different thing to test is that the tweaked PRNG really % produces only \(a \equiv 1,5 \pmod{6}\). % \begin{tcl} test isprime-2.0 "PRNG tweak" -setup { namespace eval ::math::numtheory { rename Miller--Rabin _orig_Miller--Rabin proc Miller--Rabin {n s d a} { expr {$a>7 && $a%6!=1 && $a%6!=5} } } } -body { ::math::numtheory::isprime 118670087467 -randommr 500 } -result on -cleanup { namespace eval ::math::numtheory { rename Miller--Rabin "" rename _orig_Miller--Rabin Miller--Rabin } } % % \end{tcl} % \end{proc} % % % \section*{Closings} % % \begin{tcl} %<*man> [list_end] [keywords {number theory} prime] [manpage_end] % % \end{tcl} % % \begin{tcl} %testsuiteCleanup % \end{tcl} % % % \begin{thebibliography}{9} % % \bibitem{AKS04} % Manindra Agrawal, Neeraj Kayal, and Nitin Saxena: % PRIMES is in P, % \textit{Annals of Mathematics} \textbf{160} (2004), no. 2, % 781--793. % % \bibitem{CL84} % Henri Cohen and Hendrik W. Lenstra, Jr.: % Primality testing and Jacobi sums, % \textit{Mathematics of Computation} \textbf{42} (165) (1984), % 297--330. % \texttt{doi:10.2307/2007581} % % \bibitem{RFC2409} % Dan Harkins and Dave Carrel. % \textit{The Internet Key Exchange (IKE)}, % \textbf{RFC 2409} (1998). % % \bibitem{Jaeschke} % Gerhard Jaeschke: On strong pseudoprimes to several bases, % \textit{Mathematics of Computation} \textbf{61} (204), 1993, % 915--926. % \texttt{doi:\,10.2307/2153262} % % \bibitem{Miller} % Gary L. Miller: % Riemann's Hypothesis and Tests for Primality, % \textit{Journal of Computer and System Sciences} \textbf{13} (3) % (1976), 300--317. \texttt{doi:10.1145/800116.803773} % % \bibitem{PSW80} % C.~Pomerance, J.~L.~Selfridge, and S.~S.~Wagstaff~Jr.: % The pseudoprimes to $25 \cdot 10^9$, % \textit{Mathematics of Computation} \textbf{35} (151), 1980, % 1003--1026. % \texttt{doi: 10.2307/2006210} % % \bibitem{Rabin} % Michael O. Rabin: % Probabilistic algorithm for testing primality, % \textit{Journal of Number Theory} \textbf{12} (1) (1980), % 128--138. \texttt{doi:10.1016/0022-314X(80)90084-0} % % \bibitem{Wikipedia} % Wikipedia contributors: % Miller--Rabin primality test, % \textit{Wikipedia, The Free Encyclopedia}, 2010. % Online, accessed 10 September 2010, % \url{http://en.wikipedia.org/w/index.php?title=Miller%E2%80%93Rabin_primality_test&oldid=383901104} % % \end{thebibliography} % \endinput tcllib-1.15/modules/math/combinatorics.tcl0000644000175000017500000002517712077663116020215 0ustar sergeisergei#---------------------------------------------------------------------- # # math/combinatorics.tcl -- # # This file contains definitions of mathematical functions # useful in combinatorial problems. # # Copyright (c) 2001, by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: combinatorics.tcl,v 1.5 2004/02/09 19:31:54 hobbs Exp $ # #---------------------------------------------------------------------- package require Tcl 8.0 namespace eval ::math { # Commonly used combinatorial functions # ln_Gamma is spelt thus because it's a capital gamma (\u0393) namespace export ln_Gamma; # Logarithm of the Gamma function namespace export factorial; # Factorial namespace export choose; # Binomial coefficient # Note that Beta is spelt thus because it's conventionally a # capital beta (\u0392). It is exported from the package even # though its name is capitalized. namespace export Beta; # Beta function } #---------------------------------------------------------------------- # # ::math::InitializeFactorial -- # # Initialize a table of factorials for small integer arguments. # # Parameters: # None. # # Results: # None. # # Side effects: # The variable, ::math::factorialList, is initialized to hold # a table of factorial n for 0 <= n <= 170. # # This procedure is called once when the 'factorial' procedure is # being loaded. # #---------------------------------------------------------------------- proc ::math::InitializeFactorial {} { variable factorialList set factorialList [list 1] set f 1 for { set i 1 } { $i < 171 } { incr i } { if { $i > 12. } { set f [expr { $f * double($i)}] } else { set f [expr { $f * $i }] } lappend factorialList $f } } #---------------------------------------------------------------------- # # ::math::InitializePascal -- # # Precompute the first few rows of Pascal's triangle and store # them in the variable ::math::pascal # # Parameters: # None. # # Results: # None. # # Side effects: # ::math::pascal is initialized to a flat list containing # the first 34 rows of Pascal's triangle. C(n,k) is to be found # at [lindex $pascal $i] where i = n * ( n + 1 ) + k. No attempt # is made to exploit symmetry. # #---------------------------------------------------------------------- proc ::math::InitializePascal {} { variable pascal set pascal [list 1] for { set n 1 } { $n < 34 } { incr n } { lappend pascal 1 set l2 [list 1] for { set k 1 } { $k < $n } { incr k } { set km1 [expr { $k - 1 }] set c [expr { [lindex $l $km1] + [lindex $l $k] }] lappend pascal $c lappend l2 $c } lappend pascal 1 lappend l2 1 set l $l2 } } #---------------------------------------------------------------------- # # ::math::ln_Gamma -- # # Returns ln(Gamma(x)), where x >= 0 # # Parameters: # x - Argument to the Gamma function. # # Results: # Returns the natural logarithm of Gamma(x). # # Side effects: # None. # # Gamma(x) is defined as: # # +inf # _ # | x-1 -t # Gamma(x)= _| t e dt # # 0 # # The approximation used here is from Lanczos, SIAM J. Numerical Analysis, # series B, volume 1, p. 86. For x > 1, the absolute error of the # result is claimed to be smaller than 5.5 * 10**-10 -- that is, the # resulting value of Gamma when exp( ln_Gamma( x ) ) is computed is # expected to be precise to better than nine significant figures. # #---------------------------------------------------------------------- proc ::math::ln_Gamma { x } { # Handle the common case of a real argument that's within the # permissible range. if { [string is double -strict $x] && ( $x > 0 ) && ( $x <= 2.5563481638716906e+305 ) } { set x [expr { $x - 1.0 }] set tmp [expr { $x + 5.5 }] set tmp [ expr { ( $x + 0.5 ) * log( $tmp ) - $tmp }] set ser 1.0 foreach cof { 76.18009173 -86.50532033 24.01409822 -1.231739516 .00120858003 -5.36382e-6 } { set x [expr { $x + 1.0 }] set ser [expr { $ser + $cof / $x }] } return [expr { $tmp + log( 2.50662827465 * $ser ) }] } # Handle the error cases. if { ![string is double -strict $x] } { return -code error [expectDouble $x] } if { $x <= 0.0 } { set proc [lindex [info level 0] 0] return -code error \ -errorcode [list ARITH DOMAIN \ "argument to $proc must be positive"] \ "argument to $proc must be positive" } return -code error \ -errorcode [list ARITH OVERFLOW \ "floating-point value too large to represent"] \ "floating-point value too large to represent" } #---------------------------------------------------------------------- # # math::factorial -- # # Returns the factorial of the argument x. # # Parameters: # x -- Number whose factorial is to be computed. # # Results: # Returns x!, the factorial of x. # # Side effects: # None. # # For integer x, 0 <= x <= 12, an exact integer result is returned. # # For integer x, 13 <= x <= 21, an exact floating-point result is returned # on machines with IEEE floating point. # # For integer x, 22 <= x <= 170, the result is exact to 1 ULP. # # For real x, x >= 0, the result is approximated by computing # Gamma(x+1) using the ::math::ln_Gamma function, and the result is # expected to be precise to better than nine significant figures. # # It is an error to present x <= -1 or x > 170, or a value of x that # is not numeric. # #---------------------------------------------------------------------- proc ::math::factorial { x } { variable factorialList # Common case: factorial of a small integer if { [string is integer -strict $x] && $x >= 0 && $x < [llength $factorialList] } { return [lindex $factorialList $x] } # Error case: not a number if { ![string is double -strict $x] } { return -code error [expectDouble $x] } # Error case: gamma in the left half plane if { $x <= -1.0 } { set proc [lindex [info level 0] 0] set message "argument to $proc must be greater than -1.0" return -code error -errorcode [list ARITH DOMAIN $message] $message } # Error case - gamma fails if { [catch { expr {exp( [ln_Gamma [expr { $x + 1 }]] )} } result] } { return -code error -errorcode $::errorCode $result } # Success - computed factorial n as Gamma(n+1) return $result } #---------------------------------------------------------------------- # # ::math::choose -- # # Returns the binomial coefficient C(n,k) = n!/k!(n-k)! # # Parameters: # n -- Number of objects in the sampling pool # k -- Number of objects to be chosen. # # Results: # Returns C(n,k). # # Side effects: # None. # # Results are expected to be accurate to ten significant figures. # If both parameters are integers and the result fits in 32 bits, # the result is rounded to an integer. # # Integer results are exact up to at least n = 34. # Floating point results are precise to better than nine significant # figures. # #---------------------------------------------------------------------- proc ::math::choose { n k } { variable pascal # Use a precomputed table for small integer args if { [string is integer -strict $n] && $n >= 0 && $n < 34 && [string is integer -strict $k] && $k >= 0 && $k <= $n } { set i [expr { ( ( $n * ($n + 1) ) / 2 ) + $k }] return [lindex $pascal $i] } # Test bogus arguments if { ![string is double -strict $n] } { return -code error [expectDouble $n] } if { ![string is double -strict $k] } { return -code error [expectDouble $k] } # Forbid negative n if { $n < 0. } { set proc [lindex [info level 0] 0] set msg "first argument to $proc must be non-negative" return -code error -errorcode [list ARITH DOMAIN $msg] $msg } # Handle k out of range if { [string is integer -strict $k] && [string is integer -strict $n] && ( $k < 0 || $k > $n ) } { return 0 } if { $k < 0. } { set proc [lindex [info level 0] 0] set msg "second argument to $proc must be non-negative,\ or both must be integers" return -code error -errorcode [list ARITH DOMAIN $msg] $msg } # Compute the logarithm of the desired binomial coefficient. if { [catch { expr { [ln_Gamma [expr { $n + 1 }]] - [ln_Gamma [expr { $k + 1 }]] - [ln_Gamma [expr { $n - $k + 1 }]] } } r] } { return -code error -errorcode $::errorCode $r } # Compute the binomial coefficient itself if { [catch { expr { exp( $r ) } } r] } { return -code error -errorcode $::errorCode $r } # Round to integer if both args are integers and the result fits if { $r <= 2147483647.5 && [string is integer -strict $n] && [string is integer -strict $k] } { return [expr { round( $r ) }] } return $r } #---------------------------------------------------------------------- # # ::math::Beta -- # # Return the value of the Beta function of parameters z and w. # # Parameters: # z, w : Two real parameters to the Beta function # # Results: # Returns the value of the Beta function. # # Side effects: # None. # # Beta( w, z ) is defined as: # # 1_ # | (z-1) (w-1) # Beta( w, z ) = Beta( z, w ) = | t (1-t) dt # _| # 0 # # = Gamma( z ) Gamma( w ) / Gamma( z + w ) # # Results are returned as a floating point number precise to better # than nine significant figures for w, z > 1. # #---------------------------------------------------------------------- proc ::math::Beta { z w } { # Check form of both args so that domain check can be made if { ![string is double -strict $z] } { return -code error [expectDouble $z] } if { ![string is double -strict $w] } { return -code error [expectDouble $w] } # Check sign of both args if { $z <= 0.0 } { set proc [lindex [info level 0] 0] set msg "first argument to $proc must be positive" return -code error -errorcode [list ARITH DOMAIN $msg] $msg } if { $w <= 0.0 } { set proc [lindex [info level 0] 0] set msg "second argument to $proc must be positive" return -code error -errorcode [list ARITH DOMAIN $msg] $msg } # Compute beta using gamma function, keeping stack trace clean. if { [catch { expr { exp( [ln_Gamma $z] + [ln_Gamma $w] - [ln_Gamma [ expr { $z + $w }]] ) } } beta] } { return -code error -errorcode $::errorCode $beta } return $beta } #---------------------------------------------------------------------- # # Initialization of this file: # # Initialize the precomputed tables of factorials and binomial # coefficients. # #---------------------------------------------------------------------- namespace eval ::math { InitializeFactorial InitializePascal } tcllib-1.15/modules/math/symdiff.man0000644000175000017500000000677512077663116017016 0ustar sergeisergei[manpage_begin symdiff n 1.0] [copyright "2010 by Kevin B. Kenny Redistribution permitted under the terms of the Open\ Publication License "] [moddesc "Symbolic differentiation for Tcl"] [require Tcl 8.5] [require grammar::aycock 1.0] [require math::calculus::symdiff 1.0] [description] [para] The [cmd math::calculus::symdiff] package provides a symbolic differentiation facility for Tcl math expressions. It is useful for providing derivatives to packages that either require the Jacobian of a set of functions or else are more efficient or stable when the Jacobian is provided. [section "Procedures"] The [cmd math::calculus::symdiff] package exports the two procedures: [list_begin definitions] [call [cmd math::calculus::symdiff::symdiff] [arg expression] [arg variable]] Differentiates the given [arg expression] with respect to the specified [arg variable]. (See [sectref "Expressions"] below for a discussion of the subset of Tcl math expressions that are acceptable to [cmd math::calculus::symdiff].) The result is a Tcl expression that evaluates the derivative. Returns an error if [arg expression] is not a well-formed expression or is not differentiable. [call [cmd math::calculus::jacobian] [arg variableDict]] Computes the Jacobian of a system of equations. The system is given by the dictionary [arg variableDict], whose keys are the names of variables in the system, and whose values are Tcl expressions giving the values of those variables. (See [sectref "Expressions"] below for a discussion of the subset of Tcl math expressions that are acceptable to [cmd math::calculus::symdiff]. The result is a list of lists: the i'th element of the j'th sublist is the partial derivative of the i'th variable with respect to the j'th variable. Returns an error if any of the expressions cannot be differentiated, or if [arg variableDict] is not a well-formed dictionary. [list_end] [section "Expressions"] The [cmd math::calculus::symdiff] package accepts only a small subset of the expressions that are acceptable to Tcl commands such as [cmd expr] or [cmd if]. Specifically, the only constructs accepted are: [list_begin itemized] [item]Floating-point constants such as [const 5] or [const 3.14159e+00]. [item]References to Tcl variable using $-substitution. The variable names must consist of alphanumerics and underscores: the [const \$\{...\}] notation is not accepted. [item]Parentheses. [item]The [const +], [const -], [const *], [const /]. and [const **] operators. [item]Calls to the functions [cmd acos], [cmd asin], [cmd atan], [cmd atan2], [cmd cos], [cmd cosh], [cmd exp], [cmd hypot], [cmd log], [cmd log10], [cmd pow], [cmd sin], [cmd sinh]. [cmd sqrt], [cmd tan], and [cmd tanh]. [list_end] Command substitution, backslash substitution, and argument expansion are not accepted. [section "Examples"] [example { math::calculus::symdiff::symdiff {($a*$x+$b)*($c*$x+$d)} x ==> (($c * (($a * $x) + $b)) + ($a * (($c * $x) + $d))) math::calculus::symdiff::jacobian {x {$a * $x + $b * $y} y {$c * $x + $d * $y}} ==> {{$a} {$b}} {{$c} {$d}} }] [section {Bugs, Ideas, Feedback}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph {math :: calculus}] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [see_also math::calculus math::interpolate] [manpage_end] tcllib-1.15/modules/math/bigfloat.tcl0000755000175000017500000026725512077663116017160 0ustar sergeisergei######################################################################## # BigFloat for Tcl # Copyright (C) 2003-2005 ARNOLD Stephane # # BIGFLOAT LICENSE TERMS # # This software is copyrighted by Stephane ARNOLD, (stephanearnold yahoo.fr). # 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. # # GOVERNMENT USE: If you are acquiring this software on behalf of the # U.S. government, the Government shall have only "Restricted Rights" # in the software and related documentation as defined in the Federal # Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you # are acquiring the software on behalf of the Department of Defense, the # software shall be classified as "Commercial Computer Software" and the # Government shall have only "Restricted Rights" as defined in Clause # 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the # authors grant the U.S. Government and others acting in its behalf # permission to use and distribute the software in accordance with the # terms specified in this license. # ######################################################################## package require Tcl 8.4 package require math::bignum # this line helps when I want to source this file again and again catch {namespace delete ::math::bigfloat} # private namespace # this software works only with Tcl v8.4 and higher # it is using the package math::bignum namespace eval ::math::bigfloat { # cached constants # ln(2) with arbitrary precision variable Log2 # Pi with arb. precision variable Pi variable _pi0 # some constants (bignums) : {0 1 2 3 4 5 10} variable zero set zero [::math::bignum::fromstr 0] variable one set one [::math::bignum::fromstr 1] variable two set two [::math::bignum::fromstr 2] variable three set three [::math::bignum::fromstr 3] variable four set four [::math::bignum::fromstr 4] variable five set five [::math::bignum::fromstr 5] variable ten set ten [::math::bignum::fromstr 10] } ################################################################################ # procedures that handle floating-point numbers # these procedures are sorted by name (after eventually removing the underscores) # # BigFloats are internally represented as a list : # {"F" Mantissa Exponent Delta} where "F" is a character which determins # the datatype, Mantissa and Delta are two Big integers and Exponent a raw integer. # # The BigFloat value equals to (Mantissa +/- Delta)*2^Exponent # So the internal representation is binary, but trying to get as close as possible to # the decimal one. # When calling fromstr, the Delta parameter is set to the value of the last decimal digit. # Example : 1.50 belongs to [1.49,1.51], but internally Delta is probably not equal to 1, # because of the binary representation. # # So Mantissa and Delta are not limited in size, but in practice Delta is kept under # 2^32 by the 'normalize' procedure, to avoid a never-ended growth of memory used. # Indeed, when you perform some computations, the Delta parameter (which represent # the uncertainty on the value of the Mantissa) may increase. # Exponent, as a classic integer, is limited to the interval [-2147483648,2147483647] # Retrieving the parameters of a BigFloat is often done with that command : # foreach {dummy int exp delta} $bigfloat {break} # (dummy is not used, it is just used to get the "F" marker). # The isInt, isFloat, checkNumber and checkFloat procedures are used # to check data types # # Taylor development are often used to compute the analysis functions (like exp(),log()...) # To learn how it is done in practice, take a look at ::math::bigfloat::_asin # While doing computation on Mantissas, we do not care about the last digit, # because if we compute wisely Deltas, the digits that remain will be exact. ################################################################################ ################################################################################ # returns the absolute value ################################################################################ proc ::math::bigfloat::abs {number} { checkNumber number if {[isInt $number]} { # set sign to positive for a BigInt return [::math::bignum::abs $number] } # set sign to positive for a BigFloat into the Mantissa (index 1) lset number 1 [::math::bignum::abs [lindex $number 1]] return $number } ################################################################################ # arccosinus of a BigFloat ################################################################################ proc ::math::bigfloat::acos {x} { # handy proc for checking datatype checkFloat x foreach {dummy entier exp delta} $x {break} set precision [expr {($exp<0)?(-$exp):1}] # acos(0.0)=Pi/2 # 26/07/2005 : changed precision from decimal to binary # with the second parameter of pi command set piOverTwo [floatRShift [pi $precision 1]] if {[iszero $x]} { # $x is too close to zero -> acos(0)=PI/2 return $piOverTwo } # acos(-x)= Pi/2 + asin(x) if {[::math::bignum::sign $entier]} { return [add $piOverTwo [asin [abs $x]]] } # we always use _asin to compute the result # but as it is a Taylor development, the value given to [_asin] # has to be a bit smaller than 1 ; by using that trick : acos(x)=asin(sqrt(1-x^2)) # we can limit the entry of the Taylor development below 1/sqrt(2) if {[compare $x [fromstr 0.7071]]>0} { # x > sqrt(2)/2 : trying to make _asin converge quickly # creating 0 and 1 with the same precision as the entry variable one variable zero set fzero [list F $zero -$precision $one] set fone [list F [::math::bignum::lshift 1 $precision] \ -$precision $one] # when $x is close to 1 (acos(1.0)=0.0) if {[equal $fone $x]} { return $fzero } if {[compare $fone $x]<0} { # the behavior assumed because acos(x) is not defined # when |x|>1 error "acos on a number greater than 1" } # acos(x) = asin(sqrt(1 - x^2)) # since 1 - cos(x)^2 = sin(x)^2 # x> sqrt(2)/2 so x^2 > 1/2 so 1-x^2<1/2 set x [sqrt [sub $fone [mul $x $x]]] # the parameter named x is smaller than sqrt(2)/2 return [_asin $x] } # acos(x) = Pi/2 - asin(x) # x$expB} { set diff [expr {$expA-$expB}] set integerA [::math::bignum::lshift $integerA $diff] set deltaA [::math::bignum::lshift $deltaA $diff] set integerA [::math::bignum::add $integerA $integerB] set deltaA [::math::bignum::add $deltaA $deltaB] return [normalize [list F $integerA $expB $deltaA]] } elseif {$expA==$expB} { # nothing to shift left return [normalize [list F [::math::bignum::add $integerA $integerB] \ $expA [::math::bignum::add $deltaA $deltaB]]] } else { set diff [expr {$expB-$expA}] set integerB [::math::bignum::lshift $integerB $diff] set deltaB [::math::bignum::lshift $deltaB $diff] set integerB [::math::bignum::add $integerA $integerB] set deltaB [::math::bignum::add $deltaB $deltaA] return [normalize [list F $integerB $expA $deltaB]] } } ################################################################################ # returns the sum A(BigFloat) + B(BigInt) # the greatest advantage of this method is that the uncertainty # of the result remains unchanged, in respect to the entry's uncertainty (deltaA) ################################################################################ proc ::math::bigfloat::addInt2Float {a b} { # type checking checkFloat a if {![isInt $b]} { error "'$b' is not a BigInt" } # retrieving data from $a foreach {dummy integerA expA deltaA} $a {break} # to add an int to a BigFloat,... if {$expA>0} { # we have to put the integer integerA # to the level of zero exponent : 1e8 --> 100000000e0 set shift $expA set integerA [::math::bignum::lshift $integerA $shift] set deltaA [::math::bignum::lshift $deltaA $shift] set integerA [::math::bignum::add $integerA $b] # we have to normalize, because we have shifted the mantissa # and the uncertainty left return [normalize [list F $integerA 0 $deltaA]] } elseif {$expA==0} { # integerA is already at integer level : float=(integerA)e0 return [normalize [list F [::math::bignum::add $integerA $b] \ 0 $deltaA]] } else { # here we have something like 234e-2 + 3 # we have to shift the integer left by the exponent |$expA| set b [::math::bignum::lshift $b [expr {-$expA}]] set integerA [::math::bignum::add $integerA $b] return [normalize [list F $integerA $expA $deltaA]] } } ################################################################################ # arcsinus of a BigFloat ################################################################################ proc ::math::bigfloat::asin {x} { # type checking checkFloat x foreach {dummy entier exp delta} $x {break} if {$exp>-1} { error "not enough precision on input (asin)" } set precision [expr {-$exp}] # when x=0, return 0 at the same precision as the input was if {[iszero $x]} { variable one variable zero return [list F $zero -$precision $one] } # asin(-x)=-asin(x) if {[::math::bignum::sign $entier]} { return [opp [asin [abs $x]]] } # 26/07/2005 : changed precision from decimal to binary set piOverTwo [floatRShift [pi $precision 1]] # now a little trick : asin(x)=Pi/2-asin(sqrt(1-x^2)) # so we can limit the entry of the Taylor development # to 1/sqrt(2)~0.7071 # the comparison is : if x>0.7071 then ... if {[compare $x [fromstr 0.7071]]>0} { variable one set fone [list F [::math::bignum::lshift 1 $precision] \ -$precision $one] # asin(1)=Pi/2 (with the same precision as the entry has) if {[equal $fone $x]} { return $piOverTwo } if {[compare $x $fone]>0} { error "asin on a number greater than 1" } # asin(x)=Pi/2-asin(sqrt(1-x^2)) set x [sqrt [sub $fone [mul $x $x]]] return [sub $piOverTwo [_asin $x]] } return [normalize [_asin $x]] } ################################################################################ # _asin : arcsinus of numbers between 0 and +1 ################################################################################ proc ::math::bigfloat::_asin {x} { # Taylor development # asin(x)=x + 1/2 x^3/3 + 3/2.4 x^5/5 + 3.5/2.4.6 x^7/7 + ... # into this iterative form : # asin(x)=x * (1 + 1/2 * x^2 * (1/3 + 3/4 *x^2 * (... # ...* (1/(2n-1) + (2n-1)/2n * x^2 / (2n+1))...))) # we show how is really computed the development : # we don't need to set a var with x^n or a product of integers # all we need is : x^2, 2n-1, 2n, 2n+1 and a few variables foreach {dummy mantissa exp delta} $x {break} set precision [expr {-$exp}] if {$precision+1<[::math::bignum::bits $mantissa]} { error "sinus greater than 1" } # precision is the number of after-dot digits set result $mantissa set delta_final $delta # resultat is the final result, and delta_final # will contain the uncertainty of the result # square is the square of the mantissa set square [intMulShift $mantissa $mantissa $precision] # dt is the uncertainty of Mantissa set dt [::math::bignum::add 1 [intMulShift $mantissa $delta [expr {$precision-1}]]] # these three are required to compute the fractions implicated into # the development (of Taylor, see former) variable one set num $one # two will be used into the loop variable two variable three set i $three set denom $two # the nth factor equals : $num/$denom* $mantissa/$i set delta [::math::bignum::add [::math::bignum::mul $delta $square] \ [::math::bignum::mul $dt [::math::bignum::add $delta $mantissa]]] set delta [::math::bignum::add 1 [::math::bignum::rshift [::math::bignum::div \ [::math::bignum::mul $delta $num] $denom] $precision]] # we do not multiply the Mantissa by $num right now because it is 1 ! # but we have Mantissa=$x # and we want Mantissa*$x^2 * $num / $denom / $i set mantissa [intMulShift $mantissa $square $precision] set mantissa [::math::bignum::div $mantissa $denom] # do not forget the modified Taylor development : # asin(x)=x * (1 + 1/2*x^2*(1/3 + 3/4*x^2*(...*(1/(2n-1) + (2n-1)/2n*x^2/(2n+1))...))) # all we need is : x^2, 2n-1, 2n, 2n+1 and a few variables # $num=2n-1 $denom=2n $square=x^2 and $i=2n+1 set mantissa_temp [::math::bignum::div $mantissa $i] set delta_temp [::math::bignum::add 1 [::math::bignum::div $delta $i]] # when the Mantissa increment is smaller than the Delta increment, # we would not get much precision by continuing the development while {![::math::bignum::iszero $mantissa_temp]} { # Mantissa = Mantissa * $num/$denom * $square # Add Mantissa/$i, which is stored in $mantissa_temp, to the result set result [::math::bignum::add $result $mantissa_temp] set delta_final [::math::bignum::add $delta_final $delta_temp] # here we have $two instead of [fromstr 2] (optimization) # num=num+2,i=i+2,denom=denom+2 # because num=2n-1 denom=2n and i=2n+1 set num [::math::bignum::add $num $two] set i [::math::bignum::add $i $two] set denom [::math::bignum::add $denom $two] # computes precisly the future Delta parameter set delta [::math::bignum::add [::math::bignum::mul $delta $square] \ [::math::bignum::mul $dt [::math::bignum::add $delta $mantissa]]] set delta [::math::bignum::add 1 [::math::bignum::rshift [::math::bignum::div \ [::math::bignum::mul $delta $num] $denom] $precision]] set mantissa [intMulShift $mantissa $square $precision] set mantissa [::math::bignum::div [::math::bignum::mul $mantissa $num] $denom] set mantissa_temp [::math::bignum::div $mantissa $i] set delta_temp [::math::bignum::add 1 [::math::bignum::div $delta $i]] } return [list F $result $exp $delta_final] } ################################################################################ # arctangent : returns atan(x) ################################################################################ proc ::math::bigfloat::atan {x} { checkFloat x variable one variable two variable three variable four variable zero foreach {dummy mantissa exp delta} $x {break} if {$exp>=0} { error "not enough precision to compute atan" } set precision [expr {-$exp}] # atan(0)=0 if {[iszero $x]} { return [list F $zero -$precision $one] } # atan(-x)=-atan(x) if {[::math::bignum::sign $mantissa]} { return [opp [atan [abs $x]]] } # now x is strictly positive # at this moment, we are trying to limit |x| to a fair acceptable number # to ensure that Taylor development will converge quickly set float1 [list F [::math::bignum::lshift 1 $precision] -$precision $one] if {[compare $float1 $x]<0} { # compare x to 2.4142 if {[compare $x [fromstr 2.4142]]<0} { # atan(x)=Pi/4 + atan((x-1)/(x+1)) # as 10} { # atan(x)=Pi/4 + atan((x-1)/(x+1)) # x>0.420 so (x-1)/(x+1)=1 - 2/(x+1) > 1-2/1.414 # > -0.414 # x<1 so (x-1)/(x+1)<0 set pi_sur_quatre [div [pi $precision 1] $four] return [add $pi_sur_quatre [atan \ [div [sub $x $float1] [add $x $float1]]]] } # precision increment : to have less uncertainty # we add a little more precision so that the result would be more accurate # Taylor development : x - x^3/3 + x^5/5 - ... + (-1)^(n+1)*x^(2n-1)/(2n-1) # when we have n steps in Taylor development : the nth term is : # x^(2n-1)/(2n-1) # and the loss of precision is of 2n (n sums and n divisions) # this command is called with x(precision-3/2)*log(2)-log(2n-1) # hence log(2n-1)<2n-1 # n*sqrt(2)>(precision-1.5)*log(2)+1-2n # n*(sqrt(2)+2)>(precision-1.5)*log(2)+1 set n [expr {int((log(2)*($precision-1.5)+1)/(sqrt(2)+2)+1)}] incr precision $n set mantissa [::math::bignum::lshift $mantissa $n] set delta [::math::bignum::lshift $delta $n] # end of adding precision increment # now computing Taylor development : # atan(x)=x - x^3/3 + x^5/5 - x^7/7 ... + (-1)^n*x^(2n+1)/(2n+1) # atan(x)=x * (1 - x^2 * (1/3 - x^2 * (1/5 - x^2 * (...*(1/(2n-1) - x^2 / (2n+1))...)))) # what do we need to compute this ? # x^2 ($square), 2n+1 ($divider), $result, the nth term of the development ($t) # and the nth term multiplied by 2n+1 ($temp) # then we do this (with care keeping as much precision as possible): # while ($t <>0) : # $result=$result+$t # $temp=$temp * $square # $divider = $divider+2 # $t=$temp/$divider # end-while set result $mantissa set delta_end $delta # we store the square of the integer (mantissa) set delta_square [::math::bignum::lshift $delta 1] set square [intMulShift $mantissa $mantissa $precision] # the (2n+1) divider set divider $three # computing precisely the uncertainty set delta [::math::bignum::add 1 [::math::bignum::rshift [::math::bignum::add \ [::math::bignum::mul $delta_square $mantissa] \ [::math::bignum::mul $delta $square]] $precision]] # temp contains (-1)^n*x^(2n+1) set temp [opp [intMulShift $mantissa $square $precision]] set t [::math::bignum::div $temp $divider] set dt [::math::bignum::add 1 [::math::bignum::div $delta $divider]] while {![::math::bignum::iszero $t]} { set result [::math::bignum::add $result $t] set delta_end [::math::bignum::add $delta_end $dt] set divider [::math::bignum::add $divider $two] set delta [::math::bignum::add 1 [::math::bignum::rshift [::math::bignum::add \ [::math::bignum::mul $delta_square [abs $temp]] [::math::bignum::mul $delta \ [::math::bignum::add $delta_square $square]]] $precision]] set temp [opp [intMulShift $temp $square $precision]] set t [::math::bignum::div $temp $divider] set dt [::math::bignum::add [::math::bignum::div $delta $divider] $one] } # we have to normalize because the uncertainty might be greater than 99 # moreover it is the most often case return [normalize [list F $result [expr {$exp-$n}] $delta_end]] } ################################################################################ # compute atan(1/integer) at a given precision # this proc is only used to compute Pi # it is using the same Taylor development as [atan] ################################################################################ proc ::math::bigfloat::_atanfract {integer precision} { # Taylor development : x - x^3/3 + x^5/5 - ... + (-1)^(n+1)*x^(2n-1)/(2n-1) # when we have n steps in Taylor development : the nth term is : # 1/denom^(2n+1)/(2n+1) # and the loss of precision is of 2n (n sums and n divisions) # this command is called with integer>=5 # # We do not want to compute the Delta parameter, so we just # can increment precision (with lshift) in order for the result to be precise. # Remember : we compute atan2(1,$integer) with $precision bits # $integer has no Delta parameter as it is a BigInt, of course, so # theorically we could compute *any* number of digits. # # if we add an increment to the precision, say n: # (1/5)^(2n-1)/(2n-1) has to be lower than (1/2)^(precision+n-1) # Calculus : # log(left term) < log(right term) # log(1/left term) > log(1/right term) # (2n-1)*log(5)+log(2n-1)>(precision+n-1)*log(2) # n(2log(5)-log(2))>(precision-1)*log(2)-log(2n-1)+log(5) # -log(2n-1)>-(2n-1) # n(2log(5)-log(2)+2)>(precision-1)*log(2)+1+log(5) set n [expr {int((($precision-1)*log(2)+1+log(5))/(2*log(5)-log(2)+2)+1)}] incr precision $n # first term of the development : 1/integer set a [::math::bignum::div [::math::bignum::lshift 1 $precision] $integer] # 's' will contain the result set s $a # Taylor development : x - x^3/3 + x^5/5 - ... + (-1)^(n+1)*x^(2n-1)/(2n-1) # equals x (1 - x^2 * (1/3 + x^2 * (... * (1/(2n-3) + (-1)^(n+1) * x^2 / (2n-1))...))) # all we need to store is : 2n-1 ($denom), x^(2n+1) and x^2 ($square) and two results : # - the nth term => $u # - the nth term * (2n-1) => $t # + of course, the result $s set square [::math::bignum::mul $integer $integer] variable two variable three set denom $three # $t is (-1)^n*x^(2n+1) set t [opp [::math::bignum::div $a $square]] set u [::math::bignum::div $t $denom] # we break the loop when the current term of the development is null while {![::math::bignum::iszero $u]} { set s [::math::bignum::add $s $u] # denominator= (2n+1) set denom [::math::bignum::add $denom $two] # div $t by x^2 set t [opp [::math::bignum::div $t $square]] set u [::math::bignum::div $t $denom] } # go back to the initial precision return [::math::bignum::rshift $s $n] } ################################################################################ # returns the integer part of a BigFloat, as a BigInt # the result is the same one you would have # if you had called [expr {ceil($x)}] ################################################################################ proc ::math::bigfloat::ceil {number} { checkFloat number set number [normalize $number] if {[iszero $number]} { # returns the BigInt 0 variable zero return $zero } foreach {dummy integer exp delta} $number {break} if {$exp>=0} { error "not enough precision to perform rounding (ceil)" } # saving the sign ... set sign [::math::bignum::sign $integer] set integer [abs $integer] # integer part set try [::math::bignum::rshift $integer [expr {-$exp}]] if {$sign} { return [opp $try] } # fractional part if {![equal [::math::bignum::lshift $try [expr {-$exp}]] $integer]} { return [::math::bignum::add 1 $try] } return $try } ################################################################################ # checks each variable to be a BigFloat # arguments : each argument is the name of a variable to be checked ################################################################################ proc ::math::bigfloat::checkFloat {args} { foreach x $args { upvar $x n if {![isFloat $n]} { error "BigFloat expected : received '$n'" } } } ################################################################################ # checks if each number is either a BigFloat or a BigInt # arguments : each argument is the name of a variable to be checked ################################################################################ proc ::math::bigfloat::checkNumber {args} { foreach i $args { upvar $i x if {![isInt $x] && ![isFloat $x]} { error "'$x' is not a number" } } } ################################################################################ # returns 0 if A and B are equal, else returns 1 or -1 # accordingly to the sign of (A - B) ################################################################################ proc ::math::bigfloat::compare {a b} { if {[isInt $a] && [isInt $b]} { return [::math::bignum::cmp $a $b] } checkFloat a b if {[equal $a $b]} {return 0} return [expr {([::math::bignum::sign [lindex [sub $a $b] 1]])?-1:1}] } ################################################################################ # gets cos(x) # throws an error if there is not enough precision on the input ################################################################################ proc ::math::bigfloat::cos {x} { checkFloat x foreach {dummy integer exp delta} $x {break} if {$exp>-2} { error "not enough precision on floating-point number" } set precision [expr {-$exp}] # cos(2kPi+x)=cos(x) foreach {n integer} [divPiQuarter $integer $precision] {break} # now integer>=0 and exp (multiplied by -1) lset l 1 [expr {-([lindex $l 1])}] # set the sign set integer [lindex $l 0] ::math::bignum::setsign integer $signe lset l 0 $integer return [normalize [linsert $l 0 F]] } ################################################################################ # compute cos(x) where 0<=x=0} { # cos(Pi/2-x)=sin(x) set x [::math::bignum::sub $pis2 $x] set delta [::math::bignum::add 1 $delta] return [_sin $x $precision $delta] } return [_cos $x $precision $delta] } ################################################################################ # compute cos(x) where 0<=x0} { # swap BMin and BMax set temp $BMin set BMin $BMax set BMax $temp } # multiply by zero gives zero if {[::math::bignum::iszero $integerA]} { # why not return any number or the integer 0 ? # because there is an exponent that might be different between two BigFloats # 0.00 --> exp = -2, 0.000000 -> exp = -6 return $a } # test of the division by zero if {[::math::bignum::sign $BMin]+[::math::bignum::sign $BMax]==1 || \ [::math::bignum::iszero $BMin] || [::math::bignum::iszero $BMax]} { error "divide by zero" } # shift A because we need accuracy set l [math::bignum::bits $integerB] set integerA [::math::bignum::lshift $integerA $l] set deltaA [::math::bignum::lshift $deltaA $l] set exp [expr {$expA-$l-$expB}] # relative uncertainties (dX/X) are added # to give the relative uncertainty of the result # i.e. 3% on A + 2% on B --> 5% on the quotient # d(A/B)/(A/B)=dA/A + dB/B # Q=A/B # dQ=dA/B + dB*A/B*B # dQ is "delta" set delta [::math::bignum::div [::math::bignum::mul $deltaB \ [abs $integerA]] [abs $integerB]] set delta [::math::bignum::div [::math::bignum::add\ [::math::bignum::add 1 $delta]\ $deltaA] [abs $integerB]] set quotient [::math::bignum::div $integerA $integerB] if {[::math::bignum::sign $integerB]+[::math::bignum::sign $integerA]==1} { set quotient [::math::bignum::sub $quotient 1] } return [normalize [list F $quotient $exp [::math::bignum::add $delta 1]]] } ################################################################################ # divide a BigFloat A by a BigInt B # throw error : divide by zero ################################################################################ proc ::math::bigfloat::divFloatByInt {a b} { variable one # type check checkFloat a if {![isInt $b]} { error "'$b' is not a BigInt" } foreach {dummy integer exp delta} $a {break} # zero divider test if {[::math::bignum::iszero $b]} { error "divide by zero" } # shift left for accuracy ; see other comments in [div] procedure set l [::math::bignum::bits $b] set integer [::math::bignum::lshift $integer $l] set delta [::math::bignum::lshift $delta $l] incr exp -$l set integer [::math::bignum::div $integer $b] # the uncertainty is always evaluated to the ceil value # and as an absolute value set delta [::math::bignum::add 1 [::math::bignum::div $delta [abs $b]]] return [normalize [list F $integer $exp $delta]] } ################################################################################ # returns 1 if A and B are equal, 0 otherwise # IN : a, b (BigFloats) ################################################################################ proc ::math::bigfloat::equal {a b} { if {[isInt $a] && [isInt $b]} { return [expr {[::math::bignum::cmp $a $b]==0}] } # now a & b should only be BigFloats checkFloat a b foreach {dummy aint aexp adelta} $a {break} foreach {dummy bint bexp bdelta} $b {break} # set all Mantissas and Deltas to the same level (exponent) # with lshift set diff [expr {$aexp-$bexp}] if {$diff<0} { set diff [expr {-$diff}] set bint [::math::bignum::lshift $bint $diff] set bdelta [::math::bignum::lshift $bdelta $diff] } elseif {$diff>0} { set aint [::math::bignum::lshift $aint $diff] set adelta [::math::bignum::lshift $adelta $diff] } # compute limits of the number's doubt range set asupInt [::math::bignum::add $aint $adelta] set ainfInt [::math::bignum::sub $aint $adelta] set bsupInt [::math::bignum::add $bint $bdelta] set binfInt [::math::bignum::sub $bint $bdelta] # A & B are equal # if their doubt ranges overlap themselves if {[::math::bignum::cmp $bint $aint]==0} { return 1 } if {[::math::bignum::cmp $bint $aint]>0} { set r [expr {[::math::bignum::cmp $asupInt $binfInt]>=0}] } else { set r [expr {[::math::bignum::cmp $bsupInt $ainfInt]>=0}] } return $r } ################################################################################ # returns exp(X) where X is a BigFloat ################################################################################ proc ::math::bigfloat::exp {x} { checkFloat x foreach {dummy integer exp delta} $x {break} if {$exp>=0} { # shift till exp<0 with respect to the internal representation # of the number incr exp set integer [::math::bignum::lshift $integer $exp] set delta [::math::bignum::lshift $delta $exp] set exp -1 } set precision [expr {-$exp}] # add 8 bits of precision for safety incr precision 8 set integer [::math::bignum::lshift $integer 8] set delta [::math::bignum::lshift $delta 8] set Log2 [_log2 $precision] foreach {new_exp integer} [::math::bignum::divqr $integer $Log2] {break} # new_exp = integer part of x/log(2) # integer = remainder # exp(K.log(2)+r)=2^K.exp(r) # so we just have to compute exp(r), r is small so # the Taylor development will converge quickly set delta [::math::bignum::add $delta $new_exp] foreach {integer delta} [_exp $integer $precision $delta] {break} set delta [::math::bignum::rshift $delta 8] incr precision -8 # multiply by 2^K , and take care of the sign # example : X=-6.log(2)+0.01 # exp(X)=exp(0.01)*2^-6 if {![::math::bignum::iszero [::math::bignum::rshift [abs $new_exp] 30]]} { error "floating-point overflow due to exp" } set new_exp [tostr $new_exp] set exp [expr {$new_exp-$precision}] set delta [::math::bignum::add 1 $delta] return [normalize [list F [::math::bignum::rshift $integer 8] $exp $delta]] } ################################################################################ # private procedure to compute exponentials # using Taylor development of exp(x) : # exp(x)=1+ x + x^2/2 + x^3/3! +...+x^n/n! # input : integer (the mantissa) # precision (the number of decimals) # delta (the doubt limit, or uncertainty) # returns a list : 1. the mantissa of the result # 2. the doubt limit, or uncertainty ################################################################################ proc ::math::bigfloat::_exp {integer precision delta} { set oneShifted [::math::bignum::lshift 1 $precision] if {[::math::bignum::iszero $integer]} { # exp(0)=1 return [list $oneShifted $delta] } set s [::math::bignum::add $oneShifted $integer] variable two set d [::math::bignum::add 1 [::math::bignum::div $delta $two]] set delta [::math::bignum::add $delta $delta] # dt = uncertainty on x^2 set dt [::math::bignum::add 1 [intMulShift $d $integer $precision]] # t= x^2/2 set t [intMulShift $integer $integer $precision] set t [::math::bignum::div $t $two] set denom $two while {![::math::bignum::iszero $t]} { # the sum is called 's' set s [::math::bignum::add $s $t] set delta [::math::bignum::add $delta $dt] # we do not have to keep trace of the factorial, we just iterate divisions set denom [::math::bignum::add 1 $denom] # add delta set d [::math::bignum::add 1 [::math::bignum::div $d $denom]] set dt [::math::bignum::add $dt $d] # get x^n from x^(n-1) set t [intMulShift $integer $t $precision] # here we divide set t [::math::bignum::div $t $denom] } return [list $s $delta] } ################################################################################ # divide a BigFloat by 2 power 'n' ################################################################################ proc ::math::bigfloat::floatRShift {float {n 1}} { return [lset float 2 [expr {[lindex $float 2]-$n}]] } ################################################################################ # procedure floor : identical to [expr floor($x)] in functionality # arguments : number IN (a BigFloat) # returns : the floor value as a BigInt ################################################################################ proc ::math::bigfloat::floor {number} { variable zero checkFloat number set number [normalize $number] if {[::math::bignum::iszero $number]} { # returns the BigInt 0 return $zero } foreach {dummy integer exp delta} $number {break} if {$exp>=0} { error "not enough precision to perform rounding (floor)" } # saving the sign ... set sign [::math::bignum::sign $integer] set integer [abs $integer] # integer part set try [::math::bignum::rshift $integer [expr {-$exp}]] # floor(n.xxxx)=n if {!$sign} { return $try } # floor(-n.xxxx)=-(n+1) when xxxx!=0 if {![equal [::math::bignum::lshift $try [expr {-$exp}]] $integer]} { set try [::math::bignum::add 1 $try] } ::math::bignum::setsign try $sign return $try } ################################################################################ # returns a list formed by an integer and an exponent # x = (A +/- C) * 10 power B # return [list "F" A B C] (where F is the BigFloat tag) # A and C are BigInts, B is a raw integer # return also a BigInt when there is neither a dot, nor a 'e' exponent # # arguments : -base base integer # or integer # or float # or float trailingZeros ################################################################################ proc ::math::bigfloat::fromstr {args} { if {[set string [lindex $args 0]]=="-base"} { if {[llength $args]!=3} { error "should be : fromstr -base base number" } # converts an integer i expressed in base b with : [fromstr b i] return [::math::bignum::fromstr [lindex $args 2] [lindex $args 1]] } # trailingZeros are zeros appended to the Mantissa (it is optional) set trailingZeros 0 if {[llength $args]==2} { set trailingZeros [lindex $args 1] } if {$trailingZeros<0} { error "second argument has to be a positive integer" } # eliminate the sign problem # added on 05/08/2005 # setting '$signe' to the sign of the number set string [string trimleft $string +] if {[string index $string 0]=="-"} { set signe 1 set string2 [string range $string 1 end] } else { set signe 0 set string2 $string } # integer case (not a floating-point number) if {[string is digit $string2]} { if {$trailingZeros!=0} { error "second argument not allowed with an integer" } # we have completed converting an integer to a BigInt # please note that most math::bigfloat procs accept BigInts as arguments return [::math::bignum::fromstr $string] } set string $string2 # floating-point number : check for an exponent # scientific notation set tab [split $string e] if {[llength $tab]>2} { # there are more than one 'e' letter in the number error "syntax error in number : $string" } if {[llength $tab]==2} { set exp [lindex $tab 1] # now exp can look like +099 so you need to handle octal numbers # too bad... # find the sign (if any?) regexp {^[\+\-]?} $exp expsign # trim the number with left-side 0's set found [string length $expsign] set exp $expsign[string trimleft [string range $exp $found end] 0] set number [lindex $tab 0] } else { set exp 0 set number [lindex $tab 0] } # a floating-point number may have a dot set tab [split $number .] if {[llength $tab]>2} {error "syntax error in number : $string"} if {[llength $tab]==2} { set number [join $tab ""] # increment by the number of decimals (after the dot) incr exp -[string length [lindex $tab 1]] } # this is necessary to ensure we can call fromstr (recursively) with # the mantissa ($number) if {![string is digit $number]} { error "$number is not a number" } # take account of trailing zeros incr exp -$trailingZeros # multiply $number by 10^$trailingZeros set number [::math::bignum::mul [::math::bignum::fromstr $number]\ [tenPow $trailingZeros]] ::math::bignum::setsign number $signe # the F tags a BigFloat # a BigInt in internal representation begins by the sign # delta is 1 as a BigInt return [_fromstr $number $exp] } ################################################################################ # private procedure to transform decimal floats into binary ones # IN : # - number : a BigInt representing the Mantissa # - exp : the decimal exponent (a simple integer) # OUT : # $number * 10^$exp, as the internal binary representation of a BigFloat ################################################################################ proc ::math::bigfloat::_fromstr {number exp} { variable one variable five if {$exp==0} { return [list F $number 0 $one] } if {$exp>0} { # mul by 10^exp, and by 2^4, then normalize set number [::math::bignum::lshift $number 4] set exponent [tenPow $exp] set number [::math::bignum::mul $number $exponent] # normalize number*2^-4 +/- 2^4*10^exponent return [normalize [list F $number -4 [::math::bignum::lshift $exponent 4]]] } # now exp is negative or null # the closest power of 2 to the 'exp'th power of ten, but greater than it set binaryExp [expr {int(ceil(-$exp*log(10)/log(2)))+4}] # then compute n * 2^binaryExp / 10^(-exp) # (exp is negative) # equals n * 2^(binaryExp+exp) / 5^(-exp) set diff [expr {$binaryExp+$exp}] if {$diff<0} { error "internal error" } set fivePow [::math::bignum::pow $five [::math::bignum::fromstr [expr {-$exp}]]] set number [::math::bignum::div [::math::bignum::lshift $number \ $diff] $fivePow] set delta [::math::bignum::div [::math::bignum::lshift 1 \ $diff] $fivePow] return [normalize [list F $number [expr {-$binaryExp}] [::math::bignum::add $delta 1]]] } ################################################################################ # fromdouble : # like fromstr, but for a double scalar value # arguments : # double - the number to convert to a BigFloat # exp (optional) - the total number of digits ################################################################################ proc ::math::bigfloat::fromdouble {double {exp {}}} { set mantissa [lindex [split $double e] 0] # line added by SArnold on 05/08/2005 set mantissa [string trimleft [string map {+ "" - ""} $mantissa] 0] set precision [string length [string map {. ""} $mantissa]] if { $exp != {} && [incr exp]>$precision } { return [fromstr $double [expr {$exp-$precision}]] } else { # tests have failed : not enough precision or no exp argument return [fromstr $double] } } ################################################################################ # converts a BigInt into a BigFloat with a given decimal precision ################################################################################ proc ::math::bigfloat::int2float {int {decimals 1}} { # it seems like we need some kind of type handling # very odd in this Tcl world :-( if {![isInt $int]} { error "first argument is not an integer" } if {$decimals<1} { error "non-positive decimals number" } # the lowest number of decimals is 1, because # [tostr [fromstr 10.0]] returns 10. # (we lose 1 digit when converting back to string) set int [::math::bignum::mul $int [tenPow $decimals]] return [_fromstr $int [expr {-$decimals}]] } ################################################################################ # multiplies 'leftop' by 'rightop' and rshift the result by 'shift' ################################################################################ proc ::math::bigfloat::intMulShift {leftop rightop shift} { return [::math::bignum::rshift [::math::bignum::mul $leftop $rightop] $shift] } ################################################################################ # returns 1 if x is a BigFloat, 0 elsewhere ################################################################################ proc ::math::bigfloat::isFloat {x} { # a BigFloat is a list of : "F" mantissa exponent delta if {[llength $x]!=4} { return 0 } # the marker is the letter "F" if {[string equal [lindex $x 0] F]} { return 1 } return 0 } ################################################################################ # checks that n is a BigInt (a number create by math::bignum::fromstr) ################################################################################ proc ::math::bigfloat::isInt {n} { if {[llength $n]<3} { return 0 } if {[string equal [lindex $n 0] bignum]} { return 1 } return 0 } ################################################################################ # returns 1 if x is null, 0 otherwise ################################################################################ proc ::math::bigfloat::iszero {x} { if {[isInt $x]} { return [::math::bignum::iszero $x] } checkFloat x # now we do some interval rounding : if a number's interval englobs 0, # it is considered to be equal to zero foreach {dummy integer exp delta} $x {break} set integer [::math::bignum::abs $integer] if {[::math::bignum::cmp $delta $integer]>=0} {return 1} return 0 } ################################################################################ # compute log(X) ################################################################################ proc ::math::bigfloat::log {x} { checkFloat x foreach {dummy integer exp delta} $x {break} if {[::math::bignum::iszero $integer]||[::math::bignum::sign $integer]} { error "zero logarithm error" } if {[iszero $x]} { error "number is null" } set precision [::math::bignum::bits $integer] # uncertainty of the logarithm set delta [::math::bignum::add 1 [_logOnePlusEpsilon $delta $integer $precision]] # we got : x = 1xxxxxx (binary number with 'precision' bits) * 2^exp # we need : x = 0.1xxxxxx(binary) *2^(exp+precision) incr exp $precision foreach {integer deltaIncr} [_log $integer] {break} set delta [::math::bignum::add $delta $deltaIncr] # log(a * 2^exp)= log(a) + exp*log(2) # result = log(x) + exp*log(2) # as x<1 log(x)<0 but 'integer' (result of '_log') is the absolute value # that is why we substract $integer to log(2)*$exp set integer [::math::bignum::sub [::math::bignum::mul [_log2 $precision] \ [set exp [::math::bignum::fromstr $exp]]] $integer] set delta [::math::bignum::add $delta [abs $exp]] return [normalize [list F $integer -$precision $delta]] } ################################################################################ # compute log(1-epsNum/epsDenom)=log(1-'epsilon') # Taylor development gives -x -x^2/2 -x^3/3 -x^4/4 ... # used by 'log' command because log(x+/-epsilon)=log(x)+log(1+/-(epsilon/x)) # so the uncertainty equals abs(log(1-epsilon/x)) # ================================================ # arguments : # epsNum IN (the numerator of epsilon) # epsDenom IN (the denominator of epsilon) # precision IN (the number of bits after the dot) # # 'epsilon' = epsNum*2^-precision/epsDenom ################################################################################ proc ::math::bigfloat::_logOnePlusEpsilon {epsNum epsDenom precision} { if {[::math::bignum::cmp $epsNum $epsDenom]>=0} { error "number is null" } set s [::math::bignum::lshift $epsNum $precision] set s [::math::bignum::div $s $epsDenom] variable two set divider $two set t [::math::bignum::div [::math::bignum::mul $s $epsNum] $epsDenom] set u [::math::bignum::div $t $divider] # when u (the current term of the development) is zero, we have reached our goal # it has converged while {![::math::bignum::iszero $u]} { set s [::math::bignum::add $s $u] # divider = order of the term = 'n' set divider [::math::bignum::add 1 $divider] # t = (epsilon)^n set t [::math::bignum::div [::math::bignum::mul $t $epsNum] $epsDenom] # u = t/n = (epsilon)^n/n and is the nth term of the Taylor development set u [::math::bignum::div $t $divider] } return $s } ################################################################################ # compute log(0.xxxxxxxx) : log(1-epsilon)=-eps-eps^2/2-eps^3/3...-eps^n/n ################################################################################ proc ::math::bigfloat::_log {integer} { # the uncertainty is nbSteps with nbSteps<=nbBits # take nbSteps=nbBits (the worse case) and log(nbBits+increment)=increment set precision [::math::bignum::bits $integer] set n [expr {int(log($precision+2*log($precision)))}] set integer [::math::bignum::lshift $integer $n] incr precision $n variable three set delta $three # 1-epsilon=integer set integer [::math::bignum::sub [::math::bignum::lshift 1 $precision] $integer] set s $integer # t=x^2 set t [intMulShift $integer $integer $precision] variable two set denom $two # u=x^2/2 (second term) set u [::math::bignum::div $t $denom] while {![::math::bignum::iszero $u]} { # while the current term is not zero, it has not converged set s [::math::bignum::add $s $u] set delta [::math::bignum::add 1 $delta] # t=x^n set t [intMulShift $t $integer $precision] # denom = n (the order of the current development term) set denom [::math::bignum::add 1 $denom] # u = x^n/n (the nth term of Taylor development) set u [::math::bignum::div $t $denom] } # shift right to restore the precision set delta [::math::bignum::add 1 [::math::bignum::rshift $delta $n]] return [list [::math::bignum::rshift $s $n] $delta] } ################################################################################ # computes log(num/denom) with 'precision' bits # used to compute some analysis constants with a given accuracy # you might not call this procedure directly : it assumes 'num/denom'>4/5 # and 'num/denom'<1 ################################################################################ proc ::math::bigfloat::__log {num denom precision} { # Please Note : we here need a precision increment, in order to # keep accuracy at $precision digits. If we just hold $precision digits, # each number being precise at the last digit +/- 1, # we would lose accuracy because small uncertainties add to themselves. # Example : 0.0001 + 0.0010 = 0.0011 +/- 0.0002 # This is quite the same reason that made tcl_precision defaults to 12 : # internally, doubles are computed with 17 digits, but to keep precision # we need to limit our results to 12. # The solution : given a precision target, increment precision with a # computed value so that all digits of he result are exacts. # # p is the precision # pk is the precision increment # 2 power pk is also the maximum number of iterations # for a number close to 1 but lower than 1, # (denom-num)/denum is (in our case) lower than 1/5 # so the maximum nb of iterations is for: # 1/5*(1+1/5*(1/2+1/5*(1/3+1/5*(...)))) # the last term is 1/n*(1/5)^n # for the last term to be lower than 2^(-p-pk) # the number of iterations has to be # 2^(-pk).(1/5)^(2^pk) < 2^(-p-pk) # log(1/5).2^pk < -p # 2^pk > p/log(5) # pk > log(2)*log(p/log(5)) # now set the variable n to the precision increment i.e. pk set n [expr {int(log(2)*log($precision/log(5)))+1}] incr precision $n # log(num/denom)=log(1-(denom-num)/denom) # log(1+x) = x + x^2/2 + x^3/3 + ... + x^n/n # = x(1 + x(1/2 + x(1/3 + x(...+ x(1/(n-1) + x/n)...)))) set num [::math::bignum::fromstr [expr {$denom-$num}]] set denom [::math::bignum::fromstr $denom] # $s holds the result set s [::math::bignum::div [::math::bignum::lshift $num $precision] $denom] # $t holds x^n set t [::math::bignum::div [::math::bignum::mul $s $num] $denom] variable two set d $two # $u holds x^n/n set u [::math::bignum::div $t $d] while {![::math::bignum::iszero $u]} { set s [::math::bignum::add $s $u] # get x^n * x set t [::math::bignum::div [::math::bignum::mul $t $num] $denom] # get n+1 set d [::math::bignum::add 1 $d] # then : $u = x^(n+1)/(n+1) set u [::math::bignum::div $t $d] } # see head of the proc : we return the value with its target precision return [::math::bignum::rshift $s $n] } ################################################################################ # computes log(2) with 'precision' bits and caches it into a namespace variable ################################################################################ proc ::math::bigfloat::__logbis {precision} { set increment [expr {int(log($precision)/log(2)+1)}] incr precision $increment # ln(2)=3*ln(1-4/5)+ln(1-125/128) set a [__log 125 128 $precision] set b [__log 4 5 $precision] variable three set r [::math::bignum::add [::math::bignum::mul $b $three] $a] set ::math::bigfloat::Log2 [::math::bignum::rshift $r $increment] # formerly (when BigFloats were stored in ten radix) we had to compute log(10) # ln(10)=10.ln(1-4/5)+3*ln(1-125/128) } ################################################################################ # retrieves log(2) with 'precision' bits ; the result is cached ################################################################################ proc ::math::bigfloat::_log2 {precision} { variable Log2 if {![info exists Log2]} { __logbis $precision } else { # the constant is cached and computed again when more precision is needed set l [::math::bignum::bits $Log2] if {$precision>$l} { __logbis $precision } } # return log(2) with 'precision' bits even when the cached value has more bits return [_round $Log2 $precision] } ################################################################################ # returns A modulo B (like with fmod() math function) ################################################################################ proc ::math::bigfloat::mod {a b} { checkNumber a b if {[isInt $a] && [isInt $b]} {return [::math::bignum::mod $a $b]} if {[isInt $a]} {error "trying to divide a BigInt by a BigFloat"} set quotient [div $a $b] # examples : fmod(3,2)=1 quotient=1.5 # fmod(1,2)=1 quotient=0.5 # quotient>0 and b>0 : get floor(quotient) # fmod(-3,-2)=-1 quotient=1.5 # fmod(-1,-2)=-1 quotient=0.5 # quotient>0 and b<0 : get floor(quotient) # fmod(-3,2)=-1 quotient=-1.5 # fmod(-1,2)=-1 quotient=-0.5 # quotient<0 and b>0 : get ceil(quotient) # fmod(3,-2)=1 quotient=-1.5 # fmod(1,-2)=1 quotient=-0.5 # quotient<0 and b<0 : get ceil(quotient) if {[sign $quotient]} { set quotient [ceil $quotient] } else { set quotient [floor $quotient] } return [sub $a [mul $quotient $b]] } ################################################################################ # returns A times B ################################################################################ proc ::math::bigfloat::mul {a b} { checkNumber a b # dispatch the command to appropriate commands regarding types (BigInt & BigFloat) if {[isInt $a]} { if {[isInt $b]} { return [::math::bignum::mul $a $b] } return [mulFloatByInt $b $a] } if {[isInt $b]} {return [mulFloatByInt $a $b]} # now we are sure that 'a' and 'b' are BigFloats foreach {dummy integerA expA deltaA} $a {break} foreach {dummy integerB expB deltaB} $b {break} # 2^expA * 2^expB = 2^(expA+expB) set exp [expr {$expA+$expB}] # mantissas are multiplied set integer [::math::bignum::mul $integerA $integerB] # compute precisely the uncertainty set deltaAB [::math::bignum::mul $deltaA $deltaB] set deltaA [::math::bignum::mul [abs $integerB] $deltaA] set deltaB [::math::bignum::mul [abs $integerA] $deltaB] set delta [::math::bignum::add [::math::bignum::add $deltaA $deltaB] \ [::math::bignum::add 1 $deltaAB]] # we have to normalize because 'delta' may be too big return [normalize [list F $integer $exp $delta]] } ################################################################################ # returns A times B, where B is a positive integer ################################################################################ proc ::math::bigfloat::mulFloatByInt {a b} { checkFloat a foreach {dummy integer exp delta} $a {break} if {![isInt $b]} { error "second argument expected to be a BigInt" } # Mantissa and Delta are simply multplied by $b set integer [::math::bignum::mul $integer $b] set delta [::math::bignum::mul $delta $b] # We normalize because Delta could have seriously increased return [normalize [list F $integer $exp $delta]] } ################################################################################ # normalizes a number : Delta (accuracy of the BigFloat) # has to be limited, because the memory use increase # quickly when we do some computations, as the Mantissa and Delta # increase together # The solution : keep the size of Delta under 9 bits ################################################################################ proc ::math::bigfloat::normalize {number} { checkFloat number foreach {dummy integer exp delta} $number {break} set l [::math::bignum::bits $delta] if {$l>8} { # next line : $l holds the supplementary size (in bits) incr l -8 # now we can shift right by $l bits # always round upper the Delta set delta [::math::bignum::add 1 [::math::bignum::rshift $delta $l]] set integer [::math::bignum::rshift $integer $l] incr exp $l } return [list F $integer $exp $delta] } ################################################################################ # returns -A (the opposite) ################################################################################ proc ::math::bigfloat::opp {a} { checkNumber a if {[iszero $a]} { return $a } if {[isInt $a]} { ::math::bignum::setsign a [expr {![::math::bignum::sign $a]}] return $a } # recursive call lset a 1 [opp [lindex $a 1]] return $a } ################################################################################ # gets Pi with precision bits # after the dot (after you call [tostr] on the result) ################################################################################ proc ::math::bigfloat::pi {precision {binary 0}} { if {[llength $precision]>1} { if {[isInt $precision]} { set precision [tostr $precision] } else { error "'$precision' expected to be an integer" } } if {!$binary} { # convert decimal digit length into bit length set precision [expr {int(ceil($precision*log(10)/log(2)))}] } variable one return [list F [_pi $precision] -$precision $one] } proc ::math::bigfloat::_pi {precision} { # the constant Pi begins with 3.xxx # so we need 2 digits to store the digit '3' # and then we will have precision+2 bits in the mantissa variable _pi0 if {![info exists _pi0]} { set _pi0 [__pi $precision] } set lenPiGlobal [::math::bignum::bits $_pi0] if {$lenPiGlobal<$precision} { set _pi0 [__pi $precision] } return [::math::bignum::rshift $_pi0 [expr {[::math::bignum::bits $_pi0]-2-$precision}]] } ################################################################################ # computes an integer representing Pi in binary radix, with precision bits ################################################################################ proc ::math::bigfloat::__pi {precision} { set safetyLimit 8 # for safety and for the better precision, we do so ... incr precision $safetyLimit # formula found in the Math litterature # Pi/4 = 6.atan(1/18) + 8.atan(1/57) - 5.atan(1/239) set a [::math::bignum::mul [_atanfract [::math::bignum::fromstr 18] $precision] \ [::math::bignum::fromstr 48]] set a [::math::bignum::add $a [::math::bignum::mul \ [_atanfract [::math::bignum::fromstr 57] $precision] [::math::bignum::fromstr 32]]] set a [::math::bignum::sub $a [::math::bignum::mul \ [_atanfract [::math::bignum::fromstr 239] $precision] [::math::bignum::fromstr 20]]] return [::math::bignum::rshift $a $safetyLimit] } ################################################################################ # shift right an integer until it haves $precision bits # round at the same time ################################################################################ proc ::math::bigfloat::_round {integer precision} { set shift [expr {[::math::bignum::bits $integer]-$precision}] # $result holds the shifted integer set result [::math::bignum::rshift $integer $shift] # $shift-1 is the bit just rights the last bit of the result # Example : integer=1000010 shift=2 # => result=10000 and the tested bit is '1' if {[::math::bignum::testbit $integer [expr {$shift-1}]]} { # we round to the upper limit return [::math::bignum::add 1 $result] } return $result } ################################################################################ # returns A power B, where B is a positive integer ################################################################################ proc ::math::bigfloat::pow {a b} { checkNumber a if {![isInt $b]} { error "pow : exponent is not a positive integer" } # case where it is obvious that we should use the appropriate command # from math::bignum (added 5th March 2005) if {[isInt $a]} { return [::math::bignum::pow $a $b] } # algorithm : exponent=$b = Sum(i=0..n) b(i)2^i # $a^$b = $a^( b(0) + 2b(1) + 4b(2) + ... + 2^n*b(n) ) # we have $a^(x+y)=$a^x * $a^y # then $a^$b = Product(i=0...n) $a^(2^i*b(i)) # b(i) is boolean so $a^(2^i*b(i))= 1 when b(i)=0 and = $a^(2^i) when b(i)=1 # then $a^$b = Product(i=0...n and b(i)=1) $a^(2^i) and 1 when $b=0 variable one if {[::math::bignum::iszero $b]} {return $one} # $res holds the result set res $one while {1} { # at the beginning i=0 # $remainder is b(i) set remainder [::math::bignum::testbit $b 0] # $b 'rshift'ed by 1 bit : i=i+1 # so next time we will test bit b(i+1) set b [::math::bignum::rshift $b 1] # if b(i)=1 if {$remainder} { # mul the result by $a^(2^i) # if i=0 we multiply by $a^(2^0)=$a^1=$a set res [mul $res $a] } # no more bits at '1' in $b : $res is the result if {[::math::bignum::iszero $b]} { if {[isInt $res]} { # we cannot (and should not) normalize an integer return $res } return [normalize $res] } # i=i+1 : $a^(2^(i+1)) = square of $a^(2^i) set a [mul $a $a] } } ################################################################################ # converts angles for radians to degrees ################################################################################ proc ::math::bigfloat::rad2deg {x} { checkFloat x set xLen [expr {-[lindex $x 2]}] if {$xLen<3} { error "number too loose to convert to degrees" } set pi [pi $xLen 1] # $rad/Pi=$deg/180 # so result in deg = $radians*180/Pi return [div [mul $x [::math::bignum::fromstr 180]] $pi] } ################################################################################ # retourne la partie entière (ou 0) du nombre "number" ################################################################################ proc ::math::bigfloat::round {number} { checkFloat number #set number [normalize $number] # fetching integers (or BigInts) from the internal representation foreach {dummy integer exp delta} $number {break} if {[::math::bignum::iszero $integer]} { # returns the BigInt 0 variable zero return $zero } if {$exp>=0} { error "not enough precision to round (in round)" } set exp [expr {-$exp}] # saving the sign, ... set sign [::math::bignum::sign $integer] set integer [abs $integer] # integer part of the number set try [::math::bignum::rshift $integer $exp] # first bit after the dot set way [::math::bignum::testbit $integer [expr {$exp-1}]] # delta is shifted so it gives the integer part of 2*delta set delta [::math::bignum::rshift $delta [expr {$exp-1}]] # when delta is too big to compute rounded value ( if {![::math::bignum::iszero $delta]} { error "not enough precision to round (in round)" } if {$way} { set try [::math::bignum::add 1 $try] } # ... restore the sign now ::math::bignum::setsign try $sign return $try } ################################################################################ # round and divide by 10^n ################################################################################ proc ::math::bigfloat::roundshift {integer n} { # $exp= 10^$n set exp [tenPow $n] foreach {result remainder} [::math::bignum::divqr $integer $exp] {} # $remainder belongs to the interval [0, $exp-1] # $remainder >= $exp/2 is the rounding condition # that is better expressed in this form : # $remainder*2 >= $exp , as we are treating integers, not rationals # left shift $remainder by 1 equals to multiplying by 2 and is much faster if {[::math::bignum::cmp $exp [::math::bignum::lshift $remainder 1]]<=0} { return [::math::bignum::add 1 $result] } return $result } ################################################################################ # gets the sign of either a bignum, or a BitFloat # we keep the bignum convention : 0 for positive, 1 for negative ################################################################################ proc ::math::bigfloat::sign {n} { if {[isInt $n]} { return [::math::bignum::sign $n] } # sign of 0=0 if {[iszero $n]} {return 0} # the sign of the Mantissa, which is a BigInt return [::math::bignum::sign [lindex $n 1]] } ################################################################################ # gets sin(x) ################################################################################ proc ::math::bigfloat::sin {x} { checkFloat x foreach {dummy integer exp delta} $x {break} if {$exp>-2} { error "sin : not enough precision" } set precision [expr {-$exp}] # sin(2kPi+x)=sin(x) # $integer is now the modulo of the division of the mantissa by Pi/4 # and $n is the quotient foreach {n integer} [divPiQuarter $integer $precision] {break} set delta [::math::bignum::add $delta $n] variable four set d [::math::bignum::mod $n $four] # now integer>=0 # x = $n*Pi/4 + $integer and $n belongs to [0,3] # sin(2Pi-x)=-sin(x) # sin(Pi-x)=sin(x) # sin(Pi/2+x)=cos(x) set sign 0 switch -- [tostr $d] { 0 {set l [_sin2 $integer $precision $delta]} 1 {set l [_cos2 $integer $precision $delta]} 2 {set sign 1;set l [_sin2 $integer $precision $delta]} 3 {set sign 1;set l [_cos2 $integer $precision $delta]} default {error "internal error"} } # $l is a list : {Mantissa Precision Delta} # precision --> the opposite of the exponent # 1.000 = 1000*10^-3 so exponent=-3 and precision=3 digits lset l 1 [expr {-([lindex $l 1])}] set integer [lindex $l 0] # the sign depends on the switch statement below ::math::bignum::setsign integer $sign lset l 0 $integer # we insert the Bigfloat tag (F) and normalize the final result return [normalize [linsert $l 0 F]] } proc ::math::bigfloat::_sin2 {x precision delta} { set pi [_pi $precision] # shift right by 1 = divide by 2 # shift right by 2 = divide by 4 set pis2 [::math::bignum::rshift $pi 1] set pis4 [::math::bignum::rshift $pi 2] if {[::math::bignum::cmp $x $pis4]>=0} { # sin(Pi/2-x)=cos(x) set delta [::math::bignum::add 1 $delta] set x [::math::bignum::sub $pis2 $x] return [_cos $x $precision $delta] } return [_sin $x $precision $delta] } ################################################################################ # sin(x) with 'x' lower than Pi/4 and positive # 'x' is the Mantissa - 'delta' is Delta # 'precision' is the opposite of the exponent ################################################################################ proc ::math::bigfloat::_sin {x precision delta} { # $s holds the result set s $x # sin(x) = x - x^3/3! + x^5/5! - ... + (-1)^n*x^(2n+1)/(2n+1)! # = x * (1 - x^2/(2*3) * (1 - x^2/(4*5) * (...* (1 - x^2/(2n*(2n+1)) )...))) # The second expression allows us to compute the less we can # $double holds the uncertainty (Delta) of x^2 : 2*(Mantissa*Delta) + Delta^2 # (Mantissa+Delta)^2=Mantissa^2 + 2*Mantissa*Delta + Delta^2 set double [::math::bignum::rshift [::math::bignum::mul $x $delta] [expr {$precision-1}]] set double [::math::bignum::add [::math::bignum::add 1 $double] [::math::bignum::rshift \ [::math::bignum::mul $delta $delta] $precision]] # $x holds the Mantissa of x^2 set x [intMulShift $x $x $precision] set dt [::math::bignum::rshift [::math::bignum::add [::math::bignum::mul $x $delta] \ [::math::bignum::mul [::math::bignum::add $s $delta] $double]] $precision] set dt [::math::bignum::add 1 $dt] # $t holds $s * -(x^2) / (2n*(2n+1)) # mul by x^2 set t [intMulShift $s $x $precision] variable two set denom2 $two variable three set denom3 $three # mul by -1 (opp) and divide by 2*3 set t [opp [::math::bignum::div $t [::math::bignum::mul $denom2 $denom3]]] while {![::math::bignum::iszero $t]} { set s [::math::bignum::add $s $t] set delta [::math::bignum::add $delta $dt] # incr n => 2n --> 2n+2 and 2n+1 --> 2n+3 set denom2 [::math::bignum::add $denom2 $two] set denom3 [::math::bignum::add $denom3 $two] # $dt is the Delta corresponding to $t # $double "" "" "" "" $x (x^2) # ($t+$dt) * ($x+$double) = $t*$x + ($dt*$x + $t*$double) + $dt*$double # Mantissa^ ^--------Delta-------------------^ set dt [::math::bignum::rshift [::math::bignum::add [::math::bignum::mul $x $dt] \ [::math::bignum::mul [::math::bignum::add $t $dt] $double]] $precision] set t [intMulShift $t $x $precision] # removed 2005/08/31 by sarnold75 #set dt [::math::bignum::add $dt $double] set denom [::math::bignum::mul $denom2 $denom3] # now computing : div by -2n(2n+1) set dt [::math::bignum::add 1 [::math::bignum::div $dt $denom]] set t [opp [::math::bignum::div $t $denom]] } return [list $s $precision $delta] } ################################################################################ # procedure for extracting the square root of a BigFloat ################################################################################ proc ::math::bigfloat::sqrt {x} { variable one checkFloat x foreach {dummy integer exp delta} $x {break} # if x=0, return 0 if {[iszero $x]} { variable zero # return zero, taking care of its precision ($exp) return [list F $zero $exp $one] } # we cannot get sqrt(x) if x<0 if {[lindex $integer 0]<0} { error "negative sqrt input" } # (1+epsilon)^p = 1 + epsilon*(p-1) + epsilon^2*(p-1)*(p-2)/2! + ... # + epsilon^n*(p-1)*...*(p-n)/n! # sqrt(1 + epsilon) = (1 + epsilon)^(1/2) # = 1 - epsilon/2 - epsilon^2*3/(4*2!) - ... # - epsilon^n*(3*5*..*(2n-1))/(2^n*n!) # sqrt(1 - epsilon) = 1 + Sum(i=1..infinity) epsilon^i*(3*5*...*(2i-1))/(i!*2^i) # sqrt(n +/- delta)=sqrt(n) * sqrt(1 +/- delta/n) # so the uncertainty on sqrt(n +/- delta) equals sqrt(n) * (sqrt(1 - delta/n) - 1) # sqrt(1+eps) < sqrt(1-eps) because their logarithm compare as : # -ln(2)(1+eps) < -ln(2)(1-eps) # finally : # Delta = sqrt(n) * Sum(i=1..infinity) (delta/n)^i*(3*5*...*(2i-1))/(i!*2^i) # here we compute the second term of the product by _sqrtOnePlusEpsilon set delta [_sqrtOnePlusEpsilon $delta $integer] set intLen [::math::bignum::bits $integer] # removed 2005/08/31 by sarnold75, readded 2005/08/31 set precision $intLen # intLen + exp = number of bits before the dot #set precision [expr {-$exp}] # square root extraction set integer [::math::bignum::lshift $integer $intLen] incr exp -$intLen incr intLen $intLen # there is an exponent 2^$exp : when $exp is odd, we would need to compute sqrt(2) # so we decrement $exp, in order to get it even, and we do not need sqrt(2) anymore ! if {$exp&1} { incr exp -1 set integer [::math::bignum::lshift $integer 1] incr intLen incr precision } # using a low-level (in math::bignum) root extraction procedure set integer [::math::bignum::sqrt $integer] # delta has to be multiplied by the square root set delta [::math::bignum::rshift [::math::bignum::mul $delta $integer] $precision] # round to the ceiling the uncertainty (worst precision, the fastest to compute) set delta [::math::bignum::add 1 $delta] # we are sure that $exp is even, see above return [normalize [list F $integer [expr {$exp/2}] $delta]] } ################################################################################ # compute abs(sqrt(1-delta/integer)-1) # the returned value is a relative uncertainty ################################################################################ proc ::math::bigfloat::_sqrtOnePlusEpsilon {delta integer} { # sqrt(1-x) - 1 = x/2 + x^2*3/(2^2*2!) + x^3*3*5/(2^3*3!) + ... # = x/2 * (1 + x*3/(2*2) * ( 1 + x*5/(2*3) * # (...* (1 + x*(2n-1)/(2n) ) )...))) variable one set l [::math::bignum::bits $integer] # to compute delta/integer we have to shift left to keep the same precision level # we have a better accuracy computing (delta << lg(integer))/integer # than computing (delta/integer) << lg(integer) set x [::math::bignum::div [::math::bignum::lshift $delta $l] $integer] variable four variable two # denom holds 2n set denom $four # x/2 set result [::math::bignum::div $x $two] # x^2*3/(2!*2^2) variable three # numerator holds 2n-1 set numerator $three set temp [::math::bignum::mul $result $delta] set temp [::math::bignum::div [::math::bignum::mul $temp $numerator] $integer] set temp [::math::bignum::add 1 [::math::bignum::div $temp $denom]] while {![::math::bignum::iszero $temp]} { set result [::math::bignum::add $result $temp] set numerator [::math::bignum::add $numerator $two] set denom [::math::bignum::add $two $denom] # n = n+1 ==> num=num+2 denom=denom+2 # num=2n+1 denom=2n+2 set temp [::math::bignum::mul [::math::bignum::mul $temp $delta] $numerator] set temp [::math::bignum::div [::math::bignum::div $temp $denom] $integer] } return $result } ################################################################################ # substracts B to A ################################################################################ proc ::math::bigfloat::sub {a b} { checkNumber a b if {[isInt $a] && [isInt $b]} { # the math::bignum::sub proc is designed to work with BigInts return [::math::bignum::sub $a $b] } return [add $a [opp $b]] } ################################################################################ # tangent (trivial algorithm) ################################################################################ proc ::math::bigfloat::tan {x} { return [::math::bigfloat::div [::math::bigfloat::sin $x] [::math::bigfloat::cos $x]] } ################################################################################ # returns a power of ten ################################################################################ proc ::math::bigfloat::tenPow {n} { variable ten return [::math::bignum::pow $ten [::math::bignum::fromstr $n]] } ################################################################################ # converts a BigInt to a double (basic floating-point type) # with respect to the global variable 'tcl_precision' ################################################################################ proc ::math::bigfloat::todouble {x} { global tcl_precision checkFloat x # get the string repr of x without the '+' sign set result [string trimleft [tostr $x] +] set minus "" if {[string index $result 0]=="-"} { set minus - set result [string range $result 1 end] } set l [split $result e] set exp 0 if {[llength $l]==2} { # exp : x=Mantissa*10^Exp set exp [lindex $l 1] } # Mantissa = integerPart.fractionalPart set l [split [lindex $l 0] .] set integerPart [lindex $l 0] set integerLen [string length $integerPart] set fractionalPart [lindex $l 1] # The number of digits in Mantissa, excluding the dot and the leading zeros, of course set len [string length [set integer $integerPart$fractionalPart]] # Now Mantissa is stored in $integer if {$len>$tcl_precision} { set lenDiff [expr {$len-$tcl_precision}] # true when the number begins with a zero set zeroHead 0 if {[string index $integer 0]==0} { incr lenDiff -1 set zeroHead 1 } set integer [tostr [roundshift [::math::bignum::fromstr $integer] $lenDiff]] if {$zeroHead} { set integer 0$integer } set len [string length $integer] if {$len<$integerLen} { set exp [expr {$integerLen-$len}] # restore the true length set integerLen $len } } # number = 'sign'*'integer'*10^'exp' if {$exp==0} { # no scientific notation set exp "" } else { # scientific notation set exp e$exp } # place the dot just before the index $integerLen in the Mantissa set result [string range $integer 0 [expr {$integerLen-1}]] append result .[string range $integer $integerLen end] # join the Mantissa with the sign before and the exponent after return $minus$result$exp } ################################################################################ # converts a number stored as a list to a string in which all digits are true ################################################################################ proc ::math::bigfloat::tostr {args} { variable five if {[llength $args]==2} { if {![string equal [lindex $args 0] -nosci]} {error "unknown option: should be -nosci"} set nosci yes set number [lindex $args 1] } else { if {[llength $args]!=1} {error "syntax error: should be tostr ?-nosci? number"} set nosci no set number [lindex $args 0] } if {[isInt $number]} { return [::math::bignum::tostr $number] } checkFloat number foreach {dummy integer exp delta} $number {break} if {[iszero $number]} { # we do not matter how much precision $number has : # it can be 0.0000000 or 0.0, the result is still the same : the "0" string # not anymore : 0.000 is not 0.0 ! # return 0 } if {$exp>0} { # the power of ten the closest but greater than 2^$exp # if it was lower than the power of 2, we would have more precision # than existing in the number set newExp [expr {int(ceil($exp*log(2)/log(10)))}] # 'integer' <- 'integer' * 2^exp / 10^newExp # equals 'integer' * 2^(exp-newExp) / 5^newExp set binExp [expr {$exp-$newExp}] if {$binExp<0} { # it cannot happen error "internal error" } # 5^newExp set fivePower [::math::bignum::pow $five [::math::bignum::fromstr $newExp]] # 'lshift'ing $integer by $binExp bits is like multiplying it by 2^$binExp # but much, much faster set integer [::math::bignum::div [::math::bignum::lshift $integer $binExp] \ $fivePower] # $integer is the Mantissa - Delta should follow the same operations set delta [::math::bignum::div [::math::bignum::lshift $delta $binExp] $fivePower] set exp $newExp } elseif {$exp<0} { # the power of ten the closest but lower than 2^$exp # same remark about the precision set newExp [expr {int(floor(-$exp*log(2)/log(10)))}] # 'integer' <- 'integer' * 10^newExp / 2^(-exp) # equals 'integer' * 5^(newExp) / 2^(-exp-newExp) set fivePower [::math::bignum::pow $five \ [::math::bignum::fromstr $newExp]] set binShift [expr {-$exp-$newExp}] # rshifting is like dividing by 2^$binShift, but faster as we said above about lshift set integer [::math::bignum::rshift [::math::bignum::mul $integer $fivePower] \ $binShift] set delta [::math::bignum::rshift [::math::bignum::mul $delta $fivePower] \ $binShift] set exp -$newExp } # saving the sign, to restore it into the result set sign [::math::bignum::sign $integer] set result [::math::bignum::abs $integer] # rounded 'integer' +/- 'delta' set up [::math::bignum::add $result $delta] set down [::math::bignum::sub $result $delta] if {[sign $up]^[sign $down]} { # $up>0 and $down<0 and vice-versa : then the number is considered equal to zero # delta <= 2**n (n = bits(delta)) # 2**n <= 10**exp , then # exp >= n.log(2)/log(10) # delta <= 10**(n.log(2)/log(10)) incr exp [expr {int(ceil([::math::bignum::bits $delta]*log(2)/log(10)))}] set result 0 set isZero yes } else { # iterate until the convergence of the rounding # we incr $shift until $up and $down are rounded to the same number # at each pass we lose one digit of precision, so necessarly it will success for {set shift 1} { [::math::bignum::cmp [roundshift $up $shift] [roundshift $down $shift]] } { incr shift } {} incr exp $shift set result [::math::bignum::tostr [roundshift $up $shift]] set isZero no } set l [string length $result] # now formatting the number the most nicely for having a clear reading # would'nt we allow a number being constantly displayed # as : 0.2947497845e+012 , would we ? if {$nosci} { if {$exp >= 0} { append result [string repeat 0 $exp]. } elseif {$l + $exp > 0} { set result [string range $result 0 end-[expr {-$exp}]].[string range $result end-[expr {-1-$exp}] end] } else { set result 0.[string repeat 0 [expr {-$exp-$l}]]$result } } else { if {$exp>0} { # we display 423*10^6 as : 4.23e+8 # Length of mantissa : $l # Increment exp by $l-1 because the first digit is placed before the dot, # the other ($l-1) digits following the dot. incr exp [incr l -1] set result [string index $result 0].[string range $result 1 end] append result "e+$exp" } elseif {$exp==0} { # it must have a dot to be a floating-point number (syntaxically speaking) append result . } else { set exp [expr {-$exp}] if {$exp < $l} { # we can display the number nicely as xxxx.yyyy* # the problem of the sign is solved finally at the bottom of the proc set n [string range $result 0 end-$exp] incr exp -1 append n .[string range $result end-$exp end] set result $n } elseif {$l==$exp} { # we avoid to use the scientific notation # because it is harder to read set result "0.$result" } else { # ... but here there is no choice, we should not represent a number # with more than one leading zero set result [string index $result 0].[string range $result 1 end]e-[expr {$exp-$l+1}] } } } # restore the sign : we only put a minus on numbers that are different from zero if {$sign==1 && !$isZero} {set result "-$result"} return $result } ################################################################################ # PART IV # HYPERBOLIC FUNCTIONS ################################################################################ ################################################################################ # hyperbolic cosinus ################################################################################ proc ::math::bigfloat::cosh {x} { # cosh(x) = (exp(x)+exp(-x))/2 # dividing by 2 is done faster by 'rshift'ing return [floatRShift [add [exp $x] [exp [opp $x]]] 1] } ################################################################################ # hyperbolic sinus ################################################################################ proc ::math::bigfloat::sinh {x} { # sinh(x) = (exp(x)-exp(-x))/2 # dividing by 2 is done faster by 'rshift'ing return [floatRShift [sub [exp $x] [exp [opp $x]]] 1] } ################################################################################ # hyperbolic tangent ################################################################################ proc ::math::bigfloat::tanh {x} { set up [exp $x] set down [exp [opp $x]] # tanh(x)=sinh(x)/cosh(x)= (exp(x)-exp(-x))/2/ [(exp(x)+exp(-x))/2] # =(exp(x)-exp(-x))/(exp(x)+exp(-x)) # =($up-$down)/($up+$down) return [div [sub $up $down] [add $up $down]] } # exporting public interface namespace eval ::math::bigfloat { foreach function { add mul sub div mod pow iszero compare equal fromstr tostr fromdouble todouble int2float isInt isFloat exp log sqrt round ceil floor sin cos tan cotan asin acos atan cosh sinh tanh abs opp pi deg2rad rad2deg } { namespace export $function } } # (AM) No "namespace import" - this should be left to the user! #namespace import ::math::bigfloat::* package provide math::bigfloat 1.2.2 tcllib-1.15/modules/math/fuzzy.test0000755000175000017500000002457012077663116016744 0ustar sergeisergei# -*- tcl -*- # fuzzy.test -- # # Test suite for the math::fuzzy procs of tolerant comparisons # (Tcl-only version) # # version 0.2: improved and extended implementation, march 2002 # version 0.2.1: added test for bug #2933130, january 2010 # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.2 testsNeedTcltest 1.0 support { useLocal math.tcl math } testing { useLocal fuzzy.tcl math::fuzzy } # ------------------------------------------------------------------------- namespace import ::math::fuzzy::* # ------------------------------------------------------------------------- # # Test: tolerance has sane value # #test math-fuzzy-Tolerance-1.0 {Tolerance has acceptable value} { # expr {(1.0+0.5*$::math::fuzzy::eps3) != 1.0} #} 1 #test math-fuzzy-Tolerance-1.1 {Tolerance has acceptable value} { # expr {(1.0-0.5*$::math::fuzzy::eps3) != 1.0} #} 1 test math-fuzzy-Tolerance-1.0 {Tolerance has acceptable value} { expr {(1.0+0.5*$::math::fuzzy::eps3) != 1.0} } 1 test math-fuzzy-Tolerance-1.1 {Tolerance has acceptable value} { expr {(1.0-0.5*$::math::fuzzy::eps3) != 1.0} } 1 # # Note: Equal-1.* and NotEqual-1.* are complementary # GrEqual-1.* and Lower-1.* ditto # GrThan-1.* and LoEqual-1.* ditto # test math-fuzzy-Equal-1.0 {Compare two floats and see if they are equal} { teq 1.0 1.001 } 0 test math-fuzzy-Equal-1.1 {Compare two floats and see if they are equal} { teq 1.0 1.0001 } 0 test math-fuzzy-Equal-1.2 {Compare two floats and see if they are equal} { teq 1.0 1.00000000000000001 } 1 test math-fuzzy-Equal-1.3 {Compare two floats and see if they are equal} { teq 1.0 1.000000000000001 } 0 test math-fuzzy-NotEqual-1.0 {Compare two floats and see if they differ} { tne 1.0 1.001 } 1 test math-fuzzy-NotEqual-1.1 {Compare two floats and see if they differ} { tne 1.0 1.0001 } 1 test math-fuzzy-NotEqual-1.2 {Compare two floats and see if they differ} { tne 1.0 1.00000000000000001 } 0 test math-fuzzy-NotEqual-1.3 {Compare two floats and see if they differ} { tne 1.0 1.000000000000001 } 1 test math-fuzzy-GrEqual-1.0 {Compare two floats - check greater/equal} { tge 1.0 1.001 } 0 test math-fuzzy-GrEqual-1.1 {Compare two floats - check greater/equal} { tge 1.0 1.0001 } 0 test math-fuzzy-GrEqual-1.2 {Compare two floats - check greater/equal} { tge 1.0 1.00000000000000001 } 1 test math-fuzzy-GrEqual-1.3 {Compare two floats - check greater/equal} { tge 1.0 1.000000000000001 } 0 test math-fuzzy-Lower-1.0 {Compare two floats - check lower} { tlt 1.0 1.001 } 1 test math-fuzzy-Lower-1.1 {Compare two floats - check lower} { tlt 1.0 1.0001 } 1 test math-fuzzy-Lower-1.2 {Compare two floats - check lower} { tlt 1.0 1.00000000000000001 } 0 test math-fuzzy-Lower-1.3 {Compare two floats - check lower} { tlt 1.0 1.000000000000001 } 1 test math-fuzzy-Lower-1.4 {Compare two floats - check lower} { # They can not both be true expr {[tlt 1.1 1.0] && [tlt 1.0 1.1]} } 0 test math-fuzzy-LoEqual-1.0 {Compare two floats - check lower/equal} { tle 1.0 1.001 } 1 test math-fuzzy-LoEqual-1.1 {Compare two floats - check lower/equal} { tle 1.0 1.0001 } 1 test math-fuzzy-LoEqual-1.2 {Compare two floats - check lower/equal} { tle 1.0 1.00000000000000001 } 1 test math-fuzzy-LoEqual-1.3 {Compare two floats - check lower/equal} { tle 1.0 1.000000000000001 } 1 test math-fuzzy-Greater-1.0 {Compare two floats - check greater} { tgt 1.0 1.001 } 0 test math-fuzzy-Greater-1.1 {Compare two floats - check greater} { tgt 1.0 1.0001 } 0 test math-fuzzy-Greater-1.2 {Compare two floats - check greater} { tgt 1.0 1.00000000000000001 } 0 test math-fuzzy-Greater-1.3 {Compare two floats - check greater} { tgt 1.0 1.000000000000001 } 0 # # Note: there is no possibility to print the results of the # naive comparison or floor/ceil? # # Note: no attention paid to tcl_precision! # test math-fuzzy-ManyCompares-1.0 {Compare results of calculations} { set tol_eq 0 set tol_ne 0 set tol_ge 0 set tol_gt 0 set tol_le 0 set tol_lt 0 for { set i -1000 } { $i <= 1000 } { incr i } { if { $i == 0 } continue set x [expr {1.01/double($i)}] set y [expr {(2.1*$x)*(double($i)/2.1)}] if { [teq $y 1.01] } { incr tol_eq } if { [tne $y 1.01] } { incr tol_ne } if { [tge $y 1.01] } { incr tol_ge } if { [tgt $y 1.01] } { incr tol_gt } if { [tle $y 1.01] } { incr tol_le } if { [tlt $y 1.01] } { incr tol_lt } } set result [list $tol_eq $tol_ne $tol_ge $tol_gt $tol_le $tol_lt] } {2000 0 2000 0 2000 0} test math-fuzzy-ManyCompares-1.1 {Compare fails due to missing braces at reduced precision} { set tol_eq 0 set tol_ne 0 set tol_ge 0 set tol_gt 0 set tol_le 0 set tol_lt 0 # # Force Tcl8.4 or earlier behaviour in expanding numbers # Requires tcl_precision of 12! # set prec $::tcl_precision set ::tcl_precision 12 for { set i -1000 } { $i <= 1000 } { incr i } { if { $i == 0 } continue # # NOTE: The braces in the assignment for y are missing on purpose! # set x [expr {1.01/double($i)}] set y [expr (2.1*$x)*(double($i)/2.1)] if { [teq $y 1.01] } { incr tol_eq } if { [tne $y 1.01] } { incr tol_ne } if { [tge $y 1.01] } { incr tol_ge } if { [tgt $y 1.01] } { incr tol_gt } if { [tle $y 1.01] } { incr tol_le } if { [tlt $y 1.01] } { incr tol_lt } } set result [list $tol_eq $tol_ne $tol_ge $tol_gt $tol_le $tol_lt] set intended {2000 0 2000 0 2000 0} set equal 1 foreach r $result i $intended { if { $r != $i } { set equal 0 } } set tcl_precision $prec set equal } 0 test math-fuzzy-ManyCompares-1.2 {Compare does not fail even with missing braces because of sufficient precision} { set tol_eq 0 set tol_ne 0 set tol_ge 0 set tol_gt 0 set tol_le 0 set tol_lt 0 # # Force sufficient precision if Tcl8.4 or earlier # set prec $::tcl_precision if {![package vsatisfies [package provide Tcl] 8.5]} { set ::tcl_precision 17 } else { set ::tcl_precision 0 } for { set i -1000 } { $i <= 1000 } { incr i } { if { $i == 0 } continue # # NOTE: The braces in the assignment for y are missing on purpose! # set x [expr {1.01/double($i)}] set y [expr (2.1*$x)*(double($i)/2.1)] if { [teq $y 1.01] } { incr tol_eq } if { [tne $y 1.01] } { incr tol_ne } if { [tge $y 1.01] } { incr tol_ge } if { [tgt $y 1.01] } { incr tol_gt } if { [tle $y 1.01] } { incr tol_le } if { [tlt $y 1.01] } { incr tol_lt } } set result [list $tol_eq $tol_ne $tol_ge $tol_gt $tol_le $tol_lt] set intended {2000 0 2000 0 2000 0} set equal 1 foreach r $result i $intended { if { $r != $i } { set equal 0 } } set tcl_precision $prec set equal } 1 test math-fuzzy-ManyCompares-1.3 {Compare fails due to naive comparison} { set naiv_eq 0 set naiv_ne 0 set naiv_ge 0 set naiv_gt 0 set naiv_le 0 set naiv_lt 0 for { set i -1000 } { $i <= 1000 } { incr i } { if { $i == 0 } continue set x [expr {1.01/double($i)}] set y [expr {(2.1*$x)*(double($i)/2.1)}] if { $y == 1.01 } { incr naiv_eq } if { $y != 1.01 } { incr naiv_ne } if { $y >= 1.01 } { incr naiv_ge } if { $y > 1.01 } { incr naiv_gt } if { $y <= 1.01 } { incr naiv_le } if { $y < 1.01 } { incr naiv_lt } } set result [list $naiv_eq $naiv_ne $naiv_ge $naiv_gt $naiv_le $naiv_lt] set intended {2000 0 2000 0 2000 0} set equal 1 foreach r $result i $intended { if { $r != $i } { set equal 0 } } set equal } 0 test math-fuzzy-Floor-Ceil-1.0 {Check floor and ceil functions} { set fc_eq 0 set fz_eq 0 set fz_ne 0 for { set i -1000 } { $i <= 1000 } { incr i } { set x [expr {0.11*double($i)}] set y [expr {(($x*11.0)-$x)-double($i)/10.0}] set z [expr {double($i)}] if { [tfloor $y] == $z } { incr fz_eq } if { [tfloor $y] == [tceil $y] } { incr fc_eq } } set result [list $fc_eq $fz_eq] } {2001 2001} test math-fuzzy-Floor-Ceil-1.1 {Naive floor and ceil fail} { set fc_eq 0 set fz_eq 0 set fz_ne 0 for { set i -1000 } { $i <= 1000 } { incr i } { set x [expr {0.11*double($i)}] set y [expr {(($x*11.0)-$x)-double($i)/10.0}] set z [expr {double($i)}] if { [expr {floor($y)}] == $z } { incr fz_eq } if { [expr {floor($y)}] == [expr {ceil($y)}] } { incr fc_eq } } set result [list $fc_eq $fz_eq] set intended {2001 2001} set equal 1 foreach r $result i $intended { if { $r != $i } { set equal 0 } } set equal } 0 test math-fuzzy-Roundoff-1.0 {Rounding off numbers} { set result {} foreach x { 0.1 0.3 0.4999999 0.5000001 0.99999 -0.1 -0.3 -0.4999999 -0.5000001 -0.99999 } { lappend result [tround $x] } set result } {0.0 0.0 0.0 1.0 1.0 0.0 0.0 0.0 -1.0 -1.0} test math-fuzzy-Roundoff-1.1 {Rounding off numbers naively - may fail} { set result {} foreach x { 0.1 0.3 0.4999999 0.5000001 0.99999 -0.1 -0.3 -0.4999999 -0.5000001 -0.99999 } { lappend result [expr {floor($x+0.5)}] } set result } {0.0 0.0 0.0 1.0 1.0 0.0 0.0 0.0 -1.0 -1.0} test math-fuzzy-Roundoff-2.1 {Rounding off numbers with one digit} { set result {} foreach x { 0.11 0.32 0.4999999 0.5000001 0.99999 -0.11 -0.32 -0.4999999 -0.5000001 -0.99999 } { lappend result [troundn $x 1] } set result } {0.1 0.3 0.5 0.5 1.0 -0.1 -0.3 -0.5 -0.5 -1.0} test math-fuzzy-Roundoff-2.2 {Rounding off numbers with two digits} { set result {} foreach x { 0.11 0.32 0.4999999 0.5000001 0.99999 -0.11 -0.32 -0.4999999 -0.5000001 -0.99999 } { lappend result [troundn $x 2] } set result } {0.11 0.32 0.5 0.5 1.0 -0.11 -0.32 -0.5 -0.5 -1.0} test math-fuzzy-Roundoff-2.3 {Rounding off numbers with three digits} { set result {} foreach x { 0.1115 0.3210 0.4909999 0.5123401 0.99999 -0.1115 -0.3210 -0.4909999 -0.5123401 -0.99999 } { lappend result [troundn $x 3] } set result } {0.112 0.321 0.491 0.512 1.0 -0.111 -0.321 -0.491 -0.512 -1.0} # # Hm, here we have a discrepancy: 0.112 and -0.111! tcllib-1.15/modules/math/machineparameters.tcl0000755000175000017500000002513012077663116021041 0ustar sergeisergei# machineparameters.tcl -- # Compute double precision machine parameters. # # Description # This the Tcl equivalent of the DLAMCH LAPCK function. # In floating point systems, a floating point number is represented # by # x = +/- d1 d2 ... dt basis^e # where digits satisfy # 0 <= di <= basis - 1, i = 1, t # with the convention : # - t is the size of the mantissa # - basis is the basis (the "radix") # # References # # "Algorithms to Reveal Properties of Floating-Point Arithmetic" # Michael A. Malcolm # Stanford University # Communications of the ACM # Volume 15 , Issue 11 (November 1972) # Pages: 949 - 951 # # "More on Algorithms that Reveal Properties of Floating # Point Arithmetic Units" # W. Morven Gentleman, University of Waterloo # Scott B. Marovich, Purdue University # Communications of the ACM # Volume 17 , Issue 5 (May 1974) # Pages: 276 - 277 # # Example # # In the following example, one compute the parameters of a desktop # under Linux with the following Tcl 8.4.19 properties : # #% parray tcl_platform #tcl_platform(byteOrder) = littleEndian #tcl_platform(machine) = i686 #tcl_platform(os) = Linux #tcl_platform(osVersion) = 2.6.24-19-generic #tcl_platform(platform) = unix #tcl_platform(tip,268) = 1 #tcl_platform(tip,280) = 1 #tcl_platform(user) = #tcl_platform(wordSize) = 4 # # The following example creates a machineparameters object, # computes the properties and displays it. # # set pp [machineparameters create %AUTO%] # $pp compute # $pp print # $pp destroy # # This prints out : # # Machine parameters # Epsilon : 1.11022302463e-16 # Beta : 2 # Rounding : proper # Mantissa : 53 # Maximum exponent : 1024 # Minimum exponent : -1021 # Overflow threshold : 8.98846567431e+307 # Underflow threshold : 2.22507385851e-308 # # That compares well with the results produced by Lapack 3.1.1 : # # Epsilon = 1.11022302462515654E-016 # Safe minimum = 2.22507385850720138E-308 # Base = 2.0000000000000000 # Precision = 2.22044604925031308E-016 # Number of digits in mantissa = 53.000000000000000 # Rounding mode = 1.00000000000000000 # Minimum exponent = -1021.0000000000000 # Underflow threshold = 2.22507385850720138E-308 # Largest exponent = 1024.0000000000000 # Overflow threshold = 1.79769313486231571E+308 # Reciprocal of safe minimum = 4.49423283715578977E+307 # # Copyright 2008 Michael Baudin # package require snit package provide math::machineparameters 0.1 snit::type machineparameters { # Epsilon is the smallest value so that 1+epsilon>1 is false variable epsilon 0 # basis is the basis of the floating-point representation. # basis is usually 2, i.e. binary representation (for example IEEE 754 machines), # but some machines (like HP calculators for example) uses 10, or 16, etc... variable basis 0 # The rounding mode used on the machine. # The rounding occurs when more than t digits would be required to # represent the number. # Two modes can be determined with the current system : # "chop" means than only t digits are kept, no matter the value of the number # "proper" means that another rounding mode is used, be it "round to nearest", # "round up", "round down". variable rounding "" # the size of the mantissa variable mantissa 0 # The first non-integer is A = 2^m with m is the # smallest positive integer so that fl(A+1)=A variable firstnoninteger 0 # Maximum number of iterations in loops option -maxiteration 10000 # Set to 1 to enable verbose logging option -verbose -default 0 # The largest positive exponent before overflow occurs variable exponentmax 0 # The largest negative exponent before (gradual) underflow occurs variable exponentmin 0 # Largest positive value before overflow occurs variable vmax # Largest negative value before (gradual) underflow occurs variable vmin # # compute -- # Computes the machine parameters. # method compute {} { $self log "compute" $self computeepsilon $self computefirstnoninteger $self computebasis $self computerounding $self computemantissa $self computeemax $self computeemin return "" } # # computeepsilon -- # Find epsilon the minimum value for which 1.0 + epsilon > 1.0 # method computeepsilon {} { $self log "computeepsilon" set factor 2. set epsilon 0.5 for {set i 0} {$i<$options(-maxiteration)} {incr i} { $self log "$i/$options(-maxiteration) : $epsilon" set epsilon [expr {$epsilon / $factor}] set inequality [expr {1.0+$epsilon>1.0}] if {$inequality==0} then { break } } $self log "epsilon : $epsilon (after $i loops)" return "" } # # computefirstnoninteger -- # Compute the first positive non-integer real. # It is the smallest a such that (a+1)-a is different from 1 # method computefirstnoninteger {} { $self log "computefirstnoninteger" set firstnoninteger 2. for {set i 0} {$i < $options(-maxiteration)} {incr i} { $self log "$i/$options(-maxiteration) : $firstnoninteger" set firstnoninteger [expr {2.*$firstnoninteger}] set one [expr {($firstnoninteger+1.)-$firstnoninteger}] if {$one!=1.} then { break } } $self log "Found firstnoninteger : $firstnoninteger" return "" } # # computebasis -- # Compute the basis (basis) # method computebasis {} { $self log "computebasis" # # Compute b where b is the smallest real so that fl(a+b)> a, # where a is the first non integer. # Note : # With floating point numbers, a+1==a ! # b is denoted by "B" in Malcolm's algorithm # set b 1 for {set i 0} {$i < $options(-maxiteration)} {incr i} { $self log "$i/$options(-maxiteration) : $b" set basis [expr {int(($firstnoninteger+$b)-$firstnoninteger)}] if {$basis!=0.} then { break } incr b } $self log "Found basis : $basis" return "" } # # computerounding -- # Compute the rounding mode. # Note: # This corresponds to DLAMCH implementation (DLAMC1 exactly). # method computerounding {} { $self log "computerounding" # Now determine whether rounding or chopping occurs, by adding a # bit less than beta/2 and a bit more than beta/2 to a (=firstnoninteger). set F [expr {$basis/2.0 - $basis/100.0}] set C [expr {$F + $firstnoninteger}] if {$C==$firstnoninteger} then { set rounding "proper" } else { set rounding "chop" } set F [expr {$basis/2.0 + $basis/100.0}] set C [expr {$F + $firstnoninteger}] if {$rounding=="proper" && $C==$firstnoninteger} then { set rounding "chop" } $self log "Found rounding : $rounding" return "" } # # computemantissa -- # Compute the mantissa size # method computemantissa {} { $self log "computemantissa" set a 1. set mantissa 0 for {set i 0} {$i < $options(-maxiteration)} {incr i} { incr mantissa $self log "$i/$options(-maxiteration) : $mantissa" set a [expr {$a * double($basis)}] set one [expr {($a+1)-$a}] if {$one!=1.} then { break } } $self log "Found mantissa : $mantissa" return "" } # # computeemax -- # Compute the maximum exponent before overflow # method computeemax {} { $self log "computeemax" set vmax 1. set exponentmax 1 for {set i 0} {$i < $options(-maxiteration)} {incr i} { $self log "Iteration #$i , exponentmax = $exponentmax, vmax = $vmax" incr exponentmax # Condition #1 : no exception is generated set errflag [catch { set new [expr {$vmax * $basis}] }] if {$errflag!=0} then { break } # Condition #2 : one can recover the original number if {$new / $basis != $vmax} then { break } set vmax $new } incr exponentmax -1 $self log "Exponent maximum : $exponentmax" $self log "Value maximum : $vmax" return "" } # # computeemin -- # Compute the minimum exponent before underflow # method computeemin {} { $self log "computeemin" set vmin 1. set exponentmin 1 for {set i 0} {$i < $options(-maxiteration)} {incr i} { $self log "Iteration #$i , exponentmin = $exponentmin, vmin = $vmin" incr exponentmin -1 # Condition #1 : no exception is generated set errflag [catch { set new [expr {$vmin / $basis}] }] if {$errflag!=0} then { break } # Condition #2 : one can recover the original number if {$new * $basis != $vmin} then { break } set vmin $new } incr exponentmin +1 # See in DMALCH.f, DLAMC2 relative to IEEE machines. # TODO : what happens on non-IEEE machine ? set exponentmin [expr {$exponentmin - 1 + $mantissa}] set vmin [expr {$vmin * pow($basis,$mantissa-1)}] $self log "Exponent minimum : $exponentmin" $self log "Value minimum : $vmin" return "" } # # log -- # Puts the given message on standard output. # method log {msg} { if {$options(-verbose)==1} then { puts "(mp) $msg" } return "" } # # get -- # Return value for key # method get {key} { $self log "get $key" switch -- $key { -epsilon { set result $epsilon } -rounding { set result $rounding } -basis { set result $basis } -mantissa { set result $mantissa } -exponentmax { set result $exponentmax } -exponentmin { set result $exponentmin } -vmax { set result $vmax } -vmin { set result $vmin } default { error "Unknown key $key" } } return $result } # # print -- # Print machine parameters on standard output # method print {} { set str [$self tostring] puts "$str" return "" } # # tostring -- # Return a report for machine parameters # method tostring {} { set str "" append str "Machine parameters\n" append str "Epsilon : $epsilon\n" append str "Basis : $basis\n" append str "Rounding : $rounding\n" append str "Mantissa : $mantissa\n" append str "Maximum exponent before overflow : $exponentmax\n" append str "Minimum exponent before underflow : $exponentmin\n" append str "Overflow threshold : $vmax\n" append str "Underflow threshold : $vmin\n" return $str } } tcllib-1.15/modules/math/romannumerals.tcl0000755000175000017500000001162312077663116020236 0ustar sergeisergei#========================================================================== # Roman Numeral Utility Functions #========================================================================== # Description # # A set of utility routines for handling and manipulating # roman numerals. #------------------------------------------------------------------------- # Copyright/License # # This code was originally harvested from the Tcler's # wiki at http://wiki.tcl.tk/1823 and as such is free # for any use for any purpose. #------------------------------------------------------------------------- # Modification history # # 27 Sep 2005 Kenneth Green # Original version derived from wiki code #------------------------------------------------------------------------- package provide math::roman 1.0 #========================================================================== # Namespace #========================================================================== namespace eval ::math::roman { namespace export tointeger toroman # We dont export 'sort' or 'expr' to prevent collision # with existing commands. These functions are less likely to be # commonly used and have to be accessed as fully-scoped names. # romanvalues - array that maps roman letters to integer values. # variable romanvalues # i2r - list of integer-roman tuples variable i2r {1000 M 900 CM 500 D 400 CD 100 C 90 XC 50 L 40 XL 10 X 9 IX 5 V 4 IV 1 I} # sortkey - list of patterns to supporting sorting of roman numerals variable sortkey {IX VIIII L Y XC YXXXX C Z D {\^} ZM {\^ZZZZ} M _} variable rsortkey {_ M {\^ZZZZ} ZM {\^} D Z C YXXXX XC Y L VIIII IX} # Initialise array variables array set romanvalues {M 1000 D 500 C 100 L 50 X 10 V 5 I 1} } #========================================================================== # Public Functions #========================================================================== #---------------------------------------------------------- # Roman numerals sorted # proc ::math::roman::sort list { variable sortkey variable rsortkey foreach {from to} $sortkey { regsub -all $from $list $to list } set list [lsort $list] foreach {from to} $rsortkey { regsub -all $from $list $to list } return $list } #---------------------------------------------------------- # Roman numerals from integer # proc ::math::roman::toroman {i} { variable i2r set res "" foreach {value roman} $i2r { while {$i>=$value} { append res $roman incr i -$value } } return $res } #---------------------------------------------------------- # Roman numerals parsed into integer: # proc ::math::roman::tointeger {s} { variable romanvalues set last 99999 set res 0 foreach i [split [string toupper $s] ""] { if { [catch {set val $romanvalues($i)}] } { return -code error "roman::tointeger - un-Roman digit $i in $s" } incr res $val if { $val > $last } { incr res [::expr -2*$last] } set last $val } return $res } #---------------------------------------------------------- # Roman numeral arithmetic # proc ::math::roman::expr args { if { [string first \$ $args] >= 0 } { set args [uplevel subst $args] } regsub -all {[^IVXLCDM]} $args { & } args foreach i $args { catch {set i [tointeger $i]} lappend res $i } return [toroman [::expr $res]] } #========================================================== # Developer test code # if { 0 } { puts "Basic int-to-roman-to-int conversion test" for { set i 0 } {$i < 50} {incr i} { set r [::math::roman::toroman $i] set j [::math::roman::tointeger $r] puts [format "%5d %-15s %s" $i $r $j] if { $i != $j } { error "Invalid conversion: $i -> $r -> $j" } } puts "" puts "roman arithmetic test" set x 23 set xr [::math::roman::toroman $x] set y 77 set yr [::math::roman::toroman $y] set xr+yr [::math::roman::expr $xr + $yr] set yr-xr [::math::roman::expr $yr - $xr] set xr*yr [::math::roman::expr $xr * $yr] set yr/xr [::math::roman::expr $yr / $xr] set yr/xr2 [::math::roman::expr {$yr / $xr}] puts "$x + $y\t\t= [expr $x + $y]" puts "$x * $y\t\t= [expr $x * $y]" puts "$y - $x\t\t= [expr $y - $x]" puts "$y / $x\t\t= [expr $y / $x]" puts "$xr + $yr\t= ${xr+yr} = [::math::roman::tointeger ${xr+yr}]" puts "$xr * $yr\t= ${xr*yr} = [::math::roman::tointeger ${xr*yr}]" puts "$yr - $xr\t= ${yr-xr} = [::math::roman::tointeger ${yr-xr}]" puts "$yr / $xr\t= ${yr/xr} = [::math::roman::tointeger ${yr/xr}]" puts "$yr / $xr\t= ${yr/xr2} = [::math::roman::tointeger ${yr/xr2}]" puts "" puts "roman sorting test" set l {X III IV I V} puts "IN : $l" puts "OUT: [::math::roman::sort $l]" } tcllib-1.15/modules/math/optimize.man0000755000175000017500000003314512077663116017207 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin math::optimize n 1.0] [copyright {2004 Arjen Markus }] [copyright {2004,2005 Kevn B. Kenny }] [moddesc {Tcl Math Library}] [titledesc {Optimisation routines}] [category Mathematics] [require Tcl 8.4] [require math::optimize [opt 1.0]] [description] [para] This package implements several optimisation algorithms: [list_begin itemized] [item] Minimize or maximize a function over a given interval [item] Solve a linear program (maximize a linear function subject to linear constraints) [item] Minimize a function of several variables given an initial guess for the location of the minimum. [list_end] [para] The package is fully implemented in Tcl. No particular attention has been paid to the accuracy of the calculations. Instead, the algorithms have been used in a straightforward manner. [para] This document describes the procedures and explains their usage. [section "PROCEDURES"] [para] This package defines the following public procedures: [list_begin definitions] [call [cmd ::math::optimize::minimum] [arg begin] [arg end] [arg func] [arg maxerr]] Minimize the given (continuous) function by examining the values in the given interval. The procedure determines the values at both ends and in the centre of the interval and then constructs a new interval of 1/2 length that includes the minimum. No guarantee is made that the [emph global] minimum is found. [para] The procedure returns the "x" value for which the function is minimal. [para] [emph {This procedure has been deprecated - use min_bound_1d instead}] [para] [arg begin] - Start of the interval [para] [arg end] - End of the interval [para] [arg func] - Name of the function to be minimized (a procedure taking one argument). [para] [arg maxerr] - Maximum relative error (defaults to 1.0e-4) [call [cmd ::math::optimize::maximum] [arg begin] [arg end] [arg func] [arg maxerr]] Maximize the given (continuous) function by examining the values in the given interval. The procedure determines the values at both ends and in the centre of the interval and then constructs a new interval of 1/2 length that includes the maximum. No guarantee is made that the [emph global] maximum is found. [para] The procedure returns the "x" value for which the function is maximal. [para] [emph {This procedure has been deprecated - use max_bound_1d instead}] [para] [arg begin] - Start of the interval [para] [arg end] - End of the interval [para] [arg func] - Name of the function to be maximized (a procedure taking one argument). [para] [arg maxerr] - Maximum relative error (defaults to 1.0e-4) [call [cmd ::math::optimize::min_bound_1d] [arg func] [arg begin] [arg end] [opt "[option -relerror] [arg reltol]"] [opt "[option -abserror] [arg abstol]"] [opt "[option -maxiter] [arg maxiter]"] [opt "[option -trace] [arg traceflag]"]] Miminizes a function of one variable in the given interval. The procedure uses Brent's method of parabolic interpolation, protected by golden-section subdivisions if the interpolation is not converging. No guarantee is made that a [emph global] minimum is found. The function to evaluate, [arg func], must be a single Tcl command; it will be evaluated with an abscissa appended as the last argument. [para] [arg x1] and [arg x2] are the two bounds of the interval in which the minimum is to be found. They need not be in increasing order. [para] [arg reltol], if specified, is the desired upper bound on the relative error of the result; default is 1.0e-7. The given value should never be smaller than the square root of the machine's floating point precision, or else convergence is not guaranteed. [arg abstol], if specified, is the desired upper bound on the absolute error of the result; default is 1.0e-10. Caution must be used with small values of [arg abstol] to avoid overflow/underflow conditions; if the minimum is expected to lie about a small but non-zero abscissa, you consider either shifting the function or changing its length scale. [para] [arg maxiter] may be used to constrain the number of function evaluations to be performed; default is 100. If the command evaluates the function more than [arg maxiter] times, it returns an error to the caller. [para] [arg traceFlag] is a Boolean value. If true, it causes the command to print a message on the standard output giving the abscissa and ordinate at each function evaluation, together with an indication of what type of interpolation was chosen. Default is 0 (no trace). [call [cmd ::math::optimize::min_unbound_1d] [arg func] [arg begin] [arg end] [opt "[option -relerror] [arg reltol]"] [opt "[option -abserror] [arg abstol]"] [opt "[option -maxiter] [arg maxiter]"] [opt "[option -trace] [arg traceflag]"]] Miminizes a function of one variable over the entire real number line. The procedure uses parabolic extrapolation combined with golden-section dilatation to search for a region where a minimum exists, followed by Brent's method of parabolic interpolation, protected by golden-section subdivisions if the interpolation is not converging. No guarantee is made that a [emph global] minimum is found. The function to evaluate, [arg func], must be a single Tcl command; it will be evaluated with an abscissa appended as the last argument. [para] [arg x1] and [arg x2] are two initial guesses at where the minimum may lie. [arg x1] is the starting point for the minimization, and the difference between [arg x2] and [arg x1] is used as a hint at the characteristic length scale of the problem. [para] [arg reltol], if specified, is the desired upper bound on the relative error of the result; default is 1.0e-7. The given value should never be smaller than the square root of the machine's floating point precision, or else convergence is not guaranteed. [arg abstol], if specified, is the desired upper bound on the absolute error of the result; default is 1.0e-10. Caution must be used with small values of [arg abstol] to avoid overflow/underflow conditions; if the minimum is expected to lie about a small but non-zero abscissa, you consider either shifting the function or changing its length scale. [para] [arg maxiter] may be used to constrain the number of function evaluations to be performed; default is 100. If the command evaluates the function more than [arg maxiter] times, it returns an error to the caller. [para] [arg traceFlag] is a Boolean value. If true, it causes the command to print a message on the standard output giving the abscissa and ordinate at each function evaluation, together with an indication of what type of interpolation was chosen. Default is 0 (no trace). [call [cmd ::math::optimize::solveLinearProgram] [arg objective] [arg constraints]] Solve a [emph "linear program"] in standard form using a straightforward implementation of the Simplex algorithm. (In the explanation below: The linear program has N constraints and M variables). [para] The procedure returns a list of M values, the values for which the objective function is maximal or a single keyword if the linear program is not feasible or unbounded (either "unfeasible" or "unbounded") [para] [arg objective] - The M coefficients of the objective function [para] [arg constraints] - Matrix of coefficients plus maximum values that implement the linear constraints. It is expected to be a list of N lists of M+1 numbers each, M coefficients and the maximum value. [call [cmd ::math::optimize::linearProgramMaximum] [arg objective] [arg result]] Convenience function to return the maximum for the solution found by the solveLinearProgram procedure. [para] [arg objective] - The M coefficients of the objective function [para] [arg result] - The result as returned by solveLinearProgram [call [cmd ::math::optimize::nelderMead] [arg objective] [arg xVector] [opt "[option -scale] [arg xScaleVector]"] [opt "[option -ftol] [arg epsilon]"] [opt "[option -maxiter] [arg count]"] [opt "[opt -trace] [arg flag]"]] Minimizes, in unconstrained fashion, a function of several variable over all of space. The function to evaluate, [arg objective], must be a single Tcl command. To it will be appended as many elements as appear in the initial guess at the location of the minimum, passed in as a Tcl list, [arg xVector]. [para] [arg xScaleVector] is an initial guess at the problem scale; the first function evaluations will be made by varying the co-ordinates in [arg xVector] by the amounts in [arg xScaleVector]. If [arg xScaleVector] is not supplied, the co-ordinates will be varied by a factor of 1.0001 (if the co-ordinate is non-zero) or by a constant 0.0001 (if the co-ordinate is zero). [para] [arg epsilon] is the desired relative error in the value of the function evaluated at the minimum. The default is 1.0e-7, which usually gives three significant digits of accuracy in the values of the x's. [para]pp [arg count] is a limit on the number of trips through the main loop of the optimizer. The number of function evaluations may be several times this number. If the optimizer fails to find a minimum to within [arg ftol] in [arg maxiter] iterations, it returns its current best guess and an error status. Default is to allow 500 iterations. [para] [arg flag] is a flag that, if true, causes a line to be written to the standard output for each evaluation of the objective function, giving the arguments presented to the function and the value returned. Default is false. [para] The [cmd nelderMead] procedure returns a list of alternating keywords and values suitable for use with [cmd {array set}]. The meaning of the keywords is: [para] [arg x] is the approximate location of the minimum. [para] [arg y] is the value of the function at [arg x]. [para] [arg yvec] is a vector of the best N+1 function values achieved, where N is the dimension of [arg x] [para] [arg vertices] is a list of vectors giving the function arguments corresponding to the values in [arg yvec]. [para] [arg nIter] is the number of iterations required to achieve convergence or fail. [para] [arg status] is 'ok' if the operation succeeded, or 'too-many-iterations' if the maximum iteration count was exceeded. [para] [cmd nelderMead] minimizes the given function using the downhill simplex method of Nelder and Mead. This method is quite slow - much faster methods for minimization are known - but has the advantage of being extremely robust in the face of problems where the minimum lies in a valley of complex topology. [para] [cmd nelderMead] can occasionally find itself "stuck" at a point where it can make no further progress; it is recommended that the caller run it at least a second time, passing as the initial guess the result found by the previous call. The second run is usually very fast. [para] [cmd nelderMead] can be used in some cases for constrained optimization. To do this, add a large value to the objective function if the parameters are outside the feasible region. To work effectively in this mode, [cmd nelderMead] requires that the initial guess be feasible and usually requires that the feasible region be convex. [list_end] [section NOTES] [para] Several of the above procedures take the [emph names] of procedures as arguments. To avoid problems with the [emph visibility] of these procedures, the fully-qualified name of these procedures is determined inside the optimize routines. For the user this has only one consequence: the named procedure must be visible in the calling procedure. For instance: [example { namespace eval ::mySpace { namespace export calcfunc proc calcfunc { x } { return $x } } # # Use a fully-qualified name # namespace eval ::myCalc { puts [min_bound_1d ::myCalc::calcfunc $begin $end] } # # Import the name # namespace eval ::myCalc { namespace import ::mySpace::calcfunc puts [min_bound_1d calcfunc $begin $end] } }] The simple procedures [emph minimum] and [emph maximum] have been deprecated: the alternatives are much more flexible, robust and require less function evaluations. [section EXAMPLES] [para] Let us take a few simple examples: [para] Determine the maximum of f(x) = x^3 exp(-3x), on the interval (0,10): [example { proc efunc { x } { expr {$x*$x*$x * exp(-3.0*$x)} } puts "Maximum at: [::math::optimize::max_bound_1d efunc 0.0 10.0]" }] [para] The maximum allowed error determines the number of steps taken (with each step in the iteration the interval is reduced with a factor 1/2). Hence, a maximum error of 0.0001 is achieved in approximately 14 steps. [para] An example of a [emph "linear program"] is: [para] Optimise the expression 3x+2y, where: [example { x >= 0 and y >= 0 (implicit constraints, part of the definition of linear programs) x + y <= 1 (constraints specific to the problem) 2x + 5y <= 10 }] [para] This problem can be solved as follows: [example { set solution [::math::optimize::solveLinearProgram \ { 3.0 2.0 } \ { { 1.0 1.0 1.0 } { 2.0 5.0 10.0 } } ] }] [para] Note, that a constraint like: [example { x + y >= 1 }] can be turned into standard form using: [example { -x -y <= -1 }] [para] The theory of linear programming is the subject of many a text book and the Simplex algorithm that is implemented here is the best-known method to solve this type of problems, but it is not the only one. [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph {math :: optimize}] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords math optimization minimum maximum "linear program"] [manpage_end] tcllib-1.15/modules/math/calculus.CHANGES0000755000175000017500000000103112077663116017444 0ustar sergeisergeiPackage: Calculus ----------------- This file contains information about the changes that have been made: Version 0.1: november 2001 Initial version, no differential equations yet Version 0.2: november 2001 Extended with Euler and Heun methods, 2D and 3D simple integration Version 0.3: march 2002 Implemented Runge-Kutta, converted documentation to doctools' man format Version 0.4: march 2002 Implemented Newton-Raphson method for finding roots of equations Version 0.5: may 2002 Fixed problem with namespaces tcllib-1.15/modules/math/constants.man0000755000175000017500000000613012077663116017355 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin math::constants n 1.0.1] [copyright {2004 Arjen Markus }] [moddesc {Tcl Math Library}] [titledesc {Mathematical and numerical constants}] [category Mathematics] [require Tcl [opt 8.3]] [require math::constants [opt 1.0.1]] [description] [para] This package defines some common mathematical and numerical constants. By using the package you get consistent values for numbers like pi and ln(10). [para] It defines two commands: [list_begin itemized] [item] One for importing the constants [item] One for reporting which constants are defined and what values they actually have. [list_end] [para] The motivation for this package is that quite often, with (mathematical) computations, you need a good approximation to, say, the ratio of degrees to radians. You can, of course, define this like: [example { variable radtodeg [expr {180.0/(4.0*atan(1.0))}] }] and use the variable radtodeg whenever you need the conversion. [para] This has two drawbacks: [list_begin itemized] [item] You need to remember the proper formula or value and that is error-prone. [item] Especially with the use of mathematical functions like [emph atan] you assume that they have been accurately implemented. This is seldom or never the case and for each platform you can get subtle differences. [list_end] Here is the way you can do it with the [emph math::constants] package: [example { package require math::constants ::math::constants::constants radtodeg degtorad }] which creates two variables, radtodeg and (its reciprocal) degtorad in the calling namespace. [para] Constants that have been defined (their values are mostly taken from mathematical tables with more precision than usually can be handled) include: [list_begin itemized] [item] basic constants like pi, e, gamma (Euler's constant) [item] derived values like ln(10) and sqrt(2) [item] purely numerical values such as 1/3 that are included for convenience and for the fact that certain seemingly trivial computations like: [example { set value [expr {3.0*$onethird}] }] give [emph exactly] the value you expect (if IEEE arithmetic is available). [list_end] [section "PROCEDURES"] The package defines the following public procedures: [list_begin definitions] [call [cmd ::math::constants::constants] [arg args]] Import the constants whose names are given as arguments [para] [call [cmd ::math::constants::print-constants] [arg args]] Print the constants whose names are given as arguments on the screen (name, value and description) or, if no arguments are given, print all defined constants. This is mainly a convenience procedure. [list_end] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph {math :: constants}] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords math constants pi e radians degrees] [manpage_end] tcllib-1.15/modules/math/special.test0000755000175000017500000000634112077663116017171 0ustar sergeisergei# -*- tcl -*- # Tests for special functions in math library -*- tcl -*- # # This file contains a collection of tests for one or more of the Tcllib # procedures. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # $Id: special.test,v 1.13 2007/08/21 17:33:00 andreas_kupries Exp $ # # Copyright (c) 2004 by Arjen Markus # All rights reserved. # # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.4;# statistics,linalg! testsNeedTcltest 2.1 support { useLocal math.tcl math useLocal constants.tcl math::constants useLocal linalg.tcl math::linearalgebra useLocal statistics.tcl math::statistics useLocal polynomials.tcl math::polynomials } testing { useLocal special.tcl math::special } # ------------------------------------------------------------------------- # # Expect an accuracy of at least four decimals # proc matchNumbers {expected actual} { set match 1 foreach a $actual e $expected { if {abs($a-$e) > 1.0e-4} { set match 0 break } } return $match } # # Expect an accuracy of some three decimals (Fresnel) # proc matchFresnel {expected actual} { set match 1 foreach a $actual e $expected { if {abs($a-$e) > 2.0e-3} { set match 0 break } } return $match } customMatch numbers matchNumbers customMatch numbers-fresnel matchFresnel test "Erf-1.0" "Values of the error function" \ -match numbers -body { set result {} foreach x {0.0 0.1 0.2 0.5 1.0 2.0 -0.1 -0.2 -0.5 -1.0 -2.0} { lappend result [::math::special::erf $x] } set result } -result {0.0 0.1124629 0.2227026 0.5204999 0.8427008 0.9953227 -0.1124629 -0.2227026 -0.5204999 -0.8427008 -0.9953227} proc make_erfc {erf_values} { set result {} foreach v $erf_values { lappend result [expr {1.0-$v}] } return $result } test "Erf-1.1" "Values of the complementary error function" \ -match numbers -body { set result {} foreach x {0.0 0.1 0.2 0.5 1.0 2.0 -0.1 -0.2 -0.5 -1.0 -2.0} { lappend result [::math::special::erfc $x] } set result } -result [make_erfc {0.0 0.1124629 0.2227026 0.5204999 0.8427008 0.9953227 -0.1124629 -0.2227026 -0.5204999 -0.8427008 -0.9953227}] test "Fresnel-1.0" "Values of the Fresnel C intergral" \ -match numbers-fresnel -body { set result {} foreach x {0.0 0.1 0.2 0.5 1.0 1.5 2.0 3.0 4.0 5.0} { lappend result [::math::special::fresnel_C $x] } set result } -result {0.0 0.09999 0.19992 0.49234 0.77989 0.44526 0.48825 0.60572 0.49842 0.56363} test "Fresnel-1.1" "Values of the Fresnel S intergral" \ -match numbers-fresnel -body { set result {} foreach x {0.0 0.1 0.2 0.5 1.0 1.5 2.0 3.0 4.0 5.0} { lappend result [::math::special::fresnel_S $x] } set result } -result {0.0 0.00052 0.00419 0.06473 0.43826 0.69750 0.34342 0.49631 0.42052 0.49919} # No tests for sinc yet # End of test cases testsuiteCleanup tcllib-1.15/modules/math/numtheory.test0000644000175000017500000001740512077663116017603 0ustar sergeisergei## ## This is the file `numtheory.test', ## generated with the SAK utility ## (sak docstrip/regen). ## ## The original source files were: ## ## numtheory.dtx (with options: `test') ## ## In other words: ## ************************************** ## * This Source is not the True Source * ## ************************************** ## the true source is the file from which this one was generated. ## source [file join\ [file dirname [file dirname [file join [pwd] [info script]]]]\ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2 testing {useLocal numtheory.tcl math::numtheory} test prime_trialdivision-1 "Trial division of 1" -body { ::math::numtheory::prime_trialdivision 1 } -returnCodes 2 -result 0 test prime_trialdivision-2 "Trial division of 2" -body { ::math::numtheory::prime_trialdivision 2 } -returnCodes 2 -result 1 test prime_trialdivision-3 "Trial division of 6" -body { ::math::numtheory::prime_trialdivision 6 } -returnCodes 2 -result 0 test prime_trialdivision-4 "Trial division of 7" -body { ::math::numtheory::prime_trialdivision 7 } -returnCodes 2 -result 1 test prime_trialdivision-5 "Trial division of 101" -body { ::math::numtheory::prime_trialdivision 101 } -returnCodes 2 -result 1 test prime_trialdivision-6 "Trial division of 105" -body { ::math::numtheory::prime_trialdivision 105 } -returnCodes 2 -result 0 test prime_trialdivision-7 "Trial division of 121" -body { ::math::numtheory::prime_trialdivision 121 } -returnCodes 0 -result "" test prime_trialdivision-8 "Trial division of 127" -body { ::math::numtheory::prime_trialdivision 127 } -returnCodes 0 -result "" test Miller--Rabin-1.1 "Miller--Rabin 3" -body { list [::math::numtheory::Miller--Rabin 3 1 1 1]\ [::math::numtheory::Miller--Rabin 3 1 1 2] } -result {0 0} test Miller--Rabin-1.2 "Miller--Rabin 11" -body { list [::math::numtheory::Miller--Rabin 11 1 5 1]\ [::math::numtheory::Miller--Rabin 11 1 5 2]\ [::math::numtheory::Miller--Rabin 11 1 5 4] } -result {0 0 0} test Miller--Rabin-1.3 "Miller--Rabin 27" -body { list [::math::numtheory::Miller--Rabin 27 1 13 1]\ [::math::numtheory::Miller--Rabin 27 1 13 2]\ [::math::numtheory::Miller--Rabin 27 1 13 3]\ [::math::numtheory::Miller--Rabin 27 1 13 4]\ [::math::numtheory::Miller--Rabin 27 1 13 8]\ [::math::numtheory::Miller--Rabin 27 1 13 26] } -result {0 1 1 1 1 0} test Miller--Rabin-1.4 "Miller--Rabin 65" -body { list [::math::numtheory::Miller--Rabin 65 6 1 1]\ [::math::numtheory::Miller--Rabin 65 6 1 64]\ [::math::numtheory::Miller--Rabin 65 6 1 14]\ [::math::numtheory::Miller--Rabin 65 6 1 8]\ [::math::numtheory::Miller--Rabin 65 6 1 27]\ [::math::numtheory::Miller--Rabin 65 6 1 2] } -result {0 0 1 0 1 1} test Miller--Rabin-1.5 "Miller--Rabin 17*257" -body { list [::math::numtheory::Miller--Rabin 4369 4 273 1]\ [::math::numtheory::Miller--Rabin 4369 4 273 4368]\ [::math::numtheory::Miller--Rabin 4369 4 273 4113]\ [::math::numtheory::Miller--Rabin 4369 4 273 1815]\ [::math::numtheory::Miller--Rabin 4369 4 273 273]\ [::math::numtheory::Miller--Rabin 4369 4 273 2831]\ [::math::numtheory::Miller--Rabin 4369 4 273 1029]\ [::math::numtheory::Miller--Rabin 4369 4 273 2315]\ [::math::numtheory::Miller--Rabin 4369 4 273 258] } -result {0 0 1 0 1 0 1 0 1} test Miller--Rabin-2.1 "Miller--Rabin 1373653" -body { list\ [::math::numtheory::Miller--Rabin 1373653 2 343413 2]\ [::math::numtheory::Miller--Rabin 1373653 2 343413 3]\ [::math::numtheory::Miller--Rabin 1373653 2 343413 5] } -result {0 0 1} test Miller--Rabin-2.2 "Miller--Rabin 25326001" -body { list\ [::math::numtheory::Miller--Rabin 25326001 4 1582875 2]\ [::math::numtheory::Miller--Rabin 25326001 4 1582875 3]\ [::math::numtheory::Miller--Rabin 25326001 4 1582875 5]\ [::math::numtheory::Miller--Rabin 25326001 4 1582875 7] } -result {0 0 0 1} test Miller--Rabin-2.3 "Miller--Rabin 3215031751" -body { list\ [::math::numtheory::Miller--Rabin 3215031751 1 1607515875 2]\ [::math::numtheory::Miller--Rabin 3215031751 1 1607515875 3]\ [::math::numtheory::Miller--Rabin 3215031751 1 1607515875 5]\ [::math::numtheory::Miller--Rabin 3215031751 1 1607515875 7]\ [::math::numtheory::Miller--Rabin 3215031751 1 1607515875 11] } -result {0 0 0 0 1} test Miller--Rabin-2.4 "Miller--Rabin 118670087467" -body { list\ [::math::numtheory::Miller--Rabin 118670087467 1 59335043733 2]\ [::math::numtheory::Miller--Rabin 118670087467 1 59335043733 3]\ [::math::numtheory::Miller--Rabin 118670087467 1 59335043733 5]\ [::math::numtheory::Miller--Rabin 118670087467 1 59335043733 7]\ [::math::numtheory::Miller--Rabin 118670087467 1 59335043733 11] } -result {0 0 0 0 1} test isprime-1.1 "1 is not prime" -body { ::math::numtheory::isprime 1 } -result 0 test isprime-1.2 "0 is not prime" -body { ::math::numtheory::isprime 0 } -result 0 test isprime-1.3 "-2 is not prime" -body { ::math::numtheory::isprime -2 } -result 0 test isprime-1.4 "2 is prime" -body { ::math::numtheory::isprime 2 } -result 1 test isprime-1.5 "6 is not prime" -body { ::math::numtheory::isprime 6 } -result 0 test isprime-1.6 "7 is prime" -body { ::math::numtheory::isprime 7 } -result 1 test isprime-1.7 "101 is prime" -body { ::math::numtheory::isprime 101 } -result 1 test isprime-1.8 "105 is not prime" -body { ::math::numtheory::isprime 105 } -result 0 test isprime-1.9 "121 is not prime" -body { ::math::numtheory::isprime 121 } -result 0 test isprime-1.10 "127 is prime" -body { ::math::numtheory::isprime 127 } -result 1 test isprime-1.11 "4369 is not prime" -body { ::math::numtheory::isprime 4369 } -result 0 test isprime-1.12 "1373653 is not prime" -body { ::math::numtheory::isprime 1373653 } -result 0 test isprime-1.13 "25326001 is not prime" -body { ::math::numtheory::isprime 25326001 } -result 0 test isprime-1.14 "3215031751 is not prime" -body { ::math::numtheory::isprime 3215031751 } -result 0 test isprime-1.15 "118670087467 may appear prime, but isn't" -body { expr srand(1) list\ [::math::numtheory::isprime 118670087467 -randommr 0]\ [::math::numtheory::isprime 118670087467 -randommr 1] } -result {on 0} test isprime-1.16 "Jaeschke psi_10" -body { expr srand(1) set p 22754930352733 set n [expr {$p * (3*$p-2)}] list\ [::math::numtheory::isprime $p -randommr 25]\ [::math::numtheory::isprime $n -randommr 0]\ [::math::numtheory::isprime $n -randommr 1] } -result {on on 0} test isprime-1.17 "Jaeschke psi_11" -body { expr srand(1) set p 137716125329053 set n [expr {$p * (3*$p-2)}] list\ [::math::numtheory::isprime $p -randommr 25]\ [::math::numtheory::isprime $n -randommr 0]\ [::math::numtheory::isprime $n -randommr 1]\ [::math::numtheory::isprime $n -randommr 2] } -result {on on on 0} test isprime-1.18 "OAKLEY group 1 prime" -body { set digits [join { FFFFFFFF FFFFFFFF C90FDAA2 2168C234 C4C6628B 80DC1CD1 29024E08 8A67CC74 020BBEA6 3B139B22 514A0879 8E3404DD EF9519B3 CD3A431B 302B0A6D F25F1437 4FE1356D 6D51C245 E485B576 625E7EC6 F44C42E9 A63A3620 FFFFFFFF FFFFFFFF } ""] expr srand(1) list\ [::math::numtheory::isprime 0x$digits]\ [::math::numtheory::isprime 0x[string reverse $digits]] } -result {on 0} test isprime-2.0 "PRNG tweak" -setup { namespace eval ::math::numtheory { rename Miller--Rabin _orig_Miller--Rabin proc Miller--Rabin {n s d a} { expr {$a>7 && $a%6!=1 && $a%6!=5} } } } -body { ::math::numtheory::isprime 118670087467 -randommr 500 } -result on -cleanup { namespace eval ::math::numtheory { rename Miller--Rabin "" rename _orig_Miller--Rabin Miller--Rabin } } testsuiteCleanup ## ## ## End of file `numtheory.test'.tcllib-1.15/modules/math/constants.test0000755000175000017500000000271612077663116017567 0ustar sergeisergei# -*- tcl -*- # constants.test -- # Test cases for the ::math::constants package # # This file contains a collection of tests for one or more of the Tcllib # procedures. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 2004 by Arjen Markus. All rights reserved. # # RCS: @(#) $Id: constants.test,v 1.10 2008/03/23 04:39:48 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.2 testsNeedTcltest 2.1 support { useLocal math.tcl math } testing { useLocal constants.tcl math::constants } # ------------------------------------------------------------------------- # # Test: do we get the constants into our namespace? # test "Constants-1.0" "Get constants into our namespace" -body { ::math::constants::constants pi e expr {[info exists pi] && [info exists e]} } -result 1 test "Constants-1.1" "Get constants with the right values" -body { # # Only needed once! # #::math::constants::constants pi e set result1 [expr {abs($pi-4.0*atan(1.0))<1.0e-10?1:0}] set result2 [expr {abs($e-exp(1.0))<1.0e-10?1:0}] expr {$result1+$result2} # Note: this should enough accuracy! } -result 2 # # No tests for print-constants defined ... # # End of test cases testsuiteCleanup tcllib-1.15/modules/math/wilcoxon.tcl0000755000175000017500000001352312077663116017216 0ustar sergeisergei# statistics_new.tcl -- # Implementation of the Wilcoxon test: test if the medians # of two samples are the same # package require math::statistics # test-Wilcoxon # Compute the statistic that indicates if the medians of two # samples are the same # # Arguments: # sample_a List of values in the first sample # sample_b List of values in the second sample # # Result: # Statistic for the test (if both samples have 10 or more # values, the statistic behaves as a standard normal variable) # proc ::math::statistics::test-Wilcoxon {sample_a sample_b} { # # Construct the sorted list for both # set sorted {} set count_a 0 set count_b 0 foreach sample {sample_a sample_b} code {0 1} count {count_a count_b} { foreach v [set $sample] { if { $v ne {} } { incr $count lappend sorted [list $v $code] } } } set raw_sorted [lsort -index 0 -real $sorted] # # Resolve the ties (TODO) # - Make sure the previous value is never equal to the first # - Take care of the last part of the sorted samples # set previous [expr {0.5*[lindex $raw_sorted 0 0] - 1.0}] set sorted $raw_sorted set rank 0 set sum_ranks 0 set count 0 set first 0 set index 0 foreach v [concat $raw_sorted {{} -1}] { set sum_ranks [expr {$sum_ranks + $rank}] incr count set current [lindex $v 0] if { $current != $previous } { set new_rank [expr {$sum_ranks / $count}] if { $index > [llength $raw_sorted] } { set index [llength $raw_sorted] } for {set elem $first} {$elem < $index} {incr elem} { lset sorted $elem 0 $new_rank } set previous $current set first $index set count 0 set sum_ranks 0 } incr index incr rank } # # Sum the ranks for the first sample and determine # the statistic # if { $count_a < 2 || $count_b < 2 } { return -code error \ -errorcode DATA -errorinfo {Too few data in one or both samples} } set sum 0 foreach v $sorted { if { [lindex $v 1] == 0 } { set rank [lindex $v 0] set sum [expr {$sum + $rank}] } } set expected [expr {$count_a * ($count_a + $count_b + 1)/2.0}] set stdev [expr {sqrt($count_b * $expected/6.0)}] set statistic [expr {($sum-$expected)/$stdev}] return $statistic } # SpearmanRankData -- # Auxiliary procedure to rank the data # # Arguments: # sample Series of data to be ranked # # Returns: # Ranks of the data # proc ::math::statistics::SpearmanRankData {sample} { set counted_sample {} set count 0 foreach v $sample { if { $v ne {} } { incr count lappend counted_sample [list $v 0 $count] } } set raw_sorted [lsort -index 0 -real $counted_sample] # # Resolve the ties (TODO) # - Make sure the previous value is never equal to the first # - Take care of the last part of the sorted samples # set previous [expr {0.5*[lindex $raw_sorted 0 0] - 1.0}] set sorted $raw_sorted set rank 0 set sum_ranks 0 set count 0 set first 0 set index 0 foreach v [concat $raw_sorted {{} -1}] { set sum_ranks [expr {$sum_ranks + $rank}] incr count set current [lindex $v 0] if { $current != $previous } { set new_rank [expr {$sum_ranks / $count}] if { $index > [llength $raw_sorted] } { set index [llength $raw_sorted] } for {set elem $first} {$elem < $index} {incr elem} { lset sorted $elem 1 $new_rank } set previous $current set first $index set count 0 set sum_ranks 0 } incr index incr rank } # # Return the ranks of the data in the original order # set ranks {} foreach values [lsort -index 2 -integer $sorted] { lappend ranks [lindex $values 1] } return $ranks } # spearman-rank-extended -- # Compute the Spearman's rank correlation coefficient and # associated parameters # # Arguments: # sample_a List of values in the first sample # sample_b List of values in the second sample # # Result: # List of: # - Rank correlation coefficient # - Number of data # - z-score to test the null hyothesis # proc ::math::statistics::spearman-rank-extended {sample_a sample_b} { # # Filter out missing data # if { [llength $sample_a] != [llength $sample_b] } { return -code error \ -errorcode DATA -errorinfo {The two samples should have the same number of data} } set new_sample_a {} set new_sample_b {} foreach a $sample_a b $sample_b { if { $a != {} && $b != {} } { lappend new_sample_a $a lappend new_sample_b $b } } # # Construct the ranks # set rank_a [SpearmanRankData $new_sample_a] set rank_b [SpearmanRankData $new_sample_b] set rcorr [corr $rank_a $rank_b] set number [llength $new_sample_a] set zscore [expr {sqrt(($number-3)/1.06) * 0.5 * log((1.0+$rcorr)/(1.0-$rcorr))}] return [list $rcorr $number $zscore] } # spearman-rank -- # Compute the Spearman's rank correlation coefficient # # Arguments: # sample_a List of values in the first sample # sample_b List of values in the second sample # # Result: # Rank correlation coefficient # proc ::math::statistics::spearman-rank {sample_a sample_b} { return [lindex [spearman-rank-extended $sample_a $sample_b] 0] } tcllib-1.15/modules/math/elliptic.test0000755000175000017500000000431212077663116017352 0ustar sergeisergei# -*- tcl -*- # eliptic.test -- # Test cases for the ::math::special package (Elliptic integrals) # # This file contains a collection of tests for one or more of the Tcllib # procedures. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 2004 by Arjen Markus. All rights reserved. # # RCS: @(#) $Id: elliptic.test,v 1.12 2007/08/21 17:33:00 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.4;# statistics,linalg! testsNeedTcltest 2.1 support { useLocal math.tcl math useLocal constants.tcl math::constants useLocal linalg.tcl math::linearalgebra ;# for statistics useLocal statistics.tcl math::statistics useLocal polynomials.tcl math::polynomials } testing { useLocal special.tcl math::special } # ------------------------------------------------------------------------- # As the values were given with four digits, an absolute # error is most appropriate proc matchNumbers {expected actual} { set match 1 foreach a $actual e $expected { #puts "abs($a-$e) = [expr {abs($a-$e)}]" if {abs($a-$e) > 0.1e-5} { set match 0 break } } return $match } ::tcltest::customMatch numbers matchNumbers # ------------------------------------------------------------------------- test "Elliptic-1.0" "Complete elliptic integral of the first kind" \ -match numbers -body { set result {} foreach k2 {0.0 0.1 0.2 0.4 0.5 0.7 0.8 0.95} { set k [expr {sqrt($k2)}] lappend result [::math::special::elliptic_K $k] } set result } -result {1.570796 1.612441 1.659624 1.777519 1.854075 2.075363 2.257205 2.908337} test "Elliptic-2.0" "Complete elliptic integral of the second kind" \ -match numbers -body { set result {} foreach k2 {0.0 0.1 0.2 0.4 0.5 0.7 0.8 0.95} { set k [expr {sqrt($k2)}] lappend result [::math::special::elliptic_E $k] } set result } -result {1.570796 1.530758 1.489035 1.399392 1.350644 1.241671 1.17849 1.060474} # End of test cases testsuiteCleanup tcllib-1.15/modules/math/calculus.test0000755000175000017500000004330112077663116017361 0ustar sergeisergei# calculus.test -- # Test cases for the Calculus package # # This file contains a collection of tests for one or more of the Tcllib # procedures. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 2002, 2003, 2004 by Arjen Markus. # Copyright (c) 2004 by Kevin B. Kenny # All rights reserved. # # RCS: @(#) $Id: calculus.test,v 1.18 2011/01/18 07:49:53 arjenmarkus Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.4 testsNeedTcltest 2.1 support { useLocal math.tcl math useLocal interpolate.tcl math::interpolate } testing { useLocal calculus.tcl math::calculus } # ------------------------------------------------------------------------- package require log log::lvSuppress notice # ------------------------------------------------------------------------- namespace eval ::math::calculus::test { namespace import ::tcltest::test namespace import ::math::calculus::* set prec $::tcl_precision if {![package vsatisfies [package provide Tcl] 8.5]} { set ::tcl_precision 17 } else { set ::tcl_precision 0 } proc matchNumbers {expected actual} { set match 1 foreach a $actual e $expected { if {abs($a-$e) > 0.1e-4} { set match 0 break } } return $match } customMatch numbers matchNumbers # # Simple test functions - exact result predictable! # proc const_func { x } { return 1 } proc linear_func { x } { return $x } proc downward_linear { x } { return [expr {100.0-$x}] } # # Test the Integral proc # test "Integral-1.0" "Integral of constant function" { integral 0 100 100 const_func } 100.0 test "Integral-1.1" "Integral of linear function" { integral 0 100 100 linear_func } 5000.0 test "Integral-1.2" "Integral of downward linear function" { integral 0 100 100 downward_linear } 5000.0 test "Integral-1.3" "Integral of expression" { integralExpr 0 100 100 {100.0-$x} } 5000.0 proc const_func2d { x y } { return 1 } proc linear_func2d { x y } { return $x } test "Integral2D-1.0" "Integral of constant 2D function" { integral2D { 0 100 10 } { 0 50 1 } const_func2d } 5000.0 test "Integral2D-1.1" "Integral of constant 2D function (different step)" { integral2D { 0 100 1 } { 0 50 1 } const_func2d } 5000.0 test "Integral2D-1.2" "Integral of linear 2D function" { integral2D { 0 100 10 } { 0 50 1 } linear_func2d } 250000.0 proc const_func3d { x y z } { return 1 } proc linear_func3d { x y z } { return $x } test "Integral3D-1.0" "Integral of constant 2D function" { integral3D { 0 100 10 } { 0 50 1 } { 0 50 1 } const_func3d } 250000.0 test "Integral3D-1.1" "Integral of constant 2D function (different step)" { integral3D { 0 100 1 } { 0 50 1 } { 0 50 1 } const_func3d } 250000.0 test "Integral3D-1.2" "Integral of linear 2D function" { integral3D { 0 100 10 } { 0 50 1 } { 0 50 1 } linear_func3d } 12500000.0 proc f2d_1 {x y} { return 1 } proc f2d_x {x y} { return $x } proc f2d_y {x y} { return $y } proc f2d_x2 {x y} { return [expr {$x*$x}] } proc f2d_y2 {x y} { return [expr {$y*$y}] } test "Integral2D-2.0" "Integrals of 2D functions - accurate" -match numbers -body { set result {} foreach f {f2d_1 f2d_x f2d_y f2d_x2 f2d_y2} { lappend result [::math::calculus::integral2D_accurate {-1 1 1} {-1 1 1} $f] } return $result } -result {4.0 0.0 0.0 1.333333333 1.333333333} proc f3d_1 {x y z} { return 1 } proc f3d_x {x y z} { return $x } proc f3d_y {x y z} { return $y } proc f3d_z {x y z} { return $z } proc f3d_x2 {x y z} { return [expr {$x*$x}] } proc f3d_y2 {x y z} { return [expr {$y*$y}] } proc f3d_z2 {x y z} { return [expr {$z*$z}] } test "Integral2D-2.0" "Integrals of 2D functions - accurate" -match numbers -body { set result {} foreach f {f3d_1 f3d_x f3d_y f3d_z f3d_x2 f3d_y2 f3d_z2} { lappend result [::math::calculus::integral3D_accurate {-1 1 1} {-1 1 1} {-1 1 1} $f] } return $result } -result {8.0 0.0 0.0 0.0 2.666666667 2.666666667 2.666666667} # # Test cases: yet to be brought into the tcltest form! # # xvec should one long! proc const_func { t xvec } { return 1.0 } # xvec should be two long! proc dampened_oscillator { t xvec } { set x [lindex $xvec 0] set x1 [lindex $xvec 1] return [list $x1 [expr {-$x1-$x}]] } foreach method {eulerStep heunStep rungeKuttaStep} { log::log notice "Method: $method" set xvec 0.0 set t 0.0 set tstep 1.0 for { set i 0 } { $i < 10 } { incr i } { set result [$method $t $tstep $xvec const_func] log::log notice "Result ($t): $result" set t [expr {$t+$tstep}] set xvec $result } set xvec { 1.0 0.0 } set t 0.0 set tstep 0.1 for { set i 0 } { $i < 20 } { incr i } { set result [$method $t $tstep $xvec dampened_oscillator] log::log notice "Result ($t): $result" set t [expr {$t+$tstep}] set xvec $result } } # # Boundary value problems: # proc coeffs { x } { return {1.0 0.0 0.0} } proc forces { x } { return 0.0 } log::log notice [boundaryValueSecondOrder coeffs forces {0.0 1.0} {100.0 0.0} 10] log::log notice [boundaryValueSecondOrder coeffs forces {0.0 0.0} {100.0 1.0} 10] # # Determining the root of an equation # use simple functions # proc func { x } { expr {$x*$x-1.0} } proc deriv { x } { expr {2.0*$x} } test "NewtonRaphson-1.0" "Result should be 1" { set result [newtonRaphson func deriv 2.0] if { abs($result-1.0) < 0.0001 } { set answer 1 } } 1 test "NewtonRaphson-1.1" "Result should be -1" { set result [newtonRaphson func deriv -0.5] if { abs($result+1.0) < 0.0001 } { set answer 1 } } 1 proc func2 { x } { expr {$x*exp($x)-1.0} } proc deriv2 { x } { expr {exp($x)+$x*exp($x)} } test "NewtonRaphson-2.1" "Result should be nearly 0.56714" { set result [newtonRaphson func2 deriv2 2.0] if { abs($result-0.56714) < 0.0001 } { set answer 1 } } 1 test "NewtonRaphson-2.2" "Result should be nearly 0.56714" { set result [newtonRaphson func2 deriv2 -0.5] if { abs($result-0.56714) < 0.0001 } { set answer 1 } } 1 proc checkout { expr integrator a b target } { set problems {} proc g x [list expr $expr] set cmd $integrator lappend cmd g $a $b foreach { s error } [eval $cmd] break set diff [expr { abs( $s - $target ) }] if { $diff > 1.0e-6 * $target && $diff > 1.0e-10 } { append problems \n "error underestimated!" \ \n "f =" $expr ", a=" $a ", b=" $b \ \n "machinery = " $integrator "," \ \n "estimated " $error " actual " $diff } return $problems } test romberg-1.1 {simple integral} { checkout { pow( $x, 16 ) } romberg -1. 1. [expr { 2. / 17. }] } {} test romberg-1.2 {simple integral} { checkout { exp( -$x * $x / 2. ) / sqrt( 2. * 3.1415926535897932 ) } \ romberg -1. 1. 0.68268949213708590 } {} test romberg-1.3 {simple integral} { checkout { sin($x) } romberg 0 3.1415926535897932 2.0 } {} test romberg-1.4 { Singularity where limit exists } { checkout { sin($x)/$x } romberg 0 3.1415926535897932 1.8519370519824662 } {} test romberg-1.5 { Parameter error } { catch {romberg irrelevant 0 1 -degree} result set result } "wrong \# args, should be \"romberg f x1 x2 ?-option value?...\"" test romberg-1.6 { Parameter error } { catch {romberg irrelevant 0 1 -bad flag} result set result } "unknown option \"-bad\", should be -abserror, -degree, -relerror, or\ -maxiter" test romberg-1.7 { Max iterations exceeded } \ -setup { proc f x { expr { pow($x,4) } } } \ -body { foreach { value error } [romberg f -1. 1. -degree 1 -maxiter 3 ] break expr { abs($value - 0.4) < $error } } \ -cleanup { rename f {} } \ -result 1 test romberg-1.8 {Bad param} { catch {romberg irrelevant 0 1 -degree bad} result set result } {expected an integer but found "bad"} test romberg-1.9 {Bad param} { catch {romberg irrelevant 0 1 -degree 0} result set result } {-degree must be positive} test romberg-1.10 {Bad param} { catch {romberg irrelevant 0 1 -maxiter bad} result set result } {expected an integer but found "bad"} test romberg-1.11 {Bad param} { catch {romberg irrelevant 0 1 -maxiter 0} result set result } {-maxiter must be positive} test romberg-1.12 {Bad param} { catch {romberg irrelevant 0 1 -abserror bad} result set result } {expected a floating-point number but found "bad"} test romberg-1.13 {Bad param} { catch {romberg irrelevant 0 1 -abserror 0.} result set result } {-abserror must be positive} test romberg-1.14 {Bad param} { catch {romberg irrelevant 0 1 -relerror bad} result set result } {expected a floating-point number but found "bad"} test romberg-1.15 {Bad param} { catch {romberg irrelevant 0 1 -relerror 0.} result set result } {-relerror must be positive} test romberg-1.16 {Bad limit } { catch {romberg irrelevant bad 1} result set result } {expected a floating-point number but found "bad"} test romberg-1.17 {Bad limit} { catch {romberg irrelevant 0 bad} result set result } {expected a floating-point number but found "bad"} test romberg-2.1 {Integral over half-infinite interval} { checkout { exp( -$x * $x / 2. ) / sqrt( 2. * 3.1415926535897932 ) } \ romberg_infinity -30. -1. 0.15865525393145705 } {} test romberg-2.2 {Integral over half-infinite interval} { checkout { exp( -$x * $x / 2. ) / sqrt( 2. * 3.1415926535897932 ) } \ romberg_infinity 1. 30. 0.15865525393145705 } {} test romberg-2.3 {Integral over half-infinite interval} { checkout { exp( $x ) } romberg_infinity -1.e38 -1. [expr { exp(-1.) }] } {} test romberg-2.4 {Parameter error} { catch {romberg_infinity irrelevant -1.e38 2.} result set result } {limits of integration have opposite sign} test romberg-2.5 {Bad limit } { catch {romberg_infinity irrelevant bad 1} result set result } {expected a floating-point number but found "bad"} test romberg-2.6 {Bad limit} { catch {romberg_infinity irrelevant 0 bad} result set result } {expected a floating-point number but found "bad"} test romberg-3.1 {Square root singularity at the upper bound} { checkout { sqrt( 1.0 / ( 1.0 - $x ) ) } romberg_sqrtSingUpper 0. 1. 2. } {} test romberg-3.2 \ {Square root singularity in the derivative at the upper bound} { checkout { 4. * sqrt( 1.0 - $x * $x ) } romberg_sqrtSingUpper 0. 1. \ 3.1415926535897932 } {} test romberg-3.3 {Square root singularity at the lower bound} { checkout { 1.0 / sqrt($x) } romberg_sqrtSingLower 0. 4. 4. } {} test romberg-3.4 \ {Square root singularity in the derivative at the lower bound} { checkout { 4. * sqrt( 1.0 - $x * $x ) } romberg_sqrtSingLower -1. 0. \ 3.1415926535897932 } {} test romberg-3.5 {Bad limit } { catch {romberg_sqrtSingUpper irrelevant bad 1} result set result } {expected a floating-point number but found "bad"} test romberg-3.6 {Bad limit} { catch {romberg_sqrtSingUpper irrelevant 0 bad} result set result } {expected a floating-point number but found "bad"} test romberg-3.7 {Bad limits} { catch {romberg_sqrtSingUpper irrelevant 1 0} result set result } {limits of integration out of order} test romberg-3.8 {Bad limit } { catch {romberg_sqrtSingLower irrelevant bad 1} result set result } {expected a floating-point number but found "bad"} test romberg-3.9 {Bad limit} { catch {romberg_sqrtSingLower irrelevant 0 bad} result set result } {expected a floating-point number but found "bad"} test romberg-3.10 {Bad limits} { catch {romberg_sqrtSingLower irrelevant 1 0} result set result } {limits of integration out of order} test romberg-4.1 {Power law singularity at the lower bound} { checkout { 1.0 / sqrt($x) } [list romberg_powerLawLower 0.5] 0. 4. 4. } {} test romberg-4.2 \ {Power law signularity in the derivative at the lower bound.} { checkout { sqrt( sqrt( $x ) ) } \ [list romberg_powerLawLower 0.75] 0. 1. 0.8 } {} test romberg-4.3 {Power law singularity at the upper bound} { checkout { 1.0 / sqrt(4.0 - $x) } \ [list romberg_powerLawUpper 0.5] 0. 4. 4. } {} test romberg-4.4 \ {Power law singularity in the derivative at the upper bound} { checkout { sqrt( sqrt( -$x ) ) } \ [list romberg_powerLawUpper 0.75] -1. 0. 0.8 } {} test romberg-4.5 {Bad limit } { catch {romberg_powerLawUpper 0.5 irrelevant bad 1} result set result } {expected a floating-point number but found "bad"} test romberg-4.6 {Bad limit} { catch {romberg_powerLawUpper 0.5 irrelevant 0 bad} result set result } {expected a floating-point number but found "bad"} test romberg-4.7 {Bad limits} { catch {romberg_powerLawUpper 0.5 irrelevant 1 0} result set result } {limits of integration out of order} test romberg-4.8 {Bad limit } { catch {romberg_powerLawLower 0.5 irrelevant bad 1} result set result } {expected a floating-point number but found "bad"} test romberg-4.9 {Bad limit} { catch {romberg_powerLawLower 0.5 irrelevant 0 bad} result set result } {expected a floating-point number but found "bad"} test romberg-4.10 {Bad limits} { catch {romberg_powerLawLower 0.5 irrelevant 1 0} result set result } {limits of integration out of order} test romberg-4.11 {Bad gamma} { catch {romberg_powerLawUpper bad irrelevant 1 0} result set result } {expected a floating-point number but found "bad"} test romberg-4.12 {Bad gamma} { catch {romberg_powerLawUpper 0. irrelevant 1. 0.} result set result } {gamma must lie in the interval (0,1)} test romberg-4.13 {Bad gamma} { catch {romberg_powerLawUpper 1. irrelevant 1. 0.} result set result } {gamma must lie in the interval (0,1)} test romberg-4.14 {Bad gamma} { catch {romberg_powerLawLower bad irrelevant 1 0} result set result } {expected a floating-point number but found "bad"} test romberg-4.15 {Bad gamma} { catch {romberg_powerLawLower 0. irrelevant 1. 0.} result set result } {gamma must lie in the interval (0,1)} test romberg-4.16 {Bad gamma} { catch {romberg_powerLawLower 1. irrelevant 1. 0.} result set result } {gamma must lie in the interval (0,1)} test romberg-5.1 {Function that decays exponentially} { checkout { exp( -$x * $x / 2. ) / sqrt( 2. * 3.1415926535897932 ) } \ romberg_expUpper 1. 100. 0.15865525393145705 } {} test romberg-5.2 {Function that grows exponentially} { checkout { exp( -$x * $x / 2. ) / sqrt( 2. * 3.1415926535897932 ) } \ romberg_expLower -100. -1. 0.15865525393145705 } {} test romberg-5.3 {Bad limit } { catch {romberg_sqrtSingUpper irrelevant bad 1} result set result } {expected a floating-point number but found "bad"} test romberg-5.4 {Bad limit} { catch {romberg_sqrtSingUpper irrelevant 0 bad} result set result } {expected a floating-point number but found "bad"} test romberg-5.5 {Bad limits} { catch {romberg_sqrtSingUpper irrelevant 1 0} result set result } {limits of integration out of order} test romberg-5.6 {Bad limit } { catch {romberg_sqrtSingLower irrelevant bad 1} result set result } {expected a floating-point number but found "bad"} test romberg-5.7 {Bad limit} { catch {romberg_sqrtSingLower irrelevant 0 bad} result set result } {expected a floating-point number but found "bad"} test romberg-5.8 {Bad limits} { catch {romberg_sqrtSingLower irrelevant 1 0} result set result } {limits of integration out of order} test romberg-6.1 {Fancy integration} \ -setup { proc v {f u} { set x [expr { sin($u) }] set cmd $f; lappend cmd $x; set y [eval $cmd] return [expr { $y * cos($u) }] } proc romberg_sine { f a b args } { set f [lreplace $f 0 0 \ [uplevel 1 [list namespace which [lindex $f 0]]]] set f [list v $f] return [eval [linsert $args 0 \ romberg $f \ [expr { asin($a) }] [expr { asin($b) }]]] } } \ -body { checkout { exp($x) / sqrt( 1. - $x * $x ) } romberg_sine -1. 1. \ 3.97746326 } \ -cleanup { rename v {} rename romberg_sine {} } \ -result {} proc matchNumbers {expected actual} { set match 1 foreach a $actual e $expected { if {abs($a-$e) > 0.1e-6} { set match 0 break } } return $match } customMatch numbers matchNumbers proc ::f1 {x} {expr {1.0-$x}} proc ::f2 {x} {expr {1.0-$x*$x}} proc ::f3 {x} {expr {cos($x)}} test "regula-1.0" "Zero of linear function" \ -match numbers -body { set x1 [::math::calculus::regula_falsi ::f1 0.0 5.0] } -result 1.0 test "regula-1.1" "Zero of quadratic function" \ -match numbers -body { set x1 [::math::calculus::regula_falsi ::f2 0.0 5.0] } -result 0.99909822 test "regula-1.2" "Zero of quadratic function (more accurate)" \ -match numbers -body { set x1 [::math::calculus::regula_falsi ::f2 0.0 5.0 1.0e-6] } -result 0.99999305 test "regula-1.3" "Zero of cosine" \ -match numbers -body { set x1 [::math::calculus::regula_falsi ::f3 0.0 3.0] } -result 1.5707963 test "regula-2.1" "Negative relative error" \ -match glob -body { set x1 [::math::calculus::regula_falsi ::f1 0.0 3.0 -1.0e-4] } -result "Relative *" -returnCodes error test "regula-2.2" "Invalid interval" \ -match glob -body { set x1 [::math::calculus::regula_falsi ::f3 0.0 5.0] } -result "Interval must be *" -returnCodes error test "solveTriDiagonal-1.0" "Solve tridiagonal system" \ -match numbers -body { set x [::math::calculus::solveTriDiagonal {3 3} {1 1 1} {2 2} {1 0 0}] } -result [list [expr {5.0/11.0}] [expr {3.0/11.0}] [expr {-9.0/11.0}]] # End of test cases testsuiteCleanup set ::tcl_precision $prec testsuiteCleanup } namespace delete ::math::calculus::test # Local Variables: # mode: tcl # End: tcllib-1.15/modules/math/fuzzy.testscript0000755000175000017500000000111212077663116020154 0ustar sergeisergei# Rough tests for math::fuzzy procs # To do: convert to Tcltest package require math::fuzzy namespace import ::math::fuzzy::* puts "[teq 1.0 1.001] - expected: 0" puts "[teq 1.0 1.0000000000000000001] - expected: 1" puts "[tne 1.0 1.001] - expected: 1" puts "[tne 1.0 1.0000000000000000001] - expected: 0" puts "[tgt 1.0 1.001] - expected: 0" puts "[tgt 1.0 1.0000000000000000001] - expected: 0" set x 0.11 set y [expr {(($x*11.0)-$x)-0.1}] set z 1.0 puts "X: $x" puts "Y: $y" puts "Z: $z" puts "Floor: [tfloor $y] ([expr {floor($y)}])" puts "Ceil: [tceil $y] ([expr {ceil($y)}])" tcllib-1.15/modules/math/qcomplex.man0000755000175000017500000001501712077663116017175 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin math::complexnumbers n 1.0.2] [copyright {2004 Arjen Markus }] [moddesc {Tcl Math Library}] [titledesc {Straightforward complex number package}] [category Mathematics] [require Tcl 8.3] [require math::complexnumbers [opt 1.0.2]] [description] [para] The mathematical module [emph complexnumbers] provides a straightforward implementation of complex numbers in pure Tcl. The philosophy is that the user knows he or she is dealing with complex numbers in an abstract way and wants as high a performance as can be had within the limitations of an interpreted language. [para] Therefore the procedures defined in this package assume that the arguments are valid (representations of) "complex numbers", that is, lists of two numbers defining the real and imaginary part of a complex number (though this is a mere detail: rely on the [emph complex] command to construct a valid number.) [para] Most procedures implement the basic arithmetic operations or elementary functions whereas several others convert to and from different representations: [para] [example { set z [complex 0 1] puts "z = [tostring $z]" puts "z**2 = [* $z $z] }] would result in: [example { z = i z**2 = -1 }] [section "AVAILABLE PROCEDURES"] The package implements all or most basic operations and elementary functions. [para] [emph {The arithmetic operations are:}] [list_begin definitions] [call [cmd ::math::complexnumbers::+] [arg z1] [arg z2]] Add the two arguments and return the resulting complex number [list_begin arguments] [arg_def complex z1 in] First argument in the summation [arg_def complex z2 in] Second argument in the summation [list_end] [para] [call [cmd ::math::complexnumbers::-] [arg z1] [arg z2]] Subtract the second argument from the first and return the resulting complex number. If there is only one argument, the opposite of z1 is returned (i.e. -z1) [list_begin arguments] [arg_def complex z1 in] First argument in the subtraction [arg_def complex z2 in] Second argument in the subtraction (optional) [list_end] [para] [call [cmd ::math::complexnumbers::*] [arg z1] [arg z2]] Multiply the two arguments and return the resulting complex number [list_begin arguments] [arg_def complex z1 in] First argument in the multiplication [arg_def complex z2 in] Second argument in the multiplication [list_end] [para] [call [cmd ::math::complexnumbers::/] [arg z1] [arg z2]] Divide the first argument by the second and return the resulting complex number [list_begin arguments] [arg_def complex z1 in] First argument (numerator) in the division [arg_def complex z2 in] Second argument (denominator) in the division [list_end] [para] [call [cmd ::math::complexnumbers::conj] [arg z1]] Return the conjugate of the given complex number [list_begin arguments] [arg_def complex z1 in] Complex number in question [list_end] [para] [list_end] [para] [emph {Conversion/inquiry procedures:}] [list_begin definitions] [call [cmd ::math::complexnumbers::real] [arg z1]] Return the real part of the given complex number [list_begin arguments] [arg_def complex z1 in] Complex number in question [list_end] [para] [call [cmd ::math::complexnumbers::imag] [arg z1]] Return the imaginary part of the given complex number [list_begin arguments] [arg_def complex z1 in] Complex number in question [list_end] [para] [call [cmd ::math::complexnumbers::mod] [arg z1]] Return the modulus of the given complex number [list_begin arguments] [arg_def complex z1 in] Complex number in question [list_end] [para] [call [cmd ::math::complexnumbers::arg] [arg z1]] Return the argument ("angle" in radians) of the given complex number [list_begin arguments] [arg_def complex z1 in] Complex number in question [list_end] [para] [call [cmd ::math::complexnumbers::complex] [arg real] [arg imag]] Construct the complex number "real + imag*i" and return it [list_begin arguments] [arg_def float real in] The real part of the new complex number [arg_def float imag in] The imaginary part of the new complex number [list_end] [para] [call [cmd ::math::complexnumbers::tostring] [arg z1]] Convert the complex number to the form "real + imag*i" and return the string [list_begin arguments] [arg_def float complex in] The complex number to be converted [list_end] [para] [list_end] [para] [emph {Elementary functions:}] [list_begin definitions] [call [cmd ::math::complexnumbers::exp] [arg z1]] Calculate the exponential for the given complex argument and return the result [list_begin arguments] [arg_def complex z1 in] The complex argument for the function [list_end] [para] [call [cmd ::math::complexnumbers::sin] [arg z1]] Calculate the sine function for the given complex argument and return the result [list_begin arguments] [arg_def complex z1 in] The complex argument for the function [list_end] [para] [call [cmd ::math::complexnumbers::cos] [arg z1]] Calculate the cosine function for the given complex argument and return the result [list_begin arguments] [arg_def complex z1 in] The complex argument for the function [list_end] [para] [call [cmd ::math::complexnumbers::tan] [arg z1]] Calculate the tangent function for the given complex argument and return the result [list_begin arguments] [arg_def complex z1 in] The complex argument for the function [list_end] [para] [call [cmd ::math::complexnumbers::log] [arg z1]] Calculate the (principle value of the) logarithm for the given complex argument and return the result [list_begin arguments] [arg_def complex z1 in] The complex argument for the function [list_end] [para] [call [cmd ::math::complexnumbers::sqrt] [arg z1]] Calculate the (principle value of the) square root for the given complex argument and return the result [list_begin arguments] [arg_def complex z1 in] The complex argument for the function [list_end] [para] [call [cmd ::math::complexnumbers::pow] [arg z1] [arg z2]] Calculate "z1 to the power of z2" and return the result [list_begin arguments] [arg_def complex z1 in] The complex number to be raised to a power [arg_def complex z2 in] The complex power to be used [list_end] [list_end] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph {math :: complexnumbers}] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords math {complex numbers}] [manpage_end] tcllib-1.15/modules/math/romberg.man0000755000175000017500000003137012077663116017002 0ustar sergeisergei[manpage_begin math::calculus::romberg n 0.6] [copyright "2004 Kevin B. Kenny . All rights\ reserved. Redistribution permitted under the terms of the Open\ Publication License "] [moddesc {Tcl Math Library}] [titledesc {Romberg integration}] [category Mathematics] [require Tcl 8.2] [require math::calculus 0.6] [description] [para] The [cmd romberg] procedures in the [cmd math::calculus] package perform numerical integration of a function of one variable. They are intended to be of "production quality" in that they are robust, precise, and reasonably efficient in terms of the number of function evaluations. [section "PROCEDURES"] The following procedures are available for Romberg integration: [list_begin definitions] [call [cmd ::math::calculus::romberg] [arg f] [arg a] [arg b] [opt [arg "-option value"]...]] Integrates an analytic function over a given interval. [call [cmd ::math::calculus::romberg_infinity] [arg f] [arg a] [arg b] [opt [arg "-option value"]...]] Integrates an analytic function over a half-infinite interval. [call [cmd ::math::calculus::romberg_sqrtSingLower] [arg f] [arg a] [arg b] [opt [arg "-option value"]...]] Integrates a function that is expected to be analytic over an interval except for the presence of an inverse square root singularity at the lower limit. [call [cmd ::math::calculus::romberg_sqrtSingUpper] [arg f] [arg a] [arg b] [opt [arg "-option value"]...]] Integrates a function that is expected to be analytic over an interval except for the presence of an inverse square root singularity at the upper limit. [call [cmd ::math::calculus::romberg_powerLawLower] [arg gamma] [arg f] [arg a] [arg b] [opt [arg "-option value"]...]] Integrates a function that is expected to be analytic over an interval except for the presence of a power law singularity at the lower limit. [call [cmd ::math::calculus::romberg_powerLawUpper] [arg gamma] [arg f] [arg a] [arg b] [opt [arg "-option value"]...]] Integrates a function that is expected to be analytic over an interval except for the presence of a power law singularity at the upper limit. [call [cmd ::math::calculus::romberg_expLower] [arg f] [arg a] [arg b] [opt [arg "-option value"]...]] Integrates an exponentially growing function; the lower limit of the region of integration may be arbitrarily large and negative. [call [cmd ::math::calculus::romberg_expUpper] [arg f] [arg a] [arg b] [opt [arg "-option value"]...]] Integrates an exponentially decaying function; the upper limit of the region of integration may be arbitrarily large. [list_end] [section PARAMETERS] [list_begin definitions] [def [arg f]] Function to integrate. Must be expressed as a single Tcl command, to which will be appended a single argument, specifically, the abscissa at which the function is to be evaluated. The first word of the command will be processed with [cmd "namespace which"] in the caller's scope prior to any evaluation. Given this processing, the command may local to the calling namespace rather than needing to be global. [def [arg a]] Lower limit of the region of integration. [def [arg b]] Upper limit of the region of integration. For the [cmd romberg_sqrtSingLower], [cmd romberg_sqrtSingUpper], [cmd romberg_powerLawLower], [cmd romberg_powerLawUpper], [cmd romberg_expLower], and [cmd romberg_expUpper] procedures, the lower limit must be strictly less than the upper. For the other procedures, the limits may appear in either order. [def [arg gamma]] Power to use for a power law singularity; see section [sectref "IMPROPER INTEGRALS"] for details. [list_end] [section OPTIONS] [list_begin definitions] [def "[option -abserror] [arg epsilon]"] Requests that the integration machinery proceed at most until the estimated absolute error of the integral is less than [arg epsilon]. The error may be seriously over- or underestimated if the function (or any of its derivatives) contains singularities; see section [sectref "IMPROPER INTEGRALS"] for details. Default is 1.0e-08. [def "[option -relerror] [arg epsilon]"] Requests that the integration machinery proceed at most until the estimated relative error of the integral is less than [arg epsilon]. The error may be seriously over- or underestimated if the function (or any of its derivatives) contains singularities; see section [sectref "IMPROPER INTEGRALS"] for details. Default is 1.0e-06. [def "[option -maxiter] [arg m]"] Requests that integration terminate after at most [arg n] triplings of the number of evaluations performed. In other words, given [arg n] for [option -maxiter], the integration machinery will make at most 3**[arg n] evaluations of the function. Default is 14, corresponding to a limit approximately 4.8 million evaluations. (Well-behaved functions will seldom require more than a few hundred evaluations.) [def "[option -degree] [arg d]"] Requests that an extrapolating polynomial of degree [arg d] be used in Romberg integration; see section [sectref "DESCRIPTION"] for details. Default is 4. Can be at most [arg m]-1. [list_end] [section DESCRIPTION] The [cmd romberg] procedure performs Romberg integration using the modified midpoint rule. Romberg integration is an iterative process. At the first step, the function is evaluated at the midpoint of the region of integration, and the value is multiplied by the width of the interval for the coarsest possible estimate. At the second step, the interval is divided into three parts, and the function is evaluated at the midpoint of each part; the sum of the values is multiplied by three. At the third step, nine parts are used, at the fourth twenty-seven, and so on, tripling the number of subdivisions at each step. [para] Once the interval has been divided at least [arg d] times, a polynomial is fitted to the integrals estimated in the last [arg d]+1 divisions. The integrals are considered to be a function of the square of the width of the subintervals (any good numerical analysis text will discuss this process under "Romberg integration"). The polynomial is extrapolated to a step size of zero, computing a value for the integral and an estimate of the error. [para] This process will be well-behaved only if the function is analytic over the region of integration; there may be removable singularities at either end of the region provided that the limit of the function (and of all its derivatives) exists as the ends are approached. Thus, [cmd romberg] may be used to integrate a function like f(x)=sin(x)/x over an interval beginning or ending at zero. [para] Note that [cmd romberg] will either fail to converge or else return incorrect error estimates if the function, or any of its derivatives, has a singularity anywhere in the region of integration (except for the case mentioned above). Care must be used, therefore, in integrating a function like 1/(1-x**2) to avoid the places where the derivative is singular. [section "IMPROPER INTEGRALS"] Romberg integration is also useful for integrating functions over half-infinite intervals or functions that have singularities. The trick is to make a change of variable to eliminate the singularity, and to put the singularity at one end or the other of the region of integration. The [cmd math::calculus] package supplies a number of [cmd romberg] procedures to deal with the commoner cases. [list_begin definitions] [def [cmd romberg_infinity]] Integrates a function over a half-infinite interval; either [arg a] or [arg b] may be infinite. [arg a] and [arg b] must be of the same sign; if you need to integrate across the axis, say, from a negative value to positive infinity, use [cmd romberg] to integrate from the negative value to a small positive value, and then [cmd romberg_infinity] to integrate from the positive value to positive infinity. The [cmd romberg_infinity] procedure works by making the change of variable u=1/x, so that the integral from a to b of f(x) is evaluated as the integral from 1/a to 1/b of f(1/u)/u**2. [def "[cmd romberg_powerLawLower] and [cmd romberg_powerLawUpper]"] Integrate a function that has an integrable power law singularity at either the lower or upper bound of the region of integration (or has a derivative with a power law singularity there). These procedures take a first parameter, [arg gamma], which gives the power law. The function or its first derivative are presumed to diverge as (x-[arg a])**(-[arg gamma]) or ([arg b]-x)**(-[arg gamma]). [arg gamma] must be greater than zero and less than 1. [para] These procedures are useful not only in integrating functions that go to infinity at one end of the region of integration, but also functions whose derivatives do not exist at the end of the region. For instance, integrating f(x)=pow(x,0.25) with the origin as one end of the region will result in the [cmd romberg] procedure greatly underestimating the error in the integral. The problem can be fixed by observing that the first derivative of f(x), f'(x)=x**(-3/4)/4, goes to infinity at the origin. Integrating using [cmd romberg_powerLawLower] with [arg gamma] set to 0.75 gives much more orderly convergence. [para] These procedures operate by making the change of variable u=(x-a)**(1-gamma) ([cmd romberg_powerLawLower]) or u=(b-x)**(1-gamma) ([cmd romberg_powerLawUpper]). [para] To summarize the meaning of gamma: [list_begin itemized] [item] If f(x) ~ x**(-a) (0 < a < 1), use gamma = a [item] If f'(x) ~ x**(-b) (0 < b < 1), use gamma = b [list_end] [def "[cmd romberg_sqrtSingLower] and [cmd romberg_sqrtSingUpper]"] These procedures behave identically to [cmd romberg_powerLawLower] and [cmd romberg_powerLawUpper] for the common case of [arg gamma]=0.5; that is, they integrate a function with an inverse square root singularity at one end of the interval. They have a simpler implementation involving square roots rather than arbitrary powers. [def "[cmd romberg_expLower] and [cmd romberg_expUpper]"] These procedures are for integrating a function that grows or decreases exponentially over a half-infinite interval. [cmd romberg_expLower] handles exponentially growing functions, and allows the lower limit of integration to be an arbitrarily large negative number. [cmd romberg_expUpper] handles exponentially decaying functions and allows the upper limit of integration to be an arbitrary large positive number. The functions make the change of variable u=exp(-x) and u=exp(x) respectively. [list_end] [section "OTHER CHANGES OF VARIABLE"] If you need an improper integral other than the ones listed here, a change of variable can be written in very few lines of Tcl. Because the Tcl coding that does it is somewhat arcane, we offer a worked example here. [para] Let's say that the function that we want to integrate is f(x)=exp(x)/sqrt(1-x*x) (not a very natural function, but a good example), and we want to integrate it over the interval (-1,1). The denominator falls to zero at both ends of the interval. We wish to make a change of variable from x to u so that dx/sqrt(1-x**2) maps to du. Choosing x=sin(u), we can find that dx=cos(u)*du, and sqrt(1-x**2)=cos(u). The integral from a to b of f(x) is the integral from asin(a) to asin(b) of f(sin(u))*cos(u). [para] We can make a function [cmd g] that accepts an arbitrary function [cmd f] and the parameter u, and computes this new integrand. [example { proc g { f u } { set x [expr { sin($u) }] set cmd $f; lappend cmd $x; set y [eval $cmd] return [expr { $y / cos($u) }] } }] Now integrating [cmd f] from [arg a] to [arg b] is the same as integrating [cmd g] from [arg asin(a)] to [arg asin(b)]. It's a little tricky to get [cmd f] consistently evaluated in the caller's scope; the following procedure does it. [example { proc romberg_sine { f a b args } { set f [lreplace $f 0 0\ [uplevel 1 [list namespace which [lindex $f 0]]]] set f [list g $f] return [eval [linsert $args 0\ romberg $f\ [expr { asin($a) }] [expr { asin($b) }]]] } }] This [cmd romberg_sine] procedure will do any function with sqrt(1-x*x) in the denominator. Our sample function is f(x)=exp(x)/sqrt(1-x*x): [example { proc f { x } { expr { exp($x) / sqrt( 1. - $x*$x ) } } }] Integrating it is a matter of applying [cmd romberg_sine] as we would any of the other [cmd romberg] procedures: [example { foreach { value error } [romberg_sine f -1.0 1.0] break puts [format "integral is %.6g +/- %.6g" $value $error] integral is 3.97746 +/- 2.3557e-010 }] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph {math :: calculus}] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [see_also math::calculus math::interpolate] [manpage_end] tcllib-1.15/modules/math/roman.test0000755000175000017500000001442112077663116016663 0ustar sergeisergei# -*- tcl -*- #--------------------------------------------------------------------- # TITLE: # romannumeral # # AUTHOR: # Kenneth Green, 28 Sep 2005 # # DESCRIPTION: # tcltest test cases for romannumeral.tcl # Note: # Assumes Tcl 8.3 # The tests assume tcltest 2.2 # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.3 testsNeedTcltest 2.2 support { useLocal math.tcl math } testing { useLocal romannumerals.tcl math::roman } #===================================================================== # S u p p o r t F u n c t i o n s #===================================================================== #--------------------------------------------------------------------- # cleanup -- # # cleanup before each test #--------------------------------------------------------------------- proc cleanup {} { global errorInfo } #===================================================================== # I n i t i a l i s a t i o n #===================================================================== ::tcltest::testConstraint tk [info exists tk_version] #===================================================================== # T e s t C a s e s #===================================================================== #----------------------------------------------------------------------- # toroman test ToRoman-1.1 {good input} -constraints { } -setup { cleanup } -body { list [catch { list \ [::math::roman::toroman 0] \ [::math::roman::toroman 1] \ [::math::roman::toroman 2] \ [::math::roman::toroman 3] \ [::math::roman::toroman 4] \ [::math::roman::toroman 5] \ [::math::roman::toroman 6] \ [::math::roman::toroman 7] \ [::math::roman::toroman 8] \ [::math::roman::toroman 9] \ [::math::roman::toroman 10] \ [::math::roman::toroman 13] \ [::math::roman::toroman 100] \ [::math::roman::toroman 250] \ [::math::roman::toroman 333] \ [::math::roman::toroman 1001] \ [::math::roman::toroman 1963] \ } errMsg] [set errMsg] } -cleanup { cleanup } -result {0 {{} I II III IV V VI VII VIII IX X XIII C CCL CCCXXXIII MI MCMLXIII}} #----------------------------------------------------------------------- # tointeger test ToInteger-2.1 {good input} -constraints { } -setup { cleanup } -body { list [catch { list \ [::math::roman::tointeger ""] \ [::math::roman::tointeger I] \ [::math::roman::tointeger ii] \ [::math::roman::tointeger IiI] \ [::math::roman::tointeger iv] \ [::math::roman::tointeger V] \ [::math::roman::tointeger vI] \ [::math::roman::tointeger vIi] \ [::math::roman::tointeger ViiI] \ [::math::roman::tointeger ix] \ [::math::roman::tointeger X] \ [::math::roman::tointeger XiII] \ [::math::roman::tointeger C] \ [::math::roman::tointeger CCD] \ [::math::roman::tointeger CCCXXXIII] \ [::math::roman::tointeger MI] \ [::math::roman::tointeger MCMXXXVI] \ } errMsg] [set errMsg] } -cleanup { cleanup } -result {0 {0 1 2 3 4 5 6 7 8 9 10 13 100 500 333 1001 1936}} #----------------------------------------------------------------------- # combined test Combined-3.1 {good input} -constraints { } -setup { cleanup } -body { list [catch { for { set i 0 } { $i < 11666 } { incr i } { set r [::math::roman::toroman $i] set j [::math::roman::tointeger $r] if { $i != $j } { error "Mismatch i ($i) -> r ($r) -> j ($j)" } } } errMsg] [set errMsg] } -cleanup { cleanup } -result {0 {}} #----------------------------------------------------------------------- # sort test Sort-4.1 {good input} -constraints { } -setup { cleanup } -body { list [catch { set l {X III IV I V} ::math::roman::sort $l \ } errMsg] [set errMsg] } -cleanup { cleanup } -result {0 {I III IV V X}} #----------------------------------------------------------------------- # expr test Expr-5.1 {plus} -constraints { } -setup { cleanup } -body { list [catch { set x 23 set xr [::math::roman::toroman $x] set y 77 set yr [::math::roman::toroman $y] set xr+yr [::math::roman::expr $xr + $yr] expr [::math::roman::tointeger ${xr+yr}] == [expr $x + $y] } errMsg] [set errMsg] } -cleanup { cleanup } -result {0 1} test Expr-5.2 {minus} -constraints { } -setup { cleanup } -body { list [catch { set x 23 set xr [::math::roman::toroman $x] set y 77 set yr [::math::roman::toroman $y] set yr-xr [::math::roman::expr $yr - $xr] expr [::math::roman::tointeger ${yr-xr}] == [expr $y - $x] } errMsg] [set errMsg] } -cleanup { cleanup } -result {0 1} test Expr-5.3 {times} -constraints { } -setup { cleanup } -body { list [catch { set x 23 set xr [::math::roman::toroman $x] set y 77 set yr [::math::roman::toroman $y] set xr*yr [::math::roman::expr $xr * $yr] expr $x * $y expr [::math::roman::tointeger ${xr*yr}] == [expr $x * $y] } errMsg] [set errMsg] } -cleanup { cleanup } -result {0 1} test Expr-5.4 {divide} -constraints { } -setup { cleanup } -body { list [catch { set x 23 set xr [::math::roman::toroman $x] set y 77 set yr [::math::roman::toroman $y] set yr/xr [::math::roman::expr $yr / $xr] expr [::math::roman::tointeger ${yr/xr}] == [expr $y / $x] } errMsg] [set errMsg] } -cleanup { cleanup } -result {0 1} #--------------------------------------------------------------------- # Clean up cleanup testsuiteCleanup tcllib-1.15/modules/math/rational_funcs.man0000755000175000017500000001156212077663116020355 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin math::rationalfunctions n 1.0.1] [copyright {2005 Arjen Markus }] [moddesc {Math}] [titledesc {Polynomial functions}] [category Mathematics] [require Tcl [opt 8.4]] [require math::rationalfunctions [opt 1.0.1]] [description] [para] This package deals with rational functions of one variable: [list_begin itemized] [item] the basic arithmetic operations are extended to rational functions [item] computing the derivatives of these functions [item] evaluation through a general procedure or via specific procedures) [list_end] [section "PROCEDURES"] The package defines the following public procedures: [list_begin definitions] [call [cmd ::math::rationalfunctions::rationalFunction] [arg num] [arg den]] Return an (encoded) list that defines the rational function. A rational function [example { 1 + x^3 f(x) = ------------ 1 + 2x + x^2 }] can be defined via: [example { set f [::math::rationalfunctions::rationalFunction [list 1 0 0 1] \ [list 1 2 1]] }] [list_begin arguments] [arg_def list num] Coefficients of the numerator of the rational function (in ascending order) [para] [arg_def list den] Coefficients of the denominator of the rational function (in ascending order) [list_end] [para] [call [cmd ::math::rationalfunctions::ratioCmd] [arg num] [arg den]] Create a new procedure that evaluates the rational function. The name of the function is automatically generated. Useful if you need to evaluate the function many times, as the procedure consists of a single [lb]expr[rb] command. [list_begin arguments] [arg_def list num] Coefficients of the numerator of the rational function (in ascending order) [para] [arg_def list den] Coefficients of the denominator of the rational function (in ascending order) [list_end] [para] [call [cmd ::math::rationalfunctions::evalRatio] [arg rational] [arg x]] Evaluate the rational function at x. [list_begin arguments] [arg_def list rational] The rational function's definition (as returned by the rationalFunction command). order) [arg_def float x] The coordinate at which to evaluate the function [list_end] [para] [call [cmd ::math::rationalfunctions::addRatio] [arg ratio1] [arg ratio2]] Return a new rational function which is the sum of the two others. [list_begin arguments] [arg_def list ratio1] The first rational function operand [arg_def list ratio2] The second rational function operand [list_end] [para] [call [cmd ::math::rationalfunctions::subRatio] [arg ratio1] [arg ratio2]] Return a new rational function which is the difference of the two others. [list_begin arguments] [arg_def list ratio1] The first rational function operand [arg_def list ratio2] The second rational function operand [list_end] [para] [call [cmd ::math::rationalfunctions::multRatio] [arg ratio1] [arg ratio2]] Return a new rational function which is the product of the two others. If one of the arguments is a scalar value, the other rational function is simply scaled. [list_begin arguments] [arg_def list ratio1] The first rational function operand or a scalar [arg_def list ratio2] The second rational function operand or a scalar [list_end] [para] [call [cmd ::math::rationalfunctions::divRatio] [arg ratio1] [arg ratio2]] Divide the first rational function by the second rational function and return the result. The remainder is dropped [list_begin arguments] [arg_def list ratio1] The first rational function operand [arg_def list ratio2] The second rational function operand [list_end] [para] [call [cmd ::math::rationalfunctions::derivPolyn] [arg ratio]] Differentiate the rational function and return the result. [list_begin arguments] [arg_def list ratio] The rational function to be differentiated [list_end] [para] [call [cmd ::math::rationalfunctions::coeffsNumerator] [arg ratio]] Return the coefficients of the numerator of the rational function. [list_begin arguments] [arg_def list ratio] The rational function to be examined [list_end] [para] [call [cmd ::math::rationalfunctions::coeffsDenominator] [arg ratio]] Return the coefficients of the denominator of the rational function. [list_begin arguments] [arg_def list ratio] The rational function to be examined [list_end] [para] [list_end] [section "REMARKS ON THE IMPLEMENTATION"] The implementation of the rational functions relies on the math::polynomials package. For further remarks see the documentation on that package. [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph {math :: rationalfunctions}] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords math "rational functions"] [manpage_end] tcllib-1.15/modules/math/symdiff.tcl0000644000175000017500000010610712077663116017013 0ustar sergeisergei# symdiff.tcl -- # # Symbolic differentiation package for Tcl # # This package implements a command, "math::calculus::symdiff::symdiff", # which accepts a Tcl expression and a variable name, and if the expression # is readily differentiable, returns a Tcl expression that evaluates the # derivative. # # Copyright (c) 2005, 2010 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: symdiff.tcl,v 1.2 2011/01/13 02:49:53 andreas_kupries Exp $ # This package requires the 'tclparser' from http://tclpro.sf.net/ # to analyze the expressions presented to it. package require Tcl 8.4 package require grammar::aycock 1.0 package provide math::calculus::symdiff 1.0 namespace eval math {} namespace eval math::calculus {} namespace eval math::calculus::symdiff { namespace export jacobian symdiff namespace eval differentiate {} } # math::calculus::symdiff::jacobian -- # # Differentiate a set of expressions with respect to a set of # model variables # # Parameters: # model -- A list of alternating {variable name} {expr} # # Results: # Returns a list of lists. The ith sublist is the gradient vector # of the ith expr in the model; that is, the jth element of # the ith sublist is the derivative of the ith expr with respect # to the jth variable. # # Returns an error if any expression cannot be differentiated with # respect to any of the elements of the list, or if the list has # no elements or an odd number of elements. proc math::calculus::symdiff::jacobian {list} { set l [llength $list] if {$l == 0 || $l%2 != 0} { return -code error "list of variables and expressions must have an odd number of elements" } set J {} foreach {- expr} $list { set gradient {} foreach {var -} $list { lappend gradient [symdiff $expr $var] } lappend J $gradient } return $J } # math::calculus::symdiff::symdiff -- # # Differentiate an expression with respect to a variable. # # Parameters: # expr -- expression to differentiate (Must be a Tcl expression, # without command substitution.) # var -- Name of the variable to differentiate the expression # with respect to. # # Results: # Returns a Tcl expression that evaluates the derivative. proc math::calculus::symdiff::symdiff {expr var} { variable parser set parsetree [$parser parse {*}[Lexer $expr] [namespace current]] return [ToInfix [differentiate::MakeDeriv $parsetree $var]] } # math::calculus::symdiff::Parser -- # # Parser for the mathematical expressions that this package can # differentiate. namespace eval math::calculus::symdiff { variable parser [grammar::aycock::parser { expression ::= expression addop term { set result [${clientData}::MakeOperator [lindex $_ 1]] lappend result [lindex $_ 0] [lindex $_ 2] } expression ::= term { lindex $_ 0 } addop ::= + { lindex $_ 0 } addop ::= - { lindex $_ 0 } term ::= term mulop factor { set result [${clientData}::MakeOperator [lindex $_ 1]] lappend result [lindex $_ 0] [lindex $_ 2] } term ::= factor { lindex $_ 0 } mulop ::= * { lindex $_ 0 } mulop ::= / { lindex $_ 0 } factor ::= addop factor { set result [${clientData}::MakeOperator [lindex $_ 0]] lappend result [lindex $_ 1] } factor ::= expon { lindex $_ 0 } expon ::= primary ** expon { set result [${clientData}::MakeOperator [lindex $_ 1]] lappend result [lindex $_ 0] [lindex $_ 2] } expon ::= primary { lindex $_ 0 } primary ::= {$} bareword { ${clientData}::MakeVariable [lindex $_ 1] } primary ::= number { ${clientData}::MakeConstant [lindex $_ 0] } primary ::= bareword ( arglist ) { set result [${clientData}::MakeOperator [lindex $_ 0]] lappend result {*}[lindex $_ 2] } primary ::= ( expression ) { lindex $_ 1 } arglist ::= expression { set _ } arglist ::= arglist , expression { linsert [lindex $_ 0] end [lindex $_ 2] } }] } # math::calculus::symdiff::Lexer -- # # Lexer for the arithmetic expressions that the 'symdiff' package # can differentiate. # # Results: # Returns a two element list. The first element is a list of the # lexical values of the tokens that were found in the expression; # the second is a list of the semantic values of the tokens. The # two sublists are the same length. proc math::calculus::symdiff::Lexer {expression} { set start 0 set tokens {} set values {} while {$expression ne {}} { if {[regexp {^\*\*(.*)} $expression -> rest]} { # Exponentiation lappend tokens ** lappend values ** } elseif {[regexp {^([-+/*$(),])(.*)} $expression -> token rest]} { # Single-character operators lappend tokens $token lappend values $token } elseif {[regexp {^([[:alpha:]][[:alnum:]_]*)(.*)} \ $expression -> token rest]} { # Variable and function names lappend tokens bareword lappend values $token } elseif {[regexp -nocase -expanded { ^((?: (?: [[:digit:]]+ (?:[.][[:digit:]]*)? ) | (?: [.][[:digit:]]+ ) ) (?: e [-+]? [[:digit:]]+ )? ) (.*) }\ $expression -> token rest]} { # Numbers lappend tokens number lappend values $token } elseif {[regexp {[[:space:]]+(.*)} $expression -> rest]} { # Whitespace } else { # Anything else is an error return -code error \ -errorcode [list MATH SYMDIFF INVCHAR \ [string index $expression 0]] \ [list invalid character [string index $expression 0]] \ } set expression $rest } return [list $tokens $values] } # math::calculus::symdiff::ToInfix -- # # Converts a parse tree to infix notation. # # Parameters: # tree - Parse tree to convert # # Results: # Returns the parse tree as a Tcl expression. proc math::calculus::symdiff::ToInfix {tree} { set a [lindex $tree 0] set kind [lindex $a 0] switch -exact $kind { constant - text { set result [lindex $tree 1] } var { set result \$[lindex $tree 1] } operator { set name [lindex $a 1] if {([string is alnum $name] && $name ne {eq} && $name ne {ne}) || [llength $tree] == 2} { set result $name append result \( set sep "" foreach arg [lrange $tree 1 end] { append result $sep [ToInfix $arg] set sep ", " } append result \) } elseif {[llength $tree] == 3} { set result \( append result [ToInfix [lindex $tree 1]] append result " " $name " " append result [ToInfix [lindex $tree 2]] append result \) } else { error "symdiff encountered a malformed parse, can't happen" } } default { error "symdiff can't synthesize a $kind expression" } } return $result } # math::calculus::symdiff::differentiate::MakeDeriv -- # # Differentiates a Tcl expression represented as a parse tree. # # Parameters: # tree -- Parse tree from MakeParseTreeForExpr # var -- Variable to differentiate with respect to # # Results: # Returns the parse tree of the derivative. proc math::calculus::symdiff::differentiate::MakeDeriv {tree var} { return [eval [linsert $tree 1 $var]] } # math::calculus::symdiff::differentiate::ChainRule -- # # Applies the Chain Rule to evaluate the derivative of a unary # function. # # Parameters: # var -- Variable to differentiate with respect to. # derivMaker -- Command prefix for differentiating the function. # u -- Function argument. # # Results: # Returns a parse tree representing the derivative of f($u). # # ChainRule differentiates $u with respect to $var by calling MakeDeriv, # makes the derivative of f($u) with respect to $u by calling derivMaker # passing $u as a parameter, and then returns a parse tree representing # the product of the results. proc math::calculus::symdiff::differentiate::ChainRule {var derivMaker u} { lappend derivMaker $u set result [MakeProd [MakeDeriv $u $var] [eval $derivMaker]] } # math::calculus::symdiff::differentiate::constant -- # # Differentiate a constant. # # Parameters: # var -- Variable to differentiate with respect to - unused # constant -- Constant expression to differentiate - ignored # # Results: # Returns a parse tree of the derivative, which is, of course, the # constant zero. proc math::calculus::symdiff::differentiate::constant {var constant} { return [MakeConstant 0.0] } # math::calculus::symdiff::differentiate::var -- # # Differentiate a variable expression. # # Parameters: # var - Variable with which to differentiate. # exprVar - Expression being differentiated, which is a single # variable. # # Results: # Returns a parse tree of the derivative. # # The derivative is the constant unity if the variables are the same # and the constant zero if they are different. proc math::calculus::symdiff::differentiate::var {var exprVar} { if {$exprVar eq $var} { return [MakeConstant 1.0] } else { return [MakeConstant 0.0] } } # math::calculus::symdiff::differentiate::operator + -- # # Forms the derivative of a sum. # # Parameters: # var -- Variable to differentiate with respect to. # args -- One or two arguments giving augend and addend. If only # one argument is supplied, this is unary +. # # Results: # Returns a parse tree representing the derivative. # # Of course, the derivative of a sum is the sum of the derivatives. proc {math::calculus::symdiff::differentiate::operator +} {var args} { if {[llength $args] == 1} { set u [lindex $args 0] set result [eval [linsert $u 1 $var]] } elseif {[llength $args] == 2} { foreach {u v} $args break set du [eval [linsert $u 1 $var]] set dv [eval [linsert $v 1 $var]] set result [MakeSum $du $dv] } else { error "symdiff encountered a malformed parse, can't happen" } return $result } # math::calculus::symdiff::differentiate::operator - -- # # Forms the derivative of a difference. # # Parameters: # var -- Variable to differentiate with respect to. # args -- One or two arguments giving minuend and subtrahend. If only # one argument is supplied, this is unary -. # # Results: # Returns a parse tree representing the derivative. # # Of course, the derivative of a sum is the sum of the derivatives. proc {math::calculus::symdiff::differentiate::operator -} {var args} { if {[llength $args] == 1} { set u [lindex $args 0] set du [eval [linsert $u 1 $var]] set result [MakeUnaryMinus $du] } elseif {[llength $args] == 2} { foreach {u v} $args break set du [eval [linsert $u 1 $var]] set dv [eval [linsert $v 1 $var]] set result [MakeDifference $du $dv] } else { error "symdiff encounered a malformed parse, can't happen" } return $result } # math::calculus::symdiff::differentiate::operator * -- # # Forms the derivative of a product. # # Parameters: # var -- Variable to differentiate with respect to. # u, v -- Multiplicand and multiplier. # # Results: # Returns a parse tree representing the derivative. # # The familiar freshman calculus product rule. proc {math::calculus::symdiff::differentiate::operator *} {var u v} { set du [eval [linsert $u 1 $var]] set dv [eval [linsert $v 1 $var]] set result [MakeSum [MakeProd $dv $u] [MakeProd $du $v]] return $result } # math::calculus::symdiff::differentiate::operator / -- # # Forms the derivative of a quotient. # # Parameters: # var -- Variable to differentiate with respect to. # u, v -- Dividend and divisor. # # Results: # Returns a parse tree representing the derivative. # # The familiar freshman calculus quotient rule. proc {math::calculus::symdiff::differentiate::operator /} {var u v} { set du [eval [linsert $u 1 $var]] set dv [eval [linsert $v 1 $var]] set result [MakeQuotient \ [MakeDifference \ $du \ [MakeQuotient \ [MakeProd $dv $u] \ $v]] \ $v] return $result } # math::calculus::symdiff::differentiate::operator acos -- # # Differentiates the 'acos' function. # # Parameters: # var -- Variable to differentiate with respect to. # u -- Argument to the acos() function. # # Results: # Returns a parse tree of the derivative. # # Applies the Chain Rule: D(acos(u))=-D(u)/sqrt(1 - u*u) # (Might it be better to factor 1-u*u into (1+u)(1-u)? Less likely to be # catastrophic cancellation if u is near 1?) proc {math::calculus::symdiff::differentiate::operator acos} {var u} { set du [eval [linsert $u 1 $var]] set result [MakeQuotient [MakeUnaryMinus $du] \ [MakeFunCall sqrt \ [MakeDifference [MakeConstant 1.0] \ [MakeProd $u $u]]]] return $result } # math::calculus::symdiff::differentiate::operator asin -- # # Differentiates the 'asin' function. # # Parameters: # var -- Variable to differentiate with respect to. # u -- Argument to the asin() function. # # Results: # Returns a parse tree of the derivative. # # Applies the Chain Rule: D(asin(u))=D(u)/sqrt(1 - u*u) # (Might it be better to factor 1-u*u into (1+u)(1-u)? Less likely to be # catastrophic cancellation if u is near 1?) proc {math::calculus::symdiff::differentiate::operator asin} {var u} { set du [eval [linsert $u 1 $var]] set result [MakeQuotient $du \ [MakeFunCall sqrt \ [MakeDifference [MakeConstant 1.0] \ [MakeProd $u $u]]]] return $result } # math::calculus::symdiff::differentiate::operator atan -- # # Differentiates the 'atan' function. # # Parameters: # var -- Variable to differentiate with respect to. # u -- Argument to the atan() function. # # Results: # Returns a parse tree of the derivative. # # Applies the Chain Rule: D(atan(u))=D(u)/(1 + $u*$u) proc {math::calculus::symdiff::differentiate::operator atan} {var u} { set du [eval [linsert $u 1 $var]] set result [MakeQuotient $du \ [MakeSum [MakeConstant 1.0] \ [MakeProd $u $u]]] } # math::calculus::symdiff::differentiate::operator atan2 -- # # Differentiates the 'atan2' function. # # Parameters: # var -- Variable to differentiate with respect to. # f, g -- Arguments to the atan() function. # # Results: # Returns a parse tree of the derivative. # # Applies the Chain and Quotient Rules: # D(atan2(f, g)) = (D(f)*g - D(g)*f)/(f*f + g*g) proc {math::calculus::symdiff::differentiate::operator atan2} {var f g} { set df [eval [linsert $f 1 $var]] set dg [eval [linsert $g 1 $var]] return [MakeQuotient \ [MakeDifference \ [MakeProd $df $g] \ [MakeProd $f $dg]] \ [MakeSum \ [MakeProd $f $f] \ [MakeProd $g $g]]] } # math::calculus::symdiff::differentiate::operator cos -- # # Differentiates the 'cos' function. # # Parameters: # var -- Variable to differentiate with respect to. # u -- Argument to the cos() function. # # Results: # Returns a parse tree of the derivative. # # Applies the Chain Rule: D(cos(u))=-sin(u)*D(u) proc {math::calculus::symdiff::differentiate::operator cos} {var u} { return [ChainRule $var MakeMinusSin $u] } proc math::calculus::symdiff::differentiate::MakeMinusSin {operand} { return [MakeUnaryMinus [MakeFunCall sin $operand]] } # math::calculus::symdiff::differentiate::operator cosh -- # # Differentiates the 'cosh' function. # # Parameters: # var -- Variable to differentiate with respect to. # u -- Argument to the cosh() function. # # Results: # Returns a parse tree of the derivative. # # Applies the Chain Rule: D(cosh(u))=sinh(u)*D(u) proc {math::calculus::symdiff::differentiate::operator cosh} {var u} { set result [ChainRule $var [list MakeFunCall sinh] $u] return $result } # math::calculus::symdiff::differentiate::operator exp -- # # Differentiate the exponential function # # Parameters: # var -- Variable to differentiate with respect to. # u -- Argument of the exponential function. # # Results: # Returns a parse tree of the derivative. # # Uses the Chain Rule D(exp(u)) = exp(u)*D(u). proc {math::calculus::symdiff::differentiate::operator exp} {var u} { set result [ChainRule $var [list MakeFunCall exp] $u] return $result } # math::calculus::symdiff::differentiate::operator hypot -- # # Differentiate the 'hypot' function # # Parameters: # var - Variable to differentiate with respect to. # f, g - Arguments to the 'hypot' function # # Results: # Returns a parse tree of the derivative # # Uses a number of algebraic simplifications to arrive at: # D(hypot(f,g)) = (f*D(f)+g*D(g))/hypot(f,g) proc {math::calculus::symdiff::differentiate::operator hypot} {var f g} { set df [eval [linsert $f 1 $var]] set dg [eval [linsert $g 1 $var]] return [MakeQuotient \ [MakeSum \ [MakeProd $df $f] \ [MakeProd $dg $g]] \ [MakeFunCall hypot $f $g]] } # math::calculus::symdiff::differentiate::operator log -- # # Differentiates a logarithm. # # Parameters: # var -- Variable to differentiate with respect to. # u -- Argument to the log() function. # # Results: # Returns a parse tree of the derivative. # # D(log(u))==D(u)/u proc {math::calculus::symdiff::differentiate::operator log} {var u} { set du [eval [linsert $u 1 $var]] set result [MakeQuotient $du $u] return $result } # math::calculus::symdiff::differentiate::operator log10 -- # # Differentiates a common logarithm. # # Parameters: # var -- Variable to differentiate with respect to. # u -- Argument to the log10() function. # # Results: # Returns a parse tree of the derivative. # # D(log(u))==D(u)/(u * log(10)) proc {math::calculus::symdiff::differentiate::operator log10} {var u} { set du [eval [linsert $u 1 $var]] set result [MakeQuotient $du \ [MakeProd [MakeConstant [expr log(10.)]] $u]] return $result } # math::calculus::symdiff::differentiate::operator ** -- # # Differentiate an exponential. # # Parameters: # var -- Variable to differentiate with respect to # f, g -- Base and exponent # # Results: # Returns the parse tree of the derivative. # # Handles the special case where g is constant as # D(f**g) == g*f**(g-1)*D(f) # Otherwise, uses the general power formula # D(f**g) == (f**g) * (((D(f)*g)/f) + (D(g)*log(f))) proc {math::calculus::symdiff::differentiate::operator **} {var f g} { set df [eval [linsert $f 1 $var]] if {[IsConstant $g]} { set gm1 [MakeConstant [expr {[ConstantValue $g] - 1}]] set result [MakeProd $df [MakeProd $g [MakePower $f $gm1]]] } else { set dg [eval [linsert $g 1 $var]] set result [MakeProd [MakePower $f $g] \ [MakeSum \ [MakeQuotient [MakeProd $df $g] $f] \ [MakeProd $dg [MakeFunCall log $f]]]] } return $result } interp alias {} {math::calculus::symdiff::differentiate::operator pow} \ {} {math::calculus::symdiff::differentiate::operator **} # math::calculus::symdiff::differentiate::operator sin -- # # Differentiates the 'sin' function. # # Parameters: # var -- Variable to differentiate with respect to. # u -- Argument to the sin() function. # # Results: # Returns a parse tree of the derivative. # # Applies the Chain Rule: D(sin(u))=cos(u)*D(u) proc {math::calculus::symdiff::differentiate::operator sin} {var u} { set result [ChainRule $var [list MakeFunCall cos] $u] return $result } # math::calculus::symdiff::differentiate::operator sinh -- # # Differentiates the 'sinh' function. # # Parameters: # var -- Variable to differentiate with respect to. # u -- Argument to the sinh() function. # # Results: # Returns a parse tree of the derivative. # # Applies the Chain Rule: D(sin(u))=cosh(u)*D(u) proc {math::calculus::symdiff::differentiate::operator sinh} {var u} { set result [ChainRule $var [list MakeFunCall cosh] $u] return $result } # math::calculus::symdiff::differentiate::operator sqrt -- # # Differentiate the 'sqrt' function. # # Parameters: # var -- Variable to differentiate with respect to # u -- Parameter of 'sqrt' as a parse tree. # # Results: # Returns a parse tree representing the derivative. # # D(sqrt(u))==D(u)/(2*sqrt(u)) proc {math::calculus::symdiff::differentiate::operator sqrt} {var u} { set du [eval [linsert $u 1 $var]] set result [MakeQuotient $du [MakeProd [MakeConstant 2.0] \ [MakeFunCall sqrt $u]]] return $result } # math::calculus::symdiff::differentiate::operator tan -- # # Differentiates the 'tan' function. # # Parameters: # var -- Variable to differentiate with respect to. # u -- Argument to the tan() function. # # Results: # Returns a parse tree of the derivative. # # Applies the Chain Rule: D(tan(u))=D(u)/(cos(u)*cos(u)) proc {math::calculus::symdiff::differentiate::operator tan} {var u} { set du [eval [linsert $u 1 $var]] set cosu [MakeFunCall cos $u] return [MakeQuotient $du [MakeProd $cosu $cosu]] } # math::calculus::symdiff::differentiate::operator tanh -- # # Differentiates the 'tanh' function. # # Parameters: # var -- Variable to differentiate with respect to. # u -- Argument to the tanh() function. # # Results: # Returns a parse tree of the derivative. # # Applies the Chain Rule: D(tanh(u))=D(u)/(cosh(u)*cosh(u)) proc {math::calculus::symdiff::differentiate::operator tanh} {var u} { set du [eval [linsert $u 1 $var]] set coshu [MakeFunCall cosh $u] return [MakeQuotient $du [MakeProd $coshu $coshu]] } # math::calculus::symdiff::MakeFunCall -- # # Makes a parse tree for a function call # # Parameters: # fun -- Name of the function to call # args -- Arguments to the function, expressed as parse trees # # Results: # Returns a parse tree for the result of calling the function. # # Performs the peephole optimization of replacing a function with # constant parameters with its value. proc math::calculus::symdiff::MakeFunCall {fun args} { set constant 1 set exp $fun append exp \( set sep "" foreach a $args { if {[IsConstant $a]} { append exp $sep [ConstantValue $a] set sep "," } else { set constant 0 break } } if {$constant} { append exp \) return [MakeConstant [expr $exp]] } set result [MakeOperator $fun] foreach arg $args { lappend result $arg } return $result } # math::calculus::symdiff::MakeSum -- # # Makes the parse tree for a sum. # # Parameters: # left, right -- Parse trees for augend and addend # # Results: # Returns the parse tree for the sum. # # Performs the following peephole optimizations: # (1) a + (-b) = a - b # (2) (-a) + b = b - a # (3) 0 + a = a # (4) a + 0 = a # (5) The sum of two constants may be reduced to a constant proc math::calculus::symdiff::MakeSum {left right} { if {[IsUnaryMinus $right]} { return [MakeDifference $left [UnaryMinusArg $right]] } if {[IsUnaryMinus $left]} { return [MakeDifference $right [UnaryMinusArg $left]] } if {[IsConstant $left]} { set v [ConstantValue $left] if {$v == 0} { return $right } elseif {[IsConstant $right]} { return [MakeConstant [expr {[ConstantValue $left] + [ConstantValue $right]}]] } } elseif {[IsConstant $right]} { set v [ConstantValue $right] if {$v == 0} { return $left } } set result [MakeOperator +] lappend result $left $right return $result } # math::calculus::symdiff::MakeDifference -- # # Makes the parse tree for a difference # # Parameters: # left, right -- Minuend and subtrahend, expressed as parse trees # # Results: # Returns a parse tree expressing the difference # # Performs the following peephole optimizations: # (1) a - (-b) = a + b # (2) -a - b = -(a + b) # (3) 0 - b = -b # (4) a - 0 = a # (5) The difference of any two constants can be reduced to a constant. proc math::calculus::symdiff::MakeDifference {left right} { if {[IsUnaryMinus $right]} { return [MakeSum $left [UnaryMinusArg $right]] } if {[IsUnaryMinus $left]} { return [MakeUnaryMinus [MakeSum [UnaryMinusArg $left] $right]] } if {[IsConstant $left]} { set v [ConstantValue $left] if {$v == 0} { return [MakeUnaryMinus $right] } elseif {[IsConstant $right]} { return [MakeConstant [expr {[ConstantValue $left] - [ConstantValue $right]}]] } } elseif {[IsConstant $right]} { set v [ConstantValue $right] if {$v == 0} { return $left } } set result [MakeOperator -] lappend result $left $right return $result } # math::calculus::symdiff::MakeProd -- # # Constructs the parse tree for a product, left*right. # # Parameters: # left, right - Multiplicand and multiplier # # Results: # Returns the parse tree for the result. # # Performs the following peephole optimizations. # (1) If either operand is a unary minus, it is hoisted out of the # expression. # (2) If either operand is the constant 0, the result is the constant 0 # (3) If either operand is the constant 1, the result is the other operand. # (4) If either operand is the constant -1, the result is unary minus # applied to the other operand # (5) If both operands are constant, the result is a constant containing # their product. proc math::calculus::symdiff::MakeProd {left right} { if {[IsUnaryMinus $left]} { return [MakeUnaryMinus [MakeProd [UnaryMinusArg $left] $right]] } if {[IsUnaryMinus $right]} { return [MakeUnaryMinus [MakeProd $left [UnaryMinusArg $right]]] } if {[IsConstant $left]} { set v [ConstantValue $left] if {$v == 0} { return [MakeConstant 0.0] } elseif {$v == 1} { return $right } elseif {$v == -1} { return [MakeUnaryMinus $right] } elseif {[IsConstant $right]} { return [MakeConstant [expr {[ConstantValue $left] * [ConstantValue $right]}]] } } elseif {[IsConstant $right]} { set v [ConstantValue $right] if {$v == 0} { return [MakeConstant 0.0] } elseif {$v == 1} { return $left } elseif {$v == -1} { return [MakeUnaryMinus $left] } } set result [MakeOperator *] lappend result $left $right return $result } # math::calculus::symdiff::MakeQuotient -- # # Makes a parse tree for a quotient, n/d # # Parameters: # n, d - Parse trees for numerator and denominator # # Results: # Returns the parse tree for the quotient. # # Performs peephole optimizations: # (1) If either operand is a unary minus, it is hoisted out. # (2) If the numerator is the constant 0, the result is the constant 0. # (3) If the demominator is the constant 1, the result is the numerator # (4) If the denominator is the constant -1, the result is the unary # negation of the numerator. # (5) If both numerator and denominator are constant, the result is # a constant representing their quotient. proc math::calculus::symdiff::MakeQuotient {n d} { if {[IsUnaryMinus $n]} { return [MakeUnaryMinus [MakeQuotient [UnaryMinusArg $n] $d]] } if {[IsUnaryMinus $d]} { return [MakeUnaryMinus [MakeQuotient $n [UnaryMinusArg $d]]] } if {[IsConstant $n]} { set v [ConstantValue $n] if {$v == 0} { return [MakeConstant 0.0] } elseif {[IsConstant $d]} { return [MakeConstant [expr {[ConstantValue $n] * [ConstantValue $d]}]] } } elseif {[IsConstant $d]} { set v [ConstantValue $d] if {$v == 0} { return -code error "requested expression will result in division by zero at run time" } elseif {$v == 1} { return $n } elseif {$v == -1} { return [MakeUnaryMinus $n] } } set result [MakeOperator /] lappend result $n $d return $result } # math::calculus::symdiff::MakePower -- # # Make a parse tree for an exponentiation operation # # Parameters: # a -- Base, expressed as a parse tree # b -- Exponent, expressed as a parse tree # # Results: # Returns a parse tree for the expression # # Performs peephole optimizations: # (1) The constant zero raised to any non-zero power is 0 # (2) The constant 1 raised to any power is 1 # (3) Any non-zero quantity raised to the zero power is 1 # (4) Any non-zero quantity raised to the first power is the base itself. # (5) MakeFunCall will optimize any other case of a constant raised # to a constant power. proc math::calculus::symdiff::MakePower {a b} { if {[IsConstant $a]} { if {[ConstantValue $a] == 0} { if {[IsConstant $b] && [ConstantValue $b] == 0} { error "requested expression will result in zero to zero power at run time" } return [MakeConstant 0.0] } elseif {[ConstantValue $a] == 1} { return [MakeConstant 1.0] } } if {[IsConstant $b]} { if {[ConstantValue $b] == 0} { return [MakeConstant 1.0] } elseif {[ConstantValue $b] == 1} { return $a } } return [MakeFunCall pow $a $b] } # math::calculus::symdiff::MakeUnaryMinus -- # # Makes the parse tree for a unary negation. # # Parameters: # operand -- Parse tree for the operand # # Results: # Returns the parse tree for the expression # # Performs the following peephole optimizations: # (1) -(-$a) = $a # (2) The unary negation of a constant is another constant proc math::calculus::symdiff::MakeUnaryMinus {operand} { if {[IsUnaryMinus $operand]} { return [UnaryMinusArg $operand] } if {[IsConstant $operand]} { return [MakeConstant [expr {-[ConstantValue $operand]}]] } else { return [list [list operator -] $operand] } } # math::calculus::symdiff::IsUnaryMinus -- # # Determines whether a parse tree represents a unary negation # # Parameters: # x - Parse tree to examine # # Results: # Returns 1 if the parse tree represents a unary minus, 0 otherwise proc math::calculus::symdiff::IsUnaryMinus {x} { return [expr {[llength $x] == 2 && [lindex $x 0] eq [list operator -]}] } # math::calculus::symdiff::UnaryMinusArg -- # # Extracts the argument from a unary negation. # # Parameters: # x - Parse tree to examine, known to represent a unary negation # # Results: # Returns a parse tree representing the operand. proc math::calculus::symdiff::UnaryMinusArg {x} { return [lindex $x 1] } # math::calculus::symdiff::MakeOperator -- # # Makes a partial parse tree for an operator # # Parameters: # op -- Name of the operator # # Results: # Returns the resulting parse tree. # # The caller may use [lappend] to place any needed operands proc math::calculus::symdiff::MakeOperator {op} { if {$op eq {?}} { return -code error "symdiff can't differentiate the ternary ?: operator" } elseif {[namespace which [list differentiate::operator $op]] ne {}} { return [list [list operator $op]] } elseif {[string is alnum $op] && ($op ni {eq ne in ni})} { return -code error "symdiff can't differentiate the \"$op\" function" } else { return -code error "symdiff can't differentiate the \"$op\" operator" } } # math::calculus::symdiff::MakeVariable -- # # Makes a partial parse tree for a single variable # # Parameters: # name -- Name of the variable # # Results: # Returns a partial parse tree giving the variable proc math::calculus::symdiff::MakeVariable {name} { return [list var $name] } # math::calculus::symdiff::MakeConstant -- # # Make the parse tree for a constant. # # Parameters: # value -- The constant's value # # Results: # Returns a parse tree. proc math::calculus::symdiff::MakeConstant {value} { return [list constant $value] } # math::calculus::symdiff::IsConstant -- # # Test if an expression represented by a parse tree is a constant. # # Parameters: # Item - Parse tree to test # # Results: # Returns 1 for a constant, 0 for anything else proc math::calculus::symdiff::IsConstant {item} { return [expr {[lindex $item 0] eq {constant}}] } # math::calculus::symdiff::ConstantValue -- # # Recovers a constant value from the parse tree representing a constant # expression. # # Parameters: # item -- Parse tree known to be a constant. # # Results: # Returns the constant value. proc math::calculus::symdiff::ConstantValue {item} { return [lindex $item 1] } # Define the parse tree fabrication routines in the 'differentiate' # namespace as well as the 'symdiff' namespace, without exporting them # from the package. interp alias {} math::calculus::symdiff::differentiate::IsConstant \ {} math::calculus::symdiff::IsConstant interp alias {} math::calculus::symdiff::differentiate::ConstantValue \ {} math::calculus::symdiff::ConstantValue interp alias {} math::calculus::symdiff::differentiate::MakeConstant \ {} math::calculus::symdiff::MakeConstant interp alias {} math::calculus::symdiff::differentiate::MakeDifference \ {} math::calculus::symdiff::MakeDifference interp alias {} math::calculus::symdiff::differentiate::MakeFunCall \ {} math::calculus::symdiff::MakeFunCall interp alias {} math::calculus::symdiff::differentiate::MakePower \ {} math::calculus::symdiff::MakePower interp alias {} math::calculus::symdiff::differentiate::MakeProd \ {} math::calculus::symdiff::MakeProd interp alias {} math::calculus::symdiff::differentiate::MakeQuotient \ {} math::calculus::symdiff::MakeQuotient interp alias {} math::calculus::symdiff::differentiate::MakeSum \ {} math::calculus::symdiff::MakeSum interp alias {} math::calculus::symdiff::differentiate::MakeUnaryMinus \ {} math::calculus::symdiff::MakeUnaryMinus interp alias {} math::calculus::symdiff::differentiate::MakeVariable \ {} math::calculus::symdiff::MakeVariable interp alias {} math::calculus::symdiff::differentiate::ExtractExpression \ {} math::calculus::symdiff::ExtractExpression tcllib-1.15/modules/math/numtheory.tcl0000644000175000017500000000466212077663116017407 0ustar sergeisergei## ## This is the file `numtheory.tcl', ## generated with the SAK utility ## (sak docstrip/regen). ## ## The original source files were: ## ## numtheory.dtx (with options: `pkg') ## ## In other words: ## ************************************** ## * This Source is not the True Source * ## ************************************** ## the true source is the file from which this one was generated. ## # Copyright (c) 2010 by Lars Hellstrom. All rights reserved. # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require Tcl 8.5 package provide math::numtheory 1.0 namespace eval ::math::numtheory { namespace export isprime } proc ::math::numtheory::prime_trialdivision {n} { if {$n<2} then {return -code return 0} if {$n<4} then {return -code return 1} if {$n%2 == 0} then {return -code return 0} if {$n<9} then {return -code return 1} if {$n%3 == 0} then {return -code return 0} if {$n%5 == 0} then {return -code return 0} if {$n%7 == 0} then {return -code return 0} if {$n<121} then {return -code return 1} } proc ::math::numtheory::Miller--Rabin {n s d a} { set x 1 while {$d>1} { if {$d & 1} then {set x [expr {$x*$a % $n}]} set a [expr {$a*$a % $n}] set d [expr {$d >> 1}] } set x [expr {$x*$a % $n}] if {$x == 1} then {return 0} for {} {$s>1} {incr s -1} { if {$x == $n-1} then {return 0} set x [expr {$x*$x % $n}] if {$x == 1} then {return 1} } return [expr {$x != $n-1}] } proc ::math::numtheory::isprime {n args} { prime_trialdivision $n set d [expr {$n-1}]; set s 0 while {($d&1) == 0} { incr s set d [expr {$d>>1}] } if {[Miller--Rabin $n $s $d 2]} then {return 0} if {$n < 2047} then {return 1} if {[Miller--Rabin $n $s $d 3]} then {return 0} if {$n < 1373653} then {return 1} if {[Miller--Rabin $n $s $d 5]} then {return 0} if {$n < 25326001} then {return 1} if {[Miller--Rabin $n $s $d 7] || $n==3215031751} then {return 0} if {$n < 118670087467} then {return 1} array set O {-randommr 4} array set O $args for {set i $O(-randommr)} {$i >= 1} {incr i -1} { if {[Miller--Rabin $n $s $d [expr {( (round(rand()*0x100000000)-1) *3 | 1) + 10 }]]} then {return 0} } return on } ## ## ## End of file `numtheory.tcl'.tcllib-1.15/modules/math/decimal.tcl0000755000175000017500000011553212077663116016755 0ustar sergeisergeipackage require Tcl 8.5 package provide math::decimal 1.0.2 # # Copyright 2011 Mark Alston. All rights reserved. # # Redistribution and use in source and binary forms, with or # without modification, are permitted provided that the following # conditions are met: # # 1. Redistributions of source code must retain the above copyright # notice, this list of conditions and the following disclaimer. # # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in # the documentation and/or other materials provided with the distribution. # # THIS SOFTWARE IS PROVIDED BY Mark Alston ``AS IS'' AND ANY EXPRESS # OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED # WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL Mark Alston OR CONTRIBUTORS # BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; # OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, # WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE # OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, # EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. # # # decimal.tcl -- # # Tcl implementation of a General Decimal Arithmetic as defined # by the IEEE 754 standard as given on http:://speleotrove.com/decimal # # Decimal numbers are defined as a list of sign mantissa exponent # # The following operations are current implemented: # # fromstr tostr -- for converting to and from decimal numbers. # # add subtract divide multiply abs compare -- basic operations # max min plus minus copynegate copysign is-zero is-signed # is-NaN is-infinite is-finite # # round_half_even round_half_up round_half_down -- rounding methods # round_down round_up round_floor round_ceiling # round_05up # # By setting the extended variable to 0 you get the behavior of the decimal # subset arithmetic X3.274 as defined on # http://speleotrove.com/decimal/dax3274.html#x3274 # # This package passes all tests in test suites: # http://speleotrove.com/decimal/dectest.html # and http://speleotrove.com/decimal/dectest0.html # # with the following exceptions: # # This version fails some tests that require setting the max # or min exponent to force truncation or rounding. # # This version fails some tests which require the sign of zero to be set # correctly during rounding # # This version cannot handle sNaN's (Not sure that they are of any use for # tcl programmers anyway. # # If you find errors in this code please let me know at # mark at beernut dot com # # Decimal -- # Namespace for the decimal arithmetic procedures # namespace eval ::math::decimal { variable precision 20 variable maxExponent 999 variable minExponent -998 variable tinyExponent [expr {$minExponent - ($precision - 1)}] variable rounding half_up variable extended 1 # Some useful variables to set. variable zero [list 0 0 0] variable one [list 0 1 0] variable ten [list 0 1 1] variable onehundred [list 0 1 2] variable minusone [list 1 1 0] namespace export tostr fromstr setVariable getVariable\ add + subtract - divide / multiply * \ divide-int remainder \ fma fused-multiply-add \ plus minus copynegate negate copysign \ abs compare max min \ is-zero is-signed is-NaN is-infinite is-finite \ round_half_even round_half_up round_half_down \ round_down round_up round_floor round_ceiling round_05up } # setVariable # Set the desired variable # # Arguments: # variable setting # # Result: # None # proc ::math::decimal::setVariable {variable setting} { variable rounding variable precision variable extended variable maxExponent variable minExponent variable tinyExponent switch -nocase -- $variable { rounding {set rounding $setting} precision {set precision $setting} extended {set extended $setting} maxExponent {set maxExponent $setting} minExponent { set minExponent $setting set tinyExponent [expr {$minExponent - ($precision - 1)}] } default {} } } # setVariable # Set the desired variable # # Arguments: # variable setting # # Result: # None # proc ::math::decimal::getVariable {variable} { variable rounding variable precision variable extended variable maxExponent variable minExponent switch -- $variable { rounding {return $rounding} precision {return $precision} extended {return $extended} maxExponent {return $maxExponent} minExponent {return $minExponent} default {} } } # add or + # Add two numbers # # Arguments: # a First operand # b Second operand # # Result: # Sum of both (rescaled) # proc ::math::decimal::add {a b {rescale 1}} { return [+ $a $b $rescale] } proc ::math::decimal::+ {a b {rescale 1}} { variable extended variable rounding foreach {sa ma ea} $a {break} foreach {sb mb eb} $b {break} if {!$extended} { if {$ma == 0 } { return $b } if {$mb == 0 } { return $a } } if { $ma eq "NaN" || $mb eq "NaN" } { return [list 0 "NaN" 0] } if { $ma eq "Inf" || $mb eq "Inf" } { if { $ma ne "Inf" } { return $b } elseif { $mb ne "Inf" } { return $a } elseif { $sb != $sa } { return [list 0 "NaN" 0] } else { return $a } } if { $ea > $eb } { set ma [expr {$ma * 10 ** ($ea-$eb)}] set er $eb } else { set mb [expr {$mb * 10 ** ($eb-$ea)}] set er $ea } if { $sa == $sb } { # Both are either postive or negative # Sign remains the same. set mr [expr {$ma + $mb}] set sr $sa } else { # one is negative and one is positive. # Set sign to the same as the larger number # and subract the smaller from the larger. if { $ma > $mb } { set sr $sa set mr [expr {$ma - $mb}] } elseif { $mb > $ma } { set sr $sb set mr [expr {$mb - $ma}] } else { if { $rounding == "floor" } { set sr 1 } else { set sr 0 } set mr 0 } } if { $rescale } { return [Rescale [list $sr $mr $er]] } else { return [list $sr $mr $er] } } # copynegate -- # Takes one operand and returns a copy with the sign inverted. # In this implementation it works nearly the same as minus # but is probably much faster. The main difference is that no # rescaling is done. # # # Arguments: # a operand # # Result: # a with sign flipped # proc ::math::decimal::negate { a } { return [copynegate $a] } proc ::math::decimal::copynegate { a } { lset a 0 [expr {![lindex $a 0]}] return $a } # copysign -- # Takes two operands and returns a copy of the first with the # sign set to the sign of the second. # # # Arguments: # a operand # b operand # # Result: # b with a's sign # proc ::math::decimal::copysign { a b } { lset a 0 [lindex $b 0] return $a } # minus -- # subtract 0 $a # # Note: does not pass all tests on extended mode. # # Arguments: # a operand # # Result: # 0 - $a # proc ::math::decimal::minus { a } { return [- [list 0 0 0] $a] } # plus -- # add 0 $a # # Note: does not pass all tests on extended mode. # # Arguments: # a operand # # Result: # 0 + $a # proc ::math::decimal::plus {a} { return [+ [list 0 0 0] $a] } # subtract or - # Subtract two numbers (or unary minus) # # Arguments: # a First operand # b Second operand (optional) # # Result: # Sum of both (rescaled) # proc ::math::decimal::subtract {a {b {}} {rescale 1}} { return [- $a $b] } proc ::math::decimal::- {a {b {}} {rescale 1}} { variable extended if {!$extended} { foreach {sa ma ea} $a {break} foreach {sb mb eb} $b {break} if {$ma == 0 } { lset b 0 [expr {![lindex $b 0]}] return $b } if {$mb == 0 } { return $a } } if { $b == {} } { lset a 0 [expr {![lindex $a 0]}] return $a } else { lset b 0 [expr {![lindex $b 0]}] return [+ $a $b $rescale] } } # compare # Compare two numbers. # # Arguments: # a First operand # b Second operand # # Result: # 1 if a is larger than b # 0 if a is equal to b # -1 if a is smaller than b. # proc ::math::decimal::compare {a b} { foreach {sa ma ea} $a {break} foreach {sb mb eb} $b {break} if { $sa != $sb } { if {$ma != 0 } { set ma 1 set ea 0 } elseif { $mb != 0 } { set mb 1 set eb 0 } else { return 0 } } if { $ma eq "Inf" && $mb eq "Inf" } { if { $sa == $sb } { return 0 } elseif { $sa > $sb } { return -1 } else { return 1 } } set comparison [- [list $sa $ma $ea] [list $sb $mb $eb] 0] if { [lindex $comparison 0] && [lindex $comparison 1] != 0 } { return -1 } elseif { [lindex $comparison 1] == 0 } { return 0 } else { return 1 } } # min # Return the smaller of two numbers # # Arguments: # a First operand # b Second operand # # Result: # smaller of a or b # proc ::math::decimal::min {a b} { foreach {sa ma ea} $a {break} foreach {sb mb eb} $b {break} if { $sa != $sb } { if {$ma != 0 } { set ma 1 set ea 0 } elseif { $mb != 0 } { set mb 1 set eb 0 } } if { $ma eq "Inf" && $mb eq "Inf" } { if { $sa == $sb } { return [list $sa "Inf" 0] } else { return [list 1 "Inf" 0] } } set comparison [compare [list $sa $ma $ea] [list $sb $mb $eb]] if { $comparison == 1 } { return [Rescale $b] } elseif { $comparison == -1 } { return [Rescale $a] } elseif { $sb != $sa } { if { $sa } { return [Rescale $a] } else { return [Rescale $b] } } elseif { $sb && $eb > $ea } { # Both are negative and the same numerically. So return the one with the largest exponent. return [Rescale $b] } elseif { $sb } { # Negative with $eb < $ea now. return [Rescale $a] } elseif { $ea > $eb } { # Both are positive so return the one with the smaller return [Rescale $b] } else { return [Rescale $a] } } # max # Return the larger of two numbers # # Arguments: # a First operand # b Second operand # # Result: # larger of a or b # proc ::math::decimal::max {a b} { foreach {sa ma ea} $a {break} foreach {sb mb eb} $b {break} if { $sa != $sb } { if {$ma != 0 } { set ma 1 set ea 0 } elseif { $mb != 0 } { set mb 1 set eb 0 } } if { $ma eq "Inf" && $mb eq "Inf" } { if { $sa == $sb } { return [list $sa "Inf" 0] } else { return [list 0 "Inf" 0] } } set comparison [compare [list $sa $ma $ea] [list $sb $mb $eb]] if { $comparison == 1 } { return [Rescale $a] } elseif { $comparison == -1 } { return [Rescale $b] } elseif { $sb != $sa } { if { $sa } { return [Rescale $b] } else { return [Rescale $a] } } elseif { $sb && $eb > $ea } { # Both are negative and the same numerically. So return the one with the smallest exponent. return [Rescale $a] } elseif { $sb } { # Negative with $eb < $ea now. return [Rescale $b] } elseif { $ea > $eb } { # Both are positive so return the one with the larger exponent return [Rescale $a] } else { return [Rescale $b] } } # maxmag -- max-magnitude # Return the larger of two numbers ignoring their signs. # # Arguments: # a First operand # b Second operand # # Result: # larger of a or b ignoring their signs. # proc ::math::decimal::maxmag {a b} { foreach {sa ma ea} $a {break} foreach {sb mb eb} $b {break} if { $ma eq "Inf" && $mb eq "Inf" } { if { $sa == 0 || $sb == 0 } { return [list 0 "Inf" 0] } else { return [list 1 "Inf" 0] } } set comparison [compare [list 0 $ma $ea] [list 0 $mb $eb]] if { $comparison == 1 } { return [Rescale $a] } elseif { $comparison == -1 } { return [Rescale $b] } elseif { $sb != $sa } { if { $sa } { return [Rescale $b] } else { return [Rescale $a] } } elseif { $sb && $eb > $ea } { # Both are negative and the same numerically. So return the one with the smallest exponent. return [Rescale $a] } elseif { $sb } { # Negative with $eb < $ea now. return [Rescale $b] } elseif { $ea > $eb } { # Both are positive so return the one with the larger exponent return [Rescale $a] } else { return [Rescale $b] } } # minmag -- min-magnitude # Return the smaller of two numbers ignoring their signs. # # Arguments: # a First operand # b Second operand # # Result: # smaller of a or b ignoring their signs. # proc ::math::decimal::minmag {a b} { foreach {sa ma ea} $a {break} foreach {sb mb eb} $b {break} if { $ma eq "Inf" && $mb eq "Inf" } { if { $sa == 1 || $sb == 1 } { return [list 1 "Inf" 0] } else { return [list 0 "Inf" 0] } } set comparison [compare [list 0 $ma $ea] [list 0 $mb $eb]] if { $comparison == 1 } { return [Rescale $b] } elseif { $comparison == -1 } { return [Rescale $a] } else { # They compared the same so now we use a normal comparison including the signs. This is per the specs. if { $sa > $sb } { return [Rescale $a] } elseif { $sb > $sa } { return [Rescale $b] } elseif { $sb && $eb > $ea } { # Both are negative and the same numerically. So return the one with the largest exponent. return [Rescale $b] } elseif { $sb } { # Negative with $eb < $ea now. return [Rescale $a] } elseif { $ea > $eb } { return [Rescale $b] } else { return [Rescale $a] } } } # fma - fused-multiply-add # Takes three operands. Multiplies the first two and then adds the third. # Only one rounding (Rescaling) takes place at the end instead of after # both the multiplication and again after the addition. # # Arguments: # a First operand # b Second operand # c Third operand # # Result: # (a*b)+c # proc ::math::decimal::fused-multiply-add {a b c} { return [fma $a $b $c] } proc ::math::decimal::fma {a b c} { return [+ $c [* $a $b 0]] } # multiply or * # Multiply two numbers # # Arguments: # a First operand # b Second operand # # Result: # Product of both (rescaled) # proc ::math::decimal::multiply {a b {rescale 1}} { return [* $a $b $rescale] } proc ::math::decimal::* {a b {rescale 1}} { foreach {sa ma ea} $a {break} foreach {sb mb eb} $b {break} if { $ma eq "NaN" || $mb eq "NaN" } { return [list 0 "NaN" 0] } set sr [expr {$sa^$sb}] if { $ma eq "Inf" || $mb eq "Inf" } { if { $ma == 0 || $mb == 0 } { return [list 0 "NaN" 0] } else { return [list $sr "Inf" 0] } } set mr [expr {$ma * $mb}] set er [expr {$ea + $eb}] if { $rescale } { return [Rescale [list $sr $mr $er]] } else { return [list $sr $mr $er] } } # divide or / # Divide two numbers # # Arguments: # a First operand # b Second operand # # Result: # Quotient of both (rescaled) # proc ::math::decimal::divide {a b {rescale 1}} { return [/ $a $b] } proc ::math::decimal::/ {a b {rescale 1}} { variable precision foreach {sa ma ea} $a {break} foreach {sb mb eb} $b {break} if { $ma eq "NaN" || $mb eq "NaN" } { return [list 0 "NaN" 0] } set sr [expr {$sa^$sb}] if { $ma eq "Inf" } { if { $mb ne "Inf"} { return [list $sr "Inf" 0] } else { return [list 0 "NaN" 0] } } if { $mb eq "Inf" } { if { $ma ne "Inf"} { return [list $sr 0 0] } else { return [list 0 "NaN" 0] } } if { $mb == 0 } { if { $ma == 0 } { return [list 0 "NaN" 0] } else { return [list $sr "Inf" 0] } } set adjust 0 set mr 0 if { $ma == 0 } { set er [expr {$ea - $eb}] return [list $sr 0 $er] } if { $ma < $mb } { while { $ma < $mb } { set ma [expr {$ma * 10}] incr adjust } } elseif { $ma >= $mb * 10 } { while { $ma >= [expr {$mb * 10}] } { set mb [expr {$mb * 10}] incr adjust -1 } } while { 1 } { while { $mb <= $ma } { set ma [expr {$ma - $mb}] incr mr } if { ( $ma == 0 && $adjust >= 0 ) || [string length $mr] > $precision + 1 } { break } else { set ma [expr {$ma * 10}] set mr [expr {$mr * 10}] incr adjust } } set er [expr {$ea - ($eb + $adjust)}] if { $rescale } { return [Rescale [list $sr $mr $er]] } else { return [list $sr $mr $er] } } # divideint -- Divide integer # Divide a by b and return the integer part of the division. # # Basically, if we send a and b to the divideint (which returns i) # and remainder function (which returns r) then the following is true: # a = i*b + r # # Arguments: # a First operand # b Second operand # # proc ::math::decimal::divideint { a b } { foreach {sa ma ea} $a {break} foreach {sb mb eb} $b {break} set sr [expr {$sa^$sb}] if { $sr == 1 } { set sign_string "-" } else { set sign_string "" } if { ($ma eq "NaN" || $mb eq "NaN") || ($ma == 0 && $mb == 0 ) } { return "NaN" } if { $ma eq "Inf" || $mb eq "Inf" } { if { $ma eq $mb } { return "NaN" } elseif { $mb eq "Inf" } { return "${sign_string}0" } else { return "${sign_string}Inf" } } if { $mb == 0 } { return "${sign_string}Inf" } if { $mb == "Inf" } { return "${sign_string}0" } set adjust [expr {abs($ea - $eb)}] if { $ea < $eb } { set a_adjust 0 set b_adjust $adjust } elseif { $ea > $eb } { set b_adjust 0 set a_adjust $adjust } else { set a_adjust 0 set b_adjust 0 } set integer [expr {($ma*10**$a_adjust)/($mb*10**$b_adjust)}] return $sign_string$integer } # remainder -- Remainder from integer division. # Divide a by b and return the remainder part of the division. # # Basically, if we send a and b to the divideint (which returns i) # and remainder function (which returns r) then the following is true: # a = i*b + r # # Arguments: # a First operand # b Second operand # # proc ::math::decimal::remainder { a b } { foreach {sa ma ea} $a {break} foreach {sb mb eb} $b {break} if { $sa == 1 } { set sign_string "-" } else { set sign_string "" } if { ($ma eq "NaN" || $mb eq "NaN") || ($ma == 0 && $mb == 0 ) } { if { $mb eq "NaN" && $mb ne $ma } { if { $sb == 1 } { set sign_string "-" } else { set sign_string "" } return "${sign_string}NaN" } elseif { $ma eq "NaN" } { return "${sign_string}NaN" } else { return "NaN" } } elseif { $mb == 0 } { return "NaN" } if { $ma eq "Inf" || $mb eq "Inf" } { if { $ma eq $mb } { return "NaN" } elseif { $mb eq "Inf" } { return [tostr $a] } else { return "NaN" } } if { $mb == 0 } { return "${sign_string}Inf" } if { $mb == "Inf" } { return "${sign_string}0" } lset a 0 0 lset b 0 0 if { $mb == 0 } { return "${sign_string}Inf" } if { $mb == "Inf" } { return "${sign_string}0" } set adjust [expr {abs($ea - $eb)}] if { $ea < $eb } { set a_adjust 0 set b_adjust $adjust } elseif { $ea > $eb } { set b_adjust 0 set a_adjust $adjust } else { set a_adjust 0 set b_adjust 0 } set integer [expr {($ma*10**$a_adjust)/($mb*10**$b_adjust)}] set remainder [tostr [- $a [* [fromstr $integer] $b 0]]] return $sign_string$remainder } # abs -- # Returns the Absolute Value of a number # # Arguments: # Number in the form of {sign mantisse exponent} # # Result: # Absolute value (as a list) # proc ::math::decimal::abs {a} { lset a 0 0 return [Rescale $a] } # Rescale -- # Rescale the number (using proper rounding) # # Arguments: # a Number in decimal format # # Result: # Rescaled number # proc ::math::decimal::Rescale { a } { variable precision variable rounding variable maxExponent variable minExponent variable tinyExponent foreach {sign mantisse exponent} $a {break} set man_length [string length $mantisse] set adjusted_exponent [expr {$exponent + ($man_length -1)}] if { $adjusted_exponent < $tinyExponent } { set mantisse [lindex [round_$rounding [list $sign $mantisse [expr {abs($tinyExponent) - abs($adjusted_exponent)}]] 0] 1] return [list $sign $mantisse $tinyExponent] } elseif { $adjusted_exponent > $maxExponent } { if { $mantisse == 0 } { return [list $sign 0 $maxExponent] } else { switch -- $rounding { half_even - half_up { return [list $sign "Inf" 0] } down - 05up { return [list $sign [string repeat 9 $precision] $maxExponent] } ceiling { if { $sign } { return [list $sign [string repeat 9 $precision] $maxExponent] } else { return [list 0 "Inf" 0] } } floor { if { !$sign } { return [list $sign [string repeat 9 $precision] $maxExponent] } else { return [list 1 "Inf" 0] } } default { } } } } if { $man_length <= $precision } { return [list $sign $mantisse $exponent] } set mantisse [lindex [round_$rounding [list $sign $mantisse [expr {$precision - $man_length}]] 0] 1] set exponent [expr {$exponent + ($man_length - $precision)}] # it is possible now that our rounding gave us a new digit in our mantisse # example rounding 999.9 to 1 digits with precision 3 will give us # 1000 back. # This can only happen by adding a zero on the end of our mantisse however. # So we just chomp it off. set man_length_now [string length $mantisse] if { $man_length_now > $precision } { set mantisse [string range $mantisse 0 end-1] incr exponent # Check again to see if we have overflowed # we change our test to >= because we have incremented exponent. if { $adjusted_exponent >= $maxExponent } { switch -- $rounding { half_even - half_up { return [list $sign "Inf" 0] } down - 05up { return [list $sign [string repeat 9 $precision] $maxExponent] } ceiling { if { $sign } { return [list $sign [string repeat 9 $precision] $maxExponent] } else { return [list 0 "Inf" 0] } } floor { if { !$sign } { return [list $sign [string repeat 9 $precision] $maxExponent] } else { return [list 1 "Inf" 0] } } default { } } } } return [list $sign $mantisse $exponent] } # tostr -- # Convert number to string using appropriate method depending on extended # attribute setting. # # Arguments: # number Number to be converted # # Result: # Number in the form of a string # proc ::math::decimal::tostr { number } { variable extended switch -- $extended { 0 { return [tostr_numeric $number] } 1 { return [tostr_scientific $number] } } } # tostr_scientific -- # Convert number to string using scientific notation as called for in # Decmath specifications. # # Arguments: # number Number to be converted # # Result: # Number in the form of a string # proc ::math::decimal::tostr_scientific {number} { foreach {sign mantisse exponent} $number {break} if { $sign } { set sign_string "-" } else { set sign_string "" } if { $mantisse eq "NaN" } { return "NaN" } if { $mantisse eq "Inf" } { return ${sign_string}${mantisse} } set digits [string length $mantisse] set adjusted_exponent [expr {$exponent + $digits - 1}] # Why -6? Go read the specs on the website mentioned in the header. # They choose it, I'm using it. They actually list some good reasons though. if { $exponent <= 0 && $adjusted_exponent >= -6 } { if { $exponent == 0 } { set string $mantisse } else { set exponent [expr {abs($exponent)}] if { $digits > $exponent } { set string [string range $mantisse 0 [expr {$digits-$exponent-1}]].[string range $mantisse [expr {$digits-$exponent}] end] set exponent [expr {-$exponent}] } else { set string 0.[string repeat 0 [expr {$exponent-$digits}]]$mantisse } } } elseif { $exponent <= 0 && $adjusted_exponent < -6 } { if { $digits > 1 } { set string [string range $mantisse 0 0].[string range $mantisse 1 end] set exponent [expr {$exponent + $digits - 1}] set string "${string}E${exponent}" } else { set string "${mantisse}E${exponent}" } } else { if { $adjusted_exponent >= 0 } { set adjusted_exponent "+$adjusted_exponent" } if { $digits > 1 } { set string "[string range $mantisse 0 0].[string range $mantisse 1 end]E$adjusted_exponent" } else { set string "${mantisse}E$adjusted_exponent" } } return $sign_string$string } # tostr_numeric -- # Convert number to string using the simplified number set conversion # from the X3.274 subset of Decimal Arithmetic specifications. # # Arguments: # number Number to be converted # # Result: # Number in the form of a string # proc ::math::decimal::tostr_numeric {number} { variable precision foreach {sign mantisse exponent} $number {break} if { $sign } { set sign_string "-" } else { set sign_string "" } if { $mantisse eq "NaN" } { return "NaN" } if { $mantisse eq "Inf" } { return ${sign_string}${mantisse} } set digits [string length $mantisse] set adjusted_exponent [expr {$exponent + $digits - 1}] if { $mantisse == 0 } { set string 0 set sign_string "" } elseif { $exponent <= 0 && $adjusted_exponent >= -6 } { if { $exponent == 0 } { set string $mantisse } else { set exponent [expr {abs($exponent)}] if { $digits > $exponent } { set string [string range $mantisse 0 [expr {$digits-$exponent-1}]] set decimal_part [string range $mantisse [expr {$digits-$exponent}] end] set string ${string}.${decimal_part} set exponent [expr {-$exponent}] } else { set string 0.[string repeat 0 [expr {$exponent-$digits}]]$mantisse } } } elseif { $exponent <= 0 && $adjusted_exponent < -6 } { if { $digits > 1 } { set string [string range $mantisse 0 0].[string range $mantisse 1 end] set exponent [expr {$exponent + $digits - 1}] set string "${string}E${exponent}" } else { set string "${mantisse}E${exponent}" } } else { if { $adjusted_exponent >= 0 } { set adjusted_exponent "+$adjusted_exponent" } if { $digits > 1 && $adjusted_exponent >= $precision } { set string "[string range $mantisse 0 0].[string range $mantisse 1 end]E$adjusted_exponent" } elseif { $digits + $exponent <= $precision } { set string ${mantisse}[string repeat 0 [expr {$exponent}]] } else { set string "${mantisse}E$adjusted_exponent" } } return $sign_string$string } # fromstr -- # Convert string to number # # Arguments: # string String to be converted # # Result: # Number in the form of {sign mantisse exponent} # proc ::math::decimal::fromstr {string} { variable extended set string [string trim $string "'\""] if { [string range $string 0 0] == "-" } { set sign 1 set string [string trimleft $string -] incr pos -1 } else { set sign 0 } if { $string eq "Inf" || $string eq "NaN" } { if {!$extended} { # we don't allow these strings in the subset arithmetic. # throw error. error "Infinities and NaN's not allowed in simplified decimal arithmetic" } else { return [list $sign $string 0] } } set string [string trimleft $string "+-"] set echeck [string first "E" [string toupper $string]] set epart 0 if { $echeck >= 0 } { set epart [string range $string [expr {$echeck+1}] end] set string [string range $string 0 [expr {$echeck -1}]] } set pos [string first . $string] if { $pos < 0 } { if { $string == 0 } { set mantisse 0 if { !$extended } { set sign 0 } } else { set mantisse $string } set exponent 0 } else { if { $string == "" } { return [list 0 0 0] } else { #stripping the leading zeros here is required to avoid some octal issues. #However, it causes us to fail some tests with numbers like 0.00 and 0.0 #which test differently but we can't deal with now. set mantisse [string trimleft [string map {. ""} $string] 0] if { $mantisse == "" } { set mantisse 0 if {!$extended} { set sign 0 } } set fraction [string range $string [expr {$pos+1}] end] set exponent [expr {-[string length $fraction]}] } } set exponent [expr {$exponent + $epart}] if { $extended } { return [list $sign $mantisse $exponent] } else { return [Rescale [list $sign $mantisse $exponent]] } } # ipart -- # Return the integer part of a Decimal Number # # Arguments: # Number in the form of {sign mantisse exponent} # # # Result: # Integer # proc ::math::decimal::ipart { a } { foreach {sa ma ea} $a {break} if { $ea == 0 } { if { $sa } { return -$ma } else { return $ma } } elseif { $ea > 0 } { if { $sa } { return [expr {-1 * $ma * 10**$ea}] } else { return [expr {$ma * 10**$ea}] } } else { if { [string length $ma] <= abs($ea) } { return 0 } else { if { $sa } { set string_sign "-" } else { set string_sign "" } set ea [expr {abs($ea)}] return "${string_sign}[string range $ma 0 end-$ea]" } } } # round_05_up -- # Round zero or five away from 0. # The same as round-up, except that rounding up only occurs # if the digit to be rounded up is 0 or 5, and after overflow # the result is the same as for round-down. # # Bias: away from zero # # Arguments: # Number in the form of {sign mantisse exponent} # Number of decimal points to round to. # # Result: # Number in the form of {sign mantisse exponent} # proc ::math::decimal::round_05up {a digits} { foreach {sa ma ea} $a {break} if { -$ea== $digits } { return $a } elseif { $digits + $ea > 0 } { set mantissa [expr { $ma * 10**($digits+$ea) }] } else { set round_exponent [expr {$digits + $ea}] if { [string length $ma] <= $round_exponent } { if { $ma != 0 } { set mantissa 1 } else { set mantissa 0 } set exponent 0 } else { set integer_part [ipart [list 0 $ma $round_exponent]] if { [compare [list 0 $ma $round_exponent] [list 0 ${integer_part}0 -1]] == 0 } { # We are rounding something with fractional part .0 set mantissa $integer_part } elseif { [string index $integer_part end] eq 0 || [string index $integer_part end] eq 5 } { set mantissa [expr {$integer_part + 1}] } else { set mantissa $integer_part } set exponent [expr {-1 * $digits}] } } return [list $sa $mantissa $exponent] } # round_half_up -- # # Round to the nearest. If equidistant, round up. # # # Bias: away from zero # # Arguments: # Number in the form of {sign mantisse exponent} # Number of decimal points to round to. # # Result: # Number in the form of {sign mantisse exponent} # proc ::math::decimal::round_half_up {a digits} { foreach {sa ma ea} $a {break} if { $digits + $ea == 0 } { return $a } elseif { $digits + $ea > 0 } { set mantissa [expr {$ma *10 **($digits+$ea)}] } else { set round_exponent [expr {$digits + $ea}] set integer_part [ipart [list 0 $ma $round_exponent]] switch -- [compare [list 0 $ma $round_exponent] [list 0 ${integer_part}5 -1]] { 0 { # We are rounding something with fractional part .5 set mantissa [expr {$integer_part + 1}] } -1 { set mantissa $integer_part } 1 { set mantissa [expr {$integer_part + 1}] } } } set exponent [expr {-1 * $digits}] return [list $sa $mantissa $exponent] } # round_half_even -- # Round to the nearest. If equidistant, round so the final digit is even. # Bias: none # # Arguments: # Number in the form of {sign mantisse exponent} # Number of decimal points to round to. # # Result: # Number in the form of {sign mantisse exponent} # proc ::math::decimal::round_half_even {a digits} { foreach {sa ma ea} $a {break} if { $digits + $ea == 0 } { return $a } elseif { $digits + $ea > 0 } { set mantissa [expr {$ma * 10**($digits+$ea)}] } else { set round_exponent [expr {$digits + $ea}] set integer_part [ipart [list 0 $ma $round_exponent]] switch -- [compare [list 0 $ma $round_exponent] [list 0 ${integer_part}5 -1]] { 0 { # We are rounding something with fractional part .5 if { $integer_part % 2 } { # We are odd so round up set mantissa [expr {$integer_part + 1}] } else { # We are even so round down set mantissa $integer_part } } -1 { set mantissa $integer_part } 1 { set mantissa [expr {$integer_part + 1}] } } } set exponent [expr {-1 * $digits}] return [list $sa $mantissa $exponent] } # round_half_down -- # # Round to the nearest. If equidistant, round down. # # Bias: towards zero # # Arguments: # Number in the form of {sign mantisse exponent} # Number of decimal points to round to. # # Result: # Number in the form of {sign mantisse exponent} # proc ::math::decimal::round_half_down {a digits} { foreach {sa ma ea} $a {break} if { $digits + $ea == 0 } { return $a } elseif { $digits + $ea > 0 } { set mantissa [expr {$ma * 10**($digits+$ea)}] } else { set round_exponent [expr {$digits + $ea}] set integer_part [ipart [list 0 $ma $round_exponent]] switch -- [compare [list 0 $ma $round_exponent] [list 0 ${integer_part}5 -1]] { 0 { # We are rounding something with fractional part .5 # The rule is to round half down. set mantissa $integer_part } -1 { set mantissa $integer_part } 1 { set mantissa [expr {$integer_part + 1}] } } } set exponent [expr {-1 * $digits}] return [list $sa $mantissa $exponent] } # round_down -- # # Round toward 0. (Truncate) # # Bias: towards zero # # Arguments: # Number in the form of {sign mantisse exponent} # Number of decimal points to round to. # # Result: # Number in the form of {sign mantisse exponent} # proc ::math::decimal::round_down {a digits} { foreach {sa ma ea} $a {break} if { -$ea== $digits } { return $a } elseif { $digits + $ea > 0 } { set mantissa [expr { $ma * 10**($digits+$ea) }] } else { set round_exponent [expr {$digits + $ea}] set mantissa [ipart [list 0 $ma $round_exponent]] } set exponent [expr {-1 * $digits}] return [list $sa $mantissa $exponent] } # round_floor -- # # Round toward -Infinity. # # Bias: down toward -Inf. # # Arguments: # Number in the form of {sign mantisse exponent} # Number of decimal points to round to. # # Result: # Number in the form of {sign mantisse exponent} # proc ::math::decimal::round_floor {a digits} { foreach {sa ma ea} $a {break} if { -$ea== $digits } { return $a } elseif { $digits + $ea > 0 } { set mantissa [expr { $ma * 10**($digits+$ea) }] } else { set round_exponent [expr {$digits + $ea}] if { $ma == 0 } { set mantissa 0 } elseif { !$sa } { set mantissa [ipart [list 0 $ma $round_exponent]] } else { set mantissa [expr {[ipart [list 0 $ma $round_exponent]] + 1}] } } set exponent [expr {-1 * $digits}] return [list $sa $mantissa $exponent] } # round_up -- # # Round away from 0 # # Bias: away from 0 # # Arguments: # Number in the form of {sign mantisse exponent} # Number of decimal points to round to. # # Result: # Number in the form of {sign mantisse exponent} # proc ::math::decimal::round_up {a digits} { foreach {sa ma ea} $a {break} if { -$ea== $digits } { return $a } elseif { $digits + $ea > 0 } { set mantissa [expr { $ma * 10**($digits+$ea) }] } else { set round_exponent [expr {$digits + $ea}] if { [string length $ma] <= $round_exponent } { if { $ma != 0 } { set mantissa 1 } else { set mantissa 0 } set exponent 0 } else { set integer_part [ipart [list 0 $ma $round_exponent]] switch -- [compare [list 0 $ma $round_exponent] [list 0 ${integer_part}0 -1]] { 0 { # We are rounding something with fractional part .0 set mantissa $integer_part } default { set mantissa [expr {$integer_part + 1}] } } set exponent [expr {-1 * $digits}] } } return [list $sa $mantissa $exponent] } # round_ceiling -- # # Round toward Infinity # # Bias: up toward Inf. # # Arguments: # Number in the form of {sign mantisse exponent} # Number of decimal points to round to. # # Result: # Number in the form of {sign mantisse exponent} # proc ::math::decimal::round_ceiling {a digits} { foreach {sa ma ea} $a {break} if { -$ea== $digits } { return $a } elseif { $digits + $ea > 0 } { set mantissa [expr { $ma * 10**($digits+$ea) }] } else { set round_exponent [expr {$digits + $ea}] if { [string length $ma] <= $round_exponent } { if { $ma != 0 } { set mantissa 1 } else { set mantissa 0 } set exponent 0 } else { set integer_part [ipart [list 0 $ma $round_exponent]] switch -- [compare [list 0 $ma $round_exponent] [list 0 ${integer_part}0 -1]] { 0 { # We are rounding something with fractional part .0 set mantissa $integer_part } default { if { $sa } { set mantissa [expr {$integer_part}] } else { set mantissa [expr {$integer_part + 1}] } } } set exponent [expr {-1 * $digits}] } } return [list $sa $mantissa $exponent] } # is-finite # # Takes one operand and returns: 1 if neither Inf or Nan otherwise 0. # # # Arguments: # a - decimal number # # Returns: # proc ::math::decimal::is-finite { a } { set mantissa [lindex $a 1] if { $mantissa == "Inf" || $mantissa == "NaN" } { return 0 } else { return 1 } } # is-infinite # # Takes one operand and returns: 1 if Inf otherwise 0. # # # Arguments: # a - decimal number # # Returns: # proc ::math::decimal::is-infinite { a } { set mantissa [lindex $a 1] if { $mantissa == "Inf" } { return 1 } else { return 0 } } # is-NaN # # Takes one operand and returns: 1 if NaN otherwise 0. # # # Arguments: # a - decimal number # # Returns: # proc ::math::decimal::is-NaN { a } { set mantissa [lindex $a 1] if { $mantissa == "NaN" } { return 1 } else { return 0 } } # is-signed # # Takes one operand and returns: 1 if sign is 1 (negative). # # # Arguments: # a - decimal number # # Returns: # proc ::math::decimal::is-signed { a } { set sign [lindex $a 0] if { $sign } { return 1 } else { return 0 } } # is-zero # # Takes one operand and returns: 1 if operand is zero otherwise 0. # # # Arguments: # a - decimal number # # Returns: # proc ::math::decimal::is-zero { a } { set mantisse [lindex $a 1] if { $mantisse == 0 } { return 1 } else { return 0 } } tcllib-1.15/modules/math/fuzzy.eps.f900000755000175000017500000001561712077663116017153 0ustar sergeisergei!********************************************************************** ! ROUTINE: FUZZY FORTRAN OPERATORS ! PURPOSE: Illustrate Hindmarsh's computation of EPS, and APL ! tolerant comparisons, tolerant CEIL/FLOOR, and Tolerant ! ROUND functions - implemented in Fortran. ! PLATFORM: PC Windows Fortran, Compaq-Digital CVF 6.1a, AIX XLF90 ! TO RUN: Windows: DF EPS.F90 ! AIX: XLF90 eps.f -o eps.exe -qfloat=nomaf ! CALLS: none ! AUTHOR: H. D. Knoble 22 September 1978 ! REVISIONS: !********************************************************************** ! DOUBLE PRECISION EPS,EPS3, X,Y,Z, D1MACH,TFLOOR,TCEIL,EPSF90 LOGICAL TEQ,TNE,TGT,TGE,TLT,TLE !---Following are Fuzzy Comparison (arithmetic statement) Functions. ! TEQ(X,Y)=DABS(X-Y).LE.DMAX1(DABS(X),DABS(Y))*EPS3 TNE(X,Y)=.NOT.TEQ(X,Y) TGT(X,Y)=(X-Y).GT.DMAX1(DABS(X),DABS(Y))*EPS3 TLE(X,Y)=.NOT.TGT(X,Y) TLT(X,Y)=TLE(X,Y).AND.TNE(X,Y) TGE(X,Y)=TGT(X,Y).OR.TEQ(X,Y) ! !---Compute EPS for this computer. EPS is the smallest real number on ! this architecture such that 1+EPS>1 and 1-EPS<1. ! EPSILON(X) is a Fortran 90 built-in Intrinsic function. They should ! be identically equal. ! EPS=D1MACH(NULL) EPSF90=EPSILON(X) IF(EPS.NE.EPSF90) THEN WRITE(*,2)'EPS=',EPS,' .NE. EPSF90=',EPSF90 2 FORMAT(A,Z16,A,Z16) ENDIF !---Accept a representation if exact, or one bit on either side. EPS3=3.D0*EPS WRITE(*,1) EPS,EPS, EPS3,EPS3 1 FORMAT(' EPS=',D16.8,2X,Z16, ', EPS3=',D16.8,2X,Z16) !---Illustrate Fuzzy Comparisons using EPS3. Any other magnitudes will ! behave similarly. Z=1.D0 I=49 X=1.D0/I Y=X*I WRITE(*,*) 'X=1.D0/',I,', Y=X*',I,', Z=1.D0' WRITE(*,*) 'Y=',Y,' Z=',Z WRITE(*,3) X,Y,Z 3 FORMAT(' X=',Z16,' Y=',Z16,' Z=',Z16) !---Floating-point Y is not identical (.EQ.) to floating-point Z. IF(Y.EQ.Z) WRITE(*,*) 'Fuzzy Comparisons: Y=Z' IF(Y.NE.Z) WRITE(*,*) 'Fuzzy Comparisons: Y<>Z' !---But Y is tolerantly (and algebraically) equal to Z. IF(TEQ(Y,Z)) THEN WRITE(*,*) 'but TEQ(Y,Z) is .TRUE.' WRITE(*,*) 'That is, Y is computationally equal to Z.' ENDIF IF(TNE(Y,Z)) WRITE(*,*) 'and TNE(Y,Z) is .TRUE.' WRITE(*,*) ' ' !---Evaluate Fuzzy FLOOR and CEILing Function values using a Comparison ! Tolerance, CT, of EPS3. X=0.11D0 Y=((X*11.D0)-X)-0.1D0 YFLOOR=TFLOOR(Y,EPS3) YCEIL=TCEIL(Y,EPS3) 55 Z=1.D0 WRITE(*,*) 'X=0.11D0, Y=X*11.D0-X-0.1D0, Z=1.D0' WRITE(*,*) 'X=',X,' Y=',Y,' Z=',Z WRITE(*,3) X,Y,Z !---Floating-point Y is not identical (.EQ.) to floating-point Z. IF(Y.EQ.Z) WRITE(*,*) 'Fuzzy FLOOR/CEIL: Y=Z' IF(Y.NE.Z) WRITE(*,*) 'Fuzzy FLOOR/CEIL: Y<>Z' IF(TFLOOR(Y,EPS3).EQ.TCEIL(Y,EPS3).AND.TFLOOR(Y,EPS3).EQ.Z) THEN !---But Tolerant Floor/Ceil of Y is identical (and algebraically equal) ! to Z. WRITE(*,*) 'but TFLOOR(Y,EPS3)=TCEIL(Y,EPS3)=Z.' WRITE(*,*) 'That is, TFLOOR/TCEIL return exact whole numbers.' ENDIF STOP END DOUBLE PRECISION FUNCTION D1MACH (IDUM) INTEGER IDUM !======================================================================= ! This routine computes the unit roundoff of the machine in double ! precision. This is defined as the smallest positive machine real ! number, EPS, such that (1.0D0+EPS > 1.0D0) & (1.D0-EPS < 1.D0). ! This computation of EPS is the work of Alan C. Hindmarsh. ! For computation of Machine Parameters also see: ! W. J. Cody, "MACHAR: A subroutine to dynamically determine machine ! parameters, " TOMS 14, December, 1988; or ! Alan C. Hindmarsh at http://www.netlib.org/lapack/util/dlamch.f ! or Werner W. Schulz at http://www.ozemail.com.au/~milleraj/ . ! ! This routine appears to give bit-for-bit the same results as ! the Intrinsic function EPSILON(x) for x single or double precision. ! hdk - 25 August 1999. !----------------------------------------------------------------------- DOUBLE PRECISION EPS, COMP ! EPS = 1.0D0 !10 EPS = EPS*0.5D0 ! COMP = 1.0D0 + EPS ! IF (COMP .NE. 1.0D0) GO TO 10 ! D1MACH = EPS*2.0D0 EPS = 1.0D0 COMP = 2.0D0 DO WHILE ( COMP .NE. 1.0D0 ) EPS = EPS*0.5D0 COMP = 1.0D0 + EPS ENDDO D1MACH = EPS*2.0D0 RETURN END DOUBLE PRECISION FUNCTION TFLOOR(X,CT) !===========Tolerant FLOOR Function. ! ! C - is given as a double precision argument to be operated on. ! it is assumed that X is represented with m mantissa bits. ! CT - is given as a Comparison Tolerance such that ! 0.lt.CT.le.3-Sqrt(5)/2. If the relative difference between ! X and a whole number is less than CT, then TFLOOR is ! returned as this whole number. By treating the ! floating-point numbers as a finite ordered set note that ! the heuristic eps=2.**(-(m-1)) and CT=3*eps causes ! arguments of TFLOOR/TCEIL to be treated as whole numbers ! if they are exactly whole numbers or are immediately ! adjacent to whole number representations. Since EPS, the ! "distance" between floating-point numbers on the unit ! interval, and m, the number of bits in X's mantissa, exist ! on every floating-point computer, TFLOOR/TCEIL are ! consistently definable on every floating-point computer. ! ! For more information see the following references: ! {1} P. E. Hagerty, "More on Fuzzy Floor and Ceiling," APL QUOTE ! QUAD 8(4):20-24, June 1978. Note that TFLOOR=FL5 took five ! years of refereed evolution (publication). ! ! {2} L. M. Breed, "Definitions for Fuzzy Floor and Ceiling", APL ! QUOTE QUAD 8(3):16-23, March 1978. ! ! H. D. KNOBLE, Penn State University. !===================================================================== DOUBLE PRECISION X,Q,RMAX,EPS5,CT,FLOOR,DINT !---------FLOOR(X) is the largest integer algegraically less than ! or equal to X; that is, the unfuzzy Floor Function. DINT(X)=X-DMOD(X,1.D0) FLOOR(X)=DINT(X)-DMOD(2.D0+DSIGN(1.D0,X),3.D0) !---------Hagerty's FL5 Function follows... Q=1.D0 IF(X.LT.0)Q=1.D0-CT RMAX=Q/(2.D0-CT) EPS5=CT/Q TFLOOR=FLOOR(X+DMAX1(CT,DMIN1(RMAX,EPS5*DABS(1.D0+FLOOR(X))))) IF(X.LE.0 .OR. (TFLOOR-X).LT.RMAX)RETURN TFLOOR=TFLOOR-1.D0 RETURN END DOUBLE PRECISION FUNCTION TCEIL(X,CT) !==========Tolerant Ceiling Function. ! See TFLOOR. DOUBLE PRECISION X,CT,TFLOOR TCEIL= -TFLOOR(-X,CT) RETURN END DOUBLE PRECISION FUNCTION ROUND(X,CT) !=========Tolerant Round Function ! See Knuth, Art of Computer Programming, Vol. 1, Problem 1.2.4-5. DOUBLE PRECISION TFLOOR,X,CT ROUND=TFLOOR(X+0.5D0,CT) RETURN END tcllib-1.15/modules/math/decimal.test0000755000175000017500000000225112077663116017143 0ustar sergeisergei# -*- tcl -*- # Tests for decimal arithmetic package in math library -*- tcl -*- # # This file contains a collection of tests for one or more of the Tcllib # procedures. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # $Id: decimal.test,v 1.3 2011/11/09 18:33:22 andreas_kupries Exp $ # # Copyright (c) 2011 by Mark Alston # All rights reserved. # # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.1 support { useLocal math.tcl math } testing { useLocal decimal.tcl math::decimal } # ------------------------------------------------------------------------- # # Simple tests # test decimal-plus-1.1 "Sum of two numbers" { math::decimal::tostr \ [math::decimal::+ \ [math::decimal::fromstr 1.0] \ [math::decimal::fromstr 1.00]] } 2.00 # ------------------------------------------------------------------------- # End of test cases testsuiteCleanup tcllib-1.15/modules/math/symdiff.test0000644000175000017500000002642312077663116017212 0ustar sergeisergei# symdiff.test -- # # Test cases for the 'symdiff' package # # This file contains a collection of tests for one or more of the Tcllib # procedures. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 2005 by Kevin B. Kenny # All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: symdiff.test,v 1.2 2011/01/13 02:49:53 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.1 support { use grammar_aycock/aycock-runtime.tcl grammar::aycock::runtime grammar::aycock useKeep grammar_aycock/aycock-debug.tcl grammar::aycock::debug grammar::aycock useKeep grammar_aycock/aycock-build.tcl grammar::aycock grammar::aycock } testing { useLocal symdiff.tcl math::calculus::symdiff } # ------------------------------------------------------------------------- namespace eval ::math::calculus::symdiff::test { namespace import ::tcltest::test namespace import ::tcltest::cleanupTests namespace import ::math::calculus::symdiff::* set prec $::tcl_precision if {![package vsatisfies [package provide Tcl] 8.5]} { set ::tcl_precision 17 } else { set ::tcl_precision 0 } test symdiff-1.1 {derivative of a constant} { symdiff {1.0} a } 0.0 test symdiff-2.1 {derivative of a variable} { symdiff {$a} a } 1.0 test symdiff-2.2 {derivative of a variable} { symdiff {$b} a } 0.0 test symdiff-3.1 {derivative of a sum, easy cases} { symdiff {1.0 + 1.0} a } 0.0 test symdiff-3.2 {derivative of a sum, easy cases} { symdiff {1.0 + $a} a } 1.0 test symdiff-3.3 {derivative of a sum, easy cases} { symdiff {$a + 1.0} a } 1.0 test symdiff-3.4 {derivative of a sum, easy cases} { symdiff {$a + $a} a } 2.0 test symdiff-3.5 {derivative of a sum, easy cases} { symdiff {$a + $b} a } 1.0 test symdiff-3.6 {derivative of a sum, easy cases} { symdiff {$a + $a + $a} a } 3.0 test symdiff-4.1 {derivative of a difference, easy cases} { -body { symdiff {1.0 - 1.0} a } -match regexp -result {[-+]?0.0} } test symdiff-4.2 {derivative of a difference, easy cases} { symdiff {1.0 - $a} a } -1.0 test symdiff-4.3 {derivative of a difference, easy cases} { symdiff {$a - 1.0} a } 1.0 test symdiff-4.4 {derivative of a difference, easy cases} { symdiff {$a - $a} a } 0.0 test symdiff-4.5 {derivative of a difference, easy cases} { symdiff {$a + $b} a } 1.0 test symdiff-4.6 {derivative of a difference, easy cases} { symdiff {$a + $a - $a} a } 1.0 test symdiff-5.1 {derivative of a product, easy cases} { symdiff {1.0 * 1.0} a } 0.0 test symdiff-5.2 {derivative of a product, easy cases} { symdiff {3.0 * $a} a } 3.0 test symdiff-5.3 {derivative of a product, easy cases} { symdiff {$a * 3.0} a } 3.0 test symdiff-5.4 {derivative of a product, easy cases} { symdiff {$a * $a} a } {($a + $a)} test symdiff-5.5 {derivative of a product, easy cases} { symdiff {$a * $b} a } {$b} test symdiff-5.6 {derivative of a product, easy cases} { symdiff {($a + $b) * ($a + $b)} a } {(($a + $b) + ($a + $b))} test symdiff-5.7 {derivative of a linear function} { symdiff {$a*$x + $b} x } {$a} test symdiff-6.1 {derivative of a sum} { symdiff {($a*$x+$b)+($c*$x+$d)} x } {($a + $c)} test symdiff-7.1 {derivative of a difference} { symdiff {($a*$x+$b)-($c*$x+$d)} x } {($a - $c)} test symdiff-8.1 {derivative of a product} { symdiff {($a*$x+$b)*($c*$x+$d)} x } {(($c * (($a * $x) + $b)) + ($a * (($c * $x) + $d)))} test symdiff-9.1 {derivative of a quotient} { symdiff {$x/1.0} x } 1.0 test symdiff-9.2 {derivative of a quotient} { symdiff {$x/-1.0} x } -1.0 test symdiff-9.3 {derivative of a quotient} { symdiff {1.0/$x} x } {-(((1.0 / $x) / $x))} test symdiff-9.4 {derivative of a quotient} { symdiff {($a*$x+$b)/($c*$x+$d)} x } {(($a - (($c * (($a * $x) + $b)) / (($c * $x) + $d))) / (($c * $x) + $d))} test symdiff-10.1 {derivative of an exponent} { symdiff {pow($a*$x+$b,3.5)} x } {($a * (3.5 * pow((($a * $x) + $b), 2.5)))} test symdiff-10.2 {derivative of an exponent, slightly harder case} { -body { symdiff {pow(10.0,$x)} x } -match regexp -result {\(pow\(10.0, \$x\) \* 2.30258509299404(?:59|6)\)} } test symdiff-10.3 {derivative of an exponent, awkward case} { symdiff {pow($a*$x+$b,$c*$x+$d)} x } {(pow((($a * $x) + $b), (($c * $x) + $d)) * ((($a * (($c * $x) + $d)) / (($a * $x) + $b)) + ($c * log((($a * $x) + $b)))))} test symdiff-11.1 {derivative of a unary negation} { symdiff {-($a*$x + $b)} x } {-($a)} test symdiff-11.2 {derivative of a unary plus} { symdiff {+($a*$x + $b)} x } {$a} test symdiff-12.1 {derivative of acos} { symdiff {acos($x)} x } {(-1.0 / sqrt((1.0 - ($x * $x))))} test symdiff-12.2 {derivative of acos} { symdiff {acos($a*$x+$b)} x } {-(($a / sqrt((1.0 - ((($a * $x) + $b) * (($a * $x) + $b))))))} test symdiff-13.1 {derivative of acos} { symdiff {asin($x)} x } {(1.0 / sqrt((1.0 - ($x * $x))))} test symdiff-13.2 {derivative of asin} { symdiff {asin($a*$x+$b)} x } {($a / sqrt((1.0 - ((($a * $x) + $b) * (($a * $x) + $b)))))} test symdiff-14.1 {derivative of atan} { symdiff {atan($x)} x } {(1.0 / (1.0 + ($x * $x)))} test symdiff-14.2 {derivative of atan} { symdiff {atan($a*$x+$b)} x } {($a / (1.0 + ((($a * $x) + $b) * (($a * $x) + $b))))} test symdiff-15.1 {derivative of atan2} { symdiff {atan2($x,1.0)} x } {(1.0 / (($x * $x) + 1.0))} test symdiff-15.2 {derivative of atan2} { symdiff {atan2(1.0,$x)} x } {(-1.0 / (1.0 + ($x * $x)))} test symdiff-15.3 {derivative of atan2} { symdiff {atan2($x,$y)} x } {($y / (($x * $x) + ($y * $y)))} test symdiff-15.4 {derivative of atan2} { symdiff {atan2($y,$x)} x } {-(($y / (($y * $y) + ($x * $x))))} test symdiff-15.5 {derivative of atan2} { symdiff {atan2($a*$x+$b,$c*$x+$d)} x } {((($a * (($c * $x) + $d)) - ((($a * $x) + $b) * $c)) / (((($a * $x) + $b) * (($a * $x) + $b)) + ((($c * $x) + $d) * (($c * $x) + $d))))} test symdiff-16.1 {derivative of cos} { symdiff {cos($x)} x } {-(sin($x))} test symdiff-16.2 {derivative of cos} { symdiff {cos($a*$x + $b)} x } {-(($a * sin((($a * $x) + $b))))} test symdiff-17.1 {derivative of cosh} { symdiff {cosh($x)} x } {sinh($x)} test symdiff-17.2 {derivative of cosh} { symdiff {cosh($a*$x + $b)} x } {($a * sinh((($a * $x) + $b)))} test symdiff-18.1 {derivative of exp} { symdiff {exp($x)} x } {exp($x)} test symdiff-18.2 {derivative of exp} { symdiff {exp($a*$x+$b)} x } {($a * exp((($a * $x) + $b)))} test symdiff-19.1 {derivative of hypot} { symdiff {hypot(0.0,$a)} a } {($a / hypot(0.0, $a))} test symdiff-19.2 {derivative of hypot} { symdiff {hypot($b,$a)} a } {($a / hypot($b, $a))} test symdiff-19.3 {derivative of hypot} { symdiff {hypot($a*$x+$b,$c*$x+$d)} x } {((($a * (($a * $x) + $b)) + ($c * (($c * $x) + $d))) / hypot((($a * $x) + $b), (($c * $x) + $d)))} test symdiff-20.1 {derivative of log} { symdiff {log($x)} x } {(1.0 / $x)} test symdiff-20.2 {derivative of log} { symdiff {log($a*$x+$b)} x } {($a / (($a * $x) + $b))} test symdiff-21.1 {derivative of log10} { -body { symdiff {log10($x)} x } -match regexp -result {\(1.0 / \(2.30258509299404(?:59|6) \* \$x\)\)} } test symdiff-21.2 {derivative of log10} { -body { symdiff {log10($a * $x + $b)} x } -match regexp -result {\(\$a / \(2.30258509299404(?:59|6) \* \(\(\$a \* \$x\) \+ \$b\)\)\)} } test symdiff-22.1 {derivative of sin} { symdiff {sin($x)} x } {cos($x)} test symdiff-22.2 {derivative of sin} { symdiff {sin($a*$x+$b)} x } {($a * cos((($a * $x) + $b)))} test symdiff-22.1 {derivative of sinh} { symdiff {sinh($x)} x } {cosh($x)} test symdiff-22.2 {derivative of sinh} { symdiff {sinh($a*$x+$b)} x } {($a * cosh((($a * $x) + $b)))} test symdiff-23.1 {derivative of sqrt} { symdiff {sqrt($x)} x } {(1.0 / (2.0 * sqrt($x)))} test symdiff-23.2 {derivative of sqrt} { symdiff {sqrt($a*$x+$b)} x } {($a / (2.0 * sqrt((($a * $x) + $b))))} test symdiff-24.1 {derivative of tan} { symdiff {tan($x)} x } {(1.0 / (cos($x) * cos($x)))} test symdiff-24.2 {derivative of tan} { symdiff {tan($a*$x+$b)} x } {($a / (cos((($a * $x) + $b)) * cos((($a * $x) + $b))))} test symdiff-24.1 {derivative of tanh} { symdiff {tanh($x)} x } {(1.0 / (cosh($x) * cosh($x)))} test symdiff-24.2 {derivative of tanh} { symdiff {tanh($a*$x+$b)} x } {($a / (cosh((($a * $x) + $b)) * cosh((($a * $x) + $b))))} test symdiff-25.1 {error handling} { -body { symdiff {[foo $x]} x } -match glob -returnCodes error -result {invalid character*} } test symdiff-25.2 {error handling} { -body { symdiff {$x(1)} x } -match glob -returnCodes error -result {syntax error*} } test symdiff-25.3 {error handling} { -body { symdiff {$a & $b} a } -match glob -returnCodes error -result {syntax error*} } test symdiff-25.4 {error handling} { list [catch {symdiff {int($a)} a} result] $result } {1 {symdiff can't differentiate the "int" function}} test symdiff-25.5 {error handling} { -body { symdiff {$a ? $b : $c} a } -returnCodes error -match glob -result {syntax error*} } test symdiff-26.1 {unary minus optimization} { symdiff {$a * $x + -$b * $x} x } {($a - $b)} test symdiff-26.2 {unary minus optimization} { symdiff {-$a * $x - $b * $x} x } {-(($a + $b))} test symdiff-26.3 {unary minus optimization} { symdiff {$a * $x - -$b * $x} x } {($a + $b)} test symdiff-26.4 {unary minus optimization} { symdiff {-$a * $x * $b} x } {-(($a * $b))} test symdiff-26.5 {unary minus optimization} { symdiff {$a * $x * -$b} x } {-(($a * $b))} test symdiff-26.6 {unary minus optimization} { symdiff {---($a*$x+$b)} x } {-($a)} test symdiff-26.7 {unary minus optimization} { symdiff {-$x * $x} x } {-(($x + $x))} test symdiff-27.1 {power optimizations} { symdiff {pow($x,1)} x } 1.0 test symdiff-27.2 {power optimizations} { symdiff {pow($x,2.0)} x } {(2.0 * $x)} test symdiff-28.1 {quotient optimization} { symdiff {($x * $x) / 1.0} x } {($x + $x)} test symdiff-28.2 {quotient optimization} { symdiff {($x * $x) / -1.0} x } {-(($x + $x))} test symdiff-28.3 {quotient optimization - error case} { list [catch {symdiff {($x * $x) / 0.0} x} result] $result } {1 {requested expression will result in division by zero at run time}} test symdiff-29.1 {product optimization} { symdiff {(2. * $x) * 3.0} x } 6.0 test symdiff-29.2 {product optimization} { symdiff {($a * $x) * -1.0} x } {-($a)} test symdiff-30.0 {illustration of Newton's method - find a root of sin(x)-0.5 near 0.5} { proc root {expr var guess} { upvar 1 $var v set deriv [symdiff $expr $var] set v $guess set updateExpr [list expr "\$$var - ($expr) / ($deriv)"] for { set i 0 } { $i < 4 } { incr i } { set v [uplevel 1 $updateExpr] } return $v } set r [root {sin($x)-0.5} x 0.5] expr {sin($r)} } 0.5 # End of test cases set ::tcl_precision $prec cleanupTests } namespace delete ::math::calculus::symdiff::test # Local Variables: # mode: tcl # End: tcllib-1.15/modules/math/linalg.test0000755000175000017500000006033212077663116017017 0ustar sergeisergei# -*- tcl -*- # linalg.test -- # Tests for the linear algebra package # # NOTE: # Comparison by numbers, not strings, needed! # # TODO: # Tests for: # - show, angle # - solveGaussBand, solveTriangularBand # - mkHilbert and so on # - matmul # ------------------------------------------------------------------------- set regular 1 if {$regular==1} then { source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.4 testsNeedTcltest 2.1 support { useLocal math.tcl math } testing { useLocal linalg.tcl math::linearalgebra } } else { package require tcltest tcltest::configure -verbose {start body error pass} #tcltest::configure -match largesteigen-* namespace import tcltest::test namespace import tcltest::customMatch set basedir [file normalize [file dirname [info script]]] set ::auto_path [linsert $::auto_path 0 $basedir] package require -exact math::linearalgebra 1.1.3 } # ------------------------------------------------------------------------- namespace import -force ::math::linearalgebra::* set prec $::tcl_precision if {![package vsatisfies [package provide Tcl] 8.5]} { set ::tcl_precision 17 } else { set ::tcl_precision 0 } # # Returns 1 if the expected value is close to the actual value, # that is their relative difference is small with respect to the # given epsilon. # If the expected value is zero, use an absolute error instead. # proc areClose {expected actual epsilon} { if {$actual=="" && $expected!=""} then { return 0 } if {$actual!="" && $expected==""} then { return 0 } set match 1 if { [llength [lindex $expected 0]] > 1 } { foreach a $actual e $expected { set match [matchNumbers $e $a] if { $match == 0 } { break } } } else { foreach a $actual e $expected { if {[string is double $a]==0 || [string is double $e]==0} then { return 0 } if {$e!=0.0} then { set shift [expr {abs($a-$e)/abs($e)}] } else { set shift [expr {abs($a-$e)}] } #puts "a=$a, e=$e, shift = $shift" if {$shift > $epsilon} { set match 0 break } } } return $match } # # Matching procedure - flatten the lists # proc matchNumbers {expected actual} { if {$actual=="" && $expected!=""} then { return 0 } if {$actual!="" && $expected==""} then { return 0 } set match 1 if { [llength [lindex $expected 0]] > 1 } { foreach a $actual e $expected { set match [matchNumbers $e $a] if { $match == 0 } { break } } } else { foreach a $actual e $expected { if {[string is double $a]==0 || [string is double $e]==0} then { return 0 } if {abs($a-$e) > 0.1e-6} { set match 0 break } } } return $match } customMatch numbers matchNumbers test dimshape-1.0 "dimension of scalar" -body { dim 1 } -result 0 test dimshape-1.1 "dimension of vector" -body { dim {1 2 3} } -result 1 test dimshape-1.2 "dimension of matrix" -body { dim { {1 2 3} {4 5 6} } } -result 2 test dimshape-2.0 "shape of scalar" -body { shape 1 } -result {1} test dimshape-2.1 "shape of vector" -body { shape {1 2 3} } -result 3 test dimshape-2.2 "shape of matrix" -body { shape { {1 2 3} {4 5 6} } } -result {2 3} test symmetric-1.0 "non-symmetric matrix" -body { symmetric { {1 2 3} {4 5 6} {7 8 9}} } -result 0 test symmetric-1.1 "symmetric matrix" -body { symmetric { {1 2 3} {2 1 4} {3 4 1}} } -result 1 test symmetric-1.2 "non-square matrix" -body { symmetric { {1 2 3} {2 1 4}} } -result 0 test norm-1.0 "one-norm - 5 components" -match numbers -body { norm {1 2 3 0 -1} 1 } -result 7.0 test norm-1.1 "one-norm - 2 components" -match numbers -body { norm {1 -1} 1 } -result 2.0 test norm-1.2 "two-norm - 5 components" -match numbers -body { norm {1 2 3 0 -1} 2 } -result [expr {sqrt(15)}] test norm-1.3 "two-norm - 2 components" -match numbers -body { norm {1 -1} 2 } -result [expr {sqrt(2)}] test norm-1.4 "two-norm - no underflow" -match numbers -body { norm {3.0e-140 -4.0e-140} 2 } -result 5.0e-140 test norm-1.5 "two-norm - no overflow" -match numbers -body { norm {3.0e140 -4.0e140} 2 } -result 5.0e140 test norm-1.6 "max-norm - 5 components" -match numbers -body { norm {1 2 3 0 -4} max } -result 4 test norm-1.7 "max-norm - 2 components" -match numbers -body { norm {1 -1} max } -result 1 test norm-2.0 "matrix-norm - 2x2 - max" -match numbers -body { normMatrix {{1 -1} {1 1}} max } -result 1 test norm-2.1 "matrix-norm - 2x2 - 1" -match numbers -body { normMatrix {{1 -1} {1 1}} 1 } -result 4 test norm-2.2 "matrix-norm - 2x2 - 2" -match numbers -body { normMatrix {{1 -1} {1 1}} 2 } -result 2 test norm-3.0 "statistical normalisation - vector" -match numbers -body { normalizeStat {1 0 0 0} } -result {1.5 -0.5 -0.5 -0.5} test norm-3.1 "statistical normalisation - matrix" -match numbers -body { normalizeStat {{1 0 0 0} {0 0 0 1} {0 1 1 0} {0 0 0 0}} } -result {{ 1.5 -0.5 -0.5 -0.5} {-0.5 -0.5 -0.5 1.5} {-0.5 1.5 1.5 -0.5} {-0.5 -0.5 -0.5 -0.5}} test dotproduct-1.0" "dot-product - 2 components" -match numbers -body { dotproduct {1 -1} {1 -1} } -result 2.0 test dotproduct-1.1" "dot-product - 5 components" -match numbers -body { dotproduct {1 2 3 4 5} {5 4 3 2 1} } -result [expr {5.0+8+9+8+5}] test unitlength-1.0" "unitlength - 2 components" -match numbers -body { unitLengthVector {3 4} } -result {0.6 0.8} test unitlength-1.1" "unitlength - 4 components" -match numbers -body { unitLengthVector {1 1 1 1} } -result {0.5 0.5 0.5 0.5} test axpy-1.0 "axpy - vectors" -body { axpy 2 {1 -1} {2 -2} } -result {4 -4} test axpy-1.1 "axpy - matrices" -body { axpy 2 { {1 -1} {2 -2} {3 4} {-3 4} } \ { {5 -5} {5 -5} {6 6} {-6 6} } } -result {{7 -7} {9 -9} {12 14} {-12 14}} test add-1.0 "add - vectors" -body { add {1 -1} {2 -2} } -result {3 -3} test add-1.1 "add - matrices" -body { add { {1 -1} {2 -2} {3 4} {-3 4} } \ { {5 -5} {5 -5} {6 6} {-6 6} } } -result {{6 -6} {7 -7} {9 10} {-9 10}} test sub-1.0 "sub - vectors" -body { sub {1 -1} {2 -2} } -result {-1 1} test sub-1.1 "sub - matrices" -body { sub { {1 -1} {2 -2} {3 4} {-3 4} } \ { {5 -5} {5 -5} {6 6} {-6 6} } } -result {{-4 4} {-3 3} {-3 -2} {3 -2}} test scale-1.0 "scale - vectors" -body { scale 3 {2 -2} } -result {6 -6} test scale-1.1 "scale - matrices" -body { scale 3 { {5 -5} {5 -5} {6 6} {-6 6} } } -result {{15 -15} {15 -15} {18 18} {-18 18}} test make-1.0 "mkVector - create a null vector" -body { mkVector 3 } -result {0.0 0.0 0.0} test make-1.1 "mkVector - create a vector with values 1" -body { mkVector 3 1.0 } -result {1.0 1.0 1.0} test make-2.0 "mkMatrix - create a matrix with 3 rows, 2 columns" -body { mkMatrix 3 2 2.0 } -result {{2.0 2.0} {2.0 2.0} {2.0 2.0}} test make-2.1 "mkMatrix - create a matrix with 2 rows, 3 columns" -body { mkMatrix 2 3 1.0 } -result {{1.0 1.0 1.0} {1.0 1.0 1.0}} test make-3.0 "mkIdentity - create an identity matrix 2x2" -body { mkIdentity 2 } -result {{1.0 0.0} {0.0 1.0}} test make-3.1 "mkIdentity - create an identity matrix 3x3" -body { mkIdentity 3 } -result {{1.0 0.0 0.0} {0.0 1.0 0.0} {0.0 0.0 1.0}} test make-4.0 "mkDiagonal - create a diagonal matrix 2x2" -body { mkDiagonal {2.0 3.0} } -result {{2.0 0.0} {0.0 3.0}} test make-4.1 "mkDiagonal - create a diagonal matrix 3x3" -body { mkDiagonal {2.0 3.0 4.0} } -result {{2.0 0.0 0.0} {0.0 3.0 0.0} {0.0 0.0 4.0}} test getset-1.0 "getrow - get first row from a matrix" -body { getrow {{1 2 3} {4 5 6} {7 8 9} {10 11 12}} 0 } -result {1 2 3} test getset-1.1 "getrow - get last row from a matrix" -body { getrow {{1 2 3} {4 5 6} {7 8 9} {10 11 12}} 3 } -result {10 11 12} test getset-1.1b "getrow - get row of a vector" -body { getrow {1 2 3} 1 } -result {2} test getset-1.1c "getrow - get row #1, for columns #2 to #3" -body { getrow {{1 2 3 4 5 6} {7 8 9 10 11 12} {13 14 15 16 17 18}} 1 2 3 } -result {9 10} test getset-1.2 "getcol - get first column from a matrix" -body { getcol {{1 2 3} {4 5 6} {7 8 9} {10 11 12}} 0 } -result {1 4 7 10} test getset-1.3 "getcol - get last column from a matrix" -body { getcol {{1 2 3} {4 5 6} {7 8 9} {10 11 12}} 2 } -result {3 6 9 12} test getset-1.4 "getcol - get column #1 from lines #2 to #3" -body { getcol {{1 2 3} {4 5 6} {7 8 9} {10 11 12} {13 14 15}} 1 2 3 } -result {8 11} test getset-2.0 "setrow - set first row in a matrix" -body { set M {{1 2 3} {4 5 6} {7 8 9} {10 11 12}} setrow M 0 {3 2 1} } -result {{3 2 1} {4 5 6} {7 8 9} {10 11 12}} test getset-2.1 "setrow - set last row in a matrix" -body { set M {{1 2 3} {4 5 6} {7 8 9} {10 11 12}} setrow M 3 {3 2 1} } -result {{1 2 3} {4 5 6} {7 8 9} {3 2 1}} test getset-2.1b "setrow - set row #1 from column #2 to column #3" -body { set M {{1 2 3 4 5} {6 7 8 9 10} {11 12 13 14 15}} setrow M 1 {99 100} 2 3 } -result {{1 2 3 4 5} {6 7 99 100 10} {11 12 13 14 15}} test getset-2.2 "setcol - set first column in a matrix" -body { set M {{1 2 3} {4 5 6} {7 8 9} {10 11 12}} setcol M 0 {3 2 1 0} } -result {{3 2 3} {2 5 6} {1 8 9} {0 11 12}} test getset-2.3 "setcol - set last column in a matrix" -body { set M {{1 2 3} {4 5 6} {7 8 9} {10 11 12}} setcol M 2 {3 2 1 0} } -result {{1 2 3} {4 5 2} {7 8 1} {10 11 0}} test getset-2.4 "setcol - set column #1 from lines #2 to #3" -body { set M {{1 2 3} {4 5 6} {7 8 9} {10 11 12} {13 14 15}} setcol M 1 {99 100} 2 3 } -result {{1 2 3} {4 5 6} {7 99 9} {10 100 12} {13 14 15}} test getset-3.0 "getelem - get element (0,0) in a matrix" -body { getelem {{1 2 3} {4 5 6} {7 8 9} {10 11 12}} 0 0 } -result 1 test getset-3.1 "getelem - set element (1,2) in a matrix" -body { getelem {{1 2 3} {4 5 6} {7 8 9} {10 11 12}} 1 2 } -result 6 test getset-3.2 "setelem - set element (0,0) in a matrix" -body { set M {{1 2 3} {4 5 6} {7 8 9} {10 11 12}} setelem M 0 0 100 } -result {{100 2 3} {4 5 6} {7 8 9} {10 11 12}} test getset-3.3 "setelem - set element (1,2) in a matrix" -body { set M {{1 2 3} {4 5 6} {7 8 9} {10 11 12}} setelem M 1 2 100 } -result {{1 2 3} {4 5 100} {7 8 9} {10 11 12}} test getset-4.0 "getelem - get element 1 from a vector" -body { set V {1 2 3} getelem $V 1 } -result 2 test getset-4.1 "setelem - set element 1 in a vector" -body { set V {1 2 3} setelem V 1 4 } -result {1 4 3} test swaprows-1 "swap two rows of a matrix" -body { set M {{1 2 3} {4 5 6} {7 8 9} {10 11 12}} swaprows M 1 2 } -result {{1 2 3} {7 8 9} {4 5 6} {10 11 12}} test swaprows-2 "swap rows #1 and #2 from columns #2 to #3" -body { set M {{1 2 3 4 5} {6 7 8 9 10} {11 12 13 14 15} {16 17 18 19 20}} swaprows M 1 2 2 3 } -result {{1 2 3 4 5} {6 7 13 14 10} {11 12 8 9 15} {16 17 18 19 20}} test swapcols-1 "swap two columns of a matrix" -body { set M {{1 2 3 4 5} {6 7 8 9 10} {11 12 13 14 15} {16 17 18 19 20}} swapcols M 1 2 } -result {{1 3 2 4 5} {6 8 7 9 10} {11 13 12 14 15} {16 18 17 19 20}} test swapcols-2 "swap columns #1 and #2 from lines #1 to #2" -body { set M {{1 2 3 4 5} {6 7 8 9 10} {11 12 13 14 15} {16 17 18 19 20}} swapcols M 1 2 1 2 } -result {{1 2 3 4 5} {6 8 7 9 10} {11 13 12 14 15} {16 17 18 19 20}} test rotate-1.0 "rotate - over 90 degrees" -body { set v1 {1 2 3} set v2 {4 5 6} rotate 0 1 $v1 $v2 } -result {{-4 -5 -6} {1 2 3}} test rotate-1.1 "rotate - over 180 degrees" -body { set v1 {1 2 3 4 5 6} set v2 {7 8 9 10 11 12} rotate -1 0 $v1 $v2 } -result {{-1 -2 -3 -4 -5 -6} {-7 -8 -9 -10 -11 -12}} test matmul-1.0 "multiply matrix - vector" -match numbers -body { set v1 {1 2 3} set m {{0 0 1} {0 5 0} {-1 0 0}} matmul $m $v1 } -result {3 10 -1} test matmul-1.1 "multiply vector - matrix" -match numbers -body { set v1 {{1 2 3}} ;# Row vector set m {{0 0 1} {0 5 0} {-1 0 0}} matmul $v1 $m } -result {{-3 10 1}} test matmul-1.2 "multiply matrix - matrix" -match numbers -body { set m1 {{0 0 1} {0 5 0} {-1 0 0}} set m2 {{0 0 1} {1 5 1} {-1 0 0}} matmul $m1 $m2 } -result {{-1 0 0} {5 25 5} {0 0 -1}} test matmul-1.3 "multiply vector - vector" -match numbers -body { set v1 {1 2 3} set v2 {4 5 6} matmul $v1 $v2 } -result {{4 5 6} {8 10 12} {12 15 18}} test matmul-1.4 "multiply row vector - column vector" -match numbers -body { set v1 [transpose {1 2 3}] set v2 {4 5 6} matmul $v1 $v2 } -result 32 test matmul-1.5 "multiply column vector - row vector" -match numbers -body { set v1 {1 2 3} set v2 [transpose {4 5 6}] matmul $v1 $v2 } -result {{4 5 6} {8 10 12} {12 15 18}} test matmul-1.6 "multiply scalar - scalar" -match numbers -body { set v1 {1} set v2 {1} matmul $v1 $v2 } -result {1} test solve-1.1 "solveGauss - 2x2 matrix" -match numbers -body { set b {{2 3} {-2 3}} set M {{2 3} {-2 3}} solveGauss $M $b } -result {{1 0} {0 1}} test solve-1.2 "solveGauss - 3x3 matrix" -match numbers -body { set b {{2 3 4} {-2 3 4} {1 1 1}} set M {{2 3 4} {-2 3 4} {1 1 1}} solveGauss $M $b } -result {{1 0 0} {0 1 0} {0 0 1}} test solve-1.3 "solveGauss - 3x3 matrix - less trivial" -match numbers -body { set b {{6 -3 6} {2 -3 2} {2 -1 2}} set M {{2 3 4} {-2 3 4} {1 1 1}} solveGauss $M $b } -result {{1 0 1} {0 -1 0} {1 0 1}} # # MB # test solve-1.4 "solveGauss - 3x3 matrix - but better pivots may be found" -match numbers -body { set b {{67 67} {4 4} {6 6}} set M {{3 17 10} {2 4 -2} {6 18 -12}} solveGauss $M $b } -result {{1 1} {2 2} {3 3}} test solve-1.5 "solveGauss - Hilbert matrix" -match numbers -body { set expected [mkVector 10 1.0] set M [mkHilbert 10] # b is expected as a list of colums set b [mkMatrix 10 1] setcol b 0 [matmul $M $expected] set computed [solveGauss $M $b] set diff [sub $computed $expected] set norm [normMatrix $diff max] # Computed norm : 0.00043691152972824554 set result [expr {$norm<1.e-3}] } -result {1} test solvepgauss-1.6 "solveGauss - 2x2 difficult matrix with necessary permutations" -match numbers -body { set M {{1.e-8 1} {1 1}} set b [list [expr {1.+1.e-8}] 2.] set computed [solveGauss $M $b] set expected {1. 1.} set diff [sub $computed $expected] set norm [norm $diff max] # Computed norm : 5.0247592753294157e-09 set result [expr {$norm<1.e-8}] } -result {1} test solvepgauss-1 "solvePGauss - 3x3 matrix with two permutations" -match numbers -body { set b {{67} {4} {6}} set M {{3 17 10} {2 4 -2} {6 18 -12}} solvePGauss $M $b } -result {{1} {2} {3}} test solvepgauss-2 "solvePGauss - 3x3 matrix" -match numbers -body { set b {{6 -3 6} {2 -3 2} {2 -1 2}} set M {{2 3 4} {-2 3 4} {1 1 1}} solvePGauss $M $b } -result {{1 0 1} {0 -1 0} {1 0 1}} test solvepgauss-3 "solvePGauss - 10x10 Hilbert matrix" -match numbers -body { set expected [mkVector 10 1.0] set M [mkHilbert 10] # b is expected as a list of colums set b [mkMatrix 10 1] setcol b 0 [matmul $M $expected] set computed [solvePGauss $M $b] set diff [sub $computed $expected] set norm [normMatrix $diff max] # Computed norm : 0.00031339500191851499 set result [expr {$norm<1.e-3}] } -result {1} test solvepgauss-4 "solvePGauss - 2x2 difficult matrix with necessary permutations" -match numbers -body { set M {{1.e-8 1} {1 1}} set b [list [expr {1.+1.e-8}] 2.] set computed [solvePGauss $M $b] set expected {1. 1.} set diff [sub $computed $expected] set norm [norm $diff max] # Computed norm : 0. set result [expr {$norm<1.e-15}] } -result {1} test orthon-1.0 "orthonormalize columns - 3x3" -match numbers -body { set M {{1 1 1} {0 1 1} {0 0 1}} orthonormalizeColumns $M } -result {{1 0 0} {0 1 0} {0 0 1}} test orthon-1.1 "orthonormalize rows - 3x3" -match numbers -body { set M {{1 0 0} {1 1 0} {1 1 1}} orthonormalizeRows $M } -result {{1 0 0} {0 1 0} {0 0 1}} test orthon-1.2 "orthonormalize rows - 3x4" -match numbers -body { set M {{1 0 0 0} {1 1 0 0} {1 1 1 0}} orthonormalizeRows $M } -result {{1 0 0 0} {0 1 0 0} {0 0 1 0}} # # The results from the original LA package have been used # as a benchmark: # # test svd-1.0 "singular value decomposition - 2x2" -match numbers -body { set M {{1.0 2.0} {2.0 1.0}} determineSVD $M } -result { {{0.70710678118654757 0.70710678118654746} {0.70710678118654746 -0.70710678118654757}} {3.0 1.0} {{0.70710678118654757 -0.70710678118654746} {0.70710678118654746 0.70710678118654757}} } test svd-1.1 "singular value decomposition - 10x10" -match numbers -body { set M [mkDingdong 10] show [lindex [determineSVD $M] 1] %6.4f } -result {1.5708 1.5708 1.5708 1.5708 1.5708 1.5707 1.5695 1.5521 1.3935 0.6505} test LA-1.0 "to_LA - vector" -match numbers -body { set vector {1 2 3} to_LA $vector } -result {2 3 0 1 2 3} test LA-1.1 "to_LA - matrix" -match numbers -body { set matrix {{1 2 3} {4 5 6} {7 8 9} {10 11 12}} to_LA $matrix } -result {2 4 3 1 2 3 4 5 6 7 8 9 10 11 12} test LA-2.0 "from_LA - vector" -match numbers -body { set vector {2 3 0 1 2 3} from_LA $vector } -result {1 2 3} test LA-2.1 "from_LA - matrix" -match numbers -body { set matrix {2 4 3 1 2 3 4 5 6 7 8 9 10 11 12} from_LA $matrix } -result {{1 2 3} {4 5 6} {7 8 9} {10 11 12}} test choleski-1.0 "choleski decomposition of Moler matrix" -match numbers -body { set matrix [mkMoler 5] choleski $matrix } -result {{1 0 0 0 0} {-1 1 0 0 0} {-1 -1 1 0 0} {-1 -1 -1 1 0} {-1 -1 -1 -1 1}} test leastsquares-1.0 "Least-squares solution" -match numbers -body { # # Known relation: z = 1.0 + x + 0.1*y # Model this as: z = z0 + x + 0.1*y # (The column of 1s allows us to use a non-zero intercept) # # z0 x y z set Ab { { 1 1.0 1.0} 2.1 { 1 2.0 1.0} 3.1 { 1 2.0 2.0} 3.2 { 1 4.0 2.0} 5.2 { 1 4.0 22.0} 7.2 { 1 5.0 -2.0} 5.8 } set A {} set b {} foreach {Ar br} $Ab { lappend A $Ar lappend b $br } set x [::math::linearalgebra::leastSquaresSVD $A $b] } -result {1.0 1.0 0.1} test eigenvectors-1.0 "Eigenvectors solution" -match numbers -body { # # Matrix: # /2 1\ # \1 2/ # has eigenvalues 3 and 1 with eigenvectors: # / 1\ /1\ # \-1/ and \1/ # (so include a factor 1/sqrt(2) in the answer) # set A { {2 1} {1 2} } ;# Note: integer coefficients! set result [::math::linearalgebra::eigenvectorsSVD $A] } -result {{{0.7071068 -0.7071068} {0.7071068 0.7071068}} {3.0 1.0}} test mkHilbert-1.0 "Hilbert matrix" -match numbers -body { set computed [mkHilbert 3] set expected {{1.0 0.5 0.333333333333} {0.5 0.333333333333 0.25} {0.333333333333 0.25 0.2}} set diff [sub $computed $expected] set norm [normMatrix $diff max] set result [expr {$norm<1.e-10}] } -result {1} test dger-1 "dger" -match numbers -body { set M {{1 2 3} {4 5 6} {7 8 9}} set x {1 2 3} set y {4 5 6} set alpha -1. dger M $alpha $x $y } -result {{-3 -3 -3} {-4 -5 -6} {-5 -7 -9}} test dger-2 "dger" -match numbers -body { set M {{1 2 3 4 5} {6 7 8 9 10} {11 12 13 14 15} {16 17 18 19 20}} set x {1 2 3} set y {4 5 6} set alpha -1. set imin 1 set imax 3 set jmin 2 set jmax 4 set scope [list $imin $imax $jmin $jmax] dger M $alpha $x $y $scope } -result {{1 2 3 4 5} {6 7 4 4 4} {11 12 5 4 3} {16 17 6 4 2}} test dgetrf-1 "dgetrf" -body { set M {{3 17 10} {2 4 -2} {6 18 -12}} set ipiv [dgetrf M] # Check matrix set expectedmat {{6 18 -12} {0.5 8.0 16.0} {0.33333333333333331 -0.25 6.0}} set diff [sub $M $expectedmat] set norm [normMatrix $diff max] set expectation1 [expr {$norm<1.e-10}] # Check pivots set expectedpivots {2 2} set diff [sub $ipiv $expectedpivots] set norm [normMatrix $diff max] set expectation2 [expr {$norm<1.e-10}] set result [list $expectation1 $expectation2] } -result {1 1} test solvetriangular-1 "upper triangular matrix" -match numbers -body { set M {{3 17 10} {0 4 -2} {0 0 -12}} set b {{67 30} {2 2} {-36 -12}} set computed [solveTriangular $M $b] } -result {{1 1} {2 1} {3 1}} test solvetriangular-2 "lower triangular matrix" -match numbers -body { set M {{3 0 0} {2 4 0} {6 18 -12}} set b {{3 3} {10 6} {6 12}} set computed [solveTriangular $M $b "L"] } -result {{1 1} {2 1} {3 1}} test solvetriangular-3 "lower triangular random matrix" -match numbers -body { set M [mkTriangular 10 "L" 1.] set xexpected [mkVector 10 1.] set b [matmul $M $xexpected] set computed [solveTriangular $M $b "L"] } -result {1 1 1 1 1 1 1 1 1 1} test solvetriangular-4 "upper triangular random matrix" -match numbers -body { set M [mkTriangular 10 "U" 1.] set xexpected [mkVector 10 1.] set b [matmul $M $xexpected] set computed [solveTriangular $M $b "U"] } -result {1 1 1 1 1 1 1 1 1 1} test mkTriangular-1 "make triangular matrix" -match numbers -body { mkTriangular 3 } -result {{1.0 1.0 1.0} {0. 1.0 1.0} {0. 0. 1.0}} test mkTriangular-2 "make triangular matrix" -match numbers -body { mkTriangular 3 "L" 2. } -result {{2. 0. 0.} {2. 2. 0.} {2. 2. 2.}} test mkBorder "make border matrix" -match numbers -body { mkBorder 5 } -result { {1.0 0.0 0.0 0.0 1.0} {0.0 1.0 0.0 0.0 0.5} {0.0 0.0 1.0 0.0 0.25} {0.0 0.0 0.0 1.0 0.125} {1.0 0.5 0.25 0.125 1.0}} test mkWilkinsonW- "make Wilkinson W- matrix" -match numbers -body { mkWilkinsonW- 5 } -result { {2.0 1.0 0.0 0.0 0.0} {1.0 1.0 1.0 0.0 0.0} {0.0 1.0 0.0 1.0 0.0} {0.0 0.0 1.0 -1.0 1.0} {0.0 0.0 0.0 1.0 -2.0}} test mkWilkinsonW+ "make Wilkinson W+ matrix" -match numbers -body { mkWilkinsonW+ 7 } -result { {3.0 1.0 0.0 0.0 0.0 0.0 0.0} {1.0 2.0 1.0 0.0 0.0 0.0 0.0} {0.0 1.0 1.0 1.0 0.0 0.0 0.0} {0.0 0.0 1.0 0.0 1.0 0.0 0.0} {0.0 0.0 0.0 1.0 1.0 1.0 0.0} {0.0 0.0 0.0 0.0 1.0 2.0 1.0} {0.0 0.0 0.0 0.0 0.0 1.0 3.0}} test det-1 "determinant" -match numbers -body { set a [mkBorder 5] set det [det $a] } -result {-0.328125} test det-2 "determinant" -match numbers -body { set a [mkWilkinsonW+ 5] set det [det $a] } -result {-4.0} test det-3 "determinant" -match numbers -body { set a [mkWilkinsonW- 5] set det [det $a] } -result {0.0} test det-4 "determinant with pre-computed decomposition" -match numbers -body { set a [mkWilkinsonW- 5] set ipiv [dgetrf a] set det [det $a $ipiv] } -result {0.0} #set ::tcl_precision 17 test largesteigen-1 "power method" -body { set a {{-261 209 -49} {-530 422 -98} {-800 631 -144}} set pm [largesteigen $a 1.e-8 200] set eigval [lindex $pm 0] set eigvec [lindex $pm 1] set res {} set expected {-0.2672612419124256177838 -0.5345224838248414656050 -0.8017837257372776305075} lappend res -eigvec [areClose $expected $eigvec 1.e-8] lappend res -eigval [areClose 10.0 $eigval 1.e-8] } -result {-eigvec 1 -eigval 1} test largesteigen-2 "power method" -body { set a {{-261 209 -49} {-530 422 -98} {-800 631 -144}} set pm [largesteigen $a] set eigval [lindex $pm 0] set eigvec [lindex $pm 1] set res {} set expected {-0.2672612419124256177838 -0.5345224838248414656050 -0.8017837257372776305075} lappend res -eigvec [areClose $expected $eigvec 1.e-5] lappend res -eigval [areClose 10.0 $eigval 1.e-5] } -result {-eigvec 1 -eigval 1} test largesteigen-3 "power method" -body { set a {{0.0 0.0 0.0} {0.0 0.0 0.0} {0.0 0.0 0.0}} catch { set pm [largesteigen $a] } errmsg set errmsg } -result {Cannot continue power method : matrix is singular} # Additional tests: procedures by Federico Ferri #source ferri/ferri.test set ::tcl_precision $prec if {$regular==1} then { testsuiteCleanup } else { tcltest::cleanupTests } tcllib-1.15/modules/math/math.test0000644000175000017500000001643412077663116016503 0ustar sergeisergei# Tests for math library. -*- tcl -*- # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1998-2000 by Ajuba Solutions. # All rights reserved. # # RCS: @(#) $Id: math.test,v 1.22 2009/12/04 17:37:47 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.2 testsNeedTcltest 1.0 testing { useLocal math.tcl math } # ------------------------------------------------------------------------- # # Create and register (in that order!) custom matching procedures # proc matchTolerant { expected actual } { set match 1 foreach a $actual e $expected { if { abs($e-$a)>0.0001*abs($e) && abs($e-$a)>0.0001*abs($a) } { set match 0 break } } return $match } # tcltest 2.0-ism, we rely here only on 1.0 features #customMatch tolerant matchTolerant test math-1.1 {math::min, wrong num args} { catch {math::min} msg set msg } [tcltest::wrongNumArgs math::min {val args} 0] test math-1.2 {simple math::min} { math::min 1 } 1 test math-1.3 {simple math::min} { math::min 2 1 } 1 test math-1.4 {math::min} { math::min 2 1 0 } 0 test math-1.5 {math::min with negative numbers} { math::min 2 1 0 -10 } -10 test math-1.6 {math::min with floating point numbers} { math::min 2 1 0 -10 -10.5 } -10.5 test math-2.1 {math::max, wrong num args} { catch {math::max} msg set msg } [tcltest::wrongNumArgs math::max {val args} 0] test math-2.2 {simple math::max} { math::max 1 } 1 test math-2.3 {simple math::max} { math::max 2 1 } 2 test math-2.4 {math::max} { math::max 0 2 1 0 } 2 test math-2.5 {math::max with negative numbers} { math::max 2 1 0 -10 } 2 test math-2.6 {math::max with floating point numbers} { math::max 2 1 0 -10 10.5 } 10.5 test math-3.1 {math::mean, wrong num args} { catch {math::mean} msg set msg } [tcltest::wrongNumArgs math::mean {val args} 0] test math-3.2 {simple math::mean} { math::mean 1 } 1.0 test math-3.3 {simple math::mean} { math::mean 2 1 } 1.5 test math-3.4 {math::mean} { math::mean 0 2 1 0 } 0.75 test math-3.5 {math::mean with negative numbers} { math::mean 2 1 0 -11 } -2.0 test math-3.6 {math::mean with floating point numbers} { matchTolerant 0.7 [math::mean 2 1 0 -10 10.5] } 1 test math-4.1 {math::sum, wrong num args} { catch {math::sum} msg set msg } [tcltest::wrongNumArgs math::sum {val args} 0] test math-4.2 {math::sum} { math::sum 1 } 1 test math-4.3 {math::sum} { math::sum 1 2 3 } 6 test math-4.4 {math::sum} { matchTolerant 1.6 [math::sum 0.1 0.2 0.3 1] } 1 test math-4.5 {math::sum} { math::sum -1 1 } 0 test math-5.1 {math::product, wrong num args} { catch {math::product} msg set msg } [tcltest::wrongNumArgs math::product {val args} 0] test math-5.2 {simple math::product} { math::product 1 } 1 test math-5.3 {simple math::product} { math::product 0 1 2 3 4 5 6 7 } 0 test math-5.4 {math::product} { math::product 1 2 3 4 5 } 120 test math-5.5 {math::product with negative numbers} { math::product 2 -10 } -20 test math-5.6 {math::product with floating point numbers} { math::product 2 0.5 } 1.0 test math-6.1 {math::sigma, wrong num args} { catch {math::sigma} msg set msg } [tcltest::wrongNumArgs math::sigma {val1 val2 args} 0] test math-6.2 {simple math::sigma} { catch {math::sigma 1} msg set msg } [tcltest::wrongNumArgs math::sigma {val1 val2 args} 1] test math-6.3 {simple math::sigma} { expr round([ math::sigma 100 120 ]) } 14 test math-6.4 {math::sigma} { expr round([ math::sigma 100 110 100 100 ]) } 5 test math-6.5 {math::sigma with negative numbers} { math::sigma 100 100 100 -100 } 100.0 test math-6.6 {math::sigma with floating point numbers} { math::sigma 100 110 100 100.0 } 5.0 test math-7.1 {math::cov, wrong num args} { catch {math::cov} msg set msg } [tcltest::wrongNumArgs math::cov {val1 val2 args} 0] test math-7.2 {simple math::cov} { catch {math::cov 1} msg set msg } [tcltest::wrongNumArgs math::cov {val1 val2 args} 1] test math-7.3 {simple math::cov} { math::cov 2 1 } 100.0 test math-7.4 {math::cov} { if {![catch { math::cov 0 2 1 0 } msg]} { if { [string equal $msg Infinity] || [string equal $msg Inf] } { set result ok } else { set result "result of cov was [list $msg],\ should be Infinity" } } else { if { [string equal [lrange $::errorCode 0 1] {ARITH DOMAIN}] } { set result ok } else { set result "error from cov was [list $::errorCode],\ should be {ARITH DOMAIN *}" } } set result } ok test math-7.5 {math::cov with negative numbers} { math::cov 100 100 100 -100 } 200.0 test math-7.6 {math::cov with floating point numbers} { string range [ math::cov 100 110 100 100.0 ] 0 0 } 4 test math-7.7 {math::cov with zero mean} { # Throw an error catch { math::cov 1 1 -2 } msg } 1 test math-8.1 {math::stats, wrong num of args} { catch { math::stats } msg set msg } [tcltest::wrongNumArgs math::stats {val1 val2 args} 0] test math-8.2 {math::stats, wrong num of args} { catch { math::stats 100 } msg set msg } [tcltest::wrongNumArgs math::stats {val1 val2 args} 1] test math-8.3 { simple math::stats } { foreach {a b c} [ math::stats 100 100 100 110 ] { break } set a [ expr round($a) ] set b [ expr round($b) ] set c [ expr round($c) ] list $a $b $c } {102 5 5} test math-9.1 { math::integrate, insufficient data points } { catch { math::integrate {1 10 2 20 3 30 4 40} } msg set msg } "at least 5 x,y pairs must be given" test math-9.2 { simple math::integrate } { math::integrate {1 10 2 20 3 30 4 40 5 50 6 60 7 70 8 80 9 90 10 100} } {500.0 0.5} test math-10.1 { math::random } { set result [expr round(srand(12345) * 1000)] for {set i 0} {$i < 10} {incr i} { lappend result [expr round([::math::random] * 1000)] } set result } {97 834 948 36 12 51 766 585 914 784 333} test math-10.2 { math::random value } { set result {} expr {srand(12345)} for {set i 0} {$i < 10} {incr i} { lappend result [::math::random 10] } set result } {8 9 0 0 0 7 5 9 7 3} test math-10.3 { math::random value value } { set result {} expr {srand(12345)} for {set i 0} {$i < 10} {incr i} { lappend result [::math::random 5 15] } set result } {13 14 5 5 5 12 10 14 12 8} test math-10.4 {math::random} { list [catch {::math::random foo bar baz} msg] $msg } [list 1 "wrong # args: should be \"::math::random ?value1? ?value2?\""] test math-11.1 {math::fibonacci} { set result {} for {set i 0} {$i < 15} {incr i} { lappend result [::math::fibonacci $i] } set result } [list 0 1 1 2 3 5 8 13 21 34 55 89 144 233 377] test math-12.1 {Safe Interpreter} { ::safe::interpCreate safeInterp interp alias safeInterp puts {} puts set result [interp eval safeInterp { package require math set result [math::cov 100 100 100 -100] }] interp delete safeInterp set result } 200.0 testsuiteCleanup tcllib-1.15/modules/math/calculus.tcl0000755000175000017500000013116112077663116017166 0ustar sergeisergei# calculus.tcl -- # Package that implements several basic numerical methods, such # as the integration of a one-dimensional function and the # solution of a system of first-order differential equations. # # Copyright (c) 2002, 2003, 2004, 2006 by Arjen Markus. # Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: calculus.tcl,v 1.15 2008/10/08 03:30:48 andreas_kupries Exp $ package require Tcl 8.4 package require math::interpolate package provide math::calculus 0.7.1 # math::calculus -- # Namespace for the commands namespace eval ::math::calculus { namespace import ::math::interpolate::neville namespace import ::math::expectDouble ::math::expectInteger namespace export \ integral integralExpr integral2D integral3D \ eulerStep heunStep rungeKuttaStep \ boundaryValueSecondOrder solveTriDiagonal \ newtonRaphson newtonRaphsonParameters namespace export \ integral2D_2accurate integral3D_accurate namespace export romberg romberg_infinity namespace export romberg_sqrtSingLower romberg_sqrtSingUpper namespace export romberg_powerLawLower romberg_powerLawUpper namespace export romberg_expLower romberg_expUpper namespace export regula_falsi variable nr_maxiter 20 variable nr_tolerance 0.001 } # integral -- # Integrate a function over a given interval using the Simpson rule # # Arguments: # begin Start of the interval # end End of the interval # nosteps Number of steps in which to divide the interval # func Name of the function to be integrated (takes one # argument) # Return value: # Computed integral # proc ::math::calculus::integral { begin end nosteps func } { set delta [expr {($end-$begin)/double($nosteps)}] set hdelta [expr {$delta/2.0}] set result 0.0 set xval $begin set func_end [uplevel 1 $func $xval] for { set i 1 } { $i <= $nosteps } { incr i } { set func_begin $func_end set func_middle [uplevel 1 $func [expr {$xval+$hdelta}]] set func_end [uplevel 1 $func [expr {$xval+$delta}]] set result [expr {$result+$func_begin+4.0*$func_middle+$func_end}] set xval [expr {$begin+double($i)*$delta}] } return [expr {$result*$delta/6.0}] } # integralExpr -- # Integrate an expression with "x" as the integrate according to the # Simpson rule # # Arguments: # begin Start of the interval # end End of the interval # nosteps Number of steps in which to divide the interval # expression Expression with "x" as the integrate # Return value: # Computed integral # proc ::math::calculus::integralExpr { begin end nosteps expression } { set delta [expr {($end-$begin)/double($nosteps)}] set hdelta [expr {$delta/2.0}] set result 0.0 set x $begin # FRINK: nocheck set func_end [expr $expression] for { set i 1 } { $i <= $nosteps } { incr i } { set func_begin $func_end set x [expr {$x+$hdelta}] # FRINK: nocheck set func_middle [expr $expression] set x [expr {$x+$hdelta}] # FRINK: nocheck set func_end [expr $expression] set result [expr {$result+$func_begin+4.0*$func_middle+$func_end}] set x [expr {$begin+double($i)*$delta}] } return [expr {$result*$delta/6.0}] } # integral2D -- # Integrate a given fucntion of two variables over a block, # using bilinear interpolation (for this moment: block function) # # Arguments: # xinterval Start, stop and number of steps of the "x" interval # yinterval Start, stop and number of steps of the "y" interval # func Function of the two variables to be integrated # Return value: # Computed integral # proc ::math::calculus::integral2D { xinterval yinterval func } { foreach { xbegin xend xnumber } $xinterval { break } foreach { ybegin yend ynumber } $yinterval { break } set xdelta [expr {($xend-$xbegin)/double($xnumber)}] set ydelta [expr {($yend-$ybegin)/double($ynumber)}] set hxdelta [expr {$xdelta/2.0}] set hydelta [expr {$ydelta/2.0}] set result 0.0 set dxdy [expr {$xdelta*$ydelta}] for { set j 0 } { $j < $ynumber } { incr j } { set y [expr {$ybegin+$hydelta+double($j)*$ydelta}] for { set i 0 } { $i < $xnumber } { incr i } { set x [expr {$xbegin+$hxdelta+double($i)*$xdelta}] set func_value [uplevel 1 $func $x $y] set result [expr {$result+$func_value}] } } return [expr {$result*$dxdy}] } # integral3D -- # Integrate a given fucntion of two variables over a block, # using trilinear interpolation (for this moment: block function) # # Arguments: # xinterval Start, stop and number of steps of the "x" interval # yinterval Start, stop and number of steps of the "y" interval # zinterval Start, stop and number of steps of the "z" interval # func Function of the three variables to be integrated # Return value: # Computed integral # proc ::math::calculus::integral3D { xinterval yinterval zinterval func } { foreach { xbegin xend xnumber } $xinterval { break } foreach { ybegin yend ynumber } $yinterval { break } foreach { zbegin zend znumber } $zinterval { break } set xdelta [expr {($xend-$xbegin)/double($xnumber)}] set ydelta [expr {($yend-$ybegin)/double($ynumber)}] set zdelta [expr {($zend-$zbegin)/double($znumber)}] set hxdelta [expr {$xdelta/2.0}] set hydelta [expr {$ydelta/2.0}] set hzdelta [expr {$zdelta/2.0}] set result 0.0 set dxdydz [expr {$xdelta*$ydelta*$zdelta}] for { set k 0 } { $k < $znumber } { incr k } { set z [expr {$zbegin+$hzdelta+double($k)*$zdelta}] for { set j 0 } { $j < $ynumber } { incr j } { set y [expr {$ybegin+$hydelta+double($j)*$ydelta}] for { set i 0 } { $i < $xnumber } { incr i } { set x [expr {$xbegin+$hxdelta+double($i)*$xdelta}] set func_value [uplevel 1 $func $x $y $z] set result [expr {$result+$func_value}] } } } return [expr {$result*$dxdydz}] } # integral2D_accurate -- # Integrate a given function of two variables over a block, # using a four-point quadrature formula # # Arguments: # xinterval Start, stop and number of steps of the "x" interval # yinterval Start, stop and number of steps of the "y" interval # func Function of the two variables to be integrated # Return value: # Computed integral # proc ::math::calculus::integral2D_accurate { xinterval yinterval func } { foreach { xbegin xend xnumber } $xinterval { break } foreach { ybegin yend ynumber } $yinterval { break } set alpha [expr {sqrt(2.0/3.0)}] set minalpha [expr {-$alpha}] set dpoints [list $alpha 0.0 $minalpha 0.0 0.0 $alpha 0.0 $minalpha] set xdelta [expr {($xend-$xbegin)/double($xnumber)}] set ydelta [expr {($yend-$ybegin)/double($ynumber)}] set hxdelta [expr {$xdelta/2.0}] set hydelta [expr {$ydelta/2.0}] set result 0.0 set dxdy [expr {0.25*$xdelta*$ydelta}] for { set j 0 } { $j < $ynumber } { incr j } { set y [expr {$ybegin+$hydelta+double($j)*$ydelta}] for { set i 0 } { $i < $xnumber } { incr i } { set x [expr {$xbegin+$hxdelta+double($i)*$xdelta}] foreach {dx dy} $dpoints { set x1 [expr {$x+$dx}] set y1 [expr {$y+$dy}] set func_value [uplevel 1 $func $x1 $y1] set result [expr {$result+$func_value}] } } } return [expr {$result*$dxdy}] } # integral3D_accurate -- # Integrate a given function of three variables over a block, # using an 8-point quadrature formula # # Arguments: # xinterval Start, stop and number of steps of the "x" interval # yinterval Start, stop and number of steps of the "y" interval # zinterval Start, stop and number of steps of the "z" interval # func Function of the three variables to be integrated # Return value: # Computed integral # proc ::math::calculus::integral3D_accurate { xinterval yinterval zinterval func } { foreach { xbegin xend xnumber } $xinterval { break } foreach { ybegin yend ynumber } $yinterval { break } foreach { zbegin zend znumber } $zinterval { break } set alpha [expr {sqrt(1.0/3.0)}] set minalpha [expr {-$alpha}] set dpoints [list $alpha $alpha $alpha \ $alpha $alpha $minalpha \ $alpha $minalpha $alpha \ $alpha $minalpha $minalpha \ $minalpha $alpha $alpha \ $minalpha $alpha $minalpha \ $minalpha $minalpha $alpha \ $minalpha $minalpha $minalpha ] set xdelta [expr {($xend-$xbegin)/double($xnumber)}] set ydelta [expr {($yend-$ybegin)/double($ynumber)}] set zdelta [expr {($zend-$zbegin)/double($znumber)}] set hxdelta [expr {$xdelta/2.0}] set hydelta [expr {$ydelta/2.0}] set hzdelta [expr {$zdelta/2.0}] set result 0.0 set dxdydz [expr {0.125*$xdelta*$ydelta*$zdelta}] for { set k 0 } { $k < $znumber } { incr k } { set z [expr {$zbegin+$hzdelta+double($k)*$zdelta}] for { set j 0 } { $j < $ynumber } { incr j } { set y [expr {$ybegin+$hydelta+double($j)*$ydelta}] for { set i 0 } { $i < $xnumber } { incr i } { set x [expr {$xbegin+$hxdelta+double($i)*$xdelta}] foreach {dx dy dz} $dpoints { set x1 [expr {$x+$dx}] set y1 [expr {$y+$dy}] set z1 [expr {$z+$dz}] set func_value [uplevel 1 $func $x1 $y1 $z1] set result [expr {$result+$func_value}] } } } } return [expr {$result*$dxdydz}] } # eulerStep -- # Integrate a system of ordinary differential equations of the type # x' = f(x,t), where x is a vector of quantities. Integration is # done over a single step according to Euler's method. # # Arguments: # t Start value of independent variable (time for instance) # tstep Step size of interval # xvec Vector of dependent values at the start # func Function taking the arguments t and xvec to return # the derivative of each dependent variable. # Return value: # List of values at the end of the step # proc ::math::calculus::eulerStep { t tstep xvec func } { set xderiv [uplevel 1 $func $t [list $xvec]] set result {} foreach xv $xvec dx $xderiv { set xnew [expr {$xv+$tstep*$dx}] lappend result $xnew } return $result } # heunStep -- # Integrate a system of ordinary differential equations of the type # x' = f(x,t), where x is a vector of quantities. Integration is # done over a single step according to Heun's method. # # Arguments: # t Start value of independent variable (time for instance) # tstep Step size of interval # xvec Vector of dependent values at the start # func Function taking the arguments t and xvec to return # the derivative of each dependent variable. # Return value: # List of values at the end of the step # proc ::math::calculus::heunStep { t tstep xvec func } { # # Predictor step # set funcq [uplevel 1 namespace which -command $func] set xpred [eulerStep $t $tstep $xvec $funcq] # # Corrector step # set tcorr [expr {$t+$tstep}] set xcorr [eulerStep $t $tstep $xpred $funcq] set result {} foreach xv $xvec xc $xcorr { set xnew [expr {0.5*($xv+$xc)}] lappend result $xnew } return $result } # rungeKuttaStep -- # Integrate a system of ordinary differential equations of the type # x' = f(x,t), where x is a vector of quantities. Integration is # done over a single step according to Runge-Kutta 4th order. # # Arguments: # t Start value of independent variable (time for instance) # tstep Step size of interval # xvec Vector of dependent values at the start # func Function taking the arguments t and xvec to return # the derivative of each dependent variable. # Return value: # List of values at the end of the step # proc ::math::calculus::rungeKuttaStep { t tstep xvec func } { set funcq [uplevel 1 namespace which -command $func] # # Four steps: # - k1 = tstep*func(t,x0) # - k2 = tstep*func(t+0.5*tstep,x0+0.5*k1) # - k3 = tstep*func(t+0.5*tstep,x0+0.5*k2) # - k4 = tstep*func(t+ tstep,x0+ k3) # - x1 = x0 + (k1+2*k2+2*k3+k4)/6 # set tstep2 [expr {$tstep/2.0}] set tstep6 [expr {$tstep/6.0}] set xk1 [$funcq $t $xvec] set xvec2 {} foreach x1 $xvec xv $xk1 { lappend xvec2 [expr {$x1+$tstep2*$xv}] } set xk2 [$funcq [expr {$t+$tstep2}] $xvec2] set xvec3 {} foreach x1 $xvec xv $xk2 { lappend xvec3 [expr {$x1+$tstep2*$xv}] } set xk3 [$funcq [expr {$t+$tstep2}] $xvec3] set xvec4 {} foreach x1 $xvec xv $xk3 { lappend xvec4 [expr {$x1+$tstep*$xv}] } set xk4 [$funcq [expr {$t+$tstep}] $xvec4] set result {} foreach x0 $xvec k1 $xk1 k2 $xk2 k3 $xk3 k4 $xk4 { set dx [expr {$k1+2.0*$k2+2.0*$k3+$k4}] lappend result [expr {$x0+$dx*$tstep6}] } return $result } # boundaryValueSecondOrder -- # Integrate a second-order differential equation and solve for # given boundary values. # # The equation is (see the documentation): # d dy d # -- A(x) -- + -- B(x) y + C(x) y = D(x) # dx dx dx # # The procedure uses finite differences and tridiagonal matrices to # solve the equation. The boundary values are put in the matrix # directly. # # Arguments: # coeff_func Name of triple-valued function for coefficients A, B, C # force_func Name of the function providing the force term D(x) # leftbnd Left boundary condition (list of: xvalue, boundary # value or keyword zero-flux, zero-derivative) # rightbnd Right boundary condition (ditto) # nostep Number of steps # Return value: # List of x-values and calculated values (x1, y1, x2, y2, ...) # proc ::math::calculus::boundaryValueSecondOrder { coeff_func force_func leftbnd rightbnd nostep } { set coeffq [uplevel 1 namespace which -command $coeff_func] set forceq [uplevel 1 namespace which -command $force_func] if { [llength $leftbnd] != 2 || [llength $rightbnd] != 2 } { error "Boundary condition(s) incorrect" } if { $nostep < 1 } { error "Number of steps must be larger/equal 1" } # # Set up the matrix, as three different lists and the # righthand side as the fourth # set xleft [lindex $leftbnd 0] set xright [lindex $rightbnd 0] set xstep [expr {($xright-$xleft)/double($nostep)}] set acoeff {} set bcoeff {} set ccoeff {} set dvalue {} set x $xleft foreach {A B C} [$coeffq $x] { break } set A1 [expr {$A/$xstep-0.5*$B}] set B1 [expr {$A/$xstep+0.5*$B+0.5*$C*$xstep}] set C1 0.0 for { set i 1 } { $i <= $nostep } { incr i } { set x [expr {$xleft+double($i)*$xstep}] if { [expr {abs($x)-0.5*abs($xstep)}] < 0.0 } { set x 0.0 } foreach {A B C} [$coeffq $x] { break } set A2 0.0 set B2 [expr {$A/$xstep-0.5*$B+0.5*$C*$xstep}] set C2 [expr {$A/$xstep+0.5*$B}] lappend acoeff [expr {$A1+$A2}] lappend bcoeff [expr {-$B1-$B2}] lappend ccoeff [expr {$C1+$C2}] set A1 [expr {$A/$xstep-0.5*$B}] set B1 [expr {$A/$xstep+0.5*$B+0.5*$C*$xstep}] set C1 0.0 } set xvec {} for { set i 0 } { $i < $nostep } { incr i } { set x [expr {$xleft+(0.5+double($i))*$xstep}] if { [expr {abs($x)-0.25*abs($xstep)}] < 0.0 } { set x 0.0 } lappend xvec $x lappend dvalue [expr {$xstep*[$forceq $x]}] } # # Substitute the boundary values # set A [lindex $acoeff 0] set D [lindex $dvalue 0] set D1 [expr {$D-$A*[lindex $leftbnd 1]}] set C [lindex $ccoeff end] set D [lindex $dvalue end] set D2 [expr {$D-$C*[lindex $rightbnd 1]}] set dvalue [concat $D1 [lrange $dvalue 1 end-1] $D2] set yvec [solveTriDiagonal [lrange $acoeff 1 end] $bcoeff [lrange $ccoeff 0 end-1] $dvalue] foreach x $xvec y $yvec { lappend result $x $y } return $result } # solveTriDiagonal -- # Solve a system of equations Ax = b where A is a tridiagonal matrix # # Arguments: # acoeff Values on lower diagonal # bcoeff Values on main diagonal # ccoeff Values on upper diagonal # dvalue Values on righthand side # Return value: # List of values forming the solution # proc ::math::calculus::solveTriDiagonal { acoeff bcoeff ccoeff dvalue } { set nostep [llength $acoeff] # # First step: Gauss-elimination # set B [lindex $bcoeff 0] set C [lindex $ccoeff 0] set D [lindex $dvalue 0] set acoeff [concat 0.0 $acoeff] set bcoeff2 [list $B] set dvalue2 [list $D] for { set i 1 } { $i <= $nostep } { incr i } { set A2 [lindex $acoeff $i] set B2 [lindex $bcoeff $i] set D2 [lindex $dvalue $i] set ratab [expr {$A2/double($B)}] set B2 [expr {$B2-$ratab*$C}] set D2 [expr {$D2-$ratab*$D}] lappend bcoeff2 $B2 lappend dvalue2 $D2 set B $B2 set C [lindex $ccoeff $i] set D $D2 } # # Second step: substitution # set yvec {} set B [lindex $bcoeff2 end] set D [lindex $dvalue2 end] set y [expr {$D/$B}] for { set i [expr {$nostep-1}] } { $i >= 0 } { incr i -1 } { set yvec [concat $y $yvec] set B [lindex $bcoeff2 $i] set C [lindex $ccoeff $i] set D [lindex $dvalue2 $i] set y [expr {($D-$C*$y)/$B}] } set yvec [concat $y $yvec] return $yvec } # newtonRaphson -- # Determine the root of an equation via the Newton-Raphson method # # Arguments: # func Function (proc) in x # deriv Derivative (proc) of func w.r.t. x # initval Initial value for x # Return value: # Estimate of root # proc ::math::calculus::newtonRaphson { func deriv initval } { variable nr_maxiter variable nr_tolerance set funcq [uplevel 1 namespace which -command $func] set derivq [uplevel 1 namespace which -command $deriv] set value $initval set diff [expr {10.0*$nr_tolerance}] for { set i 0 } { $i < $nr_maxiter } { incr i } { if { $diff < $nr_tolerance } { break } set newval [expr {$value-[$funcq $value]/[$derivq $value]}] if { $value != 0.0 } { set diff [expr {abs($newval-$value)/abs($value)}] } else { set diff [expr {abs($newval-$value)}] } set value $newval } return $newval } # newtonRaphsonParameters -- # Set the parameters for the Newton-Raphson method # # Arguments: # maxiter Maximum number of iterations # tolerance Relative precisiion of the result # Return value: # None # proc ::math::calculus::newtonRaphsonParameters { maxiter tolerance } { variable nr_maxiter variable nr_tolerance if { $maxiter > 0 } { set nr_maxiter $maxiter } if { $tolerance > 0 } { set nr_tolerance $tolerance } } #---------------------------------------------------------------------- # # midpoint -- # # Perform one set of steps in evaluating an integral using the # midpoint method. # # Usage: # midpoint f a b s ?n? # # Parameters: # f - function to integrate # a - One limit of integration # b - Other limit of integration. a and b need not be in ascending # order. # s - Value returned from a previous call to midpoint (see below) # n - Step number (see below) # # Results: # Returns an estimate of the integral obtained by dividing the # interval into 3**n equal intervals and using the midpoint rule. # # Side effects: # f is evaluated 2*3**(n-1) times and may have side effects. # # The 'midpoint' procedure is designed for successive approximations. # It should be called initially with n==0. On this initial call, s # is ignored. The function is evaluated at the midpoint of the interval, and # the value is multiplied by the width of the interval to give the # coarsest possible estimate of the integral. # # On each iteration except the first, n should be incremented by one, # and the previous value returned from [midpoint] should be supplied # as 's'. The function will be evaluated at additional points # to give a total of 3**n equally spaced points, and the estimate # of the integral will be updated and returned # # Under normal circumstances, user code will not call this function # directly. Instead, it will use ::math::calculus::romberg to # do error control and extrapolation to a zero step size. # #---------------------------------------------------------------------- proc ::math::calculus::midpoint { f a b { n 0 } { s 0. } } { if { $n == 0 } { # First iteration. Simply evaluate the function at the midpoint # of the interval. set cmd $f; lappend cmd [expr { 0.5 * ( $a + $b ) }]; set v [eval $cmd] return [expr { ( $b - $a ) * $v }] } else { # Subsequent iterations. We've divided the interval into # $it subintervals. Evaluate the function at the 1/3 and # 2/3 points of each subinterval. Then update the estimate # of the integral that we produced on the last step with # the new sum. set it [expr { pow( 3, $n-1 ) }] set h [expr { ( $b - $a ) / ( 3. * $it ) }] set h2 [expr { $h + $h }] set x [expr { $a + 0.5 * $h }] set sum 0 for { set j 0 } { $j < $it } { incr j } { set cmd $f; lappend cmd $x; set y [eval $cmd] set sum [expr { $sum + $y }] set x [expr { $x + $h2 }] set cmd $f; lappend cmd $x; set y [eval $cmd] set sum [expr { $sum + $y }] set x [expr { $x + $h}] } return [expr { ( $s + ( $b - $a ) * $sum / $it ) / 3. }] } } #---------------------------------------------------------------------- # # romberg -- # # Compute the integral of a function over an interval using # Romberg's method. # # Usage: # romberg f a b ?-option value?... # # Parameters: # f - Function to integrate. Must be a single Tcl command, # to which will be appended the abscissa at which the function # should be evaluated. f should be analytic over the # region of integration, but may have a removable singularity # at either endpoint. # a - One bound of the interval # b - The other bound of the interval. a and b need not be in # ascending order. # # Options: # -abserror ABSERROR # Requests that the integration be performed to make # the estimated absolute error of the integral less than # the given value. Default is 1.e-10. # -relerror RELERROR # Requests that the integration be performed to make # the estimated absolute error of the integral less than # the given value. Default is 1.e-6. # -degree N # Specifies the degree of the polynomial that will be # used to extrapolate to a zero step size. -degree 0 # requests integration with the midpoint rule; -degree 1 # is equivalent to Simpson's 3/8 rule; higher degrees # are difficult to describe but (within reason) give # faster convergence for smooth functions. Default is # -degree 4. # -maxiter N # Specifies the maximum number of triplings of the # number of steps to take in integration. At most # 3**N function evaluations will be performed in # integrating with -maxiter N. The integration # will terminate at that time, even if the result # satisfies neither the -relerror nor -abserror tests. # # Results: # Returns a two-element list. The first element is the estimated # value of the integral; the second is the estimated absolute # error of the value. # #---------------------------------------------------------------------- proc ::math::calculus::romberg { f a b args } { # Replace f with a context-independent version set f [lreplace $f 0 0 [uplevel 1 [list namespace which [lindex $f 0]]]] # Assign default parameters array set params { -abserror 1.0e-10 -degree 4 -relerror 1.0e-6 -maxiter 14 } # Extract parameters if { ( [llength $args] % 2 ) != 0 } { return -code error -errorcode [list romberg wrongNumArgs] \ "wrong \# args, should be\ \"[lreplace [info level 0] 1 end \ f x1 x2 ?-option value?...]\"" } foreach { key value } $args { if { ![info exists params($key)] } { return -code error -errorcode [list romberg badoption $key] \ "unknown option \"$key\",\ should be -abserror, -degree, -relerror, or -maxiter" } set params($key) $value } # Check params if { ![string is double -strict $a] } { return -code error [expectDouble $a] } if { ![string is double -strict $b] } { return -code error [expectDouble $b] } if { ![string is double -strict $params(-abserror)] } { return -code error [expectDouble $params(-abserror)] } if { ![string is integer -strict $params(-degree)] } { return -code error [expectInteger $params(-degree)] } if { ![string is integer -strict $params(-maxiter)] } { return -code error [expectInteger $params(-maxiter)] } if { ![string is double -strict $params(-relerror)] } { return -code error [expectDouble $params(-relerror)] } foreach key {-abserror -degree -maxiter -relerror} { if { $params($key) <= 0 } { return -code error -errorcode [list romberg notPositive $key] \ "$key must be positive" } } if { $params(-maxiter) <= $params(-degree) } { return -code error -errorcode [list romberg tooFewIter] \ "-maxiter must be greater than -degree" } # Create lists of step size and sum with the given number of steps. set x [list] set y [list] set s 0; # Current best estimate of integral set indx end-$params(-degree) set pow3 1.; # Current step size (times b-a) # Perform successive integrations, tripling the number of steps each time for { set i 0 } { $i < $params(-maxiter) } { incr i } { set s [midpoint $f $a $b $i $s] lappend x $pow3 lappend y $s set pow3 [expr { $pow3 / 9. }] # Once $degree steps have been done, start Richardson extrapolation # to a zero step size. if { $i >= $params(-degree) } { set x [lrange $x $indx end] set y [lrange $y $indx end] foreach {estimate err} [neville $x $y 0.] break if { $err < $params(-abserror) || $err < $params(-relerror) * abs($estimate) } { return [list $estimate $err] } } } # If -maxiter iterations have been done, give up, and return # with the current error estimate. return [list $estimate $err] } #---------------------------------------------------------------------- # # u_infinity -- # Change of variable for integrating over a half-infinite # interval # # Parameters: # f - Function being integrated # u - 1/x, where x is the abscissa where f is to be evaluated # # Results: # Returns f(1/u)/(u**2) # # Side effects: # Whatever f does. # #---------------------------------------------------------------------- proc ::math::calculus::u_infinity { f u } { set cmd $f lappend cmd [expr { 1.0 / $u }] set y [eval $cmd] return [expr { $y / ( $u * $u ) }] } #---------------------------------------------------------------------- # # romberg_infinity -- # Evaluate a function on a half-open interval # # Usage: # Same as 'romberg' # # The 'romberg_infinity' procedure performs Romberg integration on # an interval [a,b] where an infinite a or b may be represented by # a large number (e.g. 1.e30). It operates by a change of variable; # instead of integrating f(x) from a to b, it makes a change # of variable u = 1/x, and integrates from 1/b to 1/a f(1/u)/u**2 du. # #---------------------------------------------------------------------- proc ::math::calculus::romberg_infinity { f a b args } { if { ![string is double -strict $a] } { return -code error [expectDouble $a] } if { ![string is double -strict $b] } { return -code error [expectDouble $b] } if { $a * $b <= 0. } { return -code error -errorcode {romberg_infinity cross-axis} \ "limits of integration have opposite sign" } set f [lreplace $f 0 0 [uplevel 1 [list namespace which [lindex $f 0]]]] set f [list u_infinity $f] return [eval [linsert $args 0 \ romberg $f [expr { 1.0 / $b }] [expr { 1.0 / $a }]]] } #---------------------------------------------------------------------- # # u_sqrtSingLower -- # Change of variable for integrating over an interval with # an inverse square root singularity at the lower bound. # # Parameters: # f - Function being integrated # a - Lower bound # u - sqrt(x-a), where x is the abscissa where f is to be evaluated # # Results: # Returns 2 * u * f( a + u**2 ) # # Side effects: # Whatever f does. # #---------------------------------------------------------------------- proc ::math::calculus::u_sqrtSingLower { f a u } { set cmd $f lappend cmd [expr { $a + $u * $u }] set y [eval $cmd] return [expr { 2. * $u * $y }] } #---------------------------------------------------------------------- # # u_sqrtSingUpper -- # Change of variable for integrating over an interval with # an inverse square root singularity at the upper bound. # # Parameters: # f - Function being integrated # b - Upper bound # u - sqrt(b-x), where x is the abscissa where f is to be evaluated # # Results: # Returns 2 * u * f( b - u**2 ) # # Side effects: # Whatever f does. # #---------------------------------------------------------------------- proc ::math::calculus::u_sqrtSingUpper { f b u } { set cmd $f lappend cmd [expr { $b - $u * $u }] set y [eval $cmd] return [expr { 2. * $u * $y }] } #---------------------------------------------------------------------- # # math::calculus::romberg_sqrtSingLower -- # Integrate a function with an inverse square root singularity # at the lower bound # # Usage: # Same as 'romberg' # # The 'romberg_sqrtSingLower' procedure is a wrapper for 'romberg' # for integrating a function with an inverse square root singularity # at the lower bound of the interval. It works by making the change # of variable u = sqrt( x-a ). # #---------------------------------------------------------------------- proc ::math::calculus::romberg_sqrtSingLower { f a b args } { if { ![string is double -strict $a] } { return -code error [expectDouble $a] } if { ![string is double -strict $b] } { return -code error [expectDouble $b] } if { $a >= $b } { return -code error "limits of integration out of order" } set f [lreplace $f 0 0 [uplevel 1 [list namespace which [lindex $f 0]]]] set f [list u_sqrtSingLower $f $a] return [eval [linsert $args 0 \ romberg $f 0 [expr { sqrt( $b - $a ) }]]] } #---------------------------------------------------------------------- # # math::calculus::romberg_sqrtSingUpper -- # Integrate a function with an inverse square root singularity # at the upper bound # # Usage: # Same as 'romberg' # # The 'romberg_sqrtSingUpper' procedure is a wrapper for 'romberg' # for integrating a function with an inverse square root singularity # at the upper bound of the interval. It works by making the change # of variable u = sqrt( b-x ). # #---------------------------------------------------------------------- proc ::math::calculus::romberg_sqrtSingUpper { f a b args } { if { ![string is double -strict $a] } { return -code error [expectDouble $a] } if { ![string is double -strict $b] } { return -code error [expectDouble $b] } if { $a >= $b } { return -code error "limits of integration out of order" } set f [lreplace $f 0 0 [uplevel 1 [list namespace which [lindex $f 0]]]] set f [list u_sqrtSingUpper $f $b] return [eval [linsert $args 0 \ romberg $f 0. [expr { sqrt( $b - $a ) }]]] } #---------------------------------------------------------------------- # # u_powerLawLower -- # Change of variable for integrating over an interval with # an integrable power law singularity at the lower bound. # # Parameters: # f - Function being integrated # gammaover1mgamma - gamma / (1 - gamma), where gamma is the power # oneover1mgamma - 1 / (1 - gamma), where gamma is the power # a - Lower limit of integration # u - Changed variable u == (x-a)**(1-gamma) # # Results: # Returns u**(1/1-gamma) * f(a + u**(1/1-gamma) ). # # Side effects: # Whatever f does. # #---------------------------------------------------------------------- proc ::math::calculus::u_powerLawLower { f gammaover1mgamma oneover1mgamma a u } { set cmd $f lappend cmd [expr { $a + pow( $u, $oneover1mgamma ) }] set y [eval $cmd] return [expr { $y * pow( $u, $gammaover1mgamma ) }] } #---------------------------------------------------------------------- # # math::calculus::romberg_powerLawLower -- # Integrate a function with an integrable power law singularity # at the lower bound # # Usage: # romberg_powerLawLower gamma f a b ?-option value...? # # Parameters: # gamma - Power (0= 1.0 } { return -code error -errorcode [list romberg gammaTooBig] \ "gamma must lie in the interval (0,1)" } if { ![string is double -strict $a] } { return -code error [expectDouble $a] } if { ![string is double -strict $b] } { return -code error [expectDouble $b] } if { $a >= $b } { return -code error "limits of integration out of order" } set f [lreplace $f 0 0 [uplevel 1 [list namespace which [lindex $f 0]]]] set onemgamma [expr { 1. - $gamma }] set f [list u_powerLawLower $f \ [expr { $gamma / $onemgamma }] \ [expr { 1 / $onemgamma }] \ $a] set limit [expr { pow( $b - $a, $onemgamma ) }] set result {} foreach v [eval [linsert $args 0 romberg $f 0 $limit]] { lappend result [expr { $v / $onemgamma }] } return $result } #---------------------------------------------------------------------- # # u_powerLawLower -- # Change of variable for integrating over an interval with # an integrable power law singularity at the upper bound. # # Parameters: # f - Function being integrated # gammaover1mgamma - gamma / (1 - gamma), where gamma is the power # oneover1mgamma - 1 / (1 - gamma), where gamma is the power # b - Upper limit of integration # u - Changed variable u == (b-x)**(1-gamma) # # Results: # Returns u**(1/1-gamma) * f(b-u**(1/1-gamma) ). # # Side effects: # Whatever f does. # #---------------------------------------------------------------------- proc ::math::calculus::u_powerLawUpper { f gammaover1mgamma oneover1mgamma b u } { set cmd $f lappend cmd [expr { $b - pow( $u, $oneover1mgamma ) }] set y [eval $cmd] return [expr { $y * pow( $u, $gammaover1mgamma ) }] } #---------------------------------------------------------------------- # # math::calculus::romberg_powerLawUpper -- # Integrate a function with an integrable power law singularity # at the upper bound # # Usage: # romberg_powerLawLower gamma f a b ?-option value...? # # Parameters: # gamma - Power (0= 1.0 } { return -code error -errorcode [list romberg gammaTooBig] \ "gamma must lie in the interval (0,1)" } if { ![string is double -strict $a] } { return -code error [expectDouble $a] } if { ![string is double -strict $b] } { return -code error [expectDouble $b] } if { $a >= $b } { return -code error "limits of integration out of order" } set f [lreplace $f 0 0 [uplevel 1 [list namespace which [lindex $f 0]]]] set onemgamma [expr { 1. - $gamma }] set f [list u_powerLawUpper $f \ [expr { $gamma / $onemgamma }] \ [expr { 1. / $onemgamma }] \ $b] set limit [expr { pow( $b - $a, $onemgamma ) }] set result {} foreach v [eval [linsert $args 0 romberg $f 0 $limit]] { lappend result [expr { $v / $onemgamma }] } return $result } #---------------------------------------------------------------------- # # u_expUpper -- # # Change of variable to integrate a function that decays # exponentially. # # Parameters: # f - Function to integrate # u - Changed variable u = exp(-x) # # Results: # Returns (1/u)*f(-log(u)) # # Side effects: # Whatever f does. # #---------------------------------------------------------------------- proc ::math::calculus::u_expUpper { f u } { set cmd $f lappend cmd [expr { -log($u) }] set y [eval $cmd] return [expr { $y / $u }] } #---------------------------------------------------------------------- # # romberg_expUpper -- # # Integrate a function that decays exponentially over a # half-infinite interval. # # Parameters: # Same as romberg. The upper limit of integration, 'b', # is expected to be very large. # # Results: # Same as romberg. # # The romberg_expUpper function operates by making the change of # variable, u = exp(-x). # #---------------------------------------------------------------------- proc ::math::calculus::romberg_expUpper { f a b args } { if { ![string is double -strict $a] } { return -code error [expectDouble $a] } if { ![string is double -strict $b] } { return -code error [expectDouble $b] } if { $a >= $b } { return -code error "limits of integration out of order" } set f [lreplace $f 0 0 [uplevel 1 [list namespace which [lindex $f 0]]]] set f [list u_expUpper $f] return [eval [linsert $args 0 \ romberg $f [expr {exp(-$b)}] [expr {exp(-$a)}]]] } #---------------------------------------------------------------------- # # u_expLower -- # # Change of variable to integrate a function that grows # exponentially. # # Parameters: # f - Function to integrate # u - Changed variable u = exp(x) # # Results: # Returns (1/u)*f(log(u)) # # Side effects: # Whatever f does. # #---------------------------------------------------------------------- proc ::math::calculus::u_expLower { f u } { set cmd $f lappend cmd [expr { log($u) }] set y [eval $cmd] return [expr { $y / $u }] } #---------------------------------------------------------------------- # # romberg_expLower -- # # Integrate a function that grows exponentially over a # half-infinite interval. # # Parameters: # Same as romberg. The lower limit of integration, 'a', # is expected to be very large and negative. # # Results: # Same as romberg. # # The romberg_expUpper function operates by making the change of # variable, u = exp(x). # #---------------------------------------------------------------------- proc ::math::calculus::romberg_expLower { f a b args } { if { ![string is double -strict $a] } { return -code error [expectDouble $a] } if { ![string is double -strict $b] } { return -code error [expectDouble $b] } if { $a >= $b } { return -code error "limits of integration out of order" } set f [lreplace $f 0 0 [uplevel 1 [list namespace which [lindex $f 0]]]] set f [list u_expLower $f] return [eval [linsert $args 0 \ romberg $f [expr {exp($a)}] [expr {exp($b)}]]] } # regula_falsi -- # Compute the zero of a function via regula falsi # Arguments: # f Name of the procedure/command that evaluates the function # xb Start of the interval that brackets the zero # xe End of the interval that brackets the zero # eps Relative error that is allowed (default: 1.0e-4) # Result: # Estimate of the zero, such that the estimated (!) # error < eps * abs(xe-xb) # Note: # f(xb)*f(xe) must be negative and eps must be positive # proc ::math::calculus::regula_falsi { f xb xe {eps 1.0e-4} } { if { $eps <= 0.0 } { return -code error "Relative error must be positive" } set fb [$f $xb] set fe [$f $xe] if { $fb * $fe > 0.0 } { return -code error "Interval must be chosen such that the \ function has a different sign at the beginning than at the end" } set max_error [expr {$eps * abs($xe-$xb)}] set interval [expr {abs($xe-$xb)}] while { $interval > $max_error } { set coeff [expr {($fe-$fb)/($xe-$xb)}] set xi [expr {$xb-$fb/$coeff}] set fi [$f $xi] if { $fi == 0.0 } { break } set diff1 [expr {abs($xe-$xi)}] set diff2 [expr {abs($xb-$xi)}] if { $diff1 > $diff2 } { set interval $diff2 } else { set interval $diff1 } if { $fb*$fi < 0.0 } { set xe $xi set fe $fi } else { set xb $xi set fb $fi } } return $xi } tcllib-1.15/modules/math/special.man0000755000175000017500000003147612077663116016774 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin math::special n 0.2] [copyright {2004 Arjen Markus }] [moddesc {Tcl Math Library}] [titledesc {Special mathematical functions}] [category Mathematics] [require Tcl [opt 8.3]] [require math::special [opt 0.2]] [description] [para] This package implements several so-called special functions, like the Gamma function, the Bessel functions and such. [para] Each function is implemented by a procedure that bears its name (well, in close approximation): [list_begin itemized] [item] J0 for the zeroth-order Bessel function of the first kind [item] J1 for the first-order Bessel function of the first kind [item] Jn for the nth-order Bessel function of the first kind [item] J1/2 for the half-order Bessel function of the first kind [item] J-1/2 for the minus-half-order Bessel function of the first kind [item] I_n for the modified Bessel function of the first kind of order n [item] Gamma for the Gamma function, erf and erfc for the error function and the complementary error function [item] fresnel_C and fresnel_S for the Fresnel integrals [item] elliptic_K and elliptic_E (complete elliptic integrals) [item] exponent_Ei and other functions related to the so-called exponential integrals [item] legendre, hermite: some of the classical orthogonal polynomials. [list_end] [section OVERVIEW] In the following table several characteristics of the functions in this package are summarized: the domain for the argument, the values for the parameters and error bounds. [example { Family | Function | Domain x | Parameter | Error bound -------------+-------------+-------------+-------------+-------------- Bessel | J0, J1, | all of R | n = integer | < 1.0e-8 | Jn | | | (|x|<20, n<20) Bessel | J1/2, J-1/2,| x > 0 | n = integer | exact Bessel | I_n | all of R | n = integer | < 1.0e-6 | | | | Elliptic | cn | 0 <= x <= 1 | -- | < 1.0e-10 functions | dn | 0 <= x <= 1 | -- | < 1.0e-10 | sn | 0 <= x <= 1 | -- | < 1.0e-10 Elliptic | K | 0 <= x < 1 | -- | < 1.0e-6 integrals | E | 0 <= x < 1 | -- | < 1.0e-6 | | | | Error | erf | | -- | functions | erfc | | | | ierfc_n | | | | | | | Exponential | Ei | x != 0 | -- | < 1.0e-10 (relative) integrals | En | x > 0 | -- | as Ei | li | x > 0 | -- | as Ei | Chi | x > 0 | -- | < 1.0e-8 | Shi | x > 0 | -- | < 1.0e-8 | Ci | x > 0 | -- | < 2.0e-4 | Si | x > 0 | -- | < 2.0e-4 | | | | Fresnel | C | all of R | -- | < 2.0e-3 integrals | S | all of R | -- | < 2.0e-3 | | | | general | Beta | (see Gamma) | -- | < 1.0e-9 | Gamma | x != 0,-1, | -- | < 1.0e-9 | | -2, ... | | | sinc | all of R | -- | exact | | | | orthogonal | Legendre | all of R | n = 0,1,... | exact polynomials | Chebyshev | all of R | n = 0,1,... | exact | Laguerre | all of R | n = 0,1,... | exact | | | alpha el. R | | Hermite | all of R | n = 0,1,... | exact }] [emph Note:] Some of the error bounds are estimated, as no "formal" bounds were available with the implemented approximation method, others hold for the auxiliary functions used for estimating the primary functions. [para] The following well-known functions are currently missing from the package: [list_begin itemized] [item] Bessel functions of the second kind (Y_n, K_n) [item] Bessel functions of arbitrary order (and hence the Airy functions) [item] Chebyshev polynomials of the second kind (U_n) [item] The digamma function (psi) [item] The incomplete gamma and beta functions [list_end] [section "PROCEDURES"] The package defines the following public procedures: [list_begin definitions] [call [cmd ::math::special::Beta] [arg x] [arg y]] Compute the Beta function for arguments "x" and "y" [list_begin arguments] [arg_def float x] First argument for the Beta function [arg_def float y] Second argument for the Beta function [list_end] [para] [call [cmd ::math::special::Gamma] [arg x] [arg y]] Compute the Gamma function for argument "x" [list_begin arguments] [arg_def float x] Argument for the Gamma function [list_end] [para] [call [cmd ::math::special::erf] [arg x]] Compute the error function for argument "x" [list_begin arguments] [arg_def float x] Argument for the error function [list_end] [para] [call [cmd ::math::special::erfc] [arg x]] Compute the complementary error function for argument "x" [list_begin arguments] [arg_def float x] Argument for the complementary error function [list_end] [para] [call [cmd ::math::special::J0] [arg x]] Compute the zeroth-order Bessel function of the first kind for the argument "x" [list_begin arguments] [arg_def float x] Argument for the Bessel function [list_end] [call [cmd ::math::special::J1] [arg x]] Compute the first-order Bessel function of the first kind for the argument "x" [list_begin arguments] [arg_def float x] Argument for the Bessel function [list_end] [call [cmd ::math::special::Jn] [arg n] [arg x]] Compute the nth-order Bessel function of the first kind for the argument "x" [list_begin arguments] [arg_def integer n] Order of the Bessel function [arg_def float x] Argument for the Bessel function [list_end] [call [cmd ::math::special::J1/2] [arg x]] Compute the half-order Bessel function of the first kind for the argument "x" [list_begin arguments] [arg_def float x] Argument for the Bessel function [list_end] [call [cmd ::math::special::J-1/2] [arg x]] Compute the minus-half-order Bessel function of the first kind for the argument "x" [list_begin arguments] [arg_def float x] Argument for the Bessel function [list_end] [call [cmd ::math::special::I_n] [arg x]] Compute the modified Bessel function of the first kind of order n for the argument "x" [list_begin arguments] [arg_def int x] Positive integer order of the function [arg_def float x] Argument for the function [list_end] [call [cmd ::math::special::cn] [arg u] [arg k]] Compute the elliptic function [emph cn] for the argument "u" and parameter "k". [list_begin arguments] [arg_def float u] Argument for the function [arg_def float k] Parameter [list_end] [call [cmd ::math::special::dn] [arg u] [arg k]] Compute the elliptic function [emph dn] for the argument "u" and parameter "k". [list_begin arguments] [arg_def float u] Argument for the function [arg_def float k] Parameter [list_end] [call [cmd ::math::special::sn] [arg u] [arg k]] Compute the elliptic function [emph sn] for the argument "u" and parameter "k". [list_begin arguments] [arg_def float u] Argument for the function [arg_def float k] Parameter [list_end] [call [cmd ::math::special::elliptic_K] [arg k]] Compute the complete elliptic integral of the first kind for the argument "k" [list_begin arguments] [arg_def float k] Argument for the function [list_end] [call [cmd ::math::special::elliptic_E] [arg k]] Compute the complete elliptic integral of the second kind for the argument "k" [list_begin arguments] [arg_def float k] Argument for the function [list_end] [call [cmd ::math::special::exponential_Ei] [arg x]] Compute the exponential integral of the second kind for the argument "x" [list_begin arguments] [arg_def float x] Argument for the function (x != 0) [list_end] [call [cmd ::math::special::exponential_En] [arg n] [arg x]] Compute the exponential integral of the first kind for the argument "x" and order n [list_begin arguments] [arg_def int n] Order of the integral (n >= 0) [arg_def float x] Argument for the function (x >= 0) [list_end] [call [cmd ::math::special::exponential_li] [arg x]] Compute the logarithmic integral for the argument "x" [list_begin arguments] [arg_def float x] Argument for the function (x > 0) [list_end] [call [cmd ::math::special::exponential_Ci] [arg x]] Compute the cosine integral for the argument "x" [list_begin arguments] [arg_def float x] Argument for the function (x > 0) [list_end] [call [cmd ::math::special::exponential_Si] [arg x]] Compute the sine integral for the argument "x" [list_begin arguments] [arg_def float x] Argument for the function (x > 0) [list_end] [call [cmd ::math::special::exponential_Chi] [arg x]] Compute the hyperbolic cosine integral for the argument "x" [list_begin arguments] [arg_def float x] Argument for the function (x > 0) [list_end] [call [cmd ::math::special::exponential_Shi] [arg x]] Compute the hyperbolic sine integral for the argument "x" [list_begin arguments] [arg_def float x] Argument for the function (x > 0) [list_end] [call [cmd ::math::special::fresnel_C] [arg x]] Compute the Fresnel cosine integral for real argument x [list_begin arguments] [arg_def float x] Argument for the function [list_end] [call [cmd ::math::special::fresnel_S] [arg x]] Compute the Fresnel sine integral for real argument x [list_begin arguments] [arg_def float x] Argument for the function [list_end] [call [cmd ::math::special::sinc] [arg x]] Compute the sinc function for real argument x [list_begin arguments] [arg_def float x] Argument for the function [list_end] [call [cmd ::math::special::legendre] [arg n]] Return the Legendre polynomial of degree n (see [sectref "THE ORTHOGONAL POLYNOMIALS"]) [list_begin arguments] [arg_def int n] Degree of the polynomial [list_end] [para] [call [cmd ::math::special::chebyshev] [arg n]] Return the Chebyshev polynomial of degree n (of the first kind) [list_begin arguments] [arg_def int n] Degree of the polynomial [list_end] [para] [call [cmd ::math::special::laguerre] [arg alpha] [arg n]] Return the Laguerre polynomial of degree n with parameter alpha [list_begin arguments] [arg_def float alpha] Parameter of the Laguerre polynomial [arg_def int n] Degree of the polynomial [list_end] [para] [call [cmd ::math::special::hermite] [arg n]] Return the Hermite polynomial of degree n [list_begin arguments] [arg_def int n] Degree of the polynomial [list_end] [para] [list_end] [section "THE ORTHOGONAL POLYNOMIALS"] For dealing with the classical families of orthogonal polynomials, the package relies on the [emph math::polynomials] package. To evaluate the polynomial at some coordinate, use the [emph evalPolyn] command: [example { set leg2 [::math::special::legendre 2] puts "Value at x=$x: [::math::polynomials::evalPolyn $leg2 $x]" }] [para] The return value from the [emph legendre] and other commands is actually the definition of the corresponding polynomial as used in that package. [section "REMARKS ON THE IMPLEMENTATION"] It should be noted, that the actual implementation of J0 and J1 depends on straightforward Gaussian quadrature formulas. The (absolute) accuracy of the results is of the order 1.0e-4 or better. The main reason to implement them like that was that it was fast to do (the formulas are simple) and the computations are fast too. [para] The implementation of J1/2 does not suffer from this: this function can be expressed exactly in terms of elementary functions. [para] The functions J0 and J1 are the ones you will encounter most frequently in practice. [para] The computation of I_n is based on Miller's algorithm for computing the minimal function from recurrence relations. [para] The computation of the Gamma and Beta functions relies on the combinatorics package, whereas that of the error functions relies on the statistics package. [para] The computation of the complete elliptic integrals uses the AGM algorithm. [para] Much information about these functions can be found in: [para] Abramowitz and Stegun: [emph "Handbook of Mathematical Functions"] (Dover, ISBN 486-61272-4) [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph {math :: special}] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords math "special functions" "Bessel functions" "error function"] [manpage_end] tcllib-1.15/modules/math/optimize.tcl0000755000175000017500000010754312077663116017222 0ustar sergeisergei#---------------------------------------------------------------------- # # math/optimize.tcl -- # # This file contains functions for optimization of a function # or expression. # # Copyright (c) 2004, by Arjen Markus. # Copyright (c) 2004, 2005 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: optimize.tcl,v 1.12 2011/01/18 07:49:53 arjenmarkus Exp $ # #---------------------------------------------------------------------- package require Tcl 8.4 # math::optimize -- # Namespace for the commands # namespace eval ::math::optimize { namespace export minimum maximum solveLinearProgram linearProgramMaximum namespace export min_bound_1d min_unbound_1d # Possible extension: minimumExpr, maximumExpr } # minimum -- # Minimize a given function over a given interval # # Arguments: # begin Start of the interval # end End of the interval # func Name of the function to be minimized (takes one # argument) # maxerr Maximum relative error (defaults to 1.0e-4) # Return value: # Computed value for which the function is minimal # Notes: # The function needs not to be differentiable, but it is supposed # to be continuous. There is no provision for sub-intervals where # the function is constant (this might happen when the maximum # error is very small, < 1.0e-15) # # Warning: # This procedure is deprecated - use min_bound_1d instead # proc ::math::optimize::minimum { begin end func {maxerr 1.0e-4} } { set nosteps [expr {3+int(-log($maxerr)/log(2.0))}] set delta [expr {0.5*($end-$begin)*$maxerr}] for { set step 0 } { $step < $nosteps } { incr step } { set x1 [expr {($end+$begin)/2.0}] set x2 [expr {$x1+$delta}] set fx1 [uplevel 1 $func $x1] set fx2 [uplevel 1 $func $x2] if {$fx1 < $fx2} { set end $x1 } else { set begin $x1 } } return $x1 } # maximum -- # Maximize a given function over a given interval # # Arguments: # begin Start of the interval # end End of the interval # func Name of the function to be maximized (takes one # argument) # maxerr Maximum relative error (defaults to 1.0e-4) # Return value: # Computed value for which the function is maximal # Notes: # The function needs not to be differentiable, but it is supposed # to be continuous. There is no provision for sub-intervals where # the function is constant (this might happen when the maximum # error is very small, < 1.0e-15) # # Warning: # This procedure is deprecated - use max_bound_1d instead # proc ::math::optimize::maximum { begin end func {maxerr 1.0e-4} } { set nosteps [expr {3+int(-log($maxerr)/log(2.0))}] set delta [expr {0.5*($end-$begin)*$maxerr}] for { set step 0 } { $step < $nosteps } { incr step } { set x1 [expr {($end+$begin)/2.0}] set x2 [expr {$x1+$delta}] set fx1 [uplevel 1 $func $x1] set fx2 [uplevel 1 $func $x2] if {$fx1 > $fx2} { set end $x1 } else { set begin $x1 } } return $x1 } #---------------------------------------------------------------------- # # min_bound_1d -- # # Find a local minimum of a function between two given # abscissae. Derivative of f is not required. # # Usage: # min_bound_1d f x1 x2 ?-option value?,,, # # Parameters: # f - Function to minimize. Must be expressed as a Tcl # command, to which will be appended the value at which # to evaluate the function. # x1 - Lower bound of the interval in which to search for a # minimum # x2 - Upper bound of the interval in which to search for a minimum # # Options: # -relerror value # Gives the tolerance desired for the returned # abscissa. Default is 1.0e-7. Should never be less # than the square root of the machine precision. # -maxiter n # Constrains minimize_bound_1d to evaluate the function # no more than n times. Default is 100. If convergence # is not achieved after the specified number of iterations, # an error is thrown. # -guess value # Gives a point between x1 and x2 that is an initial guess # for the minimum. f(guess) must be at most f(x1) or # f(x2). # -fguess value # Gives the value of the ordinate at the value of '-guess' # if known. Default is to evaluate the function # -abserror value # Gives the desired absolute error for the returned # abscissa. Default is 1.0e-10. # -trace boolean # A true value causes a trace to the standard output # of the function evaluations. Default is 0. # # Results: # Returns a two-element list comprising the abscissa at which # the function reaches a local minimum within the interval, # and the value of the function at that point. # # Side effects: # Whatever side effects arise from evaluating the given function. # #---------------------------------------------------------------------- proc ::math::optimize::min_bound_1d { f x1 x2 args } { set f [lreplace $f 0 0 [uplevel 1 [list namespace which [lindex $f 0]]]] set phim1 0.6180339887498949 set twomphi 0.3819660112501051 array set params { -relerror 1.0e-7 -abserror 1.0e-10 -maxiter 100 -trace 0 -fguess {} } set params(-guess) [expr { $phim1 * $x1 + $twomphi * $x2 }] if { ( [llength $args] % 2 ) != 0 } { return -code error -errorcode [list min_bound_1d wrongNumArgs] \ "wrong \# args, should be\ \"[lreplace [info level 0] 1 end f x1 x2 ?-option value?...]\"" } foreach { key value } $args { if { ![info exists params($key)] } { return -code error -errorcode [list min_bound_1d badoption $key] \ "unknown option \"$key\",\ should be -abserror,\ -fguess, -guess, -initial, -maxiter, -relerror,\ or -trace" } set params($key) $value } # a and b presumably bracket the minimum of the function. Make sure # they're in ascending order. if { $x1 < $x2 } { set a $x1; set b $x2 } else { set b $x1; set a $x2 } set x $params(-guess); # Best abscissa found so far set w $x; # Second best abscissa found so far set v $x; # Most recent earlier value of w set e 0.0; # Distance moved on the step before # last. # Evaluate the function at the initial guess if { $params(-fguess) ne {} } { set fx $params(-fguess) } else { set s $f; lappend s $x; set fx [eval $s] if { $params(-trace) } { puts stdout "f($x) = $fx (initialisation)" } } set fw $fx set fv $fx for { set iter 0 } { $iter < $params(-maxiter) } { incr iter } { # Find the midpoint of the current interval set xm [expr { 0.5 * ( $a + $b ) }] # Compute the current tolerance for x, and twice its value set tol [expr { $params(-relerror) * abs($x) + $params(-abserror) }] set tol2 [expr { $tol + $tol }] if { abs( $x - $xm ) <= $tol2 - 0.5 * ($b - $a) } { return [list $x $fx] } set golden 1 if { abs($e) > $tol } { # Use parabolic interpolation to find a minimum determined # by the evaluations at x, v, and w. The size of the step # to take will be $p/$q. set r [expr { ( $x - $w ) * ( $fx - $fv ) }] set q [expr { ( $x - $v ) * ( $fx - $fw ) }] set p [expr { ( $x - $v ) * $q - ( $x - $w ) * $r }] set q [expr { 2. * ( $q - $r ) }] if { $q > 0 } { set p [expr { - $p }] } else { set q [expr { - $q }] } set olde $e set e $d # Test if parabolic interpolation results in less than half # the movement of the step two steps ago. if { abs($p) < abs( .5 * $q * $olde ) && $p > $q * ( $a - $x ) && $p < $q * ( $b - $x ) } { set d [expr { $p / $q }] set u [expr { $x + $d }] if { ( $u - $a ) < $tol2 || ( $b - $u ) < $tol2 } { if { $xm-$x < 0 } { set d [expr { - $tol }] } else { set d $tol } } set golden 0 } } # If parabolic interpolation didn't come up with an acceptable # result, use Golden Section instead. if { $golden } { if { $x >= $xm } { set e [expr { $a - $x }] } else { set e [expr { $b - $x }] } set d [expr { $twomphi * $e }] } # At this point, d is the size of the step to take. Make sure # that it's at least $tol. if { abs($d) >= $tol } { set u [expr { $x + $d }] } elseif { $d < 0 } { set u [expr { $x - $tol }] } else { set u [expr { $x + $tol }] } # Evaluate the function set s $f; lappend s $u; set fu [eval $s] if { $params(-trace) } { if { $golden } { puts stdout "f($u)=$fu (golden section)" } else { puts stdout "f($u)=$fu (parabolic interpolation)" } } if { $fu <= $fx } { # We've the best abscissa so far. if { $u >= $x } { set a $x } else { set b $x } set v $w set fv $fw set w $x set fw $fx set x $u set fx $fu } else { if { $u < $x } { set a $u } else { set b $u } if { $fu <= $fw || $w == $x } { # We've the second-best abscissa so far set v $w set fv $fw set w $u set fw $fu } elseif { $fu <= $fv || $v == $x || $v == $w } { # We've the third-best so far set v $u set fv $fu } } } return -code error -errorcode [list min_bound_1d noconverge $iter] \ "[lindex [info level 0] 0] failed to converge after $iter steps." } #---------------------------------------------------------------------- # # brackmin -- # # Find a place along the number line where a given function has # a local minimum. # # Usage: # brackmin f x1 x2 ?trace? # # Parameters: # f - Function to minimize # x1 - Abscissa thought to be near the minimum # x2 - Additional abscissa thought to be near the minimum # trace - Boolean variable that, if true, # causes 'brackmin' to print a trace of its function # evaluations to the standard output. Default is 0. # # Results: # Returns a three element list {x1 y1 x2 y2 x3 y3} where # y1=f(x1), y2=f(x2), y3=f(x3). x2 lies between x1 and x3, and # y1>y2, y3>y2, proving that there is a local minimum somewhere # in the interval (x1,x3). # # Side effects: # Whatever effects the evaluation of f has. # #---------------------------------------------------------------------- proc ::math::optimize::brackmin { f x1 x2 {trace 0} } { set f [lreplace $f 0 0 [uplevel 1 [list namespace which [lindex $f 0]]]] set phi 1.6180339887498949 set epsilon 1.0e-20 set limit 50. # Choose a and b so that f(a) < f(b) set cmd $f; lappend cmd $x1; set fx1 [eval $cmd] if { $trace } { puts "f($x1) = $fx1 (initialisation)" } set cmd $f; lappend cmd $x2; set fx2 [eval $cmd] if { $trace } { puts "f($x2) = $fx2 (initialisation)" } if { $fx1 > $fx2 } { set a $x1; set fa $fx1 set b $x2; set fb $fx2 } else { set a $x2; set fa $fx2 set b $x1; set fb $fx1 } # Choose a c in the downhill direction set c [expr { $b + $phi * ($b - $a) }] set cmd $f; lappend cmd $c; set fc [eval $cmd] if { $trace } { puts "f($c) = $fc (initial dilatation by phi)" } while { $fb >= $fc } { # Try to do parabolic extrapolation to the minimum set r [expr { ($b - $a) * ($fb - $fc) }] set q [expr { ($b - $c) * ($fb - $fa) }] if { abs( $q - $r ) > $epsilon } { set denom [expr { $q - $r }] } elseif { $q > $r } { set denom $epsilon } else { set denom -$epsilon } set u [expr { $b - ( (($b - $c) * $q - ($b - $a) * $r) / (2. * $denom) ) }] set ulimit [expr { $b + $limit * ( $c - $b ) }] # Test the extrapolated abscissa if { ($b - $u) * ($u - $c) > 0 } { # u lies between b and c. Try to interpolate set cmd $f; lappend cmd $u; set fu [eval $cmd] if { $trace } { puts "f($u) = $fu (parabolic interpolation)" } if { $fu < $fc } { # fb > fu and fc > fu, so there is a minimum between b and c # with u as a starting guess. return [list $b $fb $u $fu $c $fc] } if { $fu > $fb } { # fb < fu, fb < fa, and u cannot lie between a and b # (because it lies between a and c). There is a minimum # somewhere between a and u, with b a starting guess. return [list $a $fa $b $fb $u $fu] } # Parabolic interpolation was useless. Expand the # distance by a factor of phi and try again. set u [expr { $c + $phi * ($c - $b) }] set cmd $f; lappend cmd $u; set fu [eval $cmd] if { $trace } { puts "f($u) = $fu (parabolic interpolation failed)" } } elseif { ( $c - $u ) * ( $u - $ulimit ) > 0 } { # u lies between $c and $ulimit. set cmd $f; lappend cmd $u; set fu [eval $cmd] if { $trace } { puts "f($u) = $fu (parabolic extrapolation)" } if { $fu > $fc } { # minimum lies between b and u, with c an initial guess. return [list $b $fb $c $fc $u $fu] } # function is still decreasing fa > fb > fc > fu. Take # another factor-of-phi step. set b $c; set fb $fc set c $u; set fc $fu set u [expr { $c + $phi * ( $c - $b ) }] set cmd $f; lappend cmd $u; set fu [eval $cmd] if { $trace } { puts "f($u) = $fu (parabolic extrapolation ok)" } } elseif { ($u - $ulimit) * ( $ulimit - $c ) >= 0 } { # u went past ulimit. Pull in to ulimit and evaluate there. set u $ulimit set cmd $f; lappend cmd $u; set fu [eval $cmd] if { $trace } { puts "f($u) = $fu (limited step)" } } else { # parabolic extrapolation gave a useless value. set u [expr { $c + $phi * ( $c - $b ) }] set cmd $f; lappend cmd $u; set fu [eval $cmd] if { $trace } { puts "f($u) = $fu (parabolic extrapolation failed)" } } set a $b; set fa $fb set b $c; set fb $fc set c $u; set fc $fu } return [list $a $fa $b $fb $c $fc] } #---------------------------------------------------------------------- # # min_unbound_1d -- # # Minimize a function of one variable, unconstrained, derivatives # not required. # # Usage: # min_bound_1d f x1 x2 ?-option value?,,, # # Parameters: # f - Function to minimize. Must be expressed as a Tcl # command, to which will be appended the value at which # to evaluate the function. # x1 - Initial guess at the minimum # x2 - Second initial guess at the minimum, used to set the # initial length scale for the search. # # Options: # -relerror value # Gives the tolerance desired for the returned # abscissa. Default is 1.0e-7. Should never be less # than the square root of the machine precision. # -maxiter n # Constrains min_bound_1d to evaluate the function # no more than n times. Default is 100. If convergence # is not achieved after the specified number of iterations, # an error is thrown. # -abserror value # Gives the desired absolute error for the returned # abscissa. Default is 1.0e-10. # -trace boolean # A true value causes a trace to the standard output # of the function evaluations. Default is 0. # #---------------------------------------------------------------------- proc ::math::optimize::min_unbound_1d { f x1 x2 args } { set f [lreplace $f 0 0 [uplevel 1 [list namespace which [lindex $f 0]]]] array set params { -relerror 1.0e-7 -abserror 1.0e-10 -maxiter 100 -trace 0 } if { ( [llength $args] % 2 ) != 0 } { return -code error -errorcode [list min_unbound_1d wrongNumArgs] \ "wrong \# args, should be\ \"[lreplace [info level 0] 1 end \ f x1 x2 ?-option value?...]\"" } foreach { key value } $args { if { ![info exists params($key)] } { return -code error -errorcode [list min_unbound_1d badoption $key] \ "unknown option \"$key\",\ should be -trace" } set params($key) $value } foreach { a fa b fb c fc } [brackmin $f $x1 $x2 $params(-trace)] { break } return [eval [linsert [array get params] 0 \ min_bound_1d $f $a $c -guess $b -fguess $fb]] } #---------------------------------------------------------------------- # # nelderMead -- # # Attempt to minimize/maximize a function using the downhill # simplex method of Nelder and Mead. # # Usage: # nelderMead f x ?-keyword value? # # Parameters: # f - The function to minimize. The function must be an incomplete # Tcl command, to which will be appended N parameters. # x - The starting guess for the minimum; a vector of N parameters # to be passed to the function f. # # Options: # -scale xscale # Initial guess as to the problem scale. If '-scale' is # supplied, then the parameters will be varied by the # specified amounts. The '-scale' parameter must of the # same dimension as the 'x' vector, and all elements must # be nonzero. Default is 0.0001 times the 'x' vector, # or 0.0001 for zero elements in the 'x' vector. # # -ftol epsilon # Requested tolerance in the function value; nelderMead # returns if N+1 consecutive iterates all differ by less # than the -ftol value. Default is 1.0e-7 # # -maxiter N # Maximum number of iterations to attempt. Default is # 500. # # -trace flag # If '-trace 1' is supplied, nelderMead writes a record # of function evaluations to the standard output as it # goes. Default is 0. # #---------------------------------------------------------------------- proc ::math::optimize::nelderMead { f startx args } { array set params { -ftol 1.e-7 -maxiter 500 -scale {} -trace 0 } # Check arguments if { ( [llength $args] % 2 ) != 0 } { return -code error -errorcode [list nelderMead wrongNumArgs] \ "wrong \# args, should be\ \"[lreplace [info level 0] 1 end \ f x1 x2 ?-option value?...]\"" } foreach { key value } $args { if { ![info exists params($key)] } { return -code error -errorcode [list nelderMead badoption $key] \ "unknown option \"$key\",\ should be -ftol, -maxiter, -scale or -trace" } set params($key) $value } # Construct the initial simplex set vertices [list $startx] if { [llength $params(-scale)] == 0 } { set i 0 foreach x0 $startx { if { $x0 == 0 } { set x1 0.0001 } else { set x1 [expr {1.0001 * $x0}] } lappend vertices [lreplace $startx $i $i $x1] incr i } } elseif { [llength $params(-scale)] != [llength $startx] } { return -code error -errorcode [list nelderMead badOption -scale] \ "-scale vector must be of same size as starting x vector" } else { set i 0 foreach x0 $startx s $params(-scale) { lappend vertices [lreplace $startx $i $i [expr { $x0 + $s }]] incr i } } # Evaluate at the initial points set n [llength $startx] foreach x $vertices { set cmd $f foreach xx $x { lappend cmd $xx } set y [uplevel 1 $cmd] if {$params(-trace)} { puts "nelderMead: evaluating initial point: x=[list $x] y=$y" } lappend yvec $y } # Loop adjusting the simplex in the 'vertices' array. set nIter 0 while { 1 } { # Find the highest, next highest, and lowest value in y, # and save the indices. set iBot 0 set yBot [lindex $yvec 0] set iTop -1 set yTop [lindex $yvec 0] set iNext -1 set i 0 foreach y $yvec { if { $y <= $yBot } { set yBot $y set iBot $i } if { $iTop < 0 || $y >= $yTop } { set iNext $iTop set yNext $yTop set iTop $i set yTop $y } elseif { $iNext < 0 || $y >= $yNext } { set iNext $i set yNext $y } incr i } # Return if the relative error is within an acceptable range set rerror [expr { 2. * abs( $yTop - $yBot ) / ( abs( $yTop ) + abs( $yBot ) ) }] if { $rerror < $params(-ftol) } { set status ok break } # Count iterations if { [incr nIter] > $params(-maxiter) } { set status too-many-iterations break } incr nIter # Find the centroid of the face opposite the vertex that # maximizes the function value. set centroid {} for { set i 0 } { $i < $n } { incr i } { lappend centroid 0.0 } set i 0 foreach v $vertices { if { $i != $iTop } { set newCentroid {} foreach x0 $centroid x1 $v { lappend newCentroid [expr { $x0 + $x1 }] } set centroid $newCentroid } incr i } set newCentroid {} foreach x $centroid { lappend newCentroid [expr { $x / $n }] } set centroid $newCentroid # The first trial point is a reflection of the high point # around the centroid set trial {} foreach x0 [lindex $vertices $iTop] x1 $centroid { lappend trial [expr {$x1 + ($x1 - $x0)}] } set cmd $f foreach xx $trial { lappend cmd $xx } set yTrial [uplevel 1 $cmd] if { $params(-trace) } { puts "nelderMead: trying reflection: x=[list $trial] y=$yTrial" } # If that reflection yields a new minimum, replace the high point, # and additionally try dilating in the same direction. if { $yTrial < $yBot } { set trial2 {} foreach x0 $centroid x1 $trial { lappend trial2 [expr { $x1 + ($x1 - $x0) }] } set cmd $f foreach xx $trial2 { lappend cmd $xx } set yTrial2 [uplevel 1 $cmd] if { $params(-trace) } { puts "nelderMead: trying dilated reflection:\ x=[list $trial2] y=$y" } if { $yTrial2 < $yBot } { # Additional dilation yields a new minimum lset vertices $iTop $trial2 lset yvec $iTop $yTrial2 } else { # Additional dilation failed, but we can still use # the first trial point. lset vertices $iTop $trial lset yvec $iTop $yTrial } } elseif { $yTrial < $yNext } { # The reflected point isn't a new minimum, but it's # better than the second-highest. Replace the old high # point and try again. lset vertices $iTop $trial lset yvec $iTop $yTrial } else { # The reflected point is worse than the second-highest point. # If it's better than the highest, keep it... but in any case, # we want to try contracting the simplex, because a further # reflection will simply bring us back to the starting point. if { $yTrial < $yTop } { lset vertices $iTop $trial lset yvec $iTop $yTrial set yTop $yTrial } set trial {} foreach x0 [lindex $vertices $iTop] x1 $centroid { lappend trial [expr { ( $x0 + $x1 ) / 2. }] } set cmd $f foreach xx $trial { lappend cmd $xx } set yTrial [uplevel 1 $cmd] if { $params(-trace) } { puts "nelderMead: contracting from high point:\ x=[list $trial] y=$y" } if { $yTrial < $yTop } { # Contraction gave an improvement, so continue with # the smaller simplex lset vertices $iTop $trial lset yvec $iTop $yTrial } else { # Contraction gave no improvement either; we seem to # be in a valley of peculiar topology. Contract the # simplex about the low point and try again. set newVertices {} set newYvec {} set i 0 foreach v $vertices y $yvec { if { $i == $iBot } { lappend newVertices $v lappend newYvec $y } else { set newv {} foreach x0 $v x1 [lindex $vertices $iBot] { lappend newv [expr { ($x0 + $x1) / 2. }] } lappend newVertices $newv set cmd $f foreach xx $newv { lappend cmd $xx } lappend newYvec [uplevel 1 $cmd] if { $params(-trace) } { puts "nelderMead: contracting about low point:\ x=[list $newv] y=$y" } } incr i } set vertices $newVertices set yvec $newYvec } } } return [list y $yBot x [lindex $vertices $iBot] vertices $vertices yvec $yvec nIter $nIter status $status] } # solveLinearProgram # Solve a linear program in standard form # # Arguments: # objective Vector defining the objective function # constraints Matrix of constraints (as a list of lists) # # Return value: # Computed values for the coordinates or "unbounded" or "infeasible" # proc ::math::optimize::solveLinearProgram { objective constraints } { # # Check the arguments first and then put them in a more convenient # form # foreach {nconst nvars matrix} \ [SimplexPrepareMatrix $objective $constraints] {break} set solution [SimplexSolve $nconst nvars $matrix] if { [llength $solution] > 1 } { return [lrange $solution 0 [expr {$nvars-1}]] } else { return $solution } } # linearProgramMaximum -- # Compute the value attained at the optimum # # Arguments: # objective The coefficients of the objective function # result The coordinate values as obtained by solving the program # # Return value: # Value at the maximum point # proc ::math::optimize::linearProgramMaximum {objective result} { set value 0.0 foreach coeff $objective coord $result { set value [expr {$value+$coeff*$coord}] } return $value } # SimplexPrintMatrix # Debugging routine: print the matrix in easy to read form # # Arguments: # matrix Matrix to be printed # # Return value: # None # # Note: # The tableau should be transposed ... # proc ::math::optimize::SimplexPrintMatrix {matrix} { puts "\nBasis:\t[join [lindex $matrix 0] \t]" foreach col [lrange $matrix 1 end] { puts " \t[join $col \t]" } } # SimplexPrepareMatrix # Prepare the standard tableau from all program data # # Arguments: # objective Vector defining the objective function # constraints Matrix of constraints (as a list of lists) # # Return value: # List of values as a standard tableau and two values # for the sizes # proc ::math::optimize::SimplexPrepareMatrix {objective constraints} { # # Check the arguments first # set nconst [llength $constraints] set ncols {} foreach row $constraints { if { $ncols == {} } { set ncols [llength $row] } else { if { $ncols != [llength $row] } { return -code error -errorcode ARGS "Incorrectly formed constraints matrix" } } } set nvars [expr {$ncols-1}] if { [llength $objective] != $nvars } { return -code error -errorcode ARGS "Incorrect length for objective vector" } # # Set up the tableau: # Easiest manipulations if we store the columns first # So: # - First column is the list of variable indices in the basis # - Second column is the list of maximum values # - "nvars" columns that follow: the coefficients for the actual # variables # - last "nconst" columns: the slack variables # set matrix [list] set lastrow [concat $objective [list 0.0]] set newcol [list] for {set idx 0} {$idx < $nconst} {incr idx} { lappend newcol [expr {$nvars+$idx}] } lappend newcol "?" lappend matrix $newcol set zvector [list] foreach row $constraints { lappend zvector [lindex $row end] } lappend zvector 0.0 lappend matrix $zvector for {set idx 0} {$idx < $nvars} {incr idx} { set newcol [list] foreach row $constraints { lappend newcol [expr {double([lindex $row $idx])}] } lappend newcol [expr {-double([lindex $lastrow $idx])}] lappend matrix $newcol } # # Add the columns for the slack variables # set zeros {} for {set idx 0} {$idx <= $nconst} {incr idx} { lappend zeros 0.0 } for {set idx 0} {$idx < $nconst} {incr idx} { lappend matrix [lreplace $zeros $idx $idx 1.0] } return [list $nconst $nvars $matrix] } # SimplexSolve -- # Solve the given linear program using the simplex method # # Arguments: # nconst Number of constraints # nvars Number of actual variables # tableau Standard tableau (as a list of columns) # # Return value: # List of values for the actual variables # proc ::math::optimize::SimplexSolve {nconst nvars tableau} { set end 0 while { !$end } { # # Find the new variable to put in the basis # set nextcol [SimplexFindNextColumn $tableau] if { $nextcol == -1 } { set end 1 continue } # # Now determine which one should leave # TODO: is a lack of a proper row indeed an # indication of the infeasibility? # set nextrow [SimplexFindNextRow $tableau $nextcol] if { $nextrow == -1 } { return "infeasible" } # # Make the vector for sweeping through the tableau # set vector [SimplexMakeVector $tableau $nextcol $nextrow] # # Sweep through the tableau # set tableau [SimplexNewTableau $tableau $nextcol $nextrow $vector] } # # Now we can return the result # SimplexResult $tableau } # SimplexResult -- # Reconstruct the result vector # # Arguments: # tableau Standard tableau (as a list of columns) # # Return value: # Vector of values representing the maximum point # proc ::math::optimize::SimplexResult {tableau} { set result {} set firstcol [lindex $tableau 0] set secondcol [lindex $tableau 1] set result {} set nvars [expr {[llength $tableau]-2}] for {set i 0} {$i < $nvars } { incr i } { lappend result 0.0 } set idx 0 foreach col [lrange $firstcol 0 end-1] { set result [lreplace $result $col $col [lindex $secondcol $idx]] incr idx } return $result } # SimplexFindNextColumn -- # Find the next column - the one with the largest negative # coefficient # # Arguments: # tableau Standard tableau (as a list of columns) # # Return value: # Index of the column # proc ::math::optimize::SimplexFindNextColumn {tableau} { set idx 0 set minidx -1 set mincoeff 0.0 foreach col [lrange $tableau 2 end] { set coeff [lindex $col end] if { $coeff < 0.0 } { if { $coeff < $mincoeff } { set minidx $idx set mincoeff $coeff } } incr idx } return $minidx } # SimplexFindNextRow -- # Find the next row - the one with the largest negative # coefficient # # Arguments: # tableau Standard tableau (as a list of columns) # nextcol Index of the variable that will replace this one # # Return value: # Index of the row # proc ::math::optimize::SimplexFindNextRow {tableau nextcol} { set idx 0 set minidx -1 set mincoeff {} set bvalues [lrange [lindex $tableau 1] 0 end-1] set yvalues [lrange [lindex $tableau [expr {2+$nextcol}]] 0 end-1] foreach rowcoeff $bvalues divcoeff $yvalues { if { $divcoeff > 0.0 } { set coeff [expr {$rowcoeff/$divcoeff}] if { $mincoeff == {} || $coeff < $mincoeff } { set minidx $idx set mincoeff $coeff } } incr idx } return $minidx } # SimplexMakeVector -- # Make the "sweep" vector # # Arguments: # tableau Standard tableau (as a list of columns) # nextcol Index of the variable that will replace this one # nextrow Index of the variable in the base that will be replaced # # Return value: # Vector to be used to update the coefficients of the tableau # proc ::math::optimize::SimplexMakeVector {tableau nextcol nextrow} { set idx 0 set vector {} set column [lindex $tableau [expr {2+$nextcol}]] set divcoeff [lindex $column $nextrow] foreach colcoeff $column { if { $idx != $nextrow } { set coeff [expr {-$colcoeff/$divcoeff}] } else { set coeff [expr {1.0/$divcoeff-1.0}] } lappend vector $coeff incr idx } return $vector } # SimplexNewTableau -- # Sweep through the tableau and create the new one # # Arguments: # tableau Standard tableau (as a list of columns) # nextcol Index of the variable that will replace this one # nextrow Index of the variable in the base that will be replaced # vector Vector to sweep with # # Return value: # New tableau # proc ::math::optimize::SimplexNewTableau {tableau nextcol nextrow vector} { # # The first column: replace the nextrow-th element # The second column: replace the value at the nextrow-th element # For all the others: the same receipe # set firstcol [lreplace [lindex $tableau 0] $nextrow $nextrow $nextcol] set newtableau [list $firstcol] # # The rest of the matrix # foreach column [lrange $tableau 1 end] { set yval [lindex $column $nextrow] set newcol {} foreach c $column vcoeff $vector { set newval [expr {$c+$yval*$vcoeff}] lappend newcol $newval } lappend newtableau $newcol } return $newtableau } # Now we can announce our presence package provide math::optimize 1.0 if { ![info exists ::argv0] || [string compare $::argv0 [info script]] } { return } namespace import math::optimize::min_bound_1d namespace import math::optimize::maximum namespace import math::optimize::nelderMead proc f {x y} { set xx [expr { $x - 3.1415926535897932 / 2. }] set v1 [expr { 0.3 * exp( -$xx*$xx / 2. ) }] set d [expr { 10. * $y - sin(9. * $x) }] set v2 [expr { exp(-10.*$d*$d)}] set rv [expr { -$v1 - $v2 }] return $rv } proc g {a b} { set x1 [expr {0.1 - $a + $b}] set x2 [expr {$a + $b - 1.}] set x3 [expr {3.-8.*$a+8.*$a*$a-8.*$b+8.*$b*$b}] set x4 [expr {$a/10. + $b/10. + $x1*$x1/3. + $x2*$x2 - $x2 * exp(1-$x3*$x3)}] return $x4 } set prec $::tcl_precision if {![package vsatisfies [package provide Tcl] 8.5]} { set ::tcl_precision 17 } else { set ::tcl_precision 0 } puts "f" puts [math::optimize::nelderMead f {1. 0.} -scale {0.1 0.01} -trace 1] puts "g" puts [math::optimize::nelderMead g {0. 0.} -scale {1. 1.} -trace 1] set ::tcl_precision $prec tcllib-1.15/modules/math/bessel.test0000755000175000017500000000412712077663116017026 0ustar sergeisergei# -*- tcl -*- # Tests for special (Bessel) functions in math library -*- tcl -*- # # This file contains a collection of tests for one or more of the Tcllib # procedures. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # $Id: bessel.test,v 1.15 2007/08/21 17:33:00 andreas_kupries Exp $ # # Copyright (c) 2004 by Arjen Markus # All rights reserved. # # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.4;# statistics,linalg! testsNeedTcltest 2.1 support { useLocal math.tcl math useLocal constants.tcl math::constants useLocal linalg.tcl math::linearalgebra ;# for statistics useLocal statistics.tcl math::statistics } testing { useLocal special.tcl math::special } # ------------------------------------------------------------------------- # # As the values were given with four digits, an absolute # error is most appropriate # proc matchNumbers {expected actual} { set match 1 foreach a $actual e $expected { if {abs($a-$e) > 0.1e-4} { set match 0 break } } return $match } customMatch numbers matchNumbers # ------------------------------------------------------------------------- test "Bessel-1.0" "Values of the zeroth-order Bessel function" \ -match numbers -body { set result {} foreach x {0.0 1.0 2.0 5.0 7.0 10.0 11.0 14.0} { lappend result [::math::special::J0 $x] } set result } -result {1.0 0.765198 0.223891 -0.177597 0.300079 -0.245936 -0.171190 0.171073} test "Bessel-1.1" "Values of the first-order Bessel function" \ -match numbers -body { set result {} foreach x {0.0 1.0 2.0 5.0 7.0 10.0 11.0 14.0} { lappend result [::math::special::J1 $x] } set result } -result {0.0 0.440050 0.576725 -0.327579 -0.004683 0.043473 -0.176785 0.133375} # # No tests for J1/2 yet # # # No tests for I_n yet # # End of test cases testsuiteCleanup tcllib-1.15/modules/math/math.man0000644000175000017500000000775512077663116016305 0ustar sergeisergei[manpage_begin math n 1.2.5] [comment {-*- tcl -*- doctools manpage}] [moddesc {Tcl Math Library}] [titledesc {Tcl Math Library}] [category Mathematics] [require Tcl 8.2] [require math [opt 1.2.5]] [description] [para] The [package math] package provides utility math functions. [para] Besides a set of basic commands, available via the package [emph math], there are more specialised packages: [list_begin itemized] [item] [package math::bigfloat] - Arbitrary-precision floating-point arithmetic [item] [package math::bignum] - Arbitrary-precision integer arithmetic [item] [package math::calculus::romberg] - Robust integration methods for functions of one variable, using Romberg integration [item] [package math::calculus] - Integration of functions, solving ordinary differential equations [item] [package math::combinatorics] - Procedures for various combinatorial functions (for instance the Gamma function and "k out of n") [item] [package math::complexnumbers] - Complex number arithmetic [item] [package math::constants] - A set of well-known mathematical constants, such as Pi, E, and the golden ratio [item] [package math::fourier] - Discrete Fourier transforms [item] [package math::fuzzy] - Fuzzy comparisons of floating-point numbers [item] [package math::geometry] - 2D geometrical computations [item] [package math::interpolate] - Various interpolation methods [item] [package math::linearalgebra] - Linear algebra package [item] [package math::optimize] - Optimization methods [item] [package math::polynomials] - Polynomial arithmetic (includes families of classical polynomials) [item] [package math::rationalfunctions] - Arithmetic of rational functions [item] [package math::roman] - Manipulation (including arithmetic) of Roman numerals [item] [package math::special] - Approximations of special functions from mathematical physics [item] [package math::statistics] - Statistical operations and tests [list_end] [section "BASIC COMMANDS"] [list_begin definitions] [call [cmd ::math::cov] [arg value] [arg value] [opt [arg {value ...}]]] Return the coefficient of variation expressed as percent of two or more numeric values. [call [cmd ::math::integrate] [arg {list of xy value pairs}]] Return the area under a "curve" defined by a set of x,y pairs and the error bound as a list. [call [cmd ::math::fibonacci] [arg n]] Return the [arg n]'th Fibonacci number. [call [cmd ::math::max] [arg value] [opt [arg {value ...}]]] Return the maximum of one or more numeric values. [call [cmd ::math::mean] [arg value] [opt [arg {value ...}]]] Return the mean, or "average" of one or more numeric values. [call [cmd ::math::min] [arg value] [opt [arg {value ...}]]] Return the minimum of one or more numeric values. [call [cmd ::math::product] [arg value] [opt [arg {value ...}]]] Return the product of one or more numeric values. [call [cmd ::math::random] [opt [arg value1]] [opt [arg value2]]] Return a random number. If no arguments are given, the number is a floating point value between 0 and 1. If one argument is given, the number is an integer value between 0 and [arg value1]. If two arguments are given, the number is an integer value between [arg value1] and [arg value2]. [call [cmd ::math::sigma] [arg value] [arg value] [opt [arg {value ...}]]] Return the population standard deviation of two or more numeric values. [call [cmd ::math::stats] [arg value] [arg value] [opt [arg {value ...}]]] Return the mean, standard deviation, and coefficient of variation (as percent) as a list. [call [cmd ::math::sum] [arg value] [opt [arg {value ...}]]] Return the sum of one or more numeric values. [list_end] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph math] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [keywords math statistics] [manpage_end] tcllib-1.15/modules/math/fuzzy.tcl0000755000175000017500000000716412077663116016547 0ustar sergeisergei# fuzzy.tcl -- # # Script to define tolerant floating-point comparisons # (Tcl-only version) # # version 0.2: improved and extended, march 2002 # version 0.2.1: fix bug #2933130, january 2010 package provide math::fuzzy 0.2.1 namespace eval ::math::fuzzy { variable eps3 2.2e-16 namespace export teq tne tge tgt tle tlt tfloor tceil tround troundn # DetermineTolerance # Determine the epsilon value # # Arguments: # None # # Result: # None # # Side effects: # Sets variable eps3 # proc DetermineTolerance { } { variable eps3 set eps 1.0 while { [expr {1.0+$eps}] != 1.0 } { set eps3 [expr 3.0*$eps] set eps [expr 0.5*$eps] } #set check [expr {1.0+2.0*$eps}] #puts "Eps3: $eps3 ($eps) ([expr {1.0-$check}] [expr 1.0-$check]" } # Absmax -- # Return the absolute maximum of two numbers # # Arguments: # first First number # second Second number # # Result: # Maximum of the absolute values # proc Absmax { first second } { return [expr {abs($first) > abs($second)? abs($first) : abs($second)}] } # teq, tne, tge, tgt, tle, tlt -- # Compare two floating-point numbers and return the logical result # # Arguments: # first First number # second Second number # # Result: # 1 if the condition holds, 0 if not. # proc teq { first second } { variable eps3 set scale [Absmax $first $second] return [expr {abs($first-$second) <= $eps3 * $scale}] } proc tne { first second } { variable eps3 return [expr {![teq $first $second]}] } proc tgt { first second } { variable eps3 set scale [Absmax $first $second] return [expr {($first-$second) > $eps3 * $scale}] } proc tle { first second } { return [expr {![tgt $first $second]}] } proc tlt { first second } { expr { [tle $first $second] && [tne $first $second] } } proc tge { first second } { if { [tgt $first $second] } { return 1 } else { return [teq $first $second] } } # tfloor -- # Determine the "floor" of a number and return the result # # Arguments: # number Number in question # # Result: # Largest integer number that is tolerantly smaller than the given # value # proc tfloor { number } { variable eps3 set q [expr {($number < 0.0)? (1.0-$eps3) : 1.0 }] set rmax [expr {$q / (2.0 - $eps3)}] set eps5 [expr {$eps3/$q}] set vmin1 [expr {$eps5*abs(1.0+floor($number))}] set vmin2 [expr {($rmax < $vmin1)? $rmax : $vmin1}] set vmax [expr {($eps3 > $vmin2)? $eps3 : $vmin2}] set result [expr {floor($number+$vmax)}] if { $number <= 0.0 || ($result-$number) < $rmax } { return $result } else { return [expr {$result-1.0}] } } # tceil -- # Determine the "ceil" of a number and return the result # # Arguments: # number Number in question # # Result: # Smallest integer number that is tolerantly greater than the given # value # proc tceil { number } { expr {-[tfloor [expr {-$number}]]} } # tround -- # Round off a number and return the result # # Arguments: # number Number in question # # Result: # Nearest integer number # proc tround { number } { tfloor [expr {$number+0.5}] } # troundn -- # Round off a number to a given precision and return the result # # Arguments: # number Number in question # ndec Number of decimals to keep # # Result: # Nearest number with given precision # proc troundn { number ndec } { set scale [expr {pow(10.0,$ndec)}] set rounded [tfloor [expr {$number*$scale+0.5}]] expr {$rounded/$scale} } # # Determine the tolerance once and for all # DetermineTolerance rename DetermineTolerance {} } ;# End of namespace tcllib-1.15/modules/math/exponential.tcl0000755000175000017500000003127312077663116017704 0ustar sergeisergei# exponential.tcl -- # Compute exponential integrals (E1, En, Ei, li, Shi, Chi, Si, Ci) # namespace eval ::math::special { variable pi 3.1415926 variable gamma 0.57721566490153286 variable halfpi [expr {$pi/2.0}] # Euler's digamma function for small integer arguments variable psi { NaN -0.57721566490153286 0.42278433509846713 0.92278433509846713 1.2561176684318005 1.5061176684318005 1.7061176684318005 1.8727843350984672 2.0156414779556102 2.1406414779556102 2.2517525890667214 2.3517525890667215 2.4426616799758123 2.5259950133091458 2.6029180902322229 2.6743466616607945 2.7410133283274614 2.8035133283274614 2.8623368577392259 2.9178924132947812 2.9705239922421498 3.0205239922421496 3.0681430398611971 3.1135975853157425 3.1570758461853079 3.1987425128519744 3.2387425128519745 3.2772040513135128 3.31424108835055 3.3499553740648356 3.3844381326855251 3.4177714660188583 3.4500295305349873 3.4812795305349873 3.5115825608380176 3.5409943255438998 3.5695657541153283 3.597343531893106 3.6243705589201332 3.6506863483938172 3.6763273740348428 } } # ComputeExponFG -- # Compute the auxiliary functions f and g # # Arguments: # x Parameter of the integral (x>=0) # Result: # Approximate values for f and g # Note: # See Abramowitz and Stegun # proc ::math::special::ComputeExponFG {x} { set x2 [expr {$x*$x}] set fx [expr {($x2*$x2+7.241163*$x2+2.463936)/ ($x2*$x2+9.068580*$x2+7.157433)/$x}] set gx [expr {($x2*$x2+7.547478*$x2+1.564072)/ ($x2*$x2+12.723684*$x2+15.723606)/$x2}] list $fx $gx } # exponential_Ei -- # Compute the exponential integral of the second kind, to relative # error eps # Arguments: # x Value of the argument # eps Relative error # Result: # Principal value of the integral exp(x)/x # from -infinity to x # proc ::math::special::exponential_Ei { x { eps 1.0e-10 } } { variable gamma if { ![string is double -strict $x] } { return -code error "expected a floating point number but found \"$x\"" } if { $x < 0.0 } { return [expr { -[exponential_En 1 [expr { - $x }] $eps] }] } if { $x == 0.0 } { set message "Argument to exponential_Ei must not be zero" return -code error -errorcode [list ARITH DOMAIN $message] $message } if { $x >= -log($eps) } { # evaluate Ei(x) as an asymptotic series; the series is formally # divergent, but the leading terms give the desired value to # enough precision. set sum 0. set term 1. set k 1 while { 1 } { set p $term set term [expr { $term * ( $k / $x ) }] if { $term < $eps } { break } if { $term < $p } { set sum [expr { $sum + $term }] } else { set sum [expr { $sum - $p }] break } incr k } return [expr { exp($x) * ( 1.0 + $sum ) / $x }] } elseif { $x >= 1e-18 } { # evaluate Ei(x) as a power series set sum 0. set fact 1. set pow $x set n 1 while { 1 } { set fact [expr { $fact * $n }] set term [expr { $pow / $n / $fact }] set sum [expr { $sum + $term }] if { $term < $eps * $sum } break set pow [expr { $x * $pow }] incr n } return [expr { $sum + $gamma + log($x) }] } else { # Ei(x) for small x return [expr { log($x) + $gamma }] } } # exponential_En -- # Compute the exponential integral of n-th order, to relative error # epsilon # # Arguments: # n Order of the integral (n>=1, integer) # x Parameter of the integral (x>0) # epsilon Relative error # Result: # Value of En(x) = integral from 0 to x of exp(-x)/x**n # proc ::math::special::exponential_En { n x { epsilon 1.0e-10 } } { variable psi variable gamma if { ![string is integer -strict $n] || $n < 0 } { return -code error "expected a non-negative integer but found \"$n\"" } if { ![string is double -strict $x] } { return -code error "expected a floating point number but found \"$x\"" } if { $n == 0 } { if { $x == 0.0 } { return -code error "E0(0) is indeterminate" } return [expr { exp( -$x ) / $x }] } if { $n == 1 && $x < 0.0 } { return [expr {- [exponential_Ei [expr { -$x }] $eps] }] } if { $x < 0.0 } { return -code error "can't evaluate En(x) for negative x" } if { $x == 0.0 } { return [expr { 1.0 / ( $n - 1 ) }] } if { $x > 1.0 } { # evaluate En(x) as a continued fraction set b [expr { $x + $n }] set c 1.e308 set d [expr { 1.0 / $b }] set h $d set i 1 while { 1 } { set a [expr { -$i * ( $n - 1 + $i ) }] set b [expr { $b + 2.0 }] set d [expr { 1.0 / ( $a * $d + $b ) }] set c [expr { $b + $a / $c }] set delta [expr { $c * $d }] set h [expr { $h * $delta }] if { abs( $delta - 1. ) < $epsilon } { return [expr { $h * exp(-$x) }] } incr i } } else { # evaluate En(x) as a series if { $n == 1 } { set a [expr { -log($x) - $gamma }] } else { set a [expr { 1.0 / ( $n - 1 ) }] } set f 1.0 set i 1 while { 1 } { set f [expr { - $f * $x / $i }] if { $i == $n - 1 } { set term [expr { $f * ([lindex $psi $n] - log($x)) }] } else { set term [expr { $f / ( $n - 1 - $i ) }] } set a [expr { $a + $term }] if { abs($term) < $epsilon * abs($a) } { return $a } incr i } } } # exponential_E1 -- # Compute the exponential integral # # Arguments: # x Parameter of the integral (x>0) # Result: # Value of E1(x) = integral from x to infinity of exp(-x)/x # Note: # This relies on a rational approximation (error ~ 2e-7 (x<1) or 5e-5 (x>1) # proc ::math::special::exponential_E1 {x} { if { $x <= 0.0 } { error "Domain error: x must be positive" } if { $x < 1.0 } { return [expr {-log($x)+((((0.00107857*$x-0.00976004)*$x+0.05519968)*$x-0.24991055)*$x+0.99999193)*$x-0.57721566}] } else { set xexpe [expr {($x*$x+2.334733*$x+0.250621)/($x*$x+3.330657*$x+1.681534)}] return [expr {$xexpe/($x*exp($x))}] } } # exponential_li -- # Compute the logarithmic integral # Arguments: # x Value of the argument # Result: # Value of the integral 1/ln(x) from 0 to x # proc ::math::special::exponential_li {x} { if { $x < 0 } { return -code error "Argument must be positive or zero" } else { if { $x == 0.0 } { return 0.0 } else { return [exponential_Ei [expr {log($x)}]] } } } # exponential_Shi -- # Compute the hyperbolic sine integral # Arguments: # x Value of the argument # Result: # Value of the integral sinh(x)/x from 0 to x # proc ::math::special::exponential_Shi {x} { if { $x < 0 } { return -code error "Argument must be positive or zero" } else { if { $x == 0.0 } { return 0.0 } else { proc g {x} { return [expr {sinh($x)/$x}] } return [lindex [::math::calculus::romberg g 0.0 $x] 0] } } } # exponential_Chi -- # Compute the hyperbolic cosine integral # Arguments: # x Value of the argument # Result: # Value of the integral (cosh(x)-1)/x from 0 to x # proc ::math::special::exponential_Chi {x} { variable gamma if { $x < 0 } { return -code error "Argument must be positive or zero" } else { if { $x == 0.0 } { return 0.0 } else { proc g {x} { return [expr {(cosh($x)-1.0)/$x}] } set integral [lindex [::math::calculus::romberg g 0.0 $x] 0] return [expr {$gamma+log($x)+$integral}] } } } # exponential_Si -- # Compute the sine integral # Arguments: # x Value of the argument # Result: # Value of the integral sin(x)/x from 0 to x # proc ::math::special::exponential_Si {x} { variable halfpi if { $x < 0 } { return -code error "Argument must be positive or zero" } else { if { $x == 0.0 } { return 0.0 } else { if { $x < 1.0 } { proc g {x} { return [expr {sin($x)/$x}] } return [lindex [::math::calculus::romberg g 0.0 $x] 0] } else { foreach {f g} [ComputeExponFG $x] {break} return [expr {$halfpi-$f*cos($x)-$g*sin($x)}] } } } } # exponential_Ci -- # Compute the cosine integral # Arguments: # x Value of the argument # Result: # Value of the integral (cosh(x)-1)/x from 0 to x # proc ::math::special::exponential_Ci {x} { variable gamma if { $x < 0 } { return -code error "Argument must be positive or zero" } else { if { $x == 0.0 } { return 0.0 } else { if { $x < 1.0 } { proc g {x} { return [expr {(cos($x)-1.0)/$x}] } set integral [lindex [::math::calculus::romberg g 0.0 $x] 0] return [expr {$gamma+log($x)+$integral}] } else { foreach {f g} [ComputeExponFG $x] {break} return [expr {$f*sin($x)-$g*cos($x)}] } } } } # some tests -- # Reproduce tables 5.1, 5.2 from Abramowitz & Stegun, if { [info exists ::argv0] && ![string compare $::argv0 [info script]] } { namespace eval ::math::special { for { set i 0.01 } { $i < 0.505 } { set i [expr { $i + 0.01 }] } { set ei [exponential_Ei $i] set e1 [expr { - [exponential_Ei [expr { - $i }]] }] puts [format "%9.6f\t%.10g\t%.10g" $i \ [expr {($ei - log($i) - 0.57721566490153286)/$i} ] \ [expr {($e1 + log($i) + 0.57721566490153286) / $i }]] } puts {} for { set i 0.5 } { $i < 2.005 } { set i [expr { $i + 0.01 }] } { set ei [exponential_Ei $i] set e1 [expr { - [exponential_Ei [expr { - $i }]] }] puts [format "%9.6f\t%.10g\t%.10g" $i $ei $e1] } puts {} for {} { $i < 10.05 } { set i [expr { $i + 0.1 }] } { set ei [exponential_Ei $i] set e1 [expr { - [exponential_Ei [expr { - $i }]] }] puts [format "%9.6f\t%.10g\t%.10g" $i \ [expr { $i * exp(-$i) * $ei }] \ [expr { $i * exp($i) * $e1 }]] } puts {} for {set ooi 0.1} { $ooi > 0.0046 } { set ooi [expr { $ooi - 0.005 }] } { set i [expr { 1.0 / $ooi }] set ri [expr { round($i) }] set ei [exponential_Ei $i] set e1 [expr { - [exponential_Ei [expr { - $i }]] }] puts [format "%9.6f\t%.10g\t%.10g\t%d" $i \ [expr { $i * exp(-$i) * $ei }] \ [expr { $i * exp($i) * $e1 }] \ $ri] } puts {} # Reproduce table 5.4 from Abramowitz and Stegun for { set x 0.00 } { $x < 0.505 } { set x [expr { $x + 0.01 }] } { set line [format %4.2f $x] if { $x == 0.00 } { append line { } 1.0000000 } else { append line { } [format %9.7f \ [expr { [exponential_En 2 $x] - $x * log($x) }]] } foreach n { 3 4 10 20 } { append line { } [format %9.7f [exponential_En $n $x]] } puts $line } puts {} for { set x 0.50 } { $x < 2.005 } { set x [expr { $x + 0.01 }] } { set line [format %4.2f $x] foreach n { 2 3 4 10 20 } { append line { } [format %9.7f [exponential_En $n $x]] } puts $line } puts {} for { set oox 0.5 } { $oox > 0.1025 } { set oox [expr { $oox - 0.05 }] } { set line [format %4.2f $oox] set x [expr { 1.0 / $oox }] set rx [expr { round( $x ) }] foreach n { 2 3 4 10 20 } { set en [exponential_En $n [expr { 1.0 / $oox }]] append line { } [format %9.7f [expr { ( $x + $n ) * exp($x) * $en }]] } append line { } [format %3d $rx] puts $line } for { set oox 0.10 } { $oox > 0.005 } { set oox [expr { $oox - 0.01 }] } { set line [format %4.2f $oox] set x [expr { 1.0 / $oox }] set rx [expr { round( $x ) }] foreach n { 2 3 4 10 20 } { set en [exponential_En $n $x] append line { } [format %9.7f [expr { ( $x + $n ) * exp($x) * $en }]] } append line { } [format %3d $rx] puts $line } puts {} catch {exponential_Ei 0.0} result; puts $result } } tcllib-1.15/modules/math/tclIndex0000644000175000017500000000325312077663116016341 0ustar sergeisergei# Tcl autoload index file, version 2.0 # This file is generated by the "auto_mkindex" command # and sourced to set up indexing information for one or # more commands. Typically each line is a command that # sets an element in the auto_index array, where the # element name is the name of a command and the value is # a script that loads the command. set auto_index(::math::cov) [list source [file join $dir misc.tcl]] set auto_index(::math::fibonacci) [list source [file join $dir misc.tcl]] set auto_index(::math::integrate) [list source [file join $dir misc.tcl]] set auto_index(::math::max) [list source [file join $dir misc.tcl]] set auto_index(::math::mean) [list source [file join $dir misc.tcl]] set auto_index(::math::min) [list source [file join $dir misc.tcl]] set auto_index(::math::product) [list source [file join $dir misc.tcl]] set auto_index(::math::random) [list source [file join $dir misc.tcl]] set auto_index(::math::sigma) [list source [file join $dir misc.tcl]] set auto_index(::math::stats) [list source [file join $dir misc.tcl]] set auto_index(::math::sum) [list source [file join $dir misc.tcl]] set auto_index(::math::expectDouble) [list source [file join $dir misc.tcl]] set auto_index(::math::InitializeFactorial) [list source [file join $dir combinatorics.tcl]] set auto_index(::math::InitializePascal) [list source [file join $dir combinatorics.tcl]] set auto_index(::math::ln_Gamma) [list source [file join $dir combinatorics.tcl]] set auto_index(::math::factorial) [list source [file join $dir combinatorics.tcl]] set auto_index(::math::choose) [list source [file join $dir combinatorics.tcl]] set auto_index(::math::Beta) [list source [file join $dir combinatorics.tcl]] tcllib-1.15/modules/math/mvlinreg.tcl0000755000175000017500000001755012077663116017203 0ustar sergeisergei# mvreglin.tcl -- # Addition to the statistics package # Copyright 2007 Eric Kemp-Benedict # Released under the BSD license under any terms # that allow it to be compatible with tcllib package require math::linearalgebra 1.0 package require math::statistics 0.4 # ::math::statistics -- # This file adds: # mvlinreg = Multivariate Linear Regression # namespace eval ::math::statistics { variable epsilon 1.0e-7 namespace export tstat mv-wls mv-ols namespace import -force \ ::math::linearalgebra::mkMatrix \ ::math::linearalgebra::mkVector \ ::math::linearalgebra::mkIdentity \ ::math::linearalgebra::mkDiagonal \ ::math::linearalgebra::getrow \ ::math::linearalgebra::setrow \ ::math::linearalgebra::getcol \ ::math::linearalgebra::setcol \ ::math::linearalgebra::getelem \ ::math::linearalgebra::setelem \ ::math::linearalgebra::dotproduct \ ::math::linearalgebra::matmul \ ::math::linearalgebra::add \ ::math::linearalgebra::sub \ ::math::linearalgebra::solveGauss \ ::math::linearalgebra::transpose } # tstats -- # Returns inverse of the single-tailed t distribution # given number of degrees of freedom & confidence # # Arguments: # n Number of degrees of freedom # alpha Confidence level (defaults to 0.05) # # Result: # Inverse of the t-distribution # # Note: # Iterates until result is within epsilon of the target. # It is possible that the iteration does not converge # proc ::math::statistics::tstat {n {alpha 0.05}} { variable epsilon variable tvals if [info exists tvals($n:$alpha)] { return $tvals($n:$alpha) } set deltat [expr {100 * $epsilon}] # For one-tailed distribution, set ptarg [expr {1.000 - $alpha/2.0}] set maxiter 100 # Initial value for t set t 2.0 set niter 0 while {abs([::math::statistics::cdf-students-t $n $t] - $ptarg) > $epsilon} { set pstar [::math::statistics::cdf-students-t $n $t] set pl [::math::statistics::cdf-students-t $n [expr {$t - $deltat}]] set ph [::math::statistics::cdf-students-t $n [expr {$t + $deltat}]] set t [expr {$t + 2.0 * $deltat * ($ptarg - $pstar)/($ph - $pl)}] incr niter if {$niter == $maxiter} { return -code error "::math::statistics::tstat: Did not converge after $niter iterations" } } # Cache the result to shorten the call in future set tvals($n:$alpha) $t return $t } # mv-wls -- # Weighted Least Squares # # Arguments: # data Alternating list of weights and observations # # Result: # List containing: # * R-squared # * Adjusted R-squared # * Coefficients of x's in fit # * Standard errors of the coefficients # * 95% confidence bounds for coefficients # # Note: # The observations are lists starting with the dependent variable y # and then the values of the independent variables (x1, x2, ...): # # mv-wls [list w [list y x's] w [list y x's] ...] # proc ::math::statistics::mv-wls {data} { # Fill the matrices of x & y values, and weights # For n points, k coefficients # The number of points is equal to half the arguments (n weights, n points) set n [expr {[llength $data]/2}] set firstloop true # Sum up all y values to take an average set ysum 0 # Add up the weights set wtsum 0 # Count over rows (points) as you go set point 0 foreach {wt pt} $data { # Check inputs if {[string is double $wt] == 0} { return -code error "::math::statistics::mv-wls: Weight \"$wt\" is not a number" return {} } ## -- Check dimensions, initialize if $firstloop { # k = num of vals in pt = 1 + number of x's (because of constant) set k [llength $pt] if {$n <= [expr {$k + 1}]} { return -code error "::math::statistics::mv-wls: Too few degrees of freedom: $k variables but only $n points" return {} } set X [mkMatrix $n $k] set y [mkVector $n] set I_x [mkIdentity $k] set I_y [mkIdentity $n] set firstloop false } else { # Have to have same number of x's for all points if {$k != [llength $pt]} { return -code error "::math::statistics::mv-wls: Point \"$pt\" has wrong number of values (expected $k)" # Clean up return {} } } ## -- Extract values from set of points # Make a list of y values set yval [expr {double([lindex $pt 0])}] setelem y $point $yval set ysum [expr {$ysum + $wt * $yval}] set wtsum [expr {$wtsum + $wt}] # Add x-values to the x-matrix set xrow [lrange $pt 1 end] # Add the constant (value = 1.0) lappend xrow 1.0 setrow X $point $xrow # Create list of weights & square root of weights lappend w [expr {double($wt)}] lappend sqrtw [expr {sqrt(double($wt))}] incr point } set ymean [expr {double($ysum)/$wtsum}] set W [mkDiagonal $w] set sqrtW [mkDiagonal $sqrtw] # Calculate sum os square differences for x's for {set r 0} {$r < $k} {incr r} { set xsqrsum 0.0 set xmeansum 0.0 # Calculate sum of squared differences as: sum(x^2) - (sum x)^2/n for {set t 0} {$t < $n} {incr t} { set xval [getelem $X $t $r] set xmeansum [expr {$xmeansum + double($xval)}] set xsqrsum [expr {$xsqrsum + double($xval * $xval)}] } lappend xsqr [expr {$xsqrsum - $xmeansum * $xmeansum/$n}] } ## -- Set up the X'WX matrix set XtW [matmul [::math::linearalgebra::transpose $X] $W] set XtWX [matmul $XtW $X] # Invert set M [solveGauss $XtWX $I_x] set beta [matmul $M [matmul $XtW $y]] ### -- Residuals & R-squared # 1) Generate list of diagonals of the hat matrix set H [matmul $X [matmul $M $XtW]] for {set i 0} {$i < $n} {incr i} { lappend h_ii [getelem $H $i $i] } set R [matmul $sqrtW [matmul [sub $I_y $H] $y]] set yhat [matmul $H $y] # 2) Generate list of residuals, sum of squared residuals, r-squared set sstot 0.0 set ssreg 0.0 # Note: Relying on representation of Vector as a list for y, yhat foreach yval $y wt $w yhatval $yhat { set sstot [expr {$sstot + $wt * ($yval - $ymean) * ($yval - $ymean)}] set ssreg [expr {$ssreg + $wt * ($yhatval - $ymean) * ($yhatval - $ymean)}] } set r2 [expr {double($ssreg)/$sstot}] set adjr2 [expr {1.0 - (1.0 - $r2) * ($n - 1)/($n - $k)}] set sumsqresid [dotproduct $R $R] set s2 [expr {double($sumsqresid) / double($n - $k)}] ### -- Confidence intervals for coefficients set tvalue [tstat [expr {$n - $k}]] for {set i 0} {$i < $k} {incr i} { set stderr [expr {sqrt($s2 * [getelem $M $i $i])}] set mid [lindex $beta $i] lappend stderrs $stderr lappend confinterval [list [expr {$mid - $tvalue * $stderr}] [expr {$mid + $tvalue * $stderr}]] } return [list $r2 $adjr2 $beta $stderrs $confinterval] } # mv-ols -- # Ordinary Least Squares # # Arguments: # data List of observations, list of lists # # Result: # List containing: # * R-squared # * Adjusted R-squared # * Coefficients of x's in fit # * Standard errors of the coefficients # * 95% confidence bounds for coefficients # # Note: # The observations are lists starting with the dependent variable y # and then the values of the independent variables (x1, x2, ...): # # mv-ols [list y x's] [list y x's] ... # proc ::math::statistics::mv-ols {data} { set newdata {} foreach pt $data { lappend newdata 1 $pt } return [mv-wls $newdata] } tcllib-1.15/modules/math/polynomials.test0000755000175000017500000002121612077663116020115 0ustar sergeisergei# -*- tcl -*- # polynomials.test -- # Test cases for the ::math::polynomials package # # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.3 testsNeedTcltest 2.1 support { useLocal math.tcl math } testing { useLocal polynomials.tcl math::polynomials } # ------------------------------------------------------------------------- proc matchNumbers {expected actual} { set match 1 foreach a $actual e $expected { if {abs($a-$e) > 0.1e-6} { set match 0 break } } return $match } customMatch numbers matchNumbers # ------------------------------------------------------------------------- test "Polynomial-1.0" "Create polynomial (degree 3)" \ -match numbers -body { set f1 [::math::polynomials::polynomial {1 2 3 4}] set result [lindex $f1 1] } -result {4 3 2 1} test "Polynomials-1.1" "Create polynomial (degree 3, leading zeros)" \ -match numbers -body { set f1 [::math::polynomials::polynomial {1 2 3 4 0 0 0}] set result [lindex $f1 1] } -result {4 3 2 1} test "Polynomials-1.2" "Create polynomial (invalid coefficients)" \ -match glob -body { set f1 [::math::polynomials::polynomial {A B C}] } -result "Coefficients *" -returnCodes 1 test "Polynomials-1.3" "Create polynomial command" \ -match numbers -body { set f1 [::math::polynomials::polynCmd {1 2 3 4 0 0 0}] set result {} foreach x {0 1 2 3} { lappend result [$f1 $x] } set result } -result {1 10 49 142} test "Polynomials-1.4" "Evaluate polynomial" \ -match numbers -body { set f1 [::math::polynomials::polynomial {1 2 3 4 0 0 0}] set result {} foreach x {0 1 2 3} { lappend result [::math::polynomials::evalPolyn $f1 $x] } set result } -result {1 10 49 142} test "Polynomials-1.5" "Evaluate null polynomial" \ -match numbers -body { set f1 [::math::polynomials::polynomial {0 0 0}] set result {} foreach x {0 1 2 3} { lappend result [::math::polynomials::evalPolyn $f1 $x] } set result } -result {0 0 0 0} test "Polynomials-2.1" "Query polynomial properties - degree" \ -match exact -body { set f1 [::math::polynomials::polynomial {1 2 3}] set result [::math::polynomials::degreePolyn $f1] } -result 2 test "Polynomials-2.2" "Query polynomial properties - degree (2 again)" \ -match exact -body { set f1 [::math::polynomials::polynomial {1 2 3 0 0 0}] set result [::math::polynomials::degreePolyn $f1] } -result 2 test "Polynomials-2.3" "Query polynomial properties - degree (null)" \ -match exact -body { set f1 [::math::polynomials::polynomial {0 0 0}] set result [::math::polynomials::degreePolyn $f1] } -result -1 test "Polynomials-2.4" "Query polynomial properties - leading coeff" \ -match exact -body { set f1 [::math::polynomials::polynomial {1 2 3}] set idx [::math::polynomials::degreePolyn $f1] set coeff [::math::polynomials::coeffPolyn $f1 $idx] } -result 3 test "Polynomials-2.5" "Query polynomial properties - all coeffs" \ -match numbers -body { set f1 [::math::polynomials::polynomial {1 2 3}] set coeffs [::math::polynomials::allCoeffsPolyn $f1] } -result {1 2 3} test "Polynomials-3.1" "Derivatives and primitives - derivative" \ -match numbers -body { set f1 [::math::polynomials::polynomial {1 2 3}] set f2 [::math::polynomials::derivPolyn $f1] set coeffs [::math::polynomials::allCoeffsPolyn $f2] } -result {2 6} test "Polynomials-3.2" "Derivatives and primitives - primitive" \ -match numbers -body { set f1 [::math::polynomials::polynomial {1 4 9}] set f2 [::math::polynomials::primitivePolyn $f1] set coeffs [::math::polynomials::allCoeffsPolyn $f2] } -result {0 1 2 3} test "Polynomials-4.1" "Arithmetical operations - add (1)" \ -match numbers -body { set f1 [::math::polynomials::polynomial {1 2 3}] set f2 [::math::polynomials::polynomial {1 2}] set f3 [::math::polynomials::addPolyn $f1 $f2] set coeffs [::math::polynomials::allCoeffsPolyn $f3] } -result {2 4 3} test "Polynomials-4.2" "Arithmetical operations - add (2)" \ -match numbers -body { set f1 [::math::polynomials::polynomial {1 2 3}] set f2 [::math::polynomials::polynomial {1 2}] set f3 [::math::polynomials::addPolyn $f2 $f1] set coeffs [::math::polynomials::allCoeffsPolyn $f3] } -result {2 4 3} test "Polynomials-4.3" "Arithmetical operations - subtract (1)" \ -match numbers -body { set f1 [::math::polynomials::polynomial {1 2 3}] set f2 [::math::polynomials::polynomial {1 2}] set f3 [::math::polynomials::subPolyn $f1 $f2] set coeffs [::math::polynomials::allCoeffsPolyn $f3] } -result {0 0 3} test "Polynomials-4.4" "Arithmetical operations - subtract (2)" \ -match numbers -body { set f1 [::math::polynomials::polynomial {1 2 3}] set f2 [::math::polynomials::polynomial {1 2}] set f3 [::math::polynomials::subPolyn $f2 $f1] set coeffs [::math::polynomials::allCoeffsPolyn $f3] } -result {0 0 -3} test "Polynomials-4.5" "Arithmetical operations - multiply (1)" \ -match numbers -body { set f1 [::math::polynomials::polynomial {1 2 3}] set f2 [::math::polynomials::polynomial {1 2}] set f3 [::math::polynomials::multPolyn $f1 $f2] set coeffs [::math::polynomials::allCoeffsPolyn $f3] } -result {1 4 7 6} test "Polynomials-4.6" "Arithmetical operations - multiply (2)" \ -match numbers -body { set f1 [::math::polynomials::polynomial {1 2 3}] set f2 [::math::polynomials::polynomial {1 2}] set f3 [::math::polynomials::multPolyn $f2 $f1] set coeffs [::math::polynomials::allCoeffsPolyn $f3] } -result {1 4 7 6} test "Polynomials-4.7" "Arithmetical operations - multiply (3)" \ -match numbers -body { set f1 [::math::polynomials::polynomial {1 2 3}] set f3 [::math::polynomials::multPolyn $f1 2.0] set coeffs [::math::polynomials::allCoeffsPolyn $f3] } -result {2 4 6} test "Polynomials-4.8" "Arithmetical operations - multiply (4)" \ -match numbers -body { set f1 [::math::polynomials::polynomial {1 2 3}] set f3 [::math::polynomials::multPolyn 2.0 $f1] set coeffs [::math::polynomials::allCoeffsPolyn $f3] } -result {2 4 6} test "Polynomials-4.9" "Arithmetical operations - divide (1)" \ -match numbers -body { set f1 [::math::polynomials::polynomial {1 2 3}] set f2 [::math::polynomials::polynomial {0 1}] set f3 [::math::polynomials::divPolyn $f1 $f2] set coeffs [::math::polynomials::allCoeffsPolyn $f3] } -result {2 3} test "Polynomials-4.10" "Arithmetical operations - divide (2)" \ -match numbers -body { set f1 [::math::polynomials::polynomial {1 2 3}] set f3 [::math::polynomials::divPolyn $f1 2.0] set coeffs [::math::polynomials::allCoeffsPolyn $f3] } -result {0.5 1 1.5} test "Polynomials-4.11" "Arithmetical operations - divide (3)" \ -match numbers -body { set f1 [::math::polynomials::polynomial {1 2 3}] set f2 [::math::polynomials::polynomial {0 1}] set f3 [::math::polynomials::divPolyn $f2 $f1] set coeffs [::math::polynomials::allCoeffsPolyn $f3] } -result {} test "Polynomials-4.12" "Arithmetical operations - divide (4)" \ -match glob -body { set f1 [::math::polynomials::polynomial {1 2 3}] set f2 [::math::polynomials::polynomial {0}] set f3 [::math::polynomials::divPolyn $f1 $f2] set coeffs [::math::polynomials::allCoeffsPolyn $f3] } -result "Denominator*" -returnCodes 1 test "Polynomials-4.13" "Arithmetical operations - remainder (1)" \ -match numbers -body { set f1 [::math::polynomials::polynomial {1 2 3}] set f2 [::math::polynomials::polynomial {0 1}] set f3 [::math::polynomials::remainderPolyn $f1 $f2] set coeffs [::math::polynomials::allCoeffsPolyn $f3] } -result {1} test "Polynomials-4.14" "Arithmetical operations - remainder (2)" \ -match numbers -body { set f1 [::math::polynomials::polynomial {1 2 3}] set f3 [::math::polynomials::remainderPolyn $f1 2.0] set coeffs [::math::polynomials::allCoeffsPolyn $f3] } -result {} test "Polynomials-4.15" "Arithmetical operations - remainder (3)" \ -match numbers -body { set f1 [::math::polynomials::polynomial {1 2 3}] set f2 [::math::polynomials::polynomial {0 1}] set f3 [::math::polynomials::remainderPolyn $f2 $f1] set coeffs [::math::polynomials::allCoeffsPolyn $f3] } -result {0 1} test "Polynomials-4.16" "Arithmetical operations - remainder (4)" \ -match glob -body { set f1 [::math::polynomials::polynomial {1 2 3}] set f2 [::math::polynomials::polynomial {0}] set f3 [::math::polynomials::remainderPolyn $f1 $f2] set coeffs [::math::polynomials::allCoeffsPolyn $f3] } -result "Denominator*" -returnCodes 1 # End of test cases testsuiteCleanup tcllib-1.15/modules/md5crypt/0000755000175000017500000000000012104363635015451 5ustar sergeisergeitcllib-1.15/modules/md5crypt/md5crypt.test0000644000175000017500000001237112077663116020133 0ustar sergeisergei# -*- tcl -*- # md5crypt.test: tests for the md5crypt commands # # This file contains a collection of tests for one or more of the Tcllib # commands. Sourcing this file into Tcl runs the tests and generates # output for errors. No output means no errors were found. # # Copyright (C) 2003 Pat Thoyts # # RCS: @(#) $Id: md5crypt.test,v 1.9 2006/10/09 21:41:41 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.2 testsNeedTcltest 1.0 testing { useLocal md5crypt.tcl md5crypt } # ------------------------------------------------------------------------- # Setup any constraints # Set this true if we have the critcl version. ::tcltest::testConstraint md5crypt_c \ [llength [info command ::md5crypt::md5crypt_c]] # ------------------------------------------------------------------------- if {[llength [info command ::md5crypt::md5crypt_c]]} { puts "> critcl based" set impl critcl } else { puts "> pure Tcl" set impl tcl } # ------------------------------------------------------------------------- # Now the package specific tests.... # ------------------------------------------------------------------------- # A procedure and a C command generate different error messages. test md5crypt-1.0 {md5crypt basic usage} { catch {::md5crypt::md5crypt} result if {$impl == "critcl"} { set expected {wrong # args: should be "::md5crypt::md5crypt_c magic pw salt"} } else { set expected [tcltest::wrongNumArgs {*} {pw salt} 0] } string match $expected $result } 1 test md5crypt-1.1 {md5crypt basic usage} { catch {::md5crypt::md5crypt pw} result if {$impl == "critcl"} { set expected {wrong # args: should be "::md5crypt::md5crypt_c magic pw salt"} } else { set expected [tcltest::wrongNumArgs {*} {pw salt} 1] } string match $expected $result } 1 test md5crypt-1.2 {md5crypt basic usage} { catch {::md5crypt::md5crypt pw salt other} result if {$impl == "critcl"} { set expected {wrong # args: should be "::md5crypt::md5crypt_c magic pw salt"} } else { set expected [tcltest::tooManyArgs {*} {pw salt}] } string match $expected $result } 1 # ------------------------------------------------------------------------- foreach {n salt passwd expected} { 1 {} a {$1$$Ij31LCAysPM23KuPlm1wA/} 2 {a} a {$1$a$44cUw6Nm5bX0muHWNIwub0} 3 {aa} a {$1$aa$aM/8fu5RTEKSCJWsk9qH.0} 4 {aaa} a {$1$aaa$SCk4CXyogLtcfwl2VqfSF0} 5 {aaaa} a {$1$aaaa$tjZedp/Ch2UpwkJdEKLPm.} 6 {aaaaa} a {$1$aaaaa$iVkHUcCwuXWk4NaYTbyUa/} 7 {aaaaaa} a {$1$aaaaaa$MUMWPbGfzrHFCNm7ZHg31.} 8 {aaaaaaa} a {$1$aaaaaaa$4OzJTk7W1gmppy.1Lu4nr.} 9 {aaaaaaaa} a {$1$aaaaaaaa$S270EsVIz5M8Y9/k4SSEf.} 10 {aaaaaaaaa} a {$1$aaaaaaaa$S270EsVIz5M8Y9/k4SSEf.} 12 {a$aaaaaaa} a {$1$a$44cUw6Nm5bX0muHWNIwub0} 13 {$1$a$junk} a {$1$a$44cUw6Nm5bX0muHWNIwub0} } { test md5passwd-2.${n} [list md5crypt salt check \"$salt\"] { ::md5crypt::md5crypt $passwd $salt } $expected # If the C code is loaded, then we have tested that so now check the # pure-tcl implementation as well. test md5passwd-3.${n}_tcl [list md5crypt salt check \"$salt\"] \ {md5crypt_c} { ::md5crypt::md5crypt_tcl {$1$} $passwd $salt } $expected } # ------------------------------------------------------------------------- foreach {n salt passwd expected} [list \ 1 {a} {} {$1$a$8CfZSfErbeskipdhZHtvu.} \ 2 {a} {a} {$1$a$44cUw6Nm5bX0muHWNIwub0} \ 3 {a} [string repeat a 100] {$1$a$vTAcWEblAgdUlX6KBz0NM.} \ 4 {a} [string repeat a 200] {$1$a$kC.K4D6mvUznpkjWJK8Tm0} \ 5 {a} [string repeat a 400] {$1$a$nBvNVTsAryOnHlW7L/gzf/} \ 6 {a} [string repeat a 1000] {$1$a$yhNnTV4IKHbl8oEB/eJaj0} \ ] { test md5passwd-4.${n} {md5crypt check passwd} { ::md5crypt::md5crypt $passwd $salt } $expected # If the C code is loaded, then we have tested that so now check the # pure-tcl implementation as well. test md5passwd-5.${n}_tcl {md5crypt (pure-Tcl) check passwd} {md5crypt_c} { ::md5crypt::md5crypt_tcl {$1$} $passwd $salt } $expected } # ------------------------------------------------------------------------- foreach {n salt passwd expected} [list \ 1 {883.....} {a} {$apr1$883.....$wCU4E7Fv9tHAzFEm5D.mp/} \ 2 {XA3.....} {a} {$apr1$XA3.....$kp5j/oX/OCrpKdKhmUqTu1} \ ] { test md5passwd-6.${n} {aprcrypt check passwd} { ::md5crypt::aprcrypt $passwd $salt } $expected # If the C code is loaded, then we have tested that so now check the # pure-tcl implementation as well. test md5passwd-7.${n}_tcl {aprcrypt (pure-Tcl) check passwd} {md5crypt_c} { ::md5crypt::md5crypt_tcl {$apr1$} $passwd $salt } $expected } # ------------------------------------------------------------------------- testsuiteCleanup # ------------------------------------------------------------------------- # Local variables: # mode: tcl # indent-tabs-mode: nil # End:tcllib-1.15/modules/md5crypt/md5crypt.tcl0000644000175000017500000001124412077663116017734 0ustar sergeisergei# md5crypt.tcl - Copyright (C) 2003 Pat Thoyts # # This file provides a pure tcl implementation of the BSD MD5 crypt algorithm. # The implementation is based upon the OpenBSD code which is in turn based upon # the original code by Poul-Henning Kamp. # # ------------------------------------------------------------------------- # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ------------------------------------------------------------------------- # @mdgen EXCLUDE: md5cryptc.tcl package require Tcl 8.2; # tcl minimum version package require md5 2; # tcllib 1.5 # Try and load a compiled extension to help. if {[catch {package require tcllibc}]} { catch {package require md5cryptc} } namespace eval md5crypt { variable version 1.1.0 variable rcsid {$Id: md5crypt.tcl,v 1.5 2008/01/26 23:56:26 patthoyts Exp $} variable itoa64 \ {./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz} namespace import -force ::md5::MD5Init ::md5::MD5Update ::md5::MD5Final namespace export md5crypt } proc ::md5crypt::to64_tcl {v n} { variable itoa64 for {} {$n > 0} {incr n -1} { set i [expr {$v & 0x3f}] append s [string index $itoa64 $i] set v [expr {($v >> 6) & 0x3FFFFFFF}] } return $s } # ::md5crypt::salt -- # Generate a salt string suitable for use with the md5crypt command. proc ::md5crypt::salt {{len 8}} { variable itoa64 set salt "" for {set n 0} {$n < $len} {incr n} { append salt [string index $itoa64 [expr {int(rand() * 64)}]] } return $salt } proc ::md5crypt::md5crypt_tcl {magic pw salt} { set sp 0 set start 0 if {[string match "${magic}*" $salt]} { set start [string length $magic] } set end [string first $ $salt $start] if {$end < 0} {set end [string length $salt]} else {incr end -1} if {$end - $start > 7} {set end [expr {$start + 7}]} set salt [string range $salt $start $end] set ctx [MD5Init] MD5Update $ctx $pw MD5Update $ctx $magic MD5Update $ctx $salt set ctx2 [MD5Init] MD5Update $ctx2 $pw MD5Update $ctx2 $salt MD5Update $ctx2 $pw set H2 [MD5Final $ctx2] for {set pl [string length $pw]} {$pl > 0} {incr pl -16} { set tl [expr {($pl > 16 ? 16 : $pl) - 1}] MD5Update $ctx [string range $H2 0 $tl] } for {set i [string length $pw]} {$i != 0} {set i [expr {$i >> 1}]} { if {$i & 1} { set c \0 } else { set c [string index $pw 0] } MD5Update $ctx $c } set result "${magic}${salt}\$" set H [MD5Final $ctx] for {set i 0} {$i < 1000} {incr i} { set ctx [MD5Init] if {$i & 1} { MD5Update $ctx $pw } else { MD5Update $ctx $H } if {$i % 3} { MD5Update $ctx $salt } if {$i % 7} { MD5Update $ctx $pw } if {$i & 1} { MD5Update $ctx $H } else { MD5Update $ctx $pw } set H [MD5Final $ctx] } binary scan $H c* Vs foreach v $Vs {lappend V [expr {$v & 0xFF}]} set l [expr {([lindex $V 0] << 16) | ([lindex $V 6] << 8) | [lindex $V 12]}] append result [to64 $l 4] set l [expr {([lindex $V 1] << 16) | ([lindex $V 7] << 8) | [lindex $V 13]}] append result [to64 $l 4] set l [expr {([lindex $V 2] << 16) | ([lindex $V 8] << 8) | [lindex $V 14]}] append result [to64 $l 4] set l [expr {([lindex $V 3] << 16) | ([lindex $V 9] << 8) | [lindex $V 15]}] append result [to64 $l 4] set l [expr {([lindex $V 4] << 16) | ([lindex $V 10] << 8) | [lindex $V 5]}] append result [to64 $l 4] set l [expr {[lindex $V 11]}] append result [to64 $l 2] return $result } if {[info commands ::md5crypt::to64_c] == {}} { interp alias {} ::md5crypt::to64 {} ::md5crypt::to64_tcl } else { interp alias {} ::md5crypt::to64 {} ::md5crypt::to64_c } if {[info commands ::md5crypt::md5crypt_c] == {}} { interp alias {} ::md5crypt::md5crypt {} ::md5crypt::md5crypt_tcl {$1$} interp alias {} ::md5crypt::aprcrypt {} ::md5crypt::md5crypt_tcl {$apr1$} } else { interp alias {} ::md5crypt::md5crypt {} ::md5crypt::md5crypt_c {$1$} interp alias {} ::md5crypt::aprcrypt {} ::md5crypt::md5crypt_c {$apr1$} } # ------------------------------------------------------------------------- package provide md5crypt $::md5crypt::version # ------------------------------------------------------------------------- # Local Variables: # mode: tcl # indent-tabs-mode: nil # End: tcllib-1.15/modules/md5crypt/md5crypt.bench0000644000175000017500000000235412077663116020233 0ustar sergeisergei# -*- tcl -*- # Tcl Benchmark File # # This file contains a number of benchmarks for the 'md5' module. # This allow developers to monitor/gauge/track package performance. # # (c) 2005 Andreas Kupries # We need at least version 8.2 for the package and thus the # benchmarks. if {![package vsatisfies [package provide Tcl] 8.2]} { return } # ### ### ### ######### ######### ######### ########################### ## Setting up the environment ... set moddir [file dirname [file dirname [info script]]] lappend auto_path $moddir package forget md5 catch {namespace delete ::md5} source [file join [file dirname [file dirname [info script]]] md5 md5x.tcl] package forget md5crypt catch {namespace delete ::md5crypt} source [file join [file dirname [info script]] md5crypt.tcl] set key aaaaaaaaa # ### ### ### ######### ######### ######### ########################### ## Benchmarks. foreach n {1 10 100 1000 10000} { # Extremely expensive. Limit #iterations to keep total runtime acceptable. bench -desc "MD5Crypt $n" -pre { set str [string repeat " " $n] } -body { md5crypt::md5crypt $key $str } -iters 10 } # ### ### ### ######### ######### ######### ########################### ## Complete tcllib-1.15/modules/md5crypt/ChangeLog0000644000175000017500000000711512104363437017227 0ustar sergeisergei2013-02-01 Andreas Kupries * * Released and tagged Tcllib 1.15 ======================== * 2011-12-13 Andreas Kupries * * Released and tagged Tcllib 1.14 ======================== * 2011-01-24 Andreas Kupries * * Released and tagged Tcllib 1.13 ======================== * 2009-12-07 Andreas Kupries * * Released and tagged Tcllib 1.12 ======================== * 2009-05-07 Pat Thoyts * md5cryptc.tcl: Fixed poor idiom setting interp result. 2008-12-12 Andreas Kupries * * Released and tagged Tcllib 1.11.1 ======================== * 2008-10-16 Andreas Kupries * * Released and tagged Tcllib 1.11 ======================== * 2008-01-26 Pat Thoyts * md5crypt.tcl: Implemented FR #1824212 from Aaron Faupell to * md5crypt.man: provide a salt command for use when generating * pkgIndex.tcl: passwords. 2007-09-12 Andreas Kupries * * Released and tagged Tcllib 1.10 ======================== * 2007-03-21 Andreas Kupries * md5crypt.man: Fixed all warnings due to use of now deprecated commands. Added a section about how to give feedback. 2006-10-03 Andreas Kupries * * Released and tagged Tcllib 1.9 ======================== * 2006-09-16 Andreas Kupries * md5crypt.test: The critcl implementation of md5crypt generates different error messages when called with the wrong number of arguments. Updated the tests to take this into account. 2006-01-23 Andreas Kupries * md5crypt.test: More boilerplate simplified via use of test support. 2006-01-19 Andreas Kupries * md5crypt.test: Hooked into the new common test support code. 2005-10-24 Andreas Kupries * md5crypt.bench: New file. Basic benchmarks for MD5 password hashes. 2005-10-06 Andreas Kupries * * Released and tagged Tcllib 1.8 ======================== * 2005-10-05 Pat Thoyts * md5cryptc.tcl: Fix for building with msvc. 2004-10-05 Andreas Kupries * * Released and tagged Tcllib 1.7 ======================== * 2004-05-23 Andreas Kupries * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * 2004-02-12 Andreas Kupries * md5crypt.test: Testsuite fixed. Had to account that error messages can dependent on the version of the Tcl core. 2003-07-26 Pat Thoyts * md5crypt.tcl: Provided implementation of the Apache * md5cryptc.tcl: variation of md5crypt - as used in the * md5crypt.test: Apache2 htpasswd program. * md5crypt.man: Added a manual page. 2003-07-26 Pat Thoyts * md5crypt.tcl: Initial version of a pure-Tcl and * md5crypt.test: critcl-enhanced implementation of * md5cryptc.tcl: the BSD MD5-crypt algorithm. * pkgIndex.tcl: * ChangeLog: tcllib-1.15/modules/md5crypt/md5crypt.man0000644000175000017500000000536012077663116017727 0ustar sergeisergei[manpage_begin md5crypt n 1.1.0] [moddesc {MD5-based password encryption}] [copyright {2003, Pat Thoyts }] [titledesc {MD5-based password encryption}] [category {Hashes, checksums, and encryption}] [require Tcl 8.2] [require md5 2.0] [require md5crypt [opt 1.1.0]] [description] [para] This package provides an implementation of the MD5-crypt password encryption algorithm as pioneered by FreeBSD and currently in use as a replacement for the unix crypt(3) function in many modern systems. An implementation of the closely related Apache MD5-crypt is also available. The output of these commands are compatible with the BSD and OpenSSL implementation of md5crypt and the Apache 2 htpasswd program. [section {COMMANDS}] [list_begin definitions] [call [cmd "::md5crypt::md5crypt"] \ [arg "password"] \ [arg "salt"]] Generate a BSD compatible md5-encoded password hash from the plaintext password and a random salt (see SALT). [call [cmd "::md5crypt::aprcrypt"] \ [arg "password"] \ [arg "salt"]] Generate an Apache compatible md5-encoded password hash from the plaintext password and a random salt (see SALT). [call [cmd "::md5crypt::salt"] [opt [arg "length"]]] Generate a random salt string suitable for use with the [cmd md5crypt] and [cmd aprcrypt] commands. [list_end] [section {SALT}] The salt passed to either of the encryption schemes implemented here is checked to see if it begins with the encryption scheme magic string (either "$1$" for MD5-crypt or "$apr1$" for Apache crypt). If so, this is removed. The remaining characters up to the next $ and up to a maximum of 8 characters are then used as the salt. The salt text should probably be restricted the set of ASCII alphanumeric characters plus "./" (dot and forward-slash) - this is to preserve maximum compatability with the unix password file format. [para] If a password is being generated rather than checked from a password file then the [cmd salt] command may be used to generate a random salt. [section {EXAMPLES}] [example { % md5crypt::md5crypt password 01234567 $1$01234567$b5lh2mHyD2PdJjFfALlEz1 }] [example { % md5crypt::aprcrypt password 01234567 $apr1$01234567$IXBaQywhAhc0d75ZbaSDp/ }] [example { % md5crypt::md5crypt password [md5crypt::salt] $1$dFmvyRmO$T.V3OmzqeEf3hqJp2WFcb. }] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph md5crypt] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [see_also md5] [keywords md5crypt md5 hashing message-digest security] [manpage_end] tcllib-1.15/modules/md5crypt/pkgIndex.tcl0000644000175000017500000000024712077663116017737 0ustar sergeisergei# package index for md5crypt if {![package vsatisfies [package provide Tcl] 8.2]} {return} package ifneeded md5crypt 1.1.0 [list source [file join $dir md5crypt.tcl]] tcllib-1.15/modules/md5crypt/md5cryptc.tcl0000644000175000017500000001441312077663116020100 0ustar sergeisergei# md5cryptc.tcl - Copyright (C) 2003 Pat Thoyts # # This is a critcl-based wrapper to provide a Tcl implementation of the md5crypt # function. The C code here is based upon the OpenBSD source, which is in turn # derived from the original implementation by Poul-Henning Kamp # # The original C source license reads: #/* # * ---------------------------------------------------------------------------- # * "THE BEER-WARE LICENSE" (Revision 42): # * wrote this file. As long as you retain this notice you # * can do whatever you want with this stuff. If we meet some day, and you think # * this stuff is worth it, you can buy me a beer in return. Poul-Henning Kamp # * ---------------------------------------------------------------------------- # */ # # ------------------------------------------------------------------------- # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ------------------------------------------------------------------------- package require critcl # @sak notprovided md5cryptc package provide md5cryptc 1.0 critcl::cheaders ../md5/md5.h #critcl::csources ../md5/md5.c namespace eval ::md5crypt { critcl::ccode { #include "md5.h" #ifdef _MSC_VER #define snprintf _snprintf #endif static unsigned char itoa64[] = "./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"; static void to64(char *s, unsigned int v, int n) { while (--n >= 0) { *s++ = itoa64[v&0x3f]; v >>= 6; } } static void dump(const char *s, unsigned int len) { unsigned int i; for (i = 0; i < len; i++) printf("%02X", s[i]&0xFF); putchar('\n'); } static char * md5crypt(const char *pw, const char *salt, const char *magic) { static char passwd[120], *p; static const unsigned char *sp,*ep; unsigned char final[16]; int sl,pl,i; MD5_CTX ctx,ctx1; unsigned long l; /* Refine the Salt first */ sp = (const unsigned char *)salt; /* If it starts with the magic string, then skip that */ if(!strncmp((const char *)sp,(const char *)magic,strlen((const char *)magic))) sp += strlen((const char *)magic); /* It stops at the first '$', max 8 chars */ for(ep=sp;*ep && *ep != '$' && ep < (sp+8);ep++) continue; /* get the length of the true salt */ sl = ep - sp; MD5Init(&ctx); /* The password first, since that is what is most unknown */ MD5Update(&ctx,(const unsigned char *)pw,strlen(pw)); /* Then our magic string */ MD5Update(&ctx,magic,strlen((const char *)magic)); /* Then the raw salt */ MD5Update(&ctx,sp,sl); /* Then just as many characters of the MD5(pw,salt,pw) */ MD5Init(&ctx1); MD5Update(&ctx1,(const unsigned char *)pw,strlen(pw)); MD5Update(&ctx1,sp,sl); MD5Update(&ctx1,(const unsigned char *)pw,strlen(pw)); MD5Final(final,&ctx1); for(pl = strlen(pw); pl > 0; pl -= 16) { int tl = pl > 16 ? 16 : pl; MD5Update(&ctx,final,pl>16 ? 16 : pl); } /* Don't leave anything around in vm they could use. */ memset(final,0,sizeof final); /* Then something really weird... */ for (i = strlen(pw); i ; i >>= 1) { if(i&1) MD5Update(&ctx, final, 1); else MD5Update(&ctx, (const unsigned char *)pw, 1); } /* Now make the output string */ snprintf(passwd, sizeof(passwd), "%s%.*s$", (char *)magic, sl, (const char *)sp); MD5Final(final,&ctx); /* * and now, just to make sure things don't run too fast * On a 60 Mhz Pentium this takes 34 msec, so you would * need 30 seconds to build a 1000 entry dictionary... */ for(i=0;i<1000;i++) { MD5Init(&ctx1); if(i & 1) MD5Update(&ctx1,(const unsigned char *)pw,strlen(pw)); else MD5Update(&ctx1,final,16); if(i % 3) MD5Update(&ctx1,sp,sl); if(i % 7) MD5Update(&ctx1,pw,strlen(pw)); if(i & 1) MD5Update(&ctx1,final,16); else MD5Update(&ctx1,pw,strlen(pw)); MD5Final(final,&ctx1); } p = passwd + strlen(passwd); l = (final[ 0]<<16) | (final[ 6]<<8) | final[12]; to64(p,l,4); p += 4; l = (final[ 1]<<16) | (final[ 7]<<8) | final[13]; to64(p,l,4); p += 4; l = (final[ 2]<<16) | (final[ 8]<<8) | final[14]; to64(p,l,4); p += 4; l = (final[ 3]<<16) | (final[ 9]<<8) | final[15]; to64(p,l,4); p += 4; l = (final[ 4]<<16) | (final[10]<<8) | final[ 5]; to64(p,l,4); p += 4; l = final[11] ; to64(p,l,2); p += 2; *p = '\0'; /* Don't leave anything around in vm they could use. */ memset(final,0,sizeof final); return passwd; } } critcl::cproc to64_c {Tcl_Interp* interp int v int n} ok { char s[5]; to64(s, (unsigned int)v, n); Tcl_SetObjResult(interp, Tcl_NewStringObj(s, n)); return TCL_OK; } critcl::cproc md5crypt_c {Tcl_Interp* interp char* magic char* pw char* salt} ok { char* s = md5crypt(pw, salt, magic); Tcl_SetObjResult(interp, Tcl_NewStringObj(s, strlen(s))); return TCL_OK; } } tcllib-1.15/modules/bench/0000755000175000017500000000000012104363635014761 5ustar sergeisergeitcllib-1.15/modules/bench/bench_read.tcl0000644000175000017500000000764112077663115017554 0ustar sergeisergei# bench_read.tcl -- # # Management of benchmarks, reading results in various formats. # # Copyright (c) 2005 by Andreas Kupries # library derived from runbench.tcl application (C) Jeff Hobbs. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: bench_read.tcl,v 1.3 2006/06/13 23:20:30 andreas_kupries Exp $ # ### ### ### ######### ######### ######### ########################### ## Requisites - Packages and namespace for the commands and data. package require Tcl 8.2 package require csv namespace eval ::bench::in {} # ### ### ### ######### ######### ######### ########################### ## Public API - Result reading # ::bench::in::read -- # # Read a bench result in any of the raw/csv/text formats # # Arguments: # path to file to read # # Results: # DATA dictionary, internal representation of the bench results. proc ::bench::in::read {file} { set f [open $file r] set head [gets $f] if {![string match "# -\\*- tcl -\\*- bench/*" $head]} { return -code error "Bad file format, not a benchmark file" } else { regexp {bench/(.*)$} $head -> format switch -exact -- $format { raw - csv - text { set res [RD$format $f] } default { return -code error "Bad format \"$val\", expected text, csv, or raw" } } } close $f return $res } # ### ### ### ######### ######### ######### ########################### ## Internal commands proc ::bench::in::RDraw {chan} { return [string trimright [::read $chan]] } proc ::bench::in::RDcsv {chan} { # Lines Format # First line is number of interpreters #n. int # Next to 1+n is interpreter data. id,ver,path # Beyond is benchmark results. id,desc,res1,...,res#n array set DATA {} # #Interp ... set nip [lindex [csv::split [gets $chan]] 0] # Interp data ... set iplist {} for {set i 0} {$i < $nip} {incr i} { foreach {__ ver ip} [csv::split [gets $chan]] break set DATA([list interp $ip]) $ver lappend iplist $ip } # Benchmark data ... while {[gets $chan line] >= 0} { set line [string trim $line] if {$line == {}} break set line [csv::split $line] set desc [lindex $line 1] set DATA([list desc $desc]) {} foreach val [lrange $line 2 end] ip $iplist { if {$val == {}} continue set DATA([list usec $desc $ip]) $val } } return [array get DATA] } proc ::bench::in::RDtext {chan} { array set DATA {} # Interp data ... # Empty line - ignore # "id: ver path" - interp data. # Empty line - separator before benchmark data. set n 0 set iplist {} while {[gets $chan line] >= 0} { set line [string trim $line] if {$line == {}} { incr n if {$n == 2} break continue } regexp {[^:]+: ([^ ]+) (.*)$} $line -> ver ip set DATA([list interp $ip]) $ver lappend iplist $ip } # Benchmark data ... # '---' -> Ignore. # '|' column separators. Remove spaces around it. Then treat line # as CSV data with a particular separator. # Ignore the INTERP line. while {[gets $chan line] >= 0} { set line [string trim $line] if {$line == {}} continue if {[string match "+---*" $line]} continue if {[string match "*INTERP*" $line]} continue regsub -all "\\| +" $line {|} line regsub -all " +\\|" $line {|} line set line [csv::split [string trim $line |] |] set desc [lindex $line 1] set DATA([list desc $desc]) {} foreach val [lrange $line 2 end] ip $iplist { if {$val == {}} continue set DATA([list usec $desc $ip]) $val } } return [array get DATA] } # ### ### ### ######### ######### ######### ########################### ## Initialize internal data structures. # ### ### ### ######### ######### ######### ########################### ## Ready to run package provide bench::in 0.1 tcllib-1.15/modules/bench/bench_wtext.tcl0000644000175000017500000000725312077663115020013 0ustar sergeisergei# bench_wtext.tcl -- # # Management of benchmarks, formatted text. # # Copyright (c) 2005 by Andreas Kupries # library derived from runbench.tcl application (C) Jeff Hobbs. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: bench_wtext.tcl,v 1.4 2007/01/21 23:29:06 andreas_kupries Exp $ # ### ### ### ######### ######### ######### ########################### ## Requisites - Packages and namespace for the commands and data. package require Tcl 8.2 package require struct::matrix package require report namespace eval ::bench::out {} # ### ### ### ######### ######### ######### ########################### ## Public API - Result formatting. # ::bench::out::text -- # # Format the result of a benchmark run. # Style: TEXT # # General structure like CSV, but nicely formatted and aligned # columns. # # Arguments: # DATA dict # # Results: # String containing the formatted DATA. proc ::bench::out::text {data} { array set DATA $data set LINES {} # 1st line to #shells: Interpreter data (id, version, path) # #shells+1 to end: Benchmark data (id,desc,result1,...,result#shells) lappend LINES {} # --- --- ---- # Table 1: Interpreter information. set ipkeys [array names DATA interp*] set n 1 set iplist {} set vlen 0 foreach key [lsort -dict $ipkeys] { lappend iplist [lindex $key 1] incr n set l [string length $DATA($key)] if {$l > $vlen} {set vlen $l} } set idlen [string length $n] set dlist {} set n 1 foreach key [lsort -dict -index 1 [array names DATA desc*]] { lappend dlist [lindex $key 1] incr n } set didlen [string length $n] set n 1 set record [list "" INTERP] foreach ip $iplist { set v $DATA([list interp $ip]) lappend LINES " [PADL $idlen $n]: [PADR $vlen $v] $ip" lappend record $n incr n } lappend LINES {} # --- --- ---- # Table 2: Benchmark information set m [struct::matrix m] $m add columns [expr {2 + [llength $iplist]}] $m add row $record set n 1 foreach desc $dlist { set record [list $n] lappend record $desc foreach ip $iplist { if {[catch { set val $DATA([list usec $desc $ip]) }]} { set val {} } if {[string is double -strict $val]} { lappend record [format %.2f $val] } else { lappend record [format %s $val] } } $m add row $record incr n } ::report::defstyle simpletable {} { data set [split "[string repeat "| " [columns]]|"] top set [split "[string repeat "+ - " [columns]]+"] bottom set [top get] top enable bottom enable set c [columns] justify 0 right pad 0 both if {$c > 1} { justify 1 left pad 1 both } for {set i 2} {$i < $c} {incr i} { justify $i right pad $i both } } ::report::defstyle captionedtable {{n 1}} { simpletable topdata set [data get] topcapsep set [top get] topcapsep enable tcaption $n } set r [report::report r [$m columns] style captionedtable] lappend LINES [$m format 2string $r] $m destroy $r destroy return [join $LINES \n] } # ### ### ### ######### ######### ######### ########################### ## Internal commands proc ::bench::out::PADL {max str} { format "%${max}s" $str #return "[PAD $max $str]$str" } proc ::bench::out::PADR {max str} { format "%-${max}s" $str #return "$str[PAD $max $str]" } # ### ### ### ######### ######### ######### ########################### ## Initialize internal data structures. # ### ### ### ######### ######### ######### ########################### ## Ready to run package provide bench::out::text 0.1.2 tcllib-1.15/modules/bench/bench_read.man0000644000175000017500000000367312077663115017546 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin bench::in n 0.1] [copyright {2007 Andreas Kupries }] [moddesc {Benchmarking/Performance tools}] [titledesc {bench::in - Reading benchmark results}] [category {Benchmark tools}] [require Tcl 8.2] [require csv] [require bench::in [opt 0.1]] [description] This package provides a command for reading benchmark results from files, sockets, etc. [para] A reader interested in the creation, processing or writing of such results should go and read [term {bench - Processing benchmark suites}] instead. [para] If the bench language itself is the actual interest please start with the [term {bench language introduction}] and then proceed from there to the formal [term {bench language specification}]. [para] [section {PUBLIC API}] [list_begin definitions] [call [cmd ::bench::in::read] [arg file]] This command reads a benchmark result from the specified [arg file] and returns it as its result. The command understands the three formats created by the commands [list_begin commands] [cmd_def bench::out::raw] Provided by package [package bench]. [cmd_def bench::out::csv] Provided by package [package bench::out::csv]. [cmd_def bench::out::text] Provided by package [package bench::out::text]. [list_end] [para] and automatically detects which format is used by the input file. [list_end] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph bench] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [see_also bench_intro] [see_also bench] [see_also bench::out::csv] [see_also bench::out::text] [keywords testing performance benchmark formatting csv text {human readable}] [keywords reading parsing] [manpage_end] tcllib-1.15/modules/bench/ChangeLog0000644000175000017500000004250712104363437016543 0ustar sergeisergei2013-02-01 Andreas Kupries * * Released and tagged Tcllib 1.15 ======================== * 2011-12-13 Andreas Kupries * * Released and tagged Tcllib 1.14 ======================== * 2011-01-24 Andreas Kupries * * Released and tagged Tcllib 1.13 ======================== * 2009-12-07 Andreas Kupries * * Released and tagged Tcllib 1.12 ======================== * 2008-12-12 Andreas Kupries * * Released and tagged Tcllib 1.11.1 ======================== * 2008-10-16 Andreas Kupries * * Released and tagged Tcllib 1.11 ======================== * 2008-10-07 Andreas Kupries * bench.tcl: Bumped to version 0.4 for 2008-06-30 commit by * bench.man: myself. Was a major rewrite of the internals, * pkgIndex.tcl: should have been bumped then. 2008-06-30 Andreas Kupries * bench.tcl (::bench::Invoke): Reworked the protocol between * libbench.tcl: manager and execution system to allow for incremental returning of results and proper progress feedback. This enables users to see how a benchmark progresses, and to provide their own notes about conditions and decisions as well. 2007-09-12 Andreas Kupries * * Released and tagged Tcllib 1.10 ======================== * 2007-08-23 Andreas Kupries * bench.tcl: Fixed problem with the glob patterns used to query * bench.man: the data array, was not matching the list quoting * pkgIndex.tcl: used to generate the keys. Was fine while we had no keys with spaces in the interp reference, but with -pkgdir this is possible, and broke. Version bumped to 0.3.1. Reported by Rolf Ade. 2007-08-21 Andreas Kupries * bench.tcl (::bench::run): Extended with a new option -pkgdir * bench.man: helping in the handling of multiple versions of a * pkgIndex.tcl: package to benchmark, as suggested and first * libbench.tcl: implemented by Rolf Ade. Moved invokation of libbench to a separate helper procedure. Extended the documentation. Version bumped to 0.3. 2007-04-10 Andreas Kupries * bench_lang_intro.man: New files, documentation of the * bench_lang_spec.man: benchmark declaration language, and * bench_read.man: of the supporting packages. * bench_wcsv.man: * bench_wtext.man: 2007-01-22 Andreas Kupries * libbench.tcl: Added new benchmark options -ipre, -ipost. Per * pkgIndex.tcl: iteration pre/post scripts, untimed. Version of * bench.cl: package 'bench' is now 0.2. 2007-01-21 Andreas Kupries * bench_wcsv.tcl: Fixed sorting of descriptions in text and * bench_wtext.tcl: csv output. Version is now 0.1.2. 2007-01-18 Andreas Kupries * bench.tcl (bench::norm): Removed 'split ,' from code, was left * pkgIndex.tcl: in wrongly after the rewrite of the raw representation. The relevant key is a list which we can and have to use directly, no split required. The fixed bug caused the normalization to fail and return the empty string for all cells. Version number bumped to 0.1.1 for this. 2006-10-03 Andreas Kupries * * Released and tagged Tcllib 1.9 ======================== * 2006-06-13 Andreas Kupries * bench_read.tcl: Rewrite the internal raw representation, use * bench.tcl: lists as array keys, easier to handle, no * bench_wcsv.tcl: splitting, and quoting is done automatically * bench_wtext.tcl: by Tcl itself. See [Tcllib SF Bug 1414159]. 2006-05-27 Andreas Kupries * bench_read.tcl: Fixed typo "-error" --> "-code error". 2006-01-25 Michael Schlenker * bench_wcsv.tcl : Fixed bug when trying to format benchs on windows. * bench_wtext.tcl: The interpreter path was truncated due to a misuse of split and lindex, where string first was appropriate. 2005-10-27 Andreas Kupries * bench.tcl (::bench::norm): Fixed bug leaving time data in non-reference column when the reference is empty. To the unwary the result looks like factors, which have ridiculous values. Now the row is shown, but empty. 2005-10-21 Andreas Kupries * bench.tcl (::bench::del): New command. Removal of a column from benchmark data. 2005-10-18 Andreas Kupries * bench_read.tcl: New file. Command and package to read benchmark data in the text, csv, or raw formats. * bench.tcl (::bench::edit): New command. Changes specified interpreter path to user specified value. Needed if we wish to merge data coming from the same interpreter, for different revisions of the package under test. 2005-10-17 Andreas Kupries * Package derived from the original code added to Tcllib. 2004-12-29 Jeff Hobbs * tcl/parse.bench: ensure file size is consistent between interp runs with formatted BOUND string. 2004-12-27 Jeff Hobbs * doc/runbench.1: fix doc for -throwerrors [Bug 1091766] * runbench.tcl (getInterps): use exec << instead of echo [Bug 1091764] 2004-12-24 Miguel Sofer * tcl/namespace.bench: new benchmark, measures the cost of calling the same global command alternating different namespaces. 2004-12-20 Jeff Hobbs * tcl/array.bench (new): array hash benchmarks * tcl/file.bench: fix checkall to operate for tclsh <=8.0 * tcl/string.bench: fix string match -nocase for tclsh <=8.2 * runbench.tcl (convertVersion): add -globtclsh -globwish file path glob opts (tclsh* and wish* by default). Normalize soft-links. * normbench.tcl (normalize-text): harden time norm check 2003-08-06 Jeff Hobbs * normbench.tcl (normalize): correct normalization of new-style stats where TclX data is present in output. 2003-02-11 Jeff Hobbs * tcl/list.bench: lsearch -regexp benchmarks * tcl/file.bench: updated with more benchmarks 2003-02-08 Jeff Hobbs * tcl/startup.bench: replaced by file benchmarks * tcl/file.bench: file benchmarks 2002-11-13 Jeff Hobbs * tcl/regexp.bench: added anchored re tests * tcl/klist.bench: allow method filter from command lineinvocation. * tcl/list.bench: add lset benchmarks * tcl/md5.bench: correct to work with pre-8.2 interps * tcl/string.bench: add string growth, remove split benchmarks * tcl/split.bench: more split benchmarks * runbench.tcl: allow tclsh*/wish* (no version required) 2002-07-24 Miguel Sofer * tcl/base64.bench: added the current code from tcllib. 2002-06-20 Miguel Sofer * tcl/read.bench: modified to actually "use" the data being read by setting a local variable. 2002-06-20 Miguel Sofer * tcl/md5.bench: added the faster implementation from tcllib 2002-06-12 Jeff Hobbs * tcl/catch.bench: corrected use of string map in toplevel code * tcl/expr.bench: corrected use of string repeat in toplevel code * tcl/sha1.bench: correct wideint problem for 8.4 in sha1DF * tcl/string.bench: corrected string equality checks to use different variables (objects) * tcl/gccont.bench: new benchmark that does some bioinformatics manipulation on dna sequences 2002-06-12 Miguel Sofer * tcl/klist.bench: * tcl/heapsort.bench: added algorithms using [lset] 2002-06-11 Miguel Sofer * tcl/regexp.bench: made the bench access the match variables, to benchmark also the read access to them. * tcl/vars.bench: added a "VAR ref local" benchmark, to be able to compare the access times of linked variables to those of local variables. 2002-05-29 Jeff Hobbs * tcl/parse.bench: more complex string parsing benchmark (8.0+) * tcl/encoding.bench: start of some encoding benchmarks (8.1+) * tcl/expr.bench: added ==/!= expr benchmarks * tcl/string.bench: corrected the equality benchmarks to not use the same object unless specified. 2002-04-25 Jeff Hobbs * runbench.tcl: * libbench.tcl: added ability to set # threads to use if Thread package can be loaded. improved -result error checking * tcl/base64.bench: verify result of encode/decode * tcl/proc.bench: added empty proc benchmarks * tcl/list.bench: added LIST concat benchmarks (hartweg) 2002-03-27 Miguel Sofer * tcl/catch.bench: modified the catch benchmarks to allow comparison with catching non-error exceptions; added new "CATCH except" benchmark. 2002-03-15 Miguel Sofer * tcl/catch.bench: added benchmark for catch in a body with many nested exception ranges. 2002-02-22 Jeff Hobbs * tcl/loops.bench: added while 1 benchmark * tcl/conditional.bench: added if 1/0 benchmark 2002-02-07 Jeff Hobbs * runbench.tcl: noted thread option. * libbench.tcl: added ability to check result of test * tcl/base64.bench: stripped arg stuff out of code to make it work in 8.0 as well. * tcl/list.bench: corrected list-2.11 to append to simple var. * tcl/map.bench: added http mapReply & simple regsubs benchmarks * tcl/read.bench: commented out new changing buffersize benchmarks as they do weird things to various interp versions. * tcl/regexp.bench: added static regexp benchmarks * tcl/string.bench: added string first utf benchmarks * tcl/vars.bench: corrected namespace usage for pre-8 interps. 2001-09-25 Jeff Hobbs * tcl/string.bench: added exact string match benchmark and fixed other string match benchmarks * tcl/list.bench: added simple list benchmark * tcl/vars.bench: added mset benchmarks * libbench.tcl: * runbench.tcl: added support for -threads option to try and load a thread package and run separate benchmark files simultaneously. 2001-08-29 Jeff Hobbs * tcl/methods.bench: * tcl/vars.bench: added some more benchmarks 2001-07-18 Andreas Kupries * tcl/read.bench: new "read" benchmarks detailing the effect of the buffersize on IO performance. Created to check out the performance patch associated with SF item #427196. 2001-06-19 Jeff Hobbs * tcl/binary.bench: new "binary" benchmarks * tcl/string.bench: more random split benchmarks 2001-06-03 Jeff Hobbs * libbench.tcl: * runbench.tcl: reduced default iterations to 1000 (still quite sufficient to remove random noise). 2001-05-31 Jeff Hobbs * tcl/conditional.bench: added switch/if comparison bench. * tcl/base64.bench: new benchmark with base64 code (from tcllib). * tcl/md5.bench: new benchmark with Libes' md5 (from tcllib). * tcl/sha1.bench: new benchmark with a couple of pure tcl sha1 routines (Libes and Fellows). 2001-05-29 Andreas Kupries * doc/libbench.n: * doc/runbench.1: * doc/normbench.1: Added documentation of benchmark library and applications. * doc: Added documentation directory. 2001-05-22 Jeff Hobbs * runbench.tcl: corrected error for reporting errors in sourced files * tcl/fcopy.bench: made use of bench_tmpfile for more accurate data (not skewed by network). * libbench.tcl (bench_tmpfile): correctly allow multiple calls to bench_tmpfile within one file. * normbench.tcl: new file that allows for post-process normalization of the benchmark data. Corrected last minute code checkin bug. Added support for moving left (to higher versions) to normalize when the requested version returned non-double data. * tcl/libbench.tcl: * tcl/runbench.tcl: changed -iterations to be a maximum number for timings, to override any larger number the benchmark may set for itself. Rearranged result format of benchmarks to return data by benchmark description. Benchmarks are now always returned in alphabetical order of the benchmark description. Changed benchmarks to rerun the interpreter per benchmark file instead of sourcing all files into the same interpreter. This reduces any skew related to excessive mem usage or other factors that may arise for one benchmark file. Changed midpoint numbers to time elapsed calculation. Added -normalize option that post-processes the time information to normalize against one version as a baseline. Changed -errors to -throwerrors with no arg, and changed the default to not throw errors in benchmark files. Added version string to verbose run info. * tcl/klist.bench: added support for <8.0 to all benchmarks except shuffle0, with notably reduced default run iters due to extreme slowness of <8.0 interps for these tasks. * tcl/string.bench: * tcl/regexp.bench: fixed incorrect str-repeat replacement function 2001-05-18 Jeff Hobbs * tcl/string.bench: added <8.0 compatible rev-recursive benchmark, fixed non-octal escape in ustring instantiation. * tcl/wordcount.bench: added <8.1 compatible benchmarks * tcl/methods.bench: return for interps <8.0 2001-05-19 Andreas Kupries * tcl/conditional.bench: Changed some descriptions to make them unique and matching to the code. * tcl/fcopy.bench: New benchmarks for the [fcopy] command (unsupported0 in older versions of the core). 2001-05-16 Jeff Hobbs * tcl/string.bench: added static string length benchmarks * tcl/wordcount.in: * tcl/wordcount.bench: wordcount benchmarks * tcl/heapsort.bench: new file with heapsort benchmark * tcl/string.bench: * tcl/matrix.bench: * tcl/regexp.bench: extended benchmarks 2001-05-11 Jeff Hobbs * tcl/string.bench: clarified string reverse benchmarks, added more to the string compare benchmarks. * tcl/matrix.bench: some new matrix benchmarks. Basically a seed file looking for more. procs courtesy Sofer. * tcl/list.bench: added a list-iter benchmark * tcl/klist.bench: reduced default iters in klist.bench. Accuracy seems about the same without the wait... * libbench.tcl: * runbench.tcl: added support for -rmatch option (regexp match of benchmark description). Added MIDPOINT verbose puts for interim time notes. 2001-04-11 Jeff Hobbs * tcl/klist.bench: added shuffle5* from wiki. 2001-03-28 Jeff Hobbs * tcl/string.bench: fixed str-first proc that had bogus code in it. added more split benchmarks for dkf's split improvement in 8.4. * tk/canvas.bench: expanded item draw benchmarks 2001-03-23 * tk/canvas.bench: added simple item draw benchmarks 2001-03-15 * tcl/klist.bench: improved non-tclbench data output. * runbench.tcl: added more error capturing. * tcl/string.bench: fixed calls to string repeat to work with <8.1.1 interps. * tcl/klist.bench: new file to benchmark various list shuffling techniques (from wiki). * tcl/methods.bench: new file to benchmark various method invocation speeds (petasis). 2000-10-19 Jeff Hobbs * tcl/string.bench (str-append-2): added more append tests 2000-08-30 Jeff Hobbs * tcl/string.bench: made string repeat calls compatible with pre-8.1.1 interpreters. * libbench.tcl (bench_tmpfile): add env to global list 2000-08-29 Eric Melski * tcl/string.bench: Extended string append benchmarks to exploit new growth algorithm for string objects in Tcl 8.4a2. 2000-05-31 Jeff Hobbs * runbench.tcl: new options -errors (passed to libbench), -verbose (by default we are now quieter on output), -output (different output types - csv is char-sep-value for Excel). Added start/finish times (in -verbose mode). * libbench.tcl: libbench now takes -option switches for flexibility, options for -errors BOOL (error suppression), -interp NAME (to specify interp), -match PATTERN (glob pattern to filter tests by desc), -iters NUM (default number of iters to run). Reorganized how data is returned to runbench master. * tk/entry.bench (new): * tk/canvas.bench (new): new tests for widget creation, config * tcl/array.bench (removed): * tcl/vars.bench: merged array.bench tests into VAR * tcl/map.bench: fixed for compatability with Tcl7.4- 2000-05-25 Jeff Hobbs * runbench.tcl: added -match, -notcl, -notk options, restructured startup sequence. * libbench.tcl: added ability to return string values from bench tests and support for filtering tests to run. * tcl/string.bench: moved string mapping benchmarks and added more string equality benchmarks * tcl/map.bench: added extended string mapping benchmark * tcl/read.bench: * tcl/startup.bench: * tk/startup.bench: updated code to reflect proc-oriented tmpfile operations. tcllib-1.15/modules/bench/bench_wtext.man0000644000175000017500000000341012077663115017773 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin bench::out::text n 0.1.2] [copyright {2007 Andreas Kupries }] [moddesc {Benchmarking/Performance tools}] [titledesc {bench::out::text - Formatting benchmark results as human readable text}] [category {Benchmark tools}] [require Tcl 8.2] [require bench::out::text [opt 0.1.2]] [description] This package provides commands for fomatting of benchmark results into human readable text. [para] A reader interested in the generation or processing of such results should go and read [term {bench - Processing benchmark suites}] instead. [para] If the bench language itself is the actual interest please start with the [term {bench language introduction}] and then proceed from there to the formal [term {bench language specification}]. [para] [section {PUBLIC API}] [list_begin definitions] [call [cmd ::bench::out::text] [arg bench_result]] This command formats the specified benchmark result for output to a file, socket, etc. This specific command generates human readable text. [para] For other formatting styles see the packages [package bench] and [package bench::out::csv] which provide commands to format benchmark results in raw form, or as importable CSV data, respectively. [list_end] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph bench] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [see_also bench] [see_also bench::out::csv] [keywords testing performance benchmark formatting text {human readable}] [manpage_end] tcllib-1.15/modules/bench/bench.man0000644000175000017500000002231212077663115016542 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin bench n 0.4] [copyright {2007-2008 Andreas Kupries }] [moddesc {Benchmarking/Performance tools}] [titledesc {bench - Processing benchmark suites}] [category {Benchmark tools}] [require Tcl 8.2] [require bench [opt 0.4]] [description] This package provides commands for the execution of benchmarks written in the bench language, and for the processing of results generated by such execution. [para] A reader interested in the bench language itself should start with the [term {bench language introduction}] and proceed from there to the formal [term {bench language specification}]. [para] [section {PUBLIC API}] [subsection {Benchmark execution}] [list_begin definitions] [call [cmd ::bench::locate] [arg pattern] [arg paths]] This command locates Tcl interpreters and returns a list containing their paths. It searches them in the list of [arg paths] specified by the caller, using the glob [arg pattern]. [para] The command resolves soft links to find the actual executables matching the pattern. Note that only interpreters which are marked as executable and are actually executable on the current platform are put into the result. [call [cmd ::bench::run] [opt [arg "option value"]...] [arg interp_list] [arg file]...] This command executes the benchmarks declared in the set of files, once per Tcl interpreter specified via the [arg interp_list], and per the configuration specified by the options, and then returns the accumulated timing results. The format of this result is described in section [sectref {Result format}]. [para] It is assumed that the contents of the files are written in the bench language. [para] The available options are [list_begin options] [opt_def -errors [arg flag]] The argument is a boolean value. If set errors in benchmarks are propagated to the command, aborting benchmark execution. Otherwise they are recorded in the timing result via a special result code. The default is to propagate and abort. [opt_def -threads [arg n]] The argument is a non-negative integer value declaring the number of threads to use while executing the benchmarks. The default value is [const 0], to not use threads. [opt_def -match [arg pattern]] The argument is a glob pattern. Only benchmarks whose description matches the pattern are executed. The default is the empty string, to execute all patterns. [opt_def -rmatch [arg pattern]] The argument is a regular expression pattern. Only benchmarks whose description matches the pattern are executed. The default is the empty string, to execute all patterns. [opt_def -iters [arg n]] The argument is positive integer number, the maximal number of iterations for any benchmark. The default is [const 1000]. Individual benchmarks can override this. [opt_def -pkgdir [arg path]] The argument is a path to an existing, readable directory. Multiple paths can be specified, simply use the option multiple times, each time with one of the paths to use. [para] If no paths were specified the system will behave as before. If one or more paths are specified, say [var N], each of the specified interpreters will be invoked [var N] times, with one of the specified paths. The chosen path is put into the interpreters' [var auto_path], thus allowing it to find specific versions of a package. [para] In this way the use of [option -pkgdir] allows the user to benchmark several different versions of a package, against one or more interpreters. [para] [emph Note:] The empty string is allowed as a path and causes the system to run the specified interpreters with an unmodified [var auto_path]. In case the package in question is available there as well. [list_end] [para] [call [cmd ::bench::versions] [arg interp_list]] This command takes a list of Tcl interpreters, identified by their path, and returns a dictionary mapping from the interpreters to their versions. Interpreters which are not actually executable, or fail when interrogated, are not put into the result. I.e the result may contain less interpreters than there in the input list. [para] The command uses builtin command [cmd {info patchlevel}] to determine the version of each interpreter. [list_end] [subsection {Result manipulation}] [list_begin definitions] [call [cmd ::bench::del] [arg bench_result] [arg column]] This command removes a column, i.e. all benchmark results for a specific Tcl interpreter, from the specified benchmark result and returns the modified result. [para] The benchmark results are in the format described in section [sectref {Result format}]. [para] The column is identified by an integer number. [call [cmd ::bench::edit] [arg bench_result] [arg column] [arg newvalue]] This command renames a column in the specified benchmark result and returns the modified result. This means that the path of the Tcl interpreter in the identified column is changed to an arbitrary string. [para] The benchmark results are in the format described in section [sectref {Result format}]. [para] The column is identified by an integer number. [call [cmd ::bench::merge] [arg bench_result]...] This commands takes one or more benchmark results, merges them into one big result, and returns that as its result. [para] All benchmark results are in the format described in section [sectref {Result format}]. [call [cmd ::bench::norm] [arg bench_result] [arg column]] This command normalizes the timing results in the specified benchmark result and returns the modified result. This means that the cell values are not times anymore, but factors showing how much faster or slower the execution was relative to the baseline. [para] The baseline against which the command normalizes are the timing results in the chosen column. This means that after the normalization the values in this column are all [const 1], as these benchmarks are neither faster nor slower than the baseline. [para] A factor less than [const 1] indicates a benchmark which was faster than the baseline, whereas a factor greater than [const 1] indicates a slower execution. [para] The benchmark results are in the format described in section [sectref {Result format}]. [para] The column is identified by an integer number. [call [cmd ::bench::out::raw] [arg bench_result]] This command formats the specified benchmark result for output to a file, socket, etc. This specific command does no formatting at all, it passes the input through unchanged. [para] For other formatting styles see the packages [package bench::out::text] and [package bench::out::csv] which provide commands to format benchmark results for human consumption, or as CSV data importable by spread sheets, respectively. [para] Complementary, to read benchmark results from files, sockets etc. look for the package [package bench::in] and the commands provided by it. [list_end] [subsection {Result format}] After the execution of a set of benchmarks the raw result returned by this package is a Tcl dictionary containing all the relevant information. The dictionary is a compact representation, i.e. serialization, of a 2-dimensional table which has Tcl interpreters as columns and benchmarks as rows. The cells of the table contain the timing results. The Tcl interpreters / columns are identified by their paths. The benchmarks / rows are identified by their description. [para] The possible keys are all valid Tcl lists of two or three elements and have one of the following forms: [list_begin definitions] [def {{interp *}}] The set of keys matching this glob pattern capture the information about all the Tcl interpreters used to run the benchmarks. The second element of the key is the path to the interpreter. [para] The associated value is the version of the Tcl interpreter. [def {{desc *}}] The set of keys matching this glob pattern capture the information about all the benchmarks found in the executed benchmark suite. The second element of the key is the description of the benchmark, which has to be unique. [para] The associated value is irrelevant, and set to the empty string. [def {{usec * *}}] The set of keys matching this glob pattern capture the performance information, i.e. timing results. The second element of the key is the description of the benchmark, the third element the path of the Tcl interpreter which was used to run it. [para] The associated value is either one of several special result codes, or the time it took to execute the benchmark, in microseconds. The possible special result codes are [list_begin definitions] [def ERR] Benchmark could not be executed, failed with a Tcl error. [def BAD_RES] The benchmark could be executed, however the result from its body did not match the declared expectations. [list_end] [list_end] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph bench] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [see_also bench_intro] [see_also bench_lang_intro] [see_also bench_lang_spec] [see_also bench_wtext] [see_also bench_wcsv] [see_also bench_read] [keywords testing performance benchmark merging normalization] [manpage_end] tcllib-1.15/modules/bench/pkgIndex.tcl0000644000175000017500000000062612077663115017247 0ustar sergeisergeiif {![package vsatisfies [package provide Tcl] 8.2]} { return } package ifneeded bench 0.4 [list source [file join $dir bench.tcl]] package ifneeded bench::out::text 0.1.2 [list source [file join $dir bench_wtext.tcl]] package ifneeded bench::out::csv 0.1.2 [list source [file join $dir bench_wcsv.tcl]] package ifneeded bench::in 0.1 [list source [file join $dir bench_read.tcl]] tcllib-1.15/modules/bench/bench_wcsv.man0000644000175000017500000000341212077663115017604 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin bench::out::csv n 0.1.2] [copyright {2007 Andreas Kupries }] [moddesc {Benchmarking/Performance tools}] [titledesc {bench::out::csv - Formatting benchmark results as CSV}] [category {Benchmark tools}] [require Tcl 8.2] [require bench::out::csv [opt 0.1.2]] [description] This package provides commands for fomatting of benchmark results into a CSV table importable by spread sheets. [para] A reader interested in the generation or processing of such results should go and read [term {bench - Processing benchmark suites}] instead. [para] If the bench language itself is the actual interest please start with the [term {bench language introduction}] and then proceed from there to the formal [term {bench language specification}]. [para] [section {PUBLIC API}] [list_begin definitions] [call [cmd ::bench::out::csv] [arg bench_result]] This command formats the specified benchmark result for output to a file, socket, etc. This specific command generates CSV data importable by spread sheets. [para] For other formatting styles see the packages [package bench] and [package bench::out::text] which provide commands to format benchmark results in raw form, or for human consumption, respectively. [list_end] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph bench] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [see_also bench] [see_also bench::out::text] [keywords testing performance benchmark formatting csv] [manpage_end] tcllib-1.15/modules/bench/bench_lang_spec.man0000644000175000017500000001046012077663115020556 0ustar sergeisergei[comment {-*- tcl -*- doctools manpage}] [manpage_begin bench_lang_spec n 1.0] [copyright {2007 Andreas Kupries }] [moddesc {Documentation tools}] [titledesc {bench language specification}] [category {Benchmark tools}] [description] [para] This document specifies both names and syntax of all the commands which together are the bench language, version 1. As this document is intended to be a reference the commands are listed in alphabetical order, and the descriptions are relatively short. A beginner should read the more informally written [term {bench language introduction}] first. [section Commands] [list_begin definitions] [call [cmd bench_rm] [arg path]...] This command silently removes the files specified as its arguments and then returns the empty string as its result. The command is [emph trusted], there is no checking if the specified files are outside of whatever restricted area the benchmarks are run in. [call [cmd bench_tmpfile]] This command returns the path to a bench specific unique temporary file. The uniqueness means that multiple calls will return different paths. While the path may exist from previous runs, the command itself does [emph not] create aynthing. [para] The base location of the temporary files is platform dependent: [list_begin definitions] [def {Unix, and indeterminate platform}] [file /tmp] [def Windows] [var \$TEMP] [def {Anything else}] The current working directory. [list_end] [para] [call [cmd bench] [arg options]...] This command declares a single benchmark. Its result is the empty string. All parts of the benchmark are declared via options, and their values. The options can occur in any order. The accepted options are: [list_begin options] [opt_def -body script] The argument of this option declares the body of the benchmark, the Tcl script whose performance we wish to measure. This option, and [option -desc], are the two required parts of each benchmark. [opt_def -desc msg] The argument of this option declares the name of the benchmark. It has to be unique, or timing data from different benchmarks will be mixed together. [para] [emph Beware!] This requirement is not checked when benchmarks are executed, and the system will silently produce bogus data. This option, and [option -body], are the two required parts of each benchmark. [opt_def -ipost script] The argument of this option declares a script which is run immediately [emph after] each iteration of the body. Its responsibility is to release resources created by the body, or [option -ipre]-bodym which we do not wish to live into the next iteration. [opt_def -ipre script] The argument of this option declares a script which is run immediately [emph before] each iteration of the body. Its responsibility is to create the state of the system expected by the body so that we measure the right thing. [opt_def -iterations num] The argument of this option declares the maximum number of times to run the [option -body] of the benchmark. During execution this and the global maximum number of iterations are compared and the smaller of the two values is used. [para] This option should be used only for benchmarks which are expected or known to take a long time per run. I.e. reduce the number of times they are run to keep the overall time for the execution of the whole benchmark within manageable limits. [opt_def -post script] The argument of this option declares a script which is run [emph after] all iterations of the body have been run. Its responsibility is to release resources created by the body, or [option -pre]-body. [opt_def -pre script] The argument of this option declares a script which is run [emph before] any of the iterations of the body are run. Its responsibility is to create whatever resources are needed by the body to run without failing. [list_end] [list_end] [section {BUGS, IDEAS, FEEDBACK}] This document, and the package it describes, will undoubtedly contain bugs and other problems. Please report such in the category [emph bench] of the [uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}]. Please also report any ideas for enhancements you may have for either package and/or documentation. [see_also bench_intro] [see_also bench_lang_intro] [keywords testing performance benchmark {bench language} specification] [manpage_end] tcllib-1.15/modules/bench/bench_wcsv.tcl0000644000175000017500000000470012077663115017614 0ustar sergeisergei# bench_wtext.tcl -- # # Management of benchmarks, formatted text. # # Copyright (c) 2005 by Andreas Kupries # library derived from runbench.tcl application (C) Jeff Hobbs. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: bench_wcsv.tcl,v 1.4 2007/01/21 23:29:06 andreas_kupries Exp $ # ### ### ### ######### ######### ######### ########################### ## Requisites - Packages and namespace for the commands and data. package require Tcl 8.2 package require csv namespace eval ::bench::out {} # ### ### ### ######### ######### ######### ########################### ## Public API - Benchmark execution # ### ### ### ######### ######### ######### ########################### ## Public API - Result formatting. # ::bench::out::csv -- # # Format the result of a benchmark run. # Style: CSV # # Arguments: # DATA dict # # Results: # String containing the formatted DATA. proc ::bench::out::csv {data} { array set DATA $data set CSV {} # 1st record: #shells # 2nd record to #shells+1: Interpreter data (id, version, path) # #shells+2 to end: Benchmark data (id,desc,result1,...,result#shells) # --- --- ---- # #interpreters used set ipkeys [array names DATA interp*] lappend CSV [csv::join [list [llength $ipkeys]]] # --- --- ---- # Table 1: Interpreter information. set n 1 set iplist {} foreach key [lsort -dict $ipkeys] { set ip [lindex $key 1] lappend CSV [csv::join [list $n $DATA($key) $ip]] set DATA($key) $n incr n lappend iplist $ip } # --- --- ---- # Table 2: Benchmark information set dlist {} foreach key [lsort -dict -index 1 [array names DATA desc*]] { lappend dlist [lindex $key 1] } set n 1 foreach desc $dlist { set record {} lappend record $n lappend record $desc foreach ip $iplist { if {[catch { lappend record $DATA([list usec $desc $ip]) }]} { lappend record {} } } lappend CSV [csv::join $record] incr n } return [join $CSV \n] } # ### ### ### ######### ######### ######### ########################### ## Internal commands # ### ### ### ######### ######### ######### ########################### ## Initialize internal data structures. # ### ### ### ######### ######### ######### ########################### ## Ready to run package provide bench::out::csv 0.1.2 tcllib-1.15/modules/bench/bench.tcl0000644000175000017500000003172112077663115016555 0ustar sergeisergei# bench.tcl -- # # Management of benchmarks. # # Copyright (c) 2005-2008 by Andreas Kupries # library derived from runbench.tcl application (C) Jeff Hobbs. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: bench.tcl,v 1.14 2008/10/08 03:30:48 andreas_kupries Exp $ # ### ### ### ######### ######### ######### ########################### ## Requisites - Packages and namespace for the commands and data. package require Tcl 8.2 package require logger package require csv package require struct::matrix package require report namespace eval ::bench {} namespace eval ::bench::out {} # @mdgen OWNER: libbench.tcl # ### ### ### ######### ######### ######### ########################### ## Public API - Benchmark execution # ::bench::run -- # # Run a series of benchmarks. # # Arguments: # ... # # Results: # Dictionary. proc ::bench::run {args} { log::debug [linsert $args 0 ::bench::run] # -errors 0|1 default 1, propagate errors in benchmarks # -threads default 0, no threads, #threads to use # -match only run tests matching this pattern # -rmatch only run tests matching this pattern # -iters default 1000, max#iterations for any benchmark # -pkgdir Defaults to nothing, regular bench invokation. # interps - dict (path -> version) # files - list (of files) # Process arguments ...................................... # Defaults first, then overides by the user set errors 1 ; # Propagate errors set threads 0 ; # Do not use threads set match {} ; # Do not exclude benchmarks based on glob pattern set rmatch {} ; # Do not exclude benchmarks based on regex pattern set iters 1000 ; # Limit #iterations for any benchmark set pkgdirs {} ; # List of dirs to put in front of auto_path in the # bench interpreters. Default: nothing. while {[string match "-*" [set opt [lindex $args 0]]]} { set val [lindex $args 1] switch -exact -- $opt { -errors { if {![string is boolean -strict $val]} { return -code error "Expected boolean, got \"$val\"" } set errors $val } -threads { if {![string is int -strict $val] || ($val < 0)} { return -code error "Expected int >= 0, got \"$val\"" } set threads [lindex $args 1] } -match { set match [lindex $args 1] } -rmatch { set rmatch [lindex $args 1] } -iters { if {![string is int -strict $val] || ($val <= 0)} { return -code error "Expected int > 0, got \"$val\"" } set iters [lindex $args 1] } -pkgdir { CheckPkgDirArg $val lappend pkgdirs $val } default { return -code error "Unknown option \"$opt\", should -errors, -threads, -match, -rmatch, or -iters" } } set args [lrange $args 2 end] } if {[llength $args] != 2} { return -code error "wrong\#args, should be: ?options? interp files" } foreach {interps files} $args break # Run the benchmarks ..................................... array set DATA {} if {![llength $pkgdirs]} { # No user specified package directories => Simple run. foreach {ip ver} $interps { Invoke $ip $ver {} ;# DATA etc passed via upvar. } } else { # User specified package directories. foreach {ip ver} $interps { foreach pkgdir $pkgdirs { Invoke $ip $ver $pkgdir ;# DATA etc passed via upvar. } } } # Benchmark data ... Structure, dict (key -> value) # # Key || Value # ============ ++ ========================================= # interp IP -> Version. Shell IP was used to run benchmarks. IP is # the path to the shell. # # desc DESC -> "". DESC is description of an executed benchmark. # # usec DESC IP -> Result. Result of benchmark DESC when run by the # shell IP. Usually time in microseconds, but can be # a special code as well (ERR, BAD_RES). # ============ ++ ========================================= return [array get DATA] } # ::bench::locate -- # # Locate interpreters on the pathlist, based on a pattern. # # Arguments: # ... # # Results: # List of paths. proc ::bench::locate {pattern paths} { # Cache of executables already found. array set var {} set res {} foreach path $paths { foreach ip [glob -nocomplain [file join $path $pattern]] { if {[package vsatisfies [package provide Tcl] 8.4]} { set ip [file normalize $ip] } # Follow soft-links to the actual executable. while {[string equal link [file type $ip]]} { set link [file readlink $ip] if {[string match relative [file pathtype $link]]} { set ip [file join [file dirname $ip] $link] } else { set ip $link } } if { [file executable $ip] && ![info exists var($ip)] } { if {[catch {exec $ip << "exit"} dummy]} { log::debug "$ip: $dummy" continue } set var($ip) . lappend res $ip } } } return $res } # ::bench::versions -- # # Take list of interpreters, find their versions. # Removes all interps for which it cannot do so. # # Arguments: # List of interpreters (paths) # # Results: # dictionary: interpreter -> version. proc ::bench::versions {interps} { set res {} foreach ip $interps { if {[catch { exec $ip << {puts [info patchlevel] ; exit} } patchlevel]} { log::debug "$ip: $patchlevel" continue } lappend res [list $patchlevel $ip] } # -uniq 8.4-ism, replaced with use of array. array set tmp {} set resx {} foreach item [lsort -dictionary -decreasing -index 0 $res] { foreach {p ip} $item break if {[info exists tmp($p)]} continue set tmp($p) . lappend resx $ip $p } return $resx } # ::bench::merge -- # # Take the data of several benchmark runs and merge them into # one data set. # # Arguments: # One or more data sets to merge # # Results: # The merged data set. proc ::bench::merge {args} { if {[llength $args] == 1} { return [lindex $args 0] } array set DATA {} foreach data $args { array set DATA $data } return [array get DATA] } # ::bench::norm -- # # Normalize the time data in the dataset, using one of the # columns as reference. # # Arguments: # Data to normalize # Index of reference column # # Results: # The normalized data set. proc ::bench::norm {data col} { if {![string is integer -strict $col]} { return -code error "Ref.column: Expected integer, but got \"$col\"" } if {$col < 1} { return -code error "Ref.column out of bounds" } array set DATA $data set ipkeys [array names DATA interp*] if {$col > [llength $ipkeys]} { return -code error "Ref.column out of bounds" } incr col -1 set refip [lindex [lindex [lsort -dict $ipkeys] $col] 1] foreach key [array names DATA] { if {[string match "desc*" $key]} continue if {[string match "interp*" $key]} continue foreach {_ desc ip} $key break if {[string equal $ip $refip]} continue set v $DATA($key) if {![string is double -strict $v]} continue if {![info exists DATA([list usec $desc $refip])]} { # We cannot normalize, we do not keep the time value. # The row will be shown, empty. set DATA($key) "" continue } set vref $DATA([list usec $desc $refip]) if {![string is double -strict $vref]} continue set DATA($key) [expr {$v/double($vref)}] } foreach key [array names DATA [list * $refip]] { if {![string is double -strict $DATA($key)]} continue set DATA($key) 1 } return [array get DATA] } # ::bench::edit -- # # Change the 'path' of an interp to a user-defined value. # # Arguments: # Data to edit # Index of column to change # The value replacing the current path # # Results: # The changed data set. proc ::bench::edit {data col new} { if {![string is integer -strict $col]} { return -code error "Ref.column: Expected integer, but got \"$col\"" } if {$col < 1} { return -code error "Ref.column out of bounds" } array set DATA $data set ipkeys [array names DATA interp*] if {$col > [llength $ipkeys]} { return -code error "Ref.column out of bounds" } incr col -1 set refip [lindex [lindex [lsort -dict $ipkeys] $col] 1] if {[string equal $new $refip]} { # No change, quick return return $data } set refkey [list interp $refip] set DATA([list interp $new]) $DATA($refkey) unset DATA($refkey) foreach key [array names DATA [list * $refip]] { if {![string equal [lindex $key 0] "usec"]} continue foreach {__ desc ip} $key break set DATA([list usec $desc $new]) $DATA($key) unset DATA($key) } return [array get DATA] } # ::bench::del -- # # Remove the data for an interp. # # Arguments: # Data to edit # Index of column to remove # # Results: # The changed data set. proc ::bench::del {data col} { if {![string is integer -strict $col]} { return -code error "Ref.column: Expected integer, but got \"$col\"" } if {$col < 1} { return -code error "Ref.column out of bounds" } array set DATA $data set ipkeys [array names DATA interp*] if {$col > [llength $ipkeys]} { return -code error "Ref.column out of bounds" } incr col -1 set refip [lindex [lindex [lsort -dict $ipkeys] $col] 1] unset DATA([list interp $refip]) # Do not use 'array unset'. Keep 8.2 clean. foreach key [array names DATA [list * $refip]] { if {![string equal [lindex $key 0] "usec"]} continue unset DATA($key) } return [array get DATA] } # ### ### ### ######### ######### ######### ########################### ## Public API - Result formatting. # ::bench::out::raw -- # # Format the result of a benchmark run. # Style: Raw data. # # Arguments: # DATA dict # # Results: # String containing the formatted DATA. proc ::bench::out::raw {data} { return $data } # ### ### ### ######### ######### ######### ########################### ## Internal commands proc ::bench::CheckPkgDirArg {path {expected {}}} { # Allow empty string, special. if {![string length $path]} return if {![file isdirectory $path]} { return -code error \ "The path \"$path\" is not a directory." } if {![file readable $path]} { return -code error \ "The path \"$path\" is not readable." } } proc ::bench::Invoke {ip ver pkgdir} { variable self # Import remainder of the current configuration/settings. upvar 1 DATA DATA match match rmatch rmatch \ iters iters errors errors threads threads \ files files if {[string length $pkgdir]} { log::info "Benchmark $ver ($pkgdir) $ip" set idstr "$ip ($pkgdir)" } else { log::info "Benchmark $ver $ip" set idstr $ip } set DATA([list interp $idstr]) $ver set cmd [list $ip [file join $self libbench.tcl] \ -match $match \ -rmatch $rmatch \ -iters $iters \ -interp $ip \ -errors $errors \ -threads $threads \ -pkgdir $pkgdir \ ] # Determine elapsed time per file, logged. set start [clock seconds] array set tmp {} if {$threads} { foreach f $files { lappend cmd $f } if {[catch { close [Process [open |$cmd r+]] } output]} { if {$errors} { error $::errorInfo } } } else { foreach file $files { log::info [file tail $file] if {[catch { close [Process [open |[linsert $cmd end $file] r+]] } output]} { if {$errors} { error $::errorInfo } else { continue } } } } foreach desc [array names tmp] { set DATA([list desc $desc]) {} set DATA([list usec $desc $idstr]) $tmp($desc) } unset tmp set elapsed [expr {[clock seconds] - $start}] set hour [expr {$elapsed / 3600}] set min [expr {$elapsed / 60}] set sec [expr {$elapsed % 60}] log::info " [format %.2d:%.2d:%.2d $hour $min $sec] elapsed" return } proc ::bench::Process {pipe} { while {1} { if {[eof $pipe]} break if {[gets $pipe line] < 0} break # AK: FUTURE: Log all lines?! #puts |$line| set line [string trim $line] if {[string equal $line ""]} continue Result Feedback # Unknown lines are printed. Future: Callback?! log::info $line } return $pipe } proc ::bench::Result {} { upvar 1 line line if {[lindex $line 0] ne "RESULT"} return upvar 2 tmp tmp foreach {_ desc result} $line break set tmp($desc) $result return -code continue } proc ::bench::Feedback {} { upvar 1 line line if {[lindex $line 0] ne "LOG"} return # AK: Future - Run through callback?! log::info [lindex $line 1] return -code continue } # ### ### ### ######### ######### ######### ########################### ## Initialize internal data structures. namespace eval ::bench { variable self [file join [pwd] [file dirname [info script]]] logger::init bench logger::import -force -all -namespace log bench } # ### ### ### ######### ######### ######### ########################### ## Ready to run package provide bench 0.4 tcllib-1.15/modules/bench/libbench.tcl0000644000175000017500000003606312077663115017250 0ustar sergeisergei# -*- tcl -*- # libbench.tcl ?(