diff options
Diffstat (limited to 'tcllib/modules/math')
97 files changed, 51211 insertions, 0 deletions
diff --git a/tcllib/modules/math/ChangeLog b/tcllib/modules/math/ChangeLog new file mode 100644 index 0000000..0911406 --- /dev/null +++ b/tcllib/modules/math/ChangeLog @@ -0,0 +1,1440 @@ +2015-04-29 Arjen Markus <arjenmarkus@users.sourceforge.net> + * statistics.tcl: Add test-Duckworth + * pdf_stat.tcl: Add empirical-distribution + * statistics.test: Add tests for test-Duckworth and empirical-distribution + * statistics.man: Describe test-Duckworth and empirical-distribution + +2015-04-28 Arjen Markus <arjenmarkus@users.sourceforge.net> + * statistics.tcl: Bump version to 1.0 - Aku found the cause of earlier problems + +2015-04-26 Arjen Markus <arjenmarkus@users.sourceforge.net> + * statistics.tcl: Bump version to 0.9.3 + Implemented an alternative to histogram (ticket 1502400fff) + Revised test-normal to use "significance" (ticket 2812473fff) + * statistics.man: Describe histogram-alt, changes to test-normal (and t-test-mean, again "confidence") + * pdf_stat.tcl: Correct the returned value for pdf-beta - if x is 0 or 1. + +2014-09-27 Arjen Markus <arjenmarkus@users.sourceforge.net> + * statistics.tcl: Bump version to 0.9.2 + * statistics.test: Add tests for all pdf-* and cdf-* procedures, crude tests for random-* procedures + * pdf_stat.tcl: Fix a typo (cdf-uniform) and fix inadvertent integer divisions should arguments be integer + * special.tcl: Adding Christian's implementation of the inverse normal distribution function (invnorm) + * special.test: Adding test case for this new function + * special.man: Describing invnorm plus a correction in the overview (ierfc_n is not implemented) + * pkgIndex.tcl: Bumping version of math::special package to 0.3.0, of math::statistics to 0.9.2 + +2014-09-26 Arjen Markus <arjenmarkus@users.sourceforge.net> + * pdf-stat.tcl: Solve ticket UUID a6d69107d5, a typo in the pdf-uniform procedure + * pkgIndex.tcl: Bumping version of math::statistics package to 0.9.1 + +2014-09-21 Arjen Markus <arjenmarkus@users.sourceforge.net> + * bigfloat2.tcl: Solve ticket UUID 3309165, different implementation of isInt than suggested + * bigfloat2.test: Added several tests for the new implementation of isInt + * optimize.tcl: Solve ticket UUID 3193459, as suggested. + * optimize.tcl: Solve a problem with the detection of the exceptions in solving linear programs. Version 1.0.1 + * optimize.test: Added tests to distinguish infeasible and unbounded linear programs + * optimize.test: Added test for ticket UUID 3193459 + * pkgIndex.tcl: Bumping version of math::optimize package to 1.0.1, bigfloat2 to 2.0.2 + +2014-08-21 Arjen Markus <arjenmarkus@users.sourceforge.net> + * calculus.tcl: Bumping version to 0.8 + * pkgIndex.tcl: Bumping version of math::calculus package to 0.8 + +2014-08-21 Arjen Markus <arjenmarkus@users.sourceforge.net> + * calculus.man: Describe the qk15 procedure implementing Gauss-Kronrod 15 points quadrature rule + * calculus.tcl: Implement the qk15 procedure for Gauss-Kronrod quadrature + * calculus.test: Provide a simple test procedure for Gauss-Kronrod quadrature + +2014-08-17 Arjen Markus <arjenmarkus@users.sourceforge.net> + * statistcs.man: Add missing documentation for random-poisson procedure + +2014-01-30 Arjen Markus <arjenmarkus@users.sourceforge.net> + * geometry.tcl: Corrected edge case in pointInsidePolygon (by closer checking + intersection of line segments; ticket c1ca34ead3). + Also introduced a procedure calculateDistanceToPolygon to solve ticket bff902be35 + * math_geometry.man: Description of new procedure pointInsidePolygon + * geometry.test: Added test cases based on both tickets + * pkgIndex.tcl: Bumped version to 1.1.3 + +2014-01-19 Arjen Markus <arjenmarkus@users.sourceforge.net> + * stat_kernel.tcl: Corrected use of bandwidth + * statistics.test: Added margin per kernel - not quite satisfactory in the case of the uniform kernel + +2014-01-18 Arjen Markus <arjenmarkus@users.sourceforge.net> + * statistics.tcl: Added stat_kernel.tcl + * stat_kernel.tcl: Implements a straightforward kernel density estimation procedure + * statistics.man: Describe the kernel denstity estimation procedure, moved the description of several + tests to the general section + * statistics.test: Added three tests for the kernel density estimation (note: one result is a bit troublesome) + * pkgIndex.tcl: Bumped version of statistics package to 0.9 + +2013-12-20 Arjen Markus <arjenmarkus@users.sourceforge.net> + * interpolate.tcl: [Ticket 843c2257d2] Added special case for points coincident with the data points + * interpolate.test: [Ticket 843c2257d2] Added test case for coincident points + +2013-12-17 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * decimal.man: Fixed missing requirement of the package + * machineparameters.man: itself. + +2013-11-03 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * calculus.tcl: Corrected calculation of corrector in heunStep (now version 0.7.2) + * pkgIndex.tcl: [Ticket b25b826973] Bumped version of interpolate to 1.1 + * interpolate.tcl: [Ticket b25b826973] Corrected inconsistency in use of tables for 1D interpolation + * interpolate.test: [Ticket b25b826973] Adjusted the test for 1D interpolation + * interpolate.man: [Ticket b25b826973] Added an example for 1D interpolation and note on the + incompatibility + +2013-03-05 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * statistics.tcl: [Ticket 05d055c2f5]: Added weights to histogram + * statistics.man: [Ticket 05d055c2f5]: Documented weights to histogram + * statistics.test: [Ticket 05d055c2f5]: Added test for weights to histogram + * pkgIndex.tcl: [Ticket 05d055c2f5]: Bumped to version 0.8.1 + +2013-03-11 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * math.test (math-12.1): [Bug 3606620]: Disabled debug output + command lifting SafeBase error information into the test log. + +2013-03-05 Arjen Markus <arjenmarkus@users.sourceforge.net> + * decimal.tcl: Some rounding issues fixed (by Mark Alston) + * pkgIndex.tcl: Bumped version of decimal package to 1.0.3 + +2013-02-08 Andreas Kupries <andreask@activestate.com> + + * decimal.man: Fixed leading namespace qualifier in label. + * symdiff.man: Fixed missing short package title. + +2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.15 ======================== + * + +2012-06-25 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * statistics.tcl: Add procedures for Wilcoxon test and Spearman + rank correlation to the export list + +2012-06-24 Arjen Markus <arjenmarkus@users.sourceforge.net> + * 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 <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.14 ======================== + * + +2011-11-09 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * 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 <andreas_kupries@users.sourceforge.net> + + * 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 <andreask@activestate.com> + + * decimal.man: [Bug 3383039]: Fixed syntax errors in the + documentation of math::decimal, reported by Thomas Perschak + <tombert@users.sourceforge.net> + +2011-03-29 Andreas Kupries <andreask@activestate.com> + + * linalg.man: Documentation tweak, added keyword 'matrix'. + +2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.13 ======================== + * + +2011-01-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * 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 <andreask@activestate.com> + + * 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 <kennykb@acm.org> + + * 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 <lars_h@users.sourceforge.net> + + * numtheory.test: Fixed bug #3076576. + * numtheory.dtx: + +2010-09-22 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * kruskal.tcl: Added header to the file + +2010-09-21 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * 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 <lars_h@users.sourceforge.net> + + * 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 <andreask@activestate.com> + + * 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 <andreask@activestate.com> + + * geometry.man: A bit more commands, bumped to version 1.1.2. + * geometry.tcl: + * pkgIndex.tcl: + +2010-04-06 Andreas Kupries <andreask@activestate.com> + + * 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 <andreask@activestate.com> + + * 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 <arjenmarkus@users.sourceforge.net> + + * 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 <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.12 ======================== + * + +2009-12-04 Andreas Kupries <andreask@activestate.com> + + * 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 <arjenmarkus@users.sourceforge.net> + + * 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 <arjenmarkus@users.sourceforge.net> + + * pdf_stat.tcl: Fix bug #2897419 - very small numbers with beta + distribution + +2009-10-22 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * interpolate.tcl: Fix bug #2881739 in cubic interpolation + +2009-09-28 Andreas Kupries <andreask@activestate.com> + + * 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 <arjenmarkus@users.sourceforge.net> + + * statistics.tcl: Remove a local variable from interval-mean-stdev + +2009-08-12 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * statistics.tcl: Solve bug 2835712 regarding interval-mean-stdev + +2009-07-13 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * 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 <arjenmarkus@users.sourceforge.net> + + * 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 <arjenmarkus@users.sourceforge.net> + + * machineparameters.man: Replaced deprecated markup (bug #2597454) + +2009-02-06 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * 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 <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.11.1 ======================== + * + +2008-12-01 Andreas Kupries <andreask@activestate.com> + + * 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 <arjenmarkus@users.sourceforge.net> + + * 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 <arjenmarkus@users.sourceforge.net> + + * optimize.man: corrected names of minimum and maximum procedures + +2008-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.11 ======================== + * + +2008-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * 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 <arjenmarkus@users.sourceforge.net> + + * 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 <arjenmarkus@users.sourceforge.net> + + * special.tcl: Replaced old algorithm for erf() and erfc(). Bug + #2024843. + +2008-07-01 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * roman.man: corrected wrong mark-up command + +2008-06-25 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * 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 <arjenmarkus@users.sourceforge.net> + + * roman.man: correct namespace ::math::roman, was ::roman. + +2008-03-24 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * pkgIndex.tcl: Synchronized indexed and provided versions of + * bigfloat.man: math::bigfloat. + +2008-03-22 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * constants.test: Fixed declaration of package under test, was + wrongly declared as support. + +2008-03-14 Andreas Kupries <andreask@activestate.com> + + * statistics.man: Cleaned up a bit, replaced deprecated [nl] usage + with [para]. + +2008-02-27 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * linalg.test (eigenvectors-1.0): Moved brace to correct location. + +2008-02-27 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * linalg.test (eigenvectors-1.0): Fixed missing closing brace. + +2008-02-21 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * elliptic.tcl: Error in expression (missing )) + +2008-01-18 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * 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 <arjenmarkus@users.sourceforge.net> + + * 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 <arjenmarkus@users.sourceforge.net> + + * 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 <arjenmarkus@users.sourceforge.net> + + * 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 <arjenmarkus@users.sourceforge.net> + + * special.tcl: Corrected implementation of Gamma + function (reported by EKB) + +2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.10 ======================== + * + +2007-09-11 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * 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 <arjenmarkus@users.sourceforge.net> + + * linalg.tcl: Solved bug with matmul (SF bug 1784637) + +2007-08-21 Andreas Kupries <andreask@activestate.com> + + * 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 <andreask@activestate.com> + + * 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 <arjenmarkus@users.sourceforge.net> + + * statistics.tcl: Corrected a spelling mistake in name of Zachariadis + * linalg.test: Removed temporary reference to ferri/ferri.test + +2007-07-07 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * 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 <kennykb@acm.org> + + * 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 <andreas_kupries@users.sourceforge.net> + + * 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 <arjenmarkus@users.sourceforge.net> + + * 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 <arjenmarkus@users.sourceforge.net> + + * statistics.man : updated description of tstat + * statistics.test : converted the example into a test + +2007-03-05 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * mvlinreg.tcl : polished the source code (adding standard headers) + Still to do: test cases + +2007-02-27 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * 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 <arjenmarkus@users.sourceforge.net> + + * fuzzy.test : fixed a dependency on Tcl 8.4 behaviour in one test case + (the value of tcl_precision) + +2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.9 ======================== + * + +2006-09-26 Andreas Kupries <andreask@activestate.com> + + * bigfloat.tcl: Bumped version to 1.2.1 + * pkgIndex.tcl: + +2006-09-26 Stephane Arnold <sarnold75@users.sourceforge.net> + * 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 <andreask@activestate.com> + + * 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 <arjenmarkus@users.sourceforge.net> + * linalg.tcl: removed print statement (left over from testing leastSquares) + +2006-09-15 Arjen Markus <arjenmarkus@users.sourceforge.net> + * 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 <arjenmarkus@users.sourceforge.net> + + * pdf_stat.tcl: check for existence of argv0 - child interpreters + * plotstat.tcl: ditto + * statistics.tcl: ditto + +2006-03-29 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * math.man: Fixed name of romberg package, resorted the list, + slight reformatting of items with regard to right margin. + +2006-03-28 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * 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 <arjenmarkus@users.sourceforge.net> + + * 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 <andreas_kupries@users.sourceforge.net> + + * pkgIndex.tcl: Resynchronized the ifneeded/provide version + information for math::bignum. + +2006-02-21 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * 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 <arjenmarkus@users.sourceforge.net> + + * 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 <andreas_kupries@users.sourceforge.net> + + * bignum.tcl (testbit): Fixed [SF Tcllib Bug 1085562]. Thanks to + aubinroy <aroy@users.sf.net> 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 <andreas_kupries@users.sourceforge.net> + + * bigfloat.test: Fixed use of duplicate test names. + * calculus.test: + * linalg.test: + * statistics.test: + +2006-01-23 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * 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 <andreas_kupries@users.sourceforge.net> + + * 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 <andreask@activestate.com> + + * fourier.tcl (::math::fourier::lowpass): Changed package + * fourier.tcl (::math::fourier::highpass): reference + "complexnumbers" to the correct "math::complexnumbers". + +2006-01-10 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * linalg.tcl: Fixed bug in procedure angle + Added a procedure crossproduct + * linalg.man: Added documentation on crossproduct + +2005-11-13 Stephane Arnold <sarnold75@users.sourceforge.net> + + * 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 <andreas_kupries@users.sourceforge.net> + + * pkgIndex.tcl: Reworked the extended package index a bit to keep + the general existing structure. + +2005-11-13 Stephane Arnold <sarnold75@users.sourceforge.net> + + * 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 <arjenmarkus@users.sourceforge.net> + + * roman.test: removed extraneous messages + +2005-10-26 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * qcomplex.tcl: error in the computation of the complex + cosine. Found by Oscar Andreas Lopez. + +2005-10-21 Andreas Kupries <andreask@activestate.com> + + * 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 <arjenmarkus@users.sourceforge.net> + + * fixed one bug regarding cov in misc.tcl + +2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.8 ======================== + * + +2005-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * 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 <andreask@activestate.com> + + * 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 <arjenmarkus@users.sourceforge.net> + + * Added roman numerals package by Kenneth Green + * geometry.man: Completed the description of the + current procedures + +2005-09-28 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * optimize.man: Removed note on linear programming. It is + working now (not fully, perhaps though) + +2005-09-20 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * 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 <andreas_kupries@users.sourceforge.net> + + * 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 <sarnold75@users.sourceforge.net> + + * bigfloat.tcl : went back to the old algorithm to compute Pi + after having done much benchmarks + +2005-09-06 Stephane Arnold <sarnold75@users.sourceforge.net> + + * bigfloat.tcl : new and faster algorithm to compute Pi + +2005-08-31 Stephane Arnold <sarnold75@users.sourceforge.net> + + * 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 <andreask@activestate.com> + + * 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 <kennykb@acm.org> + + * 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 <arjenmarkus@users.sourceforge.net> + + * 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 <sarnold75@users.sourceforge.net> + + * bigfloat.tcl : added comments to make code easier to understand + +2005-08-28 Stephane Arnold <sarnold75@users.sourceforge.net> + + * 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 <sarnold75@users.sourceforge.net> + + * 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 <kennykb@acm.org> + + * 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 <arjenmarkus@users.sourceforge.net> + + * optimize.man: Corrected a few typos + +2005-08-23 Stephane Arnold <sarnold75@users.sourceforge.net> + + * 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 <kennykb@acm.org> + + * 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 <arjenmarkus@users.sourceforge.net> + + * 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 <sarnold75@users.sourceforge.net> + + * 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 <andreas_kupries@users.sourceforge.net> + + * bigfloat.man: Replaced a number of ?...? occurences to markup + optional arguments with the more correct [opt ...]. + +2005-08-04 Stephane Arnold <sarnold75@users.sourceforge.net> + + * 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 <arjenmarkus@users.sourceforge.net> + + * 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 <sarnold75@users.sourceforge.net> + + * bigfloat.man,bigfloat.test,bigfloat.tcl : updated + copyright 2005 + * bigfloat.man : put the correct package version (1.2) + +2005-07-01 Stephane Arnold <sarnold75@users.sourceforge.net> + + * 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 <arjenmarkus@users.sourceforge.net> + + * 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 <andreas_kupries@users.sourceforge.net> + + * statistics.test: Corrected typos in the test suite for the new + commands. + +2005-06-22 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * 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 <kennykb@acm.org> + + * 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 <arjenmarkus@users.sourceforge.net> + + * Removed reference to argv0 in optimize.tcl (in response + to a complaint by Bob Techentin) + +2005-04-25 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * Corrected documentation of math::product (was math::prod) + +2005-03-16 Andreas Kupries <andreask@activestate.com> + + * 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 + <andreask@activestate.com>'. Somehow the source command came + back. + +2005-03-11 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * Corrected problem with exponential_Ei - doubly defined + +2005-01-14 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * Added version 1.0 of Stephane Arnold's bigfloat package + (newer versions will come later on) + +2005-01-10 Andreas Kupries <andreask@activestate.com> + + * 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 + <aakther@users.sourceforge.net>, modifications of docs, and + small testsuite by myself. + +2005-01-05 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * Added tests for matmul (and corrected the implementation) + +2005-01-04 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * 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 <arjenmarkus@users.sourceforge.net> + + * Added modified Gram-Schmidt method to the linear algebra package + +2004-12-06 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * 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 <andreask@activestate.com> + + * linalg.man: Fixed a formatting bug in the file, found by a + regular run of the SAK tool. + +2004-11-25 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * Added descriptions of various linear algebra procedures + * Updated the code and expanded test cases + +2004-11-22 Andreas Kupries <andreask@activestate.com> + + * 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 <arjenmarkus@users.sourceforge.net> + + * 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 <arjenmarkus@users.sourceforge.net> + + * Moved initialisation of CDF in statistics module to + first call + +2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.7 ======================== + * + +2004-10-02 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * Added preliminary documentation for the geometry module + * Added procedure areaPolygon to the geometry module + * Added Fourier transform module + +2004-09-30 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * bignum.test: Boilerplate reading file under test. + +2004-09-30 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * Added a first set of test cases for the bignum module + * Corrected the namespace for the bignum module + +2004-09-29 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * Added the bignum module by Salvatore Sanfilippo. No test cases yet + +2004-09-23 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * 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 <arjenmarkus@users.sourceforge.net> + + * *.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 <arjenmarkus@users.sourceforge.net> + + * bessel.tcl: Better implementation of Bessel functions of integer + order. + +2004-09-09 Andreas Kupries <andreask@activestate.com> + + * calculus.man: Fixed problems in the calculus manpage introduced + by the last commit done yesterday. + +2004-09-08 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * calculus.tcl: added regula falsi method for finding roots + +2004-07-19 Andreas Kupries <andreask@activestate.com> + + * combinatorics.man: Polished minimally, name of manpage. + + * qcomplex.tcl: Polished minimally, changed package name + * qcomplex.man: to math::complexnumbers. + +2004-07-07 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * 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 <kennykb@acm.org> + + * 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 <kennykb@acm.org> + + * 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 <kennykb@acm.org> + + * 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 <andreask@activestate.com> + + * interpolate.man: Added a missing list_end before section + examples. Fixed usage of braces in the example as well. + +2004-06-16 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * added the modules complexnumbers, special, interpolate, constants + +2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + +2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.6 ======================== + * + +2004-02-09 Jeff Hobbs <jeffh@ActiveState.com> + + * combinatorics.tcl (::math::factorial): correct fac 171 + off-by-one and use of -strict in string is int|double. + +2003-12-22 Joe English <jenglish@users.sourceforge.net> + * calculus.man (rungeKuttaStep): Add missing argument + in function synopsis (bug report from Richard Body). + +2003-10-29 Arjen Markus <arjenmarkus@users.sourceforge.net> + + * 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 <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.4 ======================== + * + +2003-04-24 Andreas Kupries <andreask@activestate.com> + + * 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 <arjenmarkus@users.sourceforge.net> + + * 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 <andreask@activestate.com> + + * 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 <andreask@activestate.com> + + * optimize.test: Corrected errors in loading the functionality + under test, and of accessing tcltest. Now functional. + +2003-04-18 Joe English <jenglish@flightlab.com + + * optimize.man: fix minor markup errors that doctools and tmml + were complaining about. + +2003-04-16 Andreas Kupries <andreask@activestate.com> + + * 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 <andreas_kupries@users.sourceforge.net> + + * 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 <andreask@activestate.com> + + * combinatorics.man: + * math.man: + * math.tcl: + * pkgIndex.tcl: Set version of the package to to 1.2.2. + +2003-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * combinatorics.man: More semantic markup, less visual one. + * calculus.man: + +2002-06-03 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * 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 <arjenmarkus@users.sourceforge.net>. + +2002-05-08 Don Porter <dgp@users.sourceforge.net> + + * calculus.test: Corrected testing problems by namespace-ifying + the file. + +2002-04-15 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * combinatorics.man: Added doctools manpage. + * math.man: Added doctools manpage. + +2002-03-25 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * calculus.man: Fixed formatting errors in the doctools manpage. + +2002-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * 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 <andreas_kupries@users.sourceforge.net> + + * 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 <dgp@users.sourceforge.net> + + * 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 <andreas_kupries@users.sourceforge.net> + + * Bumped version to 1.2. + +2002-01-18 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * Added calculus functionality and fuzzy FP comparison as provided + by Arjen Markus <arjen.markus@wldelft.nl> 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 <kennykb@users.sourceforge.net> + + * combinatorics.tcl: Removed incorrect 'package provide'. + +2002-01-11 Kevin Kenny <kennykb@users.sourceforge.net> + + * 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 <andreas_kupries@users.sourceforge.net> + + * math.tcl: Fixed dubious code reported by frink. + +2000-10-06 Eric Melski <ericm@ajubasolutions.com> + + * math.test: + * math.n: + * math.tcl: Added ::math::fibonacci function, to compute numbers + in the Fibonacci sequence. + +2000-09-08 Eric Melski <ericm@ajubasolutions.com> + + * math.test: + * math.n: + * math.tcl: Added ::math::random function. + + * pkgIndex.tcl: Bumped version number to 1.1. + +2000-06-15 Eric Melski <ericm@scriptics.com> + + * math.n: + * math.test: + * math.tcl: Incorporated sigma, cov, stats, integrate functions + (from Philip Ehrens <pehrens@ligo.caltech.edu>). [RFE: 5060] + +2000-03-27 Eric Melski <ericm@scriptics.com> + + * math.n: + * math.test: + * math.tcl: Added sum, mean, and product functions (from Philip + Ehrens <pehrens@ligo.caltech.edu>). + +2000-03-09 Eric Melski <ericm@scriptics.com> + + * math.test: Adapted tests for use in/out of tcllib test framework. + +2000-03-07 Eric Melski <ericm@scriptics.com> + + * pkgIndex.tcl: + * math.tcl: + * math.test: + * math.n: Initial versions of files for math library. diff --git a/tcllib/modules/math/TODO b/tcllib/modules/math/TODO new file mode 100755 index 0000000..ae15a3b --- /dev/null +++ b/tcllib/modules/math/TODO @@ -0,0 +1,35 @@ +This file records outstanding actions for the math module + +dd. 26 april 2015, Arjen Markus +Add: +- additional linear algebra procedures by Federico Ferri +- lognormal income library by Eric Benedict +- empirical distribution +- tukey-duckworth test + + + +dd. 18 january 2014, Arjen Markus +test cases for kernel-density: +One test case is troublesome - uniform kernel, checking the total density + + +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 + diff --git a/tcllib/modules/math/bessel.tcl b/tcllib/modules/math/bessel.tcl new file mode 100755 index 0000000..811f242 --- /dev/null +++ b/tcllib/modules/math/bessel.tcl @@ -0,0 +1,194 @@ +# 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 +} diff --git a/tcllib/modules/math/bessel.test b/tcllib/modules/math/bessel.test new file mode 100755 index 0000000..f70768a --- /dev/null +++ b/tcllib/modules/math/bessel.test @@ -0,0 +1,81 @@ +# -*- 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 diff --git a/tcllib/modules/math/bigfloat.man b/tcllib/modules/math/bigfloat.man new file mode 100755 index 0000000..13113b2 --- /dev/null +++ b/tcllib/modules/math/bigfloat.man @@ -0,0 +1,432 @@ +[manpage_begin math::bigfloat n 2.0.1] +[keywords computations] +[keywords floating-point] +[keywords interval] +[keywords math] +[keywords multiprecision] +[keywords tcl] +[copyright {2004-2008, by Stephane Arnold <stephanearnold at yahoo dot fr>}] +[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] + +[vset CATEGORY {math :: bignum :: float}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/math/bigfloat.tcl b/tcllib/modules/math/bigfloat.tcl new file mode 100755 index 0000000..a86f339 --- /dev/null +++ b/tcllib/modules/math/bigfloat.tcl @@ -0,0 +1,2316 @@ +######################################################################## +# BigFloat for Tcl +# Copyright (C) 2003-2005 ARNOLD Stephane +# +# BIGFLOAT LICENSE TERMS +# +# This software is copyrighted by Stephane ARNOLD, (stephanearnold <at> 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<sqrt(2)/2 here too + return [sub $piOverTwo [_asin $x]] +} + + +################################################################################ +# returns A + B +################################################################################ +proc ::math::bigfloat::add {a b} { + checkNumber a b + if {[isInt $a]} { + if {[isInt $b]} { + # intAdd adds two BigInts + return [::math::bignum::add $a $b] + } + # adds the BigInt a to the BigFloat b + return [addInt2Float $b $a] + } + if {[isInt $b]} { + # ... and vice-versa + return [addInt2Float $a $b] + } + # retrieving parameters from A and B + foreach {dummy integerA expA deltaA} $a {break} + foreach {dummy integerB expB deltaB} $b {break} + # when we add two numbers which have different digit numbers (after the dot) + # for example : 1.0 and 0.00001 + # We promote the one with the less number of digits (1.0) to the same level as + # the other : so 1.00000. + # that is why we shift left the number which has the greater exponent + # But we do not forget the Delta parameter, which is lshift'ed too. + if {$expA>$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 1<x<2.4142 : (x-1)/(x+1)=1-2/(x+1) belongs to + # the range : ]0,1-2/3.414[ + # that equals ]0,0.414[ + set pi_sur_quatre [div [pi $precision 1] $four] + return [add $pi_sur_quatre [atan \ + [div [sub $x $float1] [add $x $float1]]]] + } + # atan(x)=Pi/2-atan(1/x) + # 1/x < 1/2.414 so the argument is lower than 0.414 + set pi_over_two [div [pi $precision 1] $two] + return [sub $pi_over_two [atan [div $float1 $x]]] + } + if {[compare $x [fromstr 0.4142]]>0} { + # 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<sqrt(2)-1 + # if we add an increment to the precision, say n: + # (sqrt(2)-1)^(2n-1)/(2n-1) has to be lower than 2^(-precision-n-1) + # (2n-1)*log(sqrt(2)-1)-log(2n-1)<-(precision+n+1)*log(2) + # 2n(log(sqrt(2)-1)-log(sqrt(2)))<-(precision-1)*log(2)+log(2n-1)+log(sqrt(2)-1) + # 2n*log(1-1/sqrt(2))<-(precision-1)*log(2)+log(2n-1)+log(2)/2 + # 2n/sqrt(2)>(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 <Pi/2 + set d [expr {[tostr $n]%4}] + # add trigonometric circle turns number to delta + set delta [::math::bignum::add [abs $n] $delta] + set signe 0 + # cos(Pi-x)=-cos(x) + # cos(-x)=cos(x) + # cos(Pi/2-x)=sin(x) + switch -- $d { + 1 {set signe 1;set l [_sin2 $integer $precision $delta]} + 2 {set signe 1;set l [_cos2 $integer $precision $delta]} + 0 {set l [_cos2 $integer $precision $delta]} + 3 {set l [_sin2 $integer $precision $delta]} + default {error "internal error"} + } + # precision -> 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<Pi/2 +# returns : a list formed with : +# 1. the mantissa +# 2. the precision (opposite of the exponent) +# 3. the uncertainty (doubt range) +################################################################################ +proc ::math::bigfloat::_cos2 {x precision delta} { + # precision bits after the dot + set pi [_pi $precision] + set pis4 [::math::bignum::rshift $pi 2] + set pis2 [::math::bignum::rshift $pi 1] + if {[::math::bignum::cmp $x $pis4]>=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<=x<Pi/4 +# returns : a list formed with : +# 1. the mantissa +# 2. the precision (opposite of the exponent) +# 3. the uncertainty (doubt range) +################################################################################ +proc ::math::bigfloat::_cos {x precision delta} { + variable zero + variable one + variable two + set float1 [::math::bignum::lshift $one $precision] + # Taylor development follows : + # cos(x)=1-x^2/2 + x^4/4! ... + (-1)^(2n)*x^(2n)/2n! + # cos(x)= 1 - x^2/1.2 * (1 - x^2/3.4 * (... * (1 - x^2/(2n.(2n-1))...)) + # variables : $s (the Mantissa of the result) + # $denom1 & $denom2 (2n-1 & 2n) + # $x as the square of what is named x in 'cos(x)' + set s $float1 + # 'd' is the uncertainty on x^2 + set d [::math::bignum::mul $x [::math::bignum::lshift $delta 1]] + set d [::math::bignum::add 1 [::math::bignum::rshift $d $precision]] + # x=x^2 (because in this Taylor development, there are only even powers of x) + set x [intMulShift $x $x $precision] + set denom1 $one + set denom2 $two + set t [opp [::math::bignum::rshift $x 1]] + set delta $zero + set dt $d + while {![::math::bignum::iszero $t]} { + set s [::math::bignum::add $s $t] + set delta [::math::bignum::add $delta $dt] + set denom1 [::math::bignum::add $denom1 $two] + set denom2 [::math::bignum::add $denom2 $two] + set dt [::math::bignum::rshift [::math::bignum::add [::math::bignum::mul $x $dt]\ + [::math::bignum::mul [::math::bignum::add $t $dt] $d]] $precision] + set dt [::math::bignum::add 1 $dt] + set t [intMulShift $x $t $precision] + set t [opp [::math::bignum::div $t [::math::bignum::mul $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] [::math::bignum::fromstr 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 [::math::bignum::lshift $integer 1] + set dpi [_pi $precision] + # modulo 2Pi + foreach {n integer} [::math::bignum::divqr $integer $dpi] {break} + # end modulo 2Pi + set pi [::math::bignum::rshift $dpi 1] + foreach {n integer} [::math::bignum::divqr $integer $pi] {break} + # now divide by Pi/2 + # multiply n by 2 + set n [::math::bignum::lshift $n 1] + # pis2=pi/2 + set pis2 [::math::bignum::rshift $pi 1] + foreach {m integer} [::math::bignum::divqr $integer $pis2] {break} + return [list [::math::bignum::add $n $m] [::math::bignum::rshift $integer 1]] +} + + +################################################################################ +# divide A by B and returns the result +# throw error : divide by zero +################################################################################ +proc ::math::bigfloat::div {a b} { + variable one + checkNumber a b + # dispatch to an appropriate procedure + if {[isInt $a]} { + if {[isInt $b]} { + return [::math::bignum::div $a $b] + } + error "trying to divide a BigInt 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 [::math::bignum::sub $integerB $deltaB] + set BMax [::math::bignum::add $integerB $deltaB] + if {[::math::bignum::cmp $BMin $BMax]>0} { + # 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 diff --git a/tcllib/modules/math/bigfloat.test b/tcllib/modules/math/bigfloat.test new file mode 100755 index 0000000..7fa05ed --- /dev/null +++ b/tcllib/modules/math/bigfloat.test @@ -0,0 +1,683 @@ +# -*- tcl -*- +######################################################################## +# BigFloat for Tcl +# Copyright (C) 2003-2005 ARNOLD Stephane +# +# BIGFLOAT LICENSE TERMS +# +# This software is copyrighted by Stephane ARNOLD, (stephanearnold <at> 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 diff --git a/tcllib/modules/math/bigfloat2.tcl b/tcllib/modules/math/bigfloat2.tcl new file mode 100644 index 0000000..60898c8 --- /dev/null +++ b/tcllib/modules/math/bigfloat2.tcl @@ -0,0 +1,2218 @@ +######################################################################## +# 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<sqrt(2)/2 here too + return [sub $piOverTwo [_asin $x]] +} + + +################################################################################ +# returns A + B +################################################################################ +proc ::math::bigfloat::add {a b} { + checkNumber $a + checkNumber $b + if {[isInt $a]} { + if {[isInt $b]} { + # intAdd adds two BigInts + return [incr a $b] + } + # adds the BigInt a to the BigFloat b + return [addInt2Float $b $a] + } + if {[isInt $b]} { + # ... and vice-versa + return [addInt2Float $a $b] + } + # retrieving parameters from A and B + foreach {dummy integerA expA deltaA} $a {break} + foreach {dummy integerB expB deltaB} $b {break} + if {$expA<$expB} { + foreach {dummy integerA expA deltaA} $b {break} + foreach {dummy integerB expB deltaB} $a {break} + } + # when we add two numbers which have different digit numbers (after the dot) + # for example : 1.0 and 0.00001 + # We promote the one with the less number of digits (1.0) to the same level as + # the other : so 1.00000. + # that is why we shift left the number which has the greater exponent + # But we do not forget the Delta parameter, which is lshift'ed too. + if {$expA>$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 1<x<2.4142 : (x-1)/(x+1)=1-2/(x+1) belongs to + # the range : ]0,1-2/3.414[ + # that equals ]0,0.414[ + set pi_sur_quatre [floatRShift [pi $precision 1] 2] + return [add $pi_sur_quatre [atan \ + [div [sub $x $float1] [add $x $float1]]]] + } + # atan(x)=Pi/2-atan(1/x) + # 1/x < 1/2.414 so the argument is lower than 0.414 + set pi_over_two [floatRShift [pi $precision 1]] + return [sub $pi_over_two [atan [div $float1 $x]]] + } + if {[compare $x [fromstr 0.4142]]>0} { + # 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<sqrt(2)-1 + # if we add an increment to the precision, say n: + # (sqrt(2)-1)^(2n-1)/(2n-1) has to be lower than 2^(-precision-n-1) + # (2n-1)*log(sqrt(2)-1)-log(2n-1)<-(precision+n+1)*log(2) + # 2n(log(sqrt(2)-1)-log(sqrt(2)))<-(precision-1)*log(2)+log(2n-1)+log(sqrt(2)-1) + # 2n*log(1-1/sqrt(2))<-(precision-1)*log(2)+log(2n-1)+log(2)/2 + # 2n/sqrt(2)>(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 <Pi/2 + set d [expr {$n%4}] + # add trigonometric circle turns number to delta + incr delta [expr {abs($n)}] + set signe 0 + # cos(Pi-x)=-cos(x) + # cos(-x)=cos(x) + # cos(Pi/2-x)=sin(x) + switch -- $d { + 1 {set signe 1;set l [_sin2 $integer $precision $delta]} + 2 {set signe 1;set l [_cos2 $integer $precision $delta]} + 0 {set l [_cos2 $integer $precision $delta]} + 3 {set l [_sin2 $integer $precision $delta]} + default {error "internal error"} + } + # precision -> 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<Pi/2 +# returns : a list formed with : +# 1. the mantissa +# 2. the precision (opposite of the exponent) +# 3. the uncertainty (doubt range) +################################################################################ +proc ::math::bigfloat::_cos2 {x precision delta} { + # precision bits after the dot + set pi [_pi $precision] + set pis2 [expr {$pi>>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<Pi/4 +# returns : a list formed with : +# 1. the mantissa +# 2. the precision (opposite of the exponent) +# 3. the uncertainty (doubt range) +################################################################################ +proc ::math::bigfloat::_cos {x precision delta} { + set float1 [expr {1<<$precision}] + # Taylor development follows : + # cos(x)=1-x^2/2 + x^4/4! ... + (-1)^(2n)*x^(2n)/2n! + # cos(x)= 1 - x^2/1.2 * (1 - x^2/3.4 * (... * (1 - x^2/(2n.(2n-1))...)) + # variables : $s (the Mantissa of the result) + # $denom1 & $denom2 (2n-1 & 2n) + # $x as the square of what is named x in 'cos(x)' + set s $float1 + # 'd' is the uncertainty on x^2 + set d [expr {$x*($delta<<1)}] + set d [expr {1+($d>>$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} { + set rc [catch { + expr {$n%2} + }] + return [expr {$rc == 0}] +} + + + +################################################################################ +# 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.2 diff --git a/tcllib/modules/math/bigfloat2.test b/tcllib/modules/math/bigfloat2.test new file mode 100644 index 0000000..0177d6d --- /dev/null +++ b/tcllib/modules/math/bigfloat2.test @@ -0,0 +1,641 @@ +# -*- 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. + + ################################################################################ + # tests for isInt - ticket 3309165 + ################################################################################ + assert isInt $version.0 {isInt 12345678901234} 1 + assert isInt $version.1 {isInt 12345678901234.0} 0 + assert isInt $version.1 {isInt not-a-number} 0 +} + +testSuite +################################################################################ +# end of testsuite for bigfloat 2.0 +################################################################################ +# cleanup global procs +rename assert "" +rename fassert "" +rename Zero "" + +testsuiteCleanup + +set ::tcl_precision $old_precision + + diff --git a/tcllib/modules/math/bignum.man b/tcllib/modules/math/bignum.man new file mode 100755 index 0000000..26d0867 --- /dev/null +++ b/tcllib/modules/math/bignum.man @@ -0,0 +1,228 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin math::bignum n 3.1] +[keywords bignums] +[keywords math] +[keywords multiprecision] +[keywords tcl] +[copyright {2004 Salvatore Sanfilippo <antirez at invece dot org>}] +[copyright {2004 Arjen Markus <arjenmarkus at users dot sourceforge dot net>}] +[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] + +[vset CATEGORY {math :: bignum}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/math/bignum.tcl b/tcllib/modules/math/bignum.tcl new file mode 100755 index 0000000..38e1fbb --- /dev/null +++ b/tcllib/modules/math/bignum.tcl @@ -0,0 +1,900 @@ +# bignum library in pure Tcl [VERSION 7Sep2004] +# Copyright (C) 2004 Salvatore Sanfilippo <antirez at invece dot org> +# Copyright (C) 2004 Arjen Markus <arjen dot markus at wldelft dot nl> +# +# LICENSE +# +# This software is: +# Copyright (C) 2004 Salvatore Sanfilippo <antirez at invece dot org> +# Copyright (C) 2004 Arjen Markus <arjen dot markus at wldelft dot nl> +# 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 <sign> <atom0> ... <atomN>] +# 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> 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 diff --git a/tcllib/modules/math/bignum.test b/tcllib/modules/math/bignum.test new file mode 100755 index 0000000..7183361 --- /dev/null +++ b/tcllib/modules/math/bignum.test @@ -0,0 +1,587 @@ +# -*- 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 diff --git a/tcllib/modules/math/calculus.CHANGES b/tcllib/modules/math/calculus.CHANGES new file mode 100755 index 0000000..fb50f34 --- /dev/null +++ b/tcllib/modules/math/calculus.CHANGES @@ -0,0 +1,21 @@ +Package: 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 diff --git a/tcllib/modules/math/calculus.README b/tcllib/modules/math/calculus.README new file mode 100755 index 0000000..771e08c --- /dev/null +++ b/tcllib/modules/math/calculus.README @@ -0,0 +1,21 @@ +Package: 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://core.tcl.tk/tcllib + +Please contact Arjen Markus (arjen.markus@wldelft.nl) for questions, +bug reports, enhancements and so on. diff --git a/tcllib/modules/math/calculus.doc b/tcllib/modules/math/calculus.doc new file mode 100755 index 0000000..62fdd0a --- /dev/null +++ b/tcllib/modules/math/calculus.doc @@ -0,0 +1,311 @@ +[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] diff --git a/tcllib/modules/math/calculus.man b/tcllib/modules/math/calculus.man new file mode 100755 index 0000000..2bad0b7 --- /dev/null +++ b/tcllib/modules/math/calculus.man @@ -0,0 +1,451 @@ +[vset VERSION 0.8.1] +[manpage_begin math::calculus n [vset VERSION]] +[see_also romberg] +[keywords calculus] +[keywords {differential equations}] +[keywords integration] +[keywords math] +[keywords roots] +[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 [vset VERSION]] +[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::qk15] [arg xstart] [arg xend] [arg func] [arg nosteps]] +Determine the integral of the given function using the Gauss-Kronrod 15 points quadrature rule. +The returned value is the estimate of the integral over the interval [lb][arg xstart], [arg xend][rb]. +The remaining arguments are: + +[list_begin definitions] +[def [arg func]] +Function to be integrated. It should take one single argument. + +[def [opt nosteps]] +Number of steps in which the interval is divided. Defaults to 1. +[list_end] +[para] + +[call [cmd ::math::calculus::qk15_detailed] [arg xstart] [arg xend] [arg func] [arg nosteps]] +Determine the integral of the given function using the Gauss-Kronrod 15 points quadrature rule. +The interval for the integration is [lb][arg xstart], [arg xend][rb]. +The procedure returns a list of four values: +[list_begin itemized] +[item] +The estimate of the integral over the specified interval (I). +[item] +An estimate of the absolute error in I. +[item] +The estimate of the integral of the absolute value of the function over the interval. +[item] +The estimate of the integral of the absolute value of the function minus its mean over the interval. +[list_end] +The remaining arguments are: + +[list_begin definitions] +[def [arg func]] +Function to be integrated. It should take one single argument. + +[def [opt nosteps]] +Number of steps in which the interval is divided. Defaults to 1. +[list_end] +[para] + +[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] + +[vset CATEGORY {math :: calculus}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/math/calculus.tcl b/tcllib/modules/math/calculus.tcl new file mode 100755 index 0000000..5667a6c --- /dev/null +++ b/tcllib/modules/math/calculus.tcl @@ -0,0 +1,1645 @@ +# 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.8.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 \ + qk15 qk15_detailed \ + 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 $tcorr $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<gamma<1) of the singularity +# 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 is expected to have an integrable +# power law singularity at the lower endpoint; that is, the +# integrand is expected to diverge as (x-a)**gamma. +# 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. +# +# The 'romberg_sqrtSingLower' procedure is a wrapper for 'romberg' +# for integrating a function with an integrable power law singularity +# at the lower bound of the interval. It works by making the change +# of variable u = (x-a)**(1-gamma). +# +#---------------------------------------------------------------------- + +proc ::math::calculus::romberg_powerLawLower { gamma f a b args } { + if { ![string is double -strict $gamma] } { + return -code error [expectDouble $gamma] + } + if { $gamma <= 0.0 || $gamma >= 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<gamma<1) of the singularity +# 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 is expected to have an integrable +# power law singularity at the upper endpoint; that is, the +# integrand is expected to diverge as (b-x)**gamma. +# 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. +# +# The 'romberg_PowerLawUpper' procedure is a wrapper for 'romberg' +# for integrating a function with an integrable power law singularity +# at the upper bound of the interval. It works by making the change +# of variable u = (b-x)**(1-gamma). +# +#---------------------------------------------------------------------- + +proc ::math::calculus::romberg_powerLawUpper { gamma f a b args } { + if { ![string is double -strict $gamma] } { + return -code error [expectDouble $gamma] + } + if { $gamma <= 0.0 || $gamma >= 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 +} + +# + +# qk15_basic -- +# Apply the QK15 rule to a single interval and return all results +# +# Arguments: +# f Function to integrate (name of procedure) +# xstart Start of the interval +# xend End of the interval +# +# Returns: +# List of the following: +# result Estimated integral (I) of function f +# abserr Estimate of the absolute error in "result" +# resabs Estimated integral of the absolute value of f +# resasc Estimated integral of abs(f - I/(xend-xstart)) +# +# Note: +# Translation of the 15-point Gauss-Kronrod rule (QK15) as found +# in the SLATEC library (QUADPACK) into Tcl. +# +namespace eval ::math::calculus { + variable qk15_xgk + variable qk15_wgk + variable qk15_wg + + set qk15_xgk { + 0.9914553711208126e+00 0.9491079123427585e+00 + 0.8648644233597691e+00 0.7415311855993944e+00 + 0.5860872354676911e+00 0.4058451513773972e+00 + 0.2077849550078985e+00 0.0e+00 } + set qk15_wgk { + 0.2293532201052922e-01 0.6309209262997855e-01 + 0.1047900103222502e+00 0.1406532597155259e+00 + 0.1690047266392679e+00 0.1903505780647854e+00 + 0.2044329400752989e+00 0.2094821410847278e+00} + set qk15_wg { + 0.1294849661688697e+00 0.2797053914892767e+00 + 0.3818300505051189e+00 0.4179591836734694e+00} +} + +if {[package vsatisfies [package present Tcl] 8.5]} { + proc ::math::calculus::Min {a b} { expr {min ($a, $b)} } + proc ::math::calculus::Max {a b} { expr {max ($a, $b)} } +} else { + proc ::math::calculus::Min {a b} { if {$a < $b} { return $a } else { return $b }} + proc ::math::calculus::Max {a b} { if {$a > $b} { return $a } else { return $b }} +} + +proc ::math::calculus::qk15_basic {xstart xend func} { + variable qk15_wg + variable qk15_wgk + variable qk15_xgk + + # + # Use fixed values for epmach and uflow: + # - epmach is the largest relative spacing. + # - uflow is the smallest positive magnitude. + + set epmach [expr {2.3e-308}] + set uflow [expr {1.2e-16}] + + set centr [expr {0.5e+00*($xstart+$xend)}] + set hlgth [expr {0.5e+00*($xend-$xstart)}] + set dhlgth [expr {abs($hlgth)}] + + # + # Compute the 15-point Kronrod approximation to + # the integral, and estimate the absolute error. + # + set fc [uplevel 2 $func $centr] + set resg [expr {$fc*[lindex $qk15_wg 3]}] + set resk [expr {$fc*[lindex $qk15_wgk 7]}] + set resabs [expr {abs($resk)}] + + set fv1 [lrepeat 7 0.0] + set fv2 [lrepeat 7 0.0] + + for {set j 0} {$j < 3} {incr j} { + set jtw [expr {$j*2 +1}] + set absc [expr {$hlgth*[lindex $qk15_xgk $jtw]}] + set fval1 [uplevel 2 $func [expr {$centr-$absc}]] + set fval2 [uplevel 2 $func [expr {$centr+$absc}]] + lset fv1 $jtw $fval1 + lset fv2 $jtw $fval2 + set fsum [expr {$fval1+$fval2}] + set resg [expr {$resg+[lindex $qk15_wg $j]*$fsum}] + set resk [expr {$resk+[lindex $qk15_wgk $jtw]*$fsum}] + set resabs [expr {$resabs+[lindex $qk15_wgk $jtw]*(abs($fval1)+abs($fval2))}] + } + for {set j 0} {$j < 4} {incr j} { + set jtwm1 [expr {$j*2}] + set absc [expr {$hlgth*[lindex $qk15_xgk $jtwm1]}] + set fval1 [uplevel 2 $func [expr {$centr-$absc}]] + set fval2 [uplevel 2 $func [expr {$centr+$absc}]] + lset fv1 $jtwm1 $fval1 + lset fv2 $jtwm1 $fval2 + set fsum [expr {$fval1+$fval2}] + set resk [expr {$resk+[lindex $qk15_wgk $jtwm1]*$fsum}] + set resabs [expr {$resabs+[lindex $qk15_wgk $jtwm1]*(abs($fval1)+abs($fval2))}] + } + + set reskh [expr {$resk*0.5e+00}] + set resasc [expr {[lindex $qk15_wgk 7]*abs($fc-$reskh)}] + + for {set j 0} {$j < 7} {incr j} { + set wgk [lindex $qk15_wgk $j] + set FV1 [lindex $fv1 $j] + set FV2 [lindex $fv2 $j] + set resasc [expr {$resasc+$wgk*(abs($FV1-$reskh)+abs($FV2-$reskh))}] + } + + set result [expr {$resk*$hlgth}] + set resabs [expr {$resabs*$dhlgth}] + set resasc [expr {$resasc*$dhlgth}] + set abserr [expr {abs(($resk-$resg)*$hlgth)}] + if { $resasc != 0.0e+00 && $abserr != 0.0e+00 } { + set abserr [expr {$resasc*[Min 0.1e+01 [expr {pow((0.2e+3*$abserr/$resasc),1.5e+00)}]]}] + } + if { $resabs > $uflow/(0.5e+02*$epmach) } { + set abserr [Max [expr {($epmach*0.5e+02)*$resabs}] $abserr] + } + + return [list $result $abserr $resabs $resasc] +} + +# qk15 -- +# Apply the QK15 rule to an interval and return the estimated integral +# +# Arguments: +# xstart Start of the interval +# xend End of the interval +# func Function to integrate (name of procedure) +# n Number of subintervals (default: 1) +# +# Returns: +# Estimated integral of function func +# +proc ::math::calculus::qk15 {xstart xend func {n 1}} { + if { $n == 1 } { + return [lindex [qk15_basic $xstart $xend $func] 0] + } else { + set dx [expr {($xend-$xstart)/double($n)}] + set result 0.0 + for {set i 0} {$i < $n} {incr i} { + set xb [expr {$xstart + $dx * $i}] + set xe [expr {$xstart + $dx * ($i+1)}] + + set result [expr {$result + [lindex [qk15_basic $xb $xe $func] 0]}] + } + } + + return $result +} + +# qk15_detailed -- +# Apply the QK15 rule to an interval and return the estimated integral +# as well as the other values +# +# Arguments: +# xstart Start of the interval +# xend End of the interval +# func Function to integrate (name of procedure) +# n Number of subintervals (default: 1) +# +# Returns: +# List of the following: +# result Estimated integral (I) of function func +# abserr Estimate of the absolute error in "result" +# resabs Estimated integral of the absolute value of f +# resasc Estimated integral of abs(f - I/(xend-xstart)) +# +proc ::math::calculus::qk15_detailed {xstart xend func {n 1}} { + if { $n == 1 } { + return [qk15_basic $xstart $xend $func] + } else { + set dx [expr {($xend-$xstart)/double($n)}] + set result 0.0 + set abserr 0.0 + set resabs 0.0 + set resasc 0.0 + for {set i 0} {$i < $n} {incr i} { + set xb [expr {$xstart + $dx * $i}] + set xe [expr {$xstart + $dx * ($i+1)}] + + foreach {dresult dabserr dresabs dresasc} [qk15_basic $xb $xe $func] break + set result [expr {$result + $dresult}] + set abserr [expr {$abserr + $dabserr}] + set resabs [expr {$resabs + $dresabs}] + set resasc [expr {$resasc + $dresasc}] + } + } + + return [list $result $abserr $resabs $resasc] +} diff --git a/tcllib/modules/math/calculus.test b/tcllib/modules/math/calculus.test new file mode 100755 index 0000000..a1cdf6e --- /dev/null +++ b/tcllib/modules/math/calculus.test @@ -0,0 +1,680 @@ +# 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}]] + +proc fcos {x} { + expr {cos($x)} +} + +test "integrateQk15-1.0" "Integration according to Gauss-Kronrod quadrature" \ + -match numbers -body { + set x [::math::calculus::qk15 0.0 10.0 fcos] +} -result -0.5440211108893682 + +test "integrateQk15-1.1" "Integration according to Gauss-Kronrod quadrature (10 steps)" \ + -match numbers -body { + set x [::math::calculus::qk15 0.0 10.0 fcos 10] +} -result -0.5440211108893697 + + +test "integrateQk15-1.2" "Integration according to Gauss-Kronrod quadrature (with details)" \ + -match numbers -body { + set x [::math::calculus::qk15_detailed 0.0 10.0 fcos 10] +} -result {-0.5440211108893697 6.577401743379832e-20 6.543992515206541 1.533698345844891} + + +# End of test cases +testsuiteCleanup + +set ::tcl_precision $prec + +testsuiteCleanup +} + +namespace delete ::math::calculus::test + +# Local Variables: +# mode: tcl +# End: diff --git a/tcllib/modules/math/calculus.testscript b/tcllib/modules/math/calculus.testscript new file mode 100755 index 0000000..81dd091 --- /dev/null +++ b/tcllib/modules/math/calculus.testscript @@ -0,0 +1,86 @@ +# 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] diff --git a/tcllib/modules/math/classic_polyns.tcl b/tcllib/modules/math/classic_polyns.tcl new file mode 100755 index 0000000..1fd9cd0 --- /dev/null +++ b/tcllib/modules/math/classic_polyns.tcl @@ -0,0 +1,200 @@ +# 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 +} diff --git a/tcllib/modules/math/combinatorics.man b/tcllib/modules/math/combinatorics.man new file mode 100644 index 0000000..4673e99 --- /dev/null +++ b/tcllib/modules/math/combinatorics.man @@ -0,0 +1,108 @@ +[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] + +[vset CATEGORY math] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/math/combinatorics.tcl b/tcllib/modules/math/combinatorics.tcl new file mode 100644 index 0000000..fdc61d5 --- /dev/null +++ b/tcllib/modules/math/combinatorics.tcl @@ -0,0 +1,441 @@ +#---------------------------------------------------------------------- +# +# 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 +} diff --git a/tcllib/modules/math/combinatorics.test b/tcllib/modules/math/combinatorics.test new file mode 100644 index 0000000..1ea0efc --- /dev/null +++ b/tcllib/modules/math/combinatorics.test @@ -0,0 +1,323 @@ +# 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 + diff --git a/tcllib/modules/math/constants.man b/tcllib/modules/math/constants.man new file mode 100755 index 0000000..9d95870 --- /dev/null +++ b/tcllib/modules/math/constants.man @@ -0,0 +1,136 @@ +[comment {-*- tcl -*- doctools manpage}] +[vset VERSION 1.0.2] +[manpage_begin math::constants n [vset VERSION]] +[keywords constants] +[keywords degrees] +[keywords e] +[keywords math] +[keywords pi] +[keywords radians] +[copyright {2004 Arjen Markus <arjenmarkus@users.sourceforge.net>}] +[moddesc {Tcl Math Library}] +[titledesc {Mathematical and numerical constants}] +[category Mathematics] +[require Tcl [opt 8.3]] +[require math::constants [opt [vset VERSION]]] + +[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] + +The full set of named constants is listed in section [sectref Constants]. + +[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 "Constants"] +[list_begin definitions] +[def [const pi]] Ratio of circle circumference to diameter +[def [const e]] Base for natural logarithm +[def [const ln10]] Natural logarithm of 10 +[def [const phi]] Golden ratio +[def [const gamma]] Euler's constant +[def [const sqrt2]] Square root of 2 +[def [const thirdrt2]] One-third power of 2 +[def [const sqrt3]] Square root of 3 +[def [const radtodeg]] Conversion from radians to degrees +[def [const degtorad]] Conversion from degrees to radians +[def [const onethird]] One third (0.3333....) +[def [const twothirds]]Two thirds (0.6666....) +[def [const onesixth]] One sixth (0.1666....) +[def [const huge]] (Approximately) largest number +[def [const tiny]] (Approximately) smallest number not equal zero +[def [const eps]] Smallest number such that 1+eps != 1 +[list_end] + +[vset CATEGORY {math :: constants}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/math/constants.tcl b/tcllib/modules/math/constants.tcl new file mode 100755 index 0000000..79e6ea5 --- /dev/null +++ b/tcllib/modules/math/constants.tcl @@ -0,0 +1,205 @@ +# 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.2 + +# 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.6666....)" + 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 +} diff --git a/tcllib/modules/math/constants.test b/tcllib/modules/math/constants.test new file mode 100755 index 0000000..280fb8c --- /dev/null +++ b/tcllib/modules/math/constants.test @@ -0,0 +1,56 @@ +# -*- 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 diff --git a/tcllib/modules/math/decimal.man b/tcllib/modules/math/decimal.man new file mode 100755 index 0000000..a2b7ab4 --- /dev/null +++ b/tcllib/modules/math/decimal.man @@ -0,0 +1,199 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin math::decimal n 1.0.3] +[keywords decimal] +[keywords math] +[keywords tcl] +[copyright {2011 Mark Alston <mark at beernut dot com>}] +[moddesc {Tcl Decimal Arithmetic Library}] +[titledesc {General decimal arithmetic}] +[category Mathematics] +[require Tcl [opt 8.5]] +[require math::decimal 1.0.3] + +[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] + +[vset CATEGORY decimal] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/math/decimal.tcl b/tcllib/modules/math/decimal.tcl new file mode 100755 index 0000000..6505fed --- /dev/null +++ b/tcllib/modules/math/decimal.tcl @@ -0,0 +1,1741 @@ +package require Tcl 8.5 +package provide math::decimal 1.0.3 +# +# Copyright 2011, 2013 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) }] + set exponent [expr {-1 * $digits}] + } 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) }] + set exponent [expr {-1 * $digits}] + } 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) }] + set exponent [expr {-1 * $digits}] + } 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 + } +} diff --git a/tcllib/modules/math/decimal.test b/tcllib/modules/math/decimal.test new file mode 100755 index 0000000..bc68dfd --- /dev/null +++ b/tcllib/modules/math/decimal.test @@ -0,0 +1,45 @@ +# -*- 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
diff --git a/tcllib/modules/math/elliptic.tcl b/tcllib/modules/math/elliptic.tcl new file mode 100755 index 0000000..e123318 --- /dev/null +++ b/tcllib/modules/math/elliptic.tcl @@ -0,0 +1,242 @@ +# 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 +} + diff --git a/tcllib/modules/math/elliptic.test b/tcllib/modules/math/elliptic.test new file mode 100755 index 0000000..fee0b5e --- /dev/null +++ b/tcllib/modules/math/elliptic.test @@ -0,0 +1,78 @@ +# -*- 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 diff --git a/tcllib/modules/math/exact.man b/tcllib/modules/math/exact.man new file mode 100644 index 0000000..5c46e0f --- /dev/null +++ b/tcllib/modules/math/exact.man @@ -0,0 +1,218 @@ +[manpage_begin math::exact n 1.0] +[copyright "2015 Kevin B. Kenny <kennykb@acm.org> +Redistribution permitted under the terms of the Open\ +Publication License <http://www.opencontent.org/openpub/>"] +[moddesc {Tcl Math Library}] +[titledesc {Exact Real Arithmetic}] +[category Mathematics] +[require Tcl 8.6] +[require grammar::aycock 1.0] +[require math::exact 1.0] +[description] +[para] +The [cmd exactexpr] command in the [cmd math::exact] package +allows for exact computations over the computable real numbers. +These are not arbitrary-precision calculations; rather they are +exact, with numbers represented by algorithms that produce successive +approximations. At the end of a calculation, the caller can +request a given precision for the end result, and intermediate results are +computed to whatever precision is necessary to satisfy the request. +[section "Procedures"] +The following procedure is the primary entry into the [cmd math::exact] +package. +[list_begin definitions] +[call [cmd ::math::exact::exactexpr] [arg expr]] + +Accepts a mathematical expression in Tcl syntax, and returns an object +that represents the program to calculate successive approximations to +the expression's value. The result will be referred to as an +exact real number. + +[call [arg number] [cmd ref]] + +Increases the reference count of a given exact real number. + +[call [arg number] [cmd unref]] + +Decreases the reference count of a given exact real number, and destroys +the number if the reference count is zero. + +[call [arg number] [cmd asPrint] [arg precision]] + +Formats the given [arg number] for printing, with the specified [arg precision]. +(See below for how [arg precision] is interpreted). Numbers that are known to +be rational are formatted as fractions. + +[call [arg number] [cmd asFloat] [arg precision]] + +Formats the given [arg number] for printing, with the specified [arg precision]. +(See below for how [arg precision] is interpreted). All numbers are formatted +in floating-point E format. + +[list_end] + +[section Parameters] + +[list_begin definitions] + +[def [arg expr]] + +Expression to evaluate. The syntax for expressions is the same as it is in Tcl, +but the set of operations is smaller. See [sectref Expressions] below +for details. + +[def [arg number]] + +The object returned by an earlier invocation of [cmd math::exact::exactexpr] + +[def [arg precision]] + +The requested 'precision' of the result. The precision is (approximately) +the absolute value of the binary exponent plus the number of bits of the +binary significand. For instance, to return results to IEEE-754 double +precision, 56 bits plus the exponent are required. Numbers between 1/2 and 2 +will require a precision of 57; numbers between 1/4 and 1/2 or between 2 and 4 +will require 58; numbers between 1/8 and 1/4 or between 4 and 8 will require +59; and so on. + +[list_end] + +[section Expressions] + +The [cmd math::exact::exactexpr] command accepts expressions in a subset +of Tcl's syntax. The following components may be used in an expression. + +[list_begin itemized] + +[item]Decimal integers. +[item]Variable references with the dollar sign ([const \$]). +The value of the variable must be the result of another call to +[cmd math::exact::exactexpr]. The reference count of the value +will be increased by one for each position at which it appears +in the expression. +[item]The exponentiation operator ([const **]). +[item]Unary plus ([const +]) and minus ([const -]) operators. +[item]Multiplication ([const *]) and division ([const /]) operators. +[item]Parentheses used for grouping. +[item]Functions. See [sectref Functions] below for the functions that are +available. + +[list_end] + +[section Functions] + +The following functions are available for use within exact real expressions. + +[list_begin definitions] + + +[def [const acos(][arg x][const )]] +The inverse cosine of [arg x]. The result is expressed in radians. +The absolute value of [arg x] must be less than 1. + +[def [const acosh(][arg x][const )]] +The inverse hyperbolic cosine of [arg x]. +[arg x] must be greater than 1. + +[def [const asin(][arg x][const )]] +The inverse sine of [arg x]. The result is expressed in radians. +The absolute value of [arg x] must be less than 1. + +[def [const asinh(][arg x][const )]] +The inverse hyperbolic sine of [arg x]. + +[def [const atan(][arg x][const )]] +The inverse tangent of [arg x]. The result is expressed in radians. + +[def [const atanh(][arg x][const )]] +The inverse hyperbolic tangent of [arg x]. +The absolute value of [arg x] must be less than 1. + +[def [const cos(][arg x][const )]] +The cosine of [arg x]. [arg x] is expressed in radians. + +[def [const cosh(][arg x][const )]] +The hyperbolic cosine of [arg x]. + +[def [const e()]] +The base of the natural logarithms = [const 2.71828...] + +[def [const exp(][arg x][const )]] +The exponential function of [arg x]. + +[def [const log(][arg x][const )]] +The natural logarithm of [arg x]. [arg x] must be positive. + +[def [const pi()]] +The value of pi = [const 3.15159...] + +[def [const sin(][arg x][const )]] +The sine of [arg x]. [arg x] is expressed in radians. + +[def [const sinh(][arg x][const )]] +The hyperbolic sine of [arg x]. + +[def [const sqrt(][arg x][const )]] +The square root of [arg x]. [arg x] must be positive. + +[def [const tan(][arg x][const )]] +The tangent of [arg x]. [arg x] is expressed in radians. + +[def [const tanh(][arg x][const )]] +The hyperbolic tangent of [arg x]. + +[list_end] + +[section Summary] + +The [cmd math::exact::exactexpr] command provides a system that +performs exact arithmetic over computable real numbers, representing +the numbers as algorithms for successive approximation. + +An example, which implements the high-school quadratic formula, +is shown below. + +[example { +namespace import math::exact::exactexpr +proc exactquad {a b c} { + set d [[exactexpr {sqrt($b*$b - 4*$a*$c)}] ref] + set r0 [[exactexpr {(-$b - $d) / (2 * $a)}] ref] + set r1 [[exactexpr {(-$b + $d) / (2 * $a)}] ref] + $d unref + return [list $r0 $r1] +} + +set a [[exactexpr 1] ref] +set b [[exactexpr 200] ref] +set c [[exactexpr {(-3/2) * 10**-12}] ref] +lassign [exactquad $a $b $c] r0 r1 +$a unref; $b unref; $c unref +puts [list [$r0 asFloat 70] [$r1 asFloat 110]] +$r0 unref; $r1 unref +}] + +The program prints the result: +[example { +-2.000000000000000075e2 7.499999999999999719e-15 +}] + +Note that if IEEE-754 floating point had been used, a catastrophic +roundoff error would yield a smaller root that is a factor of two +too high: + +[example { +-200.0 1.4210854715202004e-14 +}] + +The invocations of [cmd exactexpr] should be fairly self-explanatory. +The other commands of note are [cmd ref] and [cmd unref]. It is necessary +for the caller to keep track of references to exact expressions - to call +[cmd ref] every time an exact expression is stored in a variable and +[cmd unref] every time the variable goes out of scope or is overwritten. + +The [cmd asFloat] method emits decimal digits as long as the requested +precision supports them. It terminates when the requested precision +yields an uncertainty of more than one unit in the least significant digit. + +[vset CATEGORY mathematics] +[manpage_end] diff --git a/tcllib/modules/math/exact.tcl b/tcllib/modules/math/exact.tcl new file mode 100644 index 0000000..177c3df --- /dev/null +++ b/tcllib/modules/math/exact.tcl @@ -0,0 +1,4059 @@ +# exact.tcl -- +# +# Tcl package for exact real arithmetic. +# +# Copyright (c) 2015 by Kevin B. Kenny +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# This package provides a library for performing exact +# computations over the computable real numbers. The algorithms +# are largely based on the ones described in: +# +# Potts, Peter John. _Exact Real Arithmetic using Möbius Transformations._ +# PhD thesis, University of London, July 1998. +# http://www.doc.ic.ac.uk/~ae/papers/potts-phd.pdf +# +# Some of the algorithms for the elementary functions are found instead +# in: +# +# Menissier-Morain, Valérie. _Arbitrary Precision Real Arithmetic: +# Design and Algorithms. J. Symbolic Computation 11 (1996) +# http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.31.8983 +# +#----------------------------------------------------------------------------- + +package require Tcl 8.6 +package require grammar::aycock 1.0 + +namespace eval math::exact { + + namespace eval function { + namespace path ::math::exact + } + namespace path ::tcl::mathop + + # math::exact::parser -- + # + # Grammar for parsing expressions in the exact real calculator + # + # The expression syntax is almost exactly that of Tcl expressions, + # minus Tcl arrays, square-bracket substitution, and noncomputable + # operations such as equality, comparisons, bit and Boolean operations, + # and ?:. + + variable parser [grammar::aycock::parser { + + target ::= expression { + lindex $_ 0 + } + + expression ::= expression addop term { + {*}$_ + } + expression ::= term { + lindex $_ 0 + } + addop ::= + { + lindex $_ 0 + } + addop ::= - { + lindex $_ 0 + } + + term ::= term mulop factor { + {*}$_ + } + term ::= factor { + lindex $_ 0 + } + mulop ::= * { + lindex $_ 0 + } + mulop ::= / { + lindex $_ 0 + } + + factor ::= addop factor { + switch -exact -- [lindex $_ 0] { + + { + set result [lindex $_ 1] + } + - { + set result [[lindex $_ 1] U-] + } + } + set result + } + factor ::= primary ** factor { + {*}$_ + } + factor ::= primary { + lindex $_ 0 + } + + primary ::= {$} bareword { + uplevel [dict get $clientData caller] set [lindex $_ 1] + } + primary ::= number { + [dict get $clientData namespace]::V new [list [lindex $_ 0] 1] + } + primary ::= bareword ( ) { + [dict get $clientData namespace]::function::[lindex $_ 0] + } + primary ::= bareword ( arglist ) { + [dict get $clientData namespace]::function::[lindex $_ 0] \ + {*}[lindex $_ 2] + } + primary ::= ( expression ) { + lindex $_ 1 + } + arglist ::= expression { + set _ + } + arglist ::= arglist , expression { + linsert [lindex $_ 0] end [lindex $_ 2] + } + + }] +} + +# math::exact::Lexer -- +# +# Lexer for the arithmetic expressions that the 'math::exact' package +# can evaluate. +# +# 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::exact::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 {^([[: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 EXACT EXPR INVCHAR \ + [string index $expression 0]] \ + [list invalid character [string index $expression 0]] \ + } + set expression $rest + } + return [list $tokens $values] +} + +# math::exact::K -- +# +# K combinator. Returns its first argumetn +# +# Parameters: +# a - Return value +# b - Value to discard +# +# Results: +# Returns the first argument + +proc math::exact::K {a b} {return $a} + +# math::exact::exactexpr -- +# +# Evaluates an exact real expression. +# +# Parameters: +# expr - Expression to evaluate. Variables in the expression are +# assumed to be reals, which are represented as Tcl objects. +# +# Results: +# Returns a Tcl object representing the expression's value. +# +# The returned object must have its refcount incremented with [ref] if +# the caller retains a reference, and in general it is expected that a +# user of a real will [ref] the object when storing it in a variable and +# [unref] it again when the variable goes out of scope or is overwritten. + +proc math::exact::exactexpr {expr} { + variable parser + set result [$parser parse {*}[Lexer $expr] \ + [dict create \ + caller "#[expr {[info level] - 1}]" \ + namespace [namespace current]]] +} + +# Basic data types + +# A vector is a list {a b}. It can represent the rational number {a/b} + +# A matrix is a list of its columns {{a b} {c d}}. In addition to +# the ordinary rules of linear algebra, it represents the linear +# transform (ax+b)/(cx+d). + +# If x is presumed to lie in the interval [0, Inf) then this transform +# applied to x will lie in the interval [b/d, a/c), so the matrix +# {{a b} {c d}} can represent that interval. The interval [0,Inf) +# can be represented by the identity matrix {{1 0} {0 1}} + +# Moreover, if x = {p/q} is a rational number, then +# (ax+b)/(cx+d) = (a(p/q)+b)/(c(p/q)+d) +# = ((ap+bq)/q)/(cp+dq)/q) +# = (ap+bq)/(cp+dq) +# which is the rational number represented by {{a c} {b d}} {p q} +# using the conventional rule of vector-matrix multiplication. + +# Note that matrices used for this purpose are unique only up to scaling. +# If (ax+b)/(cx+d) is a rational number, then (eax+eb)/(ecx+ed) represents +# the same rational number. This means that matrix inversion may be replaced +# by matrix reversion: for {{a b} {c d}}, simply form the list of cofactors +# {{d -b} {-c a}}, without dividing by the determinant. The reverse of a matrix +# is well defined even if the matrix is singular. + +# A tensor of the third degree is a list of its levels: +# {{{a b} {c d}} {{e f} {g h}}} + +# math::exact::gcd -- +# +# Greatest common divisor of a set of integers +# +# Parameters: +# The integers whose gcd is to be found +# +# Results: +# Returns the gcd + +proc math::exact::gcd {a args} { + foreach b $args { + if {$a > $b} { + set t $b; set b $a; set a $t + } + while {$b > 0} { + set t $b + set b [expr {$a % $b}] + set a $t + } + } + return $a +} + +# math::exact::trans -- +# +# Transposes a 2x2 matrix or a 2x2x2 tensor +# +# Parameters: +# x - Object to transpose +# +# Results: +# Returns the transpose + +proc math::exact::trans {x} { + lassign $x ab cd + lassign $ab a b + lassign $cd c d + tailcall list [list $a $c] [list $b $d] +} + +# math::exact::determinant -- +# +# Calculates the determinant of a 2x2 matrix +# +# Parameters: +# x - Matrix +# +# Results: +# Returns the determinant. + +proc math::exact::determinant {x} { + lassign $x ab cd + lassign $ab a b + lassign $cd c d + return [expr {$a*$d - $b*$c}] +} + +# math::exact::reverse -- +# +# Calculates the reverse of a 2x2 matrix, which is its inverse times +# its determinant. +# +# Parameters: +# x - Matrix +# +# Results: +# Returns reverse[x]. +# +# Notes: +# The reverse is well defined even for singular matrices. + +proc math::exact::reverse {x} { + lassign $x ab cd + lassign $ab a b + lassign $cd c d + tailcall list [list $d [expr {-$b}]] [list [expr {-$c}] $a] +} + +# math::exact::veven -- +# +# Tests if both components of a 2-vector are even. +# +# Parameters: +# x - Vector to test +# +# Results: +# Returns 1 if both components are even, 0 otherwise. + +proc math::exact::veven {x} { + lassign $x a b + return [expr {($a % 2 == 0) && ($b % 2 == 0)}] +} + +# math::exact::meven -- +# +# Tests if all components of a 2x2 matrix are even. +# +# Parameters: +# x - Matrix to test +# +# Results: +# Returns 1 if all components are even, 0 otherwise. + +proc math::exact::meven {x} { + lassign $x a b + return [expr {[veven $a] && [veven $b]}] +} + +# math::exact::teven -- +# +# Tests if all components of a 2x2x2 tensor are even +# +# Parameters: +# x - Tensor to test +# +# Results: +# Returns 1 if all components are even, 0 otherwise + +proc math::exact::teven {x} { + lassign $x a b + return [expr {[meven $a] && [meven $b]}] +} + +# math::exact::vhalf -- +# +# Divides both components of a 2-vector by 2 +# +# Parameters: +# x - Vector to scale +# +# Results: +# Returns the scaled vector + +proc math::exact::vhalf {x} { + lassign $x a b + tailcall list [expr {$a / 2}] [expr {$b / 2}] +} + +# math::exact::mhalf -- +# +# Divides all components of a 2x2 matrix by 2 +# +# Parameters: +# x - Matrix to scale +# +# Results: +# Returns the scaled matrix + +proc math::exact::mhalf {x} { + lassign $x a b + tailcall list [vhalf $a] [vhalf $b] +} + +# math::exact::thalf -- +# +# Divides all components of a 2x2x2 tensor by 2 +# +# Parameters: +# x - Tensor to scale +# +# Results: +# Returns the scaled tensor + +proc math::exact::thalf {x} { + lassign $x a b + tailcall list [mhalf $a] [mhalf $b] +} + +# math::exact::vscale -- +# +# Removes all common factors of 2 from the two components of a 2-vector +# +# Paramters: +# x - Vector to scale +# +# Results: +# Returns the scaled vector + +proc math::exact::vscale {x} { + while {[veven $x]} { + set x [vhalf $x] + } + return $x +} + +# math::exact::mscale -- +# +# Removes all common factors of 2 from the two components of a +# 2x2 matrix +# +# Paramters: +# x - Matrix to scale +# +# Results: +# Returns the scaled matrix + +proc math::exact::mscale {x} { + while {[meven $x]} { + set x [mhalf $x] + } + return $x +} + +# math::exact::tscale -- +# +# Removes all common factors of 2 from the two components of a +# 2x2x2 tensor +# +# Paramters: +# x - Tensor to scale +# +# Results: +# Returns the scaled tensor + +proc math::exact::tscale {x} { + while {[teven $x]} { + set x [thalf $x] + } + return $x +} + +# math::exact::vreduce -- +# +# Reduces a vector (i.e., a rational number) to lowest terms +# +# Parameters: +# x - Vector to scale +# +# Results: +# Returns the scaled vector + +proc math::exact::vreduce {x} { + lassign $x a b + set g [gcd $a $b] + tailcall list [expr {$a / $g}] [expr {$b / $g}] +} + +# math::exact::mreduce -- +# +# Removes all common factors from the two components of a +# 2x2 matrix +# +# Paramters: +# x - Matrix to scale +# +# Results: +# Returns the scaled matrix +# +# This procedure suffices to reduce the matrix to lowest terms if the matrix +# was constructed by pre- or post-multiplying a series of sign and digit +# matrices. + +proc math::exact::mreduce {x} { + lassign $x ab cd + lassign $ab a b + lassign $cd c d + set g [gcd $a $b $c $d] + tailcall list \ + [list [expr {$a / $g}] [expr {$b / $g}]] \ + [list [expr {$c / $g}] [expr {$d / $g}]] +} + +# math::exact::treduce -- +# +# Removes all common factors from the components of a +# 2x2x2 tensor +# +# Paramters: +# x - Tensor to scale +# +# Results: +# Returns the scaled tensor +# +# This procedure suffices to reduce a tensor to lowest terms if it was +# constructed by absorbing a digit matrix into a tensor that was already +# in lowest terms. + +proc math::exact::treduce {x} { + lassign $x abcd efgh + lassign $abcd ab cd + lassign $ab a b + lassign $cd c d + lassign $efgh ef gh + lassign $ef e f + lassign $gh g h + set G [gcd $a $b $c $d $e $f $g $h] + tailcall list \ + [list \ + [list [expr {$a / $G}] [expr {$b / $G}]] \ + [list [expr {$c / $G}] [expr {$d / $G}]]] \ + [list \ + [list [expr {$e / $G}] [expr {$f / $G}]] \ + [list [expr {$g / $G}] [expr {$h / $G}]]] +} + +# math::exact::vadd -- +# +# Adds two 2-vectors +# +# Parameters: +# x - First vector +# y - Second vector +# +# Results: +# Returns the vector sum + +proc math::exact::vadd {x y} { + lmap p $x q $y {expr {$p + $q}} +} + +# math::exact::madd -- +# +# Adds two 2x2 matrices +# +# Parameters: +# A - First matrix +# B - Second matrix +# +# Results: +# Returns the matrix sum + +proc math::exact::madd {A B} { + lmap x $A y $B { + lmap p $x q $y {expr {$p + $q}} + } +} + +# math::exact::tadd -- +# +# Adds two 2x2x2 tensors +# +# Parameters: +# U - First tensor +# V - Second tensor +# +# Results: +# Returns the tensor sum + +proc math::exact::tadd {U V} { + lmap A $U B $V { + lmap x $A y $B { + lmap p $x q $y {expr {$p + $q}} + } + } +} + +# math::exact::mdotv -- +# +# 2x2 matrix times 2-vector +# +# Parameters; +# A - Matrix +# x - Vector +# +# Results: +# Returns the product vector + +proc math::exact::mdotv {A x} { + lassign $A ab cd + lassign $ab a b + lassign $cd c d + lassign $x e f + tailcall list [expr {$a*$e + $c*$f}] [expr {$b*$e + $d*$f}] +} + +# math::exact::mdotm -- +# +# Product of two matrices +# +# Parameters: +# A - Left matrix +# B - Right matrix +# +# Results: +# Returns the matrix product + +proc math::exact::mdotm {A B} { + lassign $B x y + tailcall list [mdotv $A $x] [mdotv $A $y] +} + +# math::exact::mdott -- +# +# Product of a matrix and a tensor +# +# Parameters: +# A - Matrix +# T - Tensor +# +# Results: +# Returns the product tensor + +proc math::exact::mdott {A T} { + lassign $T B C + tailcall list [mdotm $A $B] [mdotm $A $C] +} + +# math::exact::trightv -- +# +# Right product of a tensor and a vector +# +# Parameters: +# T - Tensor +# v - Right-hand vector +# +# Results: +# Returns the product matrix + +proc math::exact::trightv {T v} { + lassign $T m n + tailcall list [mdotv $m $v] [mdotv $n $v] +} + +# math::exact::trightm -- +# +# Right product of a tensor and a matrix +# +# Parameters: +# T - Tensor +# A - Right-hand matrix +# +# Results: +# Returns the product tensor + +proc math::exact::trightm {T A} { + lassign $T m n + tailcall list [mdotm $m $A] [mdotm $n $A] +} + +# math::exact::tleftv -- +# +# Left product of a tensor and a vector +# +# Parameters: +# T - Tensor +# v - Left-hand vector +# +# Results: +# Returns the product matrix + +proc math::exact::tleftv {T v} { + tailcall trightv [trans $T] $v +} + +# math::exact::tleftm -- +# +# Left product of a tensor and a matrix +# +# Parameters: +# T - Tensor +# A - Left-hand matrix +# +# Results: +# Returns the product tensor + +proc math::exact::tleftm {T A} { + tailcall trans [trightm [trans $T] $A] +} + +# math::exact::vsign -- +# +# Computes the 'sign function' of a vector. +# +# Parameters: +# v - Vector whose sign function is needed +# +# Results: +# Returns the result of the sign function. +# +# a b sign +# - - -1 +# - 0 -1 +# - + 0 +# 0 - -1 +# 0 0 0 +# 0 + 1 +# + - 0 +# + 0 1 +# + + 1 +# +# If the quotient a/b is negative or indeterminate, the result is zero. +# If the quotient a/b is zero, the result is the sign of b. +# If the quotient a/b is positive, the result is the common sign of the +# operands, which are known to be of like sign +# If the quotient a/b is infinite, the result is the sign of a. + +proc math::exact::sign {v} { + lassign $v a b + if {$a < 0} { + if {$b <= 0} { + return -1 + } else { + return 0 + } + } elseif {$a == 0} { + if {$b < 0} { + return -1 + } elseif {$b == 0} { + return 0 + } else { + return 1 + } + } else { + if {$b < 0} { + return 0 + } else { + return 1 + } + } +} + +# math::exact::vrefines -- +# +# Test if a vector refines. +# +# Parameters: +# v - Vector to test +# +# Results: +# 1 if the vector refines, 0 otherwise. + +proc math::exact::vrefines {v} { + return [expr {[sign $v] != 0}] +} + +# math::exact::mrefines -- +# +# Test whether a matrix refines +# +# Parameters: +# A - Matrix to test +# +# Results: +# 1 if the matrix refines, 0 otherwise. + +proc math::exact::mrefines {A} { + lassign $A v w + set a [sign $v] + set b [sign $w] + return [expr {$a == $b && $b != 0}] +} + +# math::exact::trefines -- +# +# Tests whether a tensor refines +# +# Parameters: +# T - Tensor to test. +# +# Results: +# 1 if the tensor refines, 0 otherwise. + +proc math::exact::trefines {T} { + lassign $T vw xy + lassign $vw v w + lassign $xy x y + set a [sign $v] + set b [sign $w] + set c [sign $x] + set d [sign $y] + return [expr {$a == $b && $b == $c && $c == $d && $d != 0}] +} + +# math::exact::vlessv - +# +# Test whether one rational is less than another +# +# Parameters: +# v, w - Two rational numbers +# +# Returns: +# The result of the comparison. + +proc math::exact::vlessv {v w} { + expr {[determinant [list $v $w]] < 0} +} + +# math::exact::mlessv - +# +# Tests whether a rational interval is less than a vector +# +# Parameters: +# m - Matrix representing the interval +# x - Rational to compare against +# +# Results: +# Returns 1 if m < x, 0 otherwise + +proc math::exact::mlessv {m x} { + lassign $m v w + expr {[vlessv $v $x] && [vlessv $w $x]} +} + +# math::exact::mlessm - +# +# Tests whether one rational interval is strictly less than another +# +# Parameters: +# m - First interval +# n - Second interval +# +# Results: +# Returns 1 if m < n, 0 otherwise + +proc math::exact::mlessm {m n} { + lassign $n v w + expr {[mlessv $m $v] && [mlessv $m $w]} +} + +# math::exact::mdisjointm - +# +# Tests whether two rational intervals are disjoint +# +# Parameters: +# m - First interval +# n - Second interval +# +# Results: +# Returns 1 if the intervals are disjoint, 0 otherwise + +proc math::exact::mdisjointm {m n} { + expr {[mlessm $m $n] || [mlessm $n $m]} +} + +# math::exact::mAsFloat +# +# Formats a matrix that represents a rational interval as a floating +# point number, stopping as soon as a digit is not determined. +# +# Parameters: +# m - Matrix to format +# +# Results: +# Returns the floating point number in scientific notation, with no +# digits to the left of the decimal point. + +proc math::exact::mAsFloat {m} { + + # Special case: If a number is exact, the determinant is zero. + + set d [determinant $m] + lassign [lindex $m 0] p q + if {$d == 0} { + if {$q < 0} { + set p [expr {-$p}] + set q [expr {-$q}] + } + if {$p == 0} { + if {$q == 0} { + return NaN + } else { + return 0 + } + } elseif {$q == 0} { + return Inf + } elseif {$q == 1} { + return $p + } else { + set G [gcd $p $q] + return [expr {$p/$G}]/[expr {$q/$G}] + } + } else { + tailcall eFormat [scientificNotation $m] + } +} + +# math::exact::scientificNotation -- +# +# Takes a matrix representing a rational interval, and extracts as +# many decimal digits as can be determined unambiguously +# +# Parameters: +# m - Matrix to format +# +# Results: +# Returns a list comprising the decimal exponent, followed by a series of +# digits of the significand. The decimal point is to the left of the +# leftmost digit of the significand. +# +# Returns the empty string if a number is entirely undetermined. + +proc math::exact::scientificNotation {m} { + set n 0 + while {1} { + if {[vrefines [mdotv [reverse $m] {1 0}]]} { + return {} + } elseif {[mrefines [mdotm $math::exact::iszer $m]]} { + return [linsert [mantissa $m] 0 $n] + } else { + set m [mdotm {{1 0} {0 10}} $m] + incr n + } + } +} + +# math::exact::mantissa -- +# +# Given a matrix m that represents a rational interval whose +# endpoints are in [0,1), formats as many digits of the represented +# number as possible. +# +# Parameters: +# m - Matrix to format +# +# Results: +# Returns a list of digits + +proc math::exact::mantissa {m} { + set retval {} + set done 0 + while {!$done} { + set done 1 + + # Brute force: try each digit in turn. This could no doubt be + # improved on. + + for {set j -9} {$j <= 9} {incr j} { + set digitMatrix \ + [list [list [expr {$j+1}] 10] [list [expr {$j-1}] 10]] + if {[mrefines [mdotm [reverse $digitMatrix] $m]]} { + lappend retval $j + set nextdigit [list {10 0} [list [expr {-$j}] 1]] + set m [mdotm $nextdigit $m] + set done 0 + break + } + } + } + return $retval +} + +# math::exact::eFormat -- +# +# Formats a decimal exponent and significand in E format +# +# Parameters: +# expAndDigits - List whose first element is the exponent and +# whose remaining elements are the digits of the +# significand. + +proc math::exact::eFormat {expAndDigits} { + + # An empty sequence of digits is an indeterminate number + + if {[llength $expAndDigits] < 2} { + return Undetermined + } + set significand [lassign $expAndDigits exponent] + + # Accumulate the digits + set v 0 + foreach digit $significand { + set v [expr {10 * $v + $digit}] + } + + # Adjust the exponent if the significand has too few digits. + + set l [llength $significand] + while {$l > 0 && abs($v) < 10**($l-1)} { + incr l -1 + incr exponent -1 + } + incr exponent -1 + + # Put in the sign + + if {$v < 0} { + set result - + set v [expr {-$v}] + } else { + set result {} + } + + # Put in the significand with the decimal point after the leading digit. + + if {$v == 0} { + append result 0 + } else { + append result [string index $v 0] . [string range $v 1 end] + } + + # Put in the exponent + + append result e $exponent + + return $result +} + +# math::exact::showRat -- +# +# Formats an exact rational for printing in E format. +# +# Parameters: +# v - Two-element list of numerator and denominator. +# +# Results: +# Returns the quotient in E format. Nonzero/zero == Infinity, +# 0/0 == NaN. + +proc math::exact::showRat {v} { + lassign $v p q + if {$p != 0 || $q != 0} { + return [format %e [expr {double($p)/double($q)}]] + } else { + return NaN + } +} + +# math::exact::showInterval -- +# +# Formats a rational interval for printing +# +# Parameters: +# m - Matrix representing the interval +# +# Results: +# Returns a string representing the interval in E format. + +proc math::exact::showInterval {m} { + lassign $m v w + return "\[[showRat $w] .. [showRat $v]\]" +} + +# math::exact::showTensor -- +# +# Formats a tensor for printing +# +# Parameters: +# t - Tensor to print +# +# Results: +# Returns a string containing the left and right matrices of the +# tensor, each represented as an interval. + +proc math::exact::showTensor {t} { + lassign $t m n + return [list [showInterval $m] [showInterval $n]] +} + +# math::exact::counted -- +# +# Reference counted object + +oo::class create math::exact::counted { + variable refcount_ + + # Constructor builds an object with a zero refcount. + constructor {} { + if 0 { + puts {} + puts "construct: [self object] refcount now 0" + for {set i [info frame]} {$i > 0} {incr i -1} { + set frame [info frame $i] + if {[dict get $frame type] eq {source}} { + set line [dict get $frame line] + puts "\t[file tail [dict get $frame file]]:$line" + if {$line < 0} { + if {[dict exists $frame proc]} { + puts "\t\t[dict get $frame proc]" + } + puts "\t\t\[[dict get $frame cmd]\]" + } + } else { + puts $frame + } + } + } + incr refcount_ + set refcount_ 0 + } + + # The 'ref' method adds a reference to this object, and returns this object + method ref {} { + if 0 { + puts {} + puts "ref: [self object] refcount now [expr {$refcount_ + 1}]" + if {$refcount_ == 0} { + puts "\t[my dump]" + } + for {set i [info frame]} {$i > 0} {incr i -1} { + set frame [info frame $i] + if {[dict get $frame type] eq {source}} { + set line [dict get $frame line] + puts "\t[file tail [dict get $frame file]]:$line" + if {$line < 0} { + if {[dict exists $frame proc]} { + puts "\t\t[dict get $frame proc]" + } + puts "\t\t\[[dict get $frame cmd]\]" + } + } else { + puts $frame + } + } + } + incr refcount_ + return [self] + } + + # The 'unref' method removes a reference from this object, and destroys + # this object if the refcount becomes nonpositive. + method unref {} { + if 0 { + puts {} + puts "unref: [self object] refcount now [expr {$refcount_ - 1}]" + for {set i [info frame]} {$i > 0} {incr i -1} { + set frame [info frame $i] + if {[dict get $frame type] eq {source}} { + set line [dict get $frame line] + puts "\t[file tail [dict get $frame file]]:$line" + if {$line < 0} { + if {[dict exists $frame proc]} { + puts "\t\t[dict get $frame proc]" + } + puts "\t\t\[[dict get $frame cmd]\]" + } + } + } + } + + # Destroying this object can result in a long chain of object + # destruction and eventually a stack overflow. Instead of destroying + # immediately, list the objects to be destroyed in + # math::exact::deleteStack, and destroy them only from the outermost + # stack level that's running 'unref'. + + if {[incr refcount_ -1] <= 0} { + variable ::math::exact::deleteStack + + # Is this the outermost level? + set queueActive [expr {[info exists deleteStack]}] + + # Schedule this object's destruction + lappend deleteStack [self object] + if {!$queueActive} { + + # At outermost level, destroy all scheduled objects. + # Destroying one may schedule another. + while {[llength $deleteStack] != 0} { + set obj [lindex $deleteStack end] + set deleteStack \ + [lreplace $deleteStack[set deleteStack {}] end end] + $obj destroy + } + + # Once everything quiesces, delete the list. + unset deleteStack + } + } + } + + # The 'refcount' method returns the reference count of this object for + # debugging. + method refcount {} { + return $refcount_ + } + + destructor { + } +} + +# An expression is a vector, a matrix applied to an expression, +# or a tensor applied to two expressions. The inner expressions +# may be constructed lazily. + +oo::class create math::exact::Expression { + superclass math::exact::counted + + # absorbed_, signAndMagnitude_, and leadingDigitAndRest_ + # memoize the return values of the 'absorb', 'getSignAndMagnitude', + # and 'getLeadingDigitAndRest' methods. + + variable absorbed_ signAndMagnitude_ leadingDigitAndRest_ + + # Constructor initializes refcount + constructor {} { + next + } + + # Destructor releases memoized objects + destructor { + if {[info exists signAndMagnitude_]} { + [lindex $signAndMagnitude_ 1] unref + } + if {[info exists absorbed_]} { + $absorbed_ unref + } + if {[info exists leadingDigitAndRest_]} { + [lindex $leadingDigitAndRest_ 1] unref + } + next + } + + # getSignAndMagnitude returns a two-element list: + # the sign matrix, which is one of ispos, isneg, isinf, and iszer, + # the magnitude, which is another exact real. + method getSignAndMagnitude {} { + if {![info exists signAndMagnitude_]} { + if {[my refinesM $::math::exact::ispos]} { + set signAndMagnitude_ \ + [list $::math::exact::spos \ + [[my applyM $::math::exact::ispos] ref]] + } elseif {[my refinesM $::math::exact::isneg]} { + set signAndMagnitude_ \ + [list $::math::exact::sneg \ + [[my applyM $::math::exact::isneg] ref]] + } elseif {[my refinesM $::math::exact::isinf]} { + set signAndMagnitude_ \ + [list $::math::exact::sinf \ + [[my applyM $::math::exact::isinf] ref]] + } elseif {[my refinesM $::math::exact::iszer]} { + set signAndMagnitude_ \ + [list $::math::exact::szer \ + [[my applyM $::math::exact::iszer] ref]] + } else { + set absorbed_ [my absorb] + set signAndMagnitude_ [$absorbed_ getSignAndMagnitude] + [lindex $signAndMagnitude_ 1] ref + } + } + return $signAndMagnitude_ + } + + # The 'getLeadingDigitAndRest' method accepts a flag for whether + # a digit must be extracted (1) or a rational number may be returned + # directly (0). It returns a two-element list: a digit matrix, which + # is one of $dpos, $dneg or $dzer, and an exact real representing + # the number by which the given digit matrix must be postmultiplied. + method getLeadingDigitAndRest {needDigit} { + if {![info exists leadingDigitAndRest_]} { + if {[my refinesM $::math::exact::idpos]} { + set leadingDigitAndRest_ \ + [list $::math::exact::dpos \ + [[my applyM $::math::exact::idpos] ref]] + } elseif {[my refinesM $::math::exact::idneg]} { + set leadingDigitAndRest_ \ + [list $::math::exact::dneg \ + [[my applyM $::math::exact::idneg] ref]] + } elseif {[my refinesM $::math::exact::idzer]} { + set leadingDigitAndRest_ \ + [list $::math::exact::dzer \ + [[my applyM $::math::exact::idzer] ref]] + } else { + set absorbed_ [my absorb] + set newval $absorbed_ + $newval ref + set leadingDigitAndRest_ \ + [$newval getLeadingDigitAndRest $needDigit] + if {[llength $leadingDigitAndRest_] >= 2} { + [lindex $leadingDigitAndRest_ 1] ref + } + $newval unref + } + } + return $leadingDigitAndRest_ + } + + # getInterval -- + # Accumulates 'nDigits' digit matrices, and returns their product, + # which is a matrix representing the interval that the digits represent. + method getInterval {nDigits} { + lassign [my getSignAndMagnitude] interval e + $e ref + lassign [$e getLeadingDigitAndRest 1] ld f + set interval [math::exact::mdotm $interval $ld] + $f ref; $e unref; set e $f + set d $ld + while {[incr nDigits -1] > 0} { + lassign [$e getLeadingDigitAndRest 1] d f + set interval [math::exact::mdotm $interval $d] + $f ref; $e unref; set e $f + } + $e unref + return $interval + } + + # asReal -- + # Coerces an object from rational to real + # + # Parameters: + # None. + # + # Results: + # Returns this object + method asReal {} {self object} + + # asFloat -- + # Represents this number in E format, after accumulating 'relDigits' + # digit matrices. + method asFloat {relDigits} { + set v [[my asReal] ref] + set result [math::exact::mAsFloat [$v getInterval $relDigits]] + $v unref + return $result + } + + # asPrint -- + # Represents this number for printing. Represents rationals exactly, + # others after accumulating 'relDigits' digit matrices. + method asPrint {relDigits} { + tailcall math::exact::mAsFloat [my getInterval $relDigits] + } + + # Derived classes are expected to implement the following methods: + # method dump {} { + # # Formats the object for debugging + # # Returns the formatted string + # } + method dump {} { + error "[info object class [self object]] does not implement the 'dump' method." + } + + # method refinesM {m} { + # # Returns 1 if premultiplying by the matrix m refines this object + # # Returns 0 otherwise + # } + method refinesM {m} { + error "[info object class [self object]] does not implement the 'refinesM' method." + } + + # method applyM {m} { + # # Premultiplies this object by the matrix m + # } + method applyM {m} { + error "[info object class [self object]] does not implement the 'applyM' method." + } + + # method applyTLeft {t r} { + # # Computes the left product of the tensor t with this object, and + # # applies the result to the right operand r. + # # Returns a new exact real representing the product + # } + method applyTLeft {t r} { + error "[info object class [self object]] does not implement the 'applyTLeft' method." + } + + # method applyTRight {t l} { + # # Computes the right product of the tensor t with this object, and + # # applies the result to the left operand l. + # # Returns a new exact real representing the product + # } + method applyTRight {t l} { + error "[info object class [self object]] does not implement the 'applyTRight' method." + } + + # method absorb {} { + # # Absorbs the next subexpression or digit into this expression + # # Returns the result of absorption, which always represents a + # # smaller interval than this expression + # } + method absorb {} { + error "[info object class [self object]] does not implement the 'absorb' method." + } + + # U- -- + # + # Unary - applied to this object + # + # Results: + # Returns the negation. + + method U- {} { + my ref + lassign [my getSignAndMagnitude] sA mA + set m [math::exact::mdotm {{-1 0} {0 1}} $sA] + set result [math::exact::Mstrict new $m $mA] + my unref + return $result + }; export U- + + # + -- + # Adds this object to another. + # + # Parameters: + # r - Right addend + # + # Results: + # Returns the sum + # + # Either object may be rational (an instance of V) or real (any other + # Expression). + # + # This method is a Consumer with respect to the current object and to r. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + + method + {r} { + return [$r E+ [self object]] + }; export + + + # E+ -- + # Adds two exact reals. + # + # Parameters: + # l - Left addend + # + # Results: + # Returns the sum. + # + # Neither object is an instance of V (that is, neither is a rational). + # + # This method is a Consumer with respect to the current object and to l. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + + method E+ {l} { + tailcall math::exact::+real $l [self object] + }; export E+ + + # V+ -- + # Adds a rational and an exact real + # + # Parameters: + # l - Left addend + # + # Results: + # Returns the sum. + # + # This method is a Consumer with respect to the current object and to l. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + + method V+ {l} { + tailcall math::exact::+real $l [self object] + }; export V+ + + # - -- + # Subtracts another object from this object + # + # Parameters: + # r - Subtrahend + # + # Results: + # Returns the difference + # + # Either object may be rational (an instance of V) or real (any other + # Expression). + # + # This method is a Consumer with respect to the current object and to r. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + + method - {r} { + return [$r E- [self object]] + }; export - + + # E- -- + # Subtracts this exact real from another + # + # Parameters: + # l - Minuend + # + # Results: + # Returns the difference + # + # Neither object is an instance of V (that is, neither is a rational). + # + # This method is a Consumer with respect to the current object and to l. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + + method E- {l} { + tailcall math::exact::-real $l [self object] + }; export E- + + # V- -- + # Subtracts this exact real from a rational + # + # Parameters: + # l - Minuend + # + # Results: + # Returns the difference + # + # This method is a Consumer with respect to the current object and to l. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + + method V- {l} { + tailcall math::exact::-real $l [self object] + }; export V- + + # * -- + # Multiplies this object by another. + # + # Parameters: + # r - Right argument to the multiplication + # + # Results: + # Returns the product + # + # Either object may be rational (an instance of V) or real (any other + # Expression). + # + # This method is a Consumer with respect to the current object and to r. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + + method * {r} { + return [$r E* [self object]] + }; export * + + # E* -- + # Multiplies two exact reals. + # + # Parameters: + # l - Left argument to the multiplication + # + # Results: + # Returns the product. + # + # Neither object is an instance of V (that is, neither is a rational). + # + # This method is a Consumer with respect to the current object and to l. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + + method E* {l} { + tailcall math::exact::*real $l [self object] + }; export E* + + # V* -- + # Multiplies a rational and an exact real + # + # Parameters: + # l - Left argument to the multiplication + # + # Results: + # Returns the product. + # + # This method is a Consumer with respect to the current object and to l. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + + method V* {l} { + tailcall math::exact::*real $l [self object] + }; export V* + + # / -- + # Divides this object by another. + # + # Parameters: + # r - Divisor + # + # Results: + # Returns the quotient + # + # Either object may be rational (an instance of V) or real (any other + # Expression). + # + # This method is a Consumer with respect to the current object and to r. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + + method / {r} { + return [$r E/ [self object]] + }; export / + + # E/ -- + # Divides two exact reals. + # + # Parameters: + # l - Dividend + # + # Results: + # Returns the quotient. + # + # Neither object is an instance of V (that is, neither is a rational). + # + # This method is a Consumer with respect to the current object and to l. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + + method E/ {l} { + tailcall math::exact::/real $l [self object] + }; export E/ + + # V/ -- + # Divides a rational by an exact real + # + # Parameters: + # l - Dividend + # + # Results: + # Returns the product. + # + # This method is a Consumer with respect to the current object and to l. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + + method V/ {l} { + tailcall math::exact::/real $l [self object] + }; export V/ + + # ** - + # Raises an exact real to a power + # + # Parameters: + # r - Exponent + # + # Results: + # Returns the power. + # + # This method is a Consumer with respect to the current object and to l. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + + method ** {r} { + tailcall $r E** [self object] + }; export ** + + # E** - + # Raises an exact real to the power of an exact real + # + # Parameters: + # l - Base to exponentiate + # + # Results: + # Returns the power + # + # This method is a Consumer with respect to the current object and to l. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + + method E** {l} { + # This doesn't work as a tailcall, because this object could have + # been destroyed by the time we're trying to invoke the tailcall, + # and that will keep command names from resolving because the + # tailcall mechanism will try to find them in the destroyed namespace. + return [math::exact::function::exp \ + [my * [math::exact::function::log $l]]] + }; export E** + + # V** - + # Raises a rational to the power of an exact real + # + # Parameters: + # l - Base to exponentiate + # + # Results: + # Returns the power + # + # This method is a Consumer with respect to the current object and to l. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + + method V** {l} { + # This doesn't work as a tailcall, because this object could have + # been destroyed by the time we're trying to invoke the tailcall, + # and that will keep command names from resolving because the + # tailcall mechanism will try to find them in the destroyed namespace. + return [math::exact::function::exp \ + [my * [math::exact::function::log $l]]] + }; export V** + + # sqrt -- + # + # Create an expression representing the square root of an exact + # real argument. + # + # Results: + # Returns the square root. + # + # This procedure is a Consumer with respect the the argument and a + # Constructor with respect to the result, returning a zero-reference + # result. + + method sqrt {} { + variable ::math::exact::isneg + variable ::math::exact::idzer + variable ::math::exact::idneg + variable ::math::exact::idpos + + # The algorithm is a modified Newton-Raphson from the Potts and + # Menissier-Morain papers. The algorithm for sqrt(x) converges + # rapidly only if x is close to 1, so we rescale to make sure that + # x is between 1/3 and 3. Specifically: + # - if x is known to be negative (that is, if $idneg refines it) + # then error. + # - if x is close to 1, $idzer refines it, and we can calculate the + # square root directly. + # - if x is less than 1, $idneg refines it, and we calculate sqrt(4*x) + # and multiply by 1/2. + # - if x is greater than 1, $idpos refines it, and we calculate + # sqrt(x/4) and multiply by 2. + # - if none of the above hold, we have insufficient information about + # the magnitude of x and perform a digit exchange. + + my ref + if {[my refinesM $isneg]} { + # Negative argument is an error + return -code error -errorcode {MATH EXACT SQRTNEGATIVE} \ + "sqrt of negative argument" + } elseif {[my refinesM $idzer]} { + # Argument close to 1 + set res [::math::exact::SqrtWorker new [self object]] + } elseif {[my refinesM $idneg]} { + # Small argument - multiply by 4 and halve the square root + set y [[my applyM {{4 0} {0 1}}] ref] + set z [[$y sqrt] ref] + set res [$z applyM {{1 0} {0 2}}] + $z unref + $y unref + } elseif {[my refinesM $idpos]} { + # Large argument - divide by 4 and double the square root + set y [[my applyM {{1 0} {0 4}}] ref] + set z [[$y sqrt] ref] + set res [$z applyM {{2 0} {0 1}}] + $z unref + $y unref + } else { + # Unclassified argyment. Perform a digit exchange and try again. + set y [[my absorb] ref] + set res [$y sqrt] + $y unref + } + my unref + return $res + } +} + +# math::exact::V -- +# Vector object +# +# A vector object represents a rational number. It is always strict; no +# methods need to perform lazy evaluation. + +oo::class create math::exact::V { + superclass math::exact::Expression + + # v_ is the vector represented. + variable v_ + + # Constructor accepts the vector as a two-element list {n d} + # where n is by convention the numerator and d the denominator. + # It is expected that either n or d is nonzero, and that gcd(n,d) == 0. + # It is also expected that the fraction will be in lowest terms. + constructor {v} { + next + set v_ $v + } + + # Destructor need only update reference counts + destructor { + next + } + + # If a rational is acceptable, getLeadingDigitAndRest may simply return + # this object. + method getLeadingDigitAndRest {needDigit} { + if {$needDigit} { + return [next $needDigit] + } else { + # Note that the result MUST NOT be memoized, as that would lead + # to a circular reference, breaking the refcount system. + return [self object] + } + } + + # Print this object + method dump {} { + return "V($v_)" + } + + # Test if the vector refines when premultiplied by a matrix + method refinesM {m} { + return [math::exact::vrefines [math::exact::mdotv $m $v_]] + } + + # Apply a matrix to the vector. + # Precondition: v is in lowest terms + + method applyM {m} { + set d [math::exact::determinant $m] + if {$d < 0} { set d [expr {-$d}] } + if {($d & ($d-1)) != 0} { + return [math::exact::V new \ + [math::exact::vreduce [math::exact::mdotv $m $v_]]] + } else { + return [math::exact::V new \ + [math::exact::vscale [math::exact::mdotv $m $v_]]] + } + } + + # Left-multiply a tensor t by the vector, and apply the result to + # an expression 'r' + method applyTLeft {t r} { + set u [math::exact::mscale [math::exact::tleftv $t $v_]] + set det [math::exact::determinant $u] + if {$det < 0} { set det [expr {-$det}] } + if {($det & ($det-1)) == 0} { + # determinant is a power of 2 + set res [$r applyM $u] + return $res + } else { + return [math::exact::Mstrict new $u $r] + } + } + + # Right-multiply a tensor t by the vector, and apply the result + # to an expression 'l' + method applyTRight {t l} { + set u [math::exact::mscale [math::exact::trightv $t $v_]] + set det [math::exact::determinant $u] + if {$det < 0} { set det [expr {-$det}] } + if {($det & ($det-1)) == 0} { + # determinant is a power of 2 + set res [$l applyM $u] + return $res + } else { + return [math::exact::Mstrict new $u $l] + } + } + + # Get the vector components + method getV {} { + return $v_ + } + + # Get the (zero-width) interval that the vector represents. + method getInterval {nDigits} { + return [list $v_ $v_] + } + + # Absorb more information + method absorb {} { + # Nothing should ever call this, because a vector's information is + # already complete. + error "cannot absorb anything into a vector" + } + + # asReal -- + # Coerces an object from rational to real + # + # Parameters: + # None. + # + # Results: + # Returns this object converted to an exact real. + method asReal {} { + my ref + lassign [my getSignAndMagnitude] s m + set result [math::exact::Mstrict new $s $m] + my unref + return $result + } + + # U- -- + # + # Unary - applied to this object + # + # Results: + # Returns the negation. + + method U- {} { + my ref + lassign $v_ p q + set result [math::exact::V new [list [expr {-$p}] $q]] + my unref + return $result + }; export U- + + # + -- + # Adds a vector to another object + # + # Parameters: + # r - Right addend + # + # Results: + # Returns the sum + # + # The right-hand addend may be rational (an instance of V) or real + # (any other Expression). + # + # This method is a Consumer with respect to the current object and to r. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + + method + {r} { + return [$r V+ [self object]] + }; export + + + # E+ -- + # Adds an exact real and a vector + # + # Parameters: + # l - Left addend + # + # Results: + # Returns the sim. + # + # This method is a Consumer with respect to the current object and to l. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + + method E+ {l} { + tailcall math::exact::+real $l [self object] + }; export E+ + + # V+ -- + # Adds two rationals + # + # Parameters: + # l - Rational multiplicand + # + # Results: + # Returns the product. + # + # This method is a Consumer with respect to the current object and to l. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + method V+ {l} { + my ref + $l ref + lassign [$l getV] a b + lassign $v_ c d + $l unref + my unref + return [math::exact::V new \ + [math::exact::vreduce \ + [list [expr {$a*$d+$b*$c}] [expr {$b*$d}]]]] + }; export V+ + + # - -- + # Subtracts another object from a vector + # + # Parameters: + # r - Subtrahend + # + # Results: + # Returns the difference + # + # The right-hand operand may be rational (an instance of V) or real + # (any other Expression). + # + # This method is a Consumer with respect to the current object and to r. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + + method - {r} { + return [$r V- [self object]] + }; export - + + # E- -- + # Subtracts this exact real from a rational + # + # Parameters: + # l - Left addend + # + # Results: + # Returns the difference. + # + # This method is a Consumer with respect to the current object and to l. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + + method E- {l} { + tailcall math::exact::-real $l [self object] + }; export E- + + # V- -- + # Subtracts this rational from another + # + # Parameters: + # l - Rational minuend + # + # Results: + # Returns the difference. + # + # This method is a Consumer with respect to the current object and to l. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + method V- {l} { + my ref + $l ref + lassign [$l getV] a b + lassign $v_ c d + $l unref + my unref + return [math::exact::V new \ + [math::exact::vreduce \ + [list [expr {$a*$d-$b*$c}] [expr {$b*$d}]]]] + }; export V- + + # * -- + # Multiplies a rational by another object + # + # Parameters: + # r - Right-hand factor + # + # Results: + # Returns the difference + # + # The right-hand operand may be rational (an instance of V) or real + # (any other Expression). + # + # This method is a Consumer with respect to the current object and to r. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + + method * {r} { + return [$r V* [self object]] + }; export * + + # E* -- + # Multiplies an exact real and a rational + # + # Parameters: + # l - Multiplicand + # + # Results: + # Returns the product. + # + # This method is a Consumer with respect to the current object and to l. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + + method E* {l} { + tailcall math::exact::*real $l [self object] + }; export E* + + # V* -- + # Multiplies two rationals + # + # Parameters: + # l - Rational multiplicand + # + # Results: + # Returns the product. + # + # This method is a Consumer with respect to the current object and to l. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + method V* {l} { + my ref + $l ref + lassign [$l getV] a b + lassign $v_ c d + $l unref + my unref + return [math::exact::V new \ + [math::exact::vreduce \ + [list [expr {$a*$c}] [expr {$b*$d}]]]] + }; export V* + + # / -- + # Divides this object by another. + # + # Parameters: + # r - Divisor + # + # Results: + # Returns the quotient + # + # Either object may be rational (an instance of V) or real (any other + # Expression). + # + # This method is a Consumer with respect to the current object and to r. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + + method / {r} { + return [$r V/ [self object]] + }; export / + + # E/ -- + # Divides an exact real and a rational + # + # Parameters: + # l - Dividend + # + # Results: + # Returns the quotient. + # + # The divisor is not a rationa. + # + # This method is a Consumer with respect to the current object and to l. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + + method E/ {l} { + tailcall math::exact::/real $l [self object] + }; export E/ + + # V/ -- + # Divides two rationals + # + # Parameters: + # l - Dividend + # + # Results: + # Returns the quotient. + # + # This method is a Consumer with respect to the current object and to l. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + method V/ {l} { + my ref + $l ref + lassign [$l getV] a b + lassign $v_ c d + set result [math::exact::V new \ + [math::exact::vreduce \ + [list [expr {$a*$d}] [expr {$b*$c}]]]] + $l unref + my unref + return $result + }; export V/ + + # ** - + # Raises a rational to a power + # + # Parameters: + # r - Exponent + # + # Results: + # Returns the power. + # + # This method is a Consumer with respect to the current object and to l. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + + method ** {r} { + tailcall $r V** [self object] + }; export ** + + # E** - + # Raises an exact real to a rational power + # + # Parameters: + # l - Base to exponentiate + # + # Results: + # Returns the power + # + # This method is a Consumer with respect to the current object and to l. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + + method E** {l} { + + # Extract numerator and demominator of the exponent, and consume the + # exponent. + my ref + lassign $v_ c d + my unref + + # Normalize the sign of the exponent + if {$d < 0} { + set c [expr {-$c}] + set d [expr {-$d}] + } + + # Don't choke if somehow a 0/0 gets here. + if {$c == 0 && $d == 0} { + $l unref + return -code error -errorcode "MATH EXACT ZERODIVZERO" \ + "zero divided by zero" + } + + # Handle integer powers + if {$d == 1} { + return [math::exact::real**int $l $c] + } + + # Other rational powers come here. + # We know that $d > 0, and we're not just doing + # exponentiation by an integer + + return [math::exact::real**rat $l $c $d] + }; export E** + + # V** - + # Raises a rational base to a rational power + # + # Parameters: + # l - Base to exponentiate + # + # Results: + # Returns the power + # + # This method is a Consumer with respect to the current object and to l. + # It is a Constructor with respect to its result, returning a zero-ref + # object. + + method V** {l} { + + # Extract the numerator and denominator of the base and consume + # the base. + $l ref + lassign [$l getV] a b + $l unref + + # Extract numerator and demominator of the exponent, and consume the + # exponent. + my ref + lassign $v_ c d + my unref + + # Normalize the signs of the arguments + if {$b < 0} { + set a [expr {-$a}] + set b [expr {-$b}] + } + if {$d < 0} { + set c [expr {-$c}] + set d [expr {-$d}] + } + + # Don't choke if somehow a 0/0 gets here. + if {$a == 0 && $b == 0 || $c == 0 && $d == 0} { + return -code error -errorcode "MATH EXACT ZERODIVZERO" \ + "zero divided by zero" + } + + # b >= 0 and d >= 0 + + if {$a == 0} { + if {$c == 0} { + return -code error -errorcode "MATH EXACT ZEROPOWZERO" \ + "zero to zero power" + } elseif {$d == 0} { + return -code error -errorcode "MATH EXACT ZEROPOWINF" \ + "zero to infinite power" + } else { + return [math::exact::V new {0 1}] + } + } + + # a != 0, b >= 0, d >= 0 + + if {$b == 0} { + if {$c == 0} { + return -code error -errorcode "MATH EXACT INFPOWZERO" \ + "infinity to zero power" + } elseif {$c < 0} { + return [math::exact::V new {0 1}] + } else { + return [math::exact::V new {1 0}] + } + } + + # a != 0, b > 0, d >= 0 + + if {$c == 0} { + return [math::exact::V new {1 1}] + } + + # handle integer exponents + + if {$d == 1} { + return [math::exact::rat**int $a $b $c] + } + + # a != 0, b > 0, c != 0, d >= 0 + + return [math::exact::rat**rat $a $b $c $d] + }; export V** + + # sqrt -- + # + # Calculates the square root of this object + # + # Results: + # Returns the square root as an exact real. + # + # This method is a Consumer with respect to this object and a Constructor + # with respect to the result, returning a zero-ref object. + method sqrt {} { + my ref + if {([lindex $v_ 0] < 0) ^ ([lindex $v_ 1] < 0)} { + return -code error -errorCode "MATH EXACT SQRTNEGATIVE" \ + {square root of negative argument} + } + set result [::math::exact::Sqrtrat new {*}$v_] + my unref + return $result + } + +} + +# math::exact::M -- +# Expression consisting of a matrix times another expression +# +# The matrix {a c} {b d} represents the homography (a*x + b) / (c*x + d). +# +# The inner expression may need to be evaluated lazily. Whether evaluation +# is strict or lazy, the 'e' method will return the expression. + +oo::class create math::exact::M { + superclass math::exact::Expression + + # m_ is the matrix; e_ the inner expression; absorbed_ a cache of the + # result of the 'absorb' method. + variable m_ e_ absorbed_ + + # constructor accepts the matrix only. The expression is managed in + # derived classes. + constructor {m} { + next + set m_ $m + } + + # destructor deletes the memoized expression if one has been stored. + # The base class destructor handles cleaning up the result of 'absorb' + destructor { + if {[info exists e_]} { + $e_ unref + } + next + } + + # Test if the matrix refines when premultiplied by another matrix n + method refinesM {n} { + return [math::exact::mrefines [math::exact::mdotm $n $m_]] + } + + # Premultiply the matrix by another matrix n + method applyM {n} { + set d [math::exact::determinant $n] + if {$d < 0} {set d [expr {-$d}]} + if {($d & ($d-1)) != 0} { + return [math::exact::Mstrict new \ + [math::exact::mreduce [math::exact::mdotm $n $m_]] \ + [my e]] + } else { + return [math::exact::Mstrict new \ + [math::exact::mscale [math::exact::mdotm $n $m_]] \ + [my e]] + } + } + + # Compute the left product of a tensor t with this matrix, and + # apply the resulting tensor to the expression 'r'. + method applyTLeft {t r} { + return [math::exact::Tstrict new \ + [math::exact::tscale [math::exact::tleftm $t $m_]] \ + 1 [my e] $r] + } + + # Compute the right product of a tensor t with this matrix, and + # apply the resulting tensor to the expression 'l'. + method applyTRight {t l} { + return [math::exact::Tstrict new \ + [math::exact::tscale [math::exact::trightm $t $m_]] \ + 0 $l [my e]] + } + + # Absorb a digit into this matrix. + method absorb {} { + if {![info exists absorbed_]} { + set absorbed_ [[[my e] applyM $m_] ref] + } + return $absorbed_ + } + + # Derived classes are expected to implement: + # method e {} { + # # Returns the expression to which this matrix is applied. + # # Optionally memoizes the result in $e_. + # } + method e {} { + error "[info object class [self object]] does not implement the 'e' method." + } +} + +# math::exact::Mstrict -- +# +# Expression representing the product of a matrix and another +# expression. +# +# In this version of the class, the expression is known in advance - +# evaluated strictly. + +oo::class create math::exact::Mstrict { + superclass math::exact::M + + # m_ is the matrix. + # e_ is the expression + # absorbed_ caches the result of the 'absorb' method. + variable m_ e_ absorbed_ + + # Constructor accepts the matrix and the expression to which + # it applies. + constructor {m e} { + next $m + set e_ [$e ref] + } + + # All the heavy lifting of destruction is performed in the base class. + destructor { + next + } + + # The 'e' method returns the expression. + method e {} { + return $e_ + } + + # The 'dump' method formats this object for debugging. + method dump {} { + return "M($m_,[$e_ dump])" + } +} + +# math::exact::T -- +# Expression representing a 2x2x2 tensor of the third order, +# applied to two subexpressions. + +oo::class create math::exact::T { + superclass math::exact::Expression + + # t_ - the tensor + # i_ A flag indicating whether the next 'absorb' should come from the + # left (0) or the right (1). + # l_ - the left subexpression + # r_ - the right subexpression + # absorbed_ - the result of an 'absorb' operation + + variable t_ i_ l_ r_ absorbed_ + + # constructor accepts the tensor and the initial state for absorption + constructor {t i} { + next + set t_ $t + set i_ $i + } + + # destructor removes cached items. + destructor { + if {[info exists l_]} { + $l_ unref + } + if {[info exists r_]} { + $r_ unref + } + next; # The base class will clean up absorbed_ + } + + # refinesM -- + # + # Tests if this tensor refines when premultiplied by a matrix + # + # Parameters: + # m - matrix to test + # + # Results: + # Returns a Boolean indicator that is true if the product refines. + + method refinesM {m} { + return [math::exact::trefines [math::exact::mdott $m $t_]] + } + + # applyM -- + # + # Left multiplies this tensor by a matrix + # + # Parameters: + # m - Matrix to multiply + # + # Results: + # Returns the product + # + # This operation has the side effect of making the product strict at + # the uppermost level, by calling [my l] [my r] to instantiate the + # subexpressions. + + method applyM {m} { + set d [math::exact::determinant $m] + if {$d < 0} {set d [expr {-$d}]} + if {($d & ($d-1)) != 0} { + return [math::exact::Tstrict new \ + [math::exact::treduce [math::exact::mdott $m $t_]] \ + 0 [my l] [my r]] + } else { + return [math::exact::Tstrict new \ + [math::exact::tscale [math::exact::mdott $m $t_]] \ + 0 [my l] [my r]] + } + } + + # absorb -- + # + # Absorbs information from the subexpressions. + # + # Results: + # Returns a copy of the current object, with information from + # at least one subexpression absorbed so that more information is + # immediately available. + + method absorb {} { + if {![info exists absorbed_]} { + if {[math::exact::trefines $t_]} { + lassign [math::exact::trans $t_] m n + set side [math::exact::mdisjointm $m $n] + } else { + set side $i_ + } + if {$side} { + set absorbed_ [[[my r] applyTRight $t_ [my l]] ref] + } else { + set absorbed_ [[[my l] applyTLeft $t_ [my r]] ref] + } + } + return $absorbed_ + } + + # applyTRight -- + # + # Right-multiplies a tensor by this expression + # + # Results: + # Returns 't' left-product l right-product $r_. + + method applyTRight {t l} { + # This is the hard case of digit exchange. We have to + # get the leading digit from this tensor, absorbing as + # necessary, right-multiply it into the tensor $t, and + # compose the new object. + # + # Note that unless 'rest' is empty, 'ld' is a digit matrix, + # so we need to check only for powers of 2 when reducing to + # lowest terms + lassign [my getLeadingDigitAndRest 0] ld rest + if {$rest eq {}} { + set u [math::exact::mreduce [math::exact::trightv $t $ld]] + return [math::exact::Mstrict new $u $l] + } else { + set u [math::exact::tscale [math::exact::trightm $t $ld]] + return [math::exact::Tstrict new $u 0 $l $rest] + } + } + + # applyTLeft -- + # + # Left-multiplies a tensor by this expression + # + # Results: + # Returns 't' left-product $l_ right-product 'r' + method applyTLeft {t r} { + # This is the hard case of digit exchange. We have to + # get the leading digit from this tensor, absorbing as + # necessary, left-multiply it into the tensor $t, and + # compose the new object + # + # Note that unless 'rest' is empty, 'ld' is a digit matrix, + # so we need to check only for powers of 2 when reducing to + # lowest terms + lassign [my getLeadingDigitAndRest 0] ld rest + if {$rest eq {}} { + set u [math::exact::mreduce [math::exact::tleftv $t $ld]] + return [math::exact::Mstrict $u $r] + } else { + set u [math::exact::tscale [math::exact::tleftm $t $ld]] + return [math::exact::Tstrict new $u 1 $rest $r] + } + } + + # Derived classes are expected to implement the following: + # l -- + # + # Returns the left operand + method l {} { + error "[info object class [self object]] does not implement the 'l' method" + } + + # r -- + # + # Returns the right operand + method r {} { + error "[info object class [self object]] does not implement the 'r' method" + } + +} + +# math::exact::Tstrict -- +# +# A strict tensor - one where the subexpressions are both known in +# advance. + +oo::class create math::exact::Tstrict { + superclass math::exact::T + + # t_ - the tensor + # i_ A flag indicating whether the next 'absorb' should come from the + # left (0) or the right (1). + # l_ - the left subexpression + # r_ - the right subexpression + # absorbed_ - the result of an 'absorb' operation + + variable t_ i_ l_ r_ absorbed_ + + # constructor accepts the tensor, the absorption state, and the + # left and right operands. + constructor {t i l r} { + next $t $i + set l_ [$l ref] + set r_ [$r ref] + } + + # base class handles all cleanup + destructor { + next + } + + # l -- + # + # Returns the left operand + method l {} { + return $l_ + } + + # r -- + # + # Returns the right operand + method r {} { + return $r_ + } + + # dump -- + # + # Formats this object for debugging + method dump {} { + return T($t_,$i_\;[$l_ dump],[$r_ dump]) + } +} + +# math::exact::opreal -- +# +# Applies a bihomography (bilinear fractional transformation) +# to two expressions. +# +# Parameters: +# op - Tensor {{{a b} {c d}} {{e f} {g h}}} representing the operation +# x - left operand +# y - right operand +# +# Results: +# Returns an expression that represents the form: +# (axy + cx + ey + g) / (bxy + dx + fy + h) +# +# Notes: +# Note that the four basic arithmetic operations are included here. +# In addition, this procedure may be used to craft other useful +# transformations. For example, (1 - u**2) / (1 + u**2) +# could be constructed as [opreal {{{-1 1} {0 0}} {{0 0} {1 1}}} $u $u] + +proc math::exact::opreal {op x y {kludge {}}} { + # split x and y into sign and magnitude + $x ref; $y ref + lassign [$x getSignAndMagnitude] sx mx + lassign [$y getSignAndMagnitude] sy my + $mx ref; $my ref + $x unref; $y unref + set t [tleftm [trightm $op $sy] $sx] + set r [math::exact::Tstrict new $t 0 $mx $my] + $mx unref; $my unref + return $r +} + +# math::exact::+real -- +# math::exact::-real -- +# math::exact::*real -- +# math::exact::/real -- +# +# Sum, difference, product and quotient of exact reals +# +# Parameters: +# x - First operand +# y - Second operand +# +# Results: +# Returns x+y, x-y, x*y or x/y as requested. + +proc math::exact::+real {a b} { variable tadd; return [opreal $tadd $a $b] } +proc math::exact::-real {a b} { variable tsub; return [opreal $tsub $a $b] } +proc math::exact::*real {a b} { variable tmul; return [opreal $tmul $a $b] } +proc math::exact::/real {a b} { variable tdiv; return [opreal $tdiv $a $b] } + +# real -- +# +# Coerce an argument to exact-real (possibly from rational) +# +# Parameters: +# x - Argument to coerce. +# +# Results: +# Returns the argument coerced to a real. +# +# This operation either does nothing and returns its argument, or is a +# Consumer with respect to its argument and a Constructor with respect to +# its result. + +proc math::exact::function::real {x} { + tailcall $x asReal +} + +# SqrtWorker -- +# +# Class to calculate the square root of a real. + + +oo::class create math::exact::SqrtWorker { + superclass math::exact::T + variable l_ r_ + + # e - The expression whose square root should be calculated. + # e should be between close to 1 for good performance. The + # 'sqrtreal' procedure below handles the scaling. + constructor {e} { + next {{{1 0} {2 1}} {{1 2} {0 1}}} 0 + set l_ [$e ref] + } + method l {} { + return $l_ + } + method r {} { + if {![info exists r_]} { + set r_ [[math::exact::SqrtWorker new $l_] ref] + } + return $r_ + } + method dump {} { + return "sqrt([$l_ dump])" + } +} + +# sqrt -- +# +# Returns the square root of a number +# +# Parameters: +# x - Exact real number whose square root is needed. +# +# Results: +# Returns the square root as an exact real. +# +# The number may be rational or real. There is a special optimization used +# if the number is rational + +proc math::exact::function::sqrt {x} { + tailcall $x sqrt +} + +# ExpWorker -- +# +# Class that evaluates the exponential function for small exact reals + +oo::class create math::exact::ExpWorker { + superclass math::exact::T + variable t_ l_ r_ n_ + + # Constructor -- + # + # Parameters: + # e - Argument whose exponential is to be computed. (What is + # actually passed in is S0'(x) = (1+x)/(1-x)) + # n - Number of the convergent of the continued fraction + # + # This class is implemented by expanding the continued fraction + # as needed for precision. Each successive step becomes a new right + # subexpression of the tensor product. + + constructor {e {n 0}} { + next [list \ + [list \ + [list [expr {2*$n + 2}] [expr {2*$n + 1}]] \ + [list [expr {2*$n + 1}] [expr {2*$n}]]] \ + [list \ + [list [expr {2*$n}] [expr {2*$n + 1}]] \ + [list [expr {2*$n + 1}] [expr {2*$n + 2}]]]] 0 + set l_ [$e ref] + set n_ [expr {$n + 1}] + } + + # l -- + # + # Returns the left subexpression; that is, the argument to the + # exponential + method l {} { + return $l_ + } + + # r -- + # Returns the right subexpresison - the next convergent, creating it + # if necessary + method r {} { + if {![info exists r_]} { + set r_ [[math::exact::ExpWorker new $l_ $n_] ref] + } + return $r_ + } + + # dump -- + # + # Displays this object for debugging + method dump {} { + return ExpWorker([$l_ dump],[expr {$n_-1}]) + } +} + +# exp -- +# +# Evaluates the exponential function of an exact real +# +# Parameters: +# x - Quantity to be exponentiated +# +# Results: +# Returns the exact real function value. +# +# This procedure is a Consumer with respect to its argument and a +# Constructor with respect to its result, returning a zero-ref object. + +proc math::exact::function::exp {x} { + variable ::math::exact::iszer + variable ::math::exact::tmul + + # The continued fraction converges only for arguments between -1 and 1. + # If $iszer refines the argument, then it is in the correct range and + # we launch ExpWorker to evaluate the continued fraction. If the argument + # is outside the range [-1/2..1/2], then we evaluate exp(x/2) and square + # the result. If neither of the above is true, then we perform a digit + # exchange to get more information about the magnitude of the argument. + + $x ref + if {[$x refinesM $iszer]} { + # Argument's absolute value is small - evaluate the exponential + set y [$x applyM $iszer] + set result [ExpWorker new $y] + } elseif {[$x refinesM {{2 2} {-1 1}}]} { + # Argument's absolute value is large - evaluate exp(x/2)**2 + set xover2 [$x applyM {{1 0} {0 2}}] + set expxover2 [exp $xover2] + set result [*real $expxover2 $expxover2] + } else { + # Argument's absolute value is uncharacterized - perform a digit + # exchange to get more information. + set result [exp [$x absorb]] + } + $x unref + return $result +} + +# LogWorker -- +# +# Helper class for evaluating logarithm of an exact real argument. +# +# The algorithm used is a continued fraction representation from Peter Potts's +# paper. This worker evaluates the second and subsequent convergents. The +# first convergent is in the 'log' procedure below, and follows a different +# pattern from the rest of them. + +oo::class create math::exact::LogWorker { + superclass math::exact::T + variable t_ l_ r_ n_ + + # Constructor - + # + # Parameters: + # e - Argument whose log is to be extracted + # n - Number of the convergent. + constructor {e {n 1}} { + next [list \ + [list \ + [list $n 0] \ + [list [expr {2*$n + 1}] [expr {$n+1}]]] \ + [list \ + [list [expr {$n + 1}] [expr {2*$n + 1}]] \ + [list 0 $n]]] 0 + set l_ [$e ref] + set n_ [expr {$n + 1}] + } + + # l - + # Returns the argument whose log is to be extracted + method l {} { + return $l_ + } + + # r - + # Returns the next convergent, constructing it if necessary. + method r {} { + if {![info exists r_]} { + set r_ [[math::exact::LogWorker new $l_ $n_] ref] + } + return $r_ + } + + # dump - + # Dumps this object for debugging + method dump {} { + return LogWorker([$l_ dump],[expr {$n_-1}]) + } +} + +# log - +# +# Calculates the natural logarithm of an exact real argument. +# +# Parameters: +# x - Quantity whose log is to be extracted. +# +# Results: +# Returns the logarithm +# +# This procedure is a Consumer with respect to its argument and a Constructor +# with respect to its result, returning a zero-ref object. + +proc math::exact::function::log {x} { + variable ::math::exact::ispos + variable ::math::exact::isneg + variable ::math::exact::idpos + variable ::math::exact::idneg + variable ::math::exact::log2 + + # If x is between 1/2 and 2, the continued fraction will converge. If + # y = LogWorker(x), then log(x) = (xy + x - y - 1)/(x + y), and the + # latter function is a bihomography that can be evaluated by 'opreal' + # directly. + # + # If x is negative, that's an error. + # If x > 1, idpos will refine it, and we compute log(x/2) + log(2) + # If x < 1, idneg will refine it, and we compute log(2x) - log(2) + # If none of the above can be proven, perform a digit exchange and + # try again. + + $x ref + if {[$x refinesM {{2 -1} {-1 2}}]} { + # argument in bounds + set result [math::exact::opreal {{{1 0} {1 1}} {{-1 1} {-1 0}}} \ + $x \ + [LogWorker new $x]] + } elseif {[$x refinesM $isneg]} { + # domain error + return -code error -errorcode {MATH EXACT LOGNEGATIVE} \ + "log of negative argument" + } elseif {[$x refinesM $idpos]} { + # large argument, reduce it and try again + set result [+real [function::log [$x applyM {{1 0} {0 2}}]] $log2] + } elseif {[$x refinesM $idneg]} { + # small argument, increase it and try again + set result [-real [function::log [$x applyM {{2 0} {0 1}}]] $log2] + } else { + # too little information, perform digit exchange. + set result [function::log [$x absorb]] + } + $x unref + return $result +} + +# TanWorker -- +# +# Auxiliary function for tangent of an exact real argument +# +# This class develops the second and subsequent convergents of the continued +# fraction expansion in Potts's paper +oo::class create math::exact::TanWorker { + superclass math::exact::T + variable t_ l_ r_ n_ + + # Constructor - + # + # Parameters: + # e - S0'(x) = (1+x)/(1-x), where we wish to evaluate tan(x). + # n - Ordinal position of the convergent + constructor {e {n 1}} { + next [list \ + [list \ + [list [expr {2*$n + 1}] [expr {2*$n + 3}]] \ + [list [expr {2*$n - 1}] [expr {2*$n + 1}]]] \ + [list \ + [list [expr {2*$n + 1}] [expr {2*$n - 1}]] \ + [list [expr {2*$n + 3}] [expr {2*$n + 1}]]]] 0 + set l_ [$e ref] + set n_ [expr {$n + 1}] + } + + # l - + # Returns the argument S0'(x) + method l {} { + return $l_ + } + + # r - + # Returns the next convergent, constructing it if necessary + method r {} { + if {![info exists r_]} { + set r_ [[math::exact::TanWorker new $l_ $n_] ref] + } + return $r_ + } + + # dump - + # Displays this object for debugging + method dump {} { + return TanWorker([$l_ dump],[expr {$n_-1}]) + } +} + +# tan -- +# Tangent of an exact real argument +# +# Parameters: +# x - Quantity whose tangent is to be computed. +# +# Results: +# Returns the tangent +# +# This procedure is a Consumer with respect to its argument and a Constructor +# with respect to its result, returning a zero-ref object. + +proc math::exact::function::tan {x} { + variable ::math::exact::iszer + + # If |x| < 1, then we use Potts's formula for the tangent. + # If |x| > 1/2, then we compute y = tan(x/2) and then use the + # trig identity tan(x) = 2*y/(1-y**2), recognizing that the latter + # expression can be expressed as a bihomography applied to y and itself, + # allowing opreal to do the job. + # If neither can be proven, we perform a digit exchange to get more + # information. + # tan((2*n+1)*pi/2), for n an integer, is a well-behaved pole. + # In particular, 1/tan(pi/2) will correctly return zero. + + $x ref + if {[$x refinesM $iszer]} { + set xx [$x applyM $iszer] + set result [math::exact::Tstrict new {{{1 2} {1 0}} {{-1 0} {-1 2}}} 0 \ + $xx [TanWorker new $xx]] + } elseif {[$x refinesM {{2 2} {-1 1}}]} { + set xover2 [$x applyM {{1 0} {0 2}}] + set tanxover2 [function::tan $xover2] + set result [opreal {{{0 -1} {1 0}} {{1 0} {0 1}}} $tanxover2 $tanxover2] + } else { + set result [function::tan [$x absorb]] + } + $x unref + return $result +} + +# sin -- +# Sine of an exact real argument +# +# Parameters: +# x - Quantity whose sine is to be computed. +# +# Results: +# Returns the sine +# +# This procedure is a Consumer with respect to its argument and a Constructor +# with respect to its result, returning a zero-ref object. + +proc math::exact::function::sin {x} { + $x ref + set tanxover2 [tan [$x applyM {{1 0} {0 2}}]] + $x unref + return [opreal {{{0 1} {1 0}} {{1 0} {0 1}}} $tanxover2 $tanxover2] +} + +# cos -- +# Cosine of an exact real argument +# +# Parameters: +# x - Quantity whose cosine is to be computed. +# +# Results: +# Returns the cosine +# +# This procedure is a Consumer with respect to its argument and a Constructor +# with respect to its result, returning a zero-ref object. + +proc math::exact::function::cos {x} { + $x ref + set tanxover2 [tan [$x applyM {{1 0} {0 2}}]] + $x unref + return [opreal {{{-1 1} {0 0}} {{0 0} {1 1}}} $tanxover2 $tanxover2] +} + +# AtanWorker -- +# +# Auxiliary function for arctangent of an exact real argument +# +# This class develops the second and subsequent convergents of the continued +# fraction expansion in Potts's paper. The argument lies in [-1,1]. + +oo::class create math::exact::AtanWorker { + superclass math::exact::T + variable t_ l_ r_ n_ + # Constructor - + # + # Parameters: + # e - S0(x) = (x-1)/(x+1), where we wish to evaluate atan(x). + # n - Ordinal position of the convergent + constructor {e {n 1}} { + next [list \ + [list \ + [list [expr {2*$n + 1}] [expr {$n + 1}]] \ + [list $n 0]] \ + [list \ + [list 0 $n] \ + [list [expr {$n + 1}] [expr {2*$n + 1}]]]] 0 + set l_ [$e ref] + set n_ [expr {$n + 1}] + } + + # l - + # Returns the argument S0(x) + method l {} { + return $l_ + } + + # r - + # Returns the next convergent, constructing it if necessary + method r {} { + if {![info exists r_]} { + set r_ [[math::exact::AtanWorker new $l_ $n_] ref] + } + return $r_ + } + + # dump - + # Displays this object for debugging + method dump {} { + return AtanWorker([$l_ dump],[expr {$n_-1}]) + } +} + +# atanS0 - +# +# Evaluates the arctangent of S0(x) = (x-1)/(x+1) +# +# Parameters: +# x - Exact real argumetn +# +# Results: +# Returns atan((x-1)/(x+1)) +# +# This function is a Consumer with respect to its argument and a Constructor +# with respect to its result, returning a 0-reference object. + +proc math::exact::atanS0 {x} { + return [opreal {{{1 2} {1 0}} {{-1 0} {-1 2}}} $x [AtanWorker new $x]] +} + +# atan - +# +# Arctangent of an exact real +# +# Parameters: +# x - Exact real argument +# +# Results: +# Returns atan(x) +# +# This function is a Consumer with respect to its argument and a Constructor +# with respect to its result, returning a 0-reference object. +# +# atan(1/0) is undefined and may cause an infinite loop. + +proc math::exact::function::atan {x} { + + # TODO - find p/q close to the real number x - can be done by + # getting a few digits - and do + # arctan(p/q + eps) = arctan(p/q) + arctan(q**2*eps/(p*q*eps+p**q+q**2)) + # using [$eps applyM] to compute the argument of the second arctan + + variable ::math::exact::szer + variable ::math::exact::spos + variable ::math::exact::sinf + variable ::math::exact::sneg + variable ::math::exact::pi + + # Four cases, depending on which octant the arctangent lies in. + + $x ref + lassign [$x getSignAndMagnitude] signum mag + $mag ref + $x unref + set aS0x [atanS0 $mag] + $mag unref + if {$signum eq $szer} { + # -1 < x < 1 + return $aS0x + } elseif {$signum eq $spos} { + # x > 0 + return [opreal {{{0 0} {4 0}} {{1 0} {0 4}}} $aS0x $pi] + } elseif {$signum eq $sinf} { + # x < -1 or x > 1 + return [opreal {{{0 0} {2 0}} {{1 0} {0 2}}} $aS0x $pi] + } elseif {$signum eq $sneg} { + # x < 0 + return [opreal {{{0 0} {4 0}} {{-1 0} {0 4}}} $aS0x $pi] + } else { + # can't happen + error "wrong sign: $signum" + } +} + +# asinreal - +# +# Computes the arcsine of an exact real argument. +# +# The arcsine is computed from the arctangent by trigonometric identities +# +# This function is a Consumer with respect to its argument and a Constructor +# with respect to its result, returning a 0-reference object. +# +# The function is defined only over the open interval (-1,1). Outside +# that range INCLUDING AT THE ENDPOINTS, it may fail and give an infinite +# loop or stack overflow. + +proc math::exact::asinreal {x} { + variable iszer + variable pi + + # Potts's formula doesn't work here - it's singular at zero, + # and undefined over negative numbers. But some messing with the + # algebra gives us: + # asin(S0*x) = 2*atan(sqrt(x)) - pi/2 + # = (4*atan(sqrt(x)) - pi) / 2 + # which is continuous and computable over (-1..1) + $x ref + set y [$x applyM $iszer] + $x unref + return [opreal {{{0 0} {-1 0}} {{4 0} {0 2}}} \ + $pi \ + [function::atan [function::sqrt $y]]] +} + +interp alias {} math::exact::function::asin {} math::exact::asinreal + +# acosreal - +# +# Computes the arccosine of an exact real argument. +# +# The arccosine is computed from the arctangent by trigonometric identities +# +# This function is a Consumer with respect to its argument and a Constructor +# with respect to its result, returning a 0-reference object. +# +# The function is defined only over the open interval (-1,1). Outside +# that range INCLUDING AT THE ENDPOINTS, it may fail and give an infinite +# loop or stack overflow. + +proc math::exact::acosreal {x} { + variable iszer + variable pi + # Potts's formula doesn't work here - it's singular at zero, + # and undefined over negative numbers. But some messing with the + # algebra gives us: + # acos(S0*x) = pi - 2*atan(sqrt(x)) + $x ref + set y [$x applyM $iszer] + $x unref + return [opreal {{{0 0} {1 0}} {{-2 0} {0 1}}} \ + $pi \ + [function::atan [function::sqrt $y]]] +} + +interp alias {} math::exact::function::acos {} math::exact::acosreal + +# sinhreal, coshreal, tanhreal -- +# +# Hyperbolic functions of exact real arguments +# +# Parameter: +# x - Argument at which to evaluate the function +# +# Results: +# Return sinh(x), cosh(x), tanh(x), respectively. +# +# These functions are all Consumers with respect to their arguments and +# Constructors with respect to their results, returning zero-ref objects. +# +# The three functions are well defined over all the finite reals, but +# are ill-behaved at infinity. + +proc math::exact::sinhreal {x} { + set expx [function::exp $x] + return [opreal {{{1 0} {0 1}} {{0 1} {-1 0}}} $expx $expx] +} + +interp alias {} math::exact::function::sinh {} math::exact::sinhreal + +proc math::exact::coshreal {x} { + set expx [function::exp $x] + return [opreal {{{1 0} {0 1}} {{0 1} {1 0}}} $expx $expx] +} + +interp alias {} math::exact::function::cosh {} math::exact::coshreal + +proc math::exact::tanhreal {x} { + set expx [function::exp $x] + return [opreal {{{1 1} {0 0}} {{0 0} {-1 1}}} $expx $expx] +} + +interp alias {} math::exact::function::tanh {} math::exact::tanhreal + +# asinhreal, acoshreal, atanhreal -- +# +# Inverse hyperbolic functions of exact real arguments +# +# Parameter: +# x - Argument at which to evaluate the function +# +# Results: +# Return asinh(x), acosh(x), atanh(x), respectively. +# +# These functions are all Consumers with respect to their arguments and +# Constructors with respect to their results, returning zero-ref objects. +# +# asinh is defined over the entire real number line, with the exception +# of the point at infinity. acosh is defined over x > 1 (NOT x=1, which +# is singular). atanh is defined over (-1..1) (NOT the endpoints of the +# interval.) + +proc math::exact::asinhreal {x} { + # domain (-Inf .. Inf) + # asinh(x) = log(x + sqrt(x**2 + 1)) + $x ref + set retval [function::log \ + [+real $x \ + [function::sqrt \ + [opreal {{{1 0} {0 0}} {{0 0} {1 1}}} $x $x]]]] + $x unref + return $retval +} + +interp alias {} math::exact::function::asinh {} math::exact::asinhreal + +proc math::exact::acoshreal {x} { + # domain (1 .. Inf) + # asinh(x) = log(x + sqrt(x**2 - 1)) + $x ref + set retval [function::log \ + [+real $x \ + [function::sqrt \ + [opreal {{{1 0} {0 0}} {{0 0} {-1 1}}} $x $x]]]] + $x unref + return $retval +} + +interp alias {} math::exact::function::acosh {} math::exact::acoshreal + +proc math::exact::atanhreal {x} { + # domain (-1 .. 1) + variable sinf + #atanh(x) = log(Sinf[x])/2 + + $x ref + set y [$x applyM $sinf] + $y ref + $x unref + set z [function::log $y] + $z ref + $y unref + set retval [$z applyM {{1 0} {0 2}}] + $z unref + return $retval +} + +interp alias {} math::exact::function::atanh {} math::exact::atanhreal + +# EWorker -- +# +# Evaluates the constant 'e' (the base of the natural logarithms +# +# This class is intended to be singleton. It returns 2.71828.... (the +# base of the natural logarithms) as an exact real. + +oo::class create math::exact::EWorker { + superclass math::exact::M + variable m_ e_ n_ + + # Constructor accepts the number of the continuant. + + constructor {{n 0}} { + set n_ [expr {$n + 1}] + next [list [list [expr {2*$n + 2}] [expr {2*$n + 1}]] \ + [list [expr {2*$n + 1}] [expr {2*$n}]]] + } + destructor { + next + } + + # e -- Returns the next continuant after this one. + + method e {} { + if {![info exists e_]} { + set e_ [[math::exact::EWorker new $n_] ref] + } + return $e_ + } + + # Formats this object for debugging + + method dump {} { + return M($m_,EWorker($n_)) + } +} + +# PiWorker -- +# +# Auxiliary object used in evaluating pi. +# +# This class evaluates the second and subsequent continuants in +# Ramanaujan's formula for sqrt(10005)/pi. The Potts paper presents +# the algorithm, almost without commentary. + +oo::class create math::exact::PiWorker { + superclass math::exact::M + variable m_ e_ n_ + + # Constructor accepts the number of the continuant + + constructor {{n 1}} { + set n_ [expr {$n + 1}] + set nsq [expr {$n * $n}] + set n4 [expr {$nsq * $nsq}] + set b [expr {(2*$n - 1) * (6*$n - 5) * (6*$n - 1)}] + set c [expr {$b * (545140134 * $n + 13591409)}] + set d [expr {$b * ($n + 1)}] + set e [expr {10939058860032000 * $n4}] + set p [list [expr {$e - $d - $c}] [expr {$e + $d + $c}]] + set q [list [expr {$e + $d - $c}] [expr {$e - $d + $c}]] + next [list $p $q] + } + destructor { + next + } + + # e -- + # + # Returns the next continuant after this one + + method e {} { + if {![info exists e_]} { + set e_ [[math::exact::PiWorker new $n_] ref] + } + return $e_ + } + + # dump -- + # + # Formats this object for debugging + method dump {} { + return M($m_,PiWorker($n_)) + } +} + +# Log2Worker -- +# +# Auxiliary class for evaluating log(2). +# +# This object represents the constant (1-2*log(2))/(log(2)-1), the +# product of the second, third, ... nth LFT's of the representation of log(2). + +oo::class create math::exact::Log2Worker { + superclass math::exact::M + variable m_ e_ n_ + + # Constructor accepts the number of the continuant + constructor {{n 1}} { + set n_ [expr {$n + 1}] + set a [expr {3*$n + 1}] + set b [expr {2*$n + 1}] + set c [expr {4*$n + 2}] + set d [expr {3*$n + 2}] + next [list [list $a $b] [list $c $d]] + } + destructor { + next + } + + # e -- + # + # Returns the next continuant after this one. + method e {} { + if {![info exists e_]} { + set e_ [[math::exact::Log2Worker new $n_] ref] + } + return $e_ + } + + # dump -- + # + # Displays this object for debugging + method dump {} { + return M($m_,Log2Worker($n_)) + } +} + +# Sqrtrat -- +# +# Class that evaluates the square root of a rational + +oo::class create math::exact::Sqrtrat { + superclass math::exact::M + variable m_ e_ a_ b_ c_ + + # Constructor accepts the numerator and denominator. The third argument + # is an intermediate result for the second and later continuants. + constructor {a b {c {}}} { + if {$c eq {}} { + set c [expr {$a - $b}] + } + set d [expr {2*($b-$a) + $c}] + if {$d >= 0} { + next $math::exact::dneg + set a_ [expr {4 * $a}] + set b_ $d + set c_ $c + } else { + next $math::exact::dpos + set a_ [expr {-$d}] + set b_ [expr {4 * $b}] + set c_ $c + } + } + destructor { + next + } + + # e -- + # + # Returns the next continuant after this one. + method e {} { + if {![info exists e_]} { + set e_ [[math::exact::Sqrtrat new $a_ $b_ $c_] ref] + } + return $e_ + } + + # dump -- + # Formats this object for debugging. + + method dump {} { + return "M($m_,Sqrtrat($a_,$b_,$c_))" + } +} + +# math::exact::rat**int -- +# +# Service procedure to raise a rational number to an integer power +# +# Parameters: +# a - Numerator of the rational +# b - Denominator of the rational +# n - Power +# +# Preconditions: +# n is not zero, a is not zero, b is positive. +# +# Results: +# Returns the power +# +# This procedure is a Consumer with respect to its arguments and a +# Constructor with respect to its result, returning a zero-ref object. + +proc math::exact::rat**int {a b n} { + if {$n < 0} { + return [V new [list [expr {$b**(-$n)}] [expr {$a**(-$n)}]]] + } elseif {$n > 0} { + return [V new [list [expr {$a**($n)}] [expr {$b**($n)}]]] + } else { ;# zero power shouldn't get here + return [V new {1 1}] + } +} + +# math::exact::rat**rat -- +# +# Service procedure to raise a rational number to a rational power +# +# Parameters: +# a - Numerator of the base +# b - Denominator of the base +# m - Numerator of the exponent +# n - Denominator of the exponent +# +# Results: +# Returns the power as an exact real +# +# Preconditions: +# a != 0, b > 0, m != 0, n > 0 +# +# This procedure is a Constructor with respect to its result + +proc math::exact::rat**rat {a b m n} { + + # It would be attractive to special case this, but the real mechanism + # works as well for the moment. + + tailcall real**rat [V new [list $a $b]] $m $n +} + +# PowWorker -- +# +# Auxiliary class to compute +# ((p/q)**n + b)**(m/n), +# where 0<m<n are integers, p, q are integers, b is an exact real + +oo::class create math::exact::PowWorker { + superclass math::exact::T + + variable t_ l_ r_ delta_ + + # Self-method: start + # + # Sets up to find z**(m/n) (1 <= m < n), with + # z = (p/q)**n + y for integers p and q. + # + # Parameters: + # p - numerator of the estimated nth root + # q - denominator of the estimated nth root + # y - residual of the quantity whose root is being extracted + # m - numerator of the exponent + # n - denominator of the exponent (1 <= m < n) + # + # Results: + # Returns the power, as an exact real. + + self method start {p q y m n} { + set pm [expr {$p ** $m}] + set pnmm [expr {$p ** ($n-$m)}] + set pn [expr {$pm * $pnmm}] + set qm [expr {$q ** $m}] + set qnmm [expr {$q ** ($n-$m)}] + set qn [expr {$qm * $qnmm}] + + set t0 \ + [list \ + [list \ + [list [expr {$m * $qn}] [expr {$n*$pnmm*$qm}]] \ + [list 0 [expr {($n-$m) * $qn}]]] \ + [list \ + [list [expr {2 * $n * $pn}] 0] \ + [list [expr {2 * ($n-$m) * $pm * $qnmm}] 0]]] + set t1 \ + [list \ + [list \ + [list [expr {$n * $qn}] [expr {2*$n * $pnmm*$qm}]] \ + [list 0 [expr {$n * $qn}]]] \ + [list \ + [list [expr {4 * $n * $pn}] 0] \ + [list [expr {2 * $n * $pm * $qnmm}] 0]]] + + set tinit \ + [list \ + [list \ + [list [expr {$m * $qn}] 0] \ + [list 0 0]] \ + [list \ + [list [expr {$n * $pn}] [expr {$n * $pnmm * $qm}]] \ + [list \ + [expr {($n-$m) * $pm * $qnmm}] \ + [expr {($n-$m) * $qn}]]]] + $y ref + set result [$y applyTLeft $tinit [my new $t0 $t1 $y]] + $y unref + return $result + } + + # Constructor -- + # + # Parameters: + # t0 - Tensor from the previous iteration + # delta - Increment to use + # y - Residual + # + # The constructor should not be called directly. Instead, the 'start' + # method should be called to initialize the iteration + + constructor {t0 delta y} { + set t [math::exact::tadd $t0 $delta] + next $t 0 + set l_ [$y ref] + set delta_ $delta + } + + # l -- + # + # Returns the left subexpression: that is, the 'y' parameter + method l {} { + return $l_ + } + + # r -- + # + # Returns the right subexpression: that is, the next continuant, + # creating it if necessary + method r {} { + if {![info exists r_]} { + set r_ [[math::exact::PowWorker new $t_ $delta_ $l_] ref] + } + return $r_ + } + + method dump {} { + set res "PowWorker($t_,$delta_,[$l_ dump]," + if {[info exists r_]} { + append res [$r_ dump] + } else { + append res ... + } + append res ")" + return $res + } + +} + +# math::exact::real**int -- +# +# Service procedure to raise a real number to an integer power. +# +# Parameters: +# b - Number to exponentiate +# e - Power to raise b to. +# +# Results: +# Returns the power. +# +# This procedure is a Consumer with respect to its arguments and a +# Constructor with respect to its result, returning a zero-ref object. + +proc math::exact::real**int {b e} { + + # Handle a negative power by raising the reciprocal of the base to + # a positive power + if {$e < 0} { + set e [expr {-$e}] + set b [K [[$b ref] applyM {{0 1} {1 0}}] [$b unref]] + } + + # Reduce using square-and-add + $b ref + set result [V new {1 1}] + while {$e != 0} { + if {$e & 1} { + set result [$b * $result] + set e [expr {$e & ~1}] + } + if {$e == 0} break + set b [K [[$b * $b] ref] [$b unref]] + set e [expr {$e>>1}] + } + $b unref + return $result +} + +# math::exact::real**rat -- +# +# Service procedure to raise a real number to a rational power. +# +# Parameters - +# +# b - The base to be exponentiated +# m - The numerator of the power +# n - The denominator of the power +# +# Preconditions: +# n > 0 +# +# Results: +# Returns the power. +# +# This procedure is a Consumer with respect to its arguments and a +# Constructor with respect to its result, returning a zero-ref object. + +proc math::exact::real**rat {b m n} { + + variable isneg + variable ispos + + # At this point we need to know the sign of b. Try to determine it. + # (This can be an infinite loop if b is zero or infinite) + while {1} { + if {[$b refinesM $ispos]} { + break + } elseif {[$b refinesM $isneg]} { + # negative number to rational power. The denominator must be + # odd. + if {$n % 2 == 0} { + return -code error -errorCode {MATH EXACT NEGATIVEPOWREAL} \ + "negative number to real power" + } else { + set b [K [[$b ref] U-] [$b unref]] + tailcall [math::exact::real**rat $b $m $n] U- + } + } else { + # can't determine positive or negative yet + $b ref + set nextb [$b absorb] + set result [math::exact::real**rat $nextb $m $n] + $b unref + return $result + } + } + + # Handle b(-m/n) by taking (1/b)(m/n) + if {$m < 0} { + set m [expr {-$m}] + set b [K [[$b ref] applyM {{0 1} {1 0}}] [$b unref]] + } + + # Break m/n apart into integer and fractional parts + set i [expr {$m / $n}] + set m [expr {$m % $n}] + + # Do the integer part + $b ref + set result [real**int $b $i] + if {$m == 0} { + # We really shouldn't get here if m/n is an integer, but don't choke + $b unref + return $result + } + + # Come up with a rational approximation for b**(1/n) + # real: exp(log(b)/n) + set approx [[math::exact::function::exp \ + [[math::exact::function::log $b] \ + * [math::exact::V new [list 1 $n]]]] ref] + lassign [$approx getSignAndMagnitude] partial rest + $rest ref + $approx unref + while {1} { + lassign [$rest getLeadingDigitAndRest 0] digit y + $y ref + $rest unref + set partial [math::exact::mscale [math::exact::mdotm $partial $digit]] + set rest $y + lassign $partial pq rs + lassign $pq p q + lassign $rs r s + set qrn [expr {($q*$r)**$n}] + set t1 [expr {$qrn}] + set t2 [expr {2 * ($p*$s)**$n}] + set t3 [expr {4 * $qrn}] + if {$t1 < $t2 && $t2 < $t3} break + } + $y unref + + # Get the residual + + lassign [math::exact::vscale [list $r $s]] p q + set xn [math::exact::V new [list [expr {$p**$n}] [expr {$q**$n}]]] + set y [$b - $xn]; $b unref + + # Launch a worker process to perform quasi-Newton iteration to refine + # the result + + set retval [$result * [math::exact::PowWorker start $p $q $y $m $n]] + return $retval +} + +# pi -- +# +# Returns pi as an exact real + +proc math::exact::function::pi {} { + variable ::math::exact::pi + return $pi +} + +# e -- +# +# Returns e as an exact real + +proc math::exact::function::e {} { + variable ::math::exact::e + return $e +} + +# math::exact::signum1 -- +# +# Tests an argument's sign. +# +# Parameters: +# x - Exact real number to test. +# +# Results: +# Returns -1 if x < -1. Returns 1 if x > 1. May return -1, 0 or 1 if +# -1 <= x <= 1. +# +# Equality of exact reals is not decidable, so a weaker version of comparison +# testing is needed. This function provides the guts of such a thing. It +# returns an approximation to the signum function that is exact for +# |x| > 1, and arbitrary for |x| < 1. +# +# A typical use would be to replace a test p < q with a test that +# looks like signum1((p-q) / epsilon) == -1. This test is decidable, +# and becomes a test that is true if p < q - epsilon, false if p > q+epsilon, +# and indeterminate if p lies within epsilon of q. This test is enough for +# most checks for convergence or for selecting a branch of a function. +# +# This function is not decidable if it is not decidable whether x is finite. + +proc math::exact::signum1 {x} { + variable ispos + variable isneg + variable iszer + while {1} { + if {[$x refinesM $ispos]} { + return 1 + } elseif {[$x refinesM $isneg]} { + return -1 + } elseif {[$x refinesM $iszer]} { + return 0 + } else { + set x [$x absorb] + } + } +} + +# math::exact::abs1 - +# +# Test whether an exact real is 'small' in absolute value. +# +# Parameters: +# x - Exact real number to test +# +# Results: +# Returns 0 if |x| is 'close to zero', 1 if |x| is 'far from zero' +# and either 0, or 1 if |x| is close to 1. +# +# This function is another useful comparator for convergence testing. +# It returns a three-way indication: +# |x| < 1/2 : 0 +# |x| > 1 : 1 +# 1/2 <= |x| <= 2 : May return -1, 0, 1 +# +# This function is useful for convergence testing, where it is desired +# to know whether a given value has an absolute value less than a given +# tolerance. + +proc math::exact::abs1 {x} { + variable iszer + while 1 { + if {[$x refinesM $iszer]} { + return 0 + } elseif {[$x refinesM {{2 1} {-2 1}}]} { + return 1 + } else { + set x [$x absorb] + } + } +} + +namespace eval math::exact { + + # Constant vectors, matrices and tensors + + ; # the identity matrix + variable identity {{ 1 0} { 0 1}} + ; # sign matrices for exact floating point + variable spos $identity + variable sinf {{ 1 -1} { 1 1}} + variable sneg {{ 0 1} {-1 0}} + variable szer {{ 1 1} {-1 1}} + + ; # inverses of the sign matrices + variable ispos [reverse $spos] + variable isinf [reverse $sinf] + variable isneg [reverse $sneg] + variable iszer [reverse $szer] + + ; # digit matrices for exact floating point + variable dneg {{ 1 1} { 0 2}} + variable dzer {{ 3 1} { 1 3}} + variable dpos {{ 2 0} { 1 1}} + + ; # inverses of the digit matrices + variable idneg [reverse $dneg] + variable idzer [reverse $dzer] + variable idpos [reverse $dpos] + + ; # aritmetic operators as tensors + variable tadd {{{ 0 0} { 1 0}} {{ 1 0} { 0 1}}} + variable tsub {{{ 0 0} { 1 0}} {{-1 0} { 0 1}}} + variable tmul {{{ 1 0} { 0 0}} {{ 0 0} { 0 1}}} + variable tdiv {{{ 0 0} { 1 0}} {{ 0 1} { 0 0}}} + + proc init {} { + + # Variables for fundamental constants e, pi, log2 + + variable e [[EWorker new] ref] + + set worker \ + [[math::exact::Mstrict new {{6795705 213440} {6795704 213440}} \ + [math::exact::PiWorker new]] ref] + variable pi [[/real [function::sqrt [V new {10005 1}]] $worker] ref] + $worker unref + + set worker [[Log2Worker new] ref] + variable log2 [[$worker applyM {{1 1} {1 2}}] ref] + $worker unref + + } + init + rename init {} + + namespace export exactexpr abs1 signum1 +} + +package provide math::exact 1.0 + +#----------------------------------------------------------------------- diff --git a/tcllib/modules/math/exact.test b/tcllib/modules/math/exact.test new file mode 100644 index 0000000..9117dee --- /dev/null +++ b/tcllib/modules/math/exact.test @@ -0,0 +1,2255 @@ +# exact.test -- +# +# Test cases for the math::exact package +# +# Copyright (c) 2015 by Kevin B. Kenny +# +# 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.6 +testsNeedTcltest 2.3 + +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 exact.tcl math::exact +} + +package require Tcl 8.6 +package require grammar::aycock 1.0 +package require math::exact 1.0 + +#----------------------------------------------------------------------------- + +namespace eval math::exact::test { + + namespace import ::math::exact::exactexpr + + proc signum {x} {expr {($x > 0) - ($x < 0)}} + + proc leakBaseline {} { + variable leakBaseline + foreach o [info commands ::oo::Obj*] { + dict set leakBaseline $o {} + } + return + } + + proc leakCheck {} { + variable leakBaseline + set trouble {} + set sep {} + foreach o [lsort -dictionary [info commands ::oo::Obj*]] { + if {![dict exists $leakBaseline $o]} { + if {[info object isa typeof $o math::exact::counted]} { + append trouble $sep "Leaked counted object " \ + $o ": " [$o dump] \n + } else { + append trouble $sep "Leaked object " $o \n + } + } + } + if {$trouble ne {}} { + return -code error -errorcode {LEAKCHECK} $trouble + } + return + } + + namespace import ::tcltest::test + + test math::exact-1.0 {unit test gcd} { + math::exact::gcd 2 + } 2 + test math::exact-1.1 {unit test gcd} { + math::exact::gcd 2 0 + } 2 + test math::exact-1.2 {unit test gcd} { + math::exact::gcd 0 2 + } 2 + test math::exact-1.3 {unit test gcd} { + math::exact::gcd 2 3 + } 1 + test math::exact-1.4 {unit test gcd} { + math::exact::gcd 3 2 + } 1 + test math::exact-1.5 {unit test gcd} { + math::exact::gcd 21 12 + } 3 + test math::exact-1.6 {unit test gcd} { + math::exact::gcd 12 21 + } 3 + test math::exact-1.5 {unit test gcd} { + math::exact::gcd 21 12 + } 3 + test math::exact-1.6 {unit test gcd} { + math::exact::gcd 12 21 + } 3 + test math::exact-1.7 {unit test gcd} { + math::exact::gcd 108 66 + } 6 + test math::exact-1.8 {unit test gcd} { + math::exact::gcd 66 108 + } 6 + test math::exact-1.9 {unit test gcd} { + math::exact::gcd 66 108 88 + } 2 + + test math::exact-2.0 {unit test transpose matrix} { + math::exact::trans {{0 1} {2 3}} + } {{0 2} {1 3}} + test math::exact-2.1 {unit test transpose 2x2x2} { + math::exact::trans {{{0 1} {2 3}} {{4 5} {6 7}}} + } {{{0 1} {4 5}} {{2 3} {6 7}}} + + test math::exact-3.1 {unit test determinant} { + math::exact::determinant {{2 3} {5 7}} + } -1 + + test math::exact-4.1 {unit test reverse} { + math::exact::reverse {{2 3} {5 7}} + } {{7 -3} {-5 2}} + + test math::exact-5.1 {unit test veven} { + math::exact::veven {2 4} + } 1 + test math::exact-5.2 {unit test veven} { + math::exact::veven {2 3} + } 0 + + test math::exact-6.1 {unit test meven} { + math::exact::meven {{2 4} {6 8}} + } 1 + test math::exact-6.2 {unit test meven} { + math::exact::meven {{2 3} {6 8}} + } 0 + + test math::exact-7.1 {unit test teven} { + math::exact::teven {{{2 4} {6 8}} {{10 12} {14 16}}} + } 1 + test math::exact-7.2 {unit test teven} { + math::exact::teven {{{2 4} {6 8}} {{10 13} {14 16}}} + } 0 + + test math::exact-8.1 {unit test vhalf} { + math::exact::vhalf {6 8} + } {3 4} + + test math::exact-9.1 {unit test mhalf} { + math::exact::mhalf {{6 8} {10 12}} + } {{3 4} {5 6}} + + test math::exact-10.1 {unit test thalf} { + math::exact::thalf {{{6 8} {10 12}} {{14 16} {18 20}}} + } {{{3 4} {5 6}} {{7 8} {9 10}}} + + test math::exact-11.1 {unit test sign} { + set trouble {} + set sep \n + for {set a -1} {$a <= 1} {incr a} { + for {set b -1} {$b <= 1} {incr b} { + if {$a ==0 && $b == 0} { + set sb 0 + } elseif {$a == 0} { + set sb [signum $b] + } elseif {$b == 0} { + set sb [signum $a] + } elseif {$a/$b < 0} { + set sb 0 + } else { + set sb [signum $a] + } + set is [math::exact::sign [list $a $b]] + if {$is != $sb} { + append trouble "sign(" $a "," $b ") is " $is \ + ", should be " $sb "\n" + } + } + } + set trouble + } {} + + test math::exact-12.1 {unit test vrefines} { + set trouble {} + set sep {} + for {set a -1} {$a <= 1} {incr a} { + for {set b -1} {$b <= 1} {incr b} { + if {$a ==0 && $b == 0} { + set sb 0 + } elseif {$a == 0} { + set sb 1 + } elseif {$b == 0} { + set sb 1 + } elseif {$a/$b < 0} { + set sb 0 + } else { + set sb 1 + } + set is [math::exact::vrefines [list $a $b]] + if {$is != $sb} { + append trouble $sep "vrefines(" $a "," $b ") is " $is \ + ", should be " $sb + set sep \n + } + } + } + set trouble + } {} + + test math::exact-13.1 {unit test mrefines} { + math::exact::mrefines {{1 2} {3 4}} + } 1 + test math::exact-13.2 {unit test mrefines} { + math::exact::mrefines {{1 2} {-3 -4}} + } 0 + test math::exact-13.3 {unit test mrefines} { + math::exact::mrefines {{-1 -2} {-3 -4}} + } 1 + test math::exact-13.4 {unit test mrefines} { + math::exact::mrefines {{-1 2} {-3 4}} + } 0 + + test math::exact-14.1 {unit test trefines} { + math::exact::trefines {{{1 2} {3 4}} {{5 6} {7 8}}} + } 1 + test math::exact-14.2 {unit test trefines} { + math::exact::trefines {{{-1 -2} {-3 -4}} {{-5 -6} {-7 -8}}} + } 1 + test math::exact-14.3 {unit test trefines} { + math::exact::trefines {{{-1 2} {-3 4}} {{-5 6} {-7 8}}} + } 0 + test math::exact-14.4 {unit test trefines} { + math::exact::trefines {{{1 2} {3 4}} {{5 6}} {{-7 -8}}} + } 0 + test math::exact-14.5 {unit test trefines} { + math::exact::trefines {{{1 2} {3 4}} {{-5 -6}} {{-7 -8}}} + } 0 + test math::exact-14.6 {unit test trefines} { + math::exact::trefines {{{1 2} {-3 -4}} {{-5 -6}} {{-7 -8}}} + } 0 + + test math::exact-15.1 {unit test vlessv} { + set intervals { + {-1 0} {-2 1} {-1 1} {-1 2} {0 1} {2 4} {3 3} {14 7} {1 0} + } + set trouble {} + set sep {} + set i 0 + foreach a $intervals { + set j 0 + foreach b $intervals { + set is [math::exact::vlessv $a $b] + if {[lindex $a 1] == 0 && [lindex $b 1] == 0} { + set sb 0 + } else { + set sb [expr {$i < $j}] + } + if {$is != $sb} { + append trouble $sep "vlessv(" $a ";" $b ") is " $is \ + " should be " $sb + set sep \n + } + incr j + } + incr i + } + set trouble + } {} + + test math::exact-16.1 {unit test mlessm - also tests mlessv} { + set intervals { + {-2 1} {-1 1} {-1 2} {0 1} {2 4} {3 3} {14 7} {1 0} + } + set trouble {} + set sep {} + set i 0 + foreach a $intervals { + set j $i + foreach b [lrange $intervals $i end] { + set k 0 + foreach c $intervals { + set l $k + foreach d [lrange $intervals $k end] { + if {[lindex $b 1] == 0 && [lindex $c 1] == 0} { + set sb 0 + } else { + set sb [expr {$j < $k}] + } + set is [math::exact::mlessm [list $b $a] [list $d $c]] + if {$is != $sb} { + append trouble $sep "mlessm(" $a "," $b ";" \ + $c "," $d ") is " $is \ + " should be " $sb " -- " \ + [list i $i j $j k $k l $k] + set sep \n + } + incr l + } + incr k + } + incr j + } + incr i + } + set trouble + } {} + + test math::exact-17.1 {unit test vscale} { + math::exact::vscale {2 3} + } {2 3} + test math::exact-17.2 {unit test vscale} { + math::exact::vscale {4 6} + } {2 3} + test math::exact-17.1 {unit test vscale} { + math::exact::vscale {8 12} + } {2 3} + + test math::exact-18.1 {unit test mscale} { + math::exact::mscale {{2 3} {4 5}} + } {{2 3} {4 5}} + test math::exact-18.2 {unit test mscale} { + math::exact::mscale {{4 6} {8 10}} + } {{2 3} {4 5}} + test math::exact-18.3 {unit test mscale} { + math::exact::mscale {{8 12} {16 20}} + } {{2 3} {4 5}} + + test math::exact-19.1 {unit test tscale} { + math::exact::tscale {{{2 3} {4 5}} {{6 7} {8 9}}} + } {{{2 3} {4 5}} {{6 7} {8 9}}} + test math::exact-19.2 {unit test tscale} { + math::exact::tscale {{{4 6} {8 10}} {{12 14} {16 18}}} + } {{{2 3} {4 5}} {{6 7} {8 9}}} + test math::exact-10.3 {unit test tscale} { + math::exact::tscale {{{8 12} {16 20}} {{24 28} {32 36}}} + } {{{2 3} {4 5}} {{6 7} {8 9}}} + + test math::exact-20.1 {unit test vreduce} { + math::exact::vreduce {2 3} + } {2 3} + test math::exact-20.2 {unit test vreduce} { + math::exact::vreduce {4 6} + } {2 3} + test math::exact-20.1 {unit test vreduce} { + math::exact::vreduce {8 12} + } {2 3} + + test math::exact-21.1 {unit test mreduce} { + math::exact::mreduce {{2 3} {4 5}} + } {{2 3} {4 5}} + test math::exact-21.2 {unit test mreduce} { + math::exact::mreduce {{4 6} {8 10}} + } {{2 3} {4 5}} + test math::exact-21.3 {unit test mreduce} { + math::exact::mreduce {{8 12} {16 20}} + } {{2 3} {4 5}} + + test math::exact-22.1 {unit test treduce} { + math::exact::treduce {{{2 3} {4 5}} {{6 7} {8 9}}} + } {{{2 3} {4 5}} {{6 7} {8 9}}} + test math::exact-22.2 {unit test treduce} { + math::exact::treduce {{{4 6} {8 10}} {{12 14} {16 18}}} + } {{{2 3} {4 5}} {{6 7} {8 9}}} + test math::exact-22.3 {unit test treduce} { + math::exact::treduce {{{8 12} {16 20}} {{24 28} {32 36}}} + } {{{2 3} {4 5}} {{6 7} {8 9}}} + + test math::exact-23.1 {unit test mdotv} { + math::exact::mdotv {{2 3} {4 5}} {10 1} + } {24 35} + + test math::exact-24.1 {unit test mdotm} { + math::exact::mdotm {{2 3} {4 5}} {{1000 10} {100 1}} + } {{2040 3050} {204 305}} + + test math::exact-25.1 {unit test mdott} { + math::exact::mdott {{1000 10} {100 1}} {{{2 3} {4 5}} {{6 7} {8 9}}} + } {{{2300 23} {4500 45}} {{6700 67} {8900 89}}} + + test math::exact-26.1 {unit test tleftv} { + math::exact::tleftv {{{2 3} {4 5}} {{6 7} {8 9}}} {10 1} + } {{26 37} {48 59}} + + test math::exact-27.1 {unit test trightv} { + math::exact::trightv {{{2 3} {4 5}} {{6 7} {8 9}}} {10 1} + } {{24 35} {68 79}} + + test math::exact-28.1 {unit test tleftm} { + math::exact::tleftm {{{2 3} {4 5}} {{6 7} {8 9}}} {{1000 10} {100 1}} + } {{{2060 3070} {4080 5090}} {{206 307} {408 509}}} + + test math::exact-29.1 {unit test trightm} { + math::exact::trightm {{{2 3} {4 5}} {{6 7} {8 9}}} {{1000 10} {100 1}} + } {{{2040 3050} {204 305}} {{6080 7090} {608 709}}} + + test math::exact-30.1 {unit test mdisjointm} { + set intervals { + {-2 1} {-1 1} {-1 2} {0 1} {2 4} {3 3} {14 7} {1 0} + } + set trouble {} + set sep {} + set i 0 + foreach a $intervals { + set j $i + foreach b [lrange $intervals $i end] { + set k 0 + foreach c $intervals { + set l $k + foreach d [lrange $intervals $k end] { + set sb [expr {$j < $k || $l < $i}] + set is [math::exact::mdisjointm \ + [list $b $a] [list $d $c]] + if {$is != $sb} { + append trouble $sep "mdisjointm(" $a "," $b ";" \ + $c "," $d ") is " $is \ + " should be " $sb " -- " \ + [list i $i j $j k $k l $k] + set sep \n + } + incr l + } + incr k + } + incr j + } + incr i + } + set trouble + } {} + + test math::exact-31.0 {mAsFloat, rational} { + math::exact::mAsFloat {{1 3} {1 3}} + } 1/3 + + test math::exact-31.1 {mAsFloat, scientificNotation, mantissa, eFormat} { + set p 0 + set q 1 + set res {} + for {set i 0} {$i < 16} {incr i} { + set r [expr {$p + $q}] + if {$q * $q > $p * $r} { + set m [list [list $q $p] \ + [list $r $q]] + } else { + set m [list [list $r $q] \ + [list $q $p]] + } + lappend res [math::exact::mAsFloat $m] + set p $q + set q $r + } + set res + } [list \ + Undetermined 1.e0 1.e0 1.6e0 1.6e0 1.6e0 1.62e0 1.61e0 1.61e0 \ + 1.618e0 1.618e0 1.6180e0 1.6180e0 1.61803e0 1.61803e0 1.61803e0] + + test math::exact-31.2 {mAsFloat, scientificNotation, mantissa, eFormat} { + set p 0 + set q 1 + set res {} + for {set i 0} {$i < 16} {incr i} { + set r [expr {$p + $q}] + if {$q * $q > $p * $r} { + set m [list [list [expr {1000*$q}] $p] \ + [list [expr {1000*$r}] $q]] + } else { + set m [list [list [expr {1000*$r}] $q] \ + [list [expr {1000*$q}] $p]] + } + lappend res [math::exact::mAsFloat $m] + set p $q + set q $r + } + set res + } [list \ + Undetermined 1.e3 1.e3 1.6e3 1.6e3 1.6e3 1.62e3 1.61e3 1.61e3 \ + 1.618e3 1.618e3 1.6180e3 1.6180e3 1.61803e3 1.61803e3 1.61803e3] + + test math::exact-31.3 {mAsFloat, scientificNotation, mantissa, eFormat} { + set p 0 + set q 1 + set res {} + for {set i 0} {$i < 16} {incr i} { + set r [expr {$p + $q}] + if {$q * $q > $p * $r} { + set m [list [list $q [expr {1000*$p}]] \ + [list $r [expr {1000*$q}]]] + } else { + set m [list [list $r [expr {1000*$q}]] \ + [list $q [expr {1000*$p}]]] + } + lappend res [math::exact::mAsFloat $m] + set p $q + set q $r + } + set res + } [list \ + Undetermined 1.e-3 1.e-3 1.6e-3 1.6e-3 \ + 1.6e-3 1.62e-3 1.61e-3 1.61e-3 \ + 1.618e-3 1.618e-3 1.6180e-3 1.6180e-3 \ + 1.61803e-3 1.61803e-3 1.61803e-3] + + test math::exact-31.4 {mAsFloat, scientificNotation, mantissa, eFormat} { + set p 0 + set q 1 + set res {} + for {set i 0} {$i < 16} {incr i} { + set r [expr {$p + $q}] + set mq [expr {-$q}] + set mr [expr {-$r}] + if {$q * $q > $p * $r} { + set m [list [list $mq $p] \ + [list $mr $q]] + } else { + set m [list [list $mr $q] \ + [list $mq $p]] + } + lappend res [math::exact::mAsFloat $m] + set p $q + set q $r + } + set res + } [list \ + Undetermined -2.e0 -2.e0 -1.6e0 \ + -1.7e0 -1.7e0 -1.62e0 -1.62e0 \ + -1.62e0 -1.618e0 -1.618e0 -1.6180e0 \ + -1.6181e0 -1.61803e0 -1.61804e0 -1.61804e0] + + test math::exact-31.5 {mAsFloat, 0/0} { + math::exact::mAsFloat {{0 0} {0 0}} + } NaN + + test math::exact-31.6 {mAsFloat, infinity} { + math::exact::mAsFloat {{1 0} {1 0}} + } Inf + + test math::exact-31.7 {mAsFloat, zero} { + math::exact::mAsFloat {{0 1} {0 1}} + } 0 + + test math::exact-31.8 {mAsFloat, integer} { + math::exact::mAsFloat {{2 1} {2 1}} + } 2 + + test math::exact-31.9 {mAsFloat, reverse signs} { + list [math::exact::mAsFloat {{2 -1} {2 -1}}] \ + [math::exact::mAsFloat {{-2 -1} {-2 -1}}] + } {-2 2} + + test math::exact-40.1 {simple expr} { + -setup leakBaseline + -body { + set v [[exactexpr {1}] ref] + set result [list [$v asPrint 57] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 1.0000000000000000e0} + } + + test math::exact-40.2 {unary plus} { + -setup leakBaseline + -body { + set v [[exactexpr {+ 1}] ref] + set result [list [$v asPrint 57] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 1.0000000000000000e0} + } + + test math::exact-40.3 {unary minus} { + -setup leakBaseline + -body { + set v [[exactexpr {- 1}] ref] + set result [list [$v asPrint 57] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {-1 -9.999999999999999e-1} + } + + test math::exact-40.4 {product} { + -setup leakBaseline + -body { + set v [[exactexpr {2 * 3}] ref] + set result [list [$v asPrint 57] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {6 6.000000000000000e0} + } + + test math::exact-40.5 {quotient} { + -setup leakBaseline + -body { + set v [[exactexpr {2 / 3}] ref] + set result [list [$v asPrint 57] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {2/3 6.666666666666666e-1} + } + + test math::exact-40.6 {associativity of /} { + -setup leakBaseline + -body { + set v [[exactexpr {2 / 3 / 4}] ref] + set result [list [$v asPrint 57] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1/6 1.6666666666666667e-1} + } + + test math::exact-40.7 {associativity of */} { + -setup leakBaseline + -body { + set v [[exactexpr {2 / 3 * 4}] ref] + set result [list [$v asPrint 57] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {8/3 2.6666666666666667e0} + } + + test math::exact-40.8 {associativity of */} { + -setup leakBaseline + -body { + set v [[exactexpr {2 * 3 / 4}] ref] + set result [list [$v asPrint 57] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {3/2 1.5000000000000000e0} + } + + test math::exact-40.9 {sum} { + -setup leakBaseline + -body { + set v [[exactexpr {2 + 3}] ref] + set result [list [$v asPrint 57] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {5 5.000000000000000e0} + } + + test math::exact-40.10 {difference} { + -setup leakBaseline + -body { + set v [[exactexpr {2 - 3}] ref] + set result [list [$v asPrint 57] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {-1 -9.999999999999999e-1} + } + + test math::exact-40.11 {associativity of -} { + -setup leakBaseline + -body { + set v [[exactexpr {2 - 3 - 4}] ref] + set result [list [$v asPrint 57] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {-5 -5.000000000000000e0} + } + + test math::exact-40.12 {associativity of +-} { + -setup leakBaseline + -body { + set v [[exactexpr {2 - 3 + 4}] ref] + set result [list [$v asPrint 57] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {3 3.0000000000000001e0} + } + + test math::exact-40.13 {associativity of +-} { + -setup leakBaseline + -body { + set v [[exactexpr {2 + 3 - 4}] ref] + set result [list [$v asPrint 57] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 1.0000000000000000e0} + } + + test math::exact-40.14 {precedence of +*} { + -setup leakBaseline + -body { + set v [[exactexpr {3 + 5 * 7}] ref] + set result [list [$v asPrint 57] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {38 3.800000000000000e1} + } + + test math::exact-40.15 {precedence of +*} { + -setup leakBaseline + -body { + set v [[exactexpr {3 * 5 + 7}] ref] + set result [list [$v asPrint 57] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {22 2.200000000000000e1} + } + + test math::exact-40.16 {parentheses} { + -setup leakBaseline + -body { + set v [[exactexpr {(2 + 3) * 5}] ref] + set result [list [$v asPrint 57] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {25 2.500000000000000e1} + } + + test math::exact-40.17 {V + E} { + -setup leakBaseline + -body { + set v [[exactexpr {2 + real(-3/5)}] ref] + set result [list [$v asPrint 57] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1.4000000000000000e0 1.4000000000000000e0} + } + + test math::exact-40.18 {V - E} { + -setup leakBaseline + -body { + set v [[exactexpr {2 - real(3/5)}] ref] + set result [list [$v asPrint 57] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1.4000000000000000e0 1.4000000000000000e0} + } + + test math::exact-40.19 {E / E} { + -setup leakBaseline + -body { + set v [[exactexpr {real(3/5)/real(2/5)}] ref] + set result [list [$v asPrint 57] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1.5000000000000000e0 1.5000000000000000e0} + } + + test math::exact-40.20 {E + V} { + -setup leakBaseline + -body { + set v [[exactexpr {real(3/2) + (2/5)}] ref] + set result [list [$v asPrint 57] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1.9000000000000000e0 1.9000000000000000e0} + } + + test math::exact-40.21 {E - V} { + -setup leakBaseline + -body { + set v [[exactexpr {real(3/2) - (2/5)}] ref] + set result [list [$v asPrint 57] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1.1000000000000000e0 1.1000000000000000e0} + } + + test math::exact-40.22 {E * V} { + -setup leakBaseline + -body { + set v [[exactexpr {real(3/2) * (2/5)}] ref] + set result [list [$v asPrint 57] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {6.0000000000000001e-1 6.0000000000000001e-1} + } + + test math::exact-40.23 {E / V} { + -setup leakBaseline + -body { + set v [[exactexpr {real(3/2) / (5/2)}] ref] + set result [list [$v asPrint 57] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {6.0000000000000001e-1 6.0000000000000001e-1} + } + + test math::exact-40.24 {lexical error} { + -setup leakBaseline + -body { + set result [list [catch {exactexpr {2 ! 1}} m] $m] + leakCheck + set result + } + -match glob + -result {1 {invalid character*}} + } + + test math::exact-40.25 {syntax error} { + -setup leakBaseline + -body { + set result [list [catch {exactexpr {2 $ 1}} m] $m] + leakCheck + set result + } + -match glob + -result {1 {syntax error*}} + } + + test math::exact-41.1 {square root} { + -setup leakBaseline + -body { + set v [[exactexpr {sqrt(25/16)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + #leakCheck + set result + } + -result {1 1.2500000000000000e0} + } + + test math::exact-41.2 {square root} { + -setup leakBaseline + -body { + set v [[exactexpr {sqrt(2)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 1.4142135623730950e0} + } + + test math::exact-41.3 {square root} { + -setup leakBaseline + -body { + set v [[exactexpr {sqrt(2000000)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 1.4142135623731e3} + } + + test math::exact-41.4 {square root} { + -setup leakBaseline + -body { + set v [[exactexpr {sqrt(2 / 1000000)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 1.41421356237309e-3} + } + + test math::exact-41.5 {square root} { + -setup leakBaseline + -body { + set v [[exactexpr {sqrt(sqrt(1/81))}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 3.3333333333333333e-1} + } + + test math::exact-41.6 {square root of negative rational} { + -setup { + leakBaseline + catch {unset v} + } + -body { + set v [[exactexpr {sqrt(-1)}] ref] + set result [$v asPrint 57] + $v unref + unset v + set result + } + -cleanup { + if {[info exists v]} {$v unref} + } + -match glob + -returnCodes error + -result {*negative argument*} + } + + test math::exact-41.7 {square root of negative real} { + -setup { + leakBaseline + catch {unset v} + } + -body { + set v [[exactexpr {sqrt(-sqrt(81))}] ref] + set result [$v asPrint 57] + $v unref + unset v + set result + } + -cleanup { + if {[info exists v]} {$v unref} + } + -match glob + -returnCodes error + -result {*negative argument*} + } + + test math::exact-41.8 {square root, cached result} { + -setup leakBaseline + -body { + set x [[exactexpr {sqrt(2)}] ref] + set y [[exactexpr {$x * $x}] ref] + $x unref + set result [list [$y asFloat 57] [$y asFloat 57]] + $y unref + leakCheck + set result + } + -result {2.0000000000000000e0 2.0000000000000000e0} + } + + test math::exact-42.1 {exponential} { + -setup leakBaseline + -body { + set v [[exactexpr {exp(1)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 2.7182818284590452e0} + } + + test math::exact-42.2 {exponential} { + -setup leakBaseline + -body { + set v [[exactexpr {exp(4)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 5.45981500331442e1} + } + + test math::exact-42.3 {exponential} { + -setup leakBaseline + -body { + set v [[exactexpr {exp(0)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 1.0000000000000000e0} + } + + test math::exact-43.1 {logarithm} { + -setup leakBaseline + -body { + set v [[exactexpr {log(1)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 0e-18} + } + + test math::exact-43.2 {logarithm} { + -setup leakBaseline + -body { + set v [[exactexpr {log(2)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 6.931471805599453e-1} + } + + test math::exact-43.3 {logarithm} { + -setup leakBaseline + -body { + set v [[exactexpr {log(1/2)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 -6.931471805599454e-1} + } + + test math::exact-43.4 {logarithm} { + -setup { + # Consume digits from math::exact::log2 to avoid appearance of + # a leak in its cache + $math::exact::log2 asFloat 100 + leakBaseline + } + -body { + set v [[exactexpr {log(4)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 1.3862943611198906e0} + } + + test math::exact-43.5 {logarithm} { + -setup { + # Consume digits from math::exact::log2 to avoid appearance of + # a leak in its cache + $math::exact::log2 asFloat 100 + leakBaseline + } + -body { + set v [[exactexpr {log(1/4)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 -1.3862943611198907e0} + } + + test math::exact-43.6 {logarithm} { + -setup { + # Consume digits from math::exact::log2 to avoid appearance of + # a leak in its cache + $math::exact::log2 asFloat 100 + leakBaseline + } + -body { + set v [[exactexpr {log(exp(10))}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 1.0000000000000000e1} + } + + test math::exact-43.7 {logarithm} { + -setup { + # Consume digits from math::exact::log2 to avoid appearance of + # a leak in its cache + $math::exact::log2 asFloat 100 + leakBaseline + } + -body { + set v [[exactexpr {log(exp(1/10))}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 1.0000000000000000e-1} + } + + test math::exact-43.8 {logarithm of negative argument} { + -setup { + leakBaseline + catch {unset v} + } + -body { + set v [[exactexpr {log(-sqrt(81))}] ref] + set result [$v asPrint 57] + $v unref + unset v + set result + } + -cleanup { + if {[info exists v]} {$v unref} + } + -match glob + -returnCodes error + -result {*negative argument*} + } + + test math::exact-44.1 {pi} { + -setup { + # Consume digits from math::exact::pi to avoid appearance of + # a leak in its cache + $math::exact::pi asFloat 3000 + leakBaseline + } + -body { + set v [[exactexpr {pi()}] ref] + set result [$v asFloat 3000] + $v unref + leakCheck + list [string range $result 0 4] \ + [string first 999999 $result] \ + [string range $result end-1 end] + } + -result {3.141 763 e0} + } + + test math::exact-44.2 {Ramanujan constant} { + -setup { + # Consume digits from math::exact::pi to avoid appearance of + # a leak in its cache + $math::exact::pi asFloat 100 + leakBaseline + } + -body { + set v [[exactexpr {exp(pi()*sqrt(163))}] ref] + set result [$v asFloat 160] + $v unref + leakCheck + set result + } + -result 2.625374126407687439999999999992e17 + } + + + test math::exact-45.1 {tangent} { + -setup leakBaseline + -body { + set v [[exactexpr {tan(0)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 0e-18} + } + + test math::exact-45.2 {tangent} { + -setup leakBaseline + -body { + set v [[exactexpr {tan(pi()/4)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 1.0000000000000000e0} + } + + test math::exact-45.3 {tangent} { + -setup leakBaseline + -body { + set v [[exactexpr {tan(pi()/-4)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 -1.0000000000000000e0} + } + + test math::exact-45.4 {tangent} { + -setup leakBaseline + -body { + set v [[exactexpr {tan(pi()/3)-sqrt(3)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 0e-18} + } + + test math::exact-45.5 {tangent} { + -setup leakBaseline + -body { + set v [[exactexpr {tan(-pi()/3)+sqrt(3)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 0e-18} + } + + test math::exact-45.6 {tangent} { + -setup leakBaseline + -body { + set v [[exactexpr {1/tan(pi()/2)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 0e-18} + } + + test math::exact-45.7 {tangent} { + -setup leakBaseline + -body { + set v [[exactexpr {tan(pi()/2)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 Undetermined} + } + + test math::exact-46.1 {sine} { + -setup leakBaseline + -body { + set v [[exactexpr {sin(0)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 0e-18} + } + + test math::exact-46.2 {sine} { + -setup leakBaseline + -body { + set v [[exactexpr {sin(pi()/6)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 5.000000000000000e-1} + } + + test math::exact-46.3 {sine} { + -setup leakBaseline + -body { + set v [[exactexpr {sin(-pi()/6)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 -5.000000000000000e-1} + } + + test math::exact-46.4 {sine} { + -setup leakBaseline + -body { + set v [[exactexpr {sin(pi()/2)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 1.0000000000000000e0} + } + + test math::exact-46.5 {sine} { + -setup leakBaseline + -body { + set v [[exactexpr {sin(-pi()/2)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 -1.0000000000000000e0} + } + + test math::exact-46.6 {sine} { + -setup leakBaseline + -body { + set v [[exactexpr {sin(pi())}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 0e-18} + } + + test math::exact-46.7 {sine} { + -setup leakBaseline + -body { + set v [[exactexpr {sin(-pi())}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 0e-18} + } + + test math::exact-46.8 {sine} { + -setup leakBaseline + -body { + set v [[exactexpr {sin(13*pi()/6)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 5.000000000000000e-1} + } + + test math::exact-46.9 {sine} { + -setup leakBaseline + -body { + set v [[exactexpr {sin(-13*pi()/6)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 -5.000000000000000e-1} + } + + test math::exact-47.1 {cosine} { + -setup leakBaseline + -body { + set v [[exactexpr {cos(0)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 9.999999999999999e-1} + } + + test math::exact-47.2 {cosine} { + -setup leakBaseline + -body { + set v [[exactexpr {cos(pi()/3)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 5.000000000000000e-1} + } + + test math::exact-47.3 {cosine} { + -setup leakBaseline + -body { + set v [[exactexpr {cos(-pi()/3)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 5.000000000000000e-1} + } + + test math::exact-47.4 {cosine} { + -setup leakBaseline + -body { + set v [[exactexpr {cos(pi()/2)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 0e-18} + } + + test math::exact-47.5 {cosine} { + -setup leakBaseline + -body { + set v [[exactexpr {cos(-pi()/2)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 0e-18} + } + + test math::exact-47.6 {cosine} { + -setup leakBaseline + -body { + set v [[exactexpr {cos(pi())}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 -1.0000000000000000e0} + } + + test math::exact-47.7 {cosine} { + -setup leakBaseline + -body { + set v [[exactexpr {cos(-pi())}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 -1.0000000000000000e0} + } + + test math::exact-47.8 {cosine} { + -setup leakBaseline + -body { + set v [[exactexpr {cos(7*pi()/3)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 5.000000000000000e-1} + } + + test math::exact-47.9 {cosine} { + -setup leakBaseline + -body { + set v [[exactexpr {cos(-7*pi()/3)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 5.000000000000000e-1} + } + + test math::exact-45.1 {arctangent} { + -setup leakBaseline + -body { + set v [[exactexpr {atan(0)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 0e-18} + } + + test math::exact-45.2 {arctangent} { + -setup leakBaseline + -body { + # Hack to get $szer as a sign matrix + set v [[exactexpr {atan(pi()-pi())}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 0e-18} + } + + test math::exact-45.3 {arctangent} { + -setup leakBaseline + -body { + set v [[exactexpr {4*atan(1)-pi()}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 0e-18} + } + + test math::exact-45.4 {arctangent} { + -setup leakBaseline + -body { + set v [[exactexpr {4*atan(-1)+pi()}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 0e-18} + } + + test math::exact-45.5 {arctangent} { + -setup leakBaseline + -body { + set v [[exactexpr {atan(tan(157/100))}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 1.5700000000000000e0} + } + + test math::exact-45.6 {arctangent, cached} { + -setup leakBaseline + -body { + set u [[exactexpr {atan(1)}] ref] + set v [[exactexpr {$u + $u + $u + $u}] ref] + $u unref + set result [$v asFloat 57] + $v unref + leakCheck + set result + } + -result 3.1415926535897933e0 + } + + test math::exact-46.1 {arcsine} { + -setup leakBaseline + -body { + set v [[exactexpr {asin(0)}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 0e-18} + } + + test math::exact-46.2 {arcsine} { + -setup leakBaseline + -body { + set v [[exactexpr {asin(1/2)-pi()/6}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 0e-18} + } + + test math::exact-46.3 {arcsine} { + -setup leakBaseline + -body { + set v [[exactexpr {asin(-1/2)+pi()/6}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 0e-18} + } + + test math::exact-47.1 {arccosine} { + -setup leakBaseline + -body { + set v [[exactexpr {acos(0)-pi()/2}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 0e-18} + } + + test math::exact-47.2 {arccosine} { + -setup leakBaseline + -body { + set v [[exactexpr {acos(1/2)-pi()/3}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 0e-18} + } + + test math::exact-47.3 {arccosine} { + -setup leakBaseline + -body { + set v [[exactexpr {acos(-1/2)-2*pi()/3}] ref] + set result [list [$v refcount] [$v asFloat 57]] + $v unref + leakCheck + set result + } + -result {1 0e-18} + } + + test math::exact-48.1 {hyperbolic functions} { + -setup leakBaseline + -body { + set result {} + set v [[exactexpr {sinh(0)}] ref] + lappend result [$v asFloat 57] + $v unref + set v [[exactexpr {cosh(0)}] ref] + lappend result [$v asFloat 57] + $v unref + set v [[exactexpr {tanh(0)}] ref] + lappend result [$v asFloat 57] + $v unref + leakCheck + set result + } + -result {0e-18 1.0000000000000000e0 0e-18} + } + + test math::exact-48.2 {hyperbolic functions} { + -setup leakBaseline + -body { + set result {} + set v [[exactexpr {sinh(1)}] ref] + lappend result [$v asFloat 57] + $v unref + set v [[exactexpr {cosh(1)}] ref] + lappend result [$v asFloat 57] + $v unref + set v [[exactexpr {tanh(1)}] ref] + lappend result [$v asFloat 57] + $v unref + leakCheck + set result + } + -result {1.1752011936438014e0 1.5430806348152437e0 7.615941559557649e-1} + } + + test math::exact-48.3 {hyperbolic functions} { + -setup leakBaseline + -body { + set result {} + set v [[exactexpr {sinh(-1)}] ref] + lappend result [$v asFloat 57] + $v unref + set v [[exactexpr {cosh(-1)}] ref] + lappend result [$v asFloat 57] + $v unref + set v [[exactexpr {tanh(-1)}] ref] + lappend result [$v asFloat 57] + $v unref + leakCheck + set result + } + -result {-1.1752011936438015e0 1.5430806348152437e0 -7.615941559557649e-1} + } + + test math::exact-49.1 {asinh} { + -setup leakBaseline + -body { + set result {} + set v [[exactexpr {asinh(-1)}] ref] + lappend result [$v asFloat 57] + $v unref + set v [[exactexpr {asinh(0)}] ref] + lappend result [$v asFloat 57] + $v unref + set v [[exactexpr {asinh(1)}] ref] + lappend result [$v asFloat 57] + $v unref + leakCheck + set result + } + -result {-8.813735870195431e-1 0e-18 8.813735870195430e-1} + } + + test math::exact-50.1 {acosh} { + -setup leakBaseline + -body { + set result {} + set v [[exactexpr {acosh(3/2)}] ref] + lappend result [$v asFloat 57] + $v unref + set v [[exactexpr {acosh(2)}] ref] + lappend result [$v asFloat 57] + $v unref + set v [[exactexpr {acosh(3)}] ref] + lappend result [$v asFloat 57] + $v unref + leakCheck + set result + } + -result {9.624236501192069e-1 1.3169578969248167e0 1.7627471740390860e0} + } + + test math::exact-51.1 {atanh} { + -setup leakBaseline + -body { + set result {} + set v [[exactexpr {atanh(-1/2)}] ref] + lappend result [$v asFloat 57] + $v unref + set v [[exactexpr {atanh(0)}] ref] + lappend result [$v asFloat 57] + $v unref + set v [[exactexpr {atanh(1/2)}] ref] + lappend result [$v asFloat 57] + $v unref + leakCheck + set result + } + -result {-5.4930614433405485e-1 0e-18 5.4930614433405485e-1} + } + + test math::exact-52.1 {e} { + -setup { + # don't report cached digits of e as a leak + $math::exact::e asPrint 100; + leakBaseline + } + -body { + set v [[exactexpr {e()}] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -result 2.7182818284590452e0 + } + + test math::exact-52.2 {e} { + -setup { + # don't report cached digits of e as a leak + $math::exact::e asPrint 100; + leakBaseline + } + -body { + set v [[exactexpr {log(e())}] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -result 1.0000000000000000e0 + } + + test math::exact-52.2 {e} { + -setup { + # don't report cached digits of e as a leak + $math::exact::e asPrint 100; + leakBaseline + } + -body { + set v [[exactexpr {asinh((e() - 1/e()) / 2)}] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -result 1.0000000000000000e0 + } + + test math::exact-53.1 {real**real} { + -setup { + # Consume digits from math::exact::e and math::exact::log2 + # to avoid appearance of a leak in the cache + $math::exact::e asFloat 100 + $math::exact::log2 asFloat 100 + leakBaseline + } + -body { + set v [[exactexpr {e() ** log(2)}] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -result 2.0000000000000000e0 + } + + test math::exact-53.2 {rational**real} { + -setup { + # Consume digits from math::exact::e + # to avoid appearance of a leak in the cache + $math::exact::e asFloat 100 + leakBaseline + } + -body { + set v [[exactexpr {2 ** e()}] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -result 6.580885991017921e0 + } + + test math::exact-53.3 {real**1} { + -setup leakBaseline + -body { + set v [[exactexpr {sqrt(4) ** 1}] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -result 2.0000000000000000e0 + } + + test math::exact-53.4 {real**-1} { + -setup leakBaseline + -body { + set v [[exactexpr {sqrt(4) ** (-1)}] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -result 5.000000000000000e-1 + } + + test math::exact-53.5 {real**0} { + -setup leakBaseline + -body { + set v [[exactexpr {sqrt(4) ** 0}] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -result 1 + } + + test math::exact-53.6 {real**+int} { + -setup leakBaseline + -body { + set v [[exactexpr {sqrt(4)**2}] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -result 4.000000000000000e0 + } + + test math::exact-53.7 {real**+int} { + -setup leakBaseline + -body { + set v [[exactexpr {sqrt(4)**5}] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -result 3.200000000000000e1 + } + + test math::exact-53.6 {real**-int} { + -setup leakBaseline + -body { + set v [[exactexpr {sqrt(4)**-2}] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -result 2.5000000000000000e-1 + } + + test math::exact-53.7 {real**+int} { + -setup leakBaseline + -body { + set v [[exactexpr {sqrt(4)**-5}] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -result 3.125000000000000e-2 + } + + test math::exact-53.8 {real**rational} { + -setup leakBaseline + -body { + set v [[exactexpr {sqrt(64)**(10/3)}] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -result 1.02400000000000e3 + } + + test math::exact-53.9 {real**rational} { + -setup leakBaseline + -body { + set v [[exactexpr {sqrt(64)**(1/-3)}] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -result 5.000000000000000e-1 + } + + test math::exact-53.10 {real**integer, accidental} { + -setup leakBaseline + -body { + set v [[math::exact::real**rat [exactexpr {3}] 2 1] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -result 9 + } + + test math::exact-53.11 {zero to zero power} { + -setup leakBaseline + -body { + set v [[exactexpr {0**0}] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -returnCodes error + -result "zero to zero power" + } + + test math::exact-53.12 {zero to infinite power} { + -setup leakBaseline + -body { + set v [[exactexpr {0**(1/0)}] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -returnCodes error + -result "zero to infinite power" + } + + test math::exact-53.13 {zero to rational power} { + -setup leakBaseline + -body { + set v [[exactexpr {0**(1/2)}] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -result 0 + } + + test math::exact-53.14 {infinity to zero power} { + -setup leakBaseline + -body { + set v [[exactexpr {(1/0)**0}] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -returnCodes error + -result "infinity to zero power" + } + + test math::exact-53.15 {infinity to negative power} { + -setup leakBaseline + -body { + set v [[exactexpr {(1/0)**-1}] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -result 0 + } + + test math::exact-53.15 {infinity to positive power} { + -setup leakBaseline + -body { + set v [[exactexpr {(1/0)**1}] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -result Inf + } + + test math::exact-53.16 {rational to zero power} { + -setup leakBaseline + -body { + set v [[exactexpr {(2/3)**0}] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -result 1 + } + + test math::exact-53.17 {rational power of negative real argument} { + -setup leakBaseline + -body { + set v [[exactexpr {(-sqrt(64))**(1/3)}] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -result -2.0000000000000000e0 + } + + test math::exact-53.18 {rational power of argument near zero} { + -setup leakBaseline + -body { + set v [[exactexpr {log(exp(1/8))**(1/3)}] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -result 5.000000000000000e-1 + } + + test math::exact-53.19 {negative real to real power} { + -setup leakBaseline + -body { + set v [[exactexpr {(-sqrt(4))**(1/2)}] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -returnCodes error + -result "negative number to real power" + } + + test math::exact-53.20 {rational to zero power} { + -setup leakBaseline + -body { + set v [[exactexpr {(2/3)**0}] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -result 1 + } + + test math::exact-53.21 {rational to positive integer power} { + -setup leakBaseline + -body { + set v [[exactexpr {(2/3)**2}] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -result 4/9 + } + + test math::exact-53.22 {rational to negative integer power} { + -setup leakBaseline + -body { + set v [[exactexpr {(2/3)**-2}] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -result 9/4 + } + + test math::exact-53.23 {rational to rational} { + -setup leakBaseline + -body { + set v [[exactexpr {(-8)**(1/3)}] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -result -2.0000000000000000e0 + } + + test math::exact-53.24 {real to 0/0} { + -setup leakBaseline + -body { + set bad [[math::exact::V new {0 0}] ref] + set v [[exactexpr {sqrt(2)**$bad}] ref] + $bad unref + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -returnCodes error + -result {zero divided by zero} + } + + test math::exact-53.24 {rational to 0/0} { + -setup leakBaseline + -body { + set bad [[math::exact::V new {0 0}] ref] + set v [[exactexpr {(1/2)**$bad}] ref] + $bad unref + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -returnCodes error + -result {zero divided by zero} + } + + test math::exact-53.26 {unit test - rat**int (2/3)**0} { + -setup leakBaseline + -body { + set v [[math::exact::rat**int 2 3 0] ref] + set result [$v asPrint 57] + $v unref + leakCheck + set result + } + -result {1} + } + + test math::exact-53.27 {rational powers - normalize base and exponent} { + -setup leakBaseline + -body { + set p [[math::exact::V new {-2 -1}] ref] + set q [[math::exact::V new {-3 -1}] ref] + set r [[exactexpr {$p ** $q}] ref] + $p unref + $q unref + set result [$r asPrint 57] + $r unref + leakCheck + set result + } + -result 8 + } + + test math::exact-54.1 {abs1, signum1} { + -setup leakBaseline + -body { + set p [[exactexpr {0}] ref] + set q [[exactexpr {2}] ref] + while 1 { + set t [[exactexpr {($q-$p) * 10**36}] ref] + set f [math::exact::abs1 $t]; $t unref + if {!$f} break + set x [[exactexpr {($p+$q)/2}] ref] + set resid [[exactexpr {$x*$x-2}] ref] + set t [[exactexpr {$resid * 10**36}] ref] + if {[math::exact::signum1 $t] > 0} { + $q unref; set q $x + } else { + $p unref; set p $x + } + $t unref; $resid unref + } + set result [$p asFloat 100] + $p unref + $q unref + leakCheck + set result + } + -result 1.41421356237309504880168872421e0 + } + + # following are demos that I don't know where to put, yet + + if 0 { + set p 1 + for {set i 0} {$i < 20} {incr i} { + set f [expr {sin(0.01 * $p* acos(-1))}] + set v [[exactexpr "sin($p * pi() / 100)"] ref] + set a [$v asPrint 57] + set r [expr {$f - $a}] + puts "i: $i p: $p float: $f exact: $a difference: $r" + $v unref + set p [expr {11 * $p}] + } + } + + if 0 { + for {set x 100} {$x <= 12200} {incr x 100} { + set ex [[exactexpr $x] ref] + puts "x $x ex [$ex asPrint 57]" + set fa [expr {-(double($x)**-4)}] + set ea [[exactexpr {-($ex**-4)}] ref] + puts "fa $fa ea [$ea asPrint 57]" + set fb [expr {exp($fa)}] + set eb [[exactexpr {exp($ea)}] ref] + puts "fb $fb eb [$eb asPrint 120]" + set fc [expr {log($fb)}] + set ec [[exactexpr {log($eb)}] ref] + puts "fc $fc ec [$ec asPrint 120]" + catch {expr {(-$fc) ** -0.25}} ff + set ef [[exactexpr {(-$ec)**(-1/4)}] ref] + puts [format "kahan's function: %s %g" $ff [$ef asFloat 28]] + $ef unref + $ec unref + $eb unref + $ea unref + $ex unref + } + } + + if 0 { + set x0 4.0 + set x1 4.25 + set ex0 [[exactexpr 4] ref] + set ex1 [[exactexpr 4+25/100] ref] + for {set i 1} {$i < 100} {incr i} { + set x2 [expr {108. - (815. - 1500. / $x0) / $x1}] + set x0 $x1 + set x1 $x2 + set ex2 [[exactexpr {108 - (815 - 1500 / $ex0) / $ex1}] ref] + $ex0 unref + set ex0 $ex1 + set ex1 $ex2 + puts "$i $x2 [$ex2 asFloat 57]" + } + $ex0 unref + $ex1 unref + } + + testsuiteCleanup + +} + +#----------------------------------------------------------------------------- + +# End of test cases + +testsuiteCleanup + +# Exit if running this test standalone, to allow for Nagelfar coverage +if {$::argv0 eq [info script]} { + exit +} + +# Local Variables: +# mode: tcl +# End: + diff --git a/tcllib/modules/math/exponential.tcl b/tcllib/modules/math/exponential.tcl new file mode 100755 index 0000000..b90952a --- /dev/null +++ b/tcllib/modules/math/exponential.tcl @@ -0,0 +1,434 @@ +# 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 +} +} diff --git a/tcllib/modules/math/fourier.man b/tcllib/modules/math/fourier.man new file mode 100755 index 0000000..d5696dd --- /dev/null +++ b/tcllib/modules/math/fourier.man @@ -0,0 +1,134 @@ +[manpage_begin math::fourier n 1.0.2] +[keywords {complex numbers}] +[keywords FFT] +[keywords {Fourier transform}] +[keywords mathematics] +[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] + +[vset CATEGORY {math :: fourier}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/math/fourier.tcl b/tcllib/modules/math/fourier.tcl new file mode 100755 index 0000000..bd455ad --- /dev/null +++ b/tcllib/modules/math/fourier.tcl @@ -0,0 +1,376 @@ +# 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}]] +} diff --git a/tcllib/modules/math/fourier.test b/tcllib/modules/math/fourier.test new file mode 100755 index 0000000..d43f1b9 --- /dev/null +++ b/tcllib/modules/math/fourier.test @@ -0,0 +1,135 @@ +# -*- 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 diff --git a/tcllib/modules/math/fuzzy.eps.f90 b/tcllib/modules/math/fuzzy.eps.f90 new file mode 100755 index 0000000..79867e7 --- /dev/null +++ b/tcllib/modules/math/fuzzy.eps.f90 @@ -0,0 +1,170 @@ +!********************************************************************** +! 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 <hdk@psu.edu> 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 diff --git a/tcllib/modules/math/fuzzy.man b/tcllib/modules/math/fuzzy.man new file mode 100755 index 0000000..2cc0051 --- /dev/null +++ b/tcllib/modules/math/fuzzy.man @@ -0,0 +1,133 @@ +[manpage_begin math::fuzzy n 0.2] +[keywords floating-point] +[keywords math] +[keywords rounding] +[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. + +[vset CATEGORY {math :: fuzzy}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/math/fuzzy.tcl b/tcllib/modules/math/fuzzy.tcl new file mode 100755 index 0000000..5b017b5 --- /dev/null +++ b/tcllib/modules/math/fuzzy.tcl @@ -0,0 +1,173 @@ +# 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 diff --git a/tcllib/modules/math/fuzzy.test b/tcllib/modules/math/fuzzy.test new file mode 100755 index 0000000..cd0e088 --- /dev/null +++ b/tcllib/modules/math/fuzzy.test @@ -0,0 +1,387 @@ +# -*- 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! diff --git a/tcllib/modules/math/fuzzy.testscript b/tcllib/modules/math/fuzzy.testscript new file mode 100755 index 0000000..a27f21f --- /dev/null +++ b/tcllib/modules/math/fuzzy.testscript @@ -0,0 +1,21 @@ +# 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)}])" diff --git a/tcllib/modules/math/geometry.tcl b/tcllib/modules/math/geometry.tcl new file mode 100644 index 0000000..7e14fef --- /dev/null +++ b/tcllib/modules/math/geometry.tcl @@ -0,0 +1,1265 @@ +# 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 +# 0<r<1 P is interior to AB +# +proc ::math::geometry::findClosestPointOnLineImpl {P line} { + # solution based on FAQ 1.02 on comp.graphics.algorithms + # L = sqrt( (Bx-Ax)^2 + (By-Ay)^2 ) + # (Cx-Ax)(Bx-Ax) + (Cy-Ay)(By-Ay) + # r = ------------------------------- + # L^2 + # Px = Ax + r(Bx-Ax) + # Py = Ay + r(By-Ay) + 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 [list [list $Ax $Ay] 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)}] + set Px [expr {$Ax + $r*($Bx-$Ax)}] + set Py [expr {$Ay + $r*($By-$Ay)}] + return [list [list $Px $Py] $r] + } +} + +# ::math::geometry::calculateDistanceToLineSegment +# +# Calculate the distance between a point and a line segment. +# +# Arguments: +# P a point +# linesegment a line segment +# +# Results: +# dist the smallest distance between P and any point +# on the line segment +# +# Examples: +# - calculateDistanceToLineSegment {5 10} {0 0 10 10} +# Result: 3.53553390593 +# - calculateDistanceToLineSegment {-10 0} {0 0 10 10} +# Result: 10.0 +# +proc ::math::geometry::calculateDistanceToLineSegment {P linesegment} { + set result [calculateDistanceToLineSegmentImpl $P $linesegment] + set distToLine [lindex $result 0] + set r [lindex $result 1] + if {$r<0} { + return [lengthOfPolyline [concat $P [lrange $linesegment 0 1]]] + } elseif {$r>1} { + 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<r<1 P is interior to AB +# +proc ::math::geometry::calculateDistanceToLineSegmentImpl {P linesegment} { + # 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 + # (Cx-Ax)(Bx-Ax) + (Cy-Ay)(By-Ay) + # r = ------------------------------- + # L^2 + # dist = |s|*L + # + # => + # + # | (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::calculateDistanceToPolygon +# +# Calculate the distance between a point and a polygon. +# +# Arguments: +# P a point +# polygon a polygon +# +# Results: +# dist the smallest distance between P and any point +# on the polygon +# +# Note: +# The polygon does not need to be closed - this is taken +# care of in the procedure. +# +proc ::math::geometry::calculateDistanceToPolygon {P polygon} { + return [::math::geometry::calculateDistanceToPolyline $P [ClosedPolygon $polygon]] +} + +# ::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] + + # + # First check the distance between the endpoints + # + set margin 1.0e-7 + if { [calculateDistanceToLineSegment [lrange $linesegment1 0 1] $linesegment2] < $margin } { + return 1 + } + if { [calculateDistanceToLineSegment [lrange $linesegment1 2 3] $linesegment2] < $margin } { + return 1 + } + if { [calculateDistanceToLineSegment [lrange $linesegment2 0 1] $linesegment1] < $margin } { + return 1 + } + if { [calculateDistanceToLineSegment [lrange $linesegment2 2 3] $linesegment1] < $margin } { + return 1 + } + + 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.3 diff --git a/tcllib/modules/math/geometry.test b/tcllib/modules/math/geometry.test new file mode 100644 index 0000000..8fbfec9 --- /dev/null +++ b/tcllib/modules/math/geometry.test @@ -0,0 +1,520 @@ +# -*- 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 +test geometry-15.13 {geometry::pointInsidePolygon, edge case polygon/point, ticket c1ca34ead3} { + math::geometry::pointInsidePolygon {3.0 -1.5} {2.0 2.0 -2.0 2.0 -2.0 -2.0 2.0 -2.0} +} 0 + + +### +# 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 + + +### +# calculateDistanceToPolygon +### +test geometry-18.1 {geometry::calculateDistanceToPolygon, non-closed polygon, point on polygon} { + eval withFourDecimals [::math::geometry::calculateDistanceToPolygon {2.0 0.5} {2.0 2.0 -2.0 2.0 -2.0 -2.0 2.0 -2.0}] +} 0.0 + + +### +testsuiteCleanup diff --git a/tcllib/modules/math/interpolate.man b/tcllib/modules/math/interpolate.man new file mode 100755 index 0000000..f104e5d --- /dev/null +++ b/tcllib/modules/math/interpolate.man @@ -0,0 +1,299 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin math::interpolate n 1.1] +[keywords interpolation] +[keywords math] +[keywords {spatial interpolation}] +[copyright {2004 Arjen Markus <arjenmarkus@users.sourceforge.net>}] +[copyright {2004 Kevn B. Kenny <kennykb@users.sourceforge.net>}] +[moddesc {Tcl Math Library}] +[titledesc {Interpolation routines}] +[category Mathematics] +[require Tcl [opt 8.4]] +[require struct] +[require math::interpolate [opt 1.1]] + +[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 "INCOMPATIBILITY WITH VERSION 1.0.3"] + +The interpretation of the tables in the [cmd ::math::interpolate::interpolate-1d-table] command +has been changed to be compatible with the interpretation for 2D interpolation in +the [cmd ::math::interpolate::interpolate-table] command. As a consequence this version is +incompatible with the previous versions of the command (1.0.x). + +[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 "Example of using one-dimensional tables:"] +[para] +Suppose you have several tabulated functions of one variable: +[example { + x y1 y2 + 0.0 0.0 0.0 + 1.0 1.0 1.0 + 2.0 4.0 8.0 + 3.0 9.0 27.0 + 4.0 16.0 64.0 +}] +Then to estimate the values at 0.5, 1.5, 2.5 and 3.5, you can use: +[example { + set table [::math::interpolate::defineTable table1 \ + {x y1 y2} { - 1 2 + 0.0 0.0 0.0 + 1.0 1.0 1.0 + 2.0 4.0 8.0 + 3.0 9.0 27.0 + 4.0 16.0 64.0}] + foreach x {0.5 1.5 2.5 3.5} { + puts "$x: [::math::interpolate::interp-1d-table $table $x]" + } +}] +For one-dimensional tables the first row is not used. For two-dimensional +tables, the first row represents the values for the second independent variable. +[para] + +[emph "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. + +[vset CATEGORY {math :: interpolate}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/math/interpolate.tcl b/tcllib/modules/math/interpolate.tcl new file mode 100755 index 0000000..871c012 --- /dev/null +++ b/tcllib/modules/math/interpolate.tcl @@ -0,0 +1,667 @@ +# 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] 2 end] + + foreach {row row2} [FindEnclosingEntries $xval $xvalues] break + incr row + incr row2 + + 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)}] + } + + # + # Take care of coincident points + # + if { $dist == 0.0 } { + return [lindex $point end] + } + + # + # The general case + # + 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.1 diff --git a/tcllib/modules/math/interpolate.test b/tcllib/modules/math/interpolate.test new file mode 100755 index 0000000..e91db58 --- /dev/null +++ b/tcllib/modules/math/interpolate.test @@ -0,0 +1,346 @@ +# -*- 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 +# +# Add a dummy row to the table - ticket b25b826973edcbb5b3a95f6c284214925a1d5e67 +# This makes it possible to use the same table in both 1D and 2D interpolations +# +set t [::math::interpolate::defineTable table1 \ + { x v1 v2 v3 } \ + { - 1 2 3 + 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 "Interpolate-4.3" "Spatial interpolation - 3 - coincident points" \ + -match numbers -body { + set result {} + + set xyzvalues { {-1.0 0.0 { -2.0 1.0 } } + { 1.0 0.0 { 2.0 -1.0 } } } + set coord {-1.0 0.0} + set result [::math::interpolate::interp-spatial $xyzvalues $coord] + + set result +} -result { -2.0 1.0 } + +# +# 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: diff --git a/tcllib/modules/math/kruskal.tcl b/tcllib/modules/math/kruskal.tcl new file mode 100755 index 0000000..a08083b --- /dev/null +++ b/tcllib/modules/math/kruskal.tcl @@ -0,0 +1,154 @@ +# 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
+}
diff --git a/tcllib/modules/math/linalg.man b/tcllib/modules/math/linalg.man new file mode 100755 index 0000000..6bbe49b --- /dev/null +++ b/tcllib/modules/math/linalg.man @@ -0,0 +1,968 @@ +[comment {-*- tcl -*- doctools manpage}] +[vset VERSION 1.1.5] +[manpage_begin math::linearalgebra n [vset VERSION]] +[keywords {least squares}] +[keywords {linear algebra}] +[keywords {linear equations}] +[keywords math] +[keywords matrices] +[keywords matrix] +[keywords vectors] +[copyright {2004-2008 Arjen Markus <arjenmarkus@users.sourceforge.net>}] +[copyright {2004 Ed Hume <http://www.hume.com/contact.us.htm>}] +[copyright {2008 Michael Buadin <relaxkmike@users.sourceforge.net>}] +[moddesc {Tcl Math Library}] +[titledesc {Linear Algebra}] +[category Mathematics] +[require Tcl [opt 8.4]] +[require math::linearalgebra [opt [vset VERSION]]] +[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 ... +} +}] + +[vset CATEGORY {math :: linearalgebra}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/math/linalg.tcl b/tcllib/modules/math/linalg.tcl new file mode 100755 index 0000000..98347ac --- /dev/null +++ b/tcllib/modules/math/linalg.tcl @@ -0,0 +1,2288 @@ +# 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 {$aii + 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.5 + +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 +} diff --git a/tcllib/modules/math/linalg.test b/tcllib/modules/math/linalg.test new file mode 100755 index 0000000..7bd9b90 --- /dev/null +++ b/tcllib/modules/math/linalg.test @@ -0,0 +1,855 @@ +# -*- 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! + + ::math::linearalgebra::eigenvectorsSVD $A +} -cleanup { + unset A +} -result {{{0.7071068 -0.7071068} {0.7071068 0.7071068}} {3.0 1.0}} + +test eigenvectors-1.1-tkt7f082f8667 {Eigenvector signs} -setup { + # Test case derived from the example code found in ticket [7f082f8667]. + set A { + {2.7563361585555084 0.02600440980933252 0.0} + {0.02600440980933252 2.785766824118953 0.0} + {0.0 0.0 -5.542102982674461} + } +} -body { + lindex [::math::linearalgebra::eigenvectorsSVD $A] 1 +} -cleanup { + unset A +} -match numbers -result {2.80093075418638 2.7411722284880806 -5.542102982674461} + + +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 +} + diff --git a/tcllib/modules/math/liststat.tcl b/tcllib/modules/math/liststat.tcl new file mode 100755 index 0000000..d7b2e14 --- /dev/null +++ b/tcllib/modules/math/liststat.tcl @@ -0,0 +1,95 @@ +# 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 diff --git a/tcllib/modules/math/machineparameters.man b/tcllib/modules/math/machineparameters.man new file mode 100755 index 0000000..1deb093 --- /dev/null +++ b/tcllib/modules/math/machineparameters.man @@ -0,0 +1,190 @@ +[comment {-*- tclrep -*- doctools manpage}] +[manpage_begin tclrep/machineparameters n 1.0] +[copyright {2008 Michael Baudin <michael.baudin@sourceforge.net>}] +[moddesc tclrep] +[require snit] +[require math::machineparameters 0.1] + +[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) = <username> +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] + +[vset CATEGORY math] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/math/machineparameters.tcl b/tcllib/modules/math/machineparameters.tcl new file mode 100755 index 0000000..97cdb92 --- /dev/null +++ b/tcllib/modules/math/machineparameters.tcl @@ -0,0 +1,377 @@ +# 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) = <username> +#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 + } +} diff --git a/tcllib/modules/math/machineparameters.test b/tcllib/modules/math/machineparameters.test new file mode 100755 index 0000000..a361b43 --- /dev/null +++ b/tcllib/modules/math/machineparameters.test @@ -0,0 +1,40 @@ +# 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 + diff --git a/tcllib/modules/math/math.man b/tcllib/modules/math/math.man new file mode 100644 index 0000000..b49f304 --- /dev/null +++ b/tcllib/modules/math/math.man @@ -0,0 +1,126 @@ +[manpage_begin math n 1.2.5] +[keywords math] +[keywords statistics] +[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] + +[vset CATEGORY math] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/math/math.tcl b/tcllib/modules/math/math.tcl new file mode 100644 index 0000000..aa173e0 --- /dev/null +++ b/tcllib/modules/math/math.tcl @@ -0,0 +1,44 @@ +# 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. + +package require Tcl 8.2 ;# uses [lindex $l end-$integer] + +# @mdgen OWNER: tclIndex +# @mdgen OWNER: misc.tcl +# @mdgen OWNER: combinatorics.tcl + +namespace eval ::math { + # 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]] 1.2.5 +} diff --git a/tcllib/modules/math/math.test b/tcllib/modules/math/math.test new file mode 100644 index 0000000..a170cd2 --- /dev/null +++ b/tcllib/modules/math/math.test @@ -0,0 +1,279 @@ +# 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 diff --git a/tcllib/modules/math/math_geometry.man b/tcllib/modules/math/math_geometry.man new file mode 100644 index 0000000..65a2b81 --- /dev/null +++ b/tcllib/modules/math/math_geometry.man @@ -0,0 +1,456 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin math::geometry n 1.1.3] +[keywords angle] +[keywords distance] +[keywords line] +[keywords math] +[keywords {plane geometry}] +[keywords point] +[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.3]] + +[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. Note that a polyline needs not to be closed. + +[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::calculateDistanceToPolygon] [arg P] [arg polygon]] + +Calculate the distance of point P to the polygon and +return the result. If the list of coordinates is not closed (first and last +points differ), it is automatically closed. + +[list_begin arguments] +[arg_def list P] List of two numbers, the coordinates of the point + +[arg_def list polygon] List of numbers, the coordinates of the +vertices of the polygon +[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). If an endpoint of one segment lies on +the other segment (or is very close to the segment), they are considered to intersect + +[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] + +[vset CATEGORY {math :: geometry}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/math/misc.tcl b/tcllib/modules/math/misc.tcl new file mode 100644 index 0000000..a1db91c --- /dev/null +++ b/tcllib/modules/math/misc.tcl @@ -0,0 +1,385 @@ +# 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] +} + diff --git a/tcllib/modules/math/mvlinreg.tcl b/tcllib/modules/math/mvlinreg.tcl new file mode 100755 index 0000000..ba84743 --- /dev/null +++ b/tcllib/modules/math/mvlinreg.tcl @@ -0,0 +1,261 @@ +# 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 + +# ::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] +} diff --git a/tcllib/modules/math/numtheory.dtx b/tcllib/modules/math/numtheory.dtx new file mode 100755 index 0000000..61497f3 --- /dev/null +++ b/tcllib/modules/math/numtheory.dtx @@ -0,0 +1,952 @@ +% +% \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. +%</pkg> +%<*driver> +\documentclass{tclldoc} +\usepackage{amsmath,amsfonts} +\usepackage{url} +\newcommand{\Tcl}{\Tcllogo} +\begin{document} +\DocInput{numtheory.dtx} +\end{document} +%</driver> +% \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 +} +%</pkg> +% \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} +%</test> +% \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\ + <Lars dot Hellstrom at residenset dot net>"] +[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] +%</man> +% \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. + +%</man> +% \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} +} +%</pkg> +% \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 "" +%</test> +% \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<x<n\) to \(x^2 \equiv 1 \pmod{n}\). It is thus not +% too hard to imagine that a ``random'' $a^d$ squaring to $1$ +% modulo $n$ will be one of the nonstandard square roots of~$1$ +% when $n$ is not a prime, even if the above is not a proof that +% at least $3/4$ of all $a$ are witnesses to the compositeness +% of~$n$. +% +% Getting down to the implementation, the actual procedure has the +% call syntax +% \begin{quote} +% |Miller--Rabin| \word{n} \word{s} \word{d} \word{a} +% \end{quote} +% where all arguments should be integers such that \(n-1 = d2^s\), +% \(d,s \geq 1\), and \(0 < a < n\). The procedure computes +% $(a^d)^{2^s} \mod n$, and if in the course of doing this the +% Miller--Rabin test detects that $n$ is composite then this procedure +% will return |1|, otherwise it returns |0|. +% +% The first part of the procedure merely computes \(x = a^d \bmod n\), +% using exponentiation by squaring. $x$, $a$, and $d$ are modified in +% the loop, but $xa^d \bmod n$ would be an invariant quantity. +% Correctness presumes the initial \(d \geq 1\). +% \begin{tcl} +%<*pkg> +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}] +} +%</pkg> +% \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} +%</test> +% \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 +} +%</pkg> +% \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 + } +} +%</test> +% \end{tcl} +% \end{proc} +% +% +% \section*{Closings} +% +% \begin{tcl} +%<*man> +[list_end] + +[keywords {number theory} prime] +[manpage_end] +%</man> +% \end{tcl} +% +% \begin{tcl} +%<test>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 diff --git a/tcllib/modules/math/numtheory.man b/tcllib/modules/math/numtheory.man new file mode 100644 index 0000000..ad35161 --- /dev/null +++ b/tcllib/modules/math/numtheory.man @@ -0,0 +1,56 @@ +[manpage_begin math::numtheory n 1.0] +[keywords {number theory}] +[keywords prime] +[copyright "2010 Lars Hellstr\u00F6m\ + <Lars dot Hellstrom at residenset dot net>"] +[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] + +[vset CATEGORY {math :: numtheory}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/math/numtheory.stitch b/tcllib/modules/math/numtheory.stitch new file mode 100644 index 0000000..0318154 --- /dev/null +++ b/tcllib/modules/math/numtheory.stitch @@ -0,0 +1,17 @@ +# -*- 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 diff --git a/tcllib/modules/math/numtheory.tcl b/tcllib/modules/math/numtheory.tcl new file mode 100644 index 0000000..e426705 --- /dev/null +++ b/tcllib/modules/math/numtheory.tcl @@ -0,0 +1,78 @@ +## +## 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'.
\ No newline at end of file diff --git a/tcllib/modules/math/numtheory.test b/tcllib/modules/math/numtheory.test new file mode 100644 index 0000000..fa6364a --- /dev/null +++ b/tcllib/modules/math/numtheory.test @@ -0,0 +1,208 @@ +## +## 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'.
\ No newline at end of file diff --git a/tcllib/modules/math/optimize.man b/tcllib/modules/math/optimize.man new file mode 100755 index 0000000..304cd0e --- /dev/null +++ b/tcllib/modules/math/optimize.man @@ -0,0 +1,325 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin math::optimize n 1.0] +[keywords {linear program}] +[keywords math] +[keywords maximum] +[keywords minimum] +[keywords optimization] +[copyright {2004 Arjen Markus <arjenmarkus@users.sourceforge.net>}] +[copyright {2004,2005 Kevn B. Kenny <kennykb@users.sourceforge.net>}] +[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. + +[vset CATEGORY {math :: optimize}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/math/optimize.tcl b/tcllib/modules/math/optimize.tcl new file mode 100755 index 0000000..b5ddafe --- /dev/null +++ b/tcllib/modules/math/optimize.tcl @@ -0,0 +1,1319 @@ +#---------------------------------------------------------------------- +# +# 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 ) + $params(-ftol) ) }] + 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 "unbounded" + } + + # + # 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 value [lindex $secondcol $idx] + if { $value >= 0.0 } { + set result [lreplace $result $col $col [lindex $secondcol $idx]] + incr idx + } else { + # If a negative component, then the problem was not feasible + return "infeasible" + } + } + + 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.1 + +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 diff --git a/tcllib/modules/math/optimize.test b/tcllib/modules/math/optimize.test new file mode 100755 index 0000000..95827ae --- /dev/null +++ b/tcllib/modules/math/optimize.test @@ -0,0 +1,634 @@ +# -*- 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 + +test linprog-2.1 "Unbounded program 1" \ + -body { + set result [solveLinearProgram {3.0 4.0} {{1.0 -2.0 1.0} {-2.0 1.0 1.0}} ] + } \ + -result "unbounded" + +test linprog-2.2 "Unbounded program 2" \ + -body { + set result [::math::optimize::solveLinearProgram {2.0 1.0} {{3.0 0.0 6.0} {1.0 0.0 2.0}}] + } \ + -result "unbounded" + +test linprog-2.3 "Infeasible program" \ + -body { + set result [::math::optimize::solveLinearProgram {2.0 1.0} {{3.0 1.0 6.0} {1.0 -1.0 2.0} {0.0 1.0 -3.0}}] + } \ + -result "infeasible" + +test linprog-2.4 "Degenerate program" \ + -body { + # Solution: {1.0 3.0} + set result [::math::optimize::solveLinearProgram {2.0 1.0} {{3.0 1.0 6.0} {1.0 -1.0 2.0} {0.0 1.0 3.0}}] + set ok 1 + if { ! [within_range [lindex $result 0] 0.99999 1.00001] || + ! [within_range [lindex $result 1] 2.99999 3.00001] } { + set ok 0 + } + set ok + + } \ + -result 1 + +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 + +# Make sure the method deals gracefully with a "valley" +# (Ticket UUID: 3193459) + +test nelderMead-2.5 "Nelder-Mead - indeterminate minimum (valley)" \ + -setup { + proc h {a b} { + return [expr {abs($a-$b)}] + } + } \ + -body { + array set dd [::math::optimize::nelderMead h {1. 1.}] + foreach {x y} $dd(x) break + expr { abs($x-1.) < 0.00005 && abs($y-1.) < 0.00005 } + } \ + -cleanup { + rename h {}; unset dd + } \ + -result 1 + +testsuiteCleanup + +# Restore precision +set ::tcl_precision $old_precision + +# Local Variables: +# mode: tcl +# End: + +} ;# End of optimizetest namespace + + diff --git a/tcllib/modules/math/pdf_stat.tcl b/tcllib/modules/math/pdf_stat.tcl new file mode 100755 index 0000000..4e16e9d --- /dev/null +++ b/tcllib/modules/math/pdf_stat.tcl @@ -0,0 +1,2010 @@ +# 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-lognormal \ + pdf-exponential \ + cdf-normal cdf-uniform cdf-lognormal \ + cdf-exponential \ + cdf-students-t \ + random-normal random-uniform random-lognormal \ + random-exponential \ + histogram-uniform \ + pdf-gamma pdf-poisson pdf-chisquare pdf-students-t pdf-beta \ + pdf-weibull pdf-gumbel pdf-pareto pdf-cauchy \ + cdf-gamma cdf-poisson cdf-chisquare cdf-beta \ + cdf-weibull cdf-gumbel cdf-pareto cdf-cauchy \ + random-gamma random-poisson random-chisquare random-students-t random-beta \ + random-weibull random-gumbel random-pareto random-cauchy \ + incompleteGamma incompleteBeta \ + estimate-pareto empirical-distribution + + 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-lognormal -- +# Return the probabilities belonging to a log-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-lognormal { mean stdev x } { + variable NEGSTDEV + variable factorNormalPdf + + if { $stdev <= 0.0 || $mean <= 0.0 } { + return -code error -errorcode ARG \ + -errorinfo "Standard deviation and mean must be positive" \ + "Standard deviation and mean must be positive" + } + + set sigma [expr {sqrt(log(1.0 + $stdev /double($mean*$mean)))}] + set mu [expr {log($mean) - 0.5 * $sigma * $sigma}] + + set xn [expr {(log($x)-$mu)/$sigma}] + set prob [expr {exp(-$xn*$xn/2.0)/$sigma/$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-$pmin)}] + + 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 { $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/double($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-double($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-lognormal -- +# Return the cumulative probability belonging to a log-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::cdf-lognormal { mean stdev x } { + variable NEGSTDEV + + if { $stdev <= 0.0 || $mean <= 0.0 } { + return -code error -errorcode ARG \ + -errorinfo "Standard deviation and mean must be positive" \ + "Standard deviation and mean must be positive" + } + + set sigma [expr {sqrt(log(1.0 + $stdev /double($mean*$mean)))}] + set mu [expr {log($mean) - 0.5 * $sigma * $sigma}] + + set xn [expr {(log($x)-$mu)/$sigma}] + 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)/double($pmax-$pmin)}] + + 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/double($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)/double($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 +} + + + +# random-lognormal -- +# Return a list of random numbers satisfying a log-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-lognormal { mean stdev number } { + variable twopi + + if { $stdev <= 0.0 || $mean <= 0.0 } { + return -code error -errorcode ARG \ + -errorinfo "Standard deviation and mean must be positive" \ + "Standard deviation and mean must be positive" + } + + set sigma [expr {sqrt(log(1.0 + $stdev /double($mean*$mean)))}] + set mu [expr {log($mean) - 0.5 * $sigma * $sigma}] + +# set result {} +# for { set i 0 } {$i < $number } { incr i } { +# lappend result [Inverse-cdf-normal $mean $stdev [expr {rand()}]] +# } + + #puts "Random-lognormal: $mu -- $sigma" + + 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 {exp($mu + $sigma * $xrand)}] + if { $i < $number-1 } { + lappend result [expr {exp($mu + $sigma * $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 <http://www.netlib.org> +# +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 [expr {$a > 1.0? 0.0 : Inf}] + } + if {$x == 1.0} { + return [expr {$b > 1.0? 0.0 : Inf}] + } + 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 +} + + +# pdf-weibull -- +# Return the probabilities belonging to a Weibull distribution +# +# Arguments: +# scale Scale parameter of the Weibull distribution +# shape Shape parameter of the Weibull distribution +# x Value of variate +# +# Result: +# Probability density of the given value of x to occur +# +# Note: +# "-$x ** $shape" is evaluated as "(-$x)**$shape", hence use a division +# +proc ::math::statistics::pdf-weibull { scale shape x } { + variable OUTOFRANGE + + if { $x < 0 } { + return 0.0 + } + if { $scale <= 0.0 || $shape <= 0.0 } { + return -code error -errorcode ARG -errorinfo $OUTOFRANGE $OUTOFRANGE + } + set x [expr {$x / double($scale)}] + return [expr {$shape/double($scale) * pow($x,($shape-1.0)) / exp(pow($x,$shape))}] +} + + +# pdf-gumbel -- +# Return the probabilities belonging to a Gumbel distribution +# +# Arguments: +# location Location parameter of the Gumbel distribution +# scale Scale parameter of the Gumbel distribution +# x Value of variate +# +# Result: +# Probability density of the given value of x to occur +# +proc ::math::statistics::pdf-gumbel { location scale x } { + variable OUTOFRANGE + + if { $scale <= 0.0 } { + return -code error -errorcode ARG -errorinfo $OUTOFRANGE $OUTOFRANGE + } + set x [expr {($x - $location) / double($scale)}] + return [expr {exp(-$x - exp(-$x)) / $scale}] +} + + +# pdf-pareto -- +# Return the probabilities belonging to a Pareto distribution +# +# Arguments: +# scale Scale parameter of the Pareto distribution +# shape Shape parameter of the Pareto distribution +# x Value of variate +# +# Result: +# Probability density of the given value of x to occur +# +proc ::math::statistics::pdf-pareto { scale shape x } { + variable OUTOFRANGE + + if { $x <= $scale } { + return 0.0 + } + if { $scale <= 0.0 || $shape <= 0.0 } { + return -code error -errorcode ARG -errorinfo $OUTOFRANGE $OUTOFRANGE + } + set x [expr {$x / double($scale)}] + return [expr {$shape / double($scale) / pow($x,($shape + 1.0))}] +} + + +# pdf-cauchy -- +# Return the probabilities belonging to a Cauchy distribution +# +# Arguments: +# location Location parameter of the Cauchy distribution +# scale Scale parameter of the Cauchy distribution +# x Value of variate +# +# Result: +# Probability density of the given value of x to occur +# +# Note: +# The Cauchy distribution does not have finite higher-order moments +# +proc ::math::statistics::pdf-cauchy { location scale x } { + variable OUTOFRANGE + variable pi + + if { $scale <= 0.0 } { + return -code error -errorcode ARG -errorinfo $OUTOFRANGE $OUTOFRANGE + } + set x [expr {($x - $location) / double($scale)}] + return [expr {1.0 / $pi / $scale / (1.0 +$x*$x)}] +} + + +# 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 +} + + +# cdf-weibull -- +# Return the cumulative probabilities belonging to a Weibull distribution +# +# Arguments: +# scale Scale parameter of the Weibull distribution +# shape Shape parameter of the Weibull distribution +# x Value of variate +# +# Result: +# Cumulative probability of the given value of x to occur +# +proc ::math::statistics::cdf-weibull { scale shape x } { + variable OUTOFRANGE + + if { $x <= 0 } { + return 0.0 + } + if { $scale <= 0.0 || $shape <= 0.0 } { + return -code error -errorcode ARG -errorinfo $OUTOFRANGE $OUTOFRANGE + } + set x [expr {$x / double($scale)}] + return [expr {1.0 - 1.0 / exp(pow($x,$shape))}] +} + + +# cdf-gumbel -- +# Return the cumulative probabilities belonging to a Gumbel distribution +# +# Arguments: +# location Location parameter of the Gumbel distribution +# scale Scale parameter of the Gumbel distribution +# x Value of variate +# +# Result: +# Cumulative probability of the given value of x to occur +# +proc ::math::statistics::cdf-gumbel { location scale x } { + variable OUTOFRANGE + + if { $scale <= 0.0 } { + return -code error -errorcode ARG -errorinfo $OUTOFRANGE $OUTOFRANGE + } + set x [expr {($x - $location) / double($scale)}] + return [expr {exp( -exp(-$x) )}] +} + + +# cdf-pareto -- +# Return the cumulative probabilities belonging to a Pareto distribution +# +# Arguments: +# scale Scale parameter of the Pareto distribution +# shape Shape parameter of the Pareto distribution +# x Value of variate +# +# Result: +# Cumulative probability density of the given value of x to occur +# +proc ::math::statistics::cdf-pareto { scale shape x } { + variable OUTOFRANGE + + if { $x <= $scale } { + return 0.0 + } + if { $scale <= 0.0 || $shape <= 0.0 } { + return -code error -errorcode ARG -errorinfo $OUTOFRANGE $OUTOFRANGE + } + set x [expr {$x / double($scale)}] + return [expr {1.0 - 1.0 / pow($x,$shape)}] +} + + +# cdf-cauchy -- +# Return the cumulative probabilities belonging to a Cauchy distribution +# +# Arguments: +# location Scale parameter of the Cauchy distribution +# scale Shape parameter of the Cauchy distribution +# x Value of variate +# +# Result: +# Cumulative probability density of the given value of x to occur +# +proc ::math::statistics::cdf-cauchy { location scale x } { + variable OUTOFRANGE + variable pi + + if { $scale <= 0.0 } { + return -code error -errorcode ARG -errorinfo $OUTOFRANGE $OUTOFRANGE + } + set x [expr {($x - $location) / double($scale)}] + return [expr {0.5 + atan($x) / $pi}] +} + + +# random-gamma -- +# Generate a list of gamma-distributed deviates +# +# Arguments: +# alpha Shape parameter +# beta Rate parameter +# number Number of values to return +# +# 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 +} + + +# random-weibull -- +# Generate a list of Weibull distributed deviates +# +# Arguments: +# scale Scale parameter of the Weibull distribution +# shape Shape parameter of the Weibull distribution +# number Number of values to return +# +# Result: +# List of random values +# +proc ::math::statistics::random-weibull { scale shape number } { + variable OUTOFRANGE + + if { $scale <= 0.0 || $shape <= 0.0 } { + return -code error -errorcode ARG -errorinfo $OUTOFRANGE $OUTOFRANGE + } + set rshape [expr {1.0/$shape}] + set retval {} + for {set i 0} {$i < $number} {incr i} { + lappend retval [expr {$scale * pow( (-log(rand())),$rshape)}] + } + return $retval +} + + +# random-gumbel -- +# Generate a list of Weibull distributed deviates +# +# Arguments: +# location Location parameter of the Gumbel distribution +# scale Scale parameter of the Gumbel distribution +# number Number of values to return +# +# Result: +# List of random values +# +proc ::math::statistics::random-gumbel { location scale number } { + variable OUTOFRANGE + + if { $scale <= 0.0 } { + return -code error -errorcode ARG -errorinfo $OUTOFRANGE $OUTOFRANGE + } + set retval {} + for {set i 0} {$i < $number} {incr i} { + lappend retval [expr {$location - $scale * log(-log(rand()))}] + } + return $retval +} + + +# random-pareto -- +# Generate a list of Pareto distributed deviates +# +# Arguments: +# scale Scale parameter of the Pareto distribution +# shape Shape parameter of the Pareto distribution +# number Number of values to return +# +# Result: +# List of random values +# +proc ::math::statistics::random-pareto { scale shape number } { + variable OUTOFRANGE + + if { $scale <= 0.0 || $shape <= 0.0 } { + return -code error -errorcode ARG -errorinfo $OUTOFRANGE $OUTOFRANGE + } + set rshape [expr {1.0/$shape}] + set retval {} + for {set i 0} {$i < $number} {incr i} { + lappend retval [expr {$scale / pow(rand(),$rshape)}] + } + return $retval +} + + +# random-cauchy -- +# Generate a list of Cauchy distributed deviates +# +# Arguments: +# location Location parameter of the Cauchy distribution +# scale Shape parameter of the Cauchy distribution +# number Number of values to return +# +# Result: +# List of random values +# +proc ::math::statistics::random-cauchy { location scale number } { + variable OUTOFRANGE + variable pi + + if { $scale <= 0.0 } { + return -code error -errorcode ARG -errorinfo $OUTOFRANGE $OUTOFRANGE + } + set retval {} + for {set i 0} {$i < $number} {incr i} { + lappend retval [expr {$location + $scale * tan( $pi * (rand() - 0.5))}] + } + return $retval +} + + +# estimate-pareto -- +# Estimate the parameters of a Pareto distribution +# +# Arguments: +# values Values that are supposed to be distributed according to Pareto +# +# Result: +# Estimates of the scale and shape parameters as well as the standard error +# for the shape parameter. +# +proc ::math::statistics::estimate-pareto { values } { + variable OUTOFRANGE + variable TOOFEWDATA + + set nvalues {} + set negative 0 + + foreach v $values { + if { $v != {} } { + lappend nvalues $v + if { $v <= 0.0 } { + set negative 1 + } + } + } + if { [llength $nvalues] == 0 } { + return -code error -errorcode ARG -errorinfo $TOOFEWDATA $TOOFEWDATA + } + if { $negative } { + return -code error -errorcode ARG -errorinfo "One or more negative or zero values" $OUTOFRANGE + } + + # + # Scale parameter + # + set scale [min $nvalues] + + # + # Shape parameter + # + set n [llength $nvalues] + set sum 0.0 + foreach v $nvalues { + set sum [expr {$sum + log($v) - log($scale)}] + } + set shape [expr {$n / $sum}] + + return [list $scale $shape [expr {$shape/sqrt($n)}]] +} + + +# empirical-distribution -- +# Determine the empirical distribution +# +# Arguments: +# values Values that are to be examined +# +# Result: +# List of sorted values and their empirical probability +# +# Note: +# The value of "a" is adopted from the corresponding Wikipedia page, +# which in turn adopted it from the R "stats" package (qqnorm function) +# +proc ::math::statistics::empirical-distribution { values } { + variable TOOFEWDATA + + set n [llength $values] + + if { $n < 5 } { + return -code error -errorcode ARG -errorinfo $TOOFEWDATA $TOOFEWDATA + } + + set a 0.375 + if { $n > 10 } { + set a 0.5 + } + + set distribution {} + set idx 1 + foreach x [lsort -real -increasing $values] { + if { $x != {} } { + set p [expr {($idx - $a) / ($n + 1 - 2.0 * $a)}] + + lappend distribution $x $p + incr idx + } + } + + return $distribution +} + + +# +# 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 +} diff --git a/tcllib/modules/math/pkgIndex.tcl b/tcllib/modules/math/pkgIndex.tcl new file mode 100644 index 0000000..fb9b3c3 --- /dev/null +++ b/tcllib/modules/math/pkgIndex.tcl @@ -0,0 +1,33 @@ +if {![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.3 [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.3.0 [list source [file join $dir special.tcl]] +package ifneeded math::constants 1.0.2 [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 1.0 [list source [file join $dir statistics.tcl]] +package ifneeded math::optimize 1.0.1 [list source [file join $dir optimize.tcl]] +package ifneeded math::calculus 0.8.1 [list source [file join $dir calculus.tcl]] +package ifneeded math::interpolate 1.1 [list source [file join $dir interpolate.tcl]] +package ifneeded math::linearalgebra 1.1.5 [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.1 [list source [file join $dir symdiff.tcl]] +package ifneeded math::bigfloat 2.0.2 [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.3 [list source [file join $dir decimal.tcl]] + +if {![package vsatisfies [package require Tcl] 8.6]} {return} +package ifneeded math::exact 1.0 [list source [file join $dir exact.tcl]] diff --git a/tcllib/modules/math/plotstat.tcl b/tcllib/modules/math/plotstat.tcl new file mode 100755 index 0000000..1c38fcb --- /dev/null +++ b/tcllib/modules/math/plotstat.tcl @@ -0,0 +1,312 @@ +# 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 +} diff --git a/tcllib/modules/math/polynomials.man b/tcllib/modules/math/polynomials.man new file mode 100755 index 0000000..ede9a3c --- /dev/null +++ b/tcllib/modules/math/polynomials.man @@ -0,0 +1,219 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin math::polynomials n 1.0.1] +[keywords math] +[keywords {polynomial functions}] +[copyright {2004 Arjen Markus <arjenmarkus@users.sourceforge.net>}] +[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. + +[vset CATEGORY {math :: polynomials}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/math/polynomials.tcl b/tcllib/modules/math/polynomials.tcl new file mode 100755 index 0000000..928d3c8 --- /dev/null +++ b/tcllib/modules/math/polynomials.tcl @@ -0,0 +1,560 @@ +# 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 +} diff --git a/tcllib/modules/math/polynomials.test b/tcllib/modules/math/polynomials.test new file mode 100755 index 0000000..7484fcb --- /dev/null +++ b/tcllib/modules/math/polynomials.test @@ -0,0 +1,260 @@ +# -*- 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 diff --git a/tcllib/modules/math/qcomplex.man b/tcllib/modules/math/qcomplex.man new file mode 100755 index 0000000..f7ce939 --- /dev/null +++ b/tcllib/modules/math/qcomplex.man @@ -0,0 +1,302 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin math::complexnumbers n 1.0.2] +[keywords {complex numbers}] +[keywords math] +[copyright {2004 Arjen Markus <arjenmarkus@users.sourceforge.net>}] +[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] + +[vset CATEGORY {math :: complexnumbers}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/math/qcomplex.tcl b/tcllib/modules/math/qcomplex.tcl new file mode 100755 index 0000000..ac3cbf7 --- /dev/null +++ b/tcllib/modules/math/qcomplex.tcl @@ -0,0 +1,178 @@ +# 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 diff --git a/tcllib/modules/math/qcomplex.test b/tcllib/modules/math/qcomplex.test new file mode 100755 index 0000000..394c44f --- /dev/null +++ b/tcllib/modules/math/qcomplex.test @@ -0,0 +1,250 @@ +# -*- 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 diff --git a/tcllib/modules/math/rational_funcs.man b/tcllib/modules/math/rational_funcs.man new file mode 100755 index 0000000..d647709 --- /dev/null +++ b/tcllib/modules/math/rational_funcs.man @@ -0,0 +1,186 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin math::rationalfunctions n 1.0.1] +[keywords math] +[keywords {rational functions}] +[copyright {2005 Arjen Markus <arjenmarkus@users.sourceforge.net>}] +[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. + +[vset CATEGORY {math :: rationalfunctions}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/math/rational_funcs.tcl b/tcllib/modules/math/rational_funcs.tcl new file mode 100755 index 0000000..2dae397 --- /dev/null +++ b/tcllib/modules/math/rational_funcs.tcl @@ -0,0 +1,364 @@ +# 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 +} diff --git a/tcllib/modules/math/roman.man b/tcllib/modules/math/roman.man new file mode 100755 index 0000000..e8c6dc3 --- /dev/null +++ b/tcllib/modules/math/roman.man @@ -0,0 +1,51 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin math::roman "" 1.0] +[keywords conversion] +[keywords integer] +[keywords {roman numeral}] +[copyright {2005 Kenneth Green <kenneth.green@gmail.com>}] +[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. + +[vset CATEGORY {math :: roman}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/math/roman.test b/tcllib/modules/math/roman.test new file mode 100755 index 0000000..2fd3459 --- /dev/null +++ b/tcllib/modules/math/roman.test @@ -0,0 +1,223 @@ +# -*- 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 diff --git a/tcllib/modules/math/romannumerals.tcl b/tcllib/modules/math/romannumerals.tcl new file mode 100755 index 0000000..a67d259 --- /dev/null +++ b/tcllib/modules/math/romannumerals.tcl @@ -0,0 +1,164 @@ +#========================================================================== +# 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]" +} diff --git a/tcllib/modules/math/romberg.man b/tcllib/modules/math/romberg.man new file mode 100755 index 0000000..9d1f1e9 --- /dev/null +++ b/tcllib/modules/math/romberg.man @@ -0,0 +1,340 @@ +[manpage_begin math::calculus::romberg n 0.6] +[see_also math::calculus] +[see_also math::interpolate] +[copyright "2004 Kevin B. Kenny <kennykb@acm.org>. All rights\ +reserved. Redistribution permitted under the terms of the Open\ +Publication License <http://www.opencontent.org/openpub/>"] +[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 +}] + +[vset CATEGORY {math :: calculus}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/math/special.man b/tcllib/modules/math/special.man new file mode 100755 index 0000000..908c1ce --- /dev/null +++ b/tcllib/modules/math/special.man @@ -0,0 +1,472 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin math::special n 0.3] +[keywords {Bessel functions}] +[keywords {error function}] +[keywords math] +[keywords {special functions}] +[copyright {2004 Arjen Markus <arjenmarkus@users.sourceforge.net>}] +[moddesc {Tcl Math Library}] +[titledesc {Special mathematical functions}] +[category Mathematics] +[require Tcl [opt 8.3]] +[require math::special [opt 0.3]] + +[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 | | | + | | | | +Inverse | invnorm | 0 < x < 1 | -- | < 1.2e-9 +normal | | | | +distribution | | | | + | | | | +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]] + +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::invnorm] [arg p]] + +Compute the inverse of the normal distribution function for argument "p" + +[list_begin arguments] +[arg_def float p] Argument for the inverse normal distribution function +(p must be greater than 0 and lower than 1) +[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) + +[vset CATEGORY {math :: special}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/math/special.tcl b/tcllib/modules/math/special.tcl new file mode 100755 index 0000000..637a3bc --- /dev/null +++ b/tcllib/modules/math/special.tcl @@ -0,0 +1,301 @@ +# 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 invnorm +} + +# 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}] + } +} + +# invnorm -- +# Compute the inverse of the cumulative normal distribution +# +# Arguments: +# p Value of erf(x) for x must be found +# +# Returns: +# Value of x +# +# Notes: +# Implementation in Tcl by Christian Gollwitzer +# Uses rational approximation from +# http://home.online.no/~pjacklam/notes/invnorm/#Pseudo_code_for_rational_approximation +# relative precision 1.2*10^-9 in the full range +# +proc ::math::special::invnorm {p} { + # inverse normal distribution + # rational approximation from + # http://home.online.no/~pjacklam/notes/invnorm/#Pseudo_code_for_rational_approximation + # precision 1.2*10^-9 + + if {$p<=0 || $p>=1} { + return -code error "Domain error (invnorm)" + } + # Coefficients in rational approximations. + set a1 -3.969683028665376e+01 + set a2 2.209460984245205e+02 + set a3 -2.759285104469687e+02 + set a4 1.383577518672690e+02 + set a5 -3.066479806614716e+01 + set a6 2.506628277459239e+00 + + set b1 -5.447609879822406e+01 + set b2 1.615858368580409e+02 + set b3 -1.556989798598866e+02 + set b4 6.680131188771972e+01 + set b5 -1.328068155288572e+01 + + set c1 -7.784894002430293e-03 + set c2 -3.223964580411365e-01 + set c3 -2.400758277161838e+00 + set c4 -2.549732539343734e+00 + set c5 4.374664141464968e+00 + set c6 2.938163982698783e+00 + + set d1 7.784695709041462e-03 + set d2 3.224671290700398e-01 + set d3 2.445134137142996e+00 + set d4 3.754408661907416e+00 + + # Define break-points. + + set p_low 0.02425 + set p_high [expr {1-$p_low}] + + # Rational approximation for lower region. + + if {$p < $p_low} { + set q [expr {sqrt(-2*log($p))}] + set x [expr {((((($c1*$q+$c2)*$q+$c3)*$q+$c4)*$q+$c5)*$q+$c6) / \ + (((($d1*$q+$d2)*$q+$d3)*$q+$d4)*$q+1)}] + return $x + } + + # Rational approximation for central region. + + if {$p <= $p_high} { + set q [expr {$p - 0.5}] + set r [expr {$q*$q}] + set x [expr {((((($a1*$r+$a2)*$r+$a3)*$r+$a4)*$r+$a5)*$r+$a6)*$q / \ + ((((($b1*$r+$b2)*$r+$b3)*$r+$b4)*$r+$b5)*$r+1)}] + return $x + } + + # Rational approximation for upper region. + + set q [expr {sqrt(-2*log(1-$p))}] + set x [expr {-((((($c1*$q+$c2)*$q+$c3)*$q+$c4)*$q+$c5)*$q+$c6) / + (((($d1*$q+$d2)*$q+$d3)*$q+$d4)*$q+1)}] + return $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.3.0 diff --git a/tcllib/modules/math/special.test b/tcllib/modules/math/special.test new file mode 100755 index 0000000..c778935 --- /dev/null +++ b/tcllib/modules/math/special.test @@ -0,0 +1,132 @@ +# -*- 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} + +test "invnorm-1.0" "Values of the inverse normal distribution" \ + -match numbers -body { + set result {} + foreach p {0.001 0.01 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 0.99 0.999} { + lappend result [::math::special::invnorm $p] + } + set result +} -result {-3.090232304709404 -2.326347874388028 -1.2815515641401563 -0.8416212327266185 -0.5244005132792953 -0.2533471028599986 + 0.0 0.2533471028599986 0.5244005132792952 0.8416212327266186 1.2815515641401563 2.326347874388028 3.090232304709404} + +test "sinc-1.0" "Values of the sinc function" \ + -match numbers -body { + set result [::math::special::sinc 0.0] +} -result 1.0 + +# End of test cases +testsuiteCleanup diff --git a/tcllib/modules/math/stat_kernel.tcl b/tcllib/modules/math/stat_kernel.tcl new file mode 100644 index 0000000..1d1f219 --- /dev/null +++ b/tcllib/modules/math/stat_kernel.tcl @@ -0,0 +1,217 @@ +# stat_kernel.tcl -- +# +# Part of the statistics package for basic statistical analysis +# Based on http://en.wikipedia.org/wiki/Kernel_(statistics) and +# http://en.wikipedia.org/wiki/Kernel_density_estimation +# +# version 0.1: initial implementation, january 2014 + +# kernel-density -- +# Estimate the probability density using the kernel density +# estimation method +# +# Arguments: +# data List of univariate data +# args List of options in the form of keyword-value pairs: +# -weights weights: per data point the weight +# -bandwidth value: bandwidth to be used for the estimation +# -number value: number of bins to be returned +# -interval {begin end}: begin and end of the interval for +# which the density is returned +# -kernel function: kernel to be used (gaussian, cosine, +# epanechnikov, uniform, triangular, biweight, +# logistic) +# For all options more or less sensible defaults are +# provided. +# +# Result: +# A list of the bin centres, a list of the corresponding density +# estimates and a list containing several computational parameters: +# begin and end of the interval, mean, standard deviation and bandwidth +# +# Note: +# The conditions for the kernel function are fairly weak: +# - It should integrate to 1 +# - It should be symmetric around 0 +# +# As for the implementation in Tcl: it should be reachable in the +# ::math::statistics namespace. As a consequence, you can define +# your own kernel function too. Hence there is no check. +# +proc ::math::statistics::kernel-density {data args} { + + # + # Determine the basic statistics + # + set basicStats [BasicStats all $data] + + set mean [lindex $basicStats 0] + set ndata [lindex $basicStats 3] + set stdev [lindex $basicStats 4] + + if { $ndata < 1 } { + return -code error -errorcode ARG -errorinfo "Too few actual data" + } + + # + # Get the options (providing defaults as needed) + # + set opt(-weights) {} + set opt(-number) 100 + set opt(-kernel) gaussian + + # + # The default bandwidth is set via a simple expression, which + # is supposed to be optimal for the Gaussian kernel. + # Perhaps a more sophisticated method should be provided as well + # + set opt(-bandwidth) [expr {1.06 * $stdev / pow($ndata,0.2)}] + + # + # The default interval is derived from the mean and the + # standard deviation + # + set opt(-interval) [list [expr {$mean - 3.0 * $stdev}] [expr {$mean + 3.0 * $stdev}]] + + # + # Retrieve the given options from $args + # + if { [llength $args] % 2 != 0 } { + return -code error -errorcode ARG -errorinfo "The options must all have a value" + } + array set opt $args + + # + # Elementary checks + # + if { $opt(-bandwidth) <= 0.0 } { + return -code error -errorcode ARG -errorinfo "The bandwidth must be positive: $opt(-bandwidth)" + } + + if { $opt(-number) <= 0.0 } { + return -code error -errorcode ARG -errorinfo "The number of bins must be positive: $opt(-number)" + } + + if { [lindex $opt(-interval) 0] == [lindex $opt(-interval) 1] } { + return -code error -errorcode ARG -errorinfo "The interval has length zero: $opt(-interval)" + } + + if { [llength [info proc $opt(-kernel)]] == 0 } { + return -code error -errorcode ARG -errorinfo "Unknown kernel function: $opt(-kernel)" + } + + # + # Construct the weights + # + if { [llength $opt(-weights)] > 0 } { + if { [llength $data] != [llength $opt(-weights)] } { + return -code error -errorcode ARG -errorinfo "The list of weights must match the data" + } + + set sum 0.0 + foreach d $data w $opt(-weights) { + if { $d != {} } { + set sum [expr {$sum + $w}] + } + } + set scale [expr {1.0/$sum/$ndata}] + + set weight {} + foreach w $opt(-weights) { + if { $d != {} } { + lappend weight [expr {$w / $scale}] + } else { + lappend weight {} + } + } + } else { + set weight [lrepeat [llength $data] [expr {1.0/$ndata}]] ;# Note: missing values have weight zero + } + + # + # Construct the centres of the bins + # + set xbegin [lindex $opt(-interval) 0] + set xend [lindex $opt(-interval) 1] + set dx [expr {($xend - $xbegin) / double($opt(-number))}] + set xb [expr {$xbegin + 0.5 * $dx}] + set xvalue {} + for {set i 0} {$i < $opt(-number)} {incr i} { + lappend xvalue [expr {$xb + $i * $dx}] + } + + # + # Construct the density function + # + set density {} + set scale [expr {1.0/$opt(-bandwidth)}] + foreach x $xvalue { + set sum 0.0 + foreach d $data w $weight { + if { $d != {} } { + set kvalue [$opt(-kernel) [expr {$scale * ($x-$d)}]] + set sum [expr {$sum + $w * $kvalue}] + } + } + lappend density [expr {$sum * $scale}] + } + + # + # Return the result + # + return [list $xvalue $density [list $xbegin $xend $mean $stdev $opt(-bandwidth)]] +} + +# gaussian, uniform, triangular, epanechnikov, biweight, cosine, logistic -- +# The Gaussian kernel +# +# Arguments: +# x (Scaled) argument +# +# Result: +# Value of the kernel +# +# Note: +# The standard deviation is 1. +# +proc ::math::statistics::gaussian {x} { + return [expr {exp(-0.5*$x*$x) / sqrt(2.0*acos(-1.0))}] +} +proc ::math::statistics::uniform {x} { + if { abs($x) <= 1.0 } { + return 0.5 + } else { + return 0.0 + } +} +proc ::math::statistics::triangular {x} { + if { abs($x) < 1.0 } { + return [expr {1.0 - abs($x)}] + } else { + return 0.0 + } +} +proc ::math::statistics::epanechnikov {x} { + if { abs($x) < 1.0 } { + return [expr {0.75 * (1.0 - abs($x)*abs($x))}] + } else { + return 0.0 + } +} +proc ::math::statistics::biweight {x} { + if { abs($x) < 1.0 } { + return [expr {0.9375 * pow((1.0 - abs($x)*abs($x)),2)}] + } else { + return 0.0 + } +} +proc ::math::statistics::cosine {x} { + if { abs($x) < 1.0 } { + return [expr {0.25 * acos(-1.0) * cos(0.5 * acos(-1.0) * $x)}] + } else { + return 0.0 + } +} +proc ::math::statistics::logistic {x} { + return [expr {1.0 / (exp($x) + 2.0 + exp(-$x))}] +} diff --git a/tcllib/modules/math/statistics.man b/tcllib/modules/math/statistics.man new file mode 100755 index 0000000..433e61d --- /dev/null +++ b/tcllib/modules/math/statistics.man @@ -0,0 +1,1504 @@ +[vset VERSION 1] +[manpage_begin math::statistics n [vset VERSION]] +[keywords {data analysis}] +[keywords mathematics] +[keywords statistics] +[moddesc {Tcl Math Library}] +[titledesc {Basic statistical functions and procedures}] +[category Mathematics] +[require Tcl 8.4] +[require math::statistics [vset VERSION]] +[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] [opt weights]] +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.) +[para] +Optionally, you can use weights to influence the histogram. + +[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 +[arg_def list weights] - List of weights, one weight per value +[list_end] +[para] + +[call [cmd ::math::statistics::histogram-alt] [arg limits] [arg values] [opt weights]] +Alternative implementation of the histogram procedure: the open end of the intervals +is at the lower bound instead of the upper bound. + +[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 +[arg_def list weights] - List of weights, one weight per value +[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 alpha]] +Test whether the mean value of a sample is in accordance with the +estimated normal distribution with a certain probability. +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 alpha] - Probability level (0.95 or 0.99 for instance) +[list_end] +[para] + +[call [cmd ::math::statistics::test-normal] [arg data] [arg significance]] +Test whether the given data follow a normal distribution +with a certain level of significance. +Returns 1 if the data are normally distributed within the level of +significance, returns 0 if not. The underlying test is the Lilliefors +test. Smaller values of the significance mean a stricter testing. + +[list_begin arguments] +[arg_def list data] - List of raw data values +[arg_def float significance] - Significance level (one of 0.01, 0.05, 0.10, 0.15 or 0.20). For compatibility +reasons the values "1-significance", 0.80, 0.85, 0.90, 0.95 or 0.99 are also accepted. +[list_end] +[para] +Compatibility issue: the original implementation and documentation used the term "confidence" and used a value +1-significance (see ticket 2812473fff). This has been corrected as of version 0.9.3. + +[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::test-Duckworth] [arg list1] [arg list2] [arg significance]] +Determine if two data sets have the same median according to the Tukey-Duckworth test. +The procedure returns 0 if the medians are unequal, 1 if they are equal, -1 if the test can not +be conducted (the smallest value must be in a different set than the greatest value). +# +# Arguments: +# list1 Values in the first data set +# list2 Values in the second data set +# significance Significance level (either 0.05, 0.01 or 0.001) +# +# Returns: + +Test whether the given data follow a normal distribution +with a certain level of significance. +Returns 1 if the data are normally distributed within the level of +significance, returns 0 if not. The underlying test is the Lilliefors +test. Smaller values of the significance mean a stricter testing. + +[list_begin arguments] +[arg_def list list1] - First list of data +[arg_def list list2] - Second list of data +[arg_def float significance] - Significance level (either 0.05, 0.01 or 0.001) +[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) or a list of confidence levels. +[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) or a list of confidence levels. +[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] + +[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] + +[call [cmd ::math::statistics::kernel-density] [arg data] opt [arg "-option value"] ...]] +Return the density function based on kernel density estimation. The procedure is controlled by +a small set of options, each of which is given a reasonable default. +[para] +The return value consists of three lists: the centres of the bins, the associated probability +density and a list of computational parameters (begin and end of the interval, mean and standard +deviation and the used bandwidth). The computational parameters can be used for further analysis. + +[list_begin arguments] +[arg_def list data] - The data to be examined +[arg_def list args] - Option-value pairs: +[list_begin definitions] +[def "[option -weights] [arg weights]"] Per data point the weight (default: 1 for all data) +[def "[option -bandwidth] [arg value]"] Bandwidth to be used for the estimation (default: determined from standard deviation) +[def "[option -number] [arg value]"] Number of bins to be returned (default: 100) +[def "[option -interval] [arg "{begin end}"]"] Begin and end of the interval for +which the density is returned (default: mean +/- 3*standard deviation) +[def "[option -kernel] [arg function]"] Kernel to be used (One of: gaussian, cosine, +epanechnikov, uniform, triangular, biweight, logistic; default: gaussian) +[list_end] +[list_end] + +[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 as well as the log-normal 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 beta distribution +[item] +The chi-square distribution +[item] +The student's T distribution +[item] +The Poisson distribution +[item] +The Pareto distribution +[item] +The Gumbel distribution +[item] +The Weibull distribution +[item] +The Cauchy 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-lognormal] [arg mean] [arg stdev] [arg value]] +Return the probability of a given value for a log-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-gamma] [arg a] [arg b] [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 a] - Shape parameter +[arg_def float b] - Rate parameter +[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] - Second shape parameter +[arg_def float value] - Value for which the probability is required +[list_end] +[para] + +[call [cmd ::math::statistics::pdf-weibull] [arg scale] [arg shape] [arg value]] +Return the probability of a given value for a Weibull +distribution with given scale and shape parameters + +[list_begin arguments] +[arg_def float location] - Scale parameter +[arg_def float scale] - Shape parameter +[arg_def float value] - Value for which the probability is required +[list_end] +[para] + +[call [cmd ::math::statistics::pdf-gumbel] [arg location] [arg scale] [arg value]] +Return the probability of a given value for a Gumbel +distribution with given location and shape parameters + +[list_begin arguments] +[arg_def float location] - Location parameter +[arg_def float scale] - Shape parameter +[arg_def float value] - Value for which the probability is required +[list_end] +[para] + +[call [cmd ::math::statistics::pdf-pareto] [arg scale] [arg shape] [arg value]] +Return the probability of a given value for a Pareto +distribution with given scale and shape parameters + +[list_begin arguments] +[arg_def float scale] - Scale parameter +[arg_def float shape] - Shape parameter +[arg_def float value] - Value for which the probability is required +[list_end] +[para] + +[call [cmd ::math::statistics::pdf-cauchy] [arg location] [arg scale] [arg value]] +Return the probability of a given value for a Cauchy +distribution with given location and shape parameters. Note that the Cauchy distribution +has no finite higher-order moments. + +[list_begin arguments] +[arg_def float location] - Location parameter +[arg_def float scale] - 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-lognormal] [arg mean] [arg stdev] [arg value]] +Return the cumulative probability of a given value for a log-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] - Second shape parameter +[arg_def float value] - Value for which the probability is required +[list_end] +[para] + +[call [cmd ::math::statistics::cdf-weibull] [arg scale] [arg shape] [arg value]] +Return the cumulative probability of a given value for a Weibull +distribution with given scale and shape parameters. + +[list_begin arguments] +[arg_def float scale] - Scale parameter +[arg_def float shape] - Shape parameter +[arg_def float value] - Value for which the probability is required +[list_end] +[para] + +[call [cmd ::math::statistics::cdf-gumbel] [arg location] [arg scale] [arg value]] +Return the cumulative probability of a given value for a Gumbel +distribution with given location and scale parameters. + +[list_begin arguments] +[arg_def float location] - Location parameter +[arg_def float scale] - Scale parameter +[arg_def float value] - Value for which the probability is required +[list_end] +[para] + +[call [cmd ::math::statistics::cdf-pareto] [arg scale] [arg shape] [arg value]] +Return the cumulative probability of a given value for a Pareto +distribution with given scale and shape parameters + +[list_begin arguments] +[arg_def float scale] - Scale parameter +[arg_def float shape] - Shape parameter +[arg_def float value] - Value for which the probability is required +[list_end] +[para] + +[call [cmd ::math::statistics::cdf-cauchy] [arg location] [arg scale] [arg value]] +Return the cumulative probability of a given value for a Cauchy +distribution with given location and scale parameters. + +[list_begin arguments] +[arg_def float location] - Location parameter +[arg_def float scale] - Scale parameter +[arg_def float value] - Value for which the probability is required +[list_end] +[para] + +[call [cmd ::math::statistics::empirical-distribution] [arg values]] +Return a list of values and their empirical probability. The values are sorted in increasing order. +(The implementation follows the description at the corresponding Wikipedia page) + +[list_begin arguments] +[arg_def list values] - List of data to be examined +[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-lognormal] [arg mean] [arg stdev] [arg number]] +Return a list of "number" random values satisfying a log-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-poisson] [arg mu] [arg number]] +Return a list of "number" random values satisfying +a Poisson distribution with given mean. + +[list_begin arguments] +[arg_def float mu] - Mean of the distribution +[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::random-weibull] [arg scale] [arg shape] [arg number]] +Return a list of "number" random values satisfying +a Weibull distribution with given scale and shape parameters. + +[list_begin arguments] +[arg_def float scale] - Scale parameter +[arg_def float shape] - Shape parameter +[arg_def int number] - Number of values to be returned +[list_end] +[para] + +[call [cmd ::math::statistics::random-gumbel] [arg location] [arg scale] [arg number]] +Return a list of "number" random values satisfying +a Gumbel distribution with given location and scale parameters. + +[list_begin arguments] +[arg_def float location] - Location parameter +[arg_def float scale] - Scale parameter +[arg_def int number] - Number of values to be returned +[list_end] +[para] + +[call [cmd ::math::statistics::random-pareto] [arg scale] [arg shape] [arg number]] +Return a list of "number" random values satisfying +a Pareto distribution with given scale and shape parameters. + +[list_begin arguments] +[arg_def float scale] - Scale parameter +[arg_def float shape] - Shape parameter +[arg_def int number] - Number of values to be returned +[list_end] +[para] + +[call [cmd ::math::statistics::random-cauchy] [arg location] [arg scale] [arg number]] +Return a list of "number" random values satisfying +a Cauchy distribution with given location and scale parameters. + +[list_begin arguments] +[arg_def float location] - Location parameter +[arg_def float scale] - Scale 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] + +[call [cmd ::math::statistics::estimate-pareto] [arg values]] +Estimate the parameters for the Pareto distribution that comes closest to the given values. +Returns the estimated scale and shape parameters, as well as the standard error for the shape parameter. + +[list_begin arguments] +[arg_def list values] - List of values, assumed to be distributed according to a Pareto distribution +[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] + +[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] + +[vset CATEGORY {math :: statistics}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/math/statistics.tcl b/tcllib/modules/math/statistics.tcl new file mode 100755 index 0000000..46fb014 --- /dev/null +++ b/tcllib/modules/math/statistics.tcl @@ -0,0 +1,1634 @@ +# statistics.tcl -- +# +# Package for basic statistical analysis +# +# version 0.1: initial implementation, january 2003 +# version 0.1.1: added linear regres +# 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 +# version 0.9: added kernel density estimation +# version 0.9.3: added histogram-alt, corrected test-normal + +package require Tcl 8.4 +package provide math::statistics 1.0 +package require math + +if {![llength [info commands ::lrepeat]]} { + # Forward portability, emulate lrepeat + proc ::lrepeat {n args} { + if {$n < 1} { + return -code error "must have a count of at least 1" + } + set res {} + while {$n} { + foreach x $args { lappend res $x } + incr n -1 + } + return $res + } +} + +# ::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 histogram-alt 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 \ + test-Duckworth + # + # 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 +# weights List of weights, one per value (optional) +# +# Results: +# List of number of values in each bucket (length is one more than +# the number of limits) +# +# +proc ::math::statistics::histogram { limits values {weights {}} } { + + if { [llength $limits] < 1 } { + return -code error -errorcode ARG -errorinfo {No limits given} {No limits given} + } + if { [llength $weights] > 0 && [llength $values] != [llength $weights] } { + return -code error -errorcode ARG -errorinfo {Number of weights be equal to number of values} {Weights and values differ in length} + } + + set limits [lsort -real -increasing $limits] + + for { set index 0 } { $index <= [llength $limits] } { incr index } { + set buckets($index) 0 + } + + set last [llength $limits] + + # Will do integer arithmetic if unset + if {$weights eq ""} { + set weights [lrepeat [llength $values] 1] + } + + foreach value $values weight $weights { + if { $value == {} } { + continue + } + + set index 0 + set found 0 + foreach limit $limits { + if { $value <= $limit } { + set found 1 + set buckets($index) [expr $buckets($index)+$weight] + break + } + incr index + } + + if { $found == 0 } { + set buckets($last) [expr $buckets($last)+$weight] + } + } + + set result {} + for { set index 0 } { $index <= $last } { incr index } { + lappend result $buckets($index) + } + + return $result +} + +# histogram-alt -- +# Return histogram information from a list of numbers - +# intervals are open-ended at the lower bound instead of at the upper bound +# +# Arguments: +# limits Upper limits for the buckets (in increasing order) +# values List of values to be examined +# weights List of weights, one per value (optional) +# +# Results: +# List of number of values in each bucket (length is one more than +# the number of limits) +# +# +proc ::math::statistics::histogram-alt { limits values {weights {}} } { + + if { [llength $limits] < 1 } { + return -code error -errorcode ARG -errorinfo {No limits given} {No limits given} + } + if { [llength $weights] > 0 && [llength $values] != [llength $weights] } { + return -code error -errorcode ARG -errorinfo {Number of weights be equal to number of values} {Weights and values differ in length} + } + + set limits [lsort -real -increasing $limits] + + for { set index 0 } { $index <= [llength $limits] } { incr index } { + set buckets($index) 0 + } + + set last [llength $limits] + + # Will do integer arithmetic if unset + if {$weights eq ""} { + set weights [lrepeat [llength $values] 1] + } + + foreach value $values weight $weights { + if { $value == {} } { + continue + } + + set index 0 + set found 0 + foreach limit $limits { + if { $value < $limit } { + set found 1 + set buckets($index) [expr $buckets($index)+$weight] + break + } + incr index + } + + if { $found == 0 } { + set buckets($last) [expr $buckets($last)+$weight] + } + } + + 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 +# significance Level at which the discrepancy from normality is tested +# +# Result: +# 1 if the Lilliefors statistic D is larger than the critical level +# +# Note: +# There was a mistake in the implementation before 0.9.3: confidence (wrong word) +# instead of significance. To keep compatibility with earlier versions, both +# significance and 1-significance are accepted. +# +proc ::math::statistics::test-normal {data significance} { + set D [lillieforsFit $data] + + if { $significance > 0.5 } { + set significance [expr {1.0-$significance}] ;# Convert the erroneous levels pre 0.9.3 + } + + set Dcrit -- + if { abs($significance-0.20) < 0.0001 } { + set Dcrit 0.741 + } + if { abs($significance-0.15) < 0.0001 } { + set Dcrit 0.775 + } + if { abs($significance-0.10) < 0.0001 } { + set Dcrit 0.819 + } + if { abs($significance-0.05) < 0.0001 } { + set Dcrit 0.895 + } + if { abs($significance-0.01) < 0.0001 } { + set Dcrit 1.035 + } + if { $Dcrit != "--" } { + return [expr {$D > $Dcrit ? 1 : 0 }] + } else { + return -code error "Significancce level must be one of: 0.20, 0.15, 0.10, 0.05 or 0.01" + } +} + +# t-test-mean -- +# Test whether the mean value of a sample is in accordance with the +# estimated normal distribution with a certain probability +# (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 +# alpha Probability 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 alpha } { + variable NEGSTDEV + variable TOOFEWDATA + + if { $est_stdev <= 0.0 } { + return -code error -errorcode ARG -errorinfo $NEGSTDEV $NEGSTDEV + } + + set allstats [BasicStats all $data] + + set alpha2 [expr {(1.0+$alpha)/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<$alpha2}] + + } 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 +} + +# test-Duckworth -- +# Determine if two data sets have the same median according to the Tukey-Duckworth test +# +# Arguments: +# list1 Values in the first data set +# list2 Values in the second data set +# significance Significance level (either 0.05, 0.01 or 0.001) +# +# Returns: +# 0 if the medians are unequal, 1 if they are equal, -1 if the test can not +# be conducted (the smallest value must be in a different set than the greatest value) +# +proc ::math::statistics::test-Duckworth {list1 list2 significance} { + set sorted1 [lsort -real $list1] + set sorted2 [lsort -real -decreasing $list2] + + set lowest1 [lindex $sorted1 0] + set lowest2 [lindex $sorted2 end] + set greatest1 [lindex $sorted1 end] + set greatest2 [lindex $sorted2 0] + + if { $lowest1 <= $lowest2 && $greatest1 >= $greatest2 } { + return -1 + } + if { $lowest1 >= $lowest2 && $greatest1 <= $greatest2 } { + return -1 + } + + # + # Determine how many elements of set 1 are lower than the lowest of set 2 + # Ditto for the number of elements of set 2 greater than the greatest of set 1 + # (Or vice versa) + # + if { $lowest1 < $lowest2 } { + set lowest $lowest2 + set greatest $greatest1 + } else { + set lowest $lowest1 + set greatest $greatest2 + set sorted1 [lsort -real $list2] + set sorted2 [lsort -real -decreasing $list1] + #lassign [list $sorted1 $sorted2] sorted2 sorted1 + } + + set count1 0 + set count2 0 + foreach v1 $sorted1 { + if { $v1 >= $lowest } { + break + } + incr count1 + } + foreach v2 $sorted2 { + if { $v2 <= $greatest } { + break + } + incr count2 + } + + # + # Determine the statistic D, possibly with correction + # + set n1 [llength $list1] + set n2 [llength $list2] + + set correction 0 + if { 3 + 4*$n1/3 <= $n2 && $n2 <= 2*$n1 } { + set correction -1 + } + if { 3 + 4*$n2/3 <= $n1 && $n1 <= 2*$n2 } { + set correction -1 + } + + set D [expr {$count1 + $count2 + $correction}] + + switch -- [string trim $significance 0] { + ".05" { + return [expr {$D >= 7? 0 : 1}] + } + ".01" { + return [expr {$D >= 10? 0 : 1}] + } + ".001" { + return [expr {$D >= 13? 0 : 1}] + } + default { + return -code error "Significance level must be 0.05, 0.01 or 0.001" + } + } +} + + +# +# 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] +source [file join [file dirname [info script]] stat_kernel.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" +} + diff --git a/tcllib/modules/math/statistics.test b/tcllib/modules/math/statistics.test new file mode 100755 index 0000000..11a8ba2 --- /dev/null +++ b/tcllib/modules/math/statistics.test @@ -0,0 +1,1043 @@ +# -*- 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} + +# +# Adding two dummy values should not influence the histogram (ticket 05d055c2f5) +# +test "Histogram-1.4" "Histogram - linear data 2 with weights" -match glob -body { + set values [::math::statistics::histogram {1.5 2.5 10.5} [concat $::data_linear 0.0 0.0] \ + [concat [lrepeat [llength $::data_linear] 1] 0 0]] +} -result {1 1 8 0} + +test "Histogram-1.5" "Histogram - linear data 2 with weights" -match glob -body { + set values [::math::statistics::histogram {1.5 2.5} [concat $::data_linear 0.0 0.0] \ + [concat [lrepeat [llength $::data_linear] 1] 0 0]] +} -result {1 1 8} + +# +# Alternative definition of the intervals (ticket 1502400fff) +# Note the difference in the expected bin sizes for the two +# +test "Histogram-2.1" "Histogram - alternative interval bounds" -match glob -body { + set values [concat [::math::statistics::histogram-alt {5.0 7.0} $::data_linear] \ + [::math::statistics::histogram {5.0 7.0} $::data_linear]] +} -result {4 2 4 5 2 3} + +# +# 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 - 20% significance" -match exact -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.20 +} -result 1 + +test "Testnormal-1.0" "Test birthweight data for normality - 5% significance" -match exact -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.05 +} -result 0 + +test "Test-Duckworth-1.0" "Test Tukey-Duckworth - 5% significance" -match exact -body { + set list1 {10 2 3 4 6} + set list2 {12 3 4 6} + + ::math::statistics::test-Duckworth $list1 $list2 0.05 +} -result 1 + +test "Test-Duckworth-1.1" "Test Tukey-Duckworth - symmetry" -match exact -body { + set list1 {1 2 3 4 5 6 7 8 9 10} + set list2 {6 7 8 9 10 11 12 13 14 15 16 17} + + set result [list [::math::statistics::test-Duckworth $list1 $list2 0.05] \ + [::math::statistics::test-Duckworth $list2 $list1 0.05]] +} -result {0 0} + +test "Test-Duckworth-1.2" "Test Tukey-Duckworth - applicability" -match exact -body { + set list1 {2 3 4 6 20} + set list2 {12 3 4 6} + + ::math::statistics::test-Duckworth $list1 $list2 0.05 +} -result -1 + +# +# 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. +# +# Note: cases with integer numbers test if divisions are done in floating-point or not +# + +test "uniform-distribution-1.0" "Test pdf-uniform" -match tolerant -body { + set x [list \ + [::math::statistics::pdf-uniform 0 10 5] \ + [::math::statistics::pdf-uniform 0.0 1.0 0.5] \ + [::math::statistics::pdf-uniform -10.0 1.0 -4.5] \ + [::math::statistics::pdf-uniform -2.0 2.0 1.0]] +} -result {0.1 1.0 0.0909090909 0.25} + +test "uniform-distribution-1.1" "Test cdf-uniform" -match tolerant -body { + set x [list \ + [::math::statistics::cdf-uniform 0 10 5] \ + [::math::statistics::cdf-uniform 0.0 1.0 0.5] \ + [::math::statistics::cdf-uniform -10.0 1.0 -4.5] \ + [::math::statistics::cdf-uniform -2.0 2.0 1.0]] +} -result {0.5 0.5 0.5 0.75} + +test "exponential-distribution-1.0" "Test pdf-exponential" -match tolerant -body { + set x [list \ + [::math::statistics::pdf-exponential 2 1] \ + [::math::statistics::pdf-exponential 1.0 1.0] \ + [::math::statistics::pdf-exponential 2.0 2.0] \ + [::math::statistics::pdf-exponential 2.0 1.0]] +} -result {0.3032653298563167 0.36787944117144233 0.18393972058572117 0.3032653298563167} + +test "exponential-distribution-1.1" "Test cdf-exponential" -match tolerant -body { + set x [list \ + [::math::statistics::cdf-exponential 2 1] \ + [::math::statistics::cdf-exponential 1.0 1.0] \ + [::math::statistics::cdf-exponential 2.0 2.0] \ + [::math::statistics::cdf-exponential 2.0 1.0]] +} -result {0.3934693402873666 0.6321205588285577 0.6321205588285577 0.3934693402873666} + +test "normal-distribution-1.0" "Test pdf-normal" -match tolerant -body { + set x [list \ + [::math::statistics::pdf-normal 0 1 1] \ + [::math::statistics::pdf-normal 0.0 1.0 1.0] \ + [::math::statistics::pdf-normal 2.0 2.0 4.0] \ + [::math::statistics::pdf-normal -2.0 2.0 0.0] \ + [::math::statistics::pdf-normal 2.0 2.0 3.0]] +} -result {0.24197072451914337 0.24197072451914337 0.12098536225957168 0.12098536225957168 0.17603266338214976} + +test "normal-distribution-1.1" "Test cdf-normal" -match tolerant -body { + set x [list \ + [::math::statistics::cdf-normal 0 1 1] \ + [::math::statistics::cdf-normal 0.0 1.0 1.0] \ + [::math::statistics::cdf-normal 2.0 2.0 4.0] \ + [::math::statistics::cdf-normal -2.0 2.0 0.0] \ + [::math::statistics::cdf-normal 2.0 2.0 3.0]] +} -result {0.8413205502059895 0.8413205502059895 0.8413205502059895 0.8413205502059895 0.691451459572962} + +test "lognormal-distribution-1.0" "Test pdf-lognormal" -match tolerant -body { + foreach {mu sigma mean stdev} {0.0 1.0 mean1 stdev1 2.0 2.0 mean2 stdev2 -2.0 2.0 mean3 stdev3} { + set m [expr {exp($mu + $sigma*$sigma/2.0)}] + set $mean $m + set $stdev [expr {(exp($sigma*$sigma) - 1.0) * $m*$m}] + } + + set x [list \ + [::math::statistics::pdf-lognormal $mean1 $stdev1 [expr {exp(1.0)}]] \ + [::math::statistics::pdf-lognormal $mean2 $stdev2 [expr {exp(4.0)}]] \ + [::math::statistics::pdf-lognormal $mean3 $stdev3 [expr {exp(0.0)}]] \ + [::math::statistics::pdf-lognormal $mean2 $stdev2 [expr {exp(3.0)}]]] +} -result {0.24197072451914337 0.12098536225957168 0.12098536225957168 0.17603266338214976} + +test "lognormal-distribution-1.1" "Test cdf-lognormal" -match tolerant -body { + foreach {mu sigma mean stdev} {0.0 1.0 mean1 stdev1 2.0 2.0 mean2 stdev2 -2.0 2.0 mean3 stdev3} { + set m [expr {exp($mu + $sigma*$sigma/2.0)}] + set $mean $m + set $stdev [expr {(exp($sigma*$sigma) - 1.0) * $m*$m}] + } + + set x [list \ + [::math::statistics::cdf-lognormal $mean1 $stdev1 [expr {exp(1.0)}]] \ + [::math::statistics::cdf-lognormal $mean2 $stdev2 [expr {exp(4.0)}]] \ + [::math::statistics::cdf-lognormal $mean3 $stdev3 [expr {exp(0.0)}]] \ + [::math::statistics::cdf-lognormal $mean2 $stdev2 [expr {exp(3.0)}]]] +} -result {0.8413205502059895 0.8413205502059895 0.8413205502059895 0.691451459572962} + +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} + +# +# TODO: chose the tests with _integer_ arguments more carefully +# +test "gumbel-distribution-1.0" "Test pdf-gumbel" -match tolerant -body { + set x [list \ + [::math::statistics::pdf-gumbel 1.0 1.0 0.0] \ + [::math::statistics::pdf-gumbel 1.0 1.0 0.1] \ + [::math::statistics::pdf-gumbel 1.0 1.0 0.2] \ + [::math::statistics::pdf-gumbel 1.0 1.0 1.0] \ + [::math::statistics::pdf-gumbel 1.0 1.0 2.0] \ + [::math::statistics::pdf-gumbel 1.0 1.0 5.0] \ + [::math::statistics::pdf-gumbel 0.1 2.0 0.0] \ + [::math::statistics::pdf-gumbel 0.1 2.0 1.0] \ + [::math::statistics::pdf-gumbel 0.1 2.0 2.0] \ + [::math::statistics::pdf-gumbel 0.1 2.0 5.0] \ + [::math::statistics::pdf-gumbel 1 1 5 ] ] +} -result {0.179374 0.210219 0.240378 0.367879 0.254646 0.017983 0.183706 0.168507 0.131350 0.039580 0.017983} + +test "gumbel-distribution-1.1" "Test cdf-gumbel" -match tolerant -body { + set x [list \ + [::math::statistics::cdf-gumbel 1.0 1.0 0.0] \ + [::math::statistics::cdf-gumbel 1.0 1.0 0.2] \ + [::math::statistics::cdf-gumbel 1.0 1.0 1.0] \ + [::math::statistics::cdf-gumbel 1.0 1.0 2.0] \ + [::math::statistics::cdf-gumbel 0.1 2.0 0.0] \ + [::math::statistics::cdf-gumbel 0.1 2.0 1.0] \ + [::math::statistics::cdf-gumbel 0.1 2.0 2.0] \ + [::math::statistics::cdf-gumbel 1 1 2 ] ] +} -result {0.065988 0.108009 0.367879 0.692201 0.349493 0.528544 0.679266 0.692201} + +test "weibull-distribution-1.0" "Test pdf-weibull" -match tolerant -body { + set x [list \ + [::math::statistics::pdf-weibull 1.0 1.0 -1.0] \ + [::math::statistics::pdf-weibull 1.0 1.0 0.0] \ + [::math::statistics::pdf-weibull 1.0 1.0 0.1] \ + [::math::statistics::pdf-weibull 1.0 1.0 0.2] \ + [::math::statistics::pdf-weibull 1.0 1.0 1.0] \ + [::math::statistics::pdf-weibull 1.0 1.0 2.0] \ + [::math::statistics::pdf-weibull 1.0 1.0 5.0] \ + [::math::statistics::pdf-weibull 2.0 2.0 0.0] \ + [::math::statistics::pdf-weibull 2.0 2.0 1.0] \ + [::math::statistics::pdf-weibull 2.0 2.0 2.0] \ + [::math::statistics::pdf-weibull 2.0 2.0 5.0] ] +} -result {0 1.0 0.904837 0.818730 0.367879 0.135335 0.006738 0 0.389400 0.367879 0.004826} + +test "weibull-distribution-1.1" "Test cdf-weibull" -match tolerant -body { + set x [list \ + [::math::statistics::cdf-weibull 1.0 1.0 -1.0] \ + [::math::statistics::cdf-weibull 1.0 1.0 0.0] \ + [::math::statistics::cdf-weibull 1.0 1.0 0.2] \ + [::math::statistics::cdf-weibull 1.0 1.0 1.0] \ + [::math::statistics::cdf-weibull 1.0 1.0 2.0] \ + [::math::statistics::cdf-weibull 2.0 2.0 0.0] \ + [::math::statistics::cdf-weibull 2.0 2.0 1.0] \ + [::math::statistics::cdf-weibull 2.0 2.0 2.0] \ + [::math::statistics::cdf-weibull 2 2 2 ] ] +} -result {0 0 0.181269 0.632106 0.864665 0 0.221199 0.632121 0.632121} + +test "pareto-distribution-1.0" "Test pdf-pareto" -match tolerant -body { + set x [list \ + [::math::statistics::pdf-pareto 1.0 1.0 0.0] \ + [::math::statistics::pdf-pareto 1.0 1.0 1.1] \ + [::math::statistics::pdf-pareto 1.0 1.0 1.2] \ + [::math::statistics::pdf-pareto 1.0 1.0 2.0] \ + [::math::statistics::pdf-pareto 1.0 1.0 3.0] \ + [::math::statistics::pdf-pareto 1.0 1.0 5.0] \ + [::math::statistics::pdf-pareto 2.0 2.0 2.1] \ + [::math::statistics::pdf-pareto 2.0 2.0 3.0] \ + [::math::statistics::pdf-pareto 2.0 2.0 5.0] \ + [::math::statistics::pdf-pareto 2.0 2.0 10.0] ] +} -result {0 0.826446 0.694444 0.25 0.111111 0.04 0.863838 0.296296 0.064 0.008} + +test "pareto-distribution-1.1" "Test cdf-pareto" -match tolerant -body { + set x [list \ + [::math::statistics::cdf-pareto 1.0 1.0 0.0] \ + [::math::statistics::cdf-pareto 1.0 1.0 1.1] \ + [::math::statistics::cdf-pareto 1.0 1.0 1.2] \ + [::math::statistics::cdf-pareto 1.0 1.0 2.0] \ + [::math::statistics::cdf-pareto 1.0 1.0 3.0] \ + [::math::statistics::cdf-pareto 2.0 2.0 2.1] \ + [::math::statistics::cdf-pareto 2.0 2.0 3.0] \ + [::math::statistics::cdf-pareto 2.0 2.0 5.0] \ + [::math::statistics::cdf-pareto 2 2 3 ] ] +} -result {0 0.090909 0.1666667 0.5 0.666667 0.092971 0.555556 0.84 0.555556} + +test "cauchy-distribution-1.0" "Test pdf-cauchy" -match tolerant -body { + set x [list \ + [::math::statistics::pdf-cauchy 1.0 1.0 0.0] \ + [::math::statistics::pdf-cauchy 2.0 1.0 1.0] \ + [::math::statistics::pdf-cauchy 1.0 2.0 2.0] \ + [::math::statistics::pdf-cauchy 2.0 2.0 2.0] ] +} -result {0.1591555 0.1591555 0.1273240 0.1591550} + +test "cauchy-distribution-1.1" "Test cdf-cauchy" -match tolerant -body { + set x [list \ + [::math::statistics::cdf-cauchy 1.0 1.0 0.0] \ + [::math::statistics::cdf-cauchy 2.0 1.0 1.0] \ + [::math::statistics::cdf-cauchy 1.0 2.0 2.0] \ + [::math::statistics::cdf-cauchy 2.0 2.0 2.0] ] +} -result {0.25 0.25 0.6475836 0.5} + +test "empirical-distribution-1.0" "Test empirical-distribution" -match tolerant -body { + set x {10 4 3 2 5 6 7} + set distribution [::math::statistics::empirical-distribution $x] +} -result {2 0.086207 3 0.224138 4 0.36207 5 0.5 6 0.637910 7 0.775862 10 0.913793} + +# +# Crude tests for the random number generators +# Mainly to verify that there are no obvious errors +# +# To verify that the values are scaled properly, use a fixed seed +# +set ::rseed 1000000 + +test "random-numbers-1.0" "Test random-uniform" -body { + expr {srand($::rseed)} + + set rnumbers [::math::statistics::random-uniform 0 10 100] + + set inrange 1 + foreach r $rnumbers { + if { $r < 0.0 || $r > 10.0 } { + set inrange 0 + break + } + } + + expr {srand($::rseed)} + set scaled 1 + set rnumbers2 [::math::statistics::random-uniform 0 20 100] + foreach r1 $rnumbers r2 $rnumbers2 { + set scale [expr {$r2 / $r1}] + if { abs($scale - 2.0) > 0.00001 } { + set scaled 0 + } + } + expr {srand($::rseed)} + set shifted 1 + set rnumbers3 [::math::statistics::random-uniform 10 20 100] + foreach r1 $rnumbers r3 $rnumbers3 { + set shift [expr {$r3 - $r1}] + if { abs($shift - 10.0) > 0.00001 } { + set shifted 0 + } + } + + set result [list $inrange [llength $rnumbers] $scaled $shifted] +} -result {1 100 1 1} + +test "random-numbers-1.1" "Test random-exponential" -body { + expr {srand($::rseed)} + set rnumbers [::math::statistics::random-exponential 1 100] + + set inrange 1 + foreach r $rnumbers { + if { $r < 0.0 } { + set inrange 0 + break + } + } + + expr {srand($::rseed)} + set scaled 1 + set rnumbers2 [::math::statistics::random-exponential 2 100] + foreach r1 $rnumbers r2 $rnumbers2 { + set scale [expr {$r2 / $r1}] + if { abs($scale - 2.0) > 0.00001 } { + set scaled 0 + } + } + set result [list $inrange [llength $rnumbers] $scaled] +} -result {1 100 1} + +test "random-numbers-1.2" "Test random-normal" -body { + set rnumbers [::math::statistics::random-normal 0 1 100] + set result [llength $rnumbers] +} -result 100 + +test "random-numbers-1.3" "Test random-gamma" -body { + set rnumbers [::math::statistics::random-gamma 1.5 2.7 100] + set result [llength $rnumbers] +} -result 100 + +test "random-numbers-1.4" "Test random-poisson" -body { + set rnumbers [::math::statistics::random-poisson 2.5 100] + set result [llength $rnumbers] +} -result 100 + +test "random-numbers-1.5" "Test random-chisquare" -body { + set rnumbers [::math::statistics::random-chisquare 3 100] + set result [llength $rnumbers] +} -result 100 + +test "random-numbers-1.6" "Test random-students-t" -body { + set rnumbers [::math::statistics::random-students-t 3 100] + set result [llength $rnumbers] +} -result 100 + +test "random-numbers-1.7" "Test random-beta" -body { + set rnumbers [::math::statistics::random-beta 1.3 2.4 100] + set result 1 + foreach r $rnumbers { + if { $r < 0.0 || $r > 1.0 } { + result 0 + break + } + } + lappend result [llength $rnumbers] +} -result {1 100} + +test "random-numbers-1.8" "Test random-gumbel" -body { + set rnumbers [::math::statistics::random-gumbel 1.0 3.0 100] + set result [llength $rnumbers] +} -result 100 + +test "random-numbers-1.9" "Test random-weibull" -body { + set rnumbers [::math::statistics::random-weibull 1.0 3.0 100] + set result [llength $rnumbers] +} -result 100 + +test "random-numbers-1.10" "Test random-pareto" -body { + set rnumbers [::math::statistics::random-pareto 1.0 3.0 100] + set result 1 + foreach r $rnumbers { + if { $r < 1.0 } { + result 0 + break + } + } + lappend result [llength $rnumbers] +} -result {1 100} + +test "random-numbers-1.11" "Test random-lognormal" -body { + set rnumbers [::math::statistics::random-lognormal 1 1 100] + set result [llength $rnumbers] +} -result 100 + +test "random-numbers-1.11" "Test random-cauchy" -body { + set rnumbers [::math::statistics::random-cauchy 0 1 100] + set result [llength $rnumbers] +} -result 100 + +test "random-numbers-2.1" "Test estimate-pareto" -match tolerant -body { + expr {srand($::rseed)} + set rnumbers [::math::statistics::random-pareto 1.0 3.0 100] + set result [::math::statistics::estimate-pareto $rnumbers] +} -result {1.000519 3.668162 0.3668162} + +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} + +# +# Note: for the uniform and the logistic kernel the sum deviates more from 1 than for the others. +# For the logistic kernel this is because the density function is very widespread. For the +# uniform kernel the reason is not quite clear. Hence the margin per kernel. +# +test "kernel-density-1.0" "Test various kernel functions" -body { + set data {1 2 3 4 5 6 7 8 9 10} + + set roughlyOne {} + + foreach kernel {gaussian uniform triangular epanechnikov biweight cosine logistic} \ + margin {0.01 0.02 0.01 0.01 0.01 0.01 0.05 } { + set result [::math::statistics::kernel-density $data -kernel $kernel] + + set sum 0.0 + set xbegin [lindex $result 2 0] + set xend [lindex $result 2 1] + set number [llength [lindex $result 0]] + set dx [expr {($xend-$xbegin) / $number}] + + # + # Integral should be roughly one + # + set sum 0.0 + foreach v [lindex $result 1] { + set sum [expr {$sum + $dx * $v}] + } + + lappend roughlyOne [expr {abs($sum-1.0) < $margin}] + } + + return $roughlyOne +} -result {1 1 1 1 1 1 1} + +test "kernel-density-1.1" "Test various options - just that they have effect" -body { + set subResults {} + + set data {1 2 3 4 5 6 7 8 9 10} + + set result [::math::statistics::kernel-density $data -number 20] + lappend subResults [llength [lindex $result 0]] ;# Number of bins + lappend subResults [llength [lindex $result 1]] ;# Number of density values + + set result [::math::statistics::kernel-density $data -interval {0 20}] + lappend subResults [lindex $result 2 0] ;# Beginning of interval + lappend subResults [lindex $result 2 1] ;# End of interval + lappend subResults [expr {[lindex $result 0 0] > [lindex $result 2 0]}] ;# First bin -- beginning of interval + lappend subResults [expr {[lindex $result 0 0] < [lindex $result 2 1]}] ;# First bin -- end of interval + lappend subResults [expr {[lindex $result 0 end] > [lindex $result 2 0]}] ;# Last bin -- beginning of interval + lappend subResults [expr {[lindex $result 0 end] < [lindex $result 2 1]}] ;# Last bin -- end of interval + + set result [::math::statistics::kernel-density $data -bandwidth 2] + lappend subResults [lindex $result 2 end] ;# Bandwidth + + return $subResults +} -result {20 20 0 20 1 1 1 1 2} + +test "kernel-density-1.2" "Dealing with missing values" -body { + set subResults {} + + set data {1 2 3 4 {} 6 7 8 9 10} + + set result [::math::statistics::kernel-density $data] + + set sum 0.0 + set xbegin [lindex $result 2 0] + set xend [lindex $result 2 1] + set number [llength [lindex $result 0]] + set dx [expr {($xend-$xbegin) / $number}] + + # + # Integral should be roughly one + # + set sum 0.0 + foreach v [lindex $result 1] { + set sum [expr {$sum + $dx * $v}] + } + + return [expr {abs($sum-1.0) < 0.01}] +} -result 1 + +# End of test cases +testsuiteCleanup diff --git a/tcllib/modules/math/symdiff.man b/tcllib/modules/math/symdiff.man new file mode 100644 index 0000000..7cc06fd --- /dev/null +++ b/tcllib/modules/math/symdiff.man @@ -0,0 +1,72 @@ +[vset VERSION 1.0.1] +[manpage_begin math::calculus::symdiff n [vset VERSION]] +[see_also math::calculus] +[see_also math::interpolate] +[copyright "2010 by Kevin B. Kenny <kennykb@acm.org> +Redistribution permitted under the terms of the Open\ +Publication License <http://www.opencontent.org/openpub/>"] +[moddesc "Symbolic differentiation for Tcl"] +[titledesc "Symbolic differentiation for Tcl"] +[require Tcl 8.5] +[require grammar::aycock 1.0] +[require math::calculus::symdiff [vset VERSION]] +[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}} +}] + +[vset CATEGORY {math :: calculus}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/math/symdiff.tcl b/tcllib/modules/math/symdiff.tcl new file mode 100644 index 0000000..79eeb54 --- /dev/null +++ b/tcllib/modules/math/symdiff.tcl @@ -0,0 +1,1229 @@ +# 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.1 + +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 diff --git a/tcllib/modules/math/symdiff.test b/tcllib/modules/math/symdiff.test new file mode 100644 index 0000000..bf35cb8 --- /dev/null +++ b/tcllib/modules/math/symdiff.test @@ -0,0 +1,458 @@ +# 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 {invalid character*} +} + +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 {invalid character*} +} + +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: diff --git a/tcllib/modules/math/tclIndex b/tcllib/modules/math/tclIndex new file mode 100644 index 0000000..49f0bd1 --- /dev/null +++ b/tcllib/modules/math/tclIndex @@ -0,0 +1,26 @@ +# 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]] diff --git a/tcllib/modules/math/wilcoxon.tcl b/tcllib/modules/math/wilcoxon.tcl new file mode 100755 index 0000000..deab070 --- /dev/null +++ b/tcllib/modules/math/wilcoxon.tcl @@ -0,0 +1,228 @@ +# statistics_new.tcl -- +# Implementation of the Wilcoxon test: test if the medians +# of two samples are the same +# + +# 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] +} |