From 07fc041d7bc0793318dd31ebef6ab2da9bcb3fe2 Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Mon, 5 Dec 2022 02:14:51 -0500 Subject: Vendor tcllib linear algebra --- pi/Display.tcl | 1 + vendor/math/ChangeLog | 1689 +++++++++++++++ vendor/math/TODO | 239 +++ vendor/math/bessel.tcl | 194 ++ vendor/math/bessel.test | 81 + vendor/math/bigfloat.man | 433 ++++ vendor/math/bigfloat.tcl | 2316 ++++++++++++++++++++ vendor/math/bigfloat.test | 705 +++++++ vendor/math/bigfloat2.tcl | 2224 ++++++++++++++++++++ vendor/math/bigfloat2.test | 666 ++++++ vendor/math/bignum.man | 228 ++ vendor/math/bignum.tcl | 900 ++++++++ vendor/math/bignum.test | 587 ++++++ vendor/math/calculus.CHANGES | 21 + vendor/math/calculus.README | 21 + vendor/math/calculus.doc | 311 +++ vendor/math/calculus.man | 551 +++++ vendor/math/calculus.tcl | 1650 +++++++++++++++ vendor/math/calculus.test | 734 +++++++ vendor/math/calculus.testscript | 86 + vendor/math/changepoint.man | 123 ++ vendor/math/changepoint.tcl | 311 +++ vendor/math/changepoint.test | 105 + vendor/math/classic_polyns.tcl | 200 ++ vendor/math/combinatorics.man | 275 +++ vendor/math/combinatorics.tcl | 443 ++++ vendor/math/combinatorics.test | 323 +++ vendor/math/combinatoricsExt.tcl | 825 ++++++++ vendor/math/combinatoricsExt.test | 444 ++++ vendor/math/constants.man | 136 ++ vendor/math/constants.tcl | 205 ++ vendor/math/constants.test | 56 + vendor/math/decimal.man | 199 ++ vendor/math/decimal.tcl | 1742 ++++++++++++++++ vendor/math/decimal.test | 51 + vendor/math/elliptic.tcl | 242 +++ vendor/math/elliptic.test | 140 ++ vendor/math/exact.man | 219 ++ vendor/math/exact.tcl | 4060 ++++++++++++++++++++++++++++++++++++ vendor/math/exact.test | 2255 ++++++++++++++++++++ vendor/math/exponential.tcl | 434 ++++ vendor/math/figurate.man | 373 ++++ vendor/math/figurate.tcl | 294 +++ vendor/math/figurate.test | 563 +++++ vendor/math/filtergen.man | 81 + vendor/math/filtergen.tcl | 250 +++ vendor/math/filtergen.test | 125 ++ vendor/math/fourier.man | 134 ++ vendor/math/fourier.tcl | 376 ++++ vendor/math/fourier.test | 135 ++ vendor/math/fuzzy.eps.f90 | 170 ++ vendor/math/fuzzy.man | 133 ++ vendor/math/fuzzy.tcl | 173 ++ vendor/math/fuzzy.test | 387 ++++ vendor/math/fuzzy.testscript | 21 + vendor/math/geometry.tcl | 1572 ++++++++++++++ vendor/math/geometry.test | 1054 ++++++++++ vendor/math/geometry_circle.tcl | 382 ++++ vendor/math/geometry_ext.tcl | 1023 +++++++++ vendor/math/interpolate.man | 299 +++ vendor/math/interpolate.tcl | 667 ++++++ vendor/math/interpolate.test | 374 ++++ vendor/math/kruskal.tcl | 154 ++ vendor/math/linalg.man | 968 +++++++++ vendor/math/linalg.tcl | 2299 ++++++++++++++++++++ vendor/math/linalg.test | 937 +++++++++ vendor/math/liststat.tcl | 95 + vendor/math/machineparameters.man | 191 ++ vendor/math/machineparameters.tcl | 378 ++++ vendor/math/machineparameters.test | 52 + vendor/math/math.man | 126 ++ vendor/math/math.tcl | 44 + vendor/math/math.test | 279 +++ vendor/math/math_geometry.man | 818 ++++++++ vendor/math/misc.tcl | 385 ++++ vendor/math/mvlinreg.tcl | 265 +++ vendor/math/numtheory.dtx | 1832 ++++++++++++++++ vendor/math/numtheory.man | 231 ++ vendor/math/numtheory.stitch | 24 + vendor/math/numtheory.tcl | 82 + vendor/math/numtheory.test | 240 +++ vendor/math/optimize.man | 325 +++ vendor/math/optimize.tcl | 1319 ++++++++++++ vendor/math/optimize.test | 634 ++++++ vendor/math/pca.man | 136 ++ vendor/math/pca.tcl | 402 ++++ vendor/math/pca.test | 288 +++ vendor/math/pdf_stat.tcl | 2676 ++++++++++++++++++++++++ vendor/math/pkgIndex.tcl | 42 + vendor/math/plotstat.tcl | 312 +++ vendor/math/polynomials.man | 219 ++ vendor/math/polynomials.tcl | 560 +++++ vendor/math/polynomials.test | 260 +++ vendor/math/primes.tcl | 569 +++++ vendor/math/primes.test | 231 ++ vendor/math/probopt.man | 226 ++ vendor/math/probopt.tcl | 19 + vendor/math/probopt.test | 315 +++ vendor/math/probopt_diffev.tcl | 275 +++ vendor/math/probopt_lipo.tcl | 241 +++ vendor/math/probopt_pso.tcl | 427 ++++ vendor/math/probopt_sce.tcl | 378 ++++ vendor/math/qcomplex.man | 302 +++ vendor/math/qcomplex.tcl | 178 ++ vendor/math/qcomplex.test | 250 +++ vendor/math/quasirandom.man | 118 ++ vendor/math/quasirandom.tcl | 517 +++++ vendor/math/quasirandom.test | 498 +++++ vendor/math/rational_funcs.man | 186 ++ vendor/math/rational_funcs.tcl | 364 ++++ vendor/math/roman.man | 51 + vendor/math/roman.test | 223 ++ vendor/math/romannumerals.tcl | 164 ++ vendor/math/romberg.man | 340 +++ vendor/math/rootfind.tcl | 343 +++ vendor/math/special.man | 531 +++++ vendor/math/special.tcl | 463 ++++ vendor/math/special.test | 239 +++ vendor/math/stat_kernel.tcl | 217 ++ vendor/math/stat_logit.tcl | 120 ++ vendor/math/stat_wasserstein.tcl | 214 ++ vendor/math/statistics.man | 1867 +++++++++++++++++ vendor/math/statistics.tcl | 2037 ++++++++++++++++++ vendor/math/statistics.test | 1560 ++++++++++++++ vendor/math/symdiff.man | 72 + vendor/math/symdiff.tcl | 1229 +++++++++++ vendor/math/symdiff.test | 458 ++++ vendor/math/tclIndex | 26 + vendor/math/trig.man | 195 ++ vendor/math/trig.tcl | 290 +++ vendor/math/trig.test | 369 ++++ vendor/math/wilcoxon.tcl | 338 +++ 132 files changed, 68024 insertions(+) create mode 100644 vendor/math/ChangeLog create mode 100644 vendor/math/TODO create mode 100644 vendor/math/bessel.tcl create mode 100644 vendor/math/bessel.test create mode 100644 vendor/math/bigfloat.man create mode 100644 vendor/math/bigfloat.tcl create mode 100644 vendor/math/bigfloat.test create mode 100644 vendor/math/bigfloat2.tcl create mode 100644 vendor/math/bigfloat2.test create mode 100644 vendor/math/bignum.man create mode 100644 vendor/math/bignum.tcl create mode 100644 vendor/math/bignum.test create mode 100644 vendor/math/calculus.CHANGES create mode 100644 vendor/math/calculus.README create mode 100644 vendor/math/calculus.doc create mode 100644 vendor/math/calculus.man create mode 100644 vendor/math/calculus.tcl create mode 100644 vendor/math/calculus.test create mode 100644 vendor/math/calculus.testscript create mode 100644 vendor/math/changepoint.man create mode 100644 vendor/math/changepoint.tcl create mode 100644 vendor/math/changepoint.test create mode 100644 vendor/math/classic_polyns.tcl create mode 100644 vendor/math/combinatorics.man create mode 100644 vendor/math/combinatorics.tcl create mode 100644 vendor/math/combinatorics.test create mode 100644 vendor/math/combinatoricsExt.tcl create mode 100644 vendor/math/combinatoricsExt.test create mode 100644 vendor/math/constants.man create mode 100644 vendor/math/constants.tcl create mode 100644 vendor/math/constants.test create mode 100644 vendor/math/decimal.man create mode 100644 vendor/math/decimal.tcl create mode 100644 vendor/math/decimal.test create mode 100644 vendor/math/elliptic.tcl create mode 100644 vendor/math/elliptic.test create mode 100644 vendor/math/exact.man create mode 100644 vendor/math/exact.tcl create mode 100644 vendor/math/exact.test create mode 100644 vendor/math/exponential.tcl create mode 100644 vendor/math/figurate.man create mode 100644 vendor/math/figurate.tcl create mode 100644 vendor/math/figurate.test create mode 100644 vendor/math/filtergen.man create mode 100644 vendor/math/filtergen.tcl create mode 100644 vendor/math/filtergen.test create mode 100644 vendor/math/fourier.man create mode 100644 vendor/math/fourier.tcl create mode 100644 vendor/math/fourier.test create mode 100644 vendor/math/fuzzy.eps.f90 create mode 100644 vendor/math/fuzzy.man create mode 100644 vendor/math/fuzzy.tcl create mode 100644 vendor/math/fuzzy.test create mode 100644 vendor/math/fuzzy.testscript create mode 100644 vendor/math/geometry.tcl create mode 100644 vendor/math/geometry.test create mode 100644 vendor/math/geometry_circle.tcl create mode 100644 vendor/math/geometry_ext.tcl create mode 100644 vendor/math/interpolate.man create mode 100644 vendor/math/interpolate.tcl create mode 100644 vendor/math/interpolate.test create mode 100644 vendor/math/kruskal.tcl create mode 100644 vendor/math/linalg.man create mode 100644 vendor/math/linalg.tcl create mode 100644 vendor/math/linalg.test create mode 100644 vendor/math/liststat.tcl create mode 100644 vendor/math/machineparameters.man create mode 100644 vendor/math/machineparameters.tcl create mode 100644 vendor/math/machineparameters.test create mode 100644 vendor/math/math.man create mode 100644 vendor/math/math.tcl create mode 100644 vendor/math/math.test create mode 100644 vendor/math/math_geometry.man create mode 100644 vendor/math/misc.tcl create mode 100644 vendor/math/mvlinreg.tcl create mode 100644 vendor/math/numtheory.dtx create mode 100644 vendor/math/numtheory.man create mode 100644 vendor/math/numtheory.stitch create mode 100644 vendor/math/numtheory.tcl create mode 100644 vendor/math/numtheory.test create mode 100644 vendor/math/optimize.man create mode 100644 vendor/math/optimize.tcl create mode 100644 vendor/math/optimize.test create mode 100644 vendor/math/pca.man create mode 100644 vendor/math/pca.tcl create mode 100644 vendor/math/pca.test create mode 100644 vendor/math/pdf_stat.tcl create mode 100644 vendor/math/pkgIndex.tcl create mode 100644 vendor/math/plotstat.tcl create mode 100644 vendor/math/polynomials.man create mode 100644 vendor/math/polynomials.tcl create mode 100644 vendor/math/polynomials.test create mode 100644 vendor/math/primes.tcl create mode 100644 vendor/math/primes.test create mode 100644 vendor/math/probopt.man create mode 100644 vendor/math/probopt.tcl create mode 100644 vendor/math/probopt.test create mode 100644 vendor/math/probopt_diffev.tcl create mode 100644 vendor/math/probopt_lipo.tcl create mode 100644 vendor/math/probopt_pso.tcl create mode 100644 vendor/math/probopt_sce.tcl create mode 100644 vendor/math/qcomplex.man create mode 100644 vendor/math/qcomplex.tcl create mode 100644 vendor/math/qcomplex.test create mode 100644 vendor/math/quasirandom.man create mode 100644 vendor/math/quasirandom.tcl create mode 100644 vendor/math/quasirandom.test create mode 100644 vendor/math/rational_funcs.man create mode 100644 vendor/math/rational_funcs.tcl create mode 100644 vendor/math/roman.man create mode 100644 vendor/math/roman.test create mode 100644 vendor/math/romannumerals.tcl create mode 100644 vendor/math/romberg.man create mode 100644 vendor/math/rootfind.tcl create mode 100644 vendor/math/special.man create mode 100644 vendor/math/special.tcl create mode 100644 vendor/math/special.test create mode 100644 vendor/math/stat_kernel.tcl create mode 100644 vendor/math/stat_logit.tcl create mode 100644 vendor/math/stat_wasserstein.tcl create mode 100644 vendor/math/statistics.man create mode 100644 vendor/math/statistics.tcl create mode 100644 vendor/math/statistics.test create mode 100644 vendor/math/symdiff.man create mode 100644 vendor/math/symdiff.tcl create mode 100644 vendor/math/symdiff.test create mode 100644 vendor/math/tclIndex create mode 100644 vendor/math/trig.man create mode 100644 vendor/math/trig.tcl create mode 100644 vendor/math/trig.test create mode 100644 vendor/math/wilcoxon.tcl diff --git a/pi/Display.tcl b/pi/Display.tcl index 3443f7e5..ee00542a 100644 --- a/pi/Display.tcl +++ b/pi/Display.tcl @@ -227,6 +227,7 @@ namespace eval Display { variable fb + lappend auto_path "./vendor" package require math::linearalgebra # functions diff --git a/vendor/math/ChangeLog b/vendor/math/ChangeLog new file mode 100644 index 00000000..9bb8b10a --- /dev/null +++ b/vendor/math/ChangeLog @@ -0,0 +1,1689 @@ +2022-06-05 Arjen Markus + * rootfind.tcl: New file containing the new root-findng procedures + * calculus.tcl: Add a "source" command for rootfind.tcl, bump version to 1.0 + * calculus.test: Add tests for the root-finding procedures + * calculus.man: Description of the root-finding procedures + * pkgIndex.tcl: Bump version to 1.0 + +2022-04-26 Arjen Markus + * figurate.tcl: Correct the implementation of various procedures (note: consistent handling of "no objects") + * figurate.test: Correct the test cases + * figurate.man: Add note about zero or less objects + +2021-10-31 Arjen Markus + * figurate.tcl: Evaluate various "figurate" numbers (new package, ticket f8adb7a036) + * figurate.test: Corresponding tests + * figurate.man: Description of the figurate procedures + * pkgIndex.tcl: Added the new package + +2021-05-29 Arjen Markus + * elliptic.tcl: Correct the implementation of "dn" (ticket 828109660d) + * elliptic.test: Add proper tests for sn, cn and dn + * special.tcl: Update the version to 0.5.2 + * pkgIndex.tcl: Updated the version of math::special to 0.5.2 + +2021-05-06 Arjen Markus + * elliptic.tcl: Correct the name of "dn" (ticket f46d2826b59f540296e76586570c86d07a4a5cec) + * special.tcl: Changed version of math::special to 0.5.1 + * pkgIndex.tcl: Changed version of math::special to 0.5.1 + +2021-03-14 Arjen Markus + * decimal.tcl: Apply patch for fromstr, version 1.0.4 (ticket d159e101f329682a232aabac36c0ef6640ff8484) + * decimal.test: Added test for this ticket + * primes.tcl: Added procedures for returning pairs and lists of primes (ticket 0ce5a9fc98f7c752d4dabc0911dccfb513686ad2) + * primes.test: Added tests for the new procedures + * numtheory.man: Description of the new procedures + * numtheory.tcl: Updated version to 1.1.3 + * pkgIndex.tcl: Updated the version for math::decimal and math::numtheory + * fourier.man: Updated the introduction as per ticket 2695827 + +2021-03-07 Arjen Markus + * various man files: Require Tcl 8.6 and TclOO + +2021-01-31 Arjen Markus + * combinatoricsExt.tcl: Extension of the collection of combinatorial procedures + * combinatoricsExt.test: Tests for the new procedures + * combinatorics.man: Description of the new procedures + * pkgIndex.tcl: Added the package math::combinatorics + +2021-01-03 Arjen Markus + * changepoint.tcl: New package defining two change point detection algorithms + * changepoint.test: Basic tests for the change point detection algorithms + * changepoint.man: Description of the change point detection procedures + * pkgIndex.tcl: Added the changepoint package + +2021-01-01 Arjen Markus + * probopt.tcl: New package defining a number of probabilistic optimisation algorithms + * probopt_*.tcl: Individual source files for these algorithms + * probopt.test: Tests for the probabilistic algorithms + * probopt.man: Description of the algorithms (including references describing the backgrounds) + * filtergen.tcl: Correct a small mistake (loop over data) + * filtergen.test: Correct tests (several small mistakes) + +2020-12-20 Arjen Markus + * filtergen.tcl: New package for digital filtering + * filtergen.man: Description of the filters package + * filtergen.test: Simple tests for the filters package + * pkgIndex.tcl: Added the filters package + +2020-11-22 Arjen Markus + * geometry.tcl: Source the file geometry_ext.tcl - additional procedures by Manfred Rosenberger + * geometry_ext.tcl: File with the additional procedures + * geometry.test: Added tests for these procedures + * math_geometry.man: Description of these procedures + * pkgIndex.tcl: Bumped version to 1.4.1 + +2020-09-20 Arjen Markus + * geometry.tcl: The procedures [direction] and [octant] used an inconsistent definition of the direction (see https://core.tcl-lang.org/tcllib/tktview?name=fb4812f82b). + The changes make the results consistent with the standard mathematical definition. + Further change: return the common point for adjacent line segments. + * geometry.test: Added several tests wrt the above changes + * pkgIndex.tcl: Bumped the version of geometry to 1.4.0, as the changes above represent a minor incompatibility. + * geometry.man: Document these changes + +2020-04-17 Arjen Markus + * primes.tcl: Correct the implementation of the totient function, as per https://core.tcl-lang.org/tcllib/tktview?name=7017dad214 + * primes.test: Added a test case for the numbers 1 to 12 for the totient function + * pkgIndex.tcl: Bumped version of numtheory to 1.1.2 + +2020-02-13 Arjen Markus + * special.tcl: Add procs for returning Euler and Bernoulli number, version to 0.5.0 + * special.test: Add tests for these new procs + * special.man: Add documentation for these new procs + * pkgIndex.tcl: Bumped version of special functions package to 0.5.0 + +2019-11-08 Arjen Markus + * statistics.tcl: Add a new type of error message, version to 1.5.0 + * pdf_stat.tcl: Add procedures for Laplace, Kumaraswamy and negative binomial distributions, also tests for homoscedasticity + * statistics.tcl: Corresponding tests + * statistics.man: Documentation of the new procedures + * pkgIndex.tcl: Bumped version of statistics package to 1.5.0 + +2019-11-04 Arjen Markus + * interpolate.tcl: Correct the procedure interp-linear for another pair of corner cases (thanks to Alexandru) + +2019-10-29 Arjen Markus + * interpolate.tcl: Correct the procedure interp-linear for several corner cases (thanks to Alexandru) + * pkgIndex.tcl: Bumped version of interpolation package to 1.1.2 + +2019-09-30 Arjen Markus + * special.tcl: Add function incomplete Beta, regularized Beta and digamma + * special.test: Add tests for the new functions + * special.man: Describe the new functions + * pkgIndex.tcl: Bumped version of special functions package to 0.4 + +2019-08-14 Arjen Markus + * math_geometry.man: Describe several procedures that were not described yet + * geometry.tcl: Export several procedures that were not exported yet + * pkgIndex.tcl: Bumped version of geometry package to 1.3.1 + +2019-06-22 Arjen Markus + * pdf_stat.tcl: Add procedures for triangular distribution + * statistics.man: Describe procedures for triangular distribution + * statistics.test: Add tests for triangular distribution + * statistics.tcl: Bumped version to 1.3.1 + * pkgIndex.tcl: Bumped version to 1.3.1 +2019-05-07 Arjen Markus + * quasirandom.test: Add tests to deal with procedures in a different namespace + * quasirandom.tcl: Deal with procedures in a different namespace + +2019-04-24 Arjen Markus + * quasirandom.test: Add support code + * numtheory.tcl: Add estimation of the number of primes between two limits + * numtheory.test: Add tests regarding the estimated number of primes + +2019-04-23 Arjen Markus + * quasirandom.tcl: New package - generate quasi-random numbers (for instance for estimating multidimensional integrals) + * quasirandom.test: Tests for the new package + * quasirandom.man: Documentation for the new package + * pkgIndex.tcl: Add the new package + +2019-04-18 Arjen Markus + * misc.tcl: Add double() to calculation of mean and standard deviation in proc stats (ticket 0a030f850d4e3fc05da98aa954a6ec1b16e655d9) + * math.test: Correct the outcome of the test for stats (consequence of ticket 0a030f850d4e3fc05da98aa954a6ec1b16e655d9) + +2018-08-04 Arjen Markus + * statistics.tcl: Source stat_wasserstein.tcl and stat_logit.tcl - for new commands + * statistics.test: Add corresponding tests + * statistics.man: Add description of these commands + * pkgIndex.tcl: Bump the version to 1.3.0 + +2018-07-22 Arjen Markus + * trig.tcl: Implementation of (additional) trigonometric functions - package math::trig + * trig.test: Trst for the (additional) trigonometric functions + * trig.man: Documentation for the (additional) trigonometric functions + * pkgIndex.tcl: Add the new package + +2018-07-19 Arjen Markus + * math_geometry.man: Describe the new criterium + +2018-06-23 Arjen Markus + * geometry_circle.tcl: Use the mean radius as criterium for touching circles (suggestion Andreas Kupries) + +2018-06-18 Arjen Markus + * geometry_circle.tcl: New source file with circle procedures + * geometry.tcl: Added [source] statement for the new file, bumped version to 1.3.0 + * math_geometry.man: Description of the new procedures + * geometry.test: Tests for the new procefures + * pkgIndex.tcl: Version of math::geometry + +2018-01-26 Arjen Markus + * pdf_stat.tcl: Add a new procedure, bootstrap + * statistics.test: Add tests for the bootstrap procedure + * statistics.man: Add description of the bootstrap procedure + * statistics.tcl: Change the version number for the statistics package (1.2.0) + * pkgIndex.tcl: Change the version number for the statistics package + +2018-01-07 Arjen Markus + * pca.tcl: New package PCA, principal components analysis + * pca.man: DoOcumentation for the PCA package + * pca.test: Tests for the PCA package + * pkgIndex.tcl: Add the package require command for the PCA package +2017-10-06 Arjen Markus + * mvlinreg.tcl: Special case for zero variation - then the correlation coefficient should be 1.0 + * statistics.test: Test that mv-ols is well behaved if the variation in the dependent variable is zero (ticket 51c03aac1a45161ab6cc59afb69d1768175e054c) + * statistics.tcl: Bumped the version to 1.1.1 + * pkgIndex.tcl: Bumped the version of math::statistics to 1.1.1 + +2017-08-10 Arjen Markus + * geometry.test: Add tests for areaPolygon + * geometry.tcl: Correct implementation of areaPolygon (ticket cb043ecc70e0e90bff93535d1d371a78b94f5d44) +2017-05-29 Arjen Markus + * geometry.test: Require at least Tcl 8.5 + * numtheory.man: Add description of Jacobi symbol + * primes.tcl: Add Jacobi symbol + * primes.test: Add tests for Jacobi symbol + +2017-05-28 Arjen Markus + * numtheory.tcl: Source primes.tcl at the end, version now 1.1 + * primes.tcl: Additonal procedures for the number theory package, includes estimates of number of primes + and factors (tickets 1be9ea99c9b76c8ffeff3edfb73671309bf657e8 and 734dd2ae5c89319a3b8579e48d581f9d0a3da4f4) + * numtheory.man: Document additional procedures + * primes.test: Tests for additional procedures + * linalg.tcl: Correction of [conforming] procedure (ticket 776a75f14f53b5c9a06fe3f3892485a6efe1dc20) + * linalg.test: Added tests for the [conforming] procedure + * pkgIndex.tcl: Bumped version of numtheory to 1.1, linearalgebra to 1.1.6 + +2017-01-17 Arjen Markus + * statistics.test: Add tests for test-Tukey-range and test-Dunnett + * statistics.tcl: Add two procedures, test-Tukey-range and test-Dunnett, and auxiliary code + * statistics.man: Describe the two new procedures + * pkgIndex.tcl: Bumped version of the statistics module to 1.1.0 + +2017-01-10 Arjen Markus + * statistics.test: Correct the tests for the test-anova-F procedure + * statistics.tcl: Correct the namespace for the test-anova-F procedure and the comment + * statistics.man: Correct the description of the test-anova-F procedure + * linalg.test: Correct test solve-1.6 regarding permuted matrices + * geometry.test: Add a simple definition of lmap for older versions of Tcl (notably 8.5) + * interpolate.test: Correct test Interpolate-1.3 - missing keyword -result and use of existing table name + +2016-08-16 Arjen Markus + * pdf_stat.tcl: Correct the use of the argument for standard deviation, affects pdf-lognormal and cdf-lognormal + (ticket 002b9e8e07777425) + * statistics.test: Correct the tests for both procedures + * statistics.tcl: Bumped the version to 1.0.1 + * pkgIndex.tcl: Load version 1.0.1 of the statistics module + +2016-08-04 Arjen Markus + * interpolate.tcl: Correct the calculation of the weight for interpolation - cast to double + * interpolate.test: Added test for this change + * statistics.test: Correct the ANOVA tests (use -result) + * linalg.test: Added test to show that permuted linear systems give the same result + +2016-04-12 Arjen Markus + * geometry.tcl: Replace the algorithm in pointInsidePolygon (ticket dc49af96c2), also add an alternative + method based on the winding number + * geometry.test: Add the new test case for this ticket and adjust the outcome for an edge case (hour glass). + Further tests added for the alternative method and for some edge cases + +2015-11-14 Arjen Markus + * statistics.tcl: Add test-anova-F + * pdf_stat.tcl: Add cdf-F + * statistics.test: Add tests for test-anova-F and cdf-F + * statistics.man: Describe test-anova-F and cdf-F + * geometry.tcl: Implement translation, rotation, reflection and conversion to/from radians and degrees + * geometry.test: Add tests for translation, rotation and reflection and conversion radians/degrees + * math_geometry.tcl: Describe the new procedures + * special.man: Correct description of Beta and Gamma functions + +2015-04-29 Arjen Markus + * 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 + * statistics.tcl: Bump version to 1.0 - Aku found the cause of earlier problems + +2015-04-26 Arjen Markus + * 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 + * 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 + * 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 + * 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 + * calculus.tcl: Bumping version to 0.8 + * pkgIndex.tcl: Bumping version of math::calculus package to 0.8 + +2014-08-21 Arjen Markus + * 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 + * statistcs.man: Add missing documentation for random-poisson procedure + +2014-01-30 Arjen Markus + * 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 + * 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 + * 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 + * 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 + + * decimal.man: Fixed missing requirement of the package + * machineparameters.man: itself. + +2013-11-03 Arjen Markus + + * 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 + + * 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 + + * math.test (math-12.1): [Bug 3606620]: Disabled debug output + command lifting SafeBase error information into the test log. + +2013-03-05 Arjen Markus + * 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 + + * decimal.man: Fixed leading namespace qualifier in label. + * symdiff.man: Fixed missing short package title. + +2013-02-01 Andreas Kupries + + * + * Released and tagged Tcllib 1.15 ======================== + * + +2012-06-25 Arjen Markus + + * statistics.tcl: Add procedures for Wilcoxon test and Spearman + rank correlation to the export list + +2012-06-24 Arjen Markus + * decimal.man: Correct documentation (namespace) for decimal package + * statistics.tcl: Add Wilcoxon test and Spearman rank correlation + Bumped version to 0.8 + * statistics.test: Add test cases for Wilcoxon test and Spearman rank correlation + * statistics.man: Describe procs for Wilcoxon test and Spearman rank correlation + * wilcoxon.tcl: Added this file - contains implementation of the new procs + +2011-12-13 Andreas Kupries + + * + * Released and tagged Tcllib 1.14 ======================== + * + +2011-11-09 Andreas Kupries + + * decimal.test: More fixes, now the test succeeds as + well. 'Simply' required the proper conversions for arguments and + results as most commands do not take regular numbers. + +2011-11-07 Andreas Kupries + + * decimal.test: Fixed the testsuite to be at least properly + executable, i.e. bad file names and broken Tcl syntax. The + single test still but that sahall be a problem for the actual + maintainer. + +2011-08-09 Andreas Kupries + + * decimal.man: [Bug 3383039]: Fixed syntax errors in the + documentation of math::decimal, reported by Thomas Perschak + + +2011-03-29 Andreas Kupries + + * linalg.man: Documentation tweak, added keyword 'matrix'. + +2011-01-24 Andreas Kupries + + * + * Released and tagged Tcllib 1.13 ======================== + * + +2011-01-12 Andreas Kupries + + * symdiff.test: Fixed setup (added std boilerplate). + * pkgIndex.tcl: Moved symdiff to correct section, requires 8.5, + not 8.4. + +2010-05-24 Andreas Kupries + + * geometry.man: [Bug 3110860]: Renamed this file to avoid the + * math_geometry.man: conflict with Tcl 8.6's new geometry + manpage. Thanks to Reinhard Max for reporting. + +2010-10-19 Kevin B. Kenny + + * symdiff.man: + * symdiff.tcl: Added a math::calculus::symdiff package that + * symdiff.test: performs symbolic differentiation of Tcl math + * pkgIndex.tcl: exprs. + +2010-09-27 Lars Hellstr\"om + + * numtheory.test: Fixed bug #3076576. + * numtheory.dtx: + +2010-09-22 Arjen Markus + + * kruskal.tcl: Added header to the file + +2010-09-21 Arjen Markus + + * kruskal.tcl: One-sided test according to Kruskal-Wallis + * statistics.tcl: Added test Kruskal-Wallis + * statistics.man: Describe Kruskal-Wallis + * statistics.test: Added simple test case + * pkgIndex.tcl: Bumped version to 0.7.0 + +2010-09-20 Lars Hellstr\"om + + * numtheory.dtx: New package math::numtheory (v1.0) + * numtheory.man: with command math::numtheory::isprime. + * numtheory.stitch: See numtheory.dtx for all the gory + * numtheory.tcl: details of the implementation of + * numtheory.test: package and tests. + * pkgIndex.tcl: + +2010-08-22 Andreas Kupries + + * linalg.tcl: Corrected bug #3036124 (shape of U matrix) + - should probably include an extra command for + truncated output of S and V + +2010-05-24 Andreas Kupries + + * geometry.man: A bit more commands, bumped to version 1.1.2. + * geometry.tcl: + * pkgIndex.tcl: + +2010-04-06 Andreas Kupries + + * geometry.tcl (findLineIntersection): Fixed numerical + * geometry.man: instability in the algorithm by replacing + * geometry.test: it with Kevin's parametric code. Updated + * pkgIndex.tcl: documentation, testsuite. Bumped to + version 1.1.1. + +2010-04-05 Andreas Kupries + + * geometry.tcl: Extended API with a number of basic point + * geometry.man: and vector operations (+, -, scale, ...). + * geometry.test: Updated documentation, testsuite. + * pkgIndex.tcl: Bumped to version 1.1. + +2010-01-17 Arjen Markus + + * fuzzy.tcl: [Bug 2933130]. Fixed procedure tlt + * fuzzy.test: [Bug 2933130]. Added test for this bug + * pkgIndex.tcl: Version increased to 0.2.1 + +2009-12-07 Andreas Kupries + + * + * Released and tagged Tcllib 1.12 ======================== + * + +2009-12-04 Andreas Kupries + + * math.man: [Bug 1998628]. Accepted fix by Arjen Markus, with + * math.tcl: modifications. Extended testsuite. Bumped version + * math.test: to 1.2.5. + * pkgIndex.tcl: + +2009-11-17 Arjen Markus + + * statistics.tcl: Bumped version to 0.6.3 + * geometry.tcl: Solved bug #1623653 - corner case in pointInsidePolygon + * geometry.test: Added two tests for the corner case + * pkgIndex.tcl: Updated version numbers + +2009-11-16 Arjen Markus + + * pdf_stat.tcl: Fix bug #2897419 - very small numbers with beta + distribution + +2009-10-22 Arjen Markus + + * interpolate.tcl: Fix bug #2881739 in cubic interpolation + +2009-09-28 Andreas Kupries + + * linalg.test: Switched the test setup back to 'regular' and also + fixed the version information in the non-regular branch of the + setup. + +2009-08-21 Arjen Markus + + * statistics.tcl: Remove a local variable from interval-mean-stdev + +2009-08-12 Arjen Markus + + * statistics.tcl: Solve bug 2835712 regarding interval-mean-stdev + +2009-07-13 Arjen Markus + + * statistics.tcl: Implement more robust computation of basic statistics + Fixes bug 2812832; simplified the code (as indicated by akupries) + * statistics.test: Added test for this more robust computation + * linalg.tcl: Corrected dim and shape procedures for scalars (version now 1.1.3; + Fixes bug 2818958 + * linalg.test: Corrected result of dim and shape procedures for scalars + * pkgIndex.tcl: Updated version numbers + +2009-03-20 Arjen Markus + + * linalg.tcl: Solving bugs with test matrices (bugs #2695513, 2695564, 2695618) + * linalg.test: Added test cases for border matrix and Wilkinson W- and W+ + * pkgIndex.tcl: Version of linear algebra package increased to 1.1.1 + +2009-02-18 Arjen Markus + + * machineparameters.man: Replaced deprecated markup (bug #2597454) + +2009-02-06 Arjen Markus + + * pkgIndex.tcl: Added machineparameters package + * machineparameters.tcl: New package by Michael Baudin + * machineparameters.test: Test for the new package + * machineparameters.man: Man page for the new package + +2008-12-12 Andreas Kupries + + * + * Released and tagged Tcllib 1.11.1 ======================== + * + +2008-12-01 Andreas Kupries + + * linalg.man: New commands in last checkin means extended API. + * linalg.tcl: Bumping minor version, to 1.1. + * pkgIndex.tcl: + +2008-12-01 Arjen Markus + + * linalg.man: changed int to integer, documented new procedures by Michael Baudin + * linalg.test: incorporated new tests by Michael Baudin + * linalg.tcl: incorporated new procedures, extensions and several bug fixes by Michael Baudin + +2008-11-09 Arjen Markus + + * optimize.man: corrected names of minimum and maximum procedures + +2008-10-16 Andreas Kupries + + * + * Released and tagged Tcllib 1.11 ======================== + * + +2008-10-06 Andreas Kupries + + * calculus.tcl: Bumped version to 0.7.1, for the commit on + * calculus.man: 2008-06-25 by Arjen. Was a bugfix, should + * pkgIndex.tcl: have bumped the version then. + +2008-08-12 Arjen Markus + + * special.tcl: bumped version to 0.2.2 (because of previous change) + * pkgIndex.tcl: bumped version of "special" to 0.2.2 + +2008-08-11 Arjen Markus + + * special.tcl: Replaced old algorithm for erf() and erfc(). Bug + #2024843. + +2008-07-01 Arjen Markus + + * roman.man: corrected wrong mark-up command + +2008-06-25 Arjen Markus + + * calculus.tcl: solved problem with solveTriDiagonal (bug 2001539) + * calculus.tcl: repaired hidden problem with boundaryValueSecondOrder + * calculus.test: added test case for solveTriDiagonal + +2008-05-19 Arjen Markus + + * roman.man: correct namespace ::math::roman, was ::roman. + +2008-03-24 Andreas Kupries + + * pkgIndex.tcl: Synchronized indexed and provided versions of + * bigfloat.man: math::bigfloat. + +2008-03-22 Andreas Kupries + + * constants.test: Fixed declaration of package under test, was + wrongly declared as support. + +2008-03-14 Andreas Kupries + + * statistics.man: Cleaned up a bit, replaced deprecated [nl] usage + with [para]. + +2008-02-27 Andreas Kupries + + * linalg.test (eigenvectors-1.0): Moved brace to correct location. + +2008-02-27 Andreas Kupries + + * linalg.test (eigenvectors-1.0): Fixed missing closing brace. + +2008-02-21 Arjen Markus + + * elliptic.tcl: Error in expression (missing )) + +2008-01-18 Arjen Markus + + * statistics.man: Update manual; added beta distribution + * statistics.test: Added tests for beta distribution + * pdf-stat.tcl: Added procedures for beta distirbution + (Improved implementation by Eric K. Benedict) + +2008-01-13 Arjen Markus + + * statistics.man: Update manual; added description of various new procedures + * statistics.test: Added tests for chi square and Student's t distributions + * pdf-stat.tcl: Added procedures for chi square and Student's t distributions + (Next batch of feature requests by Eric K. Benedict) + +2008-01-11 Arjen Markus + + * statistics.man: Update manual; added description of various new procedures + * statistics.test: Added tests for Gamma and Poisson distributions + * pdf-stat.tcl: Added procedures for Gamma and Poission distributions + (Feature requests by Eric K. Benedict) + +2007-12-22 Arjen Markus + + * linalg.tcl: Corrected bug #1805912 (eigenvectorsSVD) by means of path #1852519 + * linalg.test: Added simple test case for eigenvectorsSVD + * pkgIndex.tcl: Increased version number for linear algebra (1.0.3 now) + +2007-12-11 Arjen Markus + + * special.tcl: Corrected implementation of Gamma + function (reported by EKB) + +2007-09-12 Andreas Kupries + + * + * Released and tagged Tcllib 1.10 ======================== + * + +2007-09-11 Arjen Markus + + * linalg.test: Corrected test that was linked to SF bug 1784637 + * linalg.tcl: Corrected case in matmul that was linked to SF bug + 1784637 + +2007-09-06 Arjen Markus + + * linalg.tcl: Solved bug with matmul (SF bug 1784637) + +2007-08-21 Andreas Kupries + + * math.test (matchTolerant): Changed to not use tcltest 2.0+ + features in a testsuite for tcltest 1.0. Rewritten the tests + using this custom comparison command to be tcltest 1.0 + compliant. + + * pkgIndex.tcl: With permission from Arjen moved math::statistics + * bessel.test: into the 8.4 section. Due to its new dependency on + * elliptic.test: math::linearalgebra via multi-variate linear + * statistics.test: regression it now depends on Tcl 8.4+ too. + * special.test: Updated the tests using math::statistics for this + as well. + +2007-08-20 Andreas Kupries + + * bessel.test: Added missing dependency on math::linearalgebra. + * elliptic.test: (For math::statistics). This not fully ok yet, + the Tcl core requirements are out of whack too. + +2007-07-10 Arjen Markus + + * statistics.tcl: Corrected a spelling mistake in name of Zachariadis + * linalg.test: Removed temporary reference to ferri/ferri.test + +2007-07-07 Arjen Markus + + * math.test: Added a small tolerance for two tests + * statistics.man: Added pvar and pstdev, difference between var and pvar documented + * statistics.tcl: Added population stdev and variance + * statistics.test: Added tests for pvar and pstdev + * special.test: Added dependency on math::linearalgebra + +2007-06-26 Kevin B. Kenny + + * elliptic.tcl: Removed a spurious 'puts' in the computation of + Jacobian elliptic functions. + * special.tcl: Advanced patchlevel to 0.2.1. + +2007-03-22 Andreas Kupries + + * bigfloat.man: Fixed all warnings due to use of now deprecated + * bignum.man: commands. Added a section about how to give + * calculus.man: feedback. + * combinatorics.man: + * constants.man: + * fourier.man: + * fuzzy.man: + * geometry.man: + * interpolate.man: + * linalg.man: + * math.man: + * optimize.man: + * polynomials.man: + * qcomplex.man: + * rational_funcs.man: + * roman.man: + * romberg.man: + * special.man: + * statistics.man: + +2007-03-20 Arjen Markus + + * mvlinreg.tcl : changed the API to make it more robust (no eval needed) + * statistics.man : updated description of mv-ols and mv-wls + * statistics.test : updated the API + +2007-03-18 Arjen Markus + + * statistics.man : updated description of tstat + * statistics.test : converted the example into a test + +2007-03-05 Arjen Markus + + * mvlinreg.tcl : polished the source code (adding standard headers) + Still to do: test cases + +2007-02-27 Arjen Markus + + * statistics.man : added description of multivariate linear regression procedures + (contribution by Eric Kemp-Benedict) + * statistics.tcl : sources "mvlinreg.tcl" now + * mvlinreg.tcl : original source code from Eric, still needs some polishing + (the test case needs to be integrated too) + +2006-11-06 Arjen Markus + + * fuzzy.test : fixed a dependency on Tcl 8.4 behaviour in one test case + (the value of tcl_precision) + +2006-10-03 Andreas Kupries + + * + * Released and tagged Tcllib 1.9 ======================== + * + +2006-09-26 Andreas Kupries + + * bigfloat.tcl: Bumped version to 1.2.1 + * pkgIndex.tcl: + +2006-09-26 Stephane Arnold + * bigfloat.man : fixed a bug in [math::bigfloat::tostr] + * bigfloat.tcl : when a number is close to zero, + * bigfloat.test it takes the precision into account, + * bigfloat2.tcl so instead of getting '0' we get '0.e-4'. + * bigfloat2.test [math::bigfloat::iszero] is not impacted + +2006-09-20 Andreas Kupries + + * math.tcl: Bumped version to 1.2.4 + * math.man: + * qcomplex.man: Bumped version to 1.0.2 + * qcomplex.tcl: + * fourier.man: Bumped version to 1.0.2 + * fourier.tcl: + * interpolate.man: Bumped version to 1.0.2 + * interpolate.tcl: + * linalg.tcl: Bumped version to 1.0.1 + * linalg.man: + * pkgIndex.tcl: + +2006-09-19 Arjen Markus + * linalg.tcl: removed print statement (left over from testing leastSquares) + +2006-09-15 Arjen Markus + * linalg.man: added remark on name conflict with Tk + added missing descriptions of several procedures + * linalg.tcl: added crossproduct to the exported commands + implemented normalizeStat + corrected error in leastSquaresSVD + * linalg.test: added test for normalizeStat + added test for leastSquaresSVD + +2006-06-13 Arjen Markus + + * pdf_stat.tcl: check for existence of argv0 - child interpreters + * plotstat.tcl: ditto + * statistics.tcl: ditto + +2006-03-29 Andreas Kupries + + * math.man: Fixed name of romberg package, resorted the list, + slight reformatting of items with regard to right margin. + +2006-03-28 Andreas Kupries + + * math.man: Added a bit of markup to the package list for better + cross-referencing. + + * statistics.man: Fixed unclosed bracket. + +2006-03-28 Arjen Markus + + * calculus.tcl (integral2D and integral3D): Fixed a bug concerning + intervals that do not start at 0.0 + * calculus.tcl (integral2D and integral3D): Added accurate versions + for integration over rectangles and blocks (exact for polynomials + of degree 3 or less). + * statistics.tcl (test-normal): Added implementation of normality test + by Torsten Reincke (as it appeared on the Wiki) + +2006-03-02 Andreas Kupries + + * pkgIndex.tcl: Resynchronized the ifneeded/provide version + information for math::bignum. + +2006-02-21 Arjen Markus + + * linalg.tcl (matmul): Fixed [SF Tcllib Bug xxxxxxx]. The bug + concerns the possibility of using row vectors. Because I + did not think they were possible/practical, I regarded all + vectors as column vectors or row vectors whenever suitable. + Row vectors are however practical, so I needed to add these + cases, at least for [matmul]. + +2006-02-13 Arjen Markus + + * bignum.tcl (rshift): Fixed [SF Tcllib Bug 1098051]. (Solution + provided by Lars Hellstrom. Added tests for both rshift and lshift) + +2006-01-30 Andreas Kupries + + * bignum.tcl (testbit): Fixed [SF Tcllib Bug 1085562]. Thanks to + aubinroy for the report, bugfix, and his + patience while waiting for us to apply the fix. + * bignum.test: Extended the testsuite. + +2006-01-29 Andreas Kupries + + * bigfloat.test: Fixed use of duplicate test names. + * calculus.test: + * linalg.test: + * statistics.test: + +2006-01-23 Andreas Kupries + + * bessel.test: More boilerplate simplified via use of test support. + * bigfloat.test: + * bigfloat2.test: + * bignum.test: + * calculus.test: + * combinatorics.test: + * constants.test: + * elliptic.test: + * fourier.test: + * fuzzy.test: + * geometry.test: + * interpolate.test: + * linalg.test: + * math.test: + * optimize.test: + * polynomials.test: + * qcomplex.test: + * roman.test: + * special.test: + * statistics.test: + +2006-01-19 Andreas Kupries + + * bessel.test: Hooked into the new common test support code. + * bigfloat.test: + * bigfloat2.test: + * bignum.test: + * calculus.test: + * combinatorics.test: + * constants.test: + * elliptic.test: + * fourier.test: + * fuzzy.test: + * geometry.test: + * interpolate.test: + * linalg.test: + * math.test: + * optimize.test: + * polynomials.test: + * qcomplex.test: + * roman.test: + * special.test: + * statistics.test: + +2006-01-11 Andreas Kupries + + * fourier.tcl (::math::fourier::lowpass): Changed package + * fourier.tcl (::math::fourier::highpass): reference + "complexnumbers" to the correct "math::complexnumbers". + +2006-01-10 Arjen Markus + + * linalg.tcl: Fixed bug in procedure angle + Added a procedure crossproduct + * linalg.man: Added documentation on crossproduct + +2005-11-13 Stephane Arnold + + * bigfloat2.tcl : bug fix in trigonometry, functions may have + return a number more precise than the input + * bignum.tcl : a little performance enhancement by avoiding + the use of [upvar] in [_treat] + * bigfloat2.test : minor changes + * bigfloat.man : rewriting 40% of the documentation that + now covers both 1.2 and 2.0 versions + +2005-11-14 Andreas Kupries + + * pkgIndex.tcl: Reworked the extended package index a bit to keep + the general existing structure. + +2005-11-13 Stephane Arnold + + * bigfloat2.tcl,bigfloat2.test : two files + forming the math::bigfloat package for Tcl 8.5 + * pkgIndex.tcl : updated to handle the different Tcl versions + Tcl 8.4 still has math::bigfloat 1.2 + +2005-11-04 Arjen Markus + + * roman.test: removed extraneous messages + +2005-10-26 Arjen Markus + + * qcomplex.tcl: error in the computation of the complex + cosine. Found by Oscar Andreas Lopez. + +2005-10-21 Andreas Kupries + + * interpolate.test: Reduced requirement for struct down to + * interpolate.tcl: struct::matrix, as that is the only structure + used by this package. This means that we are loading 272 KB less + (344 KB - 72 KB). Also fixed the testsuite header code. + +2005-10-10 Arjen Markus + + * fixed one bug regarding cov in misc.tcl + +2005-10-06 Andreas Kupries + + * + * Released and tagged Tcllib 1.8 ======================== + * + +2005-10-05 Andreas Kupries + + * pkgIndex.tcl: Updated all version numbers to be in sync with the + * bignum.man: changes made to the various packages in this module. + * bignum.tcl: + * calculus.man: + * calculus.tcl: + * combinatorics.man: + * constants.man: + * constants.tcl: + * fourier.man: + * fourier.tcl: + * interpolate.man: + * interpolate.tcl: + * math.man: + * math.tcl: + * polynomials.man: + * polynomials.tcl: + * qcomplex.man: + * qcomplex.tcl: + * rational_funcs.man: + * rational_funcs.tcl: + * special.man: + * special.tcl: + * statistics.man: + * statistics.tcl: + +2005-10-04 Andreas Kupries + + * geometry.man: Fixed bad reversals of geometry version + * geometry.tcl: numbers. Bumped version to reflect the + documentation change. + + * pkgIndex.tcl: Added new 'math::roman' to package index. + +2005-10-04 Arjen Markus + + * Added roman numerals package by Kenneth Green + * geometry.man: Completed the description of the + current procedures + +2005-09-28 Arjen Markus + + * optimize.man: Removed note on linear programming. It is + working now (not fully, perhaps though) + +2005-09-20 Andreas Kupries + + * pkgIndex.tcl: Declared 8.4 dependency of packages + * optimize.man: math::optimize, math::calculus, and + * optimize.tcl: math::interpolate in package index, code, and + * optimize.test: testsuite. + * interpolate.man: + * interpolate.tcl: + * interpolate.test: + * calculus.man: + * calculus.tcl: + * calculus.test: + +2005-09-19 Andreas Kupries + + * pkgIndex.tcl: Declared 8.4 dependency of linalg package in + * linalg.tcl: package index, code, and testsuite. + * linalg.test: + + * bessel.test: Fixed a number of typos in the abort messages. + * bigfloat.test: Indented abort messages for better visibility + * bignum.test: in the log. + * calculus.test: Declared 8.4 dependency of bignum/bigfloat in + * constants.test: package index, code, and testsuite. + * elliptic.test: Removed 8.4isms from testsuites for packages + * fourier.test: allowing use with Tcl 8.2+ + * interpolate.test: + * linalg.test: + * math.test: + * optimize.test: + * polynomials.test: + * qcomplex.test: + * special.test: + * statistics.test: + * bigfloat.tcl: + * bignum.tcl: + * pkgIndex.tcl: + +2005-09-09 Stephane Arnold + + * bigfloat.tcl : went back to the old algorithm to compute Pi + after having done much benchmarks + +2005-09-06 Stephane Arnold + + * bigfloat.tcl : new and faster algorithm to compute Pi + +2005-08-31 Stephane Arnold + + * bigfloat.tcl : added many comments and fixed some minor bugs + (possibly following to inexact last digits) + * bigfloat.test : fixed a bug that causes the version number + of some tests to be replaced by 1.0 or by the string "version" + +2005-08-30 Andreas Kupries + + * bignum.tcl: Fixed code exporting the bignum commands, it was + done in the wrong namespace. This fixes [Tcllib SF Bug 1276680]. + +2005-08-29 Kevin Kenny + + * combinatorics.test (combinatorics-2.7,3.10): Revised a few test cases + * math.test (math-7.4): to handle Infinity + in the interim (pre-TIP#237) 8.5 configuration as well as + kennykb-numerics-branch. + +2005-08-29 Arjen Markus + + * Fixed bug #1272910: due to the different rounding + of 0.5 in Tcl 8.5, the Quantiles-1.0 test failed. + Using different levels steers the test away from + this odd edge case. + +2005-08-29 Stephane Arnold + + * bigfloat.tcl : added comments to make code easier to understand + +2005-08-28 Stephane Arnold + + * bigfloat.tcl : many optimizations around the fromstr + command and all kind of constants (mainly integer) + * bigfloat.test : updated test labels to more significant labels + * Bug #1272836 : the math round() function has changed + in Tcl 8.5a4 (intentionally) - now the round tests + do no more rely upon this function. + +2005-08-26 Stephane Arnold + + * Feature Request 1261101 : automatically convert + the strings "0" and "1" to bignums + * modified files : bignum.man,bignum.tcl,bignum.test + * Bug 1273403 : fixed in bigfloat.test (all tests shared + the same version number) + +2005-08-25 Kevin Kenny + + * combinatorics.test (combinatorics-2.7,3.10): Revised a few test cases + * math.test (math-7.4): to handle Infinity + as well as "overflow" and "division by zero" as an error result. + +2005-08-24 Arjen Markus + + * optimize.man: Corrected a few typos + +2005-08-23 Stephane Arnold + + * bigfloat.tcl : Fixed a small bug in [fromstr]. + * bigfloat.man : Trying to make it more clear about accuracy + and interval computations. + +2005-08-17 Kevin Kenny + + * optimize.tcl (nelderMead): Added ::math::optimize::nelderMead, + * optimize.test (nelderMead-*): an implementation of multidimensional + * optimize.man: optimization using the downhill + simplex method of Nelder and Mead. (Addition includes test cases + and rudimentary documentation.) + * exponential.tcl: Changed the demo script not to error out. + +2005-08-09 Arjen Markus + + * Added the linear programming routines that were + described in the man page, but not actually there + * Updated the test file and man page for this + * Updated the pkgIndex.tcl file (optimize now at 1.0) + +2005-08-05 Stephane Arnold + + * bigfloat.tcl : Fixed a bug in [fromstr] when a number + began with '+' ; another bug, in [fromdouble], when + a number began with '+' or '-'. + * bigfloat.test : Added tests for fromdouble. + +2005-08-04 Andreas Kupries + + * bigfloat.man: Replaced a number of ?...? occurences to markup + optional arguments with the more correct [opt ...]. + +2005-08-04 Stephane Arnold + + * bigfloat : Fixed a bug in [fromstr] when a number + with an exponent beginning by 0 was given (like 1.1e+099) + + * bigfloat : Added a [fromdouble] new proc. + +2005-08-01 Arjen Markus + + * Changed the credits for Ed Hume at his request + (anti-spam measure) + +2005-07-26 Stephane Arnold + + * Changed in many places : '[pi $precision]' + to '[pi $precision 1]' in which $precision is treated + as binary digit length (instead of decimals) + since the internal representation of the mantissa is binary + +2005-07-01 Stephane Arnold + + * bigfloat.man,bigfloat.test,bigfloat.tcl : updated + copyright 2005 + * bigfloat.man : put the correct package version (1.2) + +2005-07-01 Stephane Arnold + + * bigfloat.tcl : new [int2float] conversion procedure + * bigfloat.test : updated test suite for the new procedure + * bigfloat.man : updated documentation and added a new EXAMPLES + section + +2005-06-23 Arjen Markus + + * bigfloat.tcl: Removed the namespace import statement + * bigfloat.test: Explicitly import the bigfloat procedures + * qcomplex.test: Force the import of complex number procedures + (conflict with bigfloat's sqrt) + +2005-06-22 Andreas Kupries + + * statistics.test: Corrected typos in the test suite for the new + commands. + +2005-06-22 Arjen Markus + + * statistics.tcl/test/man: + Added several methods: 2x2 tables and two quality + control charts + + * elliptic.tcl/man: + Added functions cn, dn and sn. Test cases still + needed. + +2005-06-07 Kevin Kenny + + * constants.tcl: Corrected ::math::constants::find_huge + and ::math::constants::find_tiny to not go + into an infinite loop when overflow is not an error. + +2005-05-04 Arjen Markus + + * Removed reference to argv0 in optimize.tcl (in response + to a complaint by Bob Techentin) + +2005-04-25 Arjen Markus + + * Corrected documentation of math::product (was math::prod) + +2005-03-16 Andreas Kupries + + * bigfloat.tcl: Added package require math::bignum. If we use the + package we should load it as well. + + * rational_funcs.tcl: Redone entry '2004-11-22 Andreas Kupries + '. Somehow the source command came + back. + +2005-03-11 Arjen Markus + + * Corrected problem with exponential_Ei - doubly defined + +2005-01-14 Arjen Markus + + * Added version 1.0 of Stephane Arnold's bigfloat package + (newer versions will come later on) + +2005-01-10 Andreas Kupries + + * bignum.tcl: Integrated [Tcllib SF Bug 1093414]. Basic bit + * bignum.test: operations (and, or, xor) on big numbers. Correct + * bignum.man: operation is limited to positive numbers (including + zero). The basic code was provided by Aamer Aakther + , modifications of docs, and + small testsuite by myself. + +2005-01-05 Arjen Markus + + * Added tests for matmul (and corrected the implementation) + +2005-01-04 Arjen Markus + + * Expanded the documentation (it should now describe all + public procedures) + * Expanded the tests (not complete, but it should cover most + more complicated procedures) + * Expanded the set of procedures (only a few algorithms + await implementation) + +2005-01-03 Arjen Markus + + * Added modified Gram-Schmidt method to the linear algebra package + +2004-12-06 Arjen Markus + + * Fixed bug in rungeKuttaStep (calculus.tcl) found by Mark Stucky. + (Also moved the empty lines upward to better reflect the steps) + +2004-11-25 Andreas Kupries + + * linalg.man: Fixed a formatting bug in the file, found by a + regular run of the SAK tool. + +2004-11-25 Arjen Markus + + * Added descriptions of various linear algebra procedures + * Updated the code and expanded test cases + +2004-11-22 Andreas Kupries + + * rational_funcs.tcl: Removed bad source'ing of file + polynomials.tcl. Depended on current working directory in the + right place, and superfluous as well, as immediately after a + 'package require' of the package loaded it in the proper + manner. Disabled the test code at the end as well. + +2004-11-08 Arjen Markus + + * Added preliminary versions of a linear algebra module + (revision of Hume's LA). No documentation yet + * Removed the initialisation of CDF (that was left in there) + +2004-11-01 Arjen Markus + + * Moved initialisation of CDF in statistics module to + first call + +2004-10-05 Andreas Kupries + + * + * Released and tagged Tcllib 1.7 ======================== + * + +2004-10-02 Arjen Markus + + * Added preliminary documentation for the geometry module + * Added procedure areaPolygon to the geometry module + * Added Fourier transform module + +2004-09-30 Andreas Kupries + + * bignum.test: Boilerplate reading file under test. + +2004-09-30 Arjen Markus + + * Added a first set of test cases for the bignum module + * Corrected the namespace for the bignum module + +2004-09-29 Arjen Markus + + * Added the bignum module by Salvatore Sanfilippo. No test cases yet + +2004-09-23 Andreas Kupries + + * pdf_stat.tcl: Braced expr'essions, removed duplicated error + message. + + * constants.tcl (find_eps): Fixed expr'essions without braces. + * statistics.tcl: + + * exponential.tcl (proc): Removes superfluous no-op [append]. + +2004-09-22 Arjen Markus + + * *.test: Made sure the test files check for version 2.1 of the + tcltest package + + * *.tcl: Updated the package versions and consistently put the + "package provide" statement at the end + + * interpolate.*: Added cubic splines as interpolation method + +2004-09-17 Arjen Markus + + * bessel.tcl: Better implementation of Bessel functions of integer + order. + +2004-09-09 Andreas Kupries + + * calculus.man: Fixed problems in the calculus manpage introduced + by the last commit done yesterday. + +2004-09-08 Arjen Markus + + * calculus.tcl: added regula falsi method for finding roots + +2004-07-19 Andreas Kupries + + * combinatorics.man: Polished minimally, name of manpage. + + * qcomplex.tcl: Polished minimally, changed package name + * qcomplex.man: to math::complexnumbers. + +2004-07-07 Arjen Markus + + * bessel,tcl: Indentation adjusted to conform to + * bessel.test: the _Tcl Style Guide._ Errors + * constants.test: corrected in the documentation of + * elliptic.tcl: Romberg integration. + * elliptic.text: + * qcomplex.tcl: + * romberg.man: + * special.test: + +2004-07-05 Kevin Kenny + + * calculus.man: Added Romberg integration to + * romberg.man: the library. The procedures should + * calculus.tcl (romberg*): provide a "production quality" + * calculus.test (romberg-*): library for integrating functions + * math.tcl: of one variable, including functions + * misc.tcl (expectInteger): that have integrable singularities + and integrals over half-infinite + intervals. + * constants.tcl: Changes so that constants get defined in the + * constants.test: correct namespace. Changed tests so that they + * elliptic.test: don't fail when other tests have already run. + * special.tcl: Changed the definition of Gamma to the correct + * special.test: one. + Also added copyright notices and CVS IDs in several files that + lacked them, and corrected indentation in several files. + +2004-06-19 Kevin Kenny + + * interpolate.man: Added polynomial interpolation with Neville's + * interpolate.tcl: algorithm; this procedure will be needed in + * interpolate.test: Romberg integration, which is the next project. + +2004-06-18 Kevin Kenny + + * bessel.test: Fixed several problems that were causing tests + * combinatorics.test: to fail or to run noisily. Corrected inconsistent + * interpolate.tcl: package version number in interpolate.tcl. + * interpolate.test: + * qcomplex.test: + + * optimize.man: Added min_bound_1d and min_unbound_1d functions + * optimize.tcl: to do one-dimensional function minimization, + * optimize.test: constrained and unconstrained, respectively, + without derivatives. + +2004-06-16 Andreas Kupries + + * interpolate.man: Added a missing list_end before section + examples. Fixed usage of braces in the example as well. + +2004-06-16 Arjen Markus + + * added the modules complexnumbers, special, interpolate, constants + +2004-05-23 Andreas Kupries + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + +2004-02-15 Andreas Kupries + + * + * Released and tagged Tcllib 1.6 ======================== + * + +2004-02-09 Jeff Hobbs + + * combinatorics.tcl (::math::factorial): correct fac 171 + off-by-one and use of -strict in string is int|double. + +2003-12-22 Joe English + * calculus.man (rungeKuttaStep): Add missing argument + in function synopsis (bug report from Richard Body). + +2003-10-29 Arjen Markus + + * statistics.tcl (BasicStat): Applied fix for [SF Tcllib Bug + 820807]. Uniform data may cause a small negative value when + computing the base value for a standard deviation, instead of + the correct 0.0. The fix now enforces 0.0 when encountering this + situation. This entry in the ChangeLog by Andreas Kupries. + +2003-05-05 Andreas Kupries + + * + * Released and tagged Tcllib 1.4 ======================== + * + +2003-04-24 Andreas Kupries + + * pkgIndex.tcl: Found math::optimize missing in index. + * optimize.man: Version number inconsistent with code, + corrected. + + * calculus.test: Converted [puts] into log statements, and + suppress them by default. Reduces the noise when running the + testsuite. + + * math.test: Added output listing the version of the + * statistics.test: package we are testing. + * calculus.test: + * geometry.test: + * combinatorics.test: + * optimize.test: + +2003-04-24 Arjen Markus + + * liststat.tcl: Corrected the handling of the expression in the + list manipulation procedures. This solves the scope problem (bug + 725231). AK: Lifted from the 'cvs log'. This passes the testsuite. + +2003-04-23 Andreas Kupries + + * fuzzy.test: Re-applied bug fixes I did before (See 2003-04-13) + to the newly committed version, which was not merged, but simply + overwrote my changes. + +2003-04-21 Andreas Kupries + + * optimize.test: Corrected errors in loading the functionality + under test, and of accessing tcltest. Now functional. + +2003-04-18 Joe English + + * pkgIndex.tcl: Added math::statistics after yesterday's commit by + Arjen Markus. + + * statistics.test: Changed to conform to standard of importing + tcltest, changed import of tested functionality, added checks + that actually tcltest 1.2 or higher is used (Aborting if not). + + * statistics.tcl: + * liststat.tcl + * pdf_stat.tcl: + * plotstat.tcl: Reformatted a bit to be more near to the + style-guide with regard to indentation. + +2003-04-13 Andreas Kupries + + * pkgIndex.tcl: + * fuzzy.tcl: Committed new code (see #535216), this also updates + the package to version 0.2 + + * fuzzy.man: + * fuzzy.test: New files for fuzzy comparisons, documentation and + testsuite. Fixed some bugs in them. NOTE: There are failures in + the testsuite. + +2003-04-11 Andreas Kupries + + * combinatorics.man: + * math.man: + * math.tcl: + * pkgIndex.tcl: Set version of the package to to 1.2.2. + +2003-01-16 Andreas Kupries + + * combinatorics.man: More semantic markup, less visual one. + * calculus.man: + +2002-06-03 Andreas Kupries + + * pkgIndex.tcl: updated calculus to version 0.5. + * calculus.man: Added [require] declarations. + + * calculus.README: + * calculus.CHANGES: + * calculus.tcl: + * calculus.test: + * calculus.man: Applied changes for #553773 on behalf of Arjen + Markus . + +2002-05-08 Don Porter + + * calculus.test: Corrected testing problems by namespace-ifying + the file. + +2002-04-15 Andreas Kupries + + * combinatorics.man: Added doctools manpage. + * math.man: Added doctools manpage. + +2002-03-25 Andreas Kupries + + * calculus.man: Fixed formatting errors in the doctools manpage. + +2002-02-15 Andreas Kupries + + * Update of calculus. #528434 + + * calculus.man: New file, calculus documentation in doctools format. + * calculus.test: New file, beginnings of testsuite + + * calculus.CHANGES: + * calculus.README: + * calculus.tcl: + * pkgIndex.tcl: updated to calculus 0.3 + +2002-02-14 Andreas Kupries + + * combinatorics.tcl + * geometry.tcl (proc): Frink run + + * math::geometry: Version is now 1.0.1 to distinguish this from + the code in tcllib release 1.2 + + * math: Version is now 1.2.1 to distinguish this from + the code in tcllib release 1.2 + +2002-01-18 Don Porter + + * math.tcl: [namespace export Beta] got out of sync with the + command name. + * misc.tcl: removed [package provide math]; duplicated in + math.tcl, a sync problem waiting to happen. + +2002-01-18 Andreas Kupries + + * Bumped version to 1.2. + +2002-01-18 Andreas Kupries + + * Added calculus functionality and fuzzy FP comparison as provided + by Arjen Markus as is. This code + currently has neither true testsuite nor good documentation but + was considered important enough to get in now. Polish has to + come in the subsequent patch releases. + +2002-01-11 Kevin Kenny + + * combinatorics.tcl: Removed incorrect 'package provide'. + +2002-01-11 Kevin Kenny + + * math.tcl: + * misc.tcl: + * pkgIndex.tcl: + * tclIndex: Reorganized so that math.tcl is a top-level 'package + provide' script and loads a tclIndex. The code from 'math.tcl' + moves into 'misc.tcl'. + * combinatorics.n: + * combinatorics.tcl: + * combinatorics.test: Added a 'combinatorics' module containing + the Gamma function and several related functions (factorial, + binomial coefficient, and Beta). (Feature request #484850). + +2001-06-21 Andreas Kupries + + * math.tcl: Fixed dubious code reported by frink. + +2000-10-06 Eric Melski + + * math.test: + * math.n: + * math.tcl: Added ::math::fibonacci function, to compute numbers + in the Fibonacci sequence. + +2000-09-08 Eric Melski + + * math.test: + * math.n: + * math.tcl: Added ::math::random function. + + * pkgIndex.tcl: Bumped version number to 1.1. + +2000-06-15 Eric Melski + + * math.n: + * math.test: + * math.tcl: Incorporated sigma, cov, stats, integrate functions + (from Philip Ehrens ). [RFE: 5060] + +2000-03-27 Eric Melski + + * math.n: + * math.test: + * math.tcl: Added sum, mean, and product functions (from Philip + Ehrens ). + +2000-03-09 Eric Melski + + * math.test: Adapted tests for use in/out of tcllib test framework. + +2000-03-07 Eric Melski + + * pkgIndex.tcl: + * math.tcl: + * math.test: + * math.n: Initial versions of files for math library. diff --git a/vendor/math/TODO b/vendor/math/TODO new file mode 100644 index 00000000..0948ac3f --- /dev/null +++ b/vendor/math/TODO @@ -0,0 +1,239 @@ +This file records outstanding actions for the math module + + +dd. 21 september 2021 +Ticket de2be80fd27630f85c25c238fe26c89a3dfe9407: direction and octant delete the minus sign lead to diagram display bugs +The changes were made in 2020, so a year ago. It is unclear what has happened and what should still be repaired. Apparently +the definition in the Diagram package is screen-oriented. + + + + + +dd. 11 may 2021 +Update linearalgebra code: +- comparison of strings via == +- using foreach instead of lassign + + +dd. 4 march 2021 +Paired t-test: https://mathworld.wolfram.com/Pairedt-Test.html + + +dd. 19 february 2021 +Provide alternatives for pdf-gamma/cdf-gamma: using mean and standard deviation instead of alpha and beta + +Support Kaplan-Meier for censored data + +dd. 11 february 2021 +Check: +- statistical procedures for testing " normality" - I saw some obviously not normal datasets that were still not flagged as such + -- that seems to have been my mistake: comparing the wrong graphs +Implement: +- PPCC +- Plot positions +- QQ plots +- general support for censored data + + +dd. 19 january 2021 +Solve a problem with determineSVD - reported by Nicolas Robert +https://groups.google.com/g/comp.lang.tcl/c/RKcM7OfVkXk +- the code turned out to be correct. Issue was closed. + + +dd. 4 january 2021 +Check the man pages: +- [category] missing in several +- [strong] used (deprecated) - or some other keyword, no, [nl] in quasirandom.man + math_geometry.man + probopt.man + quasirandom.man + + +dd. 27 november 2020 +Stirling numbers - https://mathworld.wolfram.com/StirlingNumberoftheFirstKind.html + https://mathworld.wolfram.com/StirlingNumberoftheSecondKind.html + +Most efficient via the recurrence relations and memoization? + +First kind: S1(n+1,k) = S1(n,k-1) - n S1(n,k) -- S1(n,1) = (-1)**(n-1) * (n-1)! , S1(n,0) = Kronecker(n,0) +Second kind: S2(n,k) = S2(n-1,k-1) + k S2(n-1,k) -- S2(n,n) = 1, S2(n,1) = 1, S2(n,0) = Kronecker(n,0) + +-- done + +Note: [math::choose] does not take the bigints into account! + +More numbers: Fibonacci and Lucas numbers: +F(0) = 1, F(1) = 1, F(n+2) = F(n+1) + F(n) +L(0) = 1, L(1) = 3, L(n+2) = L(n+1) + L(n) + +dd. 23 november 2020 +Add new procs by Manfred Rosenberger +Clean up some of the code (notably the synonyms) + + +dd. 2 november 2020 +Generate the actual combinations - in math::combinatinatorics + - take struct::list as an example!! + + +dd. 20 september 2020 +Incorporate suggestions by Manfred Rosenberger for the geometry package - done + +dd. 16 august 2020 +Statistics: +Based on article by Dennis Helsel: +- Shapiro-Wilk or Anderson-Darling? +- mean according to Kaplan-Meier +- Box-Cox transformation + + +dd. 17 april 2020 +Issue with the totient function: +https://core.tcl-lang.org/tcllib/tktview?name=7017dad214 +Done + +dd. 6 february 2020 +- Implement accelerations for infinite sums: + - Method described on Wolfram + - Method for alternating series from the book + +dd. 9 february +http://numbers.computation.free.fr/Constants/Miscellaneous/seriesacceleration.html +- provides an overview +https://arxiv.org/pdf/math/0202009.pdf +- also interesting +https://www.cis.twcu.ac.jp/~osada/thesis_osada.pdf +- thesis +https://kconrad.math.uconn.edu/blurbs/analysis/series_acceleration.pdf +- yet another article + +dd. 4 november 2019 +- Extend the set of test cases for linear interpolation with corner cases + - these should fail with a clear error message. + +dd. 4 september 2018 +- Implement a "typical profile" for timeseries and determining residuals + (Plus perhaps a notion of outliers) +- Implement detection of extreme values/periods with extreme values + + +dd. 17 june 2018 +- Factor out the backward rotation in the intersection routines for circles +- Add a normalisation routine for vectors +- Add routines to construct a perpendicular vector and line +- Add a routine to return the perpendicular bisector of a line segment +- Add routines to deal with triangles (incircle, circumcircle) +- Add various other geometrical procs + +- Add documentation of the new procs + +dd. 12 june 2018 +- Create a complex number based on modulus and argument + +dd. 24 january 2018 +- Implement plot positions for ranking in statistics package +- Implement a bootstrap method for selecting "new" samples +- Implement maximum likelihood methods for various distributions + (exponential, normal and binomial are simple enough). Partly esthetical. + +dd. 29 may 2017 +- Implement Kronecker symbol (extension of Jacobi symbol) + +dd. 8 january 2017 +- Fix problem with test-anova-F (at least the test cases 1.1 and 1.2) - done + + +dd. 3 august 2016 +- Fix problem in interpolation - integer arguments - done +- Fix problem in pdf-lognormal and cdf-lognormal: stdev is now used as variance - done + +dd. 4 august 2016 +- Add test case for permuted linear system - done +- Add test case for pdf-lognormal and cdf-lognormal (non-unity standard deviation) - done + + + +dd. 11 april 2016 +Fix problem in math::geometry::pointInsidePolygon (Eduard on comp.lang.tcl): + +% set polygon "-764 -677 -668 -1341 -124 -797 -508 -406" +-764 -677 -668 -1341 -124 -797 -508 -406 +% set point "838 456" +838 456 +% package require math::geometry +1.1.3 +% ::math::geometry::pointInsidePolygon $point $polygon +1 + +Possible solution at: https://www.ecse.rpi.edu/~wrf/Research/Short_Notes/pnpoly.html + +I fixed the calculation of the point far away - but I want an edge case or two extra! + + +dd. 10 november 2015, Arjen Markus +Implement Box-Cox and Fisher's F test + +Note: Fisher's F test implemented as test-anova-F + +dd. 28 october 2015, Arjen Markus +Implement Dunnett's test for means and Levene's test for standard deviations + + +dd. 1 october 2015, Arjen Markus +Implement the following geometrical functions: +inproduct, crossProduct, areaParallellogram, unitVector, translate, rotate, rotateGeneral, reflect, reflectGeneral, +angleBetween, affine, degToRad, radToDeg, mkAffine + +circles and triangles + +Still to be implemented: +unitVector, rotateGeneral, reflectGeneral, affine, mkAffine + +don't use lset, but lappend instead? + +Describe the procedures + +Implement tests + +dd. 9 september 2015, Arjen Markus +Implement an inverse Student's t function - based on cephes library (cprob.tgz) + +dd. 29 may 2015, Arjen Markus +- implement a wavelets module +- small stuff: create a proc that constructs a piece-wise linear function from a specification + +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/vendor/math/bessel.tcl b/vendor/math/bessel.tcl new file mode 100644 index 00000000..811f242c --- /dev/null +++ b/vendor/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/vendor/math/bessel.test b/vendor/math/bessel.test new file mode 100644 index 00000000..700cc891 --- /dev/null +++ b/vendor/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.5;# 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/vendor/math/bigfloat.man b/vendor/math/bigfloat.man new file mode 100644 index 00000000..34fe0e21 --- /dev/null +++ b/vendor/math/bigfloat.man @@ -0,0 +1,433 @@ +[vset VERSION 2.0.4] +[manpage_begin math::bigfloat n [vset VERSION]] +[keywords computations] +[keywords floating-point] +[keywords interval] +[keywords math] +[keywords multiprecision] +[keywords tcl] +[copyright {2004-2008, by Stephane Arnold }] +[moddesc {Tcl Math Library}] +[titledesc {Arbitrary precision floating-point numbers}] +[category Mathematics] +[require Tcl 8.5] +[require math::bigfloat [opt [vset VERSION]]] + +[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 ../common-text/feedback.inc] +[manpage_end] diff --git a/vendor/math/bigfloat.tcl b/vendor/math/bigfloat.tcl new file mode 100644 index 00000000..f6f5febe --- /dev/null +++ b/vendor/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 yahoo.fr). +# The following terms apply to all files associated +# with the software unless explicitly disclaimed in individual files. +# +# The authors hereby grant permission to use, copy, modify, distribute, +# and license this software and its documentation for any purpose, provided +# that existing copyright notices are retained in all copies and that this +# notice is included verbatim in any distributions. No written agreement, +# license, or royalty fee is required for any of the authorized uses. +# Modifications to this software may be copyrighted by their authors +# and need not follow the licensing terms described here, provided that +# the new terms are clearly indicated on the first page of each file where +# they apply. +# +# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY +# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY +# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. +# +# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE +# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE +# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +# MODIFICATIONS. +# +# GOVERNMENT USE: If you are acquiring this software on behalf of the +# U.S. government, the Government shall have only "Restricted Rights" +# in the software and related documentation as defined in the Federal +# Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you +# are acquiring the software on behalf of the Department of Defense, the +# software shall be classified as "Commercial Computer Software" and the +# Government shall have only "Restricted Rights" as defined in Clause +# 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the +# authors grant the U.S. Government and others acting in its behalf +# permission to use and distribute the software in accordance with the +# terms specified in this license. +# +######################################################################## + +package require Tcl 8.4 +package require math::bignum + +# this line helps when I want to source this file again and again +catch {namespace delete ::math::bigfloat} + +# private namespace +# this software works only with Tcl v8.4 and higher +# it is using the package math::bignum +namespace eval ::math::bigfloat { + # cached constants + # ln(2) with arbitrary precision + variable Log2 + # Pi with arb. precision + variable Pi + variable _pi0 + # some constants (bignums) : {0 1 2 3 4 5 10} + variable zero + set zero [::math::bignum::fromstr 0] + variable one + set one [::math::bignum::fromstr 1] + variable two + set two [::math::bignum::fromstr 2] + variable three + set three [::math::bignum::fromstr 3] + variable four + set four [::math::bignum::fromstr 4] + variable five + set five [::math::bignum::fromstr 5] + variable ten + set ten [::math::bignum::fromstr 10] +} + + + + +################################################################################ +# procedures that handle floating-point numbers +# these procedures are sorted by name (after eventually removing the underscores) +# +# BigFloats are internally represented as a list : +# {"F" Mantissa Exponent Delta} where "F" is a character which determins +# the datatype, Mantissa and Delta are two Big integers and Exponent a raw integer. +# +# The BigFloat value equals to (Mantissa +/- Delta)*2^Exponent +# So the internal representation is binary, but trying to get as close as possible to +# the decimal one. +# When calling fromstr, the Delta parameter is set to the value of the last decimal digit. +# Example : 1.50 belongs to [1.49,1.51], but internally Delta is probably not equal to 1, +# because of the binary representation. +# +# So Mantissa and Delta are not limited in size, but in practice Delta is kept under +# 2^32 by the 'normalize' procedure, to avoid a never-ended growth of memory used. +# Indeed, when you perform some computations, the Delta parameter (which represent +# the uncertainty on the value of the Mantissa) may increase. +# Exponent, as a classic integer, is limited to the interval [-2147483648,2147483647] + +# Retrieving the parameters of a BigFloat is often done with that command : +# foreach {dummy int exp delta} $bigfloat {break} +# (dummy is not used, it is just used to get the "F" marker). +# The isInt, isFloat, checkNumber and checkFloat procedures are used +# to check data types +# +# Taylor development are often used to compute the analysis functions (like exp(),log()...) +# To learn how it is done in practice, take a look at ::math::bigfloat::_asin +# While doing computation on Mantissas, we do not care about the last digit, +# because if we compute wisely Deltas, the digits that remain will be exact. +################################################################################ + + +################################################################################ +# returns the absolute value +################################################################################ +proc ::math::bigfloat::abs {number} { + checkNumber number + if {[isInt $number]} { + # set sign to positive for a BigInt + return [::math::bignum::abs $number] + } + # set sign to positive for a BigFloat into the Mantissa (index 1) + lset number 1 [::math::bignum::abs [lindex $number 1]] + return $number +} + + +################################################################################ +# arccosinus of a BigFloat +################################################################################ +proc ::math::bigfloat::acos {x} { + # handy proc for checking datatype + checkFloat x + foreach {dummy entier exp delta} $x {break} + set precision [expr {($exp<0)?(-$exp):1}] + # acos(0.0)=Pi/2 + # 26/07/2005 : changed precision from decimal to binary + # with the second parameter of pi command + set piOverTwo [floatRShift [pi $precision 1]] + if {[iszero $x]} { + # $x is too close to zero -> acos(0)=PI/2 + return $piOverTwo + } + # acos(-x)= Pi/2 + asin(x) + if {[::math::bignum::sign $entier]} { + return [add $piOverTwo [asin [abs $x]]] + } + # we always use _asin to compute the result + # but as it is a Taylor development, the value given to [_asin] + # has to be a bit smaller than 1 ; by using that trick : acos(x)=asin(sqrt(1-x^2)) + # we can limit the entry of the Taylor development below 1/sqrt(2) + if {[compare $x [fromstr 0.7071]]>0} { + # x > sqrt(2)/2 : trying to make _asin converge quickly + # creating 0 and 1 with the same precision as the entry + variable one + variable zero + set fzero [list F $zero -$precision $one] + set fone [list F [::math::bignum::lshift 1 $precision] \ + -$precision $one] + # when $x is close to 1 (acos(1.0)=0.0) + if {[equal $fone $x]} { + return $fzero + } + if {[compare $fone $x]<0} { + # the behavior assumed because acos(x) is not defined + # when |x|>1 + error "acos on a number greater than 1" + } + # acos(x) = asin(sqrt(1 - x^2)) + # since 1 - cos(x)^2 = sin(x)^2 + # x> sqrt(2)/2 so x^2 > 1/2 so 1-x^2<1/2 + set x [sqrt [sub $fone [mul $x $x]]] + # the parameter named x is smaller than sqrt(2)/2 + return [_asin $x] + } + # acos(x) = Pi/2 - asin(x) + # x$expB} { + set diff [expr {$expA-$expB}] + set integerA [::math::bignum::lshift $integerA $diff] + set deltaA [::math::bignum::lshift $deltaA $diff] + set integerA [::math::bignum::add $integerA $integerB] + set deltaA [::math::bignum::add $deltaA $deltaB] + return [normalize [list F $integerA $expB $deltaA]] + } elseif {$expA==$expB} { + # nothing to shift left + return [normalize [list F [::math::bignum::add $integerA $integerB] \ + $expA [::math::bignum::add $deltaA $deltaB]]] + } else { + set diff [expr {$expB-$expA}] + set integerB [::math::bignum::lshift $integerB $diff] + set deltaB [::math::bignum::lshift $deltaB $diff] + set integerB [::math::bignum::add $integerA $integerB] + set deltaB [::math::bignum::add $deltaB $deltaA] + return [normalize [list F $integerB $expA $deltaB]] + } +} + +################################################################################ +# returns the sum A(BigFloat) + B(BigInt) +# the greatest advantage of this method is that the uncertainty +# of the result remains unchanged, in respect to the entry's uncertainty (deltaA) +################################################################################ +proc ::math::bigfloat::addInt2Float {a b} { + # type checking + checkFloat a + if {![isInt $b]} { + error "'$b' is not a BigInt" + } + # retrieving data from $a + foreach {dummy integerA expA deltaA} $a {break} + # to add an int to a BigFloat,... + if {$expA>0} { + # we have to put the integer integerA + # to the level of zero exponent : 1e8 --> 100000000e0 + set shift $expA + set integerA [::math::bignum::lshift $integerA $shift] + set deltaA [::math::bignum::lshift $deltaA $shift] + set integerA [::math::bignum::add $integerA $b] + # we have to normalize, because we have shifted the mantissa + # and the uncertainty left + return [normalize [list F $integerA 0 $deltaA]] + } elseif {$expA==0} { + # integerA is already at integer level : float=(integerA)e0 + return [normalize [list F [::math::bignum::add $integerA $b] \ + 0 $deltaA]] + } else { + # here we have something like 234e-2 + 3 + # we have to shift the integer left by the exponent |$expA| + set b [::math::bignum::lshift $b [expr {-$expA}]] + set integerA [::math::bignum::add $integerA $b] + return [normalize [list F $integerA $expA $deltaA]] + } +} + + +################################################################################ +# arcsinus of a BigFloat +################################################################################ +proc ::math::bigfloat::asin {x} { + # type checking + checkFloat x + foreach {dummy entier exp delta} $x {break} + if {$exp>-1} { + error "not enough precision on input (asin)" + } + set precision [expr {-$exp}] + # when x=0, return 0 at the same precision as the input was + if {[iszero $x]} { + variable one + variable zero + return [list F $zero -$precision $one] + } + # asin(-x)=-asin(x) + if {[::math::bignum::sign $entier]} { + return [opp [asin [abs $x]]] + } + # 26/07/2005 : changed precision from decimal to binary + set piOverTwo [floatRShift [pi $precision 1]] + # now a little trick : asin(x)=Pi/2-asin(sqrt(1-x^2)) + # so we can limit the entry of the Taylor development + # to 1/sqrt(2)~0.7071 + # the comparison is : if x>0.7071 then ... + if {[compare $x [fromstr 0.7071]]>0} { + variable one + set fone [list F [::math::bignum::lshift 1 $precision] \ + -$precision $one] + # asin(1)=Pi/2 (with the same precision as the entry has) + if {[equal $fone $x]} { + return $piOverTwo + } + if {[compare $x $fone]>0} { + error "asin on a number greater than 1" + } + # asin(x)=Pi/2-asin(sqrt(1-x^2)) + set x [sqrt [sub $fone [mul $x $x]]] + return [sub $piOverTwo [_asin $x]] + } + return [normalize [_asin $x]] +} + +################################################################################ +# _asin : arcsinus of numbers between 0 and +1 +################################################################################ +proc ::math::bigfloat::_asin {x} { + # Taylor development + # asin(x)=x + 1/2 x^3/3 + 3/2.4 x^5/5 + 3.5/2.4.6 x^7/7 + ... + # into this iterative form : + # asin(x)=x * (1 + 1/2 * x^2 * (1/3 + 3/4 *x^2 * (... + # ...* (1/(2n-1) + (2n-1)/2n * x^2 / (2n+1))...))) + # we show how is really computed the development : + # we don't need to set a var with x^n or a product of integers + # all we need is : x^2, 2n-1, 2n, 2n+1 and a few variables + foreach {dummy mantissa exp delta} $x {break} + set precision [expr {-$exp}] + if {$precision+1<[::math::bignum::bits $mantissa]} { + error "sinus greater than 1" + } + # precision is the number of after-dot digits + set result $mantissa + set delta_final $delta + # resultat is the final result, and delta_final + # will contain the uncertainty of the result + # square is the square of the mantissa + set square [intMulShift $mantissa $mantissa $precision] + # dt is the uncertainty of Mantissa + set dt [::math::bignum::add 1 [intMulShift $mantissa $delta [expr {$precision-1}]]] + # these three are required to compute the fractions implicated into + # the development (of Taylor, see former) + variable one + set num $one + # two will be used into the loop + variable two + variable three + set i $three + set denom $two + # the nth factor equals : $num/$denom* $mantissa/$i + set delta [::math::bignum::add [::math::bignum::mul $delta $square] \ + [::math::bignum::mul $dt [::math::bignum::add $delta $mantissa]]] + set delta [::math::bignum::add 1 [::math::bignum::rshift [::math::bignum::div \ + [::math::bignum::mul $delta $num] $denom] $precision]] + # we do not multiply the Mantissa by $num right now because it is 1 ! + # but we have Mantissa=$x + # and we want Mantissa*$x^2 * $num / $denom / $i + set mantissa [intMulShift $mantissa $square $precision] + set mantissa [::math::bignum::div $mantissa $denom] + # do not forget the modified Taylor development : + # asin(x)=x * (1 + 1/2*x^2*(1/3 + 3/4*x^2*(...*(1/(2n-1) + (2n-1)/2n*x^2/(2n+1))...))) + # all we need is : x^2, 2n-1, 2n, 2n+1 and a few variables + # $num=2n-1 $denom=2n $square=x^2 and $i=2n+1 + set mantissa_temp [::math::bignum::div $mantissa $i] + set delta_temp [::math::bignum::add 1 [::math::bignum::div $delta $i]] + # when the Mantissa increment is smaller than the Delta increment, + # we would not get much precision by continuing the development + while {![::math::bignum::iszero $mantissa_temp]} { + # Mantissa = Mantissa * $num/$denom * $square + # Add Mantissa/$i, which is stored in $mantissa_temp, to the result + set result [::math::bignum::add $result $mantissa_temp] + set delta_final [::math::bignum::add $delta_final $delta_temp] + # here we have $two instead of [fromstr 2] (optimization) + # num=num+2,i=i+2,denom=denom+2 + # because num=2n-1 denom=2n and i=2n+1 + set num [::math::bignum::add $num $two] + set i [::math::bignum::add $i $two] + set denom [::math::bignum::add $denom $two] + # computes precisly the future Delta parameter + set delta [::math::bignum::add [::math::bignum::mul $delta $square] \ + [::math::bignum::mul $dt [::math::bignum::add $delta $mantissa]]] + set delta [::math::bignum::add 1 [::math::bignum::rshift [::math::bignum::div \ + [::math::bignum::mul $delta $num] $denom] $precision]] + set mantissa [intMulShift $mantissa $square $precision] + set mantissa [::math::bignum::div [::math::bignum::mul $mantissa $num] $denom] + set mantissa_temp [::math::bignum::div $mantissa $i] + set delta_temp [::math::bignum::add 1 [::math::bignum::div $delta $i]] + } + return [list F $result $exp $delta_final] +} + +################################################################################ +# arctangent : returns atan(x) +################################################################################ +proc ::math::bigfloat::atan {x} { + checkFloat x + variable one + variable two + variable three + variable four + variable zero + foreach {dummy mantissa exp delta} $x {break} + if {$exp>=0} { + error "not enough precision to compute atan" + } + set precision [expr {-$exp}] + # atan(0)=0 + if {[iszero $x]} { + return [list F $zero -$precision $one] + } + # atan(-x)=-atan(x) + if {[::math::bignum::sign $mantissa]} { + return [opp [atan [abs $x]]] + } + # now x is strictly positive + # at this moment, we are trying to limit |x| to a fair acceptable number + # to ensure that Taylor development will converge quickly + set float1 [list F [::math::bignum::lshift 1 $precision] -$precision $one] + if {[compare $float1 $x]<0} { + # compare x to 2.4142 + if {[compare $x [fromstr 2.4142]]<0} { + # atan(x)=Pi/4 + atan((x-1)/(x+1)) + # as 10} { + # atan(x)=Pi/4 + atan((x-1)/(x+1)) + # x>0.420 so (x-1)/(x+1)=1 - 2/(x+1) > 1-2/1.414 + # > -0.414 + # x<1 so (x-1)/(x+1)<0 + set pi_sur_quatre [div [pi $precision 1] $four] + return [add $pi_sur_quatre [atan \ + [div [sub $x $float1] [add $x $float1]]]] + } + # precision increment : to have less uncertainty + # we add a little more precision so that the result would be more accurate + # Taylor development : x - x^3/3 + x^5/5 - ... + (-1)^(n+1)*x^(2n-1)/(2n-1) + # when we have n steps in Taylor development : the nth term is : + # x^(2n-1)/(2n-1) + # and the loss of precision is of 2n (n sums and n divisions) + # this command is called with x(precision-3/2)*log(2)-log(2n-1) + # hence log(2n-1)<2n-1 + # n*sqrt(2)>(precision-1.5)*log(2)+1-2n + # n*(sqrt(2)+2)>(precision-1.5)*log(2)+1 + set n [expr {int((log(2)*($precision-1.5)+1)/(sqrt(2)+2)+1)}] + incr precision $n + set mantissa [::math::bignum::lshift $mantissa $n] + set delta [::math::bignum::lshift $delta $n] + # end of adding precision increment + # now computing Taylor development : + # atan(x)=x - x^3/3 + x^5/5 - x^7/7 ... + (-1)^n*x^(2n+1)/(2n+1) + # atan(x)=x * (1 - x^2 * (1/3 - x^2 * (1/5 - x^2 * (...*(1/(2n-1) - x^2 / (2n+1))...)))) + # what do we need to compute this ? + # x^2 ($square), 2n+1 ($divider), $result, the nth term of the development ($t) + # and the nth term multiplied by 2n+1 ($temp) + # then we do this (with care keeping as much precision as possible): + # while ($t <>0) : + # $result=$result+$t + # $temp=$temp * $square + # $divider = $divider+2 + # $t=$temp/$divider + # end-while + set result $mantissa + set delta_end $delta + # we store the square of the integer (mantissa) + set delta_square [::math::bignum::lshift $delta 1] + set square [intMulShift $mantissa $mantissa $precision] + # the (2n+1) divider + set divider $three + # computing precisely the uncertainty + set delta [::math::bignum::add 1 [::math::bignum::rshift [::math::bignum::add \ + [::math::bignum::mul $delta_square $mantissa] \ + [::math::bignum::mul $delta $square]] $precision]] + # temp contains (-1)^n*x^(2n+1) + set temp [opp [intMulShift $mantissa $square $precision]] + set t [::math::bignum::div $temp $divider] + set dt [::math::bignum::add 1 [::math::bignum::div $delta $divider]] + while {![::math::bignum::iszero $t]} { + set result [::math::bignum::add $result $t] + set delta_end [::math::bignum::add $delta_end $dt] + set divider [::math::bignum::add $divider $two] + set delta [::math::bignum::add 1 [::math::bignum::rshift [::math::bignum::add \ + [::math::bignum::mul $delta_square [abs $temp]] [::math::bignum::mul $delta \ + [::math::bignum::add $delta_square $square]]] $precision]] + set temp [opp [intMulShift $temp $square $precision]] + set t [::math::bignum::div $temp $divider] + set dt [::math::bignum::add [::math::bignum::div $delta $divider] $one] + } + # we have to normalize because the uncertainty might be greater than 99 + # moreover it is the most often case + return [normalize [list F $result [expr {$exp-$n}] $delta_end]] +} + + +################################################################################ +# compute atan(1/integer) at a given precision +# this proc is only used to compute Pi +# it is using the same Taylor development as [atan] +################################################################################ +proc ::math::bigfloat::_atanfract {integer precision} { + # Taylor development : x - x^3/3 + x^5/5 - ... + (-1)^(n+1)*x^(2n-1)/(2n-1) + # when we have n steps in Taylor development : the nth term is : + # 1/denom^(2n+1)/(2n+1) + # and the loss of precision is of 2n (n sums and n divisions) + # this command is called with integer>=5 + # + # We do not want to compute the Delta parameter, so we just + # can increment precision (with lshift) in order for the result to be precise. + # Remember : we compute atan2(1,$integer) with $precision bits + # $integer has no Delta parameter as it is a BigInt, of course, so + # theorically we could compute *any* number of digits. + # + # if we add an increment to the precision, say n: + # (1/5)^(2n-1)/(2n-1) has to be lower than (1/2)^(precision+n-1) + # Calculus : + # log(left term) < log(right term) + # log(1/left term) > log(1/right term) + # (2n-1)*log(5)+log(2n-1)>(precision+n-1)*log(2) + # n(2log(5)-log(2))>(precision-1)*log(2)-log(2n-1)+log(5) + # -log(2n-1)>-(2n-1) + # n(2log(5)-log(2)+2)>(precision-1)*log(2)+1+log(5) + set n [expr {int((($precision-1)*log(2)+1+log(5))/(2*log(5)-log(2)+2)+1)}] + incr precision $n + # first term of the development : 1/integer + set a [::math::bignum::div [::math::bignum::lshift 1 $precision] $integer] + # 's' will contain the result + set s $a + # Taylor development : x - x^3/3 + x^5/5 - ... + (-1)^(n+1)*x^(2n-1)/(2n-1) + # equals x (1 - x^2 * (1/3 + x^2 * (... * (1/(2n-3) + (-1)^(n+1) * x^2 / (2n-1))...))) + # all we need to store is : 2n-1 ($denom), x^(2n+1) and x^2 ($square) and two results : + # - the nth term => $u + # - the nth term * (2n-1) => $t + # + of course, the result $s + set square [::math::bignum::mul $integer $integer] + variable two + variable three + set denom $three + # $t is (-1)^n*x^(2n+1) + set t [opp [::math::bignum::div $a $square]] + set u [::math::bignum::div $t $denom] + # we break the loop when the current term of the development is null + while {![::math::bignum::iszero $u]} { + set s [::math::bignum::add $s $u] + # denominator= (2n+1) + set denom [::math::bignum::add $denom $two] + # div $t by x^2 + set t [opp [::math::bignum::div $t $square]] + set u [::math::bignum::div $t $denom] + } + # go back to the initial precision + return [::math::bignum::rshift $s $n] +} + + +################################################################################ +# returns the integer part of a BigFloat, as a BigInt +# the result is the same one you would have +# if you had called [expr {ceil($x)}] +################################################################################ +proc ::math::bigfloat::ceil {number} { + checkFloat number + set number [normalize $number] + if {[iszero $number]} { + # returns the BigInt 0 + variable zero + return $zero + } + foreach {dummy integer exp delta} $number {break} + if {$exp>=0} { + error "not enough precision to perform rounding (ceil)" + } + # saving the sign ... + set sign [::math::bignum::sign $integer] + set integer [abs $integer] + # integer part + set try [::math::bignum::rshift $integer [expr {-$exp}]] + if {$sign} { + return [opp $try] + } + # fractional part + if {![equal [::math::bignum::lshift $try [expr {-$exp}]] $integer]} { + return [::math::bignum::add 1 $try] + } + return $try +} + + +################################################################################ +# checks each variable to be a BigFloat +# arguments : each argument is the name of a variable to be checked +################################################################################ +proc ::math::bigfloat::checkFloat {args} { + foreach x $args { + upvar $x n + if {![isFloat $n]} { + error "BigFloat expected : received '$n'" + } + } +} + +################################################################################ +# checks if each number is either a BigFloat or a BigInt +# arguments : each argument is the name of a variable to be checked +################################################################################ +proc ::math::bigfloat::checkNumber {args} { + foreach i $args { + upvar $i x + if {![isInt $x] && ![isFloat $x]} { + error "'$x' is not a number" + } + } +} + + +################################################################################ +# returns 0 if A and B are equal, else returns 1 or -1 +# accordingly to the sign of (A - B) +################################################################################ +proc ::math::bigfloat::compare {a b} { + if {[isInt $a] && [isInt $b]} { + return [::math::bignum::cmp $a $b] + } + checkFloat a b + if {[equal $a $b]} {return 0} + return [expr {([::math::bignum::sign [lindex [sub $a $b] 1]])?-1:1}] +} + + + + +################################################################################ +# gets cos(x) +# throws an error if there is not enough precision on the input +################################################################################ +proc ::math::bigfloat::cos {x} { + checkFloat x + foreach {dummy integer exp delta} $x {break} + if {$exp>-2} { + error "not enough precision on floating-point number" + } + set precision [expr {-$exp}] + # cos(2kPi+x)=cos(x) + foreach {n integer} [divPiQuarter $integer $precision] {break} + # now integer>=0 and exp (multiplied by -1) + lset l 1 [expr {-([lindex $l 1])}] + # set the sign + set integer [lindex $l 0] + ::math::bignum::setsign integer $signe + lset l 0 $integer + return [normalize [linsert $l 0 F]] +} + +################################################################################ +# compute cos(x) where 0<=x=0} { + # cos(Pi/2-x)=sin(x) + set x [::math::bignum::sub $pis2 $x] + set delta [::math::bignum::add 1 $delta] + return [_sin $x $precision $delta] + } + return [_cos $x $precision $delta] +} + +################################################################################ +# compute cos(x) where 0<=x0} { + # swap BMin and BMax + set temp $BMin + set BMin $BMax + set BMax $temp + } + # multiply by zero gives zero + if {[::math::bignum::iszero $integerA]} { + # why not return any number or the integer 0 ? + # because there is an exponent that might be different between two BigFloats + # 0.00 --> exp = -2, 0.000000 -> exp = -6 + return $a + } + # test of the division by zero + if {[::math::bignum::sign $BMin]+[::math::bignum::sign $BMax]==1 || \ + [::math::bignum::iszero $BMin] || [::math::bignum::iszero $BMax]} { + error "divide by zero" + } + # shift A because we need accuracy + set l [math::bignum::bits $integerB] + set integerA [::math::bignum::lshift $integerA $l] + set deltaA [::math::bignum::lshift $deltaA $l] + set exp [expr {$expA-$l-$expB}] + # relative uncertainties (dX/X) are added + # to give the relative uncertainty of the result + # i.e. 3% on A + 2% on B --> 5% on the quotient + # d(A/B)/(A/B)=dA/A + dB/B + # Q=A/B + # dQ=dA/B + dB*A/B*B + # dQ is "delta" + set delta [::math::bignum::div [::math::bignum::mul $deltaB \ + [abs $integerA]] [abs $integerB]] + set delta [::math::bignum::div [::math::bignum::add\ + [::math::bignum::add 1 $delta]\ + $deltaA] [abs $integerB]] + set quotient [::math::bignum::div $integerA $integerB] + if {[::math::bignum::sign $integerB]+[::math::bignum::sign $integerA]==1} { + set quotient [::math::bignum::sub $quotient 1] + } + return [normalize [list F $quotient $exp [::math::bignum::add $delta 1]]] +} + + + + +################################################################################ +# divide a BigFloat A by a BigInt B +# throw error : divide by zero +################################################################################ +proc ::math::bigfloat::divFloatByInt {a b} { + variable one + # type check + checkFloat a + if {![isInt $b]} { + error "'$b' is not a BigInt" + } + foreach {dummy integer exp delta} $a {break} + # zero divider test + if {[::math::bignum::iszero $b]} { + error "divide by zero" + } + # shift left for accuracy ; see other comments in [div] procedure + set l [::math::bignum::bits $b] + set integer [::math::bignum::lshift $integer $l] + set delta [::math::bignum::lshift $delta $l] + incr exp -$l + set integer [::math::bignum::div $integer $b] + # the uncertainty is always evaluated to the ceil value + # and as an absolute value + set delta [::math::bignum::add 1 [::math::bignum::div $delta [abs $b]]] + return [normalize [list F $integer $exp $delta]] +} + + + + + +################################################################################ +# returns 1 if A and B are equal, 0 otherwise +# IN : a, b (BigFloats) +################################################################################ +proc ::math::bigfloat::equal {a b} { + if {[isInt $a] && [isInt $b]} { + return [expr {[::math::bignum::cmp $a $b]==0}] + } + # now a & b should only be BigFloats + checkFloat a b + foreach {dummy aint aexp adelta} $a {break} + foreach {dummy bint bexp bdelta} $b {break} + # set all Mantissas and Deltas to the same level (exponent) + # with lshift + set diff [expr {$aexp-$bexp}] + if {$diff<0} { + set diff [expr {-$diff}] + set bint [::math::bignum::lshift $bint $diff] + set bdelta [::math::bignum::lshift $bdelta $diff] + } elseif {$diff>0} { + set aint [::math::bignum::lshift $aint $diff] + set adelta [::math::bignum::lshift $adelta $diff] + } + # compute limits of the number's doubt range + set asupInt [::math::bignum::add $aint $adelta] + set ainfInt [::math::bignum::sub $aint $adelta] + set bsupInt [::math::bignum::add $bint $bdelta] + set binfInt [::math::bignum::sub $bint $bdelta] + # A & B are equal + # if their doubt ranges overlap themselves + if {[::math::bignum::cmp $bint $aint]==0} { + return 1 + } + if {[::math::bignum::cmp $bint $aint]>0} { + set r [expr {[::math::bignum::cmp $asupInt $binfInt]>=0}] + } else { + set r [expr {[::math::bignum::cmp $bsupInt $ainfInt]>=0}] + } + return $r +} + +################################################################################ +# returns exp(X) where X is a BigFloat +################################################################################ +proc ::math::bigfloat::exp {x} { + checkFloat x + foreach {dummy integer exp delta} $x {break} + if {$exp>=0} { + # shift till exp<0 with respect to the internal representation + # of the number + incr exp + set integer [::math::bignum::lshift $integer $exp] + set delta [::math::bignum::lshift $delta $exp] + set exp -1 + } + set precision [expr {-$exp}] + # add 8 bits of precision for safety + incr precision 8 + set integer [::math::bignum::lshift $integer 8] + set delta [::math::bignum::lshift $delta 8] + set Log2 [_log2 $precision] + foreach {new_exp integer} [::math::bignum::divqr $integer $Log2] {break} + # new_exp = integer part of x/log(2) + # integer = remainder + # exp(K.log(2)+r)=2^K.exp(r) + # so we just have to compute exp(r), r is small so + # the Taylor development will converge quickly + set delta [::math::bignum::add $delta $new_exp] + foreach {integer delta} [_exp $integer $precision $delta] {break} + set delta [::math::bignum::rshift $delta 8] + incr precision -8 + # multiply by 2^K , and take care of the sign + # example : X=-6.log(2)+0.01 + # exp(X)=exp(0.01)*2^-6 + if {![::math::bignum::iszero [::math::bignum::rshift [abs $new_exp] 30]]} { + error "floating-point overflow due to exp" + } + set new_exp [tostr $new_exp] + set exp [expr {$new_exp-$precision}] + set delta [::math::bignum::add 1 $delta] + return [normalize [list F [::math::bignum::rshift $integer 8] $exp $delta]] +} + + +################################################################################ +# private procedure to compute exponentials +# using Taylor development of exp(x) : +# exp(x)=1+ x + x^2/2 + x^3/3! +...+x^n/n! +# input : integer (the mantissa) +# precision (the number of decimals) +# delta (the doubt limit, or uncertainty) +# returns a list : 1. the mantissa of the result +# 2. the doubt limit, or uncertainty +################################################################################ +proc ::math::bigfloat::_exp {integer precision delta} { + set oneShifted [::math::bignum::lshift 1 $precision] + if {[::math::bignum::iszero $integer]} { + # exp(0)=1 + return [list $oneShifted $delta] + } + set s [::math::bignum::add $oneShifted $integer] + variable two + set d [::math::bignum::add 1 [::math::bignum::div $delta $two]] + set delta [::math::bignum::add $delta $delta] + # dt = uncertainty on x^2 + set dt [::math::bignum::add 1 [intMulShift $d $integer $precision]] + # t= x^2/2 + set t [intMulShift $integer $integer $precision] + set t [::math::bignum::div $t $two] + set denom $two + while {![::math::bignum::iszero $t]} { + # the sum is called 's' + set s [::math::bignum::add $s $t] + set delta [::math::bignum::add $delta $dt] + # we do not have to keep trace of the factorial, we just iterate divisions + set denom [::math::bignum::add 1 $denom] + # add delta + set d [::math::bignum::add 1 [::math::bignum::div $d $denom]] + set dt [::math::bignum::add $dt $d] + # get x^n from x^(n-1) + set t [intMulShift $integer $t $precision] + # here we divide + set t [::math::bignum::div $t $denom] + } + return [list $s $delta] +} +################################################################################ +# divide a BigFloat by 2 power 'n' +################################################################################ +proc ::math::bigfloat::floatRShift {float {n 1}} { + return [lset float 2 [expr {[lindex $float 2]-$n}]] +} + + + +################################################################################ +# procedure floor : identical to [expr floor($x)] in functionality +# arguments : number IN (a BigFloat) +# returns : the floor value as a BigInt +################################################################################ +proc ::math::bigfloat::floor {number} { + variable zero + checkFloat number + set number [normalize $number] + if {[::math::bignum::iszero $number]} { + # returns the BigInt 0 + return $zero + } + foreach {dummy integer exp delta} $number {break} + if {$exp>=0} { + error "not enough precision to perform rounding (floor)" + } + # saving the sign ... + set sign [::math::bignum::sign $integer] + set integer [abs $integer] + # integer part + set try [::math::bignum::rshift $integer [expr {-$exp}]] + # floor(n.xxxx)=n + if {!$sign} { + return $try + } + # floor(-n.xxxx)=-(n+1) when xxxx!=0 + if {![equal [::math::bignum::lshift $try [expr {-$exp}]] $integer]} { + set try [::math::bignum::add 1 $try] + } + ::math::bignum::setsign try $sign + return $try +} + + +################################################################################ +# returns a list formed by an integer and an exponent +# x = (A +/- C) * 10 power B +# return [list "F" A B C] (where F is the BigFloat tag) +# A and C are BigInts, B is a raw integer +# return also a BigInt when there is neither a dot, nor a 'e' exponent +# +# arguments : -base base integer +# or integer +# or float +# or float trailingZeros +################################################################################ +proc ::math::bigfloat::fromstr {args} { + if {[set string [lindex $args 0]]=="-base"} { + if {[llength $args]!=3} { + error "should be : fromstr -base base number" + } + # converts an integer i expressed in base b with : [fromstr b i] + return [::math::bignum::fromstr [lindex $args 2] [lindex $args 1]] + } + # trailingZeros are zeros appended to the Mantissa (it is optional) + set trailingZeros 0 + if {[llength $args]==2} { + set trailingZeros [lindex $args 1] + } + if {$trailingZeros<0} { + error "second argument has to be a positive integer" + } + # eliminate the sign problem + # added on 05/08/2005 + # setting '$signe' to the sign of the number + set string [string trimleft $string +] + if {[string index $string 0]=="-"} { + set signe 1 + set string2 [string range $string 1 end] + } else { + set signe 0 + set string2 $string + } + # integer case (not a floating-point number) + if {[string is digit $string2]} { + if {$trailingZeros!=0} { + error "second argument not allowed with an integer" + } + # we have completed converting an integer to a BigInt + # please note that most math::bigfloat procs accept BigInts as arguments + return [::math::bignum::fromstr $string] + } + set string $string2 + # floating-point number : check for an exponent + # scientific notation + set tab [split $string e] + if {[llength $tab]>2} { + # there are more than one 'e' letter in the number + error "syntax error in number : $string" + } + if {[llength $tab]==2} { + set exp [lindex $tab 1] + # now exp can look like +099 so you need to handle octal numbers + # too bad... + # find the sign (if any?) + regexp {^[\+\-]?} $exp expsign + # trim the number with left-side 0's + set found [string length $expsign] + set exp $expsign[string trimleft [string range $exp $found end] 0] + set number [lindex $tab 0] + } else { + set exp 0 + set number [lindex $tab 0] + } + # a floating-point number may have a dot + set tab [split $number .] + if {[llength $tab]>2} {error "syntax error in number : $string"} + if {[llength $tab]==2} { + set number [join $tab ""] + # increment by the number of decimals (after the dot) + incr exp -[string length [lindex $tab 1]] + } + # this is necessary to ensure we can call fromstr (recursively) with + # the mantissa ($number) + if {![string is digit $number]} { + error "$number is not a number" + } + # take account of trailing zeros + incr exp -$trailingZeros + # multiply $number by 10^$trailingZeros + set number [::math::bignum::mul [::math::bignum::fromstr $number]\ + [tenPow $trailingZeros]] + ::math::bignum::setsign number $signe + # the F tags a BigFloat + # a BigInt in internal representation begins by the sign + # delta is 1 as a BigInt + return [_fromstr $number $exp] +} + +################################################################################ +# private procedure to transform decimal floats into binary ones +# IN : +# - number : a BigInt representing the Mantissa +# - exp : the decimal exponent (a simple integer) +# OUT : +# $number * 10^$exp, as the internal binary representation of a BigFloat +################################################################################ +proc ::math::bigfloat::_fromstr {number exp} { + variable one + variable five + if {$exp==0} { + return [list F $number 0 $one] + } + if {$exp>0} { + # mul by 10^exp, and by 2^4, then normalize + set number [::math::bignum::lshift $number 4] + set exponent [tenPow $exp] + set number [::math::bignum::mul $number $exponent] + # normalize number*2^-4 +/- 2^4*10^exponent + return [normalize [list F $number -4 [::math::bignum::lshift $exponent 4]]] + } + # now exp is negative or null + # the closest power of 2 to the 'exp'th power of ten, but greater than it + set binaryExp [expr {int(ceil(-$exp*log(10)/log(2)))+4}] + # then compute n * 2^binaryExp / 10^(-exp) + # (exp is negative) + # equals n * 2^(binaryExp+exp) / 5^(-exp) + set diff [expr {$binaryExp+$exp}] + if {$diff<0} { + error "internal error" + } + set fivePow [::math::bignum::pow $five [::math::bignum::fromstr [expr {-$exp}]]] + set number [::math::bignum::div [::math::bignum::lshift $number \ + $diff] $fivePow] + set delta [::math::bignum::div [::math::bignum::lshift 1 \ + $diff] $fivePow] + return [normalize [list F $number [expr {-$binaryExp}] [::math::bignum::add $delta 1]]] +} + + +################################################################################ +# fromdouble : +# like fromstr, but for a double scalar value +# arguments : +# double - the number to convert to a BigFloat +# exp (optional) - the total number of digits +################################################################################ +proc ::math::bigfloat::fromdouble {double {exp {}}} { + set mantissa [lindex [split $double e] 0] + # line added by SArnold on 05/08/2005 + set mantissa [string trimleft [string map {+ "" - ""} $mantissa] 0] + set precision [string length [string map {. ""} $mantissa]] + if { $exp != {} && [incr exp]>$precision } { + return [fromstr $double [expr {$exp-$precision}]] + } else { + # tests have failed : not enough precision or no exp argument + return [fromstr $double] + } +} + + +################################################################################ +# converts a BigInt into a BigFloat with a given decimal precision +################################################################################ +proc ::math::bigfloat::int2float {int {decimals 1}} { + # it seems like we need some kind of type handling + # very odd in this Tcl world :-( + if {![isInt $int]} { + error "first argument is not an integer" + } + if {$decimals<1} { + error "non-positive decimals number" + } + # the lowest number of decimals is 1, because + # [tostr [fromstr 10.0]] returns 10. + # (we lose 1 digit when converting back to string) + set int [::math::bignum::mul $int [tenPow $decimals]] + return [_fromstr $int [expr {-$decimals}]] + +} + + + +################################################################################ +# multiplies 'leftop' by 'rightop' and rshift the result by 'shift' +################################################################################ +proc ::math::bigfloat::intMulShift {leftop rightop shift} { + return [::math::bignum::rshift [::math::bignum::mul $leftop $rightop] $shift] +} + +################################################################################ +# returns 1 if x is a BigFloat, 0 elsewhere +################################################################################ +proc ::math::bigfloat::isFloat {x} { + # a BigFloat is a list of : "F" mantissa exponent delta + if {[llength $x]!=4} { + return 0 + } + # the marker is the letter "F" + if {[string equal [lindex $x 0] F]} { + return 1 + } + return 0 +} + +################################################################################ +# checks that n is a BigInt (a number create by math::bignum::fromstr) +################################################################################ +proc ::math::bigfloat::isInt {n} { + if {[llength $n]<3} { + return 0 + } + if {[string equal [lindex $n 0] bignum]} { + return 1 + } + return 0 +} + + + +################################################################################ +# returns 1 if x is null, 0 otherwise +################################################################################ +proc ::math::bigfloat::iszero {x} { + if {[isInt $x]} { + return [::math::bignum::iszero $x] + } + checkFloat x + # now we do some interval rounding : if a number's interval englobs 0, + # it is considered to be equal to zero + foreach {dummy integer exp delta} $x {break} + set integer [::math::bignum::abs $integer] + if {[::math::bignum::cmp $delta $integer]>=0} {return 1} + return 0 +} + + +################################################################################ +# compute log(X) +################################################################################ +proc ::math::bigfloat::log {x} { + checkFloat x + foreach {dummy integer exp delta} $x {break} + if {[::math::bignum::iszero $integer]||[::math::bignum::sign $integer]} { + error "zero logarithm error" + } + if {[iszero $x]} { + error "number is null" + } + set precision [::math::bignum::bits $integer] + # uncertainty of the logarithm + set delta [::math::bignum::add 1 [_logOnePlusEpsilon $delta $integer $precision]] + # we got : x = 1xxxxxx (binary number with 'precision' bits) * 2^exp + # we need : x = 0.1xxxxxx(binary) *2^(exp+precision) + incr exp $precision + foreach {integer deltaIncr} [_log $integer] {break} + set delta [::math::bignum::add $delta $deltaIncr] + # log(a * 2^exp)= log(a) + exp*log(2) + # result = log(x) + exp*log(2) + # as x<1 log(x)<0 but 'integer' (result of '_log') is the absolute value + # that is why we substract $integer to log(2)*$exp + set integer [::math::bignum::sub [::math::bignum::mul [_log2 $precision] \ + [set exp [::math::bignum::fromstr $exp]]] $integer] + set delta [::math::bignum::add $delta [abs $exp]] + return [normalize [list F $integer -$precision $delta]] +} + + +################################################################################ +# compute log(1-epsNum/epsDenom)=log(1-'epsilon') +# Taylor development gives -x -x^2/2 -x^3/3 -x^4/4 ... +# used by 'log' command because log(x+/-epsilon)=log(x)+log(1+/-(epsilon/x)) +# so the uncertainty equals abs(log(1-epsilon/x)) +# ================================================ +# arguments : +# epsNum IN (the numerator of epsilon) +# epsDenom IN (the denominator of epsilon) +# precision IN (the number of bits after the dot) +# +# 'epsilon' = epsNum*2^-precision/epsDenom +################################################################################ +proc ::math::bigfloat::_logOnePlusEpsilon {epsNum epsDenom precision} { + if {[::math::bignum::cmp $epsNum $epsDenom]>=0} { + error "number is null" + } + set s [::math::bignum::lshift $epsNum $precision] + set s [::math::bignum::div $s $epsDenom] + variable two + set divider $two + set t [::math::bignum::div [::math::bignum::mul $s $epsNum] $epsDenom] + set u [::math::bignum::div $t $divider] + # when u (the current term of the development) is zero, we have reached our goal + # it has converged + while {![::math::bignum::iszero $u]} { + set s [::math::bignum::add $s $u] + # divider = order of the term = 'n' + set divider [::math::bignum::add 1 $divider] + # t = (epsilon)^n + set t [::math::bignum::div [::math::bignum::mul $t $epsNum] $epsDenom] + # u = t/n = (epsilon)^n/n and is the nth term of the Taylor development + set u [::math::bignum::div $t $divider] + } + return $s +} + + +################################################################################ +# compute log(0.xxxxxxxx) : log(1-epsilon)=-eps-eps^2/2-eps^3/3...-eps^n/n +################################################################################ +proc ::math::bigfloat::_log {integer} { + # the uncertainty is nbSteps with nbSteps<=nbBits + # take nbSteps=nbBits (the worse case) and log(nbBits+increment)=increment + set precision [::math::bignum::bits $integer] + set n [expr {int(log($precision+2*log($precision)))}] + set integer [::math::bignum::lshift $integer $n] + incr precision $n + variable three + set delta $three + # 1-epsilon=integer + set integer [::math::bignum::sub [::math::bignum::lshift 1 $precision] $integer] + set s $integer + # t=x^2 + set t [intMulShift $integer $integer $precision] + variable two + set denom $two + # u=x^2/2 (second term) + set u [::math::bignum::div $t $denom] + while {![::math::bignum::iszero $u]} { + # while the current term is not zero, it has not converged + set s [::math::bignum::add $s $u] + set delta [::math::bignum::add 1 $delta] + # t=x^n + set t [intMulShift $t $integer $precision] + # denom = n (the order of the current development term) + set denom [::math::bignum::add 1 $denom] + # u = x^n/n (the nth term of Taylor development) + set u [::math::bignum::div $t $denom] + } + # shift right to restore the precision + set delta [::math::bignum::add 1 [::math::bignum::rshift $delta $n]] + return [list [::math::bignum::rshift $s $n] $delta] +} + +################################################################################ +# computes log(num/denom) with 'precision' bits +# used to compute some analysis constants with a given accuracy +# you might not call this procedure directly : it assumes 'num/denom'>4/5 +# and 'num/denom'<1 +################################################################################ +proc ::math::bigfloat::__log {num denom precision} { + # Please Note : we here need a precision increment, in order to + # keep accuracy at $precision digits. If we just hold $precision digits, + # each number being precise at the last digit +/- 1, + # we would lose accuracy because small uncertainties add to themselves. + # Example : 0.0001 + 0.0010 = 0.0011 +/- 0.0002 + # This is quite the same reason that made tcl_precision defaults to 12 : + # internally, doubles are computed with 17 digits, but to keep precision + # we need to limit our results to 12. + # The solution : given a precision target, increment precision with a + # computed value so that all digits of he result are exacts. + # + # p is the precision + # pk is the precision increment + # 2 power pk is also the maximum number of iterations + # for a number close to 1 but lower than 1, + # (denom-num)/denum is (in our case) lower than 1/5 + # so the maximum nb of iterations is for: + # 1/5*(1+1/5*(1/2+1/5*(1/3+1/5*(...)))) + # the last term is 1/n*(1/5)^n + # for the last term to be lower than 2^(-p-pk) + # the number of iterations has to be + # 2^(-pk).(1/5)^(2^pk) < 2^(-p-pk) + # log(1/5).2^pk < -p + # 2^pk > p/log(5) + # pk > log(2)*log(p/log(5)) + # now set the variable n to the precision increment i.e. pk + set n [expr {int(log(2)*log($precision/log(5)))+1}] + incr precision $n + # log(num/denom)=log(1-(denom-num)/denom) + # log(1+x) = x + x^2/2 + x^3/3 + ... + x^n/n + # = x(1 + x(1/2 + x(1/3 + x(...+ x(1/(n-1) + x/n)...)))) + set num [::math::bignum::fromstr [expr {$denom-$num}]] + set denom [::math::bignum::fromstr $denom] + # $s holds the result + set s [::math::bignum::div [::math::bignum::lshift $num $precision] $denom] + # $t holds x^n + set t [::math::bignum::div [::math::bignum::mul $s $num] $denom] + variable two + set d $two + # $u holds x^n/n + set u [::math::bignum::div $t $d] + while {![::math::bignum::iszero $u]} { + set s [::math::bignum::add $s $u] + # get x^n * x + set t [::math::bignum::div [::math::bignum::mul $t $num] $denom] + # get n+1 + set d [::math::bignum::add 1 $d] + # then : $u = x^(n+1)/(n+1) + set u [::math::bignum::div $t $d] + } + # see head of the proc : we return the value with its target precision + return [::math::bignum::rshift $s $n] +} + +################################################################################ +# computes log(2) with 'precision' bits and caches it into a namespace variable +################################################################################ +proc ::math::bigfloat::__logbis {precision} { + set increment [expr {int(log($precision)/log(2)+1)}] + incr precision $increment + # ln(2)=3*ln(1-4/5)+ln(1-125/128) + set a [__log 125 128 $precision] + set b [__log 4 5 $precision] + variable three + set r [::math::bignum::add [::math::bignum::mul $b $three] $a] + set ::math::bigfloat::Log2 [::math::bignum::rshift $r $increment] + # formerly (when BigFloats were stored in ten radix) we had to compute log(10) + # ln(10)=10.ln(1-4/5)+3*ln(1-125/128) +} + + +################################################################################ +# retrieves log(2) with 'precision' bits ; the result is cached +################################################################################ +proc ::math::bigfloat::_log2 {precision} { + variable Log2 + if {![info exists Log2]} { + __logbis $precision + } else { + # the constant is cached and computed again when more precision is needed + set l [::math::bignum::bits $Log2] + if {$precision>$l} { + __logbis $precision + } + } + # return log(2) with 'precision' bits even when the cached value has more bits + return [_round $Log2 $precision] +} + + +################################################################################ +# returns A modulo B (like with fmod() math function) +################################################################################ +proc ::math::bigfloat::mod {a b} { + checkNumber a b + if {[isInt $a] && [isInt $b]} {return [::math::bignum::mod $a $b]} + if {[isInt $a]} {error "trying to divide a BigInt by a BigFloat"} + set quotient [div $a $b] + # examples : fmod(3,2)=1 quotient=1.5 + # fmod(1,2)=1 quotient=0.5 + # quotient>0 and b>0 : get floor(quotient) + # fmod(-3,-2)=-1 quotient=1.5 + # fmod(-1,-2)=-1 quotient=0.5 + # quotient>0 and b<0 : get floor(quotient) + # fmod(-3,2)=-1 quotient=-1.5 + # fmod(-1,2)=-1 quotient=-0.5 + # quotient<0 and b>0 : get ceil(quotient) + # fmod(3,-2)=1 quotient=-1.5 + # fmod(1,-2)=1 quotient=-0.5 + # quotient<0 and b<0 : get ceil(quotient) + if {[sign $quotient]} { + set quotient [ceil $quotient] + } else { + set quotient [floor $quotient] + } + return [sub $a [mul $quotient $b]] +} + +################################################################################ +# returns A times B +################################################################################ +proc ::math::bigfloat::mul {a b} { + checkNumber a b + # dispatch the command to appropriate commands regarding types (BigInt & BigFloat) + if {[isInt $a]} { + if {[isInt $b]} { + return [::math::bignum::mul $a $b] + } + return [mulFloatByInt $b $a] + } + if {[isInt $b]} {return [mulFloatByInt $a $b]} + # now we are sure that 'a' and 'b' are BigFloats + foreach {dummy integerA expA deltaA} $a {break} + foreach {dummy integerB expB deltaB} $b {break} + # 2^expA * 2^expB = 2^(expA+expB) + set exp [expr {$expA+$expB}] + # mantissas are multiplied + set integer [::math::bignum::mul $integerA $integerB] + # compute precisely the uncertainty + set deltaAB [::math::bignum::mul $deltaA $deltaB] + set deltaA [::math::bignum::mul [abs $integerB] $deltaA] + set deltaB [::math::bignum::mul [abs $integerA] $deltaB] + set delta [::math::bignum::add [::math::bignum::add $deltaA $deltaB] \ + [::math::bignum::add 1 $deltaAB]] + # we have to normalize because 'delta' may be too big + return [normalize [list F $integer $exp $delta]] +} + +################################################################################ +# returns A times B, where B is a positive integer +################################################################################ +proc ::math::bigfloat::mulFloatByInt {a b} { + checkFloat a + foreach {dummy integer exp delta} $a {break} + if {![isInt $b]} { + error "second argument expected to be a BigInt" + } + # Mantissa and Delta are simply multplied by $b + set integer [::math::bignum::mul $integer $b] + set delta [::math::bignum::mul $delta $b] + # We normalize because Delta could have seriously increased + return [normalize [list F $integer $exp $delta]] +} + +################################################################################ +# normalizes a number : Delta (accuracy of the BigFloat) +# has to be limited, because the memory use increase +# quickly when we do some computations, as the Mantissa and Delta +# increase together +# The solution : keep the size of Delta under 9 bits +################################################################################ +proc ::math::bigfloat::normalize {number} { + checkFloat number + foreach {dummy integer exp delta} $number {break} + set l [::math::bignum::bits $delta] + if {$l>8} { + # next line : $l holds the supplementary size (in bits) + incr l -8 + # now we can shift right by $l bits + # always round upper the Delta + set delta [::math::bignum::add 1 [::math::bignum::rshift $delta $l]] + set integer [::math::bignum::rshift $integer $l] + incr exp $l + } + return [list F $integer $exp $delta] +} + + + +################################################################################ +# returns -A (the opposite) +################################################################################ +proc ::math::bigfloat::opp {a} { + checkNumber a + if {[iszero $a]} { + return $a + } + if {[isInt $a]} { + ::math::bignum::setsign a [expr {![::math::bignum::sign $a]}] + return $a + } + # recursive call + lset a 1 [opp [lindex $a 1]] + return $a +} + +################################################################################ +# gets Pi with precision bits +# after the dot (after you call [tostr] on the result) +################################################################################ +proc ::math::bigfloat::pi {precision {binary 0}} { + if {[llength $precision]>1} { + if {[isInt $precision]} { + set precision [tostr $precision] + } else { + error "'$precision' expected to be an integer" + } + } + if {!$binary} { + # convert decimal digit length into bit length + set precision [expr {int(ceil($precision*log(10)/log(2)))}] + } + variable one + return [list F [_pi $precision] -$precision $one] +} + + +proc ::math::bigfloat::_pi {precision} { + # the constant Pi begins with 3.xxx + # so we need 2 digits to store the digit '3' + # and then we will have precision+2 bits in the mantissa + variable _pi0 + if {![info exists _pi0]} { + set _pi0 [__pi $precision] + } + set lenPiGlobal [::math::bignum::bits $_pi0] + if {$lenPiGlobal<$precision} { + set _pi0 [__pi $precision] + } + return [::math::bignum::rshift $_pi0 [expr {[::math::bignum::bits $_pi0]-2-$precision}]] +} + +################################################################################ +# computes an integer representing Pi in binary radix, with precision bits +################################################################################ +proc ::math::bigfloat::__pi {precision} { + set safetyLimit 8 + # for safety and for the better precision, we do so ... + incr precision $safetyLimit + # formula found in the Math litterature + # Pi/4 = 6.atan(1/18) + 8.atan(1/57) - 5.atan(1/239) + set a [::math::bignum::mul [_atanfract [::math::bignum::fromstr 18] $precision] \ + [::math::bignum::fromstr 48]] + set a [::math::bignum::add $a [::math::bignum::mul \ + [_atanfract [::math::bignum::fromstr 57] $precision] [::math::bignum::fromstr 32]]] + set a [::math::bignum::sub $a [::math::bignum::mul \ + [_atanfract [::math::bignum::fromstr 239] $precision] [::math::bignum::fromstr 20]]] + return [::math::bignum::rshift $a $safetyLimit] +} + +################################################################################ +# shift right an integer until it haves $precision bits +# round at the same time +################################################################################ +proc ::math::bigfloat::_round {integer precision} { + set shift [expr {[::math::bignum::bits $integer]-$precision}] + # $result holds the shifted integer + set result [::math::bignum::rshift $integer $shift] + # $shift-1 is the bit just rights the last bit of the result + # Example : integer=1000010 shift=2 + # => result=10000 and the tested bit is '1' + if {[::math::bignum::testbit $integer [expr {$shift-1}]]} { + # we round to the upper limit + return [::math::bignum::add 1 $result] + } + return $result +} + +################################################################################ +# returns A power B, where B is a positive integer +################################################################################ +proc ::math::bigfloat::pow {a b} { + checkNumber a + if {![isInt $b]} { + error "pow : exponent is not a positive integer" + } + # case where it is obvious that we should use the appropriate command + # from math::bignum (added 5th March 2005) + if {[isInt $a]} { + return [::math::bignum::pow $a $b] + } + # algorithm : exponent=$b = Sum(i=0..n) b(i)2^i + # $a^$b = $a^( b(0) + 2b(1) + 4b(2) + ... + 2^n*b(n) ) + # we have $a^(x+y)=$a^x * $a^y + # then $a^$b = Product(i=0...n) $a^(2^i*b(i)) + # b(i) is boolean so $a^(2^i*b(i))= 1 when b(i)=0 and = $a^(2^i) when b(i)=1 + # then $a^$b = Product(i=0...n and b(i)=1) $a^(2^i) and 1 when $b=0 + variable one + if {[::math::bignum::iszero $b]} {return $one} + # $res holds the result + set res $one + while {1} { + # at the beginning i=0 + # $remainder is b(i) + set remainder [::math::bignum::testbit $b 0] + # $b 'rshift'ed by 1 bit : i=i+1 + # so next time we will test bit b(i+1) + set b [::math::bignum::rshift $b 1] + # if b(i)=1 + if {$remainder} { + # mul the result by $a^(2^i) + # if i=0 we multiply by $a^(2^0)=$a^1=$a + set res [mul $res $a] + } + # no more bits at '1' in $b : $res is the result + if {[::math::bignum::iszero $b]} { + if {[isInt $res]} { + # we cannot (and should not) normalize an integer + return $res + } + return [normalize $res] + } + # i=i+1 : $a^(2^(i+1)) = square of $a^(2^i) + set a [mul $a $a] + } +} + +################################################################################ +# converts angles for radians to degrees +################################################################################ +proc ::math::bigfloat::rad2deg {x} { + checkFloat x + set xLen [expr {-[lindex $x 2]}] + if {$xLen<3} { + error "number too loose to convert to degrees" + } + set pi [pi $xLen 1] + # $rad/Pi=$deg/180 + # so result in deg = $radians*180/Pi + return [div [mul $x [::math::bignum::fromstr 180]] $pi] +} + +################################################################################ +# retourne la partie entière (ou 0) du nombre "number" +################################################################################ +proc ::math::bigfloat::round {number} { + checkFloat number + #set number [normalize $number] + # fetching integers (or BigInts) from the internal representation + foreach {dummy integer exp delta} $number {break} + if {[::math::bignum::iszero $integer]} { + # returns the BigInt 0 + variable zero + return $zero + } + if {$exp>=0} { + error "not enough precision to round (in round)" + } + set exp [expr {-$exp}] + # saving the sign, ... + set sign [::math::bignum::sign $integer] + set integer [abs $integer] + # integer part of the number + set try [::math::bignum::rshift $integer $exp] + # first bit after the dot + set way [::math::bignum::testbit $integer [expr {$exp-1}]] + # delta is shifted so it gives the integer part of 2*delta + set delta [::math::bignum::rshift $delta [expr {$exp-1}]] + # when delta is too big to compute rounded value ( + if {![::math::bignum::iszero $delta]} { + error "not enough precision to round (in round)" + } + if {$way} { + set try [::math::bignum::add 1 $try] + } + # ... restore the sign now + ::math::bignum::setsign try $sign + return $try +} + +################################################################################ +# round and divide by 10^n +################################################################################ +proc ::math::bigfloat::roundshift {integer n} { + # $exp= 10^$n + set exp [tenPow $n] + foreach {result remainder} [::math::bignum::divqr $integer $exp] {} + # $remainder belongs to the interval [0, $exp-1] + # $remainder >= $exp/2 is the rounding condition + # that is better expressed in this form : + # $remainder*2 >= $exp , as we are treating integers, not rationals + # left shift $remainder by 1 equals to multiplying by 2 and is much faster + if {[::math::bignum::cmp $exp [::math::bignum::lshift $remainder 1]]<=0} { + return [::math::bignum::add 1 $result] + } + return $result +} + +################################################################################ +# gets the sign of either a bignum, or a BitFloat +# we keep the bignum convention : 0 for positive, 1 for negative +################################################################################ +proc ::math::bigfloat::sign {n} { + if {[isInt $n]} { + return [::math::bignum::sign $n] + } + # sign of 0=0 + if {[iszero $n]} {return 0} + # the sign of the Mantissa, which is a BigInt + return [::math::bignum::sign [lindex $n 1]] +} + + +################################################################################ +# gets sin(x) +################################################################################ +proc ::math::bigfloat::sin {x} { + checkFloat x + foreach {dummy integer exp delta} $x {break} + if {$exp>-2} { + error "sin : not enough precision" + } + set precision [expr {-$exp}] + # sin(2kPi+x)=sin(x) + # $integer is now the modulo of the division of the mantissa by Pi/4 + # and $n is the quotient + foreach {n integer} [divPiQuarter $integer $precision] {break} + set delta [::math::bignum::add $delta $n] + variable four + set d [::math::bignum::mod $n $four] + # now integer>=0 + # x = $n*Pi/4 + $integer and $n belongs to [0,3] + # sin(2Pi-x)=-sin(x) + # sin(Pi-x)=sin(x) + # sin(Pi/2+x)=cos(x) + set sign 0 + switch -- [tostr $d] { + 0 {set l [_sin2 $integer $precision $delta]} + 1 {set l [_cos2 $integer $precision $delta]} + 2 {set sign 1;set l [_sin2 $integer $precision $delta]} + 3 {set sign 1;set l [_cos2 $integer $precision $delta]} + default {error "internal error"} + } + # $l is a list : {Mantissa Precision Delta} + # precision --> the opposite of the exponent + # 1.000 = 1000*10^-3 so exponent=-3 and precision=3 digits + lset l 1 [expr {-([lindex $l 1])}] + set integer [lindex $l 0] + # the sign depends on the switch statement below + ::math::bignum::setsign integer $sign + lset l 0 $integer + # we insert the Bigfloat tag (F) and normalize the final result + return [normalize [linsert $l 0 F]] +} + +proc ::math::bigfloat::_sin2 {x precision delta} { + set pi [_pi $precision] + # shift right by 1 = divide by 2 + # shift right by 2 = divide by 4 + set pis2 [::math::bignum::rshift $pi 1] + set pis4 [::math::bignum::rshift $pi 2] + if {[::math::bignum::cmp $x $pis4]>=0} { + # sin(Pi/2-x)=cos(x) + set delta [::math::bignum::add 1 $delta] + set x [::math::bignum::sub $pis2 $x] + return [_cos $x $precision $delta] + } + return [_sin $x $precision $delta] +} + +################################################################################ +# sin(x) with 'x' lower than Pi/4 and positive +# 'x' is the Mantissa - 'delta' is Delta +# 'precision' is the opposite of the exponent +################################################################################ +proc ::math::bigfloat::_sin {x precision delta} { + # $s holds the result + set s $x + # sin(x) = x - x^3/3! + x^5/5! - ... + (-1)^n*x^(2n+1)/(2n+1)! + # = x * (1 - x^2/(2*3) * (1 - x^2/(4*5) * (...* (1 - x^2/(2n*(2n+1)) )...))) + # The second expression allows us to compute the less we can + + # $double holds the uncertainty (Delta) of x^2 : 2*(Mantissa*Delta) + Delta^2 + # (Mantissa+Delta)^2=Mantissa^2 + 2*Mantissa*Delta + Delta^2 + set double [::math::bignum::rshift [::math::bignum::mul $x $delta] [expr {$precision-1}]] + set double [::math::bignum::add [::math::bignum::add 1 $double] [::math::bignum::rshift \ + [::math::bignum::mul $delta $delta] $precision]] + # $x holds the Mantissa of x^2 + set x [intMulShift $x $x $precision] + set dt [::math::bignum::rshift [::math::bignum::add [::math::bignum::mul $x $delta] \ + [::math::bignum::mul [::math::bignum::add $s $delta] $double]] $precision] + set dt [::math::bignum::add 1 $dt] + # $t holds $s * -(x^2) / (2n*(2n+1)) + # mul by x^2 + set t [intMulShift $s $x $precision] + variable two + set denom2 $two + variable three + set denom3 $three + # mul by -1 (opp) and divide by 2*3 + set t [opp [::math::bignum::div $t [::math::bignum::mul $denom2 $denom3]]] + while {![::math::bignum::iszero $t]} { + set s [::math::bignum::add $s $t] + set delta [::math::bignum::add $delta $dt] + # incr n => 2n --> 2n+2 and 2n+1 --> 2n+3 + set denom2 [::math::bignum::add $denom2 $two] + set denom3 [::math::bignum::add $denom3 $two] + # $dt is the Delta corresponding to $t + # $double "" "" "" "" $x (x^2) + # ($t+$dt) * ($x+$double) = $t*$x + ($dt*$x + $t*$double) + $dt*$double + # Mantissa^ ^--------Delta-------------------^ + set dt [::math::bignum::rshift [::math::bignum::add [::math::bignum::mul $x $dt] \ + [::math::bignum::mul [::math::bignum::add $t $dt] $double]] $precision] + set t [intMulShift $t $x $precision] + # removed 2005/08/31 by sarnold75 + #set dt [::math::bignum::add $dt $double] + set denom [::math::bignum::mul $denom2 $denom3] + # now computing : div by -2n(2n+1) + set dt [::math::bignum::add 1 [::math::bignum::div $dt $denom]] + set t [opp [::math::bignum::div $t $denom]] + } + return [list $s $precision $delta] +} + + +################################################################################ +# procedure for extracting the square root of a BigFloat +################################################################################ +proc ::math::bigfloat::sqrt {x} { + variable one + checkFloat x + foreach {dummy integer exp delta} $x {break} + # if x=0, return 0 + if {[iszero $x]} { + variable zero + # return zero, taking care of its precision ($exp) + return [list F $zero $exp $one] + } + # we cannot get sqrt(x) if x<0 + if {[lindex $integer 0]<0} { + error "negative sqrt input" + } + # (1+epsilon)^p = 1 + epsilon*(p-1) + epsilon^2*(p-1)*(p-2)/2! + ... + # + epsilon^n*(p-1)*...*(p-n)/n! + # sqrt(1 + epsilon) = (1 + epsilon)^(1/2) + # = 1 - epsilon/2 - epsilon^2*3/(4*2!) - ... + # - epsilon^n*(3*5*..*(2n-1))/(2^n*n!) + # sqrt(1 - epsilon) = 1 + Sum(i=1..infinity) epsilon^i*(3*5*...*(2i-1))/(i!*2^i) + # sqrt(n +/- delta)=sqrt(n) * sqrt(1 +/- delta/n) + # so the uncertainty on sqrt(n +/- delta) equals sqrt(n) * (sqrt(1 - delta/n) - 1) + # sqrt(1+eps) < sqrt(1-eps) because their logarithm compare as : + # -ln(2)(1+eps) < -ln(2)(1-eps) + # finally : + # Delta = sqrt(n) * Sum(i=1..infinity) (delta/n)^i*(3*5*...*(2i-1))/(i!*2^i) + # here we compute the second term of the product by _sqrtOnePlusEpsilon + set delta [_sqrtOnePlusEpsilon $delta $integer] + set intLen [::math::bignum::bits $integer] + # removed 2005/08/31 by sarnold75, readded 2005/08/31 + set precision $intLen + # intLen + exp = number of bits before the dot + #set precision [expr {-$exp}] + # square root extraction + set integer [::math::bignum::lshift $integer $intLen] + incr exp -$intLen + incr intLen $intLen + # there is an exponent 2^$exp : when $exp is odd, we would need to compute sqrt(2) + # so we decrement $exp, in order to get it even, and we do not need sqrt(2) anymore ! + if {$exp&1} { + incr exp -1 + set integer [::math::bignum::lshift $integer 1] + incr intLen + incr precision + } + # using a low-level (in math::bignum) root extraction procedure + set integer [::math::bignum::sqrt $integer] + # delta has to be multiplied by the square root + set delta [::math::bignum::rshift [::math::bignum::mul $delta $integer] $precision] + # round to the ceiling the uncertainty (worst precision, the fastest to compute) + set delta [::math::bignum::add 1 $delta] + # we are sure that $exp is even, see above + return [normalize [list F $integer [expr {$exp/2}] $delta]] +} + + + +################################################################################ +# compute abs(sqrt(1-delta/integer)-1) +# the returned value is a relative uncertainty +################################################################################ +proc ::math::bigfloat::_sqrtOnePlusEpsilon {delta integer} { + # sqrt(1-x) - 1 = x/2 + x^2*3/(2^2*2!) + x^3*3*5/(2^3*3!) + ... + # = x/2 * (1 + x*3/(2*2) * ( 1 + x*5/(2*3) * + # (...* (1 + x*(2n-1)/(2n) ) )...))) + variable one + set l [::math::bignum::bits $integer] + # to compute delta/integer we have to shift left to keep the same precision level + # we have a better accuracy computing (delta << lg(integer))/integer + # than computing (delta/integer) << lg(integer) + set x [::math::bignum::div [::math::bignum::lshift $delta $l] $integer] + variable four + variable two + # denom holds 2n + set denom $four + # x/2 + set result [::math::bignum::div $x $two] + # x^2*3/(2!*2^2) + variable three + # numerator holds 2n-1 + set numerator $three + set temp [::math::bignum::mul $result $delta] + set temp [::math::bignum::div [::math::bignum::mul $temp $numerator] $integer] + set temp [::math::bignum::add 1 [::math::bignum::div $temp $denom]] + while {![::math::bignum::iszero $temp]} { + set result [::math::bignum::add $result $temp] + set numerator [::math::bignum::add $numerator $two] + set denom [::math::bignum::add $two $denom] + # n = n+1 ==> num=num+2 denom=denom+2 + # num=2n+1 denom=2n+2 + set temp [::math::bignum::mul [::math::bignum::mul $temp $delta] $numerator] + set temp [::math::bignum::div [::math::bignum::div $temp $denom] $integer] + } + return $result +} + +################################################################################ +# substracts B to A +################################################################################ +proc ::math::bigfloat::sub {a b} { + checkNumber a b + if {[isInt $a] && [isInt $b]} { + # the math::bignum::sub proc is designed to work with BigInts + return [::math::bignum::sub $a $b] + } + return [add $a [opp $b]] +} + +################################################################################ +# tangent (trivial algorithm) +################################################################################ +proc ::math::bigfloat::tan {x} { + return [::math::bigfloat::div [::math::bigfloat::sin $x] [::math::bigfloat::cos $x]] +} + +################################################################################ +# returns a power of ten +################################################################################ +proc ::math::bigfloat::tenPow {n} { + variable ten + return [::math::bignum::pow $ten [::math::bignum::fromstr $n]] +} + + +################################################################################ +# converts a BigInt to a double (basic floating-point type) +# with respect to the global variable 'tcl_precision' +################################################################################ +proc ::math::bigfloat::todouble {x} { + global tcl_precision + checkFloat x + # get the string repr of x without the '+' sign + set result [string trimleft [tostr $x] +] + set minus "" + if {[string index $result 0]=="-"} { + set minus - + set result [string range $result 1 end] + } + set l [split $result e] + set exp 0 + if {[llength $l]==2} { + # exp : x=Mantissa*10^Exp + set exp [lindex $l 1] + } + # Mantissa = integerPart.fractionalPart + set l [split [lindex $l 0] .] + set integerPart [lindex $l 0] + set integerLen [string length $integerPart] + set fractionalPart [lindex $l 1] + # The number of digits in Mantissa, excluding the dot and the leading zeros, of course + set len [string length [set integer $integerPart$fractionalPart]] + # Now Mantissa is stored in $integer + if {$len>$tcl_precision} { + set lenDiff [expr {$len-$tcl_precision}] + # true when the number begins with a zero + set zeroHead 0 + if {[string index $integer 0]==0} { + incr lenDiff -1 + set zeroHead 1 + } + set integer [tostr [roundshift [::math::bignum::fromstr $integer] $lenDiff]] + if {$zeroHead} { + set integer 0$integer + } + set len [string length $integer] + if {$len<$integerLen} { + set exp [expr {$integerLen-$len}] + # restore the true length + set integerLen $len + } + } + # number = 'sign'*'integer'*10^'exp' + if {$exp==0} { + # no scientific notation + set exp "" + } else { + # scientific notation + set exp e$exp + } + # place the dot just before the index $integerLen in the Mantissa + set result [string range $integer 0 [expr {$integerLen-1}]] + append result .[string range $integer $integerLen end] + # join the Mantissa with the sign before and the exponent after + return $minus$result$exp +} + +################################################################################ +# converts a number stored as a list to a string in which all digits are true +################################################################################ +proc ::math::bigfloat::tostr {args} { + variable five + if {[llength $args]==2} { + if {![string equal [lindex $args 0] -nosci]} {error "unknown option: should be -nosci"} + set nosci yes + set number [lindex $args 1] + } else { + if {[llength $args]!=1} {error "syntax error: should be tostr ?-nosci? number"} + set nosci no + set number [lindex $args 0] + } + if {[isInt $number]} { + return [::math::bignum::tostr $number] + } + checkFloat number + foreach {dummy integer exp delta} $number {break} + if {[iszero $number]} { + # we do not matter how much precision $number has : + # it can be 0.0000000 or 0.0, the result is still the same : the "0" string + # not anymore : 0.000 is not 0.0 ! + # return 0 + } + if {$exp>0} { + # the power of ten the closest but greater than 2^$exp + # if it was lower than the power of 2, we would have more precision + # than existing in the number + set newExp [expr {int(ceil($exp*log(2)/log(10)))}] + # 'integer' <- 'integer' * 2^exp / 10^newExp + # equals 'integer' * 2^(exp-newExp) / 5^newExp + set binExp [expr {$exp-$newExp}] + if {$binExp<0} { + # it cannot happen + error "internal error" + } + # 5^newExp + set fivePower [::math::bignum::pow $five [::math::bignum::fromstr $newExp]] + # 'lshift'ing $integer by $binExp bits is like multiplying it by 2^$binExp + # but much, much faster + set integer [::math::bignum::div [::math::bignum::lshift $integer $binExp] \ + $fivePower] + # $integer is the Mantissa - Delta should follow the same operations + set delta [::math::bignum::div [::math::bignum::lshift $delta $binExp] $fivePower] + set exp $newExp + } elseif {$exp<0} { + # the power of ten the closest but lower than 2^$exp + # same remark about the precision + set newExp [expr {int(floor(-$exp*log(2)/log(10)))}] + # 'integer' <- 'integer' * 10^newExp / 2^(-exp) + # equals 'integer' * 5^(newExp) / 2^(-exp-newExp) + set fivePower [::math::bignum::pow $five \ + [::math::bignum::fromstr $newExp]] + set binShift [expr {-$exp-$newExp}] + # rshifting is like dividing by 2^$binShift, but faster as we said above about lshift + set integer [::math::bignum::rshift [::math::bignum::mul $integer $fivePower] \ + $binShift] + set delta [::math::bignum::rshift [::math::bignum::mul $delta $fivePower] \ + $binShift] + set exp -$newExp + } + # saving the sign, to restore it into the result + set sign [::math::bignum::sign $integer] + set result [::math::bignum::abs $integer] + # rounded 'integer' +/- 'delta' + set up [::math::bignum::add $result $delta] + set down [::math::bignum::sub $result $delta] + if {[sign $up]^[sign $down]} { + # $up>0 and $down<0 and vice-versa : then the number is considered equal to zero + # delta <= 2**n (n = bits(delta)) + # 2**n <= 10**exp , then + # exp >= n.log(2)/log(10) + # delta <= 10**(n.log(2)/log(10)) + incr exp [expr {int(ceil([::math::bignum::bits $delta]*log(2)/log(10)))}] + set result 0 + set isZero yes + } else { + # iterate until the convergence of the rounding + # we incr $shift until $up and $down are rounded to the same number + # at each pass we lose one digit of precision, so necessarly it will success + for {set shift 1} { + [::math::bignum::cmp [roundshift $up $shift] [roundshift $down $shift]] + } { + incr shift + } {} + incr exp $shift + set result [::math::bignum::tostr [roundshift $up $shift]] + set isZero no + } + set l [string length $result] + # now formatting the number the most nicely for having a clear reading + # would'nt we allow a number being constantly displayed + # as : 0.2947497845e+012 , would we ? + if {$nosci} { + if {$exp >= 0} { + append result [string repeat 0 $exp]. + } elseif {$l + $exp > 0} { + set result [string range $result 0 end-[expr {-$exp}]].[string range $result end-[expr {-1-$exp}] end] + } else { + set result 0.[string repeat 0 [expr {-$exp-$l}]]$result + } + } else { + if {$exp>0} { + # we display 423*10^6 as : 4.23e+8 + # Length of mantissa : $l + # Increment exp by $l-1 because the first digit is placed before the dot, + # the other ($l-1) digits following the dot. + incr exp [incr l -1] + set result [string index $result 0].[string range $result 1 end] + append result "e+$exp" + } elseif {$exp==0} { + # it must have a dot to be a floating-point number (syntaxically speaking) + append result . + } else { + set exp [expr {-$exp}] + if {$exp < $l} { + # we can display the number nicely as xxxx.yyyy* + # the problem of the sign is solved finally at the bottom of the proc + set n [string range $result 0 end-$exp] + incr exp -1 + append n .[string range $result end-$exp end] + set result $n + } elseif {$l==$exp} { + # we avoid to use the scientific notation + # because it is harder to read + set result "0.$result" + } else { + # ... but here there is no choice, we should not represent a number + # with more than one leading zero + set result [string index $result 0].[string range $result 1 end]e-[expr {$exp-$l+1}] + } + } + } + # restore the sign : we only put a minus on numbers that are different from zero + if {$sign==1 && !$isZero} {set result "-$result"} + return $result +} + +################################################################################ +# PART IV +# HYPERBOLIC FUNCTIONS +################################################################################ + +################################################################################ +# hyperbolic cosinus +################################################################################ +proc ::math::bigfloat::cosh {x} { + # cosh(x) = (exp(x)+exp(-x))/2 + # dividing by 2 is done faster by 'rshift'ing + return [floatRShift [add [exp $x] [exp [opp $x]]] 1] +} + +################################################################################ +# hyperbolic sinus +################################################################################ +proc ::math::bigfloat::sinh {x} { + # sinh(x) = (exp(x)-exp(-x))/2 + # dividing by 2 is done faster by 'rshift'ing + return [floatRShift [sub [exp $x] [exp [opp $x]]] 1] +} + +################################################################################ +# hyperbolic tangent +################################################################################ +proc ::math::bigfloat::tanh {x} { + set up [exp $x] + set down [exp [opp $x]] + # tanh(x)=sinh(x)/cosh(x)= (exp(x)-exp(-x))/2/ [(exp(x)+exp(-x))/2] + # =(exp(x)-exp(-x))/(exp(x)+exp(-x)) + # =($up-$down)/($up+$down) + return [div [sub $up $down] [add $up $down]] +} + +# exporting public interface +namespace eval ::math::bigfloat { + foreach function { + add mul sub div mod pow + iszero compare equal + fromstr tostr fromdouble todouble + int2float isInt isFloat + exp log sqrt round ceil floor + sin cos tan cotan asin acos atan + cosh sinh tanh abs opp + pi deg2rad rad2deg + } { + namespace export $function + } +} + +# (AM) No "namespace import" - this should be left to the user! +#namespace import ::math::bigfloat::* + +package provide math::bigfloat 1.2.3 diff --git a/vendor/math/bigfloat.test b/vendor/math/bigfloat.test new file mode 100644 index 00000000..8f344472 --- /dev/null +++ b/vendor/math/bigfloat.test @@ -0,0 +1,705 @@ +# -*- tcl -*- +######################################################################## +# BigFloat for Tcl +# Copyright (C) 2003-2005 ARNOLD Stephane +# +# BIGFLOAT LICENSE TERMS +# +# This software is copyrighted by Stephane ARNOLD, (stephanearnold yahoo.fr). +# The following terms apply to all files associated +# with the software unless explicitly disclaimed in individual files. +# +# The authors hereby grant permission to use, copy, modify, distribute, +# and license this software and its documentation for any purpose, provided +# that existing copyright notices are retained in all copies and that this +# notice is included verbatim in any distributions. No written agreement, +# license, or royalty fee is required for any of the authorized uses. +# Modifications to this software may be copyrighted by their authors +# and need not follow the licensing terms described here, provided that +# the new terms are clearly indicated on the first page of each file where +# they apply. +# +# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY +# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY +# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. +# +# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE +# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE +# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +# MODIFICATIONS. +# +# GOVERNMENT USE: If you are acquiring this software on behalf of the +# U.S. government, the Government shall have only "Restricted Rights" +# in the software and related documentation as defined in the Federal +# Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you +# are acquiring the software on behalf of the Department of Defense, the +# software shall be classified as "Commercial Computer Software" and the +# Government shall have only "Restricted Rights" as defined in Clause +# 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the +# authors grant the U.S. Government and others acting in its behalf +# permission to use and distribute the software in accordance with the +# terms specified in this license. +# +######################################################################## + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.5 +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 + +foreach {x rx r} { + 0 0 {bignum 0 0} + 0.0 0. {F {bignum 0 0} -8 {bignum 0 26}} + .0 0. {F {bignum 0 0} -8 {bignum 0 26}} + +0 0 {bignum 0 0} + +0.0 0. {F {bignum 0 0} -8 {bignum 0 26}} + +.0 0. {F {bignum 0 0} -8 {bignum 0 26}} + -0 0 {bignum 0 0} + -0.0 0. {F {bignum 1 0} -8 {bignum 0 26}} + -.0 0. {F {bignum 1 0} -8 {bignum 0 26}} +} { + test bigfloat-fromstr-3.[incr k] {fromstr zeroes} { + fromstr $x + } $r + + test bigfloat-fromstr-4.${k} {fromstr zeroes as double} { + tostr [fromstr $x] + } $rx +} +unset k + +################################################################################ +# 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 +return diff --git a/vendor/math/bigfloat2.tcl b/vendor/math/bigfloat2.tcl new file mode 100644 index 00000000..685672ec --- /dev/null +++ b/vendor/math/bigfloat2.tcl @@ -0,0 +1,2224 @@ +######################################################################## +# 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 +# determines the datatype, Mantissa and Delta are two big integers and +# Exponent another integer. +# +# The BigFloat value equals to (Mantissa +/- Delta)*2^Exponent +# So the internal representation is binary, but trying to get as close +# as possible to the decimal one when converted to a string. When +# calling [fromstr], the Delta parameter is set to the value of 1 at +# the position of the last decimal digit. +# +# Example : 1.50 belongs to [1.49,1.51], but internally Delta may not equal to 1. +# Because of the binary representation, it is between 1 and 1+(2^-15). +# +# So Mantissa and Delta are not limited in size, but in practice Delta +# is kept under 2^32 by the 'normalize' procedure, to avoid a +# never-ended growth of memory used. Indeed, when you perform some +# computations, the Delta parameter (which represent the uncertainty +# on the value of the Mantissa) may increase. Exponent, as an +# integer, is limited to 32 bits, and this limit seems fair. The +# exponent is indeed involved in logarithmic computations, so it may +# be a mistake to give it a too large value. + +# Retrieving the parameters of a BigFloat is often done with that command : +# foreach {dummy int exp delta} $bigfloat {break} +# (dummy is not used, it is just used to get the "F" marker). +# The isInt, isFloat, checkNumber and checkFloat procedures are used +# to check data types +# +# Taylor development are often used to compute the analysis functions (like exp(),log()...) +# To learn how it is done in practice, take a look at ::math::bigfloat::_asin +# While doing computation on Mantissas, we do not care about the last digit, +# because if we compute correctly Deltas, the digits that remain will be exact. +################################################################################ + + +################################################################################ +# returns the absolute value +################################################################################ +proc ::math::bigfloat::abs {number} { + checkNumber $number + if {[isInt $number]} { + # set sign to positive for a BigInt + return [expr {abs($number)}] + } + # set sign to positive for a BigFloat into the Mantissa (index 1) + lset number 1 [expr {abs([lindex $number 1])}] + return $number +} + + +################################################################################ +# arccosinus of a BigFloat +################################################################################ +proc ::math::bigfloat::acos {x} { + # handy proc for checking datatype + checkFloat $x + foreach {dummy entier exp delta} $x {break} + set precision [expr {($exp<0)?(-$exp):1}] + # acos(0.0)=Pi/2 + # 26/07/2005 : changed precision from decimal to binary + # with the second parameter of pi command + set piOverTwo [floatRShift [pi $precision 1]] + if {[iszero $x]} { + # $x is too close to zero -> acos(0)=PI/2 + return $piOverTwo + } + # acos(-x)= Pi/2 + asin(x) + if {$entier<0} { + return [add $piOverTwo [asin [abs $x]]] + } + # we always use _asin to compute the result + # but as it is a Taylor development, the value given to [_asin] + # has to be a bit smaller than 1 ; by using that trick : acos(x)=asin(sqrt(1-x^2)) + # we can limit the entry of the Taylor development below 1/sqrt(2) + if {[compare $x [fromstr 0.7071]]>0} { + # x > sqrt(2)/2 : trying to make _asin converge quickly + # creating 0 and 1 with the same precision as the entry + set fzero [list F 0 -$precision 1] + # 1.000 with $precision zeros + set fone [list F [expr {1<<$precision}] -$precision 1] + # when $x is close to 1 (acos(1.0)=0.0) + if {[equal $fone $x]} { + return $fzero + } + if {[compare $fone $x]<0} { + # the behavior assumed because acos(x) is not defined + # when |x|>1 + error "acos on a number greater than 1" + } + # acos(x) = asin(sqrt(1 - x^2)) + # since 1 - cos(x)^2 = sin(x)^2 + # x> sqrt(2)/2 so x^2 > 1/2 so 1-x^2<1/2 + set x [sqrt [sub $fone [mul $x $x]]] + # the parameter named x is smaller than sqrt(2)/2 + return [_asin $x] + } + # acos(x) = Pi/2 - asin(x) + # x$expB} { + set diff [expr {$expA-$expB}] + set integerA [expr {$integerA<<$diff}] + set deltaA [expr {$deltaA<<$diff}] + incr integerA $integerB + incr deltaA $deltaB + return [normalize [list F $integerA $expB $deltaA]] + } elseif {$expA==$expB} { + # nothing to shift left + return [normalize [list F [incr integerA $integerB] $expA [incr deltaA $deltaB]]] + } else { + error "internal error" + } +} + +################################################################################ +# returns the sum A(BigFloat) + B(BigInt) +# the greatest advantage of this method is that the uncertainty +# of the result remains unchanged, in respect to the entry's uncertainty (deltaA) +################################################################################ +proc ::math::bigfloat::addInt2Float {a b} { + # type checking + checkFloat $a + if {![isInt $b]} { + error "second argument is not an integer" + } + # retrieving data from $a + foreach {dummy integerA expA deltaA} $a {break} + # to add an int to a BigFloat,... + if {$expA>0} { + # we have to put the integer integerA + # to the level of zero exponent : 1e8 --> 100000000e0 + set shift $expA + set integerA [expr {($integerA<<$shift)+$b}] + set deltaA [expr {$deltaA<<$shift}] + # we have to normalize, because we have shifted the mantissa + # and the uncertainty left + return [normalize [list F $integerA 0 $deltaA]] + } elseif {$expA==0} { + # integerA is already at integer level : float=(integerA)e0 + return [normalize [list F [incr integerA $b] \ + 0 $deltaA]] + } else { + # here we have something like 234e-2 + 3 + # we have to shift the integer left by the exponent |$expA| + incr integerA [expr {$b<<(-$expA)}] + return [normalize [list F $integerA $expA $deltaA]] + } +} + + +################################################################################ +# arcsinus of a BigFloat +################################################################################ +proc ::math::bigfloat::asin {x} { + # type checking + checkFloat $x + foreach {dummy entier exp delta} $x {break} + if {$exp>-1} { + error "not enough precision on input (asin)" + } + set precision [expr {-$exp}] + # when x=0, return 0 at the same precision as the input was + if {[iszero $x]} { + return [list F 0 -$precision 1] + } + # asin(-x)=-asin(x) + if {$entier<0} { + return [opp [asin [abs $x]]] + } + # 26/07/2005 : changed precision from decimal to binary + set piOverTwo [floatRShift [pi $precision 1]] + # now a little trick : asin(x)=Pi/2-asin(sqrt(1-x^2)) + # so we can limit the entry of the Taylor development + # to 1/sqrt(2)~0.7071 + # the comparison is : if x>0.7071 then ... + if {[compare $x [fromstr 0.7071]]>0} { + set fone [list F [expr {1<<$precision}] -$precision 1] + # asin(1)=Pi/2 (with the same precision as the entry has) + if {[equal $fone $x]} { + return $piOverTwo + } + if {[compare $x $fone]>0} { + error "asin on a number greater than 1" + } + # asin(x)=Pi/2-asin(sqrt(1-x^2)) + set x [sqrt [sub $fone [mul $x $x]]] + return [sub $piOverTwo [_asin $x]] + } + return [normalize [_asin $x]] +} + +################################################################################ +# _asin : arcsinus of numbers between 0 and +1 +################################################################################ +proc ::math::bigfloat::_asin {x} { + # Taylor development + # asin(x)=x + 1/2 x^3/3 + 3/2.4 x^5/5 + 3.5/2.4.6 x^7/7 + ... + # into this iterative form : + # asin(x)=x * (1 + 1/2 * x^2 * (1/3 + 3/4 *x^2 * (... + # ...* (1/(2n-1) + (2n-1)/2n * x^2 / (2n+1))...))) + # we show how is really computed the development : + # we don't need to set a var with x^n or a product of integers + # all we need is : x^2, 2n-1, 2n, 2n+1 and a few variables + foreach {dummy mantissa exp delta} $x {break} + set precision [expr {-$exp}] + if {$precision+1<[bits $mantissa]} { + error "sinus greater than 1" + } + # precision is the number of after-dot digits + set result $mantissa + set delta_final $delta + # resultat is the final result, and delta_final + # will contain the uncertainty of the result + # square is the square of the mantissa + set square [expr {$mantissa*$mantissa>>$precision}] + # dt is the uncertainty of Mantissa + set dt [expr {$mantissa*$delta>>($precision-1)}] + incr dt + set num 1 + # two will be used into the loop + set i 3 + set denom 2 + # the nth factor equals : $num/$denom* $mantissa/$i + set delta [expr {$delta*$square + $dt*($delta+$mantissa)}] + set delta [expr {($delta*$num)/ $denom >>$precision}] + incr delta + # we do not multiply the Mantissa by $num right now because it is 1 ! + # but we have Mantissa=$x + # and we want Mantissa*$x^2 * $num / $denom / $i + set mantissa [expr {($mantissa*$square>>$precision)/$denom}] + # do not forget the modified Taylor development : + # asin(x)=x * (1 + 1/2*x^2*(1/3 + 3/4*x^2*(...*(1/(2n-1) + (2n-1)/2n*x^2/(2n+1))...))) + # all we need is : x^2, 2n-1, 2n, 2n+1 and a few variables + # $num=2n-1 $denom=2n $square=x^2 and $i=2n+1 + set mantissa_temp [expr {$mantissa/$i}] + set delta_temp [expr {1+$delta/$i}] + # when the Mantissa increment is smaller than the Delta increment, + # we would not get much precision by continuing the development + while {$mantissa_temp!=0} { + # Mantissa = Mantissa * $num/$denom * $square + # Add Mantissa/$i, which is stored in $mantissa_temp, to the result + incr result $mantissa_temp + incr delta_final $delta_temp + # here we have $two instead of [fromstr 2] (optimization) + # num=num+2,i=i+2,denom=denom+2 + # because num=2n-1 denom=2n and i=2n+1 + incr num 2 + incr i 2 + incr denom 2 + # computes precisly the future Delta parameter + set delta [expr {$delta*$square+$dt*($delta+$mantissa)}] + set delta [expr {($delta*$num)/$denom>>$precision}] + incr delta + set mantissa [expr {$mantissa*$square>>$precision}] + set mantissa [expr {($mantissa*$num)/$denom}] + set mantissa_temp [expr {$mantissa/$i}] + set delta_temp [expr {1+$delta/$i}] + } + return [normalize [list F $result $exp $delta_final]] +} + +################################################################################ +# arctangent : returns atan(x) +################################################################################ +proc ::math::bigfloat::atan {x} { + checkFloat $x + foreach {dummy mantissa exp delta} $x {break} + if {$exp>=0} { + error "not enough precision to compute atan" + } + set precision [expr {-$exp}] + # atan(0)=0 + if {[iszero $x]} { + return [list F 0 -$precision $delta] + } + # atan(-x)=-atan(x) + if {$mantissa<0} { + return [opp [atan [abs $x]]] + } + # now x is strictly positive + # at this moment, we are trying to limit |x| to a fair acceptable number + # to ensure that Taylor development will converge quickly + set float1 [list F [expr {1<<$precision}] -$precision 1] + if {[compare $float1 $x]<0} { + # compare x to 2.4142 + if {[compare $x [fromstr 2.4142]]<0} { + # atan(x)=Pi/4 + atan((x-1)/(x+1)) + # as 10} { + # atan(x)=Pi/4 + atan((x-1)/(x+1)) + # x>0.420 so (x-1)/(x+1)=1 - 2/(x+1) > 1-2/1.414 + # > -0.414 + # x<1 so (x-1)/(x+1)<0 + set pi_sur_quatre [floatRShift [pi $precision 1] 2] + return [add $pi_sur_quatre [atan \ + [div [sub $x $float1] [add $x $float1]]]] + } + # precision increment : to have less uncertainty + # we add a little more precision so that the result would be more accurate + # Taylor development : x - x^3/3 + x^5/5 - ... + (-1)^(n+1)*x^(2n-1)/(2n-1) + # when we have n steps in Taylor development : the nth term is : + # x^(2n-1)/(2n-1) + # and the loss of precision is of 2n (n sums and n divisions) + # this command is called with x(precision-3/2)*log(2)-log(2n-1) + # hence log(2n-1)<2n-1 + # n*sqrt(2)>(precision-1.5)*log(2)+1-2n + # n*(sqrt(2)+2)>(precision-1.5)*log(2)+1 + set n [expr {int((log(2)*($precision-1.5)+1)/(sqrt(2)+2)+1)}] + incr precision $n + set mantissa [expr {$mantissa<<$n}] + set delta [expr {$delta<<$n}] + # end of adding precision increment + # now computing Taylor development : + # atan(x)=x - x^3/3 + x^5/5 - x^7/7 ... + (-1)^n*x^(2n+1)/(2n+1) + # atan(x)=x * (1 - x^2 * (1/3 - x^2 * (1/5 - x^2 * (...*(1/(2n-1) - x^2 / (2n+1))...)))) + # what do we need to compute this ? + # x^2 ($square), 2n+1 ($divider), $result, the nth term of the development ($t) + # and the nth term multiplied by 2n+1 ($temp) + # then we do this (with care keeping as much precision as possible): + # while ($t <>0) : + # $result=$result+$t + # $temp=$temp * $square + # $divider = $divider+2 + # $t=$temp/$divider + # end-while + set result $mantissa + set delta_end $delta + # we store the square of the integer (mantissa) + # Delta of Mantissa^2 = Delta * 2 = Delta << 1 + set delta_square [expr {$delta<<1}] + set square [expr {$mantissa*$mantissa>>$precision}] + # the (2n+1) divider + set divider 3 + # computing precisely the uncertainty + set delta [expr {1+($delta_square*$mantissa+$delta*$square>>$precision)}] + # temp contains (-1)^n*x^(2n+1) + set temp [expr {-$mantissa*$square>>$precision}] + set t [expr {$temp/$divider}] + set dt [expr {1+$delta/$divider}] + while {$t!=0} { + incr result $t + incr delta_end $dt + incr divider 2 + set delta [expr {1+($delta_square*abs($temp)+$delta*($delta_square+$square)>>$precision)}] + set temp [expr {-$temp*$square>>$precision}] + set t [expr {$temp/$divider}] + set dt [expr {1+$delta/$divider}] + } + # we have to normalize because the uncertainty might be greater than 2**16 + # moreover it is the most often case + return [normalize [list F $result [expr {$exp-$n}] $delta_end]] +} + + +################################################################################ +# compute atan(1/integer) at a given precision +# this proc is only used to compute Pi +# it is using the same Taylor development as [atan] +################################################################################ +proc ::math::bigfloat::_atanfract {integer precision} { + # Taylor development : x - x^3/3 + x^5/5 - ... + (-1)^(n+1)*x^(2n-1)/(2n-1) + # when we have n steps in Taylor development : the nth term is : + # 1/denom^(2n+1)/(2n+1) + # and the loss of precision is of 2n (n sums and n divisions) + # this command is called with integer>=5 + # + # We do not want to compute the Delta parameter, so we just + # can increment precision (with lshift) in order for the result to be precise. + # Remember : we compute atan2(1,$integer) with $precision bits + # $integer has no Delta parameter as it is a BigInt, of course, so + # theorically we could compute *any* number of digits. + # + # if we add an increment to the precision, say n: + # (1/5)^(2n-1)/(2n-1) has to be lower than (1/2)^(precision+n-1) + # Calculus : + # log(left term) < log(right term) + # log(1/left term) > log(1/right term) + # (2n-1)*log(5)+log(2n-1)>(precision+n-1)*log(2) + # n(2log(5)-log(2))>(precision-1)*log(2)-log(2n-1)+log(5) + # -log(2n-1)>-(2n-1) + # n(2log(5)-log(2)+2)>(precision-1)*log(2)+1+log(5) + set n [expr {int((($precision-1)*log(2)+1+log(5))/(2*log(5)-log(2)+2)+1)}] + incr precision $n + # first term of the development : 1/integer + set a [expr {(1<<$precision)/$integer}] + # 's' will contain the result + set s $a + # Taylor development : x - x^3/3 + x^5/5 - ... + (-1)^(n+1)*x^(2n-1)/(2n-1) + # equals x (1 - x^2 * (1/3 + x^2 * (... * (1/(2n-3) + (-1)^(n+1) * x^2 / (2n-1))...))) + # all we need to store is : 2n-1 ($denom), x^(2n+1) and x^2 ($square) and two results : + # - the nth term => $u + # - the nth term * (2n-1) => $t + # + of course, the result $s + set square [expr {$integer*$integer}] + set denom 3 + # $t is (-1)^n*x^(2n+1) + set t [expr {-$a/$square}] + set u [expr {$t/$denom}] + # we break the loop when the current term of the development is null + while {$u!=0} { + incr s $u + # denominator= (2n+1) + incr denom 2 + # div $t by x^2 + set t [expr {-$t/$square}] + set u [expr {$t/$denom}] + } + # go back to the initial precision + return [expr {$s>>$n}] +} + +# +# bits : computes the number of bits of an integer, approx. +# +proc ::math::bigfloat::bits {int} { + set l [string length [set int [expr {abs($int)}]]] + # int<10**l -> log_2(int)=l*log_2(10) + set l [expr {int($l*log(10)/log(2))+1}] + if {$int>>$l!=0} { + error "bad result: $l bits" + } + while {($int>>($l-1))==0} { + incr l -1 + } + return $l +} + +################################################################################ +# returns the integer part of a BigFloat, as a BigInt +# the result is the same one you would have +# if you had called [expr {ceil($x)}] +################################################################################ +proc ::math::bigfloat::ceil {number} { + checkFloat $number + set number [normalize $number] + if {[iszero $number]} { + return 0 + } + foreach {dummy integer exp delta} $number {break} + if {$exp>=0} { + error "not enough precision to perform rounding (ceil)" + } + # saving the sign ... + set sign [expr {$integer<0}] + set integer [expr {abs($integer)}] + # integer part + set try [expr {$integer>>(-$exp)}] + if {$sign} { + return [opp $try] + } + # fractional part + if {($try<<(-$exp))!=$integer} { + return [incr try] + } + return $try +} + + +################################################################################ +# checks each variable to be a BigFloat +# arguments : each argument is the name of a variable to be checked +################################################################################ +proc ::math::bigfloat::checkFloat {number} { + if {![isFloat $number]} { + error "BigFloat expected" + } +} + +################################################################################ +# checks if each number is either a BigFloat or a BigInt +# arguments : each argument is the name of a variable to be checked +################################################################################ +proc ::math::bigfloat::checkNumber {x} { + if {![isFloat $x] && ![isInt $x]} { + error "input is not an integer, nor a BigFloat" + } +} + + +################################################################################ +# returns 0 if A and B are equal, else returns 1 or -1 +# accordingly to the sign of (A - B) +################################################################################ +proc ::math::bigfloat::compare {a b} { + if {[isInt $a] && [isInt $b]} { + set diff [expr {$a-$b}] + if {$diff>0} {return 1} elseif {$diff<0} {return -1} + return 0 + } + checkFloat $a + checkFloat $b + if {[equal $a $b]} {return 0} + if {[lindex [sub $a $b] 1]<0} {return -1} + return 1 +} + + + + +################################################################################ +# gets cos(x) +# throws an error if there is not enough precision on the input +################################################################################ +proc ::math::bigfloat::cos {x} { + checkFloat $x + foreach {dummy integer exp delta} $x {break} + if {$exp>-2} { + error "not enough precision on floating-point number" + } + set precision [expr {-$exp}] + # cos(2kPi+x)=cos(x) + foreach {n integer} [divPiQuarter $integer $precision] {break} + # now integer>=0 and exp (multiplied by -1) + #idebug break + lset l 1 [expr {-([lindex $l 1])}] + # set the sign + if {$signe} { + lset l 0 [expr {-[lindex $l 0]}] + } + #idebug break + return [normalize [linsert $l 0 F]] +} + +################################################################################ +# compute cos(x) where 0<=x>1}] + set pis4 [expr {$pis2>>1}] + if {$x>=$pis4} { + # cos(Pi/2-x)=sin(x) + set x [expr {$pis2-$x}] + incr delta + return [_sin $x $precision $delta] + } + #idebug break + return [_cos $x $precision $delta] +} + +################################################################################ +# compute cos(x) where 0<=x>$precision)}] + # x=x^2 (because in this Taylor development, there are only even powers of x) + set x [expr {$x*$x>>$precision}] + set denom1 1 + set denom2 2 + set t [expr {-($x>>1)}] + set dt $d + while {$t!=0} { + incr s $t + incr delta $dt + incr denom1 2 + incr denom2 2 + set dt [expr {$x*$dt+($t+$dt)*$d>>$precision}] + incr dt + set t [expr {$x*$t>>$precision}] + set t [expr {-$t/($denom1*$denom2)}] + } + return [list $s $precision $delta] +} + +################################################################################ +# cotangent : the trivial algorithm is used +################################################################################ +proc ::math::bigfloat::cotan {x} { + return [::math::bigfloat::div [::math::bigfloat::cos $x] [::math::bigfloat::sin $x]] +} + +################################################################################ +# converts angles from degrees to radians +# deg/180=rad/Pi +################################################################################ +proc ::math::bigfloat::deg2rad {x} { + checkFloat $x + set xLen [expr {-[lindex $x 2]}] + if {$xLen<3} { + error "number too loose to convert to radians" + } + set pi [pi $xLen 1] + return [div [mul $x $pi] 180] +} + + + +################################################################################ +# private proc to get : x modulo Pi/2 +# and the quotient (x divided by Pi/2) +# used by cos , sin & others +################################################################################ +proc ::math::bigfloat::divPiQuarter {integer precision} { + incr precision 2 + set integer [expr {$integer<<1}] + #idebug break + set P [_pi $precision] + # modulo 2Pi + set integer [expr {$integer%$P}] + # end modulo 2Pi + # 2Pi>>1 = Pi of course! + set P [expr {$P>>1}] + set n [expr {$integer/$P}] + set integer [expr {$integer%$P}] + # now divide by Pi/2 + # multiply n by 2 + set n [expr {$n<<1}] + # pi/2=Pi>>1 + set P [expr {$P>>1}] + return [list [incr n [expr {$integer/$P}]] [expr {($integer%$P)>>1}]] +} + + +################################################################################ +# divide A by B and returns the result +# throw error : divide by zero +################################################################################ +proc ::math::bigfloat::div {a b} { + checkNumber $a + checkNumber $b + # dispatch to an appropriate procedure + if {[isInt $a]} { + if {[isInt $b]} { + return [expr {$a/$b}] + } + error "trying to divide an integer by a BigFloat" + } + if {[isInt $b]} {return [divFloatByInt $a $b]} + foreach {dummy integerA expA deltaA} $a {break} + foreach {dummy integerB expB deltaB} $b {break} + # computes the limits of the doubt (or uncertainty) interval + set BMin [expr {$integerB-$deltaB}] + set BMax [expr {$integerB+$deltaB}] + if {$BMin>$BMax} { + # swap BMin and BMax + set temp $BMin + set BMin $BMax + set BMax $temp + } + # multiply by zero gives zero + if {$integerA==0} { + # why not return any number or the integer 0 ? + # because there is an exponent that might be different between two BigFloats + # 0.00 --> exp = -2, 0.000000 -> exp = -6 + return $a + } + # test of the division by zero + if {$BMin*$BMax<0 || $BMin==0 || $BMax==0} { + error "divide by zero" + } + # shift A because we need accuracy + set l [bits $integerB] + set integerA [expr {$integerA<<$l}] + set deltaA [expr {$deltaA<<$l}] + set exp [expr {$expA-$l-$expB}] + # relative uncertainties (dX/X) are added + # to give the relative uncertainty of the result + # i.e. 3% on A + 2% on B --> 5% on the quotient + # d(A/B)/(A/B)=dA/A + dB/B + # Q=A/B + # dQ=dA/B + dB*A/B*B + # dQ is "delta" + set delta [expr {($deltaB*abs($integerA))/abs($integerB)}] + set delta [expr {([incr delta]+$deltaA)/abs($integerB)}] + set quotient [expr {$integerA/$integerB}] + if {$integerB*$integerA<0} { + incr quotient -1 + } + return [normalize [list F $quotient $exp [incr delta]]] +} + + + + +################################################################################ +# divide a BigFloat A by a BigInt B +# throw error : divide by zero +################################################################################ +proc ::math::bigfloat::divFloatByInt {a b} { + # type check + checkFloat $a + if {![isInt $b]} { + error "second argument is not an integer" + } + foreach {dummy integer exp delta} $a {break} + # zero divider test + if {$b==0} { + error "divide by zero" + } + # shift left for accuracy ; see other comments in [div] procedure + set l [bits $b] + set integer [expr {$integer<<$l}] + set delta [expr {$delta<<$l}] + incr exp -$l + set integer [expr {$integer/$b}] + # the uncertainty is always evaluated to the ceil value + # and as an absolute value + set delta [expr {$delta/abs($b)+1}] + return [normalize [list F $integer $exp $delta]] +} + + + + + +################################################################################ +# returns 1 if A and B are equal, 0 otherwise +# IN : a, b (BigFloats) +################################################################################ +proc ::math::bigfloat::equal {a b} { + if {[isInt $a] && [isInt $b]} { + return [expr {$a==$b}] + } + # now a & b should only be BigFloats + checkFloat $a + checkFloat $b + foreach {dummy aint aexp adelta} $a {break} + foreach {dummy bint bexp bdelta} $b {break} + # set all Mantissas and Deltas to the same level (exponent) + # with lshift + set diff [expr {$aexp-$bexp}] + if {$diff<0} { + set diff [expr {-$diff}] + set bint [expr {$bint<<$diff}] + set bdelta [expr {$bdelta<<$diff}] + } elseif {$diff>0} { + set aint [expr {$aint<<$diff}] + set adelta [expr {$adelta<<$diff}] + } + # compute limits of the number's doubt range + set asupInt [expr {$aint+$adelta}] + set ainfInt [expr {$aint-$adelta}] + set bsupInt [expr {$bint+$bdelta}] + set binfInt [expr {$bint-$bdelta}] + # A & B are equal + # if their doubt ranges overlap themselves + if {$bint==$aint} { + return 1 + } + if {$bint>$aint} { + set r [expr {$asupInt>=$binfInt}] + } else { + set r [expr {$bsupInt>=$ainfInt}] + } + return $r +} + +################################################################################ +# returns exp(X) where X is a BigFloat +################################################################################ +proc ::math::bigfloat::exp {x} { + checkFloat $x + foreach {dummy integer exp delta} $x {break} + if {$exp>=0} { + # shift till exp<0 with respect to the internal representation + # of the number + incr exp + set integer [expr {$integer<<$exp}] + set delta [expr {$delta<<$exp}] + set exp -1 + } + # add 8 bits of precision for safety + set precision [expr {8-$exp}] + set integer [expr {$integer<<8}] + set delta [expr {$delta<<8}] + set Log2 [_log2 $precision] + set new_exp [expr {$integer/$Log2}] + set integer [expr {$integer%$Log2}] + # $new_exp = integer part of x/log(2) + # $integer = remainder + # exp(K.log(2)+r)=2^K.exp(r) + # so we just have to compute exp(r), r is small so + # the Taylor development will converge quickly + incr delta $new_exp + foreach {integer delta} [_exp $integer $precision $delta] {break} + set delta [expr {$delta>>8}] + incr precision -8 + # multiply by 2^K , and take care of the sign + # example : X=-6.log(2)+0.01 + # exp(X)=exp(0.01)*2^-6 + # if {abs($new_exp)>>30!=0} { + # error "floating-point overflow due to exp" + # } + set exp [expr {$new_exp-$precision}] + incr delta + return [normalize [list F [expr {$integer>>8}] $exp $delta]] +} + + +################################################################################ +# private procedure to compute exponentials +# using Taylor development of exp(x) : +# exp(x)=1+ x + x^2/2 + x^3/3! +...+x^n/n! +# input : integer (the mantissa) +# precision (the number of decimals) +# delta (the doubt limit, or uncertainty) +# returns a list : 1. the mantissa of the result +# 2. the doubt limit, or uncertainty +################################################################################ +proc ::math::bigfloat::_exp {integer precision delta} { + if {$integer==0} { + # exp(0)=1 + return [list [expr {1<<$precision}] $delta] + } + set s [expr {(1<<$precision)+$integer}] + set d [expr {1+$delta/2}] + incr delta $delta + # dt = uncertainty on x^2 + set dt [expr {1+($d*$integer>>$precision)}] + # t= x^2/2 = x^2>>1 + set t [expr {$integer*$integer>>$precision+1}] + set denom 2 + while {$t!=0} { + # the sum is called 's' + incr s $t + incr delta $dt + # we do not have to keep trace of the factorial, we just iterate divisions + incr denom + # add delta + set d [expr {1+$d/$denom}] + incr dt $d + # get x^n from x^(n-1) + set t [expr {($integer*$t>>$precision)/$denom}] + } + return [list $s $delta] +} +################################################################################ +# divide a BigFloat by 2 power 'n' +################################################################################ +proc ::math::bigfloat::floatRShift {float {n 1}} { + return [lset float 2 [expr {[lindex $float 2]-$n}]] +} + + + +################################################################################ +# procedure floor : identical to [expr floor($x)] in functionality +# arguments : number IN (a BigFloat) +# returns : the floor value as a BigInt +################################################################################ +proc ::math::bigfloat::floor {number} { + checkFloat $number + if {[iszero $number]} { + # returns the BigInt 0 + return 0 + } + foreach {dummy integer exp delta} $number {break} + if {$exp>=0} { + error "not enough precision to perform rounding (floor)" + } + # floor(n.xxxx)=n when n is positive + if {$integer>0} {return [expr {$integer>>(-$exp)}]} + set integer [expr {abs($integer)}] + # integer part + set try [expr {$integer>>(-$exp)}] + # floor(-n.xxxx)=-(n+1) when xxxx!=0 + if {$try<<(-$exp)!=$integer} { + incr try + } + return [expr {-$try}] +} + + +################################################################################ +# returns a list formed by an integer and an exponent +# x = (A +/- C) * 10 power B +# return [list "F" A B C] (where F is the BigFloat tag) +# A and C are BigInts, B is a raw integer +# return also a BigInt when there is neither a dot, nor a 'e' exponent +# +# arguments : -base base integer +# or integer +# or float +# or float trailingZeros +################################################################################ +proc ::math::bigfloat::fromstr {number {addzeros 0}} { + if {$addzeros<0} { + error "second argument has to be a positive integer" + } + # eliminate the sign problem + # added on 05/08/2005 + # setting '$signe' to the sign of the number + set number [string trimleft $number +] + if {[string index $number 0]=="-"} { + set signe 1 + set string [string range $number 1 end] + } else { + set signe 0 + set string $number + } + # integer case (not a floating-point number) + if {[string is digit $string]} { + if {$addzeros!=0} { + error "second argument not allowed with an integer" + } + # we have completed converting an integer to a BigInt + # please note that most math::bigfloat procs accept BigInts as arguments + return $number + } + # floating-point number : check for an exponent + # scientific notation + set tab [split $string e] + if {[llength $tab]>2} { + # there are more than one 'e' letter in the number + error "syntax error in number : $string" + } + if {[llength $tab]==2} { + set exp [lindex $tab 1] + # now exp can look like +099 so you need to handle octal numbers + # too bad... + # find the sign (if any?) + regexp {^[\+\-]?} $exp expsign + # trim the number with left-side 0's + set found [string length $expsign] + set exp $expsign[string trimleft [string range $exp $found end] 0] + if {$exp eq $expsign} { set exp ${expsign}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 + # note however, for a -0 we may be left with an empty mantissa + # Ticket [ca6a2cfef5d6e742177add4954c748170b86a02d] + if {$signe} { + set mantissa -[string trimleft $mantissa 0] + if {$mantissa eq "-"} { set 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.4 diff --git a/vendor/math/bigfloat2.test b/vendor/math/bigfloat2.test new file mode 100644 index 00000000..3cd11d78 --- /dev/null +++ b/vendor/math/bigfloat2.test @@ -0,0 +1,666 @@ +# -*- 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 + + foreach {x rx r} { + 0 0 0 + 0.0 0. {F 0 -18 32768} + .0 0. {F 0 -18 32768} + +0 0 0 + +0.0 0. {F 0 -18 32768} + +.0 0. {F 0 -18 32768} + -0 -0 -0 + -0.0 0. {F 0 -19 52430} + -.0 0. {F 0 -19 52430} + } { + test bigfloat2-fromstr-3.[incr k] {fromstr zeroes} { + fromstr $x + } $r + + test bigfloat2-fromstr-4.${k} {fromstr zeroes as double} { + tostr [fromstr $x] + } $rx + } + unset k + + test bigfloat2-fromstr-5.0 {fromstr zero exponent} { + fromstr 1.0e0 + } {F 524288 -19 52430} + + test bigfloat2-fromstr-6.0 {fromstr zero exponent} { + tostr [fromstr 1.0e0] + } 1. + + ################################################################################ + # 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 +return diff --git a/vendor/math/bignum.man b/vendor/math/bignum.man new file mode 100644 index 00000000..b8ac5330 --- /dev/null +++ b/vendor/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 }] +[copyright {2004 Arjen Markus }] +[moddesc {Tcl Math Library}] +[titledesc {Arbitrary precision integer numbers}] +[category Mathematics] +[require Tcl [opt 8.4]] +[require math::bignum [opt 3.1]] + +[description] +[para] +The bignum package provides arbitrary precision integer math +(also known as "big numbers") capabilities to the Tcl language. +Big numbers are internally represented at Tcl lists: this +package provides a set of procedures operating against +the internal representation in order to: +[list_begin itemized] +[item] +perform math operations + +[item] +convert bignums from the internal representation to a string in +the desired radix and vice versa. + +[list_end] +But the two constants "0" and "1" are automatically converted to +the internal representation, in order to easily compare a number to zero, +or increment a big number. +[para] + +The bignum interface is opaque, so +operations on bignums that are not returned by procedures +in this package (but created by hand) may lead to unspecified behaviours. +It's safe to treat bignums as pure values, so there is no need +to free a bignum, or to duplicate it via a special operation. + +[section "EXAMPLES"] +This section shows some simple example. This library being just +a way to perform math operations, examples may be the simplest way +to learn how to work with it. Consult the API section of +this man page for information about individual procedures. + +[para] +[example_begin] + package require math::bignum + + # Multiplication of two bignums + set a [lb]::math::bignum::fromstr 88888881111111[rb] + set b [lb]::math::bignum::fromstr 22222220000000[rb] + set c [lb]::math::bignum::mul $a $b[rb] + puts [lb]::math::bignum::tostr $c[rb] ; # => will output 1975308271604953086420000000 + set c [lb]::math::bignum::sqrt $c[rb] + puts [lb]::math::bignum::tostr $c[rb] ; # => will output 44444440277777 + + # From/To string conversion in different radix + set a [lb]::math::bignum::fromstr 1100010101010111001001111010111 2[rb] + puts [lb]::math::bignum::tostr $a 16[rb] ; # => will output 62ab93d7 + + # Factorial example + proc fact n { + # fromstr is not needed for 0 and 1 + set z 1 + for {set i 2} {$i <= $n} {incr i} { + set z [lb]::math::bignum::mul $z [lb]::math::bignum::fromstr $i[rb][rb] + } + return $z + } + + puts [lb]::math::bignum::tostr [lb]fact 100[rb][rb] +[example_end] + +[section "API"] +[list_begin definitions] + +[call [cmd ::math::bignum::fromstr] [arg string] ?[arg radix]?] +Convert [emph string] into a bignum. If [emph radix] is omitted or zero, +the string is interpreted in hex if prefixed with +[emph 0x], in octal if prefixed with [emph ox], +in binary if it's pefixed with [emph bx], as a number in +radix 10 otherwise. If instead the [emph radix] argument +is specified in the range 2-36, the [emph string] is interpreted +in the given radix. Please note that this conversion is +not needed for two constants : [emph 0] and [emph 1]. (see the example) + +[call [cmd ::math::bignum::tostr] [arg bignum] ?[arg radix]?] +Convert [emph bignum] into a string representing the number +in the specified radix. If [emph radix] is omitted, the +default is 10. + +[call [cmd ::math::bignum::sign] [arg bignum]] +Return the sign of the bignum. +The procedure returns 0 if the number is positive, 1 if it's negative. + +[call [cmd ::math::bignum::abs] [arg bignum]] +Return the absolute value of the bignum. + +[call [cmd ::math::bignum::cmp] [arg a] [arg b]] +Compare the two bignums a and b, returning [emph 0] if [emph {a == b}], +[emph 1] if [emph {a > b}], and [emph -1] if [emph {a < b}]. + +[call [cmd ::math::bignum::iszero] [arg bignum]] +Return true if [emph bignum] value is zero, otherwise false is returned. + +[call [cmd ::math::bignum::lt] [arg a] [arg b]] +Return true if [emph {a < b}], otherwise false is returned. + +[call [cmd ::math::bignum::le] [arg a] [arg b]] +Return true if [emph {a <= b}], otherwise false is returned. + +[call [cmd ::math::bignum::gt] [arg a] [arg b]] +Return true if [emph {a > b}], otherwise false is returned. + +[call [cmd ::math::bignum::ge] [arg a] [arg b]] +Return true if [emph {a >= b}], otherwise false is returned. + +[call [cmd ::math::bignum::eq] [arg a] [arg b]] +Return true if [emph {a == b}], otherwise false is returned. + +[call [cmd ::math::bignum::ne] [arg a] [arg b]] +Return true if [emph {a != b}], otherwise false is returned. + +[call [cmd ::math::bignum::isodd] [arg bignum]] +Return true if [emph bignum] is odd. + +[call [cmd ::math::bignum::iseven] [arg bignum]] +Return true if [emph bignum] is even. + +[call [cmd ::math::bignum::add] [arg a] [arg b]] +Return the sum of the two bignums [emph a] and [emph b]. + +[call [cmd ::math::bignum::sub] [arg a] [arg b]] +Return the difference of the two bignums [emph a] and [emph b]. + +[call [cmd ::math::bignum::mul] [arg a] [arg b]] +Return the product of the two bignums [emph a] and [emph b]. +The implementation uses Karatsuba multiplication if both +the numbers are bigger than a given threshold, otherwise +the direct algorith is used. + +[call [cmd ::math::bignum::divqr] [arg a] [arg b]] +Return a two-elements list containing as first element +the quotient of the division between the two bignums +[emph a] and [emph b], and the remainder of the division as second element. + +[call [cmd ::math::bignum::div] [arg a] [arg b]] +Return the quotient of the division between the two +bignums [emph a] and [emph b]. + +[call [cmd ::math::bignum::rem] [arg a] [arg b]] +Return the remainder of the division between the two +bignums [emph a] and [emph b]. + +[call [cmd ::math::bignum::mod] [arg n] [arg m]] +Return [emph n] modulo [emph m]. This operation is +called modular reduction. + +[call [cmd ::math::bignum::pow] [arg base] [arg exp]] +Return [emph base] raised to the exponent [emph exp]. + +[call [cmd ::math::bignum::powm] [arg base] [arg exp] [arg m]] +Return [emph base] raised to the exponent [emph exp], +modulo [emph m]. This function is often used in the field +of cryptography. + +[call [cmd ::math::bignum::sqrt] [arg bignum]] +Return the integer part of the square root of [emph bignum] + +[call [cmd ::math::bignum::rand] [arg bits]] +Return a random number of at most [emph bits] bits. +The returned number is internally generated using Tcl's [emph {expr rand()}] +function and is not suitable where an unguessable and cryptographically +secure random number is needed. + +[call [cmd ::math::bignum::lshift] [arg bignum] [arg bits]] +Return the result of left shifting [emph bignum]'s binary +representation of [emph bits] positions on the left. +This is equivalent to multiplying by 2^[emph bits] but much faster. + +[call [cmd ::math::bignum::rshift] [arg bignum] [arg bits]] +Return the result of right shifting [emph bignum]'s binary +representation of [emph bits] positions on the right. +This is equivalent to dividing by [emph 2^bits] but much faster. + +[call [cmd ::math::bignum::bitand] [arg a] [arg b]] +Return the result of doing a bitwise AND operation on a +and b. The operation is restricted to positive numbers, +including zero. When negative numbers are provided as +arguments the result is undefined. + +[call [cmd ::math::bignum::bitor] [arg a] [arg b]] +Return the result of doing a bitwise OR operation on a +and b. The operation is restricted to positive numbers, +including zero. When negative numbers are provided as +arguments the result is undefined. + +[call [cmd ::math::bignum::bitxor] [arg a] [arg b]] +Return the result of doing a bitwise XOR operation on a +and b. The operation is restricted to positive numbers, +including zero. When negative numbers are provided as +arguments the result is undefined. + +[call [cmd ::math::bignum::setbit] [arg bignumVar] [arg bit]] +Set the bit at [emph bit] position to 1 in the bignum stored +in the variable [emph bignumVar]. Bit 0 is the least significant. + +[call [cmd ::math::bignum::clearbit] [arg bignumVar] [arg bit]] +Set the bit at [emph bit] position to 0 in the bignum stored +in the variable [emph bignumVar]. Bit 0 is the least significant. + +[call [cmd ::math::bignum::testbit] [arg bignum] [arg bit]] +Return true if the bit at the [emph bit] position of [emph bignum] +is on, otherwise false is returned. If [emph bit] is out of +range, it is considered as set to zero. + +[call [cmd ::math::bignum::bits] [arg bignum]] +Return the number of bits needed to represent bignum in radix 2. + +[list_end] +[para] + +[vset CATEGORY {math :: bignum}] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/vendor/math/bignum.tcl b/vendor/math/bignum.tcl new file mode 100644 index 00000000..38e1fbbd --- /dev/null +++ b/vendor/math/bignum.tcl @@ -0,0 +1,900 @@ +# bignum library in pure Tcl [VERSION 7Sep2004] +# Copyright (C) 2004 Salvatore Sanfilippo +# Copyright (C) 2004 Arjen Markus +# +# LICENSE +# +# This software is: +# Copyright (C) 2004 Salvatore Sanfilippo +# Copyright (C) 2004 Arjen Markus +# The following terms apply to all files associated with the software +# unless explicitly disclaimed in individual files. +# +# The authors hereby grant permission to use, copy, modify, distribute, +# and license this software and its documentation for any purpose, provided +# that existing copyright notices are retained in all copies and that this +# notice is included verbatim in any distributions. No written agreement, +# license, or royalty fee is required for any of the authorized uses. +# Modifications to this software may be copyrighted by their authors +# and need not follow the licensing terms described here, provided that +# the new terms are clearly indicated on the first page of each file where +# they apply. +# +# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY +# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY +# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. +# +# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE +# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE +# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +# MODIFICATIONS. +# +# GOVERNMENT USE: If you are acquiring this software on behalf of the +# U.S. government, the Government shall have only "Restricted Rights" +# in the software and related documentation as defined in the Federal +# Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you +# are acquiring the software on behalf of the Department of Defense, the +# software shall be classified as "Commercial Computer Software" and the +# Government shall have only "Restricted Rights" as defined in Clause +# 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the +# authors grant the U.S. Government and others acting in its behalf +# permission to use and distribute the software in accordance with the +# terms specified in this license. + +# TODO +# - pow and powm should check if the exponent is zero in order to return one + +package require Tcl 8.4 + +namespace eval ::math::bignum {} + +#################################### Misc ###################################### + +# Don't change atombits define if you don't know what you are doing. +# Note that it must be a power of two, and that 16 is too big +# because expr may overflow in the product of two 16 bit numbers. +set ::math::bignum::atombits 16 +set ::math::bignum::atombase [expr {1 << $::math::bignum::atombits}] +set ::math::bignum::atommask [expr {$::math::bignum::atombase-1}] + +# Note: to change 'atombits' is all you need to change the +# library internal representation base. + +# Return the max between a and b (not bignums) +proc ::math::bignum::max {a b} { + expr {($a > $b) ? $a : $b} +} + +# Return the min between a and b (not bignums) +proc ::math::bignum::min {a b} { + expr {($a < $b) ? $a : $b} +} + +############################ Basic bignum operations ########################### + +# Returns a new bignum initialized to the value of 0. +# +# The big numbers are represented as a Tcl lists +# The all-is-a-string representation does not pay here +# bignums in Tcl are already slow, we can't slow-down it more. +# +# The bignum representation is [list bignum ... ] +# Where the atom0 is the least significant. Atoms are the digits +# of a number in base 2^$::math::bignum::atombits +# +# The sign is 0 if the number is positive, 1 for negative numbers. + +# Note that the function accepts an argument used in order to +# create a bignum of atoms. For default zero is +# represented as a single zero atom. +# +# The function is designed so that "set b [zero [atoms $a]]" will +# produce 'b' with the same number of atoms as 'a'. +proc ::math::bignum::zero {{value 0}} { + set v [list bignum 0 0] + while { $value > 1 } { + lappend v 0 + incr value -1 + } + return $v +} + +# Get the bignum sign +proc ::math::bignum::sign bignum { + lindex $bignum 1 +} + +# Get the number of atoms in the bignum +proc ::math::bignum::atoms bignum { + expr {[llength $bignum]-2} +} + +# Get the i-th atom out of a bignum. +# If the bignum is shorter than i atoms, the function +# returns 0. +proc ::math::bignum::atom {bignum i} { + if {[::math::bignum::atoms $bignum] < [expr {$i+1}]} { + return 0 + } else { + lindex $bignum [expr {$i+2}] + } +} + +# Set the i-th atom out of a bignum. If the bignum +# has less than 'i+1' atoms, add zero atoms to reach i. +proc ::math::bignum::setatom {bignumvar i atomval} { + upvar 1 $bignumvar bignum + while {[::math::bignum::atoms $bignum] < [expr {$i+1}]} { + lappend bignum 0 + } + lset bignum [expr {$i+2}] $atomval +} + +# Set the bignum sign +proc ::math::bignum::setsign {bignumvar sign} { + upvar 1 $bignumvar bignum + lset bignum 1 $sign +} + +# Remove trailing atoms with a value of zero +# The normalized bignum is returned +proc ::math::bignum::normalize bignumvar { + upvar 1 $bignumvar bignum + set atoms [expr {[llength $bignum]-2}] + set i [expr {$atoms+1}] + while {$atoms && [lindex $bignum $i] == 0} { + set bignum [lrange $bignum 0 end-1] + incr atoms -1 + incr i -1 + } + if {!$atoms} { + set bignum [list bignum 0 0] + } + return $bignum +} + +# Return the absolute value of N +proc ::math::bignum::abs n { + ::math::bignum::setsign n 0 + return $n +} + +################################# Comparison ################################### + +# Compare by absolute value. Called by ::math::bignum::cmp after the sign check. +# +# Returns 1 if |a| > |b| +# 0 if a == b +# -1 if |a| < |b| +# +proc ::math::bignum::abscmp {a b} { + if {[llength $a] > [llength $b]} { + return 1 + } elseif {[llength $a] < [llength $b]} { + return -1 + } + set j [expr {[llength $a]-1}] + while {$j >= 2} { + if {[lindex $a $j] > [lindex $b $j]} { + return 1 + } elseif {[lindex $a $j] < [lindex $b $j]} { + return -1 + } + incr j -1 + } + return 0 +} + +# High level comparison. Return values: +# +# 1 if a > b +# -1 if a < b +# 0 if a == b +# +proc ::math::bignum::cmp {a b} { ; # same sign case + set a [_treat $a] + set b [_treat $b] + if {[::math::bignum::sign $a] == [::math::bignum::sign $b]} { + if {[::math::bignum::sign $a] == 0} { + ::math::bignum::abscmp $a $b + } else { + expr {-([::math::bignum::abscmp $a $b])} + } + } else { ; # different sign case + if {[::math::bignum::sign $a]} {return -1} + return 1 + } +} + +# Return true if 'z' is zero. +proc ::math::bignum::iszero z { + set z [_treat $z] + expr {[llength $z] == 3 && [lindex $z 2] == 0} +} + +# Comparison facilities +proc ::math::bignum::lt {a b} {expr {[::math::bignum::cmp $a $b] < 0}} +proc ::math::bignum::le {a b} {expr {[::math::bignum::cmp $a $b] <= 0}} +proc ::math::bignum::gt {a b} {expr {[::math::bignum::cmp $a $b] > 0}} +proc ::math::bignum::ge {a b} {expr {[::math::bignum::cmp $a $b] >= 0}} +proc ::math::bignum::eq {a b} {expr {[::math::bignum::cmp $a $b] == 0}} +proc ::math::bignum::ne {a b} {expr {[::math::bignum::cmp $a $b] != 0}} + +########################### Addition / Subtraction ############################# + +# Add two bignums, don't care about the sign. +proc ::math::bignum::rawAdd {a b} { + while {[llength $a] < [llength $b]} {lappend a 0} + while {[llength $b] < [llength $a]} {lappend b 0} + set r [::math::bignum::zero [expr {[llength $a]-1}]] + set car 0 + for {set i 2} {$i < [llength $a]} {incr i} { + set sum [expr {[lindex $a $i]+[lindex $b $i]+$car}] + set car [expr {$sum >> $::math::bignum::atombits}] + set sum [expr {$sum & $::math::bignum::atommask}] + lset r $i $sum + } + if {$car} { + lset r $i $car + } + ::math::bignum::normalize r +} + +# Subtract two bignums, don't care about the sign. a > b condition needed. +proc ::math::bignum::rawSub {a b} { + set atoms [::math::bignum::atoms $a] + set r [::math::bignum::zero $atoms] + while {[llength $b] < [llength $a]} {lappend b 0} ; # b padding + set car 0 + incr atoms 2 + for {set i 2} {$i < $atoms} {incr i} { + set sub [expr {[lindex $a $i]-[lindex $b $i]-$car}] + set car 0 + if {$sub < 0} { + incr sub $::math::bignum::atombase + set car 1 + } + lset r $i $sub + } + # Note that if a > b there is no car in the last for iteration + ::math::bignum::normalize r +} + +# Higher level addition, care about sign and call rawAdd or rawSub +# as needed. +proc ::math::bignum::add {a b} { + set a [_treat $a] + set b [_treat $b] + # Same sign case + if {[::math::bignum::sign $a] == [::math::bignum::sign $b]} { + set r [::math::bignum::rawAdd $a $b] + ::math::bignum::setsign r [::math::bignum::sign $a] + } else { + # Different sign case + set cmp [::math::bignum::abscmp $a $b] + # 's' is the sign, set accordingly to A or B negative + set s [expr {[::math::bignum::sign $a] == 1}] + switch -- $cmp { + 0 {return [::math::bignum::zero]} + 1 { + set r [::math::bignum::rawSub $a $b] + ::math::bignum::setsign r $s + return $r + } + -1 { + set r [::math::bignum::rawSub $b $a] + ::math::bignum::setsign r [expr {!$s}] + return $r + } + } + } + return $r +} + +# Higher level subtraction, care about sign and call rawAdd or rawSub +# as needed. +proc ::math::bignum::sub {a b} { + set a [_treat $a] + set b [_treat $b] + # Different sign case + if {[::math::bignum::sign $a] != [::math::bignum::sign $b]} { + set r [::math::bignum::rawAdd $a $b] + ::math::bignum::setsign r [::math::bignum::sign $a] + } else { + # Same sign case + set cmp [::math::bignum::abscmp $a $b] + # 's' is the sign, set accordingly to A and B both negative or positive + set s [expr {[::math::bignum::sign $a] == 1}] + switch -- $cmp { + 0 {return [::math::bignum::zero]} + 1 { + set r [::math::bignum::rawSub $a $b] + ::math::bignum::setsign r $s + return $r + } + -1 { + set r [::math::bignum::rawSub $b $a] + ::math::bignum::setsign r [expr {!$s}] + return $r + } + } + } + return $r +} + +############################### Multiplication ################################# + +set ::math::bignum::karatsubaThreshold 32 + +# Multiplication. Calls Karatsuba that calls Base multiplication under +# a given threshold. +proc ::math::bignum::mul {a b} { + set a [_treat $a] + set b [_treat $b] + set r [::math::bignum::kmul $a $b] + # The sign is the xor between the two signs + ::math::bignum::setsign r [expr {[::math::bignum::sign $a]^[::math::bignum::sign $b]}] +} + +# Karatsuba Multiplication +proc ::math::bignum::kmul {a b} { + set n [expr {[::math::bignum::max [llength $a] [llength $b]]-2}] + set nmin [expr {[::math::bignum::min [llength $a] [llength $b]]-2}] + if {$nmin < $::math::bignum::karatsubaThreshold} {return [::math::bignum::bmul $a $b]} + set m [expr {($n+($n&1))/2}] + + set x0 [concat [list bignum 0] [lrange $a 2 [expr {$m+1}]]] + set y0 [concat [list bignum 0] [lrange $b 2 [expr {$m+1}]]] + set x1 [concat [list bignum 0] [lrange $a [expr {$m+2}] end]] + set y1 [concat [list bignum 0] [lrange $b [expr {$m+2}] end]] + + if {0} { + puts "m: $m" + puts "x0: $x0" + puts "x1: $x1" + puts "y0: $y0" + puts "y1: $y1" + } + + set p1 [::math::bignum::kmul $x1 $y1] + set p2 [::math::bignum::kmul $x0 $y0] + set p3 [::math::bignum::kmul [::math::bignum::add $x1 $x0] [::math::bignum::add $y1 $y0]] + + set p3 [::math::bignum::sub $p3 $p1] + set p3 [::math::bignum::sub $p3 $p2] + set p1 [::math::bignum::lshiftAtoms $p1 [expr {$m*2}]] + set p3 [::math::bignum::lshiftAtoms $p3 $m] + set p3 [::math::bignum::add $p3 $p1] + set p3 [::math::bignum::add $p3 $p2] + return $p3 +} + +# Base Multiplication. +proc ::math::bignum::bmul {a b} { + set r [::math::bignum::zero [expr {[llength $a]+[llength $b]-3}]] + for {set j 2} {$j < [llength $b]} {incr j} { + set car 0 + set t [list bignum 0 0] + for {set i 2} {$i < [llength $a]} {incr i} { + # note that A = B * C + D + E + # with A of N*2 bits and C,D,E of N bits + # can't overflow since: + # (2^N-1)*(2^N-1)+(2^N-1)+(2^N-1) == 2^(2*N)-1 + set t0 [lindex $a $i] + set t1 [lindex $b $j] + set t2 [lindex $r [expr {$i+$j-2}]] + set mul [expr {wide($t0)*$t1+$t2+$car}] + set car [expr {$mul >> $::math::bignum::atombits}] + set mul [expr {$mul & $::math::bignum::atommask}] + lset r [expr {$i+$j-2}] $mul + } + if {$car} { + lset r [expr {$i+$j-2}] $car + } + } + ::math::bignum::normalize r +} + +################################## Shifting #################################### + +# Left shift 'z' of 'n' atoms. Low-level function used by ::math::bignum::lshift +# Exploit the internal representation to go faster. +proc ::math::bignum::lshiftAtoms {z n} { + while {$n} { + set z [linsert $z 2 0] + incr n -1 + } + return $z +} + +# Right shift 'z' of 'n' atoms. Low-level function used by ::math::bignum::lshift +# Exploit the internal representation to go faster. +proc ::math::bignum::rshiftAtoms {z n} { + set z [lreplace $z 2 [expr {$n+1}]] +} + +# Left shift 'z' of 'n' bits. Low-level function used by ::math::bignum::lshift. +# 'n' must be <= $::math::bignum::atombits +proc ::math::bignum::lshiftBits {z n} { + set atoms [llength $z] + set car 0 + for {set j 2} {$j < $atoms} {incr j} { + set t [lindex $z $j] + lset z $j \ + [expr {wide($car)|((wide($t)<<$n)&$::math::bignum::atommask)}] + set car [expr {wide($t)>>($::math::bignum::atombits-$n)}] + } + if {$car} { + lappend z 0 + lset z $j $car + } + return $z ; # No normalization needed +} + +# Right shift 'z' of 'n' bits. Low-level function used by ::math::bignum::rshift. +# 'n' must be <= $::math::bignum::atombits +proc ::math::bignum::rshiftBits {z n} { + set atoms [llength $z] + set car 0 + for {set j [expr {$atoms-1}]} {$j >= 2} {incr j -1} { + set t [lindex $z $j] + lset z $j [expr {wide($car)|(wide($t)>>$n)}] + set car \ + [expr {(wide($t)<<($::math::bignum::atombits-$n))&$::math::bignum::atommask}] + } + ::math::bignum::normalize z +} + +# Left shift 'z' of 'n' bits. +proc ::math::bignum::lshift {z n} { + set z [_treat $z] + set atoms [expr {$n / $::math::bignum::atombits}] + set bits [expr {$n & ($::math::bignum::atombits-1)}] + ::math::bignum::lshiftBits [math::bignum::lshiftAtoms $z $atoms] $bits +} + +# Right shift 'z' of 'n' bits. +proc ::math::bignum::rshift {z n} { + set z [_treat $z] + set atoms [expr {$n / $::math::bignum::atombits}] + set bits [expr {$n & ($::math::bignum::atombits-1)}] + + # + # Correct for "arithmetic shift" - signed integers + # + set corr 0 + if { [::math::bignum::sign $z] == 1 } { + for {set j [expr {$atoms+1}]} {$j >= 2} {incr j -1} { + set t [lindex $z $j] + if { $t != 0 } { + set corr 1 + } + } + if { $corr == 0 } { + set t [lindex $z [expr {$atoms+2}]] + if { ( $t & ~($::math::bignum::atommask<<($bits)) ) != 0 } { + set corr 1 + } + } + } + + set newz [::math::bignum::rshiftBits [math::bignum::rshiftAtoms $z $atoms] $bits] + if { $corr } { + set newz [::math::bignum::sub $newz 1] + } + return $newz +} + +############################## Bit oriented ops ################################ + +# Set the bit 'n' of 'bignumvar' +proc ::math::bignum::setbit {bignumvar n} { + upvar 1 $bignumvar z + set atom [expr {$n / $::math::bignum::atombits}] + set bit [expr {1 << ($n & ($::math::bignum::atombits-1))}] + incr atom 2 + while {$atom >= [llength $z]} {lappend z 0} + lset z $atom [expr {[lindex $z $atom]|$bit}] +} + +# Clear the bit 'n' of 'bignumvar' +proc ::math::bignum::clearbit {bignumvar n} { + upvar 1 $bignumvar z + set atom [expr {$n / $::math::bignum::atombits}] + incr atom 2 + if {$atom >= [llength $z]} {return $z} + set mask [expr {$::math::bignum::atommask^(1 << ($n & ($::math::bignum::atombits-1)))}] + lset z $atom [expr {[lindex $z $atom]&$mask}] + ::math::bignum::normalize z +} + +# Test the bit 'n' of 'z'. Returns true if the bit is set. +proc ::math::bignum::testbit {z n} { + set atom [expr {$n / $::math::bignum::atombits}] + incr atom 2 + if {$atom >= [llength $z]} {return 0} + set mask [expr {1 << ($n & ($::math::bignum::atombits-1))}] + expr {([lindex $z $atom] & $mask) != 0} +} + +# does bitwise and between a and b +proc ::math::bignum::bitand {a b} { + # The internal number rep is little endian. Appending zeros is + # equivalent to adding leading zeros to a regular big-endian + # representation. The two numbers are extended to the same length, + # then the operation is applied to the absolute value. + set a [_treat $a] + set b [_treat $b] + while {[llength $a] < [llength $b]} {lappend a 0} + while {[llength $b] < [llength $a]} {lappend b 0} + set r [::math::bignum::zero [expr {[llength $a]-1}]] + for {set i 2} {$i < [llength $a]} {incr i} { + set or [expr {[lindex $a $i] & [lindex $b $i]}] + lset r $i $or + } + ::math::bignum::normalize r +} + +# does bitwise XOR between a and b +proc ::math::bignum::bitxor {a b} { + # The internal number rep is little endian. Appending zeros is + # equivalent to adding leading zeros to a regular big-endian + # representation. The two numbers are extended to the same length, + # then the operation is applied to the absolute value. + set a [_treat $a] + set b [_treat $b] + while {[llength $a] < [llength $b]} {lappend a 0} + while {[llength $b] < [llength $a]} {lappend b 0} + set r [::math::bignum::zero [expr {[llength $a]-1}]] + for {set i 2} {$i < [llength $a]} {incr i} { + set or [expr {[lindex $a $i] ^ [lindex $b $i]}] + lset r $i $or + } + ::math::bignum::normalize r +} + +# does bitwise or between a and b +proc ::math::bignum::bitor {a b} { + # The internal number rep is little endian. Appending zeros is + # equivalent to adding leading zeros to a regular big-endian + # representation. The two numbers are extended to the same length, + # then the operation is applied to the absolute value. + set a [_treat $a] + set b [_treat $b] + while {[llength $a] < [llength $b]} {lappend a 0} + while {[llength $b] < [llength $a]} {lappend b 0} + set r [::math::bignum::zero [expr {[llength $a]-1}]] + for {set i 2} {$i < [llength $a]} {incr i} { + set or [expr {[lindex $a $i] | [lindex $b $i]}] + lset r $i $or + } + ::math::bignum::normalize r +} + +# Return the number of bits needed to represent 'z'. +proc ::math::bignum::bits z { + set atoms [::math::bignum::atoms $z] + set bits [expr {($atoms-1)*$::math::bignum::atombits}] + set atom [lindex $z [expr {$atoms+1}]] + while {$atom} { + incr bits + set atom [expr {$atom >> 1}] + } + return $bits +} + +################################## Division #################################### + +# Division. Returns [list n/d n%d] +# +# I got this algorithm from PGP 2.6.3i (see the mp_udiv function). +# Here is how it works: +# +# Input: N=(Nn,...,N2,N1,N0)radix2 +# D=(Dn,...,D2,D1,D0)radix2 +# Output: Q=(Qn,...,Q2,Q1,Q0)radix2 = N/D +# R=(Rn,...,R2,R1,R0)radix2 = N%D +# +# Assume: N >= 0, D > 0 +# +# For j from 0 to n +# Qj <- 0 +# Rj <- 0 +# For j from n down to 0 +# R <- R*2 +# if Nj = 1 then R0 <- 1 +# if R => D then R <- (R - D), Qn <- 1 +# +# Note that the doubling of R is usually done leftshifting one position. +# The only operations needed are bit testing, bit setting and subtraction. +# +# This is the "raw" version, don't care about the sign, returns both +# quotient and rest as a two element list. +# This procedure is used by divqr, div, mod, rem. +proc ::math::bignum::rawDiv {n d} { + set bit [expr {[::math::bignum::bits $n]-1}] + set r [list bignum 0 0] + set q [::math::bignum::zero [expr {[llength $n]-2}]] + while {$bit >= 0} { + set b_atom [expr {($bit / $::math::bignum::atombits) + 2}] + set b_bit [expr {1 << ($bit & ($::math::bignum::atombits-1))}] + set r [::math::bignum::lshiftBits $r 1] + if {[lindex $n $b_atom]&$b_bit} { + lset r 2 [expr {[lindex $r 2] | 1}] + } + if {[::math::bignum::abscmp $r $d] >= 0} { + set r [::math::bignum::rawSub $r $d] + lset q $b_atom [expr {[lindex $q $b_atom]|$b_bit}] + } + incr bit -1 + } + ::math::bignum::normalize q + list $q $r +} + +# Divide by single-atom immediate. Used to speedup bignum -> string conversion. +# The procedure returns a two-elements list with the bignum quotient and +# the remainder (that's just a number being <= of the max atom value). +proc ::math::bignum::rawDivByAtom {n d} { + set atoms [::math::bignum::atoms $n] + set t 0 + set j $atoms + incr j -1 + for {} {$j >= 0} {incr j -1} { + set t [expr {($t << $::math::bignum::atombits)+[lindex $n [expr {$j+2}]]}] + lset n [expr {$j+2}] [expr {$t/$d}] + set t [expr {$t % $d}] + } + ::math::bignum::normalize n + list $n $t +} + +# Higher level division. Returns a list with two bignums, the first +# is the quotient of n/d, the second the remainder n%d. +# Note that if you want the *modulo* operator you should use ::math::bignum::mod +# +# The remainder sign is always the same as the divident. +proc ::math::bignum::divqr {n d} { + set n [_treat $n] + set d [_treat $d] + if {[::math::bignum::iszero $d]} { + error "Division by zero" + } + foreach {q r} [::math::bignum::rawDiv $n $d] break + ::math::bignum::setsign q [expr {[::math::bignum::sign $n]^[::math::bignum::sign $d]}] + ::math::bignum::setsign r [::math::bignum::sign $n] + list $q $r +} + +# Like divqr, but only the quotient is returned. +proc ::math::bignum::div {n d} { + lindex [::math::bignum::divqr $n $d] 0 +} + +# Like divqr, but only the remainder is returned. +proc ::math::bignum::rem {n d} { + lindex [::math::bignum::divqr $n $d] 1 +} + +# Modular reduction. Returns N modulo M +proc ::math::bignum::mod {n m} { + set n [_treat $n] + set m [_treat $m] + set r [lindex [::math::bignum::divqr $n $m] 1] + if {[::math::bignum::sign $m] != [::math::bignum::sign $r]} { + set r [::math::bignum::add $r $m] + } + return $r +} + +# Returns true if n is odd +proc ::math::bignum::isodd n { + expr {[lindex $n 2]&1} +} + +# Returns true if n is even +proc ::math::bignum::iseven n { + expr {!([lindex $n 2]&1)} +} + +############################# Power and Power mod N ############################ + +# Returns b^e +proc ::math::bignum::pow {b e} { + set b [_treat $b] + set e [_treat $e] + if {[::math::bignum::iszero $e]} {return [list bignum 0 1]} + # The power is negative is the base is negative and the exponent is odd + set sign [expr {[::math::bignum::sign $b] && [::math::bignum::isodd $e]}] + # Set the base to it's abs value, i.e. make it positive + ::math::bignum::setsign b 0 + # Main loop + set r [list bignum 0 1]; # Start with result = 1 + while {[::math::bignum::abscmp $e [list bignum 0 1]] > 0} { ;# While the exp > 1 + if {[::math::bignum::isodd $e]} { + set r [::math::bignum::mul $r $b] + } + set e [::math::bignum::rshiftBits $e 1] ;# exp = exp / 2 + set b [::math::bignum::mul $b $b] + } + set r [::math::bignum::mul $r $b] + ::math::bignum::setsign r $sign + return $r +} + +# Returns b^e mod m +proc ::math::bignum::powm {b e m} { + set b [_treat $b] + set e [_treat $e] + set m [_treat $m] + if {[::math::bignum::iszero $e]} {return [list bignum 0 1]} + # The power is negative is the base is negative and the exponent is odd + set sign [expr {[::math::bignum::sign $b] && [::math::bignum::isodd $e]}] + # Set the base to it's abs value, i.e. make it positive + ::math::bignum::setsign b 0 + # Main loop + set r [list bignum 0 1]; # Start with result = 1 + while {[::math::bignum::abscmp $e [list bignum 0 1]] > 0} { ;# While the exp > 1 + if {[::math::bignum::isodd $e]} { + set r [::math::bignum::mod [::math::bignum::mul $r $b] $m] + } + set e [::math::bignum::rshiftBits $e 1] ;# exp = exp / 2 + set b [::math::bignum::mod [::math::bignum::mul $b $b] $m] + } + set r [::math::bignum::mul $r $b] + ::math::bignum::setsign r $sign + set r [::math::bignum::mod $r $m] + return $r +} + +################################## Square Root ################################# + +# SQRT using the 'binary sqrt algorithm'. +# +# The basic algoritm consists in starting from the higer-bit +# the real square root may have set, down to the bit zero, +# trying to set every bit and checking if guess*guess is not +# greater than 'n'. If it is greater we don't set the bit, otherwise +# we set it. In order to avoid to compute guess*guess a trick +# is used, so only addition and shifting are really required. +proc ::math::bignum::sqrt n { + if {[lindex $n 1]} { + error "Square root of a negative number" + } + set i [expr {(([::math::bignum::bits $n]-1)/2)+1}] + set b [expr {$i*2}] ; # Bit to set to get 2^i*2^i + + set r [::math::bignum::zero] ; # guess + set x [::math::bignum::zero] ; # guess^2 + set s [::math::bignum::zero] ; # guess^2 backup + set t [::math::bignum::zero] ; # intermediate result + for {} {$i >= 0} {incr i -1; incr b -2} { + ::math::bignum::setbit t $b + set x [::math::bignum::rawAdd $s $t] + ::math::bignum::clearbit t $b + if {[::math::bignum::abscmp $x $n] <= 0} { + set s $x + ::math::bignum::setbit r $i + ::math::bignum::setbit t [expr {$b+1}] + } + set t [::math::bignum::rshiftBits $t 1] + } + return $r +} + +################################## Random Number ############################### + +# Returns a random number in the range [0,2^n-1] +proc ::math::bignum::rand bits { + set atoms [expr {($bits+$::math::bignum::atombits-1)/$::math::bignum::atombits}] + set shift [expr {($atoms*$::math::bignum::atombits)-$bits}] + set r [list bignum 0] + while {$atoms} { + lappend r [expr {int(rand()*(1<<$::math::bignum::atombits))}] + incr atoms -1 + } + set r [::math::bignum::rshiftBits $r $shift] + return $r +} + +############################ Convertion to/from string ######################### + +# The string representation charset. Max base is 36 +set ::math::bignum::cset "0123456789abcdefghijklmnopqrstuvwxyz" + +# Convert 'z' to a string representation in base 'base'. +# Note that this is missing a simple but very effective optimization +# that's to divide by the biggest power of the base that fits +# in a Tcl plain integer, and then to perform divisions with [expr]. +proc ::math::bignum::tostr {z {base 10}} { + if {[string length $::math::bignum::cset] < $base} { + error "base too big for string convertion" + } + if {[::math::bignum::iszero $z]} {return 0} + set sign [::math::bignum::sign $z] + set str {} + while {![::math::bignum::iszero $z]} { + foreach {q r} [::math::bignum::rawDivByAtom $z $base] break + append str [string index $::math::bignum::cset $r] + set z $q + } + if {$sign} {append str -} + # flip the resulting string + set flipstr {} + set i [string length $str] + incr i -1 + while {$i >= 0} { + append flipstr [string index $str $i] + incr i -1 + } + return $flipstr +} + +# Create a bignum from a string representation in base 'base'. +proc ::math::bignum::fromstr {str {base 0}} { + set z [::math::bignum::zero] + set str [string trim $str] + set sign 0 + if {[string index $str 0] eq {-}} { + set str [string range $str 1 end] + set sign 1 + } + if {$base == 0} { + switch -- [string tolower [string range $str 0 1]] { + 0x {set base 16; set str [string range $str 2 end]} + ox {set base 8 ; set str [string range $str 2 end]} + bx {set base 2 ; set str [string range $str 2 end]} + default {set base 10} + } + } + if {[string length $::math::bignum::cset] < $base} { + error "base too big for string convertion" + } + set bigbase [list bignum 0 $base] ; # Build a bignum with the base value + set basepow [list bignum 0 1] ; # multiply every digit for a succ. power + set i [string length $str] + incr i -1 + while {$i >= 0} { + set digitval [string first [string index $str $i] $::math::bignum::cset] + if {$digitval == -1} { + error "Illegal char '[string index $str $i]' for base $base" + } + set bigdigitval [list bignum 0 $digitval] + set z [::math::bignum::rawAdd $z [::math::bignum::mul $basepow $bigdigitval]] + set basepow [::math::bignum::mul $basepow $bigbase] + incr i -1 + } + if {![::math::bignum::iszero $z]} { + ::math::bignum::setsign z $sign + } + return $z +} + +# +# Pre-treatment of some constants : 0 and 1 +# Updated 19/11/2005 : abandon the 'upvar' command and its cost +# +proc ::math::bignum::_treat {num} { + if {[llength $num]<2} { + if {[string equal $num 0]} { + # set to the bignum 0 + return {bignum 0 0} + } elseif {[string equal $num 1]} { + # set to the bignum 1 + return {bignum 0 1} + } + } + return $num +} + +namespace eval ::math::bignum { + namespace export * +} + +# Announce the package + +package provide math::bignum 3.1.1 diff --git a/vendor/math/bignum.test b/vendor/math/bignum.test new file mode 100644 index 00000000..4d543b89 --- /dev/null +++ b/vendor/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.5 +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/vendor/math/calculus.CHANGES b/vendor/math/calculus.CHANGES new file mode 100644 index 00000000..61fd8ac3 --- /dev/null +++ b/vendor/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/vendor/math/calculus.README b/vendor/math/calculus.README new file mode 100644 index 00000000..64731dd3 --- /dev/null +++ b/vendor/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/vendor/math/calculus.doc b/vendor/math/calculus.doc new file mode 100644 index 00000000..62fdd0a3 --- /dev/null +++ b/vendor/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/vendor/math/calculus.man b/vendor/math/calculus.man new file mode 100644 index 00000000..d22eb36b --- /dev/null +++ b/vendor/math/calculus.man @@ -0,0 +1,551 @@ +[vset VERSION 0.8.2] +[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] + + +[call [cmd ::math::calculus::root_bisection] [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 {bisection}]. For properties: see the [emph {regula falsi}] procedure. + +[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-7) + +[list_end] + + +[call [cmd ::math::calculus::root_secant] [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 {secant}] method. For properties: see the [emph {regula falsi}] procedure. +Note that this method is not guaranteed to produce a zero, but it is fast. + +[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-7) + +[list_end] + + +[call [cmd ::math::calculus::root_brent] [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 {Brent}] method. For properties: see the [emph {regula falsi}] procedure. + +[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-7) + +[list_end] + + +[call [cmd ::math::calculus::root_chandrupatla] [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 {Chandrupatla}] method. It is a variant of the Brent method and +is reputed to be faster. See [uri https://www.embeddedrelated.com/showarticle/855.php] for a discussion. + +[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-7) + +[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). + +[item] +The various root finding methods differ in robustness, ease of use and convergence rates. While the Newton-Raphson +method is quite fast (quadratic convergence), it is not guaranteed to produce an answer. The methods +that bracket the root, require two starting points, but except for the secant method are guaranteed to +deliver a good estimate. +[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 ../common-text/feedback.inc] +[manpage_end] diff --git a/vendor/math/calculus.tcl b/vendor/math/calculus.tcl new file mode 100644 index 00000000..2869da65 --- /dev/null +++ b/vendor/math/calculus.tcl @@ -0,0 +1,1650 @@ +# 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.5;# lrepeat +package require math::interpolate +package provide math::calculus 1.0 + +# 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 root_bisection root_secant root_brent root_chandrupatla + + 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= 1.0 } { + return -code error -errorcode [list romberg gammaTooBig] \ + "gamma must lie in the interval (0,1)" + } + if { ![string is double -strict $a] } { + return -code error [expectDouble $a] + } + if { ![string is double -strict $b] } { + return -code error [expectDouble $b] + } + if { $a >= $b } { + return -code error "limits of integration out of order" + } + set f [lreplace $f 0 0 [uplevel 1 [list namespace which [lindex $f 0]]]] + set onemgamma [expr { 1. - $gamma }] + set f [list u_powerLawLower $f \ + [expr { $gamma / $onemgamma }] \ + [expr { 1 / $onemgamma }] \ + $a] + + set limit [expr { pow( $b - $a, $onemgamma ) }] + set result {} + foreach v [eval [linsert $args 0 romberg $f 0 $limit]] { + lappend result [expr { $v / $onemgamma }] + } + return $result + +} + +#---------------------------------------------------------------------- +# +# u_powerLawLower -- +# Change of variable for integrating over an interval with +# an integrable power law singularity at the upper bound. +# +# Parameters: +# f - Function being integrated +# gammaover1mgamma - gamma / (1 - gamma), where gamma is the power +# oneover1mgamma - 1 / (1 - gamma), where gamma is the power +# b - Upper limit of integration +# u - Changed variable u == (b-x)**(1-gamma) +# +# Results: +# Returns u**(1/1-gamma) * f(b-u**(1/1-gamma) ). +# +# Side effects: +# Whatever f does. +# +#---------------------------------------------------------------------- + +proc ::math::calculus::u_powerLawUpper { f gammaover1mgamma oneover1mgamma + b u } { + set cmd $f + lappend cmd [expr { $b - pow( $u, $oneover1mgamma ) }] + set y [eval $cmd] + return [expr { $y * pow( $u, $gammaover1mgamma ) }] +} + +#---------------------------------------------------------------------- +# +# math::calculus::romberg_powerLawUpper -- +# Integrate a function with an integrable power law singularity +# at the upper bound +# +# Usage: +# romberg_powerLawLower gamma f a b ?-option value...? +# +# Parameters: +# gamma - Power (0= 1.0 } { + return -code error -errorcode [list romberg gammaTooBig] \ + "gamma must lie in the interval (0,1)" + } + if { ![string is double -strict $a] } { + return -code error [expectDouble $a] + } + if { ![string is double -strict $b] } { + return -code error [expectDouble $b] + } + if { $a >= $b } { + return -code error "limits of integration out of order" + } + set f [lreplace $f 0 0 [uplevel 1 [list namespace which [lindex $f 0]]]] + set onemgamma [expr { 1. - $gamma }] + set f [list u_powerLawUpper $f \ + [expr { $gamma / $onemgamma }] \ + [expr { 1. / $onemgamma }] \ + $b] + + set limit [expr { pow( $b - $a, $onemgamma ) }] + set result {} + foreach v [eval [linsert $args 0 romberg $f 0 $limit]] { + lappend result [expr { $v / $onemgamma }] + } + return $result + +} + +#---------------------------------------------------------------------- +# +# u_expUpper -- +# +# Change of variable to integrate a function that decays +# exponentially. +# +# Parameters: +# f - Function to integrate +# u - Changed variable u = exp(-x) +# +# Results: +# Returns (1/u)*f(-log(u)) +# +# Side effects: +# Whatever f does. +# +#---------------------------------------------------------------------- + +proc ::math::calculus::u_expUpper { f u } { + set cmd $f + lappend cmd [expr { -log($u) }] + set y [eval $cmd] + return [expr { $y / $u }] +} + +#---------------------------------------------------------------------- +# +# romberg_expUpper -- +# +# Integrate a function that decays exponentially over a +# half-infinite interval. +# +# Parameters: +# Same as romberg. The upper limit of integration, 'b', +# is expected to be very large. +# +# Results: +# Same as romberg. +# +# The romberg_expUpper function operates by making the change of +# variable, u = exp(-x). +# +#---------------------------------------------------------------------- + +proc ::math::calculus::romberg_expUpper { f a b args } { + if { ![string is double -strict $a] } { + return -code error [expectDouble $a] + } + if { ![string is double -strict $b] } { + return -code error [expectDouble $b] + } + if { $a >= $b } { + return -code error "limits of integration out of order" + } + set f [lreplace $f 0 0 [uplevel 1 [list namespace which [lindex $f 0]]]] + set f [list u_expUpper $f] + return [eval [linsert $args 0 \ + romberg $f [expr {exp(-$b)}] [expr {exp(-$a)}]]] +} + +#---------------------------------------------------------------------- +# +# u_expLower -- +# +# Change of variable to integrate a function that grows +# exponentially. +# +# Parameters: +# f - Function to integrate +# u - Changed variable u = exp(x) +# +# Results: +# Returns (1/u)*f(log(u)) +# +# Side effects: +# Whatever f does. +# +#---------------------------------------------------------------------- + +proc ::math::calculus::u_expLower { f u } { + set cmd $f + lappend cmd [expr { log($u) }] + set y [eval $cmd] + return [expr { $y / $u }] +} + +#---------------------------------------------------------------------- +# +# romberg_expLower -- +# +# Integrate a function that grows exponentially over a +# half-infinite interval. +# +# Parameters: +# Same as romberg. The lower limit of integration, 'a', +# is expected to be very large and negative. +# +# Results: +# Same as romberg. +# +# The romberg_expUpper function operates by making the change of +# variable, u = exp(x). +# +#---------------------------------------------------------------------- + +proc ::math::calculus::romberg_expLower { f a b args } { + if { ![string is double -strict $a] } { + return -code error [expectDouble $a] + } + if { ![string is double -strict $b] } { + return -code error [expectDouble $b] + } + if { $a >= $b } { + return -code error "limits of integration out of order" + } + set f [lreplace $f 0 0 [uplevel 1 [list namespace which [lindex $f 0]]]] + set f [list u_expLower $f] + return [eval [linsert $args 0 \ + romberg $f [expr {exp($a)}] [expr {exp($b)}]]] +} + + +# regula_falsi -- +# Compute the zero of a function via regula falsi +# Arguments: +# f Name of the procedure/command that evaluates the function +# xb Start of the interval that brackets the zero +# xe End of the interval that brackets the zero +# eps Relative error that is allowed (default: 1.0e-4) +# Result: +# Estimate of the zero, such that the estimated (!) +# error < eps * abs(xe-xb) +# Note: +# f(xb)*f(xe) must be negative and eps must be positive +# +proc ::math::calculus::regula_falsi { f xb xe {eps 1.0e-4} } { + if { $eps <= 0.0 } { + return -code error "Relative error must be positive" + } + + set fb [$f $xb] + set fe [$f $xe] + + if { $fb * $fe > 0.0 } { + return -code error "Interval must be chosen such that the \ +function has a different sign at the beginning than at the end" + } + + set max_error [expr {$eps * abs($xe-$xb)}] + set interval [expr {abs($xe-$xb)}] + + while { $interval > $max_error } { + set coeff [expr {($fe-$fb)/($xe-$xb)}] + set xi [expr {$xb-$fb/$coeff}] + set fi [$f $xi] + + if { $fi == 0.0 } { + break + } + set diff1 [expr {abs($xe-$xi)}] + set diff2 [expr {abs($xb-$xi)}] + if { $diff1 > $diff2 } { + set interval $diff2 + } else { + set interval $diff1 + } + + if { $fb*$fi < 0.0 } { + set xe $xi + set fe $fi + } else { + set xb $xi + set fb $fi + } + } + + return $xi +} + +# + +# 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] +} + +# +# Add the root finding procedures based on bracketing a root +# +source [file join [file dirname [info script]] rootfind.tcl] diff --git a/vendor/math/calculus.test b/vendor/math/calculus.test new file mode 100644 index 00000000..5976350f --- /dev/null +++ b/vendor/math/calculus.test @@ -0,0 +1,734 @@ +# 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.5 +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 { +# From here on we are in a namespace. + +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 does not do namespaced command resolution, provide the FQN. +customMatch numbers ::math::calculus::test::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 does not do namespaced command resolution, provide the FQN. +customMatch numbers ::math::calculus::test::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 + + +# Function with one ordinary root and one double root +proc ::w {x} { + expr { ($x + 3.0) * ($x - 2.0) ** 2 } +} + +# Function with no real root +proc ::h {x} { + expr {$x**2 + 0.1} +} + +test "root-finding-1.0" "Third degree function - bisection" -match numbers -body { + set x [::math::calculus::root_bisection ::w -4.0 0.25] +} -result -3.0 + +# Converges to the double root! +# These two tests show that secant may not be the most reliable method +test "root-finding-1.1" "Third degree function - secant" -match numbers -body { + set x [::math::calculus::root_secant ::w -4.0 0.25] +} -result 1.9999937262995833 + +test "root-finding-1.1b" "Third degree function - secant (different interval)" -match numbers -body { + set x [::math::calculus::root_secant ::w -4.0 -0.25] +} -result 2.000041303828004 + +test "root-finding-1.2" "Third degree function - Brent" -match numbers -body { + set x [::math::calculus::root_brent ::w -4.0 0.25] +} -result -3.0 + +test "root-finding-1.3" "Third degree function - Chandrupatla" -match numbers -body { + set x [::math::calculus::root_chandrupatla ::w -4.0 0.25] +} -result -3.0 + + +test "root-finding-2.0" "Invalid interval - bisection" -match glob -body { + set x [::math::calculus::root_bisection ::h -0.5 2.6] +} -result "The given interval does not *" -returnCodes error + +test "root-finding-2.1" "Invalid interval - secant" -match glob -body { + set x [::math::calculus::root_secant ::h -0.5 2.6] +} -result "The given interval does not *" -returnCodes error + +test "root-finding-2.2" "Invalid interval - Brent" -match glob -body { + set x [::math::calculus::root_brent ::h -0.5 2.6] +} -result "The given interval does not *" -returnCodes error + +test "root-finding-2.3" "Invalid interval - Chandrupatla" -match glob -body { + set x [::math::calculus::root_chandrupatla ::h -0.5 2.6] +} -result "The given interval does not *" -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/vendor/math/calculus.testscript b/vendor/math/calculus.testscript new file mode 100644 index 00000000..81dd091a --- /dev/null +++ b/vendor/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/vendor/math/changepoint.man b/vendor/math/changepoint.man new file mode 100644 index 00000000..ff4a9e4f --- /dev/null +++ b/vendor/math/changepoint.man @@ -0,0 +1,123 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin math::changepoint n 0.1] +[keywords statistics] +[keywords control] +[copyright {2020 by Arjen Markus}] +[moddesc {Tcl Math Library}] +[titledesc {Change point detection methods}] +[category Mathematics] +[require Tcl 8.6] +[require TclOO] +[require math::statistics] +[require math::changepoint [opt 0.1]] + +[description] +[para] +The [package math::changepoint] package implements a number of well-known methods +to determine if a series of data contains a shift in the mean or not. Note that +these methods only indicate if a shift in the mean is probably. Due to the stochastic +nature of the data that will be analysed, false positives are possible. + +The CUSUM method is implemented in both an "offline" and an "online" version, so that +it can be used either for a complete data series or for detecting changes in data that +come in one by one. The implementation has been based on these websites mostly: + +[list_begin itemized] +[item] +[uri https://www.itl.nist.gov/div898/handbook/pmc/section3/pmc323.htm] +[item] +[uri https://en.wikipedia.org/wiki/CUSUM] +[list_end] + +Basically, the deviation of the data from a given target value is accumulated and when +the total deviation becomes too large, a change point is reported. + +A second method, binary segmentation, is implemented only as an "offline" method, as it +needs to examine the data series as a whole. In the variant contained here the following +ideas have been used: +[list_begin itemized] +[item] +The segments in which the data series may be separated shold not be too short, otherwise +the ultimate result could be segments of only one data point long. So a minimum length is +used. +[item] +To make the segmentation worthwhile there should be a minimum gain in reducing the cost +function (the sum of the squared deviations from the mean for each segment). +[list_end] + +This may not be in agreement with the descriptions of the method found in various +publications, but it is simple to understand and intuitive. + +One publication that provides more information on the method in general is +"Selective review of offline change point detection methods" by Truong et al. [uri https://arxiv.org/abs/1801.00718]. + + +[section "PROCEDURES"] + +The package defines the following public procedures: + +[list_begin definitions] + +[call [cmd ::math::changepoint::cusum-detect] [arg data] [opt args]] + +Examine a given data series and return the location of the first change (if any) + +[list_begin arguments] +[arg_def double data] Series of data to be examined +[arg_def list args] Optional list of key-value pairs: +[list_begin definitions] +[def "[option -target] [arg value]"] The target (or mean) for the time series +[def "[option -tolerance] [arg value]"] The tolerated standard deviation +[def "[option -kfactor] [arg value]"] The factor by which to multiply the standard deviation (defaults to 0.5, typically between 0.5 and 1.0) +[def "[option -hfactor] [arg value]"] The factor determining the limits betweem which the "cusum" statistic is accepted (typicaly 3.0-5.0, default 4.0) +[list_end] +[list_end] + + +[call [cmd ::math::changepoint::cusum-online] [opt args]] + +Class to examine data passed in against expected properties. At least the keywords [term -target] and [term -tolerance] must be given. + +[list_begin arguments] +[arg_def list args] List of key-value pairs: +[list_begin definitions] +[def "[option -target] [arg value]"] The target (or mean) for the time series +[def "[option -tolerance] [arg value]"] The tolerated standard deviation +[def "[option -kfactor] [arg value]"] The factor by which to multiply the standard deviation (defaults to 0.5, typically between 0.5 and 1.0) +[def "[option -hfactor] [arg value]"] The factor determining the limits betweem which the "cusum" statistic is accepted (typicaly 3.0-5.0, default 4.0) +[list_end] +[list_end] + + +[call [cmd \$cusumObj] examine [arg value]] + +Pass a value to the [term cusum-online] object and examine it. If, with this new value, the cumulative sum remains within the bounds, +zero (0) is returned, otherwise one (1) is returned. + +[list_begin arguments] +[arg_def double value] The new value +[list_end] + + +[call [cmd \$cusumObj] reset] + +Reset the cumulative sum, so that the examination can start afresh. + + +[call [cmd ::math::changepoint::binary-segmentation] [arg data] [opt args]] + +Apply the binary segmentation method recursively to find change points. Returns a list of indices of potential change points + +[list_begin arguments] +[arg_def list data] Data to be examined +[arg_def list args] Optional key-value pairs: +[list_begin definitions] +[def "[option -minlength] [arg number]"] Minimum number of points in each segment (default: 5) +[def "[option -threshold] [arg value]"] Factor applied to the standard deviation functioning as a threshold for accepting the change in cost function as an improvement (default: 1.0) +[list_end] +[list_end] + + +[list_end] + +[manpage_end] diff --git a/vendor/math/changepoint.tcl b/vendor/math/changepoint.tcl new file mode 100644 index 00000000..e080bb55 --- /dev/null +++ b/vendor/math/changepoint.tcl @@ -0,0 +1,311 @@ +# changepoint.tcl -- +# Statistical procedures for change point detection: +# - Implementation of the CUSUM procedure to detect changes in the +# mean of a series of data +# +# Partly based on: https://www.itl.nist.gov/div898/handbook/pmc/section3/pmc323.htm +# +# Note: +# Since there do not seem to be online resources for the finer details, the +# implementation uses simple guidelines as found for instance at +# https://en.wikipedia.org/wiki/CUSUM. +# +# There are two commands: +# - One to examine a complete time series +# - One (OO style) to examine data from a time series online +# +# - Implementation of the binary segmentation algorithm +# + +package require Tcl 8.6 +package require TclOO +package require math::statistics +package provide math::changepoint 0.1 + +namespace eval ::math::changepoint { + namespace export cusum-detect cusum-online binary-segmentation +} + +# cusum-detect -- +# Procedure to examine a given data series and return the location +# of the first change (if any) +# +# Arguments: +# data List of values to be examined +# args (Optional) key-value pairs to define the parameters: +# -target value -- the target (or mean) for the time series +# -tolerance value -- the tolerated standard deviation +# -kfactor -- the factor by which to multiply the +# standard deviation (defaults to 0.5, +# typically between 0.5 and 1.0 +# -hfactor -- the factor determining the limits +# betweem which the "cusum" statistic +# is accepted (typicaly 3.0-5.0, default 4.0) +# +# Result: +# Index of the location of the first change or an empty string +# +# Note: +# The CUSUM procedure is rather sensitive and details regarding the limits differ +# between descriptions. This is a straightforward implementation. +# +# If no options are given, the given time series is used for the target and the +# tolerance. +# +# Because of the senstivity using the raw data may give spurious results. +# +proc ::math::changepoint::cusum-detect {data args} { + + set kfactor 0.5 + set hfactor 4.0 + + set target {} + set tolerance {} + + foreach {key value} $args { + if { [string match "-*" $key] } { + set name [string range $key 1 end] + set $name $value + } else { + return -code error "Unknown/invalid option: $key" + } + } + + if { $target eq {} } { + set target [::math::statistics::mean $data] + } + + if { $tolerance eq {} } { + set tolerance [::math::statistics::stdev $data] + } + + set k [expr {$kfactor * $tolerance}] + set h [expr {$hfactor * $tolerance}] + + set Shi 0.0 + set Slo 0.0 + + set location {} + set index 0 + foreach value $data { + set Shi [expr {max( 0.0, $Shi + $value - $target - $k )}] + set Slo [expr {max( 0.0, $Slo + $target - $value - $k )}] + + if { $Shi > $h || $Slo > $h } { + set location $index + break + } + + incr index + } + + return $location +} + +# cusum-online -- +# Class to examine data passed in against expected properties +# +# Arguments: +# data List of values to be examined +# args (Optional) key-value pairs to define the parameters: +# -target value -- the target (or mean) for the time series +# -tolerance value -- the tolerated standard deviation +# -kfactor -- the factor by which to multiply the +# standard deviation (defaults to 0.5, +# typically between 0.5 and 1.0 +# -hfactor -- the factor determining the limits +# betweem which the "cusum" statistic +# is accepted (typicaly 3.0-5.0, default 4.0) +# +# Result: +# Index of the location of the first change or an empty string +# +# Note: +# All parameters used in this algorithm are set to default values. +# The threshold are based on 3 * stdev and a quick detection of +# a change of 1 * stdev. +# +::oo::class create ::math::changepoint::cusum-online { + variable target {} + variable tolerance {} + variable Slo 0.0 + variable Shi 0.0 + variable k 0.0 + variable h 0.0 + + # + # Constructor: + # - two key-value pairs required: -target and -tolerance + # + constructor {args} { + variable target + variable tolerance + variable k + variable h + + set kfactor 0.5 + set hfactor 4.0 + + foreach {option value} $args { + switch -- $option { + "-target" { set target $value } + "-tolerance" { set tolerance $value } + "-kfactor" { set kfactor $value } + "-hfactor" { set hfactor $value } + default { + return -code error "Unknown/invalid option: $option" + } + } + } + + if { $target eq {} || $tolerance eq {} } { + return -code error "Values for target and tolerance are required" + } + + set k [expr {$kfactor * $tolerance}] + set h [expr {$hfactor * $tolerance}] + + set Shi 0.0 + set Slo 0.0 + + } + + # + # Restart the object + # + method reset {} { + variable Slo + variable Shi + + set Shi 0.0 + set Slo 0.0 + } + + # + # Add a new value to the object and examine it. If the cusum exceeds + # the range, 1 is returned, otherwise 0. + # + method examine {value} { + variable Slo + variable Shi + variable k + variable h + + set Shi [expr {max( 0.0, $Shi + $value - $target - $k )}] + set Slo [expr {max( 0.0, $Slo + $target - $value - $k )}] + + return [expr { $Shi > $h || $Slo > $h }] + } +} + +# binary-segmentation -- +# Apply the binary segmentation method recursively to find change points +# +# Arguments: +# series The series in question +# args Key-value pairs defining the options: +# -minlength 5 Minimum number of points in each segment +# -threshold 1.0 Factor applied to the standard deviation +# functioning as a threshold for accepting +# the change in cost function as an improvement +# Result: +# List of indices where change points have been detected +# +proc ::math::changepoint::binary-segmentation {series args} { + set minlength 5 + set threshold 1.0 + + foreach {key value} $args { + switch -- $key { + "-minlength" { + set minlength $value + } + "-threshold" { + set threshold $value + } + default { + return -error "Unknown keyword: $key" + } + } + } + + if { [llength $series] < $minlength } { + return -error "Series too short - at least $minlength values expected" + } + + # + # The real work is done by this procedure + # + set indices [BinSegRecursive 0 $series $minlength $threshold] + + return $indices +} + +# BinSegRecursive -- +# Procedure for doing the actual work +# +# Arguments: +# first Index of the first value in the segment wrt the original series +# series Series/segment to be examined +# minlength Minimum length +# threshold Factor for the standard deviation +# +proc ::math::changepoint::BinSegRecursive {first series minlength threshold} { + + set length [llength $series] + + if { $length < $minlength } { + return {} + } + + # + # Overall parameters + # + set stdev [::math::statistics::stdev $series] + set idxmin -1 + set maxcost [expr {$length * $stdev ** 2}] + set mincost $maxcost + + # + # Calculate the cost function for each split of the series + # + for {set idx $minlength} {$idx < $length-$minlength} {incr idx} { + set segment1 [lrange $series 0 $idx] + set segment2 [lrange $series [expr {$idx+1}] end] + + set stdev1 [::math::statistics::stdev $segment1] + set stdev2 [::math::statistics::stdev $segment2] + + set cost [expr {($idx+1) * $stdev1**2 + ($length-$idx) * $stdev2**2}] + if { $cost < $mincost } { + set mincost $cost + set idxmin $idx + } + } + + # + # Do we accept it? + # + set indices {} + + if { $maxcost > $mincost + $threshold * $stdev ** 2 } { + set segment1 [lrange $series 0 $idxmin] + set segment2 [lrange $series [expr {$idxmin+1}] end] + + set left [BinSegRecursive [expr {$first+0}] $segment1 $minlength $threshold] + set right [BinSegRecursive [expr {$first+$idxmin}] $segment2 $minlength $threshold] + + set indices [list [expr {$first+$idxmin}]] + + if { [llength $left] > 0 } { + set indices [concat $left $indices] + } + + if { [llength $right] > 0 } { + set indices [concat $indices $right] + } + } + + return $indices +} + diff --git a/vendor/math/changepoint.test b/vendor/math/changepoint.test new file mode 100644 index 00000000..a08af9e9 --- /dev/null +++ b/vendor/math/changepoint.test @@ -0,0 +1,105 @@ +# -*- tcl -*- +# Tests for changepoint library. +# +# 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.6 +testsNeedTcltest 1.0 + +support { + useLocal math.tcl math + useLocal linalg.tcl math::linearalgebra + useLocal statistics.tcl math::statistics +} +testing { + useLocal changepoint.tcl math::changepoint +} + +# setRand -- +# Make sure we always get the same results: +# Use srand() to ensure that the random numbers follow +# the same sequence. +# +proc setRand {} { + expr {srand(100000)} +} + +# test data NIST -- +# From https://www.itl.nist.gov/div898/handbook/pmc/section3/pmc323.htm +# +set testdata { + 324.93 + 324.68 + 324.73 + 324.35 + 325.35 + 325.23 + 324.13 + 324.53 + 325.23 + 324.60 + 324.63 + 325.15 + 328.33 + 327.25 + 327.83 + 328.50 + 326.68 + 327.78 + 326.88 + 328.35 +} + +# test data for binary sgmentation +# +setRand +set series [concat [lrepeat 20 0.0] [lrepeat 20 1.0]] +set noise [::math::statistics::random-normal 0.0 1.5 40] +set binsegSeries [lrepeat 40 0.0] + +for {set n 0} {$n < 40} {incr n} { + lset binsegSeries $n [expr {[lindex $series $n] + [lindex $noise $n]}] +} + +# actual tests +# +test cusum-1.0 {examine entire data set} -body { + global testdata + + set location [::math::changepoint::cusum-detect $testdata -target 325 -tolerance 0.635] +} -result 12 + +test cusum-1.1 {examine the data set one value at a time} -body { + global testdata + + set cpd [::math::changepoint::cusum-online new -target 325 -tolerance 0.635] + + set loc 0 + foreach value $testdata { + if { [$cpd examine $value] } { + break + } + + incr loc + } + set location $loc +} -result 12 + + +test binseg-1.0 {binary segmentation for a series with clear shift} -body { + global binsegSeries + + ::math::changepoint::binary-segmentation $series +} -result 19 + +test binseg-1.1 {binary segmentation for a series with clear shift - longer minimum length} -body { + global binsegSeries + + ::math::changepoint::binary-segmentation $series -minlength 10 +} -result 19 diff --git a/vendor/math/classic_polyns.tcl b/vendor/math/classic_polyns.tcl new file mode 100644 index 00000000..1fd9cd00 --- /dev/null +++ b/vendor/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/vendor/math/combinatorics.man b/vendor/math/combinatorics.man new file mode 100644 index 00000000..aa317f79 --- /dev/null +++ b/vendor/math/combinatorics.man @@ -0,0 +1,275 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin math::combinatorics n 2.0] +[moddesc {Tcl Math Library}] +[titledesc {Combinatorial functions in the Tcl Math Library}] +[category Mathematics] +[require Tcl 8.2] +[require math [opt 1.2.3]] +[require Tcl 8.6] +[require TclOO] +[require math::combinatorics [opt 2.0]] +[description] +[para] + +The [package math] package contains implementations of several +functions useful in combinatorial problems. The [package math::combinatorics] +extends the collections based on features in Tcl 8.6. + +Note: the meaning of the partitionP function, Catalan and Stirling numbers is explained on the +[uri http://mathworld.wolfram.com {MathWorld website}] + + +[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. + + +[call [cmd ::math::combinatorics::permutations] [arg n]] +Return the number of permutations of n items. The returned number +is always an integer, it is not limited by the range of 32-or 64-bits +integers using the arbitrary precision integers available in Tcl 8.5 and later. + +[list_begin arguments] +[arg_def int n] The number of items to be permuted. +[list_end] + +[call [cmd ::math::combinatorics::variations] [arg n] [arg k]] +Return the number of variations k items selected from the total of n items. +The order of the items is taken into account. + +[list_begin arguments] +[arg_def int n] The number of items to be selected from. +[arg_def int k] The number of items to be selected in each variation. +[list_end] + +[call [cmd ::math::combinatorics::combinations] [arg n] [arg k]] +Return the number of combinations of k items selected from the total of n items. +The order of the items is not important. + +[list_begin arguments] +[arg_def int n] The number of items to be selected from. +[arg_def int k] The number of items to be selected in each combination. +[list_end] + +[call [cmd ::math::combinatorics::derangements] [arg n]] +Return the number of derangements of n items. A derangement is a permutation +where each item is displaced from the original position. + +[list_begin arguments] +[arg_def int n] The number of items to be rearranged. +[list_end] + +[call [cmd ::math::combinatorics::catalan] [arg n]] +Return the n'th Catalan number. The number n is expected to be 1 or larger. +These numbers occur in various combinatorial problems. + +[list_begin arguments] +[arg_def int n] The index of the Catalan number +[list_end] + +[call [cmd ::math::combinatorics::firstStirling] [arg n] [arg m]] +Calculate a Stirling number of the first kind +(signed version, m cycles in a permutation of n items) + +[list_begin arguments] +[arg_def int n] Number of items +[arg_def int m] Number of cycles +[list_end] + +[call [cmd ::math::combinatorics::secondStirling] [arg n] [arg m]] +Calculate a Stirling number of the second kind +(m non-empty subsets from n items) + +[list_begin arguments] +[arg_def int n] Number of items +[arg_def int m] Number of subsets +[list_end] + +[call [cmd ::math::combinatorics::partitionP] [arg n]] +Calculate the number of ways an integer n can be written as the sum of positive integers. + +[list_begin arguments] +[arg_def int n] Number in question +[list_end] + + +[call [cmd ::math::combinatorics::list-permutations] [arg n]] +Return the list of permutations of the numbers 0, ..., n-1. + +[list_begin arguments] +[arg_def int n] The number of items to be permuted. +[list_end] + +[call [cmd ::math::combinatorics::list-variations] [arg n] [arg k]] +Return the list of variations of k numbers selected from the numbers 0, ..., n-1. +The order of the items is taken into account. + +[list_begin arguments] +[arg_def int n] The number of items to be selected from. +[arg_def int k] The number of items to be selected in each variation. +[list_end] + +[call [cmd ::math::combinatorics::list-combinations] [arg n] [arg k]] +Return the list of combinations of k numbers selected from the numbers 0, ..., n-1. +The order of the items is ignored. + +[list_begin arguments] +[arg_def int n] The number of items to be selected from. +[arg_def int k] The number of items to be selected in each combination. +[list_end] + +[call [cmd ::math::combinatorics::list-derangements] [arg n]] +Return the list of derangements of the numbers 0, ..., n-1. + +[list_begin arguments] +[arg_def int n] The number of items to be rearranged. +[list_end] + +[call [cmd ::math::combinatorics::list-powerset] [arg n]] +Return the list of all subsets of the numbers 0, ..., n-1. + +[list_begin arguments] +[arg_def int n] The number of items to be rearranged. +[list_end] + + +[call [cmd ::math::combinatorics::permutationObj] new/create NAME [arg n]] +Create a TclOO object for returning permutations one by one. If the last permutation +has been reached an empty list is returned. + +[list_begin arguments] +[arg_def int n] The number of items to be rearranged. +[list_end] + +[call [cmd \$perm] next] +Return the next permutation of n objects. + +[call [cmd \$perm] reset] +Reset the object, so that the command [term next] returns the complete list again. + +[call [cmd \$perm] setElements [arg elements]] +Register a list of items to be permuted, using the [term nextElements] command. + +[list_begin arguments] +[arg_def list elements] The list of n items that will be permuted. +[list_end] + +[call [cmd \$perm] setElements] +Return the next permulation of the registered items. + +[call [cmd ::math::combinatorics::combinationObj] new/create NAME [arg n] [arg k]] +Create a TclOO object for returning combinations one by one. If the last combination +has been reached an empty list is returned. + +[list_begin arguments] +[arg_def int n] The number of items to be rearranged. +[list_end] + +[call [cmd \$combin] next] +Return the next combination of n objects. + +[call [cmd \$combin] reset] +Reset the object, so that the command [term next] returns the complete list again. + +[call [cmd \$combin] setElements [arg elements]] +Register a list of items to be permuted, using the [term nextElements] command. + +[list_begin arguments] +[arg_def list elements] The list of n items that will be permuted. +[list_end] + +[call [cmd \$combin] setElements] +Return the next combination of the registered items. + + +[list_end] + +[vset CATEGORY math] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/vendor/math/combinatorics.tcl b/vendor/math/combinatorics.tcl new file mode 100644 index 00000000..7e165e73 --- /dev/null +++ b/vendor/math/combinatorics.tcl @@ -0,0 +1,443 @@ +#---------------------------------------------------------------------- +# +# math/combinatorics.tcl -- +# +# This file contains definitions of mathematical functions +# useful in combinatorial problems. +# +# Note: this is the original collection, an update is in combinatoricsExt.tcl +# +# 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/vendor/math/combinatorics.test b/vendor/math/combinatorics.test new file mode 100644 index 00000000..32127f7a --- /dev/null +++ b/vendor/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.5 +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/vendor/math/combinatoricsExt.tcl b/vendor/math/combinatoricsExt.tcl new file mode 100644 index 00000000..1b9eff87 --- /dev/null +++ b/vendor/math/combinatoricsExt.tcl @@ -0,0 +1,825 @@ +# combinatoricsExt.tcl -- +# Procedures for combinatorial functions and generating combinatorial collections +# +# Note: +# The older procedures factorial and choose assume Tcl 8.0, so no large integer support +# The versions in this package, permutations and combinations, depend on Tcl 8.6 and later +# for the large integer support and for TclOO. +# +# Several parts based on: https://wiki.tcl-lang.org/page/Permutations and other Wiki pages +# +package require Tcl 8.6 +package require TclOO +package provide math::combinatorics 2.0 + +# ::math::combinatorics -- +# Encompassing namespace and auxiliary variables +# +namespace eval ::math::combinatorics { + variable factorial + variable partition + + set factorial {1 1 2 6 24 120 720} + + set partition(0) 0 + set partition(1) 1 + + namespace export permutations variations combinations derangements \ + list-permutations list-variations list-combinations list-derangements \ + catalan firstStirling secondStirling partitionP \ + permutationObj combinationObj +} + +# permutations -- +# Calculate the number of permutations +# +# Arguments: +# n Size of the set +# +# Returns: +# Number of permutations of the set {0 ... n} +# +proc ::math::combinatorics::permutations {n} { + variable factorial + + if { $n <= 1 } { + return 1 + } + + if { $n < [llength $factorial] } { + return [lindex $factorial $n] + } + + set newfactorial [lindex $$factorial end] + + for {set k [llength $factorial]} { $k <= $n} {incr k} { + set newfactorial [expr {$newfactorial * $k}] + lappend factorial $newfactorial + } + + return $newfactorial +} + +# variations -- +# Calculate the number of variations +# +# Arguments: +# n Size of the set +# k Number of elements per subset +# +# Returns: +# Number of variations of the set {0 ... n} +# +proc ::math::combinatorics::variations {n k} { + if { $k < 0 || $k > $n } { + return 0 + } + + if { $n <= 1 || $k == 0 } { + return 1 + } + + set perms1 [permutations $n] + set perms2 [permutations [expr {$n-$k}]] + + return [expr {$perms1 / $perms2}] +} + +# combinations -- +# Calculate the number of combinations +# +# Arguments: +# n Size of the set +# k Number of elements per subset +# +# Returns: +# Number of combinations of the set {0 ... n} +# +proc ::math::combinatorics::combinations {n k} { + if { $k < 0 || $k > $n } { + return 0 + } + + if { $n <= 1 || $k == 0 || $k == $n } { + return 1 + } + + set perms1 [permutations $n] + set perms2 [permutations $k] + set perms3 [permutations [expr {$n - $k}]] + + return [expr {$perms1 / $perms2 / $perms3}] +} + +# derangements -- +# Calculate the number of derangements +# +# Arguments: +# n Size of the set +# +# Returns: +# Number of permutations of the set {0 ... n} where every +# element is displaced +# +proc ::math::combinatorics::derangements {n} { + if { $n <= 1 } { + return 0 + } + + if { $n == 2 } { + return 1 + } + + set dim2 0 + set dim1 1 + + for {set i 3} {$i <= $n} {incr i} { + set di [expr {($i-1) * ($dim1 + $dim2)}] + set dim2 $dim1 + set dim1 $di + } + + return $di +} + +# catalan -- +# Return the n-th Catalan number +# +# Arguments: +# n Index for the Catalan number (n >= 1) +# +# Result: +# The n-th Catalan number +# +proc ::math::combinatorics::catalan {n} { + if { $n < 0 || $n != int($n) } { + return -code error "The argument must be a non-negative integer" + } + + set combin [combinations [expr {2*$n}] $n] + + return [expr {$combin / ($n + 1)}] +} + +# firstStirling -- +# Calculate a Stirling number of the first kind +# (signed version, m cycles in a permutation of n items) +# +# Arguments: +# n Number of items +# m Number of cycles +# +# Note: +# The Stirling number returned is a signed number. +# For efficiency memoization is used. +# +proc ::math::combinatorics::firstStirling {n m} { + variable stirling + + if { $n == $m } { + return 1 + } + + if { $n <= 0 || $m < 0 || $n < $m } { + return 0 + } + + if { [info exists stirling($n,$m)] } { + return $stirling($n,$m) + } + + set nm1 [expr {$n-1}] + set mm1 [expr {$m-1}] + + set Snm1_m [firstStirling $nm1 $m] + set Snm1_mm1 [firstStirling $nm1 $mm1] + + set stirling($n,$m) [expr {$Snm1_mm1 - $nm1 * $Snm1_m}] + + return $stirling($n,$m) +} + +# secondStirling -- +# Calculate a Stirling number of the second kind +# (m non-empty subsets from n items) +# +# Arguments: +# n Number of items +# m Number of subsets +# +# Note: +# For efficiency memoization is used. +# +proc ::math::combinatorics::secondStirling {n m} { + variable stirlingSecond + + if { $n == $m || $m == 1 } { + return 1 + } + + if { $n <= 0 || $m < 0 || $n < $m } { + return 0 + } + + if { [info exists stirlingSecond($n,$m)] } { + return $stirlingSecond($n,$m) + } + + set nm1 [expr {$n-1}] + set mm1 [expr {$m-1}] + + set Snm1_m [secondStirling $nm1 $m] + set Snm1_mm1 [secondStirling $nm1 $mm1] + + set stirlingSecond($n,$m) [expr {$Snm1_mm1 + $m * $Snm1_m}] + + return $stirlingSecond($n,$m) +} + + +# partitionP -- +# Calculate the partitionP function (wrapper) +# +# Arguments: +# n The integer number to be partitioned +# +# Result: +# Number of partitions +# +proc ::math::combinatorics::partitionP {n} { + incr n + return [PartitionP $n] +} + +# partitionQ -- +# Calculate the partitionQ function (wrapper) - the number of partitions with distinct values +# (that is: an acceptable partition of 4 is (3,1) but not (2,2) +# +# Arguments: +# n The integer number to be partitioned +# +# Result: +# Number of partitions +# +proc ::math::combinatorics::partitionQ {n} { + incr n + TODO - see https://mathworld.wolfram.com/PartitionFunctionQ.html + + The calculation is not entirely trivial +} + +# PartitionP -- +# Calculate the partitionP function - see note +# +# Arguments: +# n The integer number to be partitioned +# +# Result: +# Number of partitions +# +# Note: +# This code computes partitionP(n-1) rather than partitionP(n), +# so it should not be called directly. +# +proc ::math::combinatorics::PartitionP {n} { + variable partition + + if { $n <= 0} { + return 0 + } + + if { [info exists partition($n)] } { + return $partition($n) + } + + set part 0 + + for {set k 1} {$k <= $n} {incr k} { + set partm1 [PartitionP [expr {$n - $k*(3*$k-1)/2}]] + set partp1 [PartitionP [expr {$n - $k*(3*$k+1)/2}]] + set part [expr {$part + ($partm1 + $partp1) * (-1)**($k+1)}] + } + + set partition($n) $part + + return $part +} + + +# list-permutations -- +# Generate a list of permutations +# +# Arguments: +# n Size of the set +# +# Returns: +# List of all permutations of the set {0 ... n} +# +proc ::math::combinatorics::list-permutations {n} { + if { $n < 1 } { + return -error "Size n of the set must be positive" + } + + if { $n == 1 } { + return [list 0] + } + + set listperms [list-permutations [expr {$n-1}]] + + set newlist {} + + set nm1 [expr {$n-1}] + foreach perm $listperms { + for {set i 0} {$i < $n} {incr i} { + set newperm [linsert $perm $i $nm1] + lappend newlist $newperm + } + } + + return $newlist +} + + +# list-variations -- +# Generate a list of variations (permuted subsets) +# +# Arguments: +# n Size of the set +# k Number of elements per subset +# +# Returns: +# List of all permutations of the set {0 ... n} +# +proc ::math::combinatorics::list-variations {n k} { + set combinations [list-combinations $n $k] + + set variations {} + foreach c $combinations { + lappend variations [List-permuted $c $k] + } + + return [concat {*}$variations] +} + + +# List-permuted -- +# Generate a list of permutations of given elements +# +# Arguments: +# list List of elements +# size Number of elements +# +# Returns: +# List of all permutations of the given set +# +# Note: +# Intended for private use only +# +# +proc ::math::combinatorics::List-permuted {list size} { + if { $size == 0 } { + return [list [list]] + } + set retval {} + + for { set i 0 } { $i < [llength $list] } { incr i } { + set firstElement [lindex $list $i] + set remainingElements [lreplace $list $i $i] + foreach subset [List-permuted $remainingElements [expr { $size - 1 }]] { + lappend retval [linsert $subset 0 $firstElement] + } + } + return $retval +} + + +# list-derangements -- +# Generate a list of derangements - permutations where +# all elements are displaced +# +# Arguments: +# n Size of the set +# +# Returns: +# List of all derangements of the set {0 ... n} +# +# Note: +# A naive implementation did not ork properly, so use +# brute force instead: filter out the permutations that are +# also derangements +# +proc ::math::combinatorics::list-derangements {n} { + set plist [::math::combinatorics::list-permutations $n] + set dlist {} + + set numbers {} + for {set i 0} {$i < $n} {incr i} { + lappend numbers $i + } + + foreach p $plist { + set accept 1 + foreach n $numbers e $p { + if { $n == $e } { + set accept 0 + break + } + } + if { $accept } { + lappend dlist $p + } + } + return $dlist +} + +# list-combinations-deprecated -- +# Generate a list of combinations - deprecated +# +# Arguments: +# n Size of the set +# k Number of elements per subset +# +# Returns: +# List of all combinations of the set {0 ... n} +# +# Note: +# This implementation is deprecated in cfavour of the Wiki implementation +# +proc ::math::combinatorics::list-combinations-deprecated {n k} { + if { $n < 1 } { + return -error "Size n of the set must be positive" + } + if { $k < 0 || $k > $n } { + return -error "Size k of the subsets must be positive and smaller/equal to n" + } + + if { $n == 1 } { + if { $k == 0 } { + return [list] + } else { + return [list 0] + } + } + + if { $k > 1 } { + set listperms [list-combinations-deprecated [expr {$n-1}] [expr {$k-1}]] + + set newlist {} + + set nm1 [expr {$n-1}] + foreach perm $listperms { + lappend newlist [concat $perm $nm1] + } + set newlist [concat $newlist [list-combinations-deprecated [expr {$n-1}] $k]] + } else { + set newlist {} + for {set i 0} {$i < $n} {incr i} { + lappend newlist [list $i] + } + } + + return $newlist +} + +# list-combinations -- +# Generate a list of combinations +# +# Arguments: +# n Size of the set +# k Number of elements per subset +# +# Returns: +# List of all combinations of the set {0 ... n} +# +# Note: +# Copied from the WIki - the implementation is three times +# faster than the deprecated version +# +proc ::math::combinatorics::list-combinations {n k} { + set myList {} + for {set i 0} {$i < $n} {incr i} { + lappend myList $i + } + + return [List-Combinations2 $myList $k] +} + +# List-Combinations2 -- +# Generate a list of combinations of a given list of elements +# +# Arguments: +# list List of elements +# k Number of elements per subset +# +# Returns: +# List of all combinations +# +proc ::math::combinatorics::List-Combinations2 {myList size {prefix {}}} { + # + # End recursion when size is 0 or equals our list size + # + if {$size == 0} {return [list $prefix]} + if {$size == [llength $myList]} {return [list [concat $prefix $myList]]} + + set first [lindex $myList 0] + set rest [lrange $myList 1 end] + + # + # Combine solutions w/ first element and solutions w/o first element + # + set ans1 [List-Combinations2 $rest [expr {$size-1}] [concat $prefix $first]] + set ans2 [List-Combinations2 $rest $size $prefix] + return [concat $ans1 $ans2] +} + +# list-powerset -- +# Generate a list representing the power set of {0 ... n} +# +# Arguments: +# n Size of the set +# +# Returns: +# List of all subsets of the set {0 ... n} +# +proc ::math::combinatorics::list-powerset {n} { + set ret {{{}}} + for {set i 1} {$i <= $n} {incr i} { + lappend ret [list-combinations $n $i] + } + return [concat {*}$ret] +} + +# permutationObj -- +# Class for generating permutations one by one +# +::oo::class create ::math::combinatorics::permutationObj { + variable n + variable k + variable current + variable elements + + # constructor -- + # Generate permutations of the set {0 .. n} + # Arguments: + # n_in Size of the set + # + constructor {n_in} { + variable n + variable k + variable current + variable start + + if { $n_in < 1 } { + return -code error "Size of the set must be positive" + } + + set n $n_in + + set elements {} + for {set i 0} {$i < $n} {incr i} { + lappend elements $i + } + + my reset + } + + # method: reset -- + # Restart the object + # + # Arguments: + # None + # + method reset {} { + variable current + variable start + + set start 1 + set current {} + for {set i 0} {$i < $n} {incr i} { + lappend current $i + } + } + + # method: next + # Return the next permutation + # + method next {} { + variable current + variable start + + # Return the first permutation? + if { $start } { + set start 0 + return $current + } + + # Find the smallest subscript j such that we have already visited + # all permutations beginning with the first j elements. + + set j [expr { [llength $current] - 1 }] + set ajp1 [lindex $current $j] + while { $j > 0 } { + incr j -1 + set aj [lindex $current $j] + if { [string compare $ajp1 $aj] > 0 } { + set foundj {} + break + } + set ajp1 $aj + } + if { ![info exists foundj] } return + + # Find the smallest element greater than the j'th among the elements + # following aj. Let its index be l, and interchange aj and al. + + set l [expr { [llength $current] - 1 }] + while { $aj >= [set al [lindex $current $l]] } { + incr l -1 + } + lset current $j $al + lset current $l $aj + + # Reverse a_j+1 ... an + + set k [expr {$j + 1}] + set l [expr { [llength $current] - 1 }] + while { $k < $l } { + set al [lindex $current $l] + lset current $l [lindex $current $k] + lset current $k $al + incr k + incr l -1 + } + + return $current + } + + # method: setElements -- + # Register a list of elements to be permuted + # + # Arguments: + # list List of elements + # + method setElements {list} { + variable n + variable elements + + if { [llength $list] != $n } { + return -code error "The number of elements should be $n" + } + set elements $list + + # Implicit reset + my reset + } + + # + # method: nextElements + # Returns the next permutation of the given elements + # + # Arguments: + # None + # + method nextElements {} { + variable elements + + set permutation [my next] + + set list {} + + foreach idx $permutation { + lappend list [lindex $elements $idx] + } + + return $list + } +} + +# combinationObj -- +# Class for generating combinations (k-subsets) one by one +# +::oo::class create ::math::combinatorics::combinationObj { + variable n + variable k + variable current + variable elements + + # constructor -- + # Generate combinations of k elements out of the set {0 .. n} + # Arguments: + # n_in Size of the set + # k_in Size of the subsets + # + constructor {n_in k_in} { + variable n + variable k + variable current + + if { $n_in < 1 || $k_in < 1 || $k_in > $n_in } { + return -code error "Sizes of the set and subset must be positive, subset may not be larger than the set" + } + + set n $n_in + set k $k_in + + set current {} + + set elements {} + for {set i 0} {$i < $n} {incr i} { + lappend elements $i + } + } + + # method: reset -- + # Restart the object + # + # Arguments: + # None + # + method reset {} { + variable current + + set current {} + } + + # + # method: next -- + # Return the next combination + # + # Arguments: + # None + # + method next {} { + variable n + variable k + variable current + + if { [llength $current] == 0 } { + for {set i 1} {$i <= $k} {incr i} { + set c($i) $i + } + } else { + for {set i 1; set j 0} {$i <= $k} {incr i; incr j} { + set c($i) [lindex $current $j] + } + set ptr $k + while {$ptr > 0 && $c($ptr) == $n - $k + $ptr} { + incr ptr -1 + } + if {$ptr == 0} { + return {} + } + incr c($ptr) + for {set i [expr {$ptr + 1}]} {$i <= $k} {incr i} { + set c($i) [expr $c([expr {$i - 1}]) + 1] + } + } + set cL [list] + set current [list] + for {set i 1} {$i <= $k} {incr i} { + lappend cL [expr {$c($i)-1}] + lappend current $c($i) + } + return $cL + } + + # method: setElements -- + # Register a list of elements to be permuted and selected + # + # Arguments: + # list List of elements + # + method setElements {list} { + variable n + variable elements + + if { [llength $list] != $n } { + return -code error "The number of elements should be $n" + } + set elements $list + + # Implicit reset + my reset + } + + # + # method: nextElements + # Returns next k-subset of the given elements + # + # Arguments: + # None + # + method nextElements {} { + variable elements + + set combination [my next] + + set list {} + + foreach idx $combination { + lappend list [lindex $elements $idx] + } + + return $list + } +} diff --git a/vendor/math/combinatoricsExt.test b/vendor/math/combinatoricsExt.test new file mode 100644 index 00000000..efb7357f --- /dev/null +++ b/vendor/math/combinatoricsExt.test @@ -0,0 +1,444 @@ +# combinatoricsExt.test -- +# Tests for the math::combinatorics package (the extended set of procedures) +# +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.6 +testsNeedTcltest 1.0 + +support { + useLocal math.tcl math +} +testing { + useLocal combinatoricsExt.tcl math::combinatorics +} + + +test counts-1.0 {Calculation of the number of permutations} -body { + set number {} + foreach n {1 2 5 10 20 30} { + lappend number [::math::combinatorics::permutations $n] + } + + set number +} -result {1 2 120 3628800 2432902008176640000 265252859812191058636308480000000} + +test counts-1.1 {Permutations for zero or negative count} -body { + set number {} + foreach n {-1 0} { + lappend number [::math::combinatorics::permutations $n] + } + + set number +} -result {1 1} + +test counts-2.0 {Calculation of the number of variations} -body { + set number {} + foreach n {1 2 5 10} { + foreach k {1 2 5 6 7 8 9} { + if { $k <= $n } { + lappend number [::math::combinatorics::variations $n $k] + } + } + } + + set number +} -result {1 2 2 5 20 120 10 90 30240 151200 604800 1814400 3628800} + +test counts-2.1 {Variations for zero or negative counts} -body { + set number {} + foreach n {-1 0 1 2 5} { + foreach k {-1 0 1 2 6} { + lappend number [::math::combinatorics::variations $n $k] + } + } + + set number +} -result {0 0 0 0 0 0 1 0 0 0 0 1 1 0 0 0 1 2 2 0 0 1 5 20 0} + +test counts-3.0 {Calculation of the number of combinations} -body { + set number {} + foreach n {1 2 5 10} { + foreach k {1 2 5 6 7 8 9} { + if { $k <= $n } { + lappend number [::math::combinatorics::combinations $n $k] + } + } + } + + set number +} -result {1 2 1 5 10 1 10 45 252 210 120 45 10} + +test counts-3.1 {Combinations for zero or negative counts} -body { + set number {} + foreach n {-1 0 1 2 5} { + foreach k {-1 0 1 2 6} { + lappend number [::math::combinatorics::combinations $n $k] + } + } + + set number +} -result {0 0 0 0 0 0 1 0 0 0 0 1 1 0 0 0 1 2 1 0 0 1 5 10 0} + +test counts-4.0 {Calculation of the number of derangements} -body { + set number {} + foreach n {1 2 3 4 5 6 7} { + lappend number [::math::combinatorics::derangements $n] + } + + set number +} -result {0 1 2 9 44 265 1854} + +test counts-4.1 {Derangements for zero or negative counts} -body { + set number {} + foreach n {-1 0} { + lappend number [::math::combinatorics::derangements $n] + } + + set number +} -result {0 0} + +# +# The reference numbers come from https://mathworld.wolfram.com +# +test numbers-1.0 {First few Catalan numbers} -body { + set number {} + foreach n {1 2 3 4 5 6 7 8 9 10} { + lappend number [::math::combinatorics::catalan $n] + } + + set number +} -result {1 2 5 14 42 132 429 1430 4862 16796} + +test numbers-2.0 {Stirling numbers of the first kind} -body { + set number {} + foreach n {1 2 3 4 5} { + foreach k {1 2 3 4 5} { + if { $k <= $n } { + lappend number [::math::combinatorics::firstStirling $n $k] + } + } + } + + set number +} -result {1 -1 1 2 -3 1 -6 11 -6 1 24 -50 35 -10 1} + +test numbers-2.1 {Stirling numbers of the second kind} -body { + set number {} + foreach n {1 2 3 4 5 6} { + foreach k {1 2 3 4 5 6} { + if { $k <= $n } { + lappend number [::math::combinatorics::secondStirling $n $k] + } + } + } + + set number +} -result {1 1 1 1 3 1 1 7 6 1 1 15 25 10 1 1 31 90 65 15 1} + +# +# Generate collection of permutations, etc. +# +test lists-1.0 {Small number of permutations} -body { + set collection [::math::combinatorics::list-permutations 4] +} -result {{3 2 1 0} {2 3 1 0} {2 1 3 0} {2 1 0 3} {3 1 2 0} {1 3 2 0} {1 2 3 0} {1 2 0 3} {3 1 0 2} {1 3 0 2} {1 0 3 2} {1 0 2 3} {3 2 0 1} {2 3 0 1} {2 0 3 1} {2 0 1 3} {3 0 2 1} {0 3 2 1} {0 2 3 1} {0 2 1 3} {3 0 1 2} {0 3 1 2} {0 1 3 2} {0 1 2 3}} + +test lists-1.1 {Check properties of the collection of permutations} -body { + set collection [::math::combinatorics::list-permutations 5] + + # Number of elements should be 5! = 120 + set correct_number [expr {[llength $collection] == 120}] + + # All elements should have 5 entries + set five_entries 1 + foreach c $collection { + if { [llength $c] != 5 } { + set five_entries 0 + break + } + } + + # All entries in the elements should be unique + set unique_entries 1 + foreach c $collection { + if { [llength [lsort -unique $c]] != 5 } { + set unique_entries 0 + break + } + } + + # All elements of the collection should be unique + set unique_elements [expr {[llength [lsort -unique $collection]] == 120}] + + # Report our findings + set result [list $correct_number $five_entries $unique_entries $unique_elements] +} -result {1 1 1 1} + +test lists-2.0 {Small number of variations} -body { + set collection [::math::combinatorics::list-variations 4 2] +} -result {{0 1} {1 0} {0 2} {2 0} {0 3} {3 0} {1 2} {2 1} {1 3} {3 1} {2 3} {3 2}} + +test lists-2.1 {Check properties of the collection of variations} -body { + set collection [::math::combinatorics::list-variations 5 2] + + # Number of elements should be 20 + set correct_number [expr {[llength $collection] == 20}] + + # All elements should have 2 entries + set two_entries 1 + foreach c $collection { + if { [llength $c] != 2 } { + set two_entries 0 + break + } + } + + # All entries in the elements should be unique + set unique_entries 1 + foreach c $collection { + if { [llength [lsort -unique $c]] != 2 } { + set unique_entries 0 + break + } + } + + # All elements of the collection should be unique + set unique_elements [expr {[llength [lsort -unique $collection]] == 20}] + + # Report our findings + set result [list $correct_number $two_entries $unique_entries $unique_elements] +} -result {1 1 1 1} + +test lists-3.0 {Small number of combinations} -body { + set collection [::math::combinatorics::list-combinations 4 2] +} -result {{0 1} {0 2} {0 3} {1 2} {1 3} {2 3}} + +test lists-3.1 {Check properties of the collection of combinations} -body { + set collection [::math::combinatorics::list-combinations 5 2] + + set correct_number [expr {[llength $collection] == 10}] + + # All elements should have 2 entries + set two_entries 1 + foreach c $collection { + if { [llength $c] != 2 } { + set two_entries 0 + break + } + } + + # All entries in the elements should be unique + set unique_entries 1 + foreach c $collection { + if { [llength [lsort -unique $c]] != 2 } { + set unique_entries 0 + break + } + } + + # All elements of the collection should be unique + set unique_elements [expr {[llength [lsort -unique $collection]] == 10}] + + # Report our findings + set result [list $correct_number $two_entries $unique_entries $unique_elements] +} -result {1 1 1 1} + +test lists-4.0 {Small number of derangements} -body { + set collection [::math::combinatorics::list-derangements 4] +} -result {{3 2 1 0} {2 3 1 0} {1 2 3 0} {1 3 0 2} {1 0 3 2} {3 2 0 1} {2 3 0 1} {2 0 3 1} {3 0 1 2}} + +test lists-4.1 {Check properties of the collection of derangements} -body { + set collection [::math::combinatorics::list-derangements 5] + + # Number of elements should be 44 + set correct_number [expr {[llength $collection] == 44}] + + # All elements should have 5 entries + set five_entries 1 + foreach c $collection { + if { [llength $c] != 5 } { + set five_entries 0 + break + } + } + + # All entries in the elements should be unique + set unique_entries 1 + foreach c $collection { + if { [llength [lsort -unique $c]] != 5 } { + set unique_entries 0 + break + } + } + + # All elements of the collection should be unique + set unique_elements [expr {[llength [lsort -unique $collection]] == 44}] + + # All entries should be in a different place than its numeric value - {0 2 1} is not a valid derangement + set correct_derangement 1 + foreach c $collection { + foreach i {0 1 2 3 4} v $c { + if { $i == $v } { + set correct_derangement 0 + break + } + } + } + + # Report our findings + set result [list $correct_number $five_entries $unique_entries $unique_elements $correct_derangement] +} -result {1 1 1 1 1} + +test lists-5.0 {Return the power set of a small set} -body { + set powerset [::math::combinatorics::list-powerset 4] +} -result {{} 0 1 2 3 {0 1} {0 2} {0 3} {1 2} {1 3} {2 3} {0 1 2} {0 1 3} {0 2 3} {1 2 3} {0 1 2 3}} + +test lists-5.1 {Check properties of the power set} -body { + set collection [::math::combinatorics::list-powerset 5] + + # Number of elements should be 32 + set correct_number [expr {[llength $collection] == 32}] + + # All elements should have 5 or less entries + set max_five_entries 1 + foreach c $collection { + if { [llength $c] > 5 } { + set max_five_entries 0 + break + } + } + + # All entries in the elements should be unique + set unique_entries 1 + foreach c $collection { + if { [llength [lsort -unique $c]] != [llength $c] } { + set unique_entries 0 + break + } + } + + # All elements of the collection should be unique + set unique_elements [expr {[llength [lsort -unique $collection]] == 32}] + + # Report our findings + set result [list $correct_number $max_five_entries $unique_entries $unique_elements] +} -result {1 1 1 1} + +# +# Permutation and combination objects +# +test objects-1.0 {List the permutations one by one} -body { + set n 0 + set obj [::math::combinatorics::permutationObj new 4] + + set permutations {} + + while {1} { + set permutation [$obj next] + + if { $permutation eq {} } { + break + } + + # Extra check + if { [llength $permutation] ne 4 } { + break + } + lappend permutations $permutation + } + + return [llength [lsort -unique $permutations]] +} -result 24 + +test objects-1.1 {Permute a given set of elements} -body { + set n 0 + set obj [::math::combinatorics::permutationObj new 4] + + $obj setElements {A B C D} + + set permutations {} + + while {1} { + set permutation [$obj nextElements] + + if { $permutation eq {} } { + break + } + + set okay 1 + foreach elem {A B C D} { + if { $elem ni $permutation } { + set okay 0 + break + } + } + + # Extra check + if { [llength $permutation] != 4 } { + break + } + + if { $okay } { + lappend permutations $permutation + } + } + + return [llength [lsort -unique $permutations]] +} -result 24 + +test objects-2.0 {List the combinations one by one} -body { + set n 0 + set obj [::math::combinatorics::combinationObj new 5 2] + + set combinations {} + + while {1} { + set combination [$obj next] + + if { $combination eq {} } { + break + } + + # Extra check + if { [llength $combination] != 2 } { + break + } + lappend combinations $combination + } + + return [llength [lsort -unique $combinations]] +} -result 10 + +test objects-2.1 {List combinations of a given set of elements} -body { + set n 0 + set obj [::math::combinatorics::combinationObj new 5 2] + + set combinations {} + + $obj setElements {A B C D E} + + while {1} { + set combination [$obj nextElements] + + if { $combination eq {} } { + break + } + + set okay 1 + foreach elem $combination { + if { $elem ni {A B C D E} } { + set okay 0 + break + } + } + + if { $okay } { + lappend combinations $combination + } + } + + return [llength [lsort -unique $combinations]] +} -result 10 + diff --git a/vendor/math/constants.man b/vendor/math/constants.man new file mode 100644 index 00000000..cd07f9ed --- /dev/null +++ b/vendor/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 }] +[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 ../common-text/feedback.inc] +[manpage_end] diff --git a/vendor/math/constants.tcl b/vendor/math/constants.tcl new file mode 100644 index 00000000..79e6ea54 --- /dev/null +++ b/vendor/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/vendor/math/constants.test b/vendor/math/constants.test new file mode 100644 index 00000000..cdc4a0be --- /dev/null +++ b/vendor/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.5 +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/vendor/math/decimal.man b/vendor/math/decimal.man new file mode 100644 index 00000000..0228b305 --- /dev/null +++ b/vendor/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 }] +[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 math::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 add + 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 [lb]expr {8.2 + .2}[rb] ; # => will output 8.399999999999999 + puts [lb]expr {8.2 - .2}[rb] ; # => 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 ../common-text/feedback.inc] +[manpage_end] diff --git a/vendor/math/decimal.tcl b/vendor/math/decimal.tcl new file mode 100644 index 00000000..43116c90 --- /dev/null +++ b/vendor/math/decimal.tcl @@ -0,0 +1,1742 @@ +package require Tcl 8.5 +package provide math::decimal 1.0.4 +# +# 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 positive 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 epart [scan $epart %d] + 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/vendor/math/decimal.test b/vendor/math/decimal.test new file mode 100644 index 00000000..1cd7a899 --- /dev/null +++ b/vendor/math/decimal.test @@ -0,0 +1,51 @@ +# -*- 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. +# +# 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 + +# +# Ticket d159e101f329682a232aabac36c0ef6640ff8484: +# math::decimal::fromstr reports an error when the exponential part has leading zeros. +test decimal-fromstr-1.1 "Correct conversion" { + list [math::decimal::tostr [math::decimal::fromstr 1E-09]] \ + [math::decimal::tostr [math::decimal::fromstr 1E-009]] +} {1E-9 1E-9} + +# ------------------------------------------------------------------------- + +# End of test cases +testsuiteCleanup diff --git a/vendor/math/elliptic.tcl b/vendor/math/elliptic.tcl new file mode 100644 index 00000000..e3149168 --- /dev/null +++ b/vendor/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 elliptic_K elliptic_E + + ::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::dn { 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*sin($u))**2)}] + } +} + + +# 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/vendor/math/elliptic.test b/vendor/math/elliptic.test new file mode 100644 index 00000000..7a09d39f --- /dev/null +++ b/vendor/math/elliptic.test @@ -0,0 +1,140 @@ +# -*- 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.5;# 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} + +# Jacobi elliptic functions: cn, sn and dn + +set um_pairs { +0 0 +0 0.1 +0 0.8 +0.1 0.1 +0.1 0.2 +0.1 0.5 +0.1 0.7 +0.1 0.8 +0.2 0.01 +0.2 0.1 +0.2 0.5 +0.3 0.01 +0.3 0.1 +0.3 0.5 +0.4 0.01 +0.5 0.01 +0.5 0.1 +0.6 0.1 +0.7 0.1 +0.8 0.1 +0.8 0.5 +0.9 0.01 +0.9 0.1 +0.9 0.5 +0.99 0.5 +} + +test "Elliptic-3.1" "Jacobi elliptic cn function" \ + -match numbers -body { + set result {} + foreach {u m} $um_pairs { + set k [expr {sqrt($m)}] + lappend result [::math::special::cn $u $k] + } + set result + } -result {1.000000 1.000000 1.000000 0.995006 0.995007 0.995012 0.995016 0.995017 0.980069 0.980093 0.980198 0.955350 0.955467 +0.955986 0.921101 0.877678 0.878530 0.827220 0.768165 0.702062 0.722917 0.622418 0.629653 0.660895 0.602576} + +test "Elliptic-3.2" "Jacobi elliptic sn function" \ + -match numbers -body { + set result {} + foreach {u m} $um_pairs { + set k [expr {sqrt($m)}] + lappend result [::math::special::sn $u $k] + } + set result + } -result {0.000000 0.000000 0.000000 0.0998169 0.0998003 0.0997507 0.0997176 0.0997011 0.198656 0.198540 0.198022 0.295478 0.295098 +0.293413 0.389323 0.479252 0.477687 0.561878 0.640252 0.712115 0.690935 0.782685 0.776876 0.750478 0.798062} + +test "Elliptic-3.3" "Jacobi elliptic dn function" \ + -match numbers -body { + set result {} + foreach {u m} $um_pairs { + set k [expr {sqrt($m)}] + lappend result [::math::special::dn $u $k] + } + set result + } -result {1.000000 1.000000 1.000000 0.999502 0.999003 0.997509 0.996514 0.996016 0.999803 0.998027 0.990148 0.999563 0.995636 +0.978241 0.999242 0.998851 0.988525 0.984088 0.979289 0.974315 0.872528 0.996932 0.969354 0.847580 0.825560} + +# End of test cases +testsuiteCleanup diff --git a/vendor/math/exact.man b/vendor/math/exact.man new file mode 100644 index 00000000..2509f4fc --- /dev/null +++ b/vendor/math/exact.man @@ -0,0 +1,219 @@ +[vset VERSION 1.0.1] +[manpage_begin math::exact n [vset VERSION]] +[copyright "2015 Kevin B. Kenny +Redistribution permitted under the terms of the Open\ +Publication License "] +[moddesc {Tcl Math Library}] +[titledesc {Exact Real Arithmetic}] +[category Mathematics] +[require Tcl 8.6] +[require grammar::aycock 1.0] +[require math::exact [vset VERSION]] +[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/vendor/math/exact.tcl b/vendor/math/exact.tcl new file mode 100644 index 00000000..a947526a --- /dev/null +++ b/vendor/math/exact.tcl @@ -0,0 +1,4060 @@ +# 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} { + variable iszer + set n 0 + while {1} { + if {[vrefines [mdotv [reverse $m] {1 0}]]} { + return {} + } elseif {[mrefines [mdotm $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>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.1 + +#----------------------------------------------------------------------- diff --git a/vendor/math/exact.test b/vendor/math/exact.test new file mode 100644 index 00000000..ad014197 --- /dev/null +++ b/vendor/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.1 + +#----------------------------------------------------------------------------- + +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/vendor/math/exponential.tcl b/vendor/math/exponential.tcl new file mode 100644 index 00000000..b90952a7 --- /dev/null +++ b/vendor/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/vendor/math/figurate.man b/vendor/math/figurate.man new file mode 100644 index 00000000..119b1fad --- /dev/null +++ b/vendor/math/figurate.man @@ -0,0 +1,373 @@ +[manpage_begin math::figurate n 1.0] +[keywords {figurate numbers}] +[keywords mathematics] +[moddesc {Tcl Math Library}] +[titledesc {Evaluate figurate numbers}] +[category Mathematics] +[require Tcl 8.6] +[require math::figurate 1.0] +[description] +[para] + +Sums of numbers that follow a particular pattern are called figurate numbers. +A simple example is the sum of integers 1, 2, ... up to n. You can arrange +1, 1+2=3, 1+2+3=6, ... objects in a triangle, hence the name triangular +numbers: +[example { + * + * * + * * * + * * * * + ... +}] + +The [package math::figurate] package consists of a collection of procedures to +evaluate a wide variety of figurate numbers. While all formulae are +straightforward, the details are sometimes puzzling. + +[emph Note:] The procedures consider arguments lower than zero as to mean "no objects to be counted" +and therefore return 0. + +[section "PROCEDURES"] +The procedures can be arranged in a few categories: sums of integers raised to a +particular power, sums of odd integers and general figurate numbers, for +instance the pentagonal numbers. + +[list_begin definitions] + +[call [cmd ::math::figurate::sum_sequence] [arg n]] +Return the sum of integers 1, 2, ..., n. + +[list_begin arguments] +[arg_def int n] Highest integer in the sum +[list_end] +[para] + +[call [cmd ::math::figurate::sum_squares] [arg n]] +Return the sum of squares 1**2, 2**2, ..., n**2. + +[list_begin arguments] +[arg_def int n] Highest base integer in the sum +[list_end] +[para] + +[call [cmd ::math::figurate::sum_cubes] [arg n]] +Return the sum of cubes 1**3, 2**3, ..., n**3. + +[list_begin arguments] +[arg_def int n] Highest base integer in the sum +[list_end] +[para] + +[call [cmd ::math::figurate::sum_4th_power] [arg n]] +Return the sum of 4th powers 1**4, 2**4, ..., n**4. + +[list_begin arguments] +[arg_def int n] Highest base integer in the sum +[list_end] +[para] + +[call [cmd ::math::figurate::sum_5th_power] [arg n]] +Return the sum of 5th powers 1**5, 2**5, ..., n**5. + +[list_begin arguments] +[arg_def int n] Highest base integer in the sum +[list_end] +[para] + +[call [cmd ::math::figurate::sum_6th_power] [arg n]] +Return the sum of 6th powers 1**6, 2**6, ..., n**6. + +[list_begin arguments] +[arg_def int n] Highest base integer in the sum +[list_end] +[para] + +[call [cmd ::math::figurate::sum_7th_power] [arg n]] +Return the sum of 7th powers 1**7, 2**7, ..., n**7. + +[list_begin arguments] +[arg_def int n] Highest base integer in the sum +[list_end] + +[call [cmd ::math::figurate::sum_8th_power] [arg n]] +Return the sum of 8th powers 1**8, 2**8, ..., n**8. + +[list_begin arguments] +[arg_def int n] Highest base integer in the sum +[list_end] +[para] + +[call [cmd ::math::figurate::sum_9th_power] [arg n]] +Return the sum of 9th powers 1**9, 2**9, ..., n**9. + +[list_begin arguments] +[arg_def int n] Highest base integer in the sum +[list_end] +[para] + +[call [cmd ::math::figurate::sum_10th_power] [arg n]] +Return the sum of 10th powers 1**10, 2**10, ..., n**10. + +[list_begin arguments] +[arg_def int n] Highest base integer in the sum +[list_end] +[para] + + +[call [cmd ::math::figurate::sum_sequence_odd] [arg n]] +Return the sum of odd integers 1, 3, ..., 2n-1 + +[list_begin arguments] +[arg_def int n] Highest integer in the sum +[list_end] +[para] + +[call [cmd ::math::figurate::sum_squares_odd] [arg n]] +Return the sum of odd squares 1**2, 3**2, ..., (2n-1)**2. + +[list_begin arguments] +[arg_def int n] Highest base integer in the sum +[list_end] +[para] + +[call [cmd ::math::figurate::sum_cubes_odd] [arg n]] +Return the sum of odd cubes 1**3, 3**3, ..., (2n-1)**3. + +[list_begin arguments] +[arg_def int n] Highest base integer in the sum +[list_end] +[para] + +[call [cmd ::math::figurate::sum_4th_power_odd] [arg n]] +Return the sum of odd 4th powers 1**4, 2**4, ..., (2n-1)**4. + +[list_begin arguments] +[arg_def int n] Highest base integer in the sum +[list_end] +[para] + +[call [cmd ::math::figurate::sum_5th_power_odd] [arg n]] +Return the sum of odd 5th powers 1**5, 2**5, ..., (2n-1)**5. + +[list_begin arguments] +[arg_def int n] Highest base integer in the sum +[list_end] +[para] + +[call [cmd ::math::figurate::sum_6th_power_odd] [arg n]] +Return the sum of odd 6th powers 1**6, 2**6, ..., (2n-1)**6. + +[list_begin arguments] +[arg_def int n] Highest base integer in the sum +[list_end] +[para] + +[call [cmd ::math::figurate::sum_7th_power_odd] [arg n]] +Return the sum of odd 7th powers 1**7, 2**7, ..., (2n-1)**7. + +[list_begin arguments] +[arg_def int n] Highest base integer in the sum +[list_end] + +[call [cmd ::math::figurate::sum_8th_power_odd] [arg n]] +Return the sum of odd 8th powers 1**8, 2**8, ..., (2n-1)**8. + +[list_begin arguments] +[arg_def int n] Highest base integer in the sum +[list_end] +[para] + +[call [cmd ::math::figurate::sum_9th_power_odd] [arg n]] +Return the sum of odd 9th powers 1**9, 2**9, ..., (2n-1)**9. + +[list_begin arguments] +[arg_def int n] Highest base integer in the sum +[list_end] +[para] + +[call [cmd ::math::figurate::sum_10th_power_odd] [arg n]] +Return the sum of odd 10th powers 1**10, 2**10, ..., (2n-1)**10. + +[list_begin arguments] +[arg_def int n] Highest base integer in the sum +[list_end] +[para] + + +[call [cmd ::math::figurate::oblong] [arg n]] +Return the nth oblong number (twice the nth triangular number) + +[list_begin arguments] +[arg_def int n] Required index +[list_end] +[para] + +[call [cmd ::math::figurate::pronic] [arg n]] +Return the nth pronic number (synonym for oblong) + +[list_begin arguments] +[arg_def int n] Required index +[list_end] +[para] + +[call [cmd ::math::figurate::triangular] [arg n]] +Return the nth triangular number + +[list_begin arguments] +[arg_def int n] Required index +[list_end] +[para] + +[call [cmd ::math::figurate::square] [arg n]] +Return the nth square number + +[list_begin arguments] +[arg_def int n] Required index +[list_end] +[para] + +[call [cmd ::math::figurate::cubic] [arg n]] +Return the nth cubic number + +[list_begin arguments] +[arg_def int n] Required index +[list_end] +[para] + +[call [cmd ::math::figurate::biquadratic] [arg n]] +Return the nth biquaratic number (i.e. n**4) + +[list_begin arguments] +[arg_def int n] Required index +[list_end] +[para] + +[call [cmd ::math::figurate::centeredTriangular] [arg n]] +Return the nth centered triangular number (items arranged in concentric +squares) + +[list_begin arguments] +[arg_def int n] Required index +[list_end] +[para] + +[call [cmd ::math::figurate::centeredSquare] [arg n]] +Return the nth centered square number (items arranged in concentric squares) + +[list_begin arguments] +[arg_def int n] Required index +[list_end] +[para] + +[call [cmd ::math::figurate::centeredPentagonal] [arg n]] +Return the nth centered pentagonal number (items arranged in concentric +pentagons) + +[list_begin arguments] +[arg_def int n] Required index +[list_end] +[para] + +[call [cmd ::math::figurate::centeredHexagonal] [arg n]] +Return the nth centered hexagonal number (items arranged in concentric +hexagons) + +[list_begin arguments] +[arg_def int n] Required index +[list_end] +[para] + +[call [cmd ::math::figurate::centeredCube] [arg n]] +Return the nth centered cube number (items arranged in concentric +cubes) + +[list_begin arguments] +[arg_def int n] Required index +[list_end] +[para] + +[call [cmd ::math::figurate::decagonal] [arg n]] +Return the nth decagonal number (items arranged in decagons with one common +vertex) + +[list_begin arguments] +[arg_def int n] Required index +[list_end] +[para] + +[call [cmd ::math::figurate::heptagonal] [arg n]] +Return the nth heptagonal number (items arranged in heptagons with one +common vertex) + +[list_begin arguments] +[arg_def int n] Required index +[list_end] +[para] + +[call [cmd ::math::figurate::hexagonal] [arg n]] +Return the nth hexagonal number (items arranged in hexagons with one +common vertex) + +[list_begin arguments] +[arg_def int n] Required index +[list_end] +[para] + +[call [cmd ::math::figurate::octagonal] [arg n]] +Return the nth octagonal number (items arranged in octagons with one +common vertex) + +[list_begin arguments] +[arg_def int n] Required index +[list_end] +[para] + +[call [cmd ::math::figurate::octahedral] [arg n]] +Return the nth octahedral number (items arranged in octahedrons with a +common centre) + +[list_begin arguments] +[arg_def int n] Required index +[list_end] +[para] + +[call [cmd ::math::figurate::pentagonal] [arg n]] +Return the nth pentagonal number (items arranged in pentagons with one +common vertex) + +[list_begin arguments] +[arg_def int n] Required index +[list_end] +[para] + +[call [cmd ::math::figurate::squarePyramidral] [arg n]] +Return the nth square pyramidral number (items arranged in a square pyramid) + +[list_begin arguments] +[arg_def int n] Required index +[list_end] +[para] + +[call [cmd ::math::figurate::tetrahedral] [arg n]] +Return the nth tetrahedral number (items arranged in a triangular pyramid) + +[list_begin arguments] +[arg_def int n] Required index +[list_end] +[para] + +[call [cmd ::math::figurate::pentatope] [arg n]] +Return the nth pentatope number (items arranged in the four-dimensional analogue +of a triangular pyramid) + +[list_begin arguments] +[arg_def int n] Required index +[list_end] +[para] + +[list_end] + +[vset CATEGORY {math :: figurate}] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/vendor/math/figurate.tcl b/vendor/math/figurate.tcl new file mode 100644 index 00000000..0f093c3e --- /dev/null +++ b/vendor/math/figurate.tcl @@ -0,0 +1,294 @@ +# figurate.tcl -- +# Package for evaluating expressions regarding so-called figurate numbers: +# - triangular numbers: sum of 1, 2, 3, ... n +# - hex numbers: sum of centred hexagons with sides of n long, sum of 1, 6, 12, 18, ..., 6n +# - etc. +# - also sums of kth powers of 1, 2, 3, ... n (k = 1 to 10) +# +# Inspired by "gold", definitions of the figurate numbers following https://mathworld.wolfram.com/FigurateNumber.html +# +package require Tcl 8.6 +package provide math::figurate 1.0 + +namespace eval ::math::figurate { + namespace export sum_sequence sum_squares sum_cubes sum_4th_power sum_5th_power sum_6th_power \ + sum_7th_power sum_8th_power sum_9th_power sum_10th_power \ + sum_sequence_odd sum_squares_odd sum_cubes_odd sum_4th_power_odd sum_5th_power_odd sum_6th_power_odd \ + sum_7th_power_odd sum_8th_power_odd sum_9th_power_odd sum_10th_power_odd \ + oblong pronic triangular square cubic biquadratic centeredSquare centeredCube centeredPentagonal \ + centeredHexagonal decagonal heptagonal hexagonal octagonal octahedral pentagonal squarePyramidal \ + tetrahedral pentatope centeredTriangular +} + +# sum_* -- +# Compute the sums of powers of integers 1 to n +# +# Arguments: +# n Largest integer in the sum +# +# Returns: +# Sum 1**k + 2**k + ... + n**k +# +proc ::math::figurate::sum_sequence {n} { + expr {$n > 0 ? $n * ($n+1) / 2 : 0} +} + +proc ::math::figurate::sum_squares {n} { + expr {$n > 0 ? $n*($n + 1) * (2*$n +1 ) / 6 : 0} +} + +proc ::math::figurate::sum_cubes {n} { + expr {$n > 0 ? $n**2 * ($n + 1)**2 / 4 : 0} +} + +proc ::math::figurate::sum_4th_power {n} { + expr {$n > 0 ? $n* ($n + 1) * (2*$n + 1) * (3*$n**2 + 3*$n -1 ) / 30 : 0} +} + +proc ::math::figurate::sum_5th_power {n} { + expr {$n > 0 ? $n**2 * ($n + 1)**2 * (2*$n**2 + 2*$n - 1) / 12 : 0} +} + +proc ::math::figurate::sum_6th_power {n} { + expr {$n > 0 ? $n * ($n + 1) * (2*$n + 1 ) * (3*$n**4 + 6*$n**3 - 3*$n + 1) / 42 : 0} +} + +proc ::math::figurate::sum_7th_power {n} { + expr {$n > 0 ? $n**2 * ($n + 1)**2 * (3*$n**4 + 6*$n**3 - $n**2 - 4*$n + 2) / 24 : 0} +} + +proc ::math::figurate::sum_8th_power {n} { + expr {$n > 0 ? $n * ($n + 1) * (2*$n + 1) * (5*$n**6 + 15*$n**5 + 5*$n**4 - 15*$n**3 - $n**2 + 9*$n - 3) / 90 : 0} +} + +proc ::math::figurate::sum_9th_power {n} { + expr {$n > 0 ? $n**2 * ($n + 1)**2 * (2*$n**6 + 6*$n**5 + $n**4 - 8*$n**3 + $n**2 + 6*$n - 3) / 20 : 0} +} + +proc ::math::figurate::sum_10th_power {n} { + expr {$n > 0 ? $n * ($n + 1) * (2*$n + 1) * (3*$n**8 + 12*$n**7 + 8*$n**6 - 18*$n**5 - 10*$n**4 + 24*$n**3 + 2*$n**2 - 15*$n + 5) / 66 : 0} +} + +# calculate sums of odd integers: +# +# Arguments: +# n Number of odd integers (not the largest number) +# +# Note: +# The procedures sum the values (2*k+1)**m from k = 1 to n +# The calculations rely on the following identity: +# +# Sum (2k+1)**m = Sum j**m - 2**m Sum k**m, where k = 0,...,n, j = 0,..., 2*n+1 +# +proc ::math::figurate::sum_sequence_odd {n} { + if { $n > 0 } { + set maxnum [expr {2 * $n - 1}] + set sum1 [sum_sequence [expr {$n-1}]] + set sum2 [sum_sequence $maxnum] + + return [expr {$sum2 - 2 * $sum1}] + } else { + return 0 + } +} + +proc ::math::figurate::sum_squares_odd {n} { + if { $n > 0 } { + set maxnum [expr {2 * $n - 1}] + set sum1 [sum_squares [expr {$n-1}]] + set sum2 [sum_squares $maxnum] + + return [expr {$sum2 - 4 * $sum1}] + } else { + return 0 + } +} + +proc ::math::figurate::sum_cubes_odd {n} { + if { $n > 0 } { + set maxnum [expr {2 * $n - 1}] + set sum1 [sum_cubes [expr {$n-1}]] + set sum2 [sum_cubes $maxnum] + + return [expr {$sum2 - 8 * $sum1}] + } else { + return 0 + } +} + +proc ::math::figurate::sum_4th_power_odd {n} { + if { $n > 0 } { + set maxnum [expr {2 * $n - 1}] + set sum1 [sum_4th_power [expr {$n-1}]] + set sum2 [sum_4th_power $maxnum] + + return [expr {$sum2 - 16 * $sum1}] + } else { + return 0 + } +} + +proc ::math::figurate::sum_5th_power_odd {n} { + if { $n > 0 } { + set maxnum [expr {2 * $n - 1}] + set sum1 [sum_5th_power [expr {$n-1}]] + set sum2 [sum_5th_power $maxnum] + + return [expr {$sum2 - 32 * $sum1}] + } else { + return 0 + } +} + +proc ::math::figurate::sum_6th_power_odd {n} { + if { $n > 0 } { + set maxnum [expr {2 * $n - 1}] + set sum1 [sum_6th_power [expr {$n-1}]] + set sum2 [sum_6th_power $maxnum] + + return [expr {$sum2 - 64 * $sum1}] + } else { + return 0 + } +} + +proc ::math::figurate::sum_7th_power_odd {n} { + if { $n > 0 } { + set maxnum [expr {2 * $n - 1}] + set sum1 [sum_7th_power [expr {$n-1}]] + set sum2 [sum_7th_power $maxnum] + + return [expr {$sum2 - 128 * $sum1}] + } else { + return 0 + } +} + +proc ::math::figurate::sum_8th_power_odd {n} { + if { $n > 0 } { + set maxnum [expr {2 * $n - 1}] + set sum1 [sum_8th_power [expr {$n-1}]] + set sum2 [sum_8th_power $maxnum] + + return [expr {$sum2 - 256 * $sum1}] + } else { + return 0 + } +} + +proc ::math::figurate::sum_9th_power_odd {n} { + if { $n > 0 } { + set maxnum [expr {2 * $n - 1}] + set sum1 [sum_9th_power [expr {$n-1}]] + set sum2 [sum_9th_power $maxnum] + + return [expr {$sum2 - 512 * $sum1}] + } else { + return 0 + } +} + +proc ::math::figurate::sum_10th_power_odd {n} { + if { $n > 0 } { + set maxnum [expr {2 * $n - 1}] + set sum1 [sum_10th_power [expr {$n-1}]] + set sum2 [sum_10th_power $maxnum] + + return [expr {$sum2 - 1024 * $sum1}] + } else { + return 0 + } +} + +# calculate figurate numbers -- +# +# Arguments: +# n Largest integer in the sum +# +# Notes: +# - pronic and oblong are identical (see Mathworld page) +# - definitions follow the Mathworld page, though in some cases a more verbose name has been chosen +# (instead of hex, centeredHexagonal) +# - there are some trivial procedures as well (square for instance) +# - for the interpretation: again see the Mathworld page +# +proc ::math::figurate::oblong {n} { + expr {$n > 0 ? $n * ($n + 1) : 0} +} + +proc ::math::figurate::pronic {n} { + expr {$n > 0 ? $n * ($n + 1) : 0} +} + +proc ::math::figurate::triangular {n} { + expr {$n > 0 ? $n * ($n + 1)/2 : 0} +} + +proc ::math::figurate::square {n} { + expr {$n > 0 ? $n**2 : 0} +} + +proc ::math::figurate::cubic {n} { + expr {$n > 0 ? $n**3 : 0} +} + +proc ::math::figurate::biquadratic {n} { + expr {$n > 0 ? $n**4 : 0} +} + +proc ::math::figurate::centeredTriangular {n} { + expr {$n > 0 ? (3*$n**2 - 3*$n + 2) / 2 : 0} +} + +proc ::math::figurate::centeredSquare {n} { + expr {$n >0 ? $n**2 + ($n-1)**2 : 0} +} + +proc ::math::figurate::centeredCube {n} { + expr {$n > 0 ? $n**3 + ($n-1)**3 : 0} +} + +proc ::math::figurate::centeredPentagonal {n} { + expr {$n > 0 ? (5*($n-1)**2 + 5*($n-1) + 2) / 2 : 0} +} + +proc ::math::figurate::centeredHexagonal {n} { + expr {$n > 0 ? 3*($n-1)**2 + 3*($n-1) + 1 : 0} +} + +proc ::math::figurate::decagonal {n} { + expr {$n > 0 ? 4*$n**2 - 3*$n : 0} +} + +proc ::math::figurate::heptagonal {n} { + expr {$n > 0 ? $n * (5*$n - 3) / 2 : 0} +} + +proc ::math::figurate::hexagonal {n} { + expr {$n > 0 ? $n * (2*$n - 1) : 0} +} + +proc ::math::figurate::octagonal {n} { + expr {$n > 0 ? $n * (3*$n - 2) : 0} +} + +proc ::math::figurate::octahedral {n} { + expr {$n > 0 ? $n * (2*$n**2 + 1) / 3 : 0} +} + +proc ::math::figurate::pentagonal {n} { + expr {$n > 0 ? $n * (3*$n - 1) / 2 : 0} +} + +proc ::math::figurate::squarePyramidal {n} { + expr {$n > 0 ? $n * ($n + 1) * (2*$n + 1)/ 6 : 0} +} + +proc ::math::figurate::tetrahedral {n} { + expr {$n > 0 ? $n * ($n + 1) * ($n + 2) / 6 : 0} +} + +proc ::math::figurate::pentatope {n} { + expr {$n > 0 ? $n * ($n + 1) * ($n + 2) * ($n + 3) / 24 : 0} +} + diff --git a/vendor/math/figurate.test b/vendor/math/figurate.test new file mode 100644 index 00000000..dcf9d441 --- /dev/null +++ b/vendor/math/figurate.test @@ -0,0 +1,563 @@ +# -*- tcl -*- +# figurate.test -- +# Test cases for the ::math::figurate package (figurate numbers) +# +# 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) 2022 by Arjen Markus. All rights reserved. + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.6 +testsNeedTcltest 2.1 + +testing { + useLocal figurate.tcl math::figurate +} + +# ------------------------------------------------------------------------- + +# Compare the integers in lists + +proc matchNumbers {expected actual} { + set match 1 + foreach a $actual e $expected { + if { $a != $e } { + set match 0 + break + } + } + return $match +} + +::tcltest::customMatch numbers matchNumbers + +# +# Test the summation procedures +# +test "sum-1.1" "Sum of successive integers" \ + -match numbers -body { + set power 1 + + set result {} + + for {set n 1} {$n < 10} {incr n} { + set sumN [::math::figurate::sum_sequence $n] + set sumNmin1 [::math::figurate::sum_sequence [expr {$n-1}]] + set diff [expr {$sumN - $sumNmin1}] + set expected [expr {$n**$power}] + + lappend result [expr {$diff == $expected}] + } + set result + } -result {1 1 1 1 1 1 1 1 1} + +test "sum-1.2" "Sum of successive squares" \ + -match numbers -body { + set power 2 + + set result {} + + for {set n 1} {$n < 10} {incr n} { + set sumN [::math::figurate::sum_squares $n] + set sumNmin1 [::math::figurate::sum_squares [expr {$n-1}]] + set diff [expr {$sumN - $sumNmin1}] + set expected [expr {$n**$power}] + + lappend result [expr {$diff == $expected}] + } + set result + } -result {1 1 1 1 1 1 1 1 1} + +test "sum-1.3" "Sum of successive cubes" \ + -match numbers -body { + set power 3 + + set result {} + + for {set n 1} {$n < 10} {incr n} { + set sumN [::math::figurate::sum_cubes $n] + set sumNmin1 [::math::figurate::sum_cubes [expr {$n-1}]] + set diff [expr {$sumN - $sumNmin1}] + set expected [expr {$n**$power}] + + lappend result [expr {$diff == $expected}] + } + set result + } -result {1 1 1 1 1 1 1 1 1} + +test "sum-1.4" "Sum of successive 4th powers" \ + -match numbers -body { + set power 4 + + set result {} + + for {set n 1} {$n < 10} {incr n} { + set sumN [::math::figurate::sum_4th_power $n] + set sumNmin1 [::math::figurate::sum_4th_power [expr {$n-1}]] + set diff [expr {$sumN - $sumNmin1}] + set expected [expr {$n**$power}] + + lappend result [expr {$diff == $expected}] + } + set result + } -result {1 1 1 1 1 1 1 1 1} + +test "sum-1.5" "Sum of successive 5th powers" \ + -match numbers -body { + set power 5 + + set result {} + + for {set n 1} {$n < 10} {incr n} { + set sumN [::math::figurate::sum_5th_power $n] + set sumNmin1 [::math::figurate::sum_5th_power [expr {$n-1}]] + set diff [expr {$sumN - $sumNmin1}] + set expected [expr {$n**$power}] + + lappend result [expr {$diff == $expected}] + } + set result + } -result {1 1 1 1 1 1 1 1 1} + +test "sum-1.6" "Sum of successive 6th powers" \ + -match numbers -body { + set power 6 + + set result {} + + for {set n 1} {$n < 10} {incr n} { + set sumN [::math::figurate::sum_6th_power $n] + set sumNmin1 [::math::figurate::sum_6th_power [expr {$n-1}]] + set diff [expr {$sumN - $sumNmin1}] + set expected [expr {$n**$power}] + + lappend result [expr {$diff == $expected}] + } + set result + } -result {1 1 1 1 1 1 1 1 1} + +test "sum-1.7" "Sum of successive 7th powers" \ + -match numbers -body { + set power 7 + + set result {} + + for {set n 1} {$n < 10} {incr n} { + set sumN [::math::figurate::sum_7th_power $n] + set sumNmin1 [::math::figurate::sum_7th_power [expr {$n-1}]] + set diff [expr {$sumN - $sumNmin1}] + set expected [expr {$n**$power}] + + lappend result [expr {$diff == $expected}] + } + set result + } -result {1 1 1 1 1 1 1 1 1} + +test "sum-1.8" "Sum of successive 8th powers" \ + -match numbers -body { + set power 8 + + set result {} + + for {set n 1} {$n < 10} {incr n} { + set sumN [::math::figurate::sum_8th_power $n] + set sumNmin1 [::math::figurate::sum_8th_power [expr {$n-1}]] + set diff [expr {$sumN - $sumNmin1}] + set expected [expr {$n**$power}] + + lappend result [expr {$diff == $expected}] + } + set result + } -result {1 1 1 1 1 1 1 1 1} + +test "sum-1.9" "Sum of successive 9th powers" \ + -match numbers -body { + set power 9 + + set result {} + + for {set n 1} {$n < 10} {incr n} { + set sumN [::math::figurate::sum_9th_power $n] + set sumNmin1 [::math::figurate::sum_9th_power [expr {$n-1}]] + set diff [expr {$sumN - $sumNmin1}] + set expected [expr {$n**$power}] + + lappend result [expr {$diff == $expected}] + } + set result + } -result {1 1 1 1 1 1 1 1 1} + +test "sum-1.10" "Sum of successive 10th powers" \ + -match numbers -body { + set power 10 + + set result {} + + for {set n 1} {$n < 10} {incr n} { + set sumN [::math::figurate::sum_10th_power $n] + set sumNmin1 [::math::figurate::sum_10th_power [expr {$n-1}]] + set diff [expr {$sumN - $sumNmin1}] + set expected [expr {$n**$power}] + + lappend result [expr {$diff == $expected}] + } + set result + } -result {1 1 1 1 1 1 1 1 1} + +test "sum-odd-1.1" "Sum of successive odd integers" \ + -match numbers -body { + set power 1 + + set result {} + + for {set n 1} {$n < 10} {incr n} { + set odd [expr {2*$n-1}] + set sumN [::math::figurate::sum_sequence_odd $n] + set sumNmin1 [::math::figurate::sum_sequence_odd [expr {$n-1}]] + set diff [expr {$sumN - $sumNmin1}] + set expected [expr {$odd**$power}] + + lappend result [expr {$diff == $expected}] + } + set result + } -result {1 1 1 1 1 1 1 1 1} + +test "sum-odd-1.2" "Sum of successive odd squares" \ + -match numbers -body { + set power 2 + + set result {} + + for {set n 1} {$n < 10} {incr n} { + set odd [expr {2*$n-1}] + set sumN [::math::figurate::sum_squares_odd $n] + set sumNmin1 [::math::figurate::sum_squares_odd [expr {$n-1}]] + set diff [expr {$sumN - $sumNmin1}] + set expected [expr {$odd**$power}] + + lappend result [expr {$diff == $expected}] + } + set result + } -result {1 1 1 1 1 1 1 1 1} + +test "sum-odd-1.3" "Sum of successive odd cubes" \ + -match numbers -body { + set power 3 + + set result {} + + for {set n 1} {$n < 10} {incr n} { + set odd [expr {2*$n-1}] + set sumN [::math::figurate::sum_cubes_odd $n] + set sumNmin1 [::math::figurate::sum_cubes_odd [expr {$n-1}]] + set diff [expr {$sumN - $sumNmin1}] + set expected [expr {$odd**$power}] + + lappend result [expr {$diff == $expected}] + } + set result + } -result {1 1 1 1 1 1 1 1 1} + +test "sum-odd-1.4" "Sum of successive odd 4th powers" \ + -match numbers -body { + set power 4 + + set result {} + + for {set n 1} {$n < 10} {incr n} { + set odd [expr {2*$n-1}] + set sumN [::math::figurate::sum_4th_power_odd $n] + set sumNmin1 [::math::figurate::sum_4th_power_odd [expr {$n-1}]] + set diff [expr {$sumN - $sumNmin1}] + set expected [expr {$odd**$power}] + + lappend result [expr {$diff == $expected}] + } + set result + } -result {1 1 1 1 1 1 1 1 1} + +test "sum-odd-1.5" "Sum of successive odd 5th powers" \ + -match numbers -body { + set power 5 + + set result {} + + for {set n 1} {$n < 10} {incr n} { + set odd [expr {2*$n-1}] + set sumN [::math::figurate::sum_5th_power_odd $n] + set sumNmin1 [::math::figurate::sum_5th_power_odd [expr {$n-1}]] + set diff [expr {$sumN - $sumNmin1}] + set expected [expr {$odd**$power}] + + lappend result [expr {$diff == $expected}] + } + set result + } -result {1 1 1 1 1 1 1 1 1} + +test "sum-odd-1.6" "Sum of successive odd 6th powers" \ + -match numbers -body { + set power 6 + + set result {} + + for {set n 1} {$n < 10} {incr n} { + set odd [expr {2*$n-1}] + set sumN [::math::figurate::sum_6th_power_odd $n] + set sumNmin1 [::math::figurate::sum_6th_power_odd [expr {$n-1}]] + set diff [expr {$sumN - $sumNmin1}] + set expected [expr {$odd**$power}] + + lappend result [expr {$diff == $expected}] + } + set result + } -result {1 1 1 1 1 1 1 1 1} + +test "sum-odd-1.7" "Sum of successive odd 7th powers" \ + -match numbers -body { + set power 7 + + set result {} + + for {set n 1} {$n < 10} {incr n} { + set odd [expr {2*$n-1}] + set sumN [::math::figurate::sum_7th_power_odd $n] + set sumNmin1 [::math::figurate::sum_7th_power_odd [expr {$n-1}]] + set diff [expr {$sumN - $sumNmin1}] + set expected [expr {$odd**$power}] + + lappend result [expr {$diff == $expected}] + } + set result + } -result {1 1 1 1 1 1 1 1 1} + +test "sum-odd-1.8" "Sum of successive odd 8th powers" \ + -match numbers -body { + set power 8 + + set result {} + + for {set n 1} {$n < 10} {incr n} { + set odd [expr {2*$n-1}] + set sumN [::math::figurate::sum_8th_power_odd $n] + set sumNmin1 [::math::figurate::sum_8th_power_odd [expr {$n-1}]] + set diff [expr {$sumN - $sumNmin1}] + set expected [expr {$odd**$power}] + + lappend result [expr {$diff == $expected}] + } + set result + } -result {1 1 1 1 1 1 1 1 1} + +test "sum-odd-1.9" "Sum of successive odd 9th powers" \ + -match numbers -body { + set power 9 + + set result {} + + for {set n 1} {$n < 10} {incr n} { + set odd [expr {2*$n-1}] + set sumN [::math::figurate::sum_9th_power_odd $n] + set sumNmin1 [::math::figurate::sum_9th_power_odd [expr {$n-1}]] + set diff [expr {$sumN - $sumNmin1}] + set expected [expr {$odd**$power}] + + lappend result [expr {$diff == $expected}] + } + set result + } -result {1 1 1 1 1 1 1 1 1} + +test "sum-odd-1.10" "Sum of successive odd 10th powers" \ + -match numbers -body { + set power 10 + + set result {} + + for {set n 1} {$n < 10} {incr n} { + set odd [expr {2*$n-1}] + set sumN [::math::figurate::sum_10th_power_odd $n] + set sumNmin1 [::math::figurate::sum_10th_power_odd [expr {$n-1}]] + set diff [expr {$sumN - $sumNmin1}] + set expected [expr {$odd**$power}] + + lappend result [expr {$diff == $expected}] + } + set result + } -result {1 1 1 1 1 1 1 1 1} + + +# Values copied from OEIS +# Series start at n = 0 + +test "figurate-1.1" "Oblong numbers (pronic)" \ + -match numbers -body { + set result {} + + for {set n 0} {$n < 10} {incr n} { + lappend result [::math::figurate::oblong $n] + } + set result + } -result {0 2 6 12 20 30 42 56 72 90} + +test "figurate-1.1b" "Oblong numbers (pronic)" \ + -match numbers -body { + set result {} + + for {set n 0} {$n < 10} {incr n} { + lappend result [::math::figurate::pronic $n] + } + set result + } -result {0 2 6 12 20 30 42 56 72 90} + +test "figurate-1.2" "Triangular numbers" \ + -match numbers -body { + set result {} + + for {set n 0} {$n < 10} {incr n} { + lappend result [::math::figurate::triangular $n] + } + set result + } -result {0 1 3 6 10 15 21 28 36 45} + +test "figurate-1.3" "Centered square numbers" \ + -match numbers -body { + set result {} + + for {set n 0} {$n < 10} {incr n} { + lappend result [::math::figurate::centeredSquare $n] + } + set result + } -result {0 1 5 13 25 41 61 85 113 145} + +test "figurate-1.4" "Centered cube numbers" \ + -match numbers -body { + set result {} + + for {set n 0} {$n < 10} {incr n} { + lappend result [::math::figurate::centeredCube $n] + } + set result + } -result {0 1 9 35 91 189 341 559 855 1241} + +test "figurate-1.5" "Centered pentagonal numbers" \ + -match numbers -body { + set result {} + + for {set n 0} {$n < 10} {incr n} { + lappend result [::math::figurate::centeredPentagonal $n] + } + set result + } -result {0 1 6 16 31 51 76 106 141 181} + +test "figurate-1.6" "Centered hexagonal numbers" \ + -match numbers -body { + set result {} + + for {set n 0} {$n < 10} {incr n} { + lappend result [::math::figurate::centeredHexagonal $n] + } + set result + } -result {0 1 7 19 37 61 91 127 169 217} + +test "figurate-1.7" "Decagonal numbers" \ + -match numbers -body { + set result {} + + for {set n 0} {$n < 10} {incr n} { + lappend result [::math::figurate::decagonal $n] + } + set result + } -result {0 1 10 27 52 85 126 175 232 297} + +test "figurate-1.8" "Heptagonal numbers" \ + -match numbers -body { + set result {} + + for {set n 0} {$n < 10} {incr n} { + lappend result [::math::figurate::heptagonal $n] + } + set result + } -result {0 1 7 18 34 55 81 112 148 189} + +test "figurate-1.9" "Hexagonal numbers" \ + -match numbers -body { + set result {} + + for {set n 0} {$n < 10} {incr n} { + lappend result [::math::figurate::hexagonal $n] + } + set result + } -result {0 1 6 15 28 45 66 91 120 153} + +test "figurate-1.10" "Octagonal numbers" \ + -match numbers -body { + set result {} + + for {set n 0} {$n < 10} {incr n} { + lappend result [::math::figurate::octagonal $n] + } + set result + } -result {0 1 8 21 40 65 96 133 176 225} + +# OEIS A00326 - pentagonal numbers +test "figurate-1.10" "Pentagonal numbers" \ + -match numbers -body { + set result {} + + for {set n 0} {$n < 10} {incr n} { + lappend result [::math::figurate::pentagonal $n] + } + set result + } -result {0 1 5 12 22 35 51 70 92 117} + +test "figurate-1.11" "Square pyramidal numbers" \ + -match numbers -body { + set result {} + + for {set n 0} {$n < 10} {incr n} { + lappend result [::math::figurate::squarePyramidal $n] + } + set result + } -result {0 1 5 14 30 55 91 140 204 285} + +test "figurate-1.12" "Tetrahedral numbers" \ + -match numbers -body { + set result {} + + for {set n 0} {$n < 10} {incr n} { + lappend result [::math::figurate::tetrahedral $n] + } + set result + } -result {0 1 4 10 20 35 56 84 120 165} + +test "figurate-1.13" "Pentatope numbers" \ + -match numbers -body { + set result {} + + for {set n 0} {$n < 10} {incr n} { + lappend result [::math::figurate::pentatope $n] + } + set result + } -result {0 1 5 15 35 70 126 210 330 495} + +test "figurate-1.14" "Centered triangular numbers" \ + -match numbers -body { + set result {} + + for {set n 0} {$n < 10} {incr n} { + lappend result [::math::figurate::centeredTriangular $n] + } + set result + } -result {0 1 4 10 19 31 46 64 85 109} + + +# Skipping as trivial: square, cubic, biquadratic + +# End of test cases +testsuiteCleanup diff --git a/vendor/math/filtergen.man b/vendor/math/filtergen.man new file mode 100644 index 00000000..5188c205 --- /dev/null +++ b/vendor/math/filtergen.man @@ -0,0 +1,81 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin math::filters n 0.1] +[keywords digital] +[keywords filtering] +[copyright {2020 by Arjen Markus}] +[moddesc {Tcl Math Library}] +[titledesc {Digital filters}] +[category Mathematics] +[require Tcl 8.6] +[require TclOO] +[require math::filters [opt 0.1]] + +[description] +[para] +The [package math::filters] package implements digital filters, +notably Butterworth low-pass and high-pass filters. The procedures +allow to filter an entire data series as well as filter data one +by one. + + +[section "PROCEDURES"] + +The package defines the following public procedures: + +[list_begin definitions] + +[call [cmd ::math::filters::filterButterworth] [arg lowpass] [arg order] [arg samplefreq] [arg cutofffreq]] + +Determine the coefficients for a Butterworth filter of given order. The coefficients are returned as +a list of the x-coefficients, the y-coefficients and the scale. The formula is (n is the filter order): +[example { + n n + scale * y_k = sum x_(k-i) + sum y_(k-i) + i=0 i=1 +}] + +[list_begin arguments] +[arg_def bool lowpass] Generate a low-pass filter (1) or a high-pass filter (0) +[arg_def integer lowpass] The order of the filter to be generated +[arg_def double samplefreq] Sampling frequency of the data series +[arg_def double cutofffreq] Cut-off frequency for the filter +[list_end] + + +[call [cmd ::math::filters::filter] [arg coeffs] [arg data]] + +Filter the entire data series based on the filter coefficients. + +[list_begin arguments] +[arg_def list coeffs] List of coefficients as generated by [emph filterButterworth] (or in fact any similar list of coefficients) +[arg_def list data] Data to be filtered +[list_end] + + +[call [cmd ::math::filters::filterObj] new [arg coeffs] [arg yinit]] + +Create a filter object. The initial x data are taken as zero. The initial y data can be prescribed. If they are not given, +they are taken as zero as well. + +[list_begin arguments] +[arg_def list coeffs] List of coefficients as generated by [emph filterButterworth] (or in fact any similar list of coefficients) +[arg_def list yinit] (Optional) initial data for the filter result. +[list_end] + + +[call [cmd \$filterObj] filter [arg x]] + +Filter a single value and return the result. + +[list_begin arguments] +[arg_def double x] The value to be filtered +[list_end] + + +[call [cmd \$filterObj] reset] + +Reset the filter object (start anew) + +[list_end] + +[manpage_end] diff --git a/vendor/math/filtergen.tcl b/vendor/math/filtergen.tcl new file mode 100644 index 00000000..0b498874 --- /dev/null +++ b/vendor/math/filtergen.tcl @@ -0,0 +1,250 @@ +# filtergen.tcl -- +# Package for digital filters +# filterButterworth: +# Generate the coefficients for a low-pass or high-pass Butterworth filter +# filter: +# Filter an entire series of data +# filterObject: +# Class to create filters +# +# Derived from: https://www.meme.net.au/butterworth.html +# +# Here is the license notice from this webpage: +# +# @licstart The following is the entire license notice for the +# JavaScript code in this page. +# +# Copyright (C) 2013 Glenn McIntosh +# +# The JavaScript code in this page is free software: you can +# redistribute it and/or modify it under the terms of the GNU +# General Public License (GNU GPL) as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) +# any later version. The code is distributed WITHOUT ANY WARRANTY; +# without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU GPL for more details. +# +# As additional permission under GNU GPL version 3 section 7, you +# may distribute non-source (e.g., minimized or compacted) forms of +# that code without the copy of the GNU GPL normally required by +# section 4, provided you include this license notice and a URL +# through which recipients can access the Corresponding Source. +# +# @licend The above is the entire license notice +# for the JavaScript code in this page. +# +package require Tcl 8.6 +package require TclOO + +namespace eval ::math::filters {} + +# filterButterworth -- +# Generate the coefficients for a low-pass/high-pass Butterworth filter +# +# Arguments: +# lowpass Low-pass if 1, high-pass if 0 +# order Order of the filter +# samplefreq Sample frequency +# cutofffreq Cut-off frequency (3 dB point) +# +# Returns: +# List (nexted list) of coefficients for x and y and the scale factor +# +proc ::math::filters::filterButterworth {lowpass order samplefreq cutofffreq} { + + if { $order <= 0 || ! [string is integer $order] } { + return -code error "The order must be a positive integer" + } + if { $samplefreq <= 0.0 || $cutofffreq <= 0.0 } { + return -code error "The frequencies must be positive" + } + if { $samplefreq < $cutofffreq } { + return -code error "The cutoff frequency must be lower than the sample frequency" + } + + set pi [expr {acos(-1.0)}] + set cutoff [expr {-$cutofffreq / double($samplefreq) * 2.0 * $pi}] + + set yf0 [lrepeat [expr {$order+1}] 0.0] + set yf1 $yf0 + set xf $yf0 + + lset yf0 0 -1.0 + lset yf1 0 0.0 + lset xf 0 1.0 + + set scale 1.0 + set invert [expr {$lowpass == 1? 1.0 : -1.0}] + + for {set i 1} {$i <= $order} {incr i} { + set angle [expr {($i-0.5) / $order * $pi}] + set sinsin [expr {1.0 - sin($cutoff) * sin($angle)}] + set rcof0 [expr {-cos($cutoff) / $sinsin}] + set rcof1 [expr { sin($cutoff) * cos($angle) / $sinsin}] + + lset yf0 $i 0.0 + lset yf1 $i 0.0 + + for {set j $i} {$j > 0} {incr j -1} { + set yf0jm1 [lindex $yf0 [expr {$j-1}]] + set yf1jm1 [lindex $yf1 [expr {$j-1}]] + set yf0j [lindex $yf0 $j] + set yf1j [lindex $yf1 $j] + + lset yf0 $j [expr {$yf0j + $rcof0 * $yf0jm1 + $rcof1 * $yf1jm1}] + lset yf1 $j [expr {$yf1j + $rcof0 * $yf1jm1 - $rcof1 * $yf0jm1}] + } + + set scale [expr {$scale * $sinsin * 2.0 / (1.0 - cos($cutoff) * $invert)}] + set xfim1 [lindex $xf [expr {$i-1}]] + lset xf $i [expr {$xfim1 * $invert * ($order-$i+1)/double($i)}] + } + + set scale [expr {sqrt($scale)}] + + for {set i 1} {$i <= $order} {incr i} { + set yf0i [lindex $yf0 $i] + lset yf0 $i [expr {$yf0i * $scale}] + } + + return [list $xf [lrange $yf0 1 end] $scale] +} + +# filter -- +# Filter the data series based on the given coefficients +# +# Arguments: +# coeff Filter coefficients, as generated by filtergen +# data Data to be filtered +# +# Returns: +# The filtered data +# +# Note: +# The initial part of the filtered data is a list of zeroes +# +proc ::math::filters::filter {coeff data} { + lassign $coeff xcoeff ycoeff scale + + set filtered {} + + set yv [lrepeat [llength $ycoeff] [expr {0.0}]] + + set noxcoeff [llength $xcoeff] + set xcoeff [lreverse $xcoeff] + set ycoeff [lreverse $ycoeff] + + for {set i 0} {$i <= [llength $data]-$noxcoeff} {incr i} { + set xv [lrange $data $i [expr {$i+$noxcoeff-1}]] + + set f [expr {0.0}] + + foreach x $xv c $xcoeff { + set f [expr {$f + $c * $x}] + } + + foreach y $yv c $ycoeff { + set f [expr {$f + $c * $y}] + } + + set f [expr {$f / $scale}] + + lappend filtered $f + + set yv [concat [lrange $yv 1 end] $f] + } + + return $filtered +} + +# filterObject -- +# Create an object that can filter incoming data +# +# Arguments: +# coeff Filter coefficients, as generated by filtergen +# yinit (Optional) initial y-values +# +::oo::class create ::math::filters::filterObject { + variable xcoeff + variable ycoeff + variable yv + variable xv + variable xv_org + variable yv_org + + # + # Constructor: + # - the arguments coeff and, optionally, yinit + # - prepare everything + # + constructor {coeff {yinit {}}} { + variable xcoeff + variable ycoeff + variable scale + variable yv + variable xv + variable yv_org + variable xv_org + + lassign $coeff xcoeff ycoeff scale + + set xcoeff [lreverse $xcoeff] + set ycoeff [lreverse $ycoeff] + + if { $yinit eq {} } { + set yv [lrepeat [llength $ycoeff] [expr {0.0}]] + } else { + if { [llength $yinit] != [llength $ycoeff] } { + return -code error "Length of initial y-values must be equal to the number of y coefficients" + } + set yv $yinit + } + set xv [lrepeat [llength $xcoeff] [expr {0.0}]] + + set xv_org $xv + set yv_org $yv + } + + method filter {x} { + variable xcoeff + variable ycoeff + variable scale + variable yv + variable xv + + set xv [concat [lrange $xv 1 end] $x] + set f [expr {0.0}] + + foreach x $xv c $xcoeff { + set f [expr {$f + $c * $x}] + } + + foreach y $yv c $ycoeff { + set f [expr {$f + $c * $y}] + } + + set f [expr {$f / $scale}] + + set yv [concat [lrange $yv 1 end] $f] + + return $f + } + + method reset {} { + variable yv + variable xv + variable xv_org + variable yv_org + + set xv $xv_org + set yv $yv_org + } +} + +# Publish the package + +namespace eval ::math::filters { + namespace export filterButterworth filter filterObject +} + +package provide math::filters 0.1 diff --git a/vendor/math/filtergen.test b/vendor/math/filtergen.test new file mode 100644 index 00000000..07efa485 --- /dev/null +++ b/vendor/math/filtergen.test @@ -0,0 +1,125 @@ +# -*- tcl -*- +# Tests for filters library. +# +# 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.6 +testsNeedTcltest 1.0 + +support { + useLocal math.tcl math +} +testing { + useLocal filtergen.tcl math::filters +} + +# ------------------------------------------------------------------------- + +proc withFourDecimals {args} { + set res {} + foreach arg $args {lappend res [expr (round(10000*$arg))/10000.0]} + return $res +} + +if { [info commands lmap] eq {} } { + proc lmap {var list body} { + upvar 1 $var _$var + set __$var {} + foreach _$var $list { + lappend __$var [uplevel 1 $body] + } + set __$var + } +} + +# +# Custom matching procedure: +# Expect an accuracy of at least four decimals +# +proc matchNumbers {expected actual} { + set match 1 + foreach a $actual e $expected { + if { [llength $a] == 1 } { + if {abs($a-$e) > 1.0e-4} { + set match 0 + break + } + } else { + set match [matchNumbers $a $e] + } + } + return $match +} + +customMatch numbers matchNumbers + + +# ------------------------------------------------------------------------- + +# Butterworth filter coefficients + +test butterworth-1.1 {low-pass, second order} -match numbers -body { + set coeffs [::math::filters::filterButterworth 1 2 100 20] + set result [concat {*}$coeffs] +} -result {1.0 2.0 1.0 1.78885 -0.94793 4.84093} + +test butterworth-1.2 {high-pass, second order} -match numbers -body { + set coeffs [::math::filters::filterButterworth 0 2 100 20] + set result [concat {*}$coeffs] +} -result {1.0 -2.0 1.0 0.94427 -0.50038 2.55535} + + +# Actually filter data + +# 20 data, second-order filter, so 18 data returned +test filter-1.0 {low-pass, second order, uniform series} -match numbers -body { + set coeffs [::math::filters::filterButterworth 1 2 100 20] + set data [lrepeat 20 1.0] + set filtered [::math::filters::filter $coeffs $data] + set result [list [llength $filtered] [lindex $filtered end]] +} -result {18 1.0} + +test filter-1.1 {low-pass, second order, sine series} -match numbers -body { + set coeffs [::math::filters::filterButterworth 1 2 100 20] + + set twopi [expr {2.0 * acos(-1.0)}] + set period 100 + + set data {} + + for {set i 0} {$i < $period} {incr i} { + lappend data [expr {cos($twopi * ($i/1.0) / double($period))}] + } + + set filtered [lrange [::math::filters::filter $coeffs $data] end-7 end] +} -result {0.845195 0.877086 0.905515 0.930371 0.951555 0.968984 0.982588 0.992315} + +# The object interface + +test filterobj-1.0 {low-pass, second order, sine series} -match numbers -body { + set coeffs [::math::filters::filterButterworth 1 2 100 20] + set filter [::math::filters::filterObject new $coeffs] + + set twopi [expr {2.0 * acos(-1.0)}] + set period 100 + + set data {} + + for {set i 0} {$i < $period} {incr i} { + lappend filtered [$filter filter [expr {cos($twopi * ($i/1.0) / double($period))}]] + } + + set filtered [lrange $filtered end-9 end] +} -result {0.771545 0.809968 0.845195 0.877086 0.905515 0.930371 0.951555 0.968984 0.982588 0.992315} + + +# +# Cleanup +# +testsuiteCleanup diff --git a/vendor/math/fourier.man b/vendor/math/fourier.man new file mode 100644 index 00000000..f08d530f --- /dev/null +++ b/vendor/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 uses the fast +Fourier transform, if applicable, or the ordinary transform to implement +the discrete Fourier transform. It also provides a few simple filter +procedures as an illustration 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 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 ../common-text/feedback.inc] +[manpage_end] diff --git a/vendor/math/fourier.tcl b/vendor/math/fourier.tcl new file mode 100644 index 00000000..bd455ad9 --- /dev/null +++ b/vendor/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/vendor/math/fourier.test b/vendor/math/fourier.test new file mode 100644 index 00000000..7460e298 --- /dev/null +++ b/vendor/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.5 +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/vendor/math/fuzzy.eps.f90 b/vendor/math/fuzzy.eps.f90 new file mode 100644 index 00000000..79867e71 --- /dev/null +++ b/vendor/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 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/vendor/math/fuzzy.man b/vendor/math/fuzzy.man new file mode 100644 index 00000000..ce42aa73 --- /dev/null +++ b/vendor/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 ../common-text/feedback.inc] +[manpage_end] diff --git a/vendor/math/fuzzy.tcl b/vendor/math/fuzzy.tcl new file mode 100644 index 00000000..5b017b52 --- /dev/null +++ b/vendor/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/vendor/math/fuzzy.test b/vendor/math/fuzzy.test new file mode 100644 index 00000000..87163dc2 --- /dev/null +++ b/vendor/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.5 +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/vendor/math/fuzzy.testscript b/vendor/math/fuzzy.testscript new file mode 100644 index 00000000..a27f21fc --- /dev/null +++ b/vendor/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/vendor/math/geometry.tcl b/vendor/math/geometry.tcl new file mode 100644 index 00000000..f528042c --- /dev/null +++ b/vendor/math/geometry.tcl @@ -0,0 +1,1572 @@ +# 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 Tcl 8.5 +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} { + lassign $pa ax ay; lassign $pb bx by + return [list [expr {$ax + $bx}] [expr {$ay + $by}]] +} + +# Vector difference +proc ::math::geometry::- {pa pb} { + lassign $pa ax ay; lassign $pb bx by + return [list [expr {$ax - $bx}] [expr {$ay - $by}]] +} + +# Distance between 2 points +proc ::math::geometry::distance {pa pb} { + lassign $pa ax ay; lassign $pb bx by + return [expr {hypot($bx-$ax,$by-$ay)}] +} + +# Length of a vector +proc ::math::geometry::length {v} { + lassign $v x y + return [expr {hypot($x,$y)}] +} + +# Scaling a vector by a factor +proc ::math::geometry::s* {factor p} { + lassign $p x y + 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 + lassign $p x y + + 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} { + lassign $rect xnw ynw xse yse + return [list [p $xnw $ynw] [p $xse $yse]] +} + +# Construct rectangle from NW and SE corners. +proc ::math::geometry::rect {pa pb} { + lassign $pa ax ay; lassign $pb bx by + return [list $ax $ay $bx $by] +} + +proc ::math::geometry::conjx {p} { + lassign $p x y + return [list [expr {- $x}] $y] +} + +proc ::math::geometry::conjy {p} { + lassign $p x y + return [list $x [expr {- $y}]] +} + +proc ::math::geometry::x {p} { + return [lindex $p 0] +} + +proc ::math::geometry::y {p} { + return [lindex $p 1] +} + +# ::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 = hypot( Bx-Ax, By-Ay ) + # (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 {hypot($Bx-$Ax,$By-$Ay)}] + return [expr {abs(($Ay-$Cy)*($Bx-$Ax)-($Ax-$Cx)*($By-$Ay)) / $L}] + } +} + +# ::math::geometry::findClosestPointOnLine +# +# Return the point on a line which is closest to a given point. +# +# Arguments: +# P a point +# line a line +# +# Results: +# Q the point on the line that has the smallest +# distance to P +# +# Examples: +# - findClosestPointOnLine {5 10} {0 0 10 10} +# Result: 7.5 7.5 +# - findClosestPointOnLine {-10 0} {0 0 10 10} +# Result: -5.0 -5.0 +# +proc ::math::geometry::findClosestPointOnLine {P line} { + return [lindex [findClosestPointOnLineImpl $P $line] 0] +} + +# ::math::geometry::findClosestPointOnLineImpl +# +# PRIVATE FUNCTION USED BY OTHER FUNCTIONS. +# Find the point on a line that is closest to a given point. +# +# Arguments: +# P a point +# line a line defined by points A and B +# +# Results: +# Q the point on the line that has the smallest +# distance to P +# r r has the following meaning: +# r=0 P = A +# r=1 P = B +# r<0 P is on the backward extension of AB +# r>1 P is on the forward extension of AB +# 01} { + return [lengthOfPolyline [concat $P [lrange $linesegment 2 3]]] + } else { + return $distToLine + } +} + +# ::math::geometry::calculateDistanceToLineSegmentImpl +# +# PRIVATE FUNCTION USED BY OTHER FUNCTIONS. +# Find the distance between a point and a line. +# +# Arguments: +# P a point +# linesegment a line segment A->B +# +# Results: +# dist the smallest distance between P and the line +# r r has the following meaning: +# r=0 P = A +# r=1 P = B +# r<0 P is on the backward extension of AB +# r>1 P is on the forward extension of AB +# 0 + # + # | (Ay-Cy)(Bx-Ax)-(Ax-Cx)(By-Ay) | + # dist = --------------------------------- + # L + set Ax [lindex $linesegment 0] + set Ay [lindex $linesegment 1] + set Bx [lindex $linesegment 2] + set By [lindex $linesegment 3] + set Cx [lindex $P 0] + set Cy [lindex $P 1] + if {$Ax==$Bx && $Ay==$By} { + return [list [lengthOfPolyline [concat $P [lrange $linesegment 0 1]]] 0] + } else { + set L [expr {hypot($Bx-$Ax,$By-$Ay)}] + 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 "Inf" + foreach {Bx By} [lassign $polyline Ax Ay] { + set dist [calculateDistanceToLineSegment $P [list $Ax $Ay $Bx $By]] + if {$dist < $minDist} { + set minDist $dist + } + set Ax $Bx; set Ay $By + } + 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"; set closestDistance "Inf" + foreach {Bx By} [lassign $polyline Ax Ay] { + set Q [findClosestPointOnLineSegment $P [list $Ax $Ay $Bx $By]] + set dist [distance $P $Q] + if {$dist<$closestDistance} { + set closestPoint $Q + set closestDistance $dist + } + set Ax $Bx; set Ay $By + } + 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 {x2 y2} [lassign $polyline x1 y1] { + set length [expr {$length + hypot($x1-$x2,$y1-$y2)}] + set x1 $x2; set 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] +#puts ">>Intersect: $lineintersect" + 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 1] + set overlapy [intervalsOverlap $l1y1 $l1y2 $l2y1 $l2y2 1] +#puts ">>Overlap: $overlapx $overlapy" + if {$overlapx || $overlapy} { + return "coincident" + } else { + # If the line segments are adjacent, return the proper end point, otherwise "none" + if { ( $l1x1 == $l2x1 && $l1y1 == $l2y1 ) || ( $l1x1 == $l2x2 && $l1y1 == $l2y2 ) } { + return [list $l1x1 $l1y1] + } + if { ( $l1x2 == $l2x1 && $l1y2 == $l2y1 ) || ( $l1x2 == $l2x2 && $l1y2 == $l2y2 ) } { + return [list $l1x2 $l1y2] + } + 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 {l1x2 l1y2} [lassign $part1 l1x1 l1y1] { + foreach {l2x2 l2y2} [lassign $part2 l2x1 l2y1] { + if {[lineSegmentsIntersect [list $l1x1 $l1y1 $l1x2 $l1y2] \ + [list $l2x1 $l2y1 $l2x2 $l2y2]]} { + # two line segments overlap + return 1 + } + set l2x1 $l2x2; set l2y1 $l2y2 + } + set l1x1 $l1x2; set l1y1 $l1y2 + } + 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} { + + lassign $polygon x y + if { $x != [lindex $polygon end-1] || + $y != [lindex $polygon end] } { + + lappend polygon $x $y + + } + 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 {x2 y2} [lassign $closedPolygon x1 y1] { + if {[calculateDistanceToLineSegment $P [list $x1 $y1 $x2 $y2]]<0.0000001} { + return 0 + } + set x1 $x2; set y1 $y2 + } + + # 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 {x2 y2} [lassign $closedPolygon x1 y1] { + if {[lineSegmentsIntersect $infinityLine [list $x1 $y1 $x2 $y2]]} { + incr noOfIntersections + } + set x1 $x2; set y1 $y2 + } + # 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}] +} + +# See ticket [dc49af96c2] +# Original code found at: https://www.ecse.rpi.edu/~wrf/Research/Short_Notes/pnpoly.html +# Thanks to Christian Gollwitzer, Peter Lewerin and Eduard Zozuly +# Replaced by: +proc ::math::geometry::pointInsidePolygon {point polygon} { + lassign $point testx testy + foreach {x y} $polygon { + lappend vertx $x + lappend verty $y + } + set c 0 + set nvert [llength $vertx] + for {set i 0 ; set j [expr {$nvert-1}]} {$i < $nvert} {set j $i ; incr i} { + if { + (([lindex $verty $i]>$testy) != ([lindex $verty $j]>$testy)) && + ($testx < ([lindex $vertx $j] - [lindex $vertx $i]) * + ($testy - [lindex $verty $i]) / + ([lindex $verty $j] - [lindex $verty $i]) + [lindex $vertx $i]) + } { + set c [expr {!$c}] + } + } + return $c +} + +# ::math::geometry::pointInsidePolygonAlt +# +# Determine if a point is completely inside a polygon. If the point +# touches the polygon, then the point is not complete inside the +# polygon. +# This alternative algorithm works with complex (self-intersecting) +# polygons in a "natural" way. It uses the winding number instead +# of the number of crossings. +# +# See: http://geomalgorithms.com/a03-_inclusion.html +# +# Arguments: +# P a point +# polygon a polygon +# +# Results: +# isinside a boolean saying whether the point is +# completely inside the polygon or not +# + +# Auxiliary procedure: +# > 0 if point 2 left of line through points 0 and 1 +# < 0 if point 2 right of the line +# = 0 if point on the line +# +proc ::math::geometry::LeftOfEdge {x0 y0 x1 y1 x2 y2} { + expr {($x1 - $x0) * ($y2 - $y0) - ($x2 - $x0) * ($y1 - $y0)} +} + +proc ::math::geometry::pointInsidePolygonAlt {point polygon} { + lassign $point testx testy + foreach {x y} $polygon { + lappend vertx $x + lappend verty $y + } + set w 0 + set nvert [llength $vertx] + for {set i 0} {$i < $nvert} {incr i} { + set j [expr {$i+1}] + if { $j == $nvert } { + set j 0 + } + if { [lindex $verty $i] <= $testy } { + if { [lindex $verty $j] > $testy } { + if { [LeftOfEdge [lindex $vertx $i] [lindex $verty $i] [lindex $vertx $j] [lindex $verty $j] $testx $testy] > 0.0 } { + incr w + } + } + } else { + if { [lindex $verty $j] <= $testy } { + if { [LeftOfEdge [lindex $vertx $i] [lindex $verty $i] [lindex $vertx $j] [lindex $verty $j] $testx $testy] < 0.0 } { + incr w -1 + } + } + } + } + return [expr {$w != 0}] +} + +# ::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} { + + # get last pair of the polygon for start: + set b1 [lindex $polygon end-1]; set b2 [lindex $polygon end] + + set area 0.0 + foreach {c1 c2} $polygon { + set area [expr {$area + ($b1*$c2 - $b2*$c1)}] + set b1 $c1 + set b2 $c2 + } + expr {0.5*abs($area)} +} + +# ::math::geometry::inproduct +# +# Determine the inproduct of two vectors +# +# Arguments: +# vector1 first vector +# vector2 second vector +# +# Results: +# inproduct the inproduct +# +proc ::math::geometry::inproduct {vector1 vector2} { + + set inproduct 0.0 + foreach v1 $vector1 v2 $vector2 { + set inproduct [expr {$inproduct + $v1 * $v2}] + } + + return $inproduct +} + +# ::math::geometry::angleBetween +# +# Determine the angle between two vectors (degrees) +# +# Arguments: +# vector1 first vector +# vector2 second vector +# +# Results: +# angle the angle in degrees +# +proc ::math::geometry::angleBetween {vector1 vector2} { + variable todeg + + set inproduct 0.0 + set length1 0.0 + set length2 0.0 + foreach v1 $vector1 v2 $vector2 { + set inproduct [expr {$inproduct + $v1 * $v2}] + set length1 [expr {$length1 + $v1 * $v1}] + set length2 [expr {$length2 + $v2 * $v2}] + } + set angle [expr {acos($inproduct/sqrt($length1 * $length2)) * $todeg}] + + return $angle +} + +# ::math::geometry::areaParallellogram +# +# Determine the area of the parallellogram spanned by two vectors +# +# Arguments: +# vector1 first vector +# vector2 second vector +# +# Results: +# area the area of the parallellogram +# +proc ::math::geometry::areaParallellogram {vector1 vector2} { + + lassign $vector1 x1 y1; lassign $vector2 x2 y2 + + set area [expr {abs($x2 * $y1 - $x1 * $y2}] + + return $area +} + +# ::math::geometry::translate +# +# Translate a polyline over a given vector +# +# Arguments: +# vector Translation vector +# polyline Polyline (or any list of coordinate pairs) +# +# Results: +# newPolyline Translated poyline +# +proc ::math::geometry::translate {vector polyline} { + + set newPolyline $polyline + + lassign $vector xt yt + + set idx 0 + foreach {x y} $polyline { + lset newPolyline $idx [expr {$x + $xt}] + incr idx + lset newPolyline $idx [expr {$y + $yt}] + incr idx + } + + return $newPolyline +} + +# ::math::geometry::rotate +# +# Rotate a polyline over a given angle (degrees) around the origin +# +# Arguments: +# angle rotation angle (degrees) +# polyline polyline (or any list of coordinate pairs) +# +# Results: +# newPolyline rotated polyline +# +# Note: +# rotation is counterclockwise +# +proc ::math::geometry::rotate {angle polyline} { + variable torad + + set angle [expr {$torad * $angle}] + set cosa [expr {cos($angle)}] + set sina [expr {sin($angle)}] + + set newPolyline $polyline + + set idx 0 + foreach {x y} $polyline { + set newx [expr {$cosa * $x - $sina *$y}] + set newy [expr {$sina * $x + $cosa *$y}] + + lset newPolyline $idx $newx + incr idx + lset newPolyline $idx $newy + incr idx + } + + return $newPolyline +} + +# ::math::geometry::reflect +# +# Reflect a polyline in a line through the origin at a given angle to the x-axis +# +# Arguments: +# angle angle of the line of reflection (degrees) +# polyline polyline (or any list of coordinate pairs) +# +# Results: +# newPolyline reflected polyline +# +# Note: +# the angle is used counterclockwise +# +proc ::math::geometry::reflect {angle polyline} { + variable torad + + set angle [expr {2.0 * $torad * $angle}] + set cosa [expr {cos($angle)}] + set sina [expr {sin($angle)}] + + set newPolyline $polyline + + set idx 0 + foreach {x y} $polyline { + set newx [expr {$cosa * $x + $sina *$y}] + set newy [expr {$sina * $x - $cosa *$y}] + + lset newPolyline $idx $newx + incr idx + lset newPolyline $idx $newy + incr idx + } + + return $newPolyline +} + +# ::math::geometry::degToRad +# +# Convert from degrees to radians +# +# Arguments: +# angle angle (degrees) +# +# Results: +# angle angle in radians +# +proc ::math::geometry::degToRad {angle} { + variable torad + + return [expr {$angle * $torad}] +} + +# ::math::geometry::radToDeg +# +# Convert from radians to degrees +# +# Arguments: +# angle angle (radians) +# +# Results: +# angle angle in degrees +# +proc ::math::geometry::radToDeg {angle} { + variable todeg + + return [expr {$angle * $todeg}] +} + +# # ## ### ##### ############# + +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 \ + calculateDistanceToLine findClosestPointOnLine \ + calculateDistanceToLineSegment findClosestPointOnLineSegment \ + calculateDistanceToPolylineSegment findClosestPointOnPolyline lengthOfPolyline \ + movePointInDirection lineSegmentsIntersect findLineSegmentIntersection findLineIntersection \ + polylinesIntersect polylinesBoundingIntersect intervalsOverlap rectanglesOverlap pointInsidePolygon pointInsidePolygonAlt \ + rectangleInsidePolygon areaPolygon translate rotate reflect degToRad radToDeg \ + calculateDistanceToPolyline calculateDistanceToPolygon areaParallellogram angle inproduct angleBetween + +} + +source [file join [file dirname [info script]] geometry_circle.tcl] +source [file join [file dirname [info script]] geometry_ext.tcl] + +package provide math::geometry 1.4.1 diff --git a/vendor/math/geometry.test b/vendor/math/geometry.test new file mode 100644 index 00000000..b0eee35d --- /dev/null +++ b/vendor/math/geometry.test @@ -0,0 +1,1054 @@ +# -*- 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.5 +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 +} + +if { [info commands lmap] eq {} } { + proc lmap {var list body} { + upvar 1 $var _$var + set __$var {} + foreach _$var $list { + lappend __$var [uplevel 1 $body] + } + set __$var + } +} + +# +# Custom matching procedure: +# Expect an accuracy of at least four decimals +# +proc matchNumbers {expected actual} { + set match 1 + foreach a $actual e $expected { + if { [llength $a] == 1 } { + if {abs($a-$e) > 1.0e-4} { + set match 0 + break + } + } else { + set match [matchNumbers $a $e] + } + } + return $match +} + +customMatch numbers matchNumbers + + +# ------------------------------------------------------------------------- + +### +# 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 +### + +# TODO! + + +### +# 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 +test geometry-7.2 {geometry::lineSegmentsIntersect, touching segments, in line with each other} { + ::math::geometry::lineSegmentsIntersect {0 0 10 10} {10 10 15 15} +} 1 +test geometry-7.3 {geometry::lineSegmentsIntersect, touching segments, perpendicular to each other} { + ::math::geometry::lineSegmentsIntersect {0 0 10 10} {10 10 0 20} +} 1 +test geometry-7.4 {geometry::lineSegmentsIntersect, slightly overlapping segments} { + ::math::geometry::lineSegmentsIntersect {0 0 10.001 10.001} {10 10 15 15} +} 1 +test geometry-7.5 {geometry::lineSegmentsIntersect, almost touching segments, perpendicular to each other} { + ::math::geometry::lineSegmentsIntersect {0 0 10 10} {10.0001 10 0 20} +} 0 + + +### +# polylinesIntersect +### +test geometry-8.1 {geometry::polylinesIntersect, } { + ::math::geometry::polylinesIntersect {0 0 0 2 10 10} {0 10 2 10 10 0} +} 1 + + +test intersectionPolylines-0.1 {} -body { + eval withFourDecimals [::math::geometry::intersectionPolylines {0 0 10 10 10 20} {0 10 10 0}] +} -result {5.0 5.0} +test intersectionPolylines-0.2 {} -body { + eval withFourDecimals [::math::geometry::intersectionPolylines {0 0 10 10 10 20} {5 4 10 4}] +} -result {} + + +### +# 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" + +test geometry-10.7 {geometry::findLineSegmentIntersection, touching segments, in line with each other} { + list [::math::geometry::findLineSegmentIntersection {0 0 10 10} {10 10 15 15}] \ + [::math::geometry::findLineSegmentIntersection {10 10 0 0} {10 10 15 15}] \ + [::math::geometry::findLineSegmentIntersection {0 0 10 10} {15 15 10 10}] \ + [::math::geometry::findLineSegmentIntersection {10 10 0 0} {15 15 10 10}] +} {{10 10} {10 10} {10 10} {10 10}} + + +### +# 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 + +test geometry-12.10 {geometry::angle, point as argument} -body { + withFourDecimals [::math::geometry::angle {10 10}] +} -result {45.0} + +test geometry-12.11 {from direction to angle} -body { + withFourDecimals [::math::geometry::angle [::math::geometry::direction 45]] +} -result {45.0} +test geometry-12.12 {from angle to direction} -body { + withFourDecimals {*}[::math::geometry::direction [::math::geometry::angle {10 10}]] +} -result {0.7071 0.7071} + + + +### +# 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 + +### +# overlapBBox +### +test overlapBBox-0.1 {} -body { + ::math::geometry::overlapBBox {0 0 20 20} {10 10 30 30} 0 +} -result 1 +test overlapBBox-0.2 {} -body { + ::math::geometry::overlapBBox {0 0 20 20} {10 10 30 30} 1 +} -result 1 +test overlapBBox-0.3 {} -body { + ::math::geometry::overlapBBox {0 0 20 20} {20 20 40 40} 0 +} -result 1 +test overlapBBox-0.4 {} -body { + ::math::geometry::overlapBBox {0 0 20 20} {20 20 40 40} 1 +} -result 0 +test overlapBBox-0.5 {} -body { + ::math::geometry::overlapBBox {0 0 20 20} {30 30 50 50} 1 +} -result 0 +test overlapBBox-0.6 {} -body { + ::math::geometry::overlapBBox {0 0 40 40} {10 10 30 30} 1 +} -result 1 +test overlapBBox-0.7 {} -body { + ::math::geometry::overlapBBox {10 10 30 30} {0 0 40 40} 1 +} -result 1 +test overlapBBox-1.0 {} -body { +::math::geometry::overlapBBox \ + {77.10546891284076 105.79193282874378 103.04804415195639 132.87051244459752 128.9906192099546 159.9490922327779 154.93319426795279 187.0276720209583} \ + {198.60216689249415 185.37236717607064 217.34733289655512 230.62720117200968} +} -result 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 +# +# Note: outcome changed, because of ticket dc49af96c2 +# This is an edge case anyway +# +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} +} 1 +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 +test geometry-15.14 {geometry::pointInsidePolygon, point well outside polygon, negative coordinates, ticket dc49af96c2} { + math::geometry::pointInsidePolygon {838 456} {-764 -677 -668 -1341 -124 -797 -508 -406} +} 0 +test geometry-15.15 {geometry::pointInsidePolygon, point well outside polygons, mixture of negative nd positive coordinates, ticket dc49af96c2} { + set polygons { + "-764 -677 -668 -1341 -124 -797 -508 -406" + "764 -677 668 -1341 124 -797 508 -406" + "-764 677 -668 1341 -124 797 -508 406" + "764 677 668 1341 124 797 508 406" + } + + set point "838 456" + + return [lmap polygon $polygons {::math::geometry::pointInsidePolygon $point $polygon}] +} {0 0 0 0} +test geometry-15.16 {geometry::pointInsidePolygon, point on boundary of adjacent polygons} { + # Points on the edge should belong to exactly one polygon + set polygons { + "0 0 0 100 100 100 100 0" + "0 0 0 100 -100 100 -100 0" + } + + set point "0 50" + + return [lmap polygon $polygons {::math::geometry::pointInsidePolygon $point $polygon}] +} {1 0} +test geometry-15.17 {geometry::pointInsidePolygon, point on boundary of adjacent polygons, second test} { + # Points on the edge should belong to exactly one polygon + set polygons { + "0 0 0 100 100 100 100 0" + "0 0 0 -100 100 -100 100 0" + } + + set point "50 0" + + return [lmap polygon $polygons {::math::geometry::pointInsidePolygon $point $polygon}] +} {1 0} +test geometry-15.18 {geometry::pointInsidePolygonAlt, point well outside polygons, mixture of negative nd positive coordinates, ticket dc49af96c2} { + set polygons { + "-764 -677 -668 -1341 -124 -797 -508 -406" + "764 -677 668 -1341 124 -797 508 -406" + "-764 677 -668 1341 -124 797 -508 406" + "764 677 668 1341 124 797 508 406" + } + + set point "838 456" + + return [lmap polygon $polygons {::math::geometry::pointInsidePolygonAlt $point $polygon}] +} {0 0 0 0} +test geometry-15.19 {geometry::pointInsidePolygonAlt, point in self-intersection polygon} { + # The winding number algorithm should tell the point is inside the polygon, the crossing number + # algorithm will report it to be outside + set polygon {-50 0 50 0 50 50 -25 10 25 10 -50 50} + + set point "0 12" + + return [list [::math::geometry::pointInsidePolygonAlt $point $polygon] \ + [::math::geometry::pointInsidePolygon $point $polygon]] +} {1 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} +} southwest + +test octant-0.1 {} -body { + ::math::geometry::octant [list 1 0] +} -result "east" +test octant-0.2 {} -body { + ::math::geometry::octant [list 1 1] +} -result "northeast" +test octant-0.3 {} -body { + ::math::geometry::octant [list 0 1] +} -result "north" +test octant-0.4 {} -body { + ::math::geometry::octant [list -1 1] +} -result "northwest" +test octant-0.5 {} -body { + ::math::geometry::octant [list -1 0] +} -result "west" +test octant-0.6 {} -body { + ::math::geometry::octant [list -1 -1] +} -result "southwest" +test octant-0.7 {} -body { + ::math::geometry::octant [list 0 -1] +} -result "south" +test octant-0.8 {} -body { + ::math::geometry::octant [list 1 -1] +} -result "southeast" + + + +### +# calculateDistanceToPolygon +### +test geometry-18.1 {geometry::calculateDistanceToPolygon, non-closed polygon, point on polygon} { + 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 + + +### +# transformations +### +test geometry-19.1 {geometry::translate over (1,-1)} { + withFourDecimals {*}[::math::geometry::translate {1.0 -1.0} {0.0 0.0 1.0 1.0}] +} {1.0 -1.0 2.0 0.0} + +test geometry-19.2 {geometry::rotate over 90 degrees} { + withFourDecimals {*}[::math::geometry::rotate 90.0 {0.0 0.0 1.0 1.0 0.0 1.0}] +} {0.0 0.0 -1.0 1.0 -1.0 0.0} + +test geometry-19.3 {geometry::reflect in x-axis} { + withFourDecimals {*}[::math::geometry::reflect 180.0 {0.0 0.0 1.0 1.0 0.0 1.0}] +} {0.0 0.0 1.0 -1.0 0.0 -1.0} + +test geometry-19.4 {geometry::reflect in y-axis} { + withFourDecimals {*}[::math::geometry::reflect 90.0 {0.0 0.0 1.0 1.0 0.0 1.0}] +} {0.0 0.0 -1.0 1.0 0.0 1.0} + +test geometry-19.5 {geometry::radToDeg} { + ::math::geometry::radToDeg [expr {acos(-1.0)}] +} 180.0 + +test geometry-19.6 {geometry::degToRad} { + ::math::geometry::degToRad 180.0 +} [expr {acos(-1.0)}] + + +test rotateAbout-0.1 {rotate (poly)line about an arbitrary point, 90 degrees} -body { + withFourDecimals {*}[::math::geometry::rotateAbout {10 10} 90 {20 0 20 20}] +} -result {20.0 20.0 0.0 20.0} +test rotateAbout-0.2 {rotate (polyline) about an arbitrary point, 180 degrees} -body { + withFourDecimals {*}[::math::geometry::rotateAbout {10 10} 180 {20 0 20 20}] +} -result {0.0 20.0 0.0 0.0} + + +### +# areaPolygon +### +test geometry-20.1 {geometry::areaPolygon, closed polygon} { + eval withFourDecimals [::math::geometry::areaPolygon {-10 -10 10 -10 10 10 -10 10 -10 -10}] +} 400.0 + +test geometry-20.2 {geometry::areaPolygon, non-closed polygon} { + eval withFourDecimals [::math::geometry::areaPolygon {-10 -10 10 -10 10 10 -10 10}] +} 400.0 + +test geometry-20.3 {geometry::areaPolygon, closed triangle} { + eval withFourDecimals [::math::geometry::areaPolygon {-10 -10 10 -10 10 10 -10 -10}] +} 200.0 + +test geometry-20.4 {geometry::areaPolygon, open triangle} { + eval withFourDecimals [::math::geometry::areaPolygon {-10 -10 10 -10 10 10}] +} 200.0 + +test geometry-20.4 {geometry::areaPolygon, self-intersecting polygon} { + eval withFourDecimals [::math::geometry::areaPolygon {-10 -10 10 -10 -10 10 10 10 -10 -10}] +} 0.0 + + +## +# areaPolygon +## + +test geometry-20.0 {geometry::areaPolygon} { + math::geometry::areaPolygon {-10 -10 10 -10 10 10 -10 10} +} 400.0 + + +## +# circle procedures +## + +# circle construction +test circle-0.1 {construct circle} -body { + set circle [::math::geometry::circle {1.0 2.0} 3.0] +} -result {1.0 2.0 3.0} + +test circle-0.2 {construct circle from two points} -body { + set circle [::math::geometry::circleTwoPoints {1.0 0.0} {-1.0 0.0}] +} -result {0.0 0.0 1.0} + +test circle-0.3 {construct circle from two points (2)} -body { + set circle [::math::geometry::circleTwoPoints {0.0 1.0} {0.0 -1.0}] +} -result {0.0 0.0 1.0} + +# points inside/outside circles +test circle-1.0 {point in circle} -body { + set circle [::math::geometry::circle {1.0 0.0} 3.0] + set point [::math::geometry::p 0.0 0.0] + + ::math::geometry::pointInsideCircle $point $circle +} -result 1 + +test circle-1.1 {point outside circle} -body { + set circle [::math::geometry::circle {1.0 0.0} 3.0] + set point [::math::geometry::p 5.0 0.0] + + ::math::geometry::pointInsideCircle $point $circle +} -result 0 + +test circle-1.2 {point on circle edge} -body { + set circle [::math::geometry::circle {1.0 0.0} 3.0] + set point [::math::geometry::p -2.0 0.0] + + ::math::geometry::pointInsideCircle $point $circle +} -result 1 + +# lines intersecting circles +test circle-2.0 {line through circle} -body { + set circle [::math::geometry::circle {1.0 0.0} 3.0] + set line {0.0 -10.0 0.0 10.0} + + ::math::geometry::lineIntersectsCircle $line $circle +} -result 1 + +test circle-2.1 {line not through circle} -body { + set circle [::math::geometry::circle {1.0 0.0} 3.0] + set line {10.0 -10.0 10.0 10.0} + + ::math::geometry::lineIntersectsCircle $line $circle +} -result 0 + +test circle-2.2 {line on edge of circle} -body { + set circle [::math::geometry::circle {1.0 0.0} 3.0] + set line {-2.0 -10.0 -2.0 10.0} + + ::math::geometry::lineIntersectsCircle $line $circle +} -result 1 + +# line segment intersecting circle +test circle-3.0 {line segment intersecting circle} -body { + set circle [::math::geometry::circle {1.0 0.0} 3.0] + set line {0.0 -10.0 0.0 10.0} + + ::math::geometry::lineSegmentIntersectsCircle $line $circle +} -result 1 + +test circle-3.1 {line segment outside circle} -body { + set circle [::math::geometry::circle {1.0 0.0} 3.0] + set line {0.0 5.0 0.0 10.0} + + ::math::geometry::lineSegmentIntersectsCircle $line $circle +} -result 0 + +test circle-3.2 {line segment completely inside circle} -body { + set circle [::math::geometry::circle {1.0 0.0} 3.0] + set line {1.0 0.0 1.0 1.0} + + ::math::geometry::lineSegmentIntersectsCircle $line $circle +} -result 0 + +test circle-3.3 {line segment touching circle} -body { + set circle [::math::geometry::circle {1.0 0.0} 3.0] + set line {-2.0 0.0 -5.0 0.0} + + ::math::geometry::lineIntersectsCircle $line $circle +} -result 1 + +# +# Private procedures +# + +test circlePrivate-1.1 {intersect vertical line with circle (two points)} -body { + set circle [::math::geometry::circle {0.0 0.0} 5.0] + set line {3.0 4.0 3.0 -4.0} + + ::math::geometry::IntersectionVerticalLineCircle $line $circle +} -result {{3.0 4.0} {3.0 -4.0}} + +test circlePrivate-1.2 {intersect vertical line with circle (two points, version 2)} -body { + set circle [::math::geometry::circle {0.0 0.0} 5.0] + set line {3.0 40.0 3.0 -40.0} + + ::math::geometry::IntersectionVerticalLineCircle $line $circle +} -result {{3.0 4.0} {3.0 -4.0}} + +test circlePrivate-1.2 {intersect vertical line with circle (one point)} -body { + set circle [::math::geometry::circle {0.0 0.0} 5.0] + set line {5.0 40.0 5.0 -40.0} + + ::math::geometry::IntersectionVerticalLineCircle $line $circle +} -result {5.0 0.0} + +test circlePrivate-1.2 {intersect vertical line with circle (no points)} -body { + set circle [::math::geometry::circle {0.0 0.0} 5.0] + set line {15.0 40.0 15.0 -40.0} + + ::math::geometry::IntersectionVerticalLineCircle $line $circle +} -result {} + +# Coordinates: sqrt(3)/2 +test circlePrivate-2.1 {intersect two circles (two points)} -body { + set circle1 [::math::geometry::circle {0.0 0.0} 1.0] + set circle2 [::math::geometry::circle {1.0 0.0} 1.0] + + concat {*}[::math::geometry::IntersectionCircleCircle $circle1 $circle2] +} -result {0.5 0.8660254 0.5 -0.8660254} -match numbers + +test circlePrivate-2.2 {intersect two circles (one point right)} -body { + set circle1 [::math::geometry::circle {0.0 0.0} 5.0] + set circle2 [::math::geometry::circle {10.0 0.0} 5.0] + + ::math::geometry::IntersectionCircleCircle $circle1 $circle2 +} -result {5.0 0.0} + +test circlePrivate-2.3 {intersect two circles (one point left)} -body { + set circle1 [::math::geometry::circle {0.0 0.0} 5.0] + set circle2 [::math::geometry::circle {5.0 0.0} 10.0] + + ::math::geometry::IntersectionCircleCircle $circle1 $circle2 +} -result {-5.0 0.0} + +test circlePrivate-2.4 {intersect two circles (no points)} -body { + set circle1 [::math::geometry::circle {0.0 0.0} 5.0] + set circle2 [::math::geometry::circle {15.0 0.0} 5.0] + + ::math::geometry::IntersectionCircleCircle $circle1 $circle2 +} -result {} + +test circlePrivate-2.4 {intersect two concentric circles} -body { + set circle1 [::math::geometry::circle {0.0 0.0} 5.0] + set circle2 [::math::geometry::circle {0.0 0.0} 7.0] + + ::math::geometry::IntersectionCircleCircle $circle1 $circle2 +} -result {} + +# +# Intersection procedures +# +test circleIntersect-1.1 {intersect a vertical line and a circle (two points)} -body { + set line {0.0 0.0 0.0 5.0} + set circle [::math::geometry::circle {0.0 0.0} 7.0] + + concat {*}[::math::geometry::intersectionLineWithCircle $line $circle] +} -result {0.0 7.0 0.0 -7.0} -match numbers + +# Coordinates in answer: 7*sqrt(2)/2 +test circleIntersect-1.2 {intersect a diagonal line and a circle (two points)} -body { + set line {-5.0 -5.0 5.0 5.0} + set circle [::math::geometry::circle {0.0 0.0} 7.0] + + concat {*}[::math::geometry::intersectionLineWithCircle $line $circle] +} -result {4.94975 4.94975 -4.94975 -4.94975} -match numbers + +test circleIntersect-1.3 {intersect a horizontal line and a circle (one point)} -body { + set line {-5.0 5.0 5.0 5.0} + set circle [::math::geometry::circle {0.0 0.0} 5.0] + + concat {*}[::math::geometry::intersectionLineWithCircle $line $circle] +} -result {0.0 5.0} -match numbers + + +test circleIntersect-2.1 {intersect two circles, arranged horizontally (two points)} -body { + set circle1 [::math::geometry::circle {0.0 0.0} 1.0] + set circle2 [::math::geometry::circle {1.0 0.0} 1.0] + + concat {*}[::math::geometry::intersectionCircleWithCircle $circle1 $circle2] +} -result {0.5 0.8660254 0.5 -0.8660254} -match numbers + +test circleIntersect-2.2 {intersect two circles, arranged vertically (two points)} -body { + set circle1 [::math::geometry::circle {0.0 0.0} 1.0] + set circle2 [::math::geometry::circle {0.0 1.0} 1.0] + + concat {*}[::math::geometry::intersectionCircleWithCircle $circle1 $circle2] +} -result {-0.8660254 0.5 0.8660254 0.5} -match numbers + + +test circleTangent-1.1 {tangent lines to a circle} -body { + set circle [::math::geometry::circle {0.0 0.0} 1.0] + set point [::math::geometry::p 1.0 1.0] + + concat {*}[::math::geometry::tangentLinesToCircle $point $circle] +} -result {1.0 1.0 0.0 1.0 1.0 1.0 1.0 0.0} -match numbers + +test circleTangent-1.2 {tangent lines to a circle - point at circumference} -body { + set circle [::math::geometry::circle {0.0 0.0} 1.0] + set point [::math::geometry::p 0.0 1.0] + + concat {*}[::math::geometry::tangentLinesToCircle $point $circle] +} -result {0.0 1.0 1.0 1.0} -match numbers + +test circleTangent-1.3 {tangent lines to a circle - point inside the circle} -body { + set circle [::math::geometry::circle {0.0 0.0} 1.0] + set point [::math::geometry::p 0.5 0.5] + + concat {*}[::math::geometry::tangentLinesToCircle $point $circle] +} -result {} -match numbers + + +test intersectionSegmentCircle-0.1 {} -body { + ::math::geometry::intersectionSegmentCircle \ + {0 0 10 10} \ + {10 10 20} +} -result {} +test intersectionSegmentCircle-0.2 {} -body { + ::math::geometry::intersectionSegmentCircle \ + {0 0 10 10} \ + {10 10 10} +} -result {{2.9289321881345254 2.9289321881345254}} +test intersectionSegmentCircle-1.1 {} -body { + ::math::geometry::intersectionSegmentCircle \ + {332.42657091861946 335.1149986982706 129.2024714436513 114.43189293419738} \ + {94.14012946396178 76.3573401345067 64} +} -result {{137.49433961735286 123.43613007196794}} + + +test intersectionPolylineCircle-0.1 {} -body { + ::math::geometry::intersectionPolylineCircle \ + {-0.7222568045061166 24.55619398118256 25.22031843460951 51.6347735970363 51.16289367372514 78.71335321289004 77.10546891284076 105.79193282874378 103.04804415195639 132.87051244459752 128.9906192099546 159.9490922327779 154.93319426795279 187.0276720209583 180.875769325951 214.1062518091387 206.8183443839492 241.1848315973191 232.76091962306484 268.26341121317284 258.7034948621805 295.3419908290266 284.6460701012961 322.4205704448803 310.58864534041174 349.49915006073405 319.11140055170637 358.6440572586041 327.634155763001 367.7889644564742 336.1569109742956 376.9338716543443 344.67966618559024 386.0787788522143 353.2024215780023 395.2236858777577 361.7251769704144 404.36859290330113 370.2479323628265 413.51349992884457 378.77068775523855 422.65840695438794 387.2934429665332 431.803314152258 395.8161981778278 440.94822135012805 404.3389533891225 450.09312854799816 412.8617086004171 459.2380357458682} \ + {153.34733289655512 185.37236717607064 64} all +} -result {{109.072261 139.158538} {197.622404 231.586197}} -match numbers +test intersectionPolylineCircle-0.2 {} -body { + ::math::geometry::intersectionPolylineCircle \ + {435.55404176974764 444.05134367022987 401.17821790828214 407.7392289062232 366.80239478008497 371.42711346227725 332.42657091861946 335.1149986982706 230.81452154776954 224.77344547626427 129.2024714436513 114.43189293419738 27.590422072801346 4.090339712191053} \ + {94.14012946396178 76.3573401345067 64} all +} -result {{137.494347 123.436124} {50.785914 29.278555}} -match numbers + + +# +# cathetus point +# +test cathetusPoint-0.1 {cathetus point, point a} -body { + withFourDecimals {*}[::math::geometry::cathetusPoint {1 1} {5 2} 3] +} -result {3.6168 -0.4671} +test cathetusPoint-02 {cathetus point, point b} -body { + withFourDecimals {*}[::math::geometry::cathetusPoint {1 1} {5 2} 3 b] +} -result {3.3815 -0.5259} +test cathetusPoint-0.3 {no cathetus, outside range} -body { + withFourDecimals {*}[::math::geometry::cathetusPoint {1 1} {5 2} 9 b] +} -result {} + + +# +# parallel line +# +test parallel-0.1 {parallel line, default side} -body { + withFourDecimals {*}[::math::geometry::parallel {1 1 5 2} 3] +} -result {1.7276 -1.9104 5.7276 -0.9104} +test parallel-0.2 {parallel line, lefthand side} -body { + withFourDecimals {*}[::math::geometry::parallel {1 1 5 2} 3 right] +} -result {1.7276 -1.9104 5.7276 -0.9104} +test parallel-0.3 {parallel line, righthand side} -body { + withFourDecimals {*}[::math::geometry::parallel {1 1 5 2} 3 left] +} -result {0.2724 3.9104 4.2724 4.9104} + + +### +testsuiteCleanup diff --git a/vendor/math/geometry_circle.tcl b/vendor/math/geometry_circle.tcl new file mode 100644 index 00000000..5f4b46a7 --- /dev/null +++ b/vendor/math/geometry_circle.tcl @@ -0,0 +1,382 @@ +# geometry_circle.tcl -- +# +# Geometry functions with an emphasis on circles +# +# Copyright (c) 2018 Arjen Markus +# +# Part of the math::geometry package +# + +package require Tcl 8.5 +package require math + +namespace eval ::math::geometry { + namespace export circle circleTwoPoints \ + pointInsideCircle lineIntersectsCircle lineSegmentIntersectsCircle \ + intersectionLineWithCircle intersectionCircleWithCircle tangentLinesToCircle \ + + + variable margin 1.0e-10 +} + +# circles: +# List of three numbers, the first two are the x and y coordinates of the +# centre, the third is the radius +# + +# circle -- +# Return a list of numbers representing a circle +# +# Arguments: +# point Coordinates of the centre +# radius Radius of the circle +# +# Returns: +# Three-element list +# +proc ::math::geometry::circle {point radius} { + if { [llength $point] != 2 } { + return -code error "The first argument must be a point" + } + if { [llength $radius] != 1 } { + return -code error "The second argument must be a single value" + } + + return [concat $point $radius] +} + +# circleTwoPoints -- +# Construct a circle from two points - they appear on the circumference +# +# Arguments: +# point1 Coordinates of one point +# point2 Coordinates of the second point +# +# Returns: +# Three-element list +# +proc ::math::geometry::circleTwoPoints {point1 point2} { + set centre [s* 0.5 [+ $point1 $point2]] + set radius [expr {[distance $point1 $point2] * 0.5}] + + + return [concat $centre $radius] +} + +# pointInsideCircle -- +# Return whether the given point lies in the circle or not +# +# Arguments: +# point Point to be checked +# circle Circle possibly containing the point +# +# Returns: +# 1 if the point lies in or on the circle +# 0 if not +# +proc ::math::geometry::pointInsideCircle {point circle} { + set centre [lrange $circle 0 1] + set radius [lindex $circle end] + + if { [distance $point $centre] <= $radius } { + return 1 + } else { + return 0 + } +} + +# lineIntersectsCircle -- +# Return whether the given (infinite) line intersects the circle or not +# +# Arguments: +# line Infinite line to be checked +# circle Circle to be checked +# +# Returns: +# 1 if the line intersects the circle or is tangent to it +# 0 if not +# +proc ::math::geometry::lineIntersectsCircle {line circle} { + set centre [lrange $circle 0 1] + set radius [lindex $circle end] + + if { [calculateDistanceToLine $centre $line] <= $radius } { + return 1 + } else { + return 0 + } +} + +# lineSegmentIntersectsCircle -- +# Return whether the given line segment intersects the circle or not +# +# Arguments: +# line Line segment to be checked +# circle Circle to be checked +# +# Returns: +# 1 if the line segment intersects the circle or is tangent to it +# 0 if not +# +proc ::math::geometry::lineSegmentIntersectsCircle {line circle} { + set centre [lrange $circle 0 1] + set radius [lindex $circle end] + + if { [calculateDistanceToLineSegment $centre $line] <= $radius } { + # + # Check that not both end points are inside the circle + # + set point1 [lrange $line 0 1] + set point2 [lrange $line 2 3] + + set inside1 [pointInsideCircle $point1 $circle] + set inside2 [pointInsideCircle $point2 $circle] + + return [expr {$inside1+$inside2 <= 1 ? 1 : 0}] + } else { + return 0 + } +} + +# IntersectionVerticallineCircle -- +# Calculate the intersection points of a vertical line and a circle +# +# Arguments: +# line Vertical line right of y-axis +# circle Circle with centre at (0,0) +# +# Returns: +# Zero, one or two points - the intersection points +# +# Note: +# The procedure is easiest when using a horizontal or vertical +# line and a circle with centre (0,0). To be used in combination +# with suitable transformations. +# +proc ::math::geometry::IntersectionVerticalLineCircle {line circle} { + set radius [lindex $circle end] + set xval [lindex $line 0] + + if { $xval > $radius } { + return {} + } elseif { $xval == $radius } { + return [list $radius 0.0] + } + + set yval [expr {sqrt($radius**2 - $xval**2)}] + + return [list [list $xval $yval] [list $xval [expr {-$yval}]]] +} + +# IntersectionCircleCircle -- +# Calculate the intersection points of two circles +# +# Arguments: +# circle Circle with centre at (0,0) +# circle1 Circle with centre on positive x-axis +# +# Returns: +# Zero, one or two points - the intersection points +# +# Note: +# The procedure is easiest when using a circle with centre (0,0) +# and the other with the centre on an axis. To be used in combination +# with suitable transformations. +# +# Note: +# The situation of two identical circles is not handled +# +proc ::math::geometry::IntersectionCircleCircle {circle1 circle2} { + set radius1 [lindex $circle1 end] + set xval [lindex $circle2 0] + set radius2 [lindex $circle2 end] + + if { $xval - $radius2 > $radius1 } { + return {} + } elseif { $xval - $radius2 == $radius1 } { + return [list $radius1 0.0] + } elseif { $xval - $radius2 == -$radius1 } { + return [list -$radius1 0.0] + } else { + # One circle inside the other circle + if { $radius2 > $radius1 } { + if { $xval - $radius2 < -$radius1 } { + return {} + } + } else { + if { $xval + $radius2 < $radius1 } { + return {} + } + } + } + + set b [expr {0.5 * ($xval + ($radius1**2 - $radius2**2)/$xval) }] + + set yval [expr {sqrt($radius1**2 - $b**2)}] + + return [list [list $b $yval] [list $b [expr {-$yval}]]] +} + +# intersectionLineWithCircle -- +# Determine the points of intersection between a line and a circle +# +# Arguments: +# line Line in question +# circle Circle in question +# +# Returns: +# Zero, one or two points - the intersection points +# +# Note: +# Shift and rotate the line and circle first, then determine the +# intersection and transform back. +# +proc ::math::geometry::intersectionLineWithCircle {line circle} { + variable margin + + set centre [lrange $circle 0 1] + set radius [lindex $circle end] + + set midpoint [findClosestPointOnLine $centre $line] + set distance [distance $midpoint $centre] + + if { $distance > $margin*$radius } { ;# Rather arbitrary margin + set vector [s* [expr {1.0/$distance}] [- $midpoint $centre]] + } else { + lassign $line x1 y1 x2 y2 + set vector [list [expr {$y2-$y1}] [expr {$x1-$x2}]] + set distance2 [length $vector] + set vector [s* [expr {1.0/$distance2}] $vector] + } + + set newline [list $distance [expr {1.0+$radius}] $distance [expr {-1.0-$radius}]] + set intersection [IntersectionVerticalLineCircle $newline $circle] + + set newIntersection {} + lassign $vector vx vy + lassign $centre cx cy + if { [llength [lindex $intersection 0]] == 1 } { + set intersection [list $intersection] + } + foreach xy $intersection { + lassign $xy x y + + set xn [expr {$vx * $x - $vy * $y + $cx}] + set yn [expr {$vy * $x + $vx * $y + $cy}] + + lappend newIntersection [list $xn $yn] + } + + return $newIntersection +} + +# intersectionCircleWithCircle -- +# Determine the points of intersection between two circles +# +# Arguments: +# circle1 First circle +# circle2 Second circle +# +# Returns: +# Zero, one or two points - the intersection points +# +# Note: +# Shift and rotate the circles first, then determine the +# intersection and transform back. +# +proc ::math::geometry::intersectionCircleWithCircle {circle1 circle2} { + variable margin + + set centre1 [lrange $circle1 0 1] + set radius1 [lindex $circle1 end] + set centre2 [lrange $circle2 0 1] + set radius2 [lindex $circle2 end] + + set distance [distance $centre1 $centre2] + + if { $distance > 0.5*$margin*($radius1+$radius2) } { ;# Rather arbitrary margin + set vector [s* [expr {1.0/$distance}] [- $centre2 $centre1]] + } else { + return {} ;# Bit of a hack: either the circles are concentric and have different + # radii - no intersection - or they are identical, then we should + # return the complete circle, but we don't do that ... + } + + set newcircle [list $distance 0.0 $radius2] + set intersection [IntersectionCircleCircle $circle1 $newcircle] + + set newIntersection {} + lassign $vector vx vy + lassign $centre1 cx cy + if { [llength [lindex $intersection 0]] == 1 } { + set intersection [list $intersection] + } + foreach xy $intersection { + lassign $xy x y + + set xn [expr {$vx * $x - $vy * $y + $cx}] + set yn [expr {$vy * $x + $vx * $y + $cy}] + + lappend newIntersection [list $xn $yn] + } + + return $newIntersection +} + +# tangentLinesToCircle -- +# Determine the tangents from a point to a circle +# +# Arguments: +# point Point in question +# circle Second circle +# +# Returns: +# Zero, one or two points - the intersection points +# +# Note: +# Shift and rotate the point and circle first, then determine the +# intersection and transform back. +# +proc ::math::geometry::tangentLinesToCircle {point circle} { + variable margin + + set centre [lrange $circle 0 1] + set radius [lindex $circle end] + + set distance [distance $centre $point] + + if { $distance < $radius } { + return {} + } else { + set vector [- $point $centre] + set vector [s* [expr {1.0/$distance}] [- $point $centre]] + + if { abs($distance - $radius) < $margin*$radius } { + lassign $vector vx vy + return [list [concat $point [+ $point [list $vy [expr {-$vx}]]]]] + # The two tangent lines coincide + } + } + + set halfdistance [expr {$distance / 2.0}] + set newcircle [list $halfdistance 0.0 $halfdistance] + set intersection [IntersectionCircleCircle $circle $newcircle] + + set newIntersection {} + lassign $vector vx vy + lassign $centre cx cy + if { [llength [lindex $intersection 0]] == 1 } { + set intersection [list $intersection] + } + foreach xy $intersection { + lassign $xy x y + + set xn [expr {$vx * $x - $vy * $y + $cx}] + set yn [expr {$vy * $x + $vx * $y + $cy}] + + lappend newIntersection [list $xn $yn] + } + + return [list [concat $point [lindex $newIntersection 0]] \ + [concat $point [lindex $newIntersection 1]]] +} diff --git a/vendor/math/geometry_ext.tcl b/vendor/math/geometry_ext.tcl new file mode 100644 index 00000000..1b390a59 --- /dev/null +++ b/vendor/math/geometry_ext.tcl @@ -0,0 +1,1023 @@ + # geometry_ext.tcl -- + # Adapted from vectormath + # + ##+########################################################################## + # + # package: vectormath -> vectormath.tcl + # + # vectormath is software of Manfred ROSENBERGER + # based on tclTk, BWidgets and tdom on their + # own Licenses. + # + # Copyright (c) Manfred ROSENBERGER, 2010/10/24 + # + # The author 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 AUTHOR 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 AUTHOR HAVE BEEN ADVISED OF THE + # POSSIBILITY OF SUCH DAMAGE. + # + # THE AUTHOR 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 AUTHOR AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE + # MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + # + # --------------------------------------------------------------------------- + # namespace: vectormath + # --------------------------------------------------------------------------- + # + # 0.7 ... proc tangent_2_circles ... exception on equal radius + # ... proc angleVector (use proc angle) + # + + # + # +namespace eval ::math::geometry { + # + variable pi $::math::geometry::pi + variable torad $::math::geometry::torad + variable todeg $::math::geometry::todeg + # + variable margin 1.0e-10 + # + + variable CONST_PI [expr {4*atan(1)}] + + # +} + # + # + # ::math::geometry::cathetusPoint + # + # Return point of rectangular triangle locating the rectangular angle. + # + # Arguments: + # pa starting point on hypotenuse + # pb ending point on hypotenuse + # cathetus a cathetus of the triangle + # location location of the given cathetus + # a means given cathetus shares point pa (default) + # b means given cathetus shares point pb + # + # Result: + # pc point locating the rectangular angle + # + # Examples: + # - cathetusPoint {1 1} {5 2} 3 + # Result: {3.6168 -0.4671} + # - cathetusPoint {1 1} {5 2} 3 a + # Result: {3.6168 -0.4671} + # - cathetusPoint {1 1} {5 2} 3 b + # Result: {3.3815 -0.5259} + # - cathetusPoint {1 1} {5 2} 9 b + # Result: {} + # +proc ::math::geometry::cathetusPoint {pa pb cathetus {location {a}}} { + variable todeg + if {$location eq {close}} {set location a} + set length_c [length [- $pa $pb]] + set angle_c [angle [concat $pa $pb]] + if {$length_c >= $cathetus} { + set angle_cath [expr {acos($cathetus/$length_c) * $todeg}] + } else { + return {} + } + if {$location == {a}} { # cathetus next to pa + set angle_cath [expr {$angle_c - $angle_cath}] + set pc [+ $pa [s* $cathetus [direction $angle_cath]]] + } else { # cathetus next to pb + set angle_cath [expr {180 + $angle_c + $angle_cath}] + set vct_cath [s* $cathetus [direction $angle_cath]] + set pc [+ $pb [s* $cathetus [direction $angle_cath]]] + } + return $pc +} + # + # + # ::math::geometry::parallel + # + # Return line parallel to line by offset + # direction is defined by the first two coordinates of line, e.g. [lrange $line 0 3] + # Arguments: + # line + # offset + # orient right (default), left + # + # Result: + # pc point locating the rectangular angle + # + # Examples: + # - parallel {1 1} {5 2} 3 + # Result: {1.7276 -1.9104 5.7276 -0.9104} + # - parallel {1 1} {5 2} 3 a + # Result: {1.7276 -1.9104 5.7276 -0.9104} + # - parallel {1 1} {5 2} 3 b + # Result: {0.2724 3.9104 4.2724 4.9104} + # +proc ::math::geometry::parallel {line offset {orient {right}}} { + set a [angle [lrange $line 0 3]] + if {$orient == {right}} { # cathetus next to p1 + set a_p [expr {$a - 90}] + } else { # cathetus next to p2 + set a_p [expr {$a + 90}] + } + set parallel {} + set v [rotate $a_p [list $offset 0]] + foreach {x y} $line { + set p [+ [list $x $y] $v] + lappend parallel $p + } + return [join $parallel] +} + # + # + # rotateAbout -- + # + # rotate a polyline + # about a given position and angle + # + # Arguments: + # p + # angle + # polyline + # + # Result: + # rotated polyline + # + # Examples: + # - rotateAbout {10 10} 90 {20 0 20 20} + # Result: {20.0 20.0 0.0 20.0} + # - rotateAbout {10 10} 180 {20 0 20 20} + # Result: {0.0 20.0 0.0 0.0} + # +proc ::math::geometry::rotateAbout {p angle polyline} { + lassign $p px py + set polyline [translate [list [expr {- $px}] [expr {- $py}]] $polyline] + set polyline [rotate $angle $polyline] + set polyline [translate $p $polyline] + return $polyline +} + + # + # + # ::math::geometry::unitVector + # + # Calculates unit vector from line. + # + # Arguments: + # line/direction a line defined by two points A and B + # a point defined by x and y + # + # Results: + # x y unit vector describing 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 15} + # Result: 0.7071067811865476 0.7071067811865476 + # - angle {10 10} + # Result: 0.7071067811865476 0.7071067811865476 + # +proc ::math::geometry::unitVector {line} { + return [::math::geometry::direction [::math::geometry::angle $line]] +} + + # + # + # tangentLinesToCircle -- + # Determine the tangents from a point to a circle + # + # Arguments: + # point Point in question + # circle Circle in question + # + # Returns: + # The two tangent lines or an empty list if the point is inside the circle + # + # Note: + # Shift and rotate the point and circle first, then determine the + # intersection and transform back. + # +proc ::math::geometry::tangentLinesToCircle {point circle} { + variable margin + + set centre [lrange $circle 0 1] + set radius [lindex $circle end] + + set distance [distance $centre $point] + + if { $distance < $radius } { + return {} + } else { + set vector [- $point $centre] + set vector [s* [expr {1.0/$distance}] [- $point $centre]] + + if { abs($distance - $radius) < $margin*$radius } { + lassign $vector vx vy + return [list [concat $point [+ $point [list $vy [expr {-$vx}]]]]] + # The two tangent lines coincide + } + } + + set halfdistance [expr {$distance / 2.0}] + set newcircle [list $halfdistance 0.0 $halfdistance] + set intersection [IntersectionCircleCircle $circle $newcircle] + + set newIntersection {} + lassign $vector vx vy + lassign $centre cx cy + if { [llength [lindex $intersection 0]] == 1 } { + set intersection [list $intersection] + } + foreach xy $intersection { + lassign $xy x y + + set xn [expr {$vx * $x - $vy * $y + $cx}] + set yn [expr {$vy * $x + $vx * $y + $cy}] + + lappend newIntersection [list $xn $yn] + } + + return [list [concat $point [lindex $newIntersection 0]] \ + [concat $point [lindex $newIntersection 1]]] +} + # + # + # ::math::geometry::angle + # + # Calculates angle from the horizon (0,0)->(1,0) to a line. + # + # Arguments: + # line/direction a line defined by two points A and B + # a direction defined by x and y + # + # 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 + # - angle {10 10} + # Result: 45.0 + # +proc ::math::geometry::angle {line} { + if {[llength $line] == 2} { + set x1 0 + set y1 0 + lassign $line x2 y2 + } else { + lassign $line x1 y1 x2 y2 + } + # 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 +} + # + # + # ::math::geometry::unitVector + # + # Calculates unit vector from line. + # + # Arguments: + # line/direction a line defined by two points A and B + # a point defined by x and y + # + # Results: + # x y unit vector describing 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 15} + # Result: 0.7071067811865476 0.7071067811865476 + # - angle {10 10} + # Result: 0.7071067811865476 0.7071067811865476 + # +proc ::math::geometry::unitVector {line} { + return [::math::geometry::direction [::math::geometry::angle $line]] +} + # + # + # Unit vector into specific direction given by angle (degrees) + # ... opposite behaviour of ::math::geometry::direction +proc ::math::geometry::direction {angle} { + variable torad + set x [expr {cos($angle * $torad)}] + set y [expr {sin($angle * $torad)}] + return [list $x $y] +} + # + # + # Find direction octant the point (vector) lies in. + # ... opposite behaviour of ::math::geometry::direction + # +proc ::math::geometry::octant {p} { + variable todeg + lassign $p x y + + 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 southeast + } + if {$a <= 112.5} { return south } + return southwest + } else { + if {$a <= 247.5} { + if {$a <= 202.5} { return west } + return northwest + } + if {$a <= 337.5} { + if {$a <= 292.5} { return north } + return northeast + } + return east ; # a <= 360.0 + } +} + # + # + # ::math::geometry::intersectSegmentCircle + # +proc ::math::geometry::intersectSegmentCircle {line circle} { + return [::math::geometry::lineSegmentIntersectsCircle $line $circle] +} + # + # + # ::math::geometryExt::intersectLineCircle + # +proc ::math::geometry::intersectLineCircle {line circle} { + return [::math::geometry::lineIntersectsCircle $line $circle] +} + # + # + # ::math::geometry::intersectLineSegments + # +proc ::math::geometry::intersectLineSegments {line1 line2} { + return [::math::geometry::lineSegmentsIntersect $line1 $line2] +} + # + # ::math::geometry::intersectionLineCircle + # ... intersectionLineWithCircle + # +proc ::math::geometry::intersectionLineCircle {line circle} { + return [::math::geometry::intersectionLineWithCircle $line $circle] +} + # + # ::math::geometry::intersectionLineCircle + # ... findLineSegmentIntersection + # +proc ::math::geometry::intersectionLineSegments {line1 line2} { + return [::math::geometry::findLineSegmentIntersection $line1 $line2] +} + # + # + # ::math::geometry::intersectionSegmentCircle + # +proc ::math::geometry::intersectionSegmentCircle {line circle} { + if [intersectLineCircle $line $circle] { + set posList {} + foreach pos [intersectionLineCircle $line $circle] { + if { [pointInsideBBox $line $pos] } { + lappend posList $pos + } + } + return $posList + } else { + return {} + } +} + # + # + # ::math::geometry::intersectionPolylines + # + # ... based on ::math::geometry::polylinesBoundingIntersect + # + # Computes the first or all intersections of two polylines. + # + # 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 computes the + # first {mode=first} or alls {mode=all} intersecting points. + # + # Arguments: + # polyline1 the first polyline + # polyline2 the second polyline + # mode [first|all] results + # + # Results: + # posIntersect ... pos of intersections or empty list in case of no intersection found + # + # Examples: + # - intersectionPolylines {0 0 10 10 10 20} {0 10 10 0} + # Result: {5 5} + # - intersectionPolylines {0 0 10 10 10 20} {5 4 10 4} + # Result: {} + # + # + # * + # / + # +─────+ / + # \ * - - * + # \ / + # +── o ───────── ─> + # / + # * + # +proc ::math::geometry::___polylineIntersection {polyline1 polyline2 {mode first}} { + return [intersectionPolylines $polyline1 $polyline2 $mode] +} +proc ::math::geometry::intersectionPolylines {polyline1 polyline2 {mode first} {granularity 1}} { + # + #set granularity 10 ; # the number of points in each part-polyline + # # granularity<=1 means full correctness + # # 10 ... optimal search granularity? + # + # split the lines into parts consisting of $granularity points + if {$granularity > 1 } { + 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}]] + } + } else { + set polyline1parts [list $polyline1] + set polyline2parts [list $polyline2] + } + # + set posList {} + # + # do any of the parts overlap? + # + # + foreach part1 $polyline1parts { + # + # puts " -> \$part1 $part1" + set part1bbox [bbox $part1] + # + foreach part2 $polyline2parts { + # puts " -> \$part2 $part2" + set part2bbox [bbox $part2] + # puts " -> \$part1bbox $part1bbox" + # puts " -> \$part2bbox $part2bbox" + # + if {[rectanglesOverlap [lrange $part1bbox 0 1] [lrange $part1bbox 2 3] [lrange $part2bbox 0 1] [lrange $part2bbox 2 3] 0]} { + # puts " the lines' bounding boxes intersect" + foreach {l1x2 l1y2} [lassign $part1 l1x1 l1y1] { + foreach {l2x2 l2y2} [lassign $part2 l2x1 l2y1] { + # + # puts " -> try [list $l1x1 $l1y1 $l1x2 $l1y2] <-?-> [list $l2x1 $l2y1 $l2x2 $l2y2]" + if {[intersectLineSegments [list $l1x1 $l1y1 $l1x2 $l1y2] [list $l2x1 $l2y1 $l2x2 $l2y2]]} { + # puts " two line segments overlap" + # compute intersection + # return position + # puts " -> intersect - A1: yes" + set posIntersect [intersectionLineSegments [list $l1x1 $l1y1 $l1x2 $l1y2] [list $l2x1 $l2y1 $l2x2 $l2y2]] + if {$posIntersect eq "coincident" || $posIntersect eq "none"} { + set posIntersect "" + } + # puts " -> \$k: $k -> [list $l1x1 $l1y1 $l1x2 $l1y2]" + # puts " -> \$l: $l -> [list $l2x1 $l2y1 $l2x2 $l2y2]" + # puts " -> intersection: $posIntersect" + if {$mode ne "first"} { + lappend posList $posIntersect + } else { + return $posIntersect + } + # + } + set l2x1 $l2x2; set l2y1 $l2y2 + # + } + set l1x1 $l1x2; set l1y1 $l1y2 + } + } + } + } + # + # + return $posList + # +} + # + # + # ::math::geometry::intersectionPolylineCircle + # + # ... based on ::math::geometry::polylinesBoundingIntersect + # + # Computes the first or all intersections of polyline and circle. + # + # How it works: + # The 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 + # mode return [first|all] intersections + # + # Results: + # posIntersect ... pos of intersections or empty list in case of no intersection found + # + # Examples: + # - intersectionPolylineCircle {0 0 10 10 20 10 30 0} {40 0 20} + # Result: {30.564404225837308 4.717797887081346} + # - intersectionPolylineCircle {0 0 10 10 20 10 30 0} {20 0 15} + # Result: {18.81966011250105 10.0} + # - intersectionPolylineCircle {0 0 10 10 20 10 40 0} {20 0 15} + # Result: {34.77032961426901 2.6148351928654963} {6.464466094067264 6.464466094067264} + # - intersectionPolylineCircle {0 0 10 10 20 10 40 0} {20 0 15} + # Result: {} + # + # + # Results: + # posList ...... e.g: {34.77032961426901 2.6148351928654963} {6.464466094067264 6.464466094067264} + # + # + # + # \ + # +─────+ \ + # \ | + # \ | + # +── o ───────── ─> + # / + # / + # +proc ::math::geometry::___polylineCircleIntersection {polyline circle {mode first}} { + return [intersectionPolylineCircle $polyline $circle $mode] +} +proc ::math::geometry::intersectionPolylineCircle {polyline circle {mode first} {granularity 1}} { + # + # puts "\n -> ::math::geometry::polylineCircleIntersection \n" + # + #set granularity 5 ; # the number of points in each part-polyline + # granularity<=1 means full correctness + # 5 ... optimal search granularity? + # + # split the lines into parts consisting of $granularity points + set polylineAllParts {} + if { $granularity > 1 } { + for {set i 0} {$i<[llength $polyline]} {incr i [expr {2*$granularity-2}]} { + lappend polylineAllParts [lrange $polyline $i [expr {$i+2*$granularity-1}]] + } + } else { + set polylineAllParts [list $polyline] + } + # + lassign $circle x y r + set posCenter [list $x $y] + set bboxCircle [list [expr {$x - $r}] [expr {$y - $r}] [expr {$x + $r}] [expr {$y + $r}]] + # + set polylineUseParts {} + # + # -- get parts of $polylineAllParts that might intersect circle + foreach part $polylineAllParts { + # + set part1bbox [bbox $part] + # + if {[rectanglesOverlap [lrange $part1bbox 0 1] [lrange $part1bbox 2 3] [lrange $bboxCircle 0 1] [lrange $bboxCircle 2 3] 1]} { + lappend polylineUseParts $part + } + } + # + if 0 { + puts " -> llength \$polylineAllParts -> [llength $polylineAllParts]" + puts " -> llength \$polylineUseParts -> [llength $polylineUseParts]" + foreach polylinePart $polylineUseParts { + puts " \$polylineUseParts -> $polylinePart" + } + } + # + # + # -- iterate through $polylineUseParts + # + set posList {} + # + set m 0 + foreach polylinePart $polylineUseParts { + # + incr m + # + # puts "--------------------" + # puts " -> \$polylinePart $polylinePart" + set n 0 + foreach {seg_x2 seg_y2} [lassign $polylinePart seg_x1 seg_y1] { + incr n + set segment [list $seg_x1 $seg_y1 $seg_x2 $seg_y2] + set posIntersect [intersectionSegmentCircle $segment $circle] + if {$posIntersect != {}} { + # puts "\n" + # puts " $m / $n -> \$segment: $segment" + # puts " $m / $n -> \n\[::math::geometry::intersectionSegmentCircle \\\n [list $segment] \\\n [list $circle]\]" + # puts " $m / $n -> \$posIntersect: $posIntersect" + foreach pos $posIntersect { + # puts " -> $m / $n : $segment" + # puts " -> $m / $n : $pos" + if {$mode ne "first"} { + #lassign $pos _x_ _y_ + #lappend posList [list [format {%0.6f} $_x_] [format {%0.6f} $_y_]] + lappend posList $pos + } else { + return $pos + } + } + } + set seg_x1 $seg_x2; set seg_y1 $seg_y2 + } + } + # + # puts " -> \$posList $posList" + # set posList [lsort -unique $posList] + # puts " -> \$posList $posList" + # + return $posList + # + # +} + # + # + # ::math::geometry::polylineCutOrigin + # + # Arguments: + # polyline1 the first polyline + # polyline2 the second polyline + # granularity the coarseness for the procedure + # + # Return: + # polyline polyline from cut position to end + # +proc ::math::geometry::polylineCutOrigin {polyline1 polyline2 {granularity 1}} { + # + #set granularity 10 ; # the number of points in each part-polyline + # granularity<=1 means full correctness + # 10 ... optimal search granularity? + # + # split the lines into parts consisting of $granularity points + set granularity [expr {min(2,$granularity+1)}];# We need the total number of points in the section + + 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}]] + } + # + set posIntersect {} + set polyline {} + # + # do any of the parts overlap? + # + # + foreach part1 $polyline1parts { + # puts " -> \$part1 $part1" + set part1bbox [bbox $part1] + # + foreach part2 $polyline2parts { + # puts " -> \$part2 $part2" + set part2bbox [bbox $part2] + # puts " -> \$part1bbox $part1bbox" + # puts " -> \$part2bbox $part2bbox" + # + if {[rectanglesOverlap [lrange $part1bbox 0 1] [lrange $part1bbox 2 3] [lrange $part2bbox 0 1] [lrange $part2bbox 2 3] 0]} { + # puts " the lines' bounding boxes intersect" + foreach {l1x2 l1y2} [lassign $part1 l1x1 l1y1] { + if {$polyline eq {}} { + foreach {l2x2 l2y2} [lassign $part2 l2x1 l2y1] { + # + # puts " -> try [list $l1x1 $l1y1 $l1x2 $l1y2] <-?-> [list $l2x1 $l2y1 $l2x2 $l2y2]" + if {[intersectLineSegments [list $l1x1 $l1y1 $l1x2 $l1y2] [list $l2x1 $l2y1 $l2x2 $l2y2]]} { + # puts " two line segments overlap" + # compute intersection + # return position + # puts " -> intersect - A1: yes" + set posIntersect [intersectionLineSegments [list $l1x1 $l1y1 $l1x2 $l1y2] [list $l2x1 $l2y1 $l2x2 $l2y2]] + if {$posIntersect eq "coincident" || $posIntersect eq "none"} { + set posIntersect "" + } + # puts " -> \$k: $k -> [list $l1x1 $l1y1 $l1x2 $l1y2]" + # puts " -> \$l: $l -> [list $l2x1 $l2y1 $l2x2 $l2y2]" + # puts " -> intersection: $posIntersect" + set polyline [join "$posIntersect $l1x2 $l1y2"] + # + } + set l2x1 $l2x2; set l2y1 $l2y2 + # + } + } else { + lappend polyline $l1x2 $l1y2 + } + # + set l1x1 $l1x2; set l1y1 $l1y2 + # + } + } + } + } + # + # + return $polyline + # +} + # + # + # ::math::geometry::polylineCutEnd + # + # Arguments: + # polyline1 the first polyline + # polyline2 the second polyline + # granularity the coarseness for the procedure + # + # Return: + # polyline polyline from origin to cut position + # +proc ::math::geometry::polylineCutEnd {polyline1 polyline2 {granularity 1}} { + # + #set granularity 10 ; # the number of points in each part-polyline + # granularity<=1 means full correctness + # 10 ... optimal search granularity? + set granularity [expr {min(2,$granularity+1)}];# We need the total number of points in the section + # + # 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}]] + } + # + set posIntersect {} + set polyline [lrange $polyline1 0 1] + # + # do any of the parts overlap? + # + # + foreach part1 $polyline1parts { + # puts " -> \$part1 $part1" + set part1bbox [bbox $part1] + # + foreach part2 $polyline2parts { + #puts " -> \$part2 $part2" + set part2bbox [bbox $part2] + # puts " -> \$part1bbox $part1bbox" + # puts " -> \$part2bbox $part2bbox" + # + if {[rectanglesOverlap [lrange $part1bbox 0 1] [lrange $part1bbox 2 3] [lrange $part2bbox 0 1] [lrange $part2bbox 2 3] 0]} { + # puts " the lines' bounding boxes intersect" + foreach {l1x2 l1y2} [lassign $part1 l1x1 l1y1] { + foreach {l2x2 l2y2} [lassign $part2 l2x1 l2y1] { + # + # puts " -> try [list $l1x1 $l1y1 $l1x2 $l1y2] <-?-> [list $l2x1 $l2y1 $l2x2 $l2y2]" + if {[intersectLineSegments [list $l1x1 $l1y1 $l1x2 $l1y2] [list $l2x1 $l2y1 $l2x2 $l2y2]]} { + # puts " two line segments overlap" + # compute intersection + # return position + # puts " -> intersect - A1: yes" + set posIntersect [intersectionLineSegments [list $l1x1 $l1y1 $l1x2 $l1y2] [list $l2x1 $l2y1 $l2x2 $l2y2]] + if {$posIntersect eq "coincident" || $posIntersect eq "none"} { + continue + } + # puts " -> \$k: $k -> [list $l1x1 $l1y1 $l1x2 $l1y2]" + # puts " -> \$l: $l -> [list $l2x1 $l2y1 $l2x2 $l2y2]" + # puts " ... intersection found for part1 in part2 -> $l1x1 $l1y1 $l1x2 $l1y2 -?- $l2x1 $l2y1 $l2x2 $l2y2" + lappend polyline $posIntersect + # + return [join $polyline] + # + } else { + # puts " ... no intersection found for part1 in part2 -> $l1x1 $l1y1 $l1x2 $l1y2 -?- $l2x1 $l2y1 $l2x2 $l2y2" + } + # + set l2x1 $l2x2; set l2y1 $l2y2 + # + } + # + lappend polyline $l1x2 $l1y2 + # + set l1x1 $l1x2; set l1y1 $l1y2 + # + } + } else { + # puts " ... no overlap found for part1 in part2 -> [lrange $part1 2 end]" + lappend polyline [lrange $part1 2 end] + # + } + } + # + } + # + # + return [join $polyline] + # +} + # + # + # ::math::geometry::splitPolyline + # + # Arguments: + # polyline the given polyline + # + # Return: + # list of segments + # +proc ::math::geometry::splitPolyline {polyline numbVertex} { + # + set listSegments {} + # + # puts " -> splitPolyline" + # puts " -> \$numbVertex $numbVertex" + # + set myPolygon [lassign $polyline x y] + # + set xy [list $x $y] + # + set i 0 + # + set tmpPolyline $xy + # + # + foreach {x y} $myPolygon { + # + lappend tmpPolyline $x $y + # + # puts " -> $i: $tmpPolyline" + # + if {$i < $numbVertex} { + # + incr i + # + } else { + # + lappend listSegments [join $tmpPolyline] + # + set tmpPolyline [list $x $y] + set i 0 + # + } + # + } + # + if {[lindex $listSegments end] != $tmpPolyline} { + lappend listSegments $tmpPolyline + } + # + return $listSegments + # +} + # + # + # ::math::geometry::enrichPolyline + # + # Arguments: + # polyline the given polyline + # accuracy divide each segment into $accuracy number of segments + # + # Results: + # polyline each segment divided in $accuracy number of segments + # + # Example: + # - enrichPolyline {0 0 40 0 40 20 80 20} 4 + # Result: {0 0 10 0 20 0 30 0 40 0 40 5 40 10 40 15 40 20 50 20 60 20 70 20 80 20} + # +proc ::math::geometry::enrichPolyline {polyline accuracy} { + # + set retValue [lrange $polyline 0 1] + # + set accuracy [expr {$accuracy + 0.0}] ;# Avoid division by an integer + + foreach {x2 y2} [lassign $polyline x1 y1] { + # puts " -> $x1 $y1 -> $x2 $y2" + set dx [expr {($x2 - $x1) / $accuracy}] + set dy [expr {($y2 - $y1) / $accuracy}] + for {set i 1} {$i <= $accuracy} {incr i} { + lappend retValue [expr {$x1 + $i * $dx}] [expr {$y1 + $i * $dy}] + } + set x1 $x2 + set y1 $y2 + } + # + return $retValue + # +} + # + # + # ::math::geometry::cleanupPolyline + # + # remove coincidencies of neighbored points + # + # Arguments: + # polyline the given polyline + # + # Results: + # polyline + # + # Example: + # - cleanupPolyline {0 0 40 0 40 20 40 20.0 80 20 80 20.0} + # Result: {0 0 40 0 40 20 80 20} + # +proc ::math::geometry::cleanupPolyline {polyline} { + # + set retValue [lrange $polyline 0 1] + # + foreach {x2 y2} [lassign $polyline x1 y1] { + # puts " -> $x1 $y1 -> $x2 $y2" + if {$x2 != $x1 || $y2 != $y1} { + # puts " differ: $x2 -?- $x1 --- $y2 -?- $y1" + lappend retValue $x2 $y2 + } + set x1 $x2 + set y1 $y2 + } + # + return $retValue + # +} + # + # + # ::math::geometry::pointInsideBBox + # + # check wether a point is inside or on BoundingBoy + # + # Arguments: + # bbox the given polyline + # point the point to be checked + # + # Results: + # 0 ... totally outside bbox + # 1 ... inside bbox + # + # Example: + # - pointInsideBBox {0 0 40 20} {20 10} + # Result: 1 + # - pointInsideBBox {0 0 40 20} {30 20} + # Result: 1 + # - pointInsideBBox {0 0 40 20} {50 10} + # Result: 0 + # +proc ::math::geometry::pointInsideBBox {bbox point} { + lassign $bbox bb_x0 bb_y0 bb_x1 bb_y1 + lassign $point x y + if {$x == [lindex [lsort -real -increasing "$bb_x0 $bb_x1 $x"] 1]} { + if {$y == [lindex [lsort -real -increasing "$bb_y0 $bb_y1 $y"] 1]} { + return 1 + } + } + return 0 +} + # + # + # ::math::geometry::overlapBBox + # +proc ::math::geometry::overlapBBox {polyline1 polyline2 {strict 0}} { + # puts " -> \$polyline1 $polyline1" + # puts " -> \$polyline2 $polyline2" + set bbox1 [bbox $polyline1] + set bbox2 [bbox $polyline2] + # puts " -> \$bbox1 $bbox1" + # puts " -> \$bbox2 $bbox2" + # puts " -> [::math::geometry::rectanglesOverlap [lrange $bbox1 0 1] [lrange $bbox1 2 3] [lrange $bbox2 0 1] [lrange $bbox2 2 3] $strict]" + return [rectanglesOverlap [lrange $bbox1 0 1] [lrange $bbox1 2 3] [lrange $bbox2 0 1] [lrange $bbox2 2 3] $strict] +} + diff --git a/vendor/math/interpolate.man b/vendor/math/interpolate.man new file mode 100644 index 00000000..b4fba0e5 --- /dev/null +++ b/vendor/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 }] +[copyright {2004 Kevn B. Kenny }] +[moddesc {Tcl Math Library}] +[titledesc {Interpolation routines}] +[category Mathematics] +[require Tcl [opt 8.4]] +[require struct] +[require math::interpolate [opt 1.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 ../common-text/feedback.inc] +[manpage_end] diff --git a/vendor/math/interpolate.tcl b/vendor/math/interpolate.tcl new file mode 100644 index 00000000..810b808c --- /dev/null +++ b/vendor/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)/double($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]+0.0 > $xval } { + return [lindex $xyvalues 1] + } + if { [lindex $xyvalues end-1]+0.0 < $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)/double($x2-$x)}] + } else { + set yval [expr {double($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.2 diff --git a/vendor/math/interpolate.test b/vendor/math/interpolate.test new file mode 100644 index 00000000..8520b665 --- /dev/null +++ b/vendor/math/interpolate.test @@ -0,0 +1,374 @@ +# -*- 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.5 +testsNeedTcltest 2.1 + +support { + use struct/matrix.tcl struct::matrix + useLocal math.tcl math +} +testing { + useLocal interpolate.tcl math::interpolate +} + +# ------------------------------------------------------------------------- + +# +# Compare a list of numbers +# +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 +} + +test "Interpolate-1.3" "Interpolate with integers" \ + -match numbers -body { + set equalResults {} + + set table [::math::interpolate::defineTable table3 \ + {A B C D E} \ + {0 0.00000 0.00000 0.00000 0.0000 + 1 0.52000 0.52000 0.52000 0.5200 + 3 0.69831 0.63142 0.67758 0.68457 + 5 0.86111 0.71690 0.81118 0.80365 + 7 1.01367 0.78725 0.92891 0.89851}] + + foreach A {2 4 6} A2 {2.0 4.0 6.0} { + set intResults [::math::interpolate::interp-1d-table $table $A] + set floatResults [::math::interpolate::interp-1d-table $table $A2] + set equal 1 + foreach i $intResults f $floatResults { + if { $i != $f } { + set equal 0 + break + } + } + lappend equalResults $equal + } + + return $equalResults +} -result {1 1 1} + +# 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/vendor/math/kruskal.tcl b/vendor/math/kruskal.tcl new file mode 100644 index 00000000..bfada784 --- /dev/null +++ b/vendor/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/vendor/math/linalg.man b/vendor/math/linalg.man new file mode 100644 index 00000000..b6683e0f --- /dev/null +++ b/vendor/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 }] +[copyright {2004 Ed Hume }] +[copyright {2008 Michael Buadin }] +[moddesc {Tcl Math Library}] +[titledesc {Linear Algebra}] +[category Mathematics] +[require Tcl [opt 8.4]] +[require math::linearalgebra [opt [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 ../common-text/feedback.inc] +[manpage_end] diff --git a/vendor/math/linalg.tcl b/vendor/math/linalg.tcl new file mode 100644 index 00000000..2f8aeb6a --- /dev/null +++ b/vendor/math/linalg.tcl @@ -0,0 +1,2299 @@ +# 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.5 ; # conforming uses 8.5+ features (`x ni list`). + +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 ni {shape rows matmul} } { + return -code error "Unknown type of conforming check - $type - should be one of: shape rows matmul" + } + + 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" } { + if { [llength $shape1] == 2 } { + set result [expr {[lindex $shape1 1] == [lindex $shape2 0]}] + } elseif { [llength $shape2] == 2 } { + set result [expr {[lindex $shape1 0] == [lindex $shape2 0]}] + } else { + set result [expr {[lindex $shape1 0] == [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.6 + +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/vendor/math/linalg.test b/vendor/math/linalg.test new file mode 100644 index 00000000..1595c26a --- /dev/null +++ b/vendor/math/linalg.test @@ -0,0 +1,937 @@ +# -*- 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.5 + 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]} { + # 8.4 or less - Remove, 8.5+ required already + 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 solve-1.6 "solveGauss - permuted matrix" -match numbers -body { + set matrix {{1000 1 1 10} + { 1 1000 10 100} + { 10 10 100 1} + { 100 100 1000 1000}} + set b {1003.3 133 31.3 610} + + set xvec1 [solveGauss $matrix $b] + + set matrix {{ 100 100 1000 1000} + {1000 1 1 10} + { 1 1000 10 100} + { 10 10 100 1}} + set b {610 1003.3 133 31.3} + + set xvec2 [solveGauss $matrix $b] + + set closeValues [areClose $xvec1 $xvec2 1.0e-8] +} -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} + +# Conforming - ticket 776a75f14f53b5c9a06fe3f3892485a6efe1dc20 +test conforming-1 "Conforming shapes" -body { + set m1 {{1 2} + {3 4}} + set m2 {{1 3} + {3 4}} + conforming shape $m1 $m2 +} -result 1 +test conforming-2 "Non-conforming shapes" -body { + set m1 {{1 2} + {3 4}} + set m2 {{1 3 4} + {3 4 5}} + conforming shape $m1 $m2 +} -result 0 +test conforming-3 "Conforming matmul - two matrices" -body { + set m1 {{1 2} + {3 4} + {5 6}} + set m2 {{1 3 4} + {3 4 5}} + conforming matmul $m1 $m2 +} -result 1 +test conforming-4 "Conforming matmul - two matrices, reversed" -body { + set m1 {{1 2} + {3 4} + {5 6}} + set m2 {{1 3 4} + {3 4 5}} + conforming matmul $m2 $m1 +} -result 1 +test conforming-5 "Conforming matmul - vector-matrix" -body { + set mat {{1 2} + {3 4} + {5 6}} + set vec {1 3 4} + conforming matmul $vec $mat +} -result 1 +test conforming-6 "Conforming matmul - vector-matrix" -body { + set mat {{1 2} + {3 4} + {5 6}} + set vec {1 3} + conforming matmul $mat $vec +} -result 1 +test conforming-7 "Non-conforming matmul - vector-matrix" -body { + set mat {{1 2} + {3 4} + {5 6}} + set vec {1 3} + conforming matmul $vec $mat +} -result 0 +test conforming-7 "Non-conforming matmul - vector-matrix" -body { + set mat {{1 2} + {3 4} + {5 6}} + set vec {1 2 3} + conforming matmul $mat $vec +} -result 0 + + +# 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/vendor/math/liststat.tcl b/vendor/math/liststat.tcl new file mode 100644 index 00000000..d7b2e140 --- /dev/null +++ b/vendor/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/vendor/math/machineparameters.man b/vendor/math/machineparameters.man new file mode 100644 index 00000000..9de5a6b3 --- /dev/null +++ b/vendor/math/machineparameters.man @@ -0,0 +1,191 @@ +[comment {-*- tclrep -*- doctools manpage}] +[manpage_begin math::machineparameters n 1.0] +[copyright {2008 Michael Baudin }] +[moddesc tclrep] +[require Tcl 8.4] +[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) = +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 ../common-text/feedback.inc] +[manpage_end] diff --git a/vendor/math/machineparameters.tcl b/vendor/math/machineparameters.tcl new file mode 100644 index 00000000..7f2b6490 --- /dev/null +++ b/vendor/math/machineparameters.tcl @@ -0,0 +1,378 @@ +# machineparameters.tcl -- +# Compute double precision machine parameters. +# +# Description +# This the Tcl equivalent of the DLAMCH LAPCK function. +# In floating point systems, a floating point number is represented +# by +# x = +/- d1 d2 ... dt basis^e +# where digits satisfy +# 0 <= di <= basis - 1, i = 1, t +# with the convention : +# - t is the size of the mantissa +# - basis is the basis (the "radix") +# +# References +# +# "Algorithms to Reveal Properties of Floating-Point Arithmetic" +# Michael A. Malcolm +# Stanford University +# Communications of the ACM +# Volume 15 , Issue 11 (November 1972) +# Pages: 949 - 951 +# +# "More on Algorithms that Reveal Properties of Floating +# Point Arithmetic Units" +# W. Morven Gentleman, University of Waterloo +# Scott B. Marovich, Purdue University +# Communications of the ACM +# Volume 17 , Issue 5 (May 1974) +# Pages: 276 - 277 +# +# Example +# +# In the following example, one compute the parameters of a desktop +# under Linux with the following Tcl 8.4.19 properties : +# +#% parray tcl_platform +#tcl_platform(byteOrder) = littleEndian +#tcl_platform(machine) = i686 +#tcl_platform(os) = Linux +#tcl_platform(osVersion) = 2.6.24-19-generic +#tcl_platform(platform) = unix +#tcl_platform(tip,268) = 1 +#tcl_platform(tip,280) = 1 +#tcl_platform(user) = +#tcl_platform(wordSize) = 4 +# +# The following example creates a machineparameters object, +# computes the properties and displays it. +# +# set pp [machineparameters create %AUTO%] +# $pp compute +# $pp print +# $pp destroy +# +# This prints out : +# +# Machine parameters +# Epsilon : 1.11022302463e-16 +# Beta : 2 +# Rounding : proper +# Mantissa : 53 +# Maximum exponent : 1024 +# Minimum exponent : -1021 +# Overflow threshold : 8.98846567431e+307 +# Underflow threshold : 2.22507385851e-308 +# +# That compares well with the results produced by Lapack 3.1.1 : +# +# Epsilon = 1.11022302462515654E-016 +# Safe minimum = 2.22507385850720138E-308 +# Base = 2.0000000000000000 +# Precision = 2.22044604925031308E-016 +# Number of digits in mantissa = 53.000000000000000 +# Rounding mode = 1.00000000000000000 +# Minimum exponent = -1021.0000000000000 +# Underflow threshold = 2.22507385850720138E-308 +# Largest exponent = 1024.0000000000000 +# Overflow threshold = 1.79769313486231571E+308 +# Reciprocal of safe minimum = 4.49423283715578977E+307 +# +# Copyright 2008 Michael Baudin +# +package require Tcl 8.4 +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/vendor/math/machineparameters.test b/vendor/math/machineparameters.test new file mode 100644 index 00000000..2a3f58e1 --- /dev/null +++ b/vendor/math/machineparameters.test @@ -0,0 +1,52 @@ +# -*- tcl -*- +# machineparameters.test -- +# Unit tests for machineparameters.tcl +# +# Copyright 2008 Michael Baudin + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.5 +testsNeedTcltest 2.1 + +testing { + useLocal machineparameters.tcl math::machineparameters +} + +# ------------------------------------------------------------------------- + +# +# Check all parameters are there +# +test checkall {check epsilon, rounding mode} -setup { + set pp [machineparameters create %AUTO%] + $pp configure -verbose 0 + $pp compute +} -body { + 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 + 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}] +} -cleanup { + $pp destroy + unset pp +} -result {0 1 1 1} + +# ------------------------------------------------------------------------- +# +# Shutdown tests +# +tcltest::cleanupTests + diff --git a/vendor/math/math.man b/vendor/math/math.man new file mode 100644 index 00000000..1d49ae6f --- /dev/null +++ b/vendor/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 ../common-text/feedback.inc] +[manpage_end] diff --git a/vendor/math/math.tcl b/vendor/math/math.tcl new file mode 100644 index 00000000..aa173e06 --- /dev/null +++ b/vendor/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/vendor/math/math.test b/vendor/math/math.test new file mode 100644 index 00000000..8b9b9844 --- /dev/null +++ b/vendor/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.5 +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 +} {103 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/vendor/math/math_geometry.man b/vendor/math/math_geometry.man new file mode 100644 index 00000000..d9d4c1ad --- /dev/null +++ b/vendor/math/math_geometry.man @@ -0,0 +1,818 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin math::geometry n 1.4.1] +[keywords angle] +[keywords distance] +[keywords line] +[keywords math] +[keywords {plane geometry}] +[keywords point] +[copyright {2001 by Ideogramic ApS and other parties}] +[copyright {2010 by Andreas Kupries}] +[copyright {2010 by Kevin Kenny}] +[copyright {2018 by Arjen Markus}] +[copyright {2020 by Manfred Rosenberger}] +[moddesc {Tcl Math Library}] +[titledesc {Geometrical computations}] +[category Mathematics] +[require Tcl [opt 8.5]] +[require math::geometry [opt 1.4.1]] + +[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] +[emph Note:] In version 1.4.0 an inconsistency was repaired - see [uri https://core.tcl-lang.org/tcllib/tktview?name=fb4812f82b]. +More in [sectref "COORDINATE SYSTEM"] + +[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. + +[item] +[emph "circle"] - a list of three numbers, the first two are the coordinates of the +centre and the third is the radius. + +[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 (east), 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] + + +[call [cmd ::math::geometry::angleBetween] [arg vector1] [arg vector2]] + +Calculate the angle between two vectors (in degrees) + +[list_begin arguments] +[arg_def list vector1] First vector +[arg_def list vector2] Second vector +[list_end] + + +[call [cmd ::math::geometry::inproduct] [arg vector1] [arg vector2]] + +Calculate the inner product of two vectors + +[list_begin arguments] +[arg_def list vector1] First vector +[arg_def list vector2] Second vector +[list_end] + + +[call [cmd ::math::geometry::areaParallellogram] [arg vector1] [arg vector2]] + +Calculate the area of the parallellogram with the two vectors as its sides + +[list_begin arguments] +[arg_def list vector1] First vector +[arg_def list vector2] Second vector +[list_end] + + +[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] + + +[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] + + +[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] + + +[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] + + +[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] + + +[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] + + +[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] + + +[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] + + +[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] + + +[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] + + +[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] + + +[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. + + +[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] + + +[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] + + +[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] + + +[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] + + +[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] + + +[call [cmd ::math::geometry::overlapBBox] [arg polyline1] [arg polyline2] [opt strict]] + +Check if the bounding boxes of two polylines overlap or not. +[para] +Arguments: +[list_begin arguments] +[arg_def list polyline1] The first polyline +[arg_def list polyline1] The second polyline +[arg_def int strict] Whether strict overlap is to checked (1) or if the bounding boxes may touch (0, default) +[list_end] + + +[call [cmd ::math::geometry::pointInsideBBox] [arg bbox] [arg point]] +[para] +Check if the point is inside or on the bounding box or not. + +Arguments: +[list_begin arguments] +[arg_def list bbox] The bounding box given as a list of x/y coordinates +[arg_def list point] The point to be checked +[list_end] + + +[call [cmd ::math::geometry::cathetusPoint] [arg pa] [arg pb] [arg cathetusLength] [opt location]] + +Return the third point of the rectangular triangle defined by the two given end points of the hypothenusa. +The triangle's side from point A (or B, if the location is given as "b") to the third point is the cathetus length. + +If the cathetus' length is lower than the length of the hypothenusa, an empty list is returned. +[para] +Arguments: +[list_begin arguments] +[arg_def list pa] The starting point on hypotenuse +[arg_def list pb] The ending point on hypotenuse +[arg_def float cathetusLength] The length of the cathetus of the triangle +[arg_def string location] The location of the given cathetus, +"a" means given cathetus shares point pa (default) +"b" means given cathetus shares point pb +[list_end] + + +[call [cmd ::math::geometry::parallel] [arg line] [arg offset] [opt orient]] + +Return a line parallel to the given line, with a distance "offset". The orientation is determined by the +two points defining the line. +[para] +Arguments: +[list_begin arguments] +[arg_def list line] The given line +[arg_def float offset] The distance to the given line +[arg_def string orient] Orientation of the new line with respect to the given line (defaults to "right") +[list_end] +[para] + +[call [cmd ::math::geometry::unitVector] [arg line]] + +Return a unit vector from the given line or direction, if the [term line] argument is +a single point (then a line through the origin is assumed) + +Arguments: +[list_begin arguments] +[arg_def list line] The line in question (or a single point, implying a line through the origin) +[list_end] + + +[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] + + +[call [cmd ::math::geometry::pointInsidePolygonAlt] [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. [emph Note:] this alternative procedure uses the so-called +winding number to determine this. It handles self-intersecting polygons +in a "natural" way. + +[list_begin arguments] +[arg_def list P] Coordinates of the point +[arg_def list polyline] The polyline to be examined +[list_end] + + +[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] + + +[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] + + +[call [cmd ::math::geometry::translate] [arg vector] [arg polyline]] + +Translate a polyline over a given vector + +[list_begin arguments] +[arg_def list vector] Translation vector +[arg_def list polyline] The polyline to be translated +[list_end] + + +[call [cmd ::math::geometry::rotate] [arg angle] [arg polyline]] + +Rotate a polyline over a given angle (degrees) around the origin + +[list_begin arguments] +[arg_def list angle] Angle over which to rotate the polyline (degrees) +[arg_def list polyline] The polyline to be rotated +[list_end] + + +[call [cmd ::math::geometry::rotateAbout] [arg p] [arg angle] [arg polyline]] + +Rotate a polyline around a given point p and return the new polyline. +[para] +Arguments: +[list_begin arguments] +[arg_def list p] The point of rotation +[arg_def float angle] The angle over which to rotate the polyline (degrees) +[arg_def list polyline] The polyline to be rotated +[list_end] + + +[call [cmd ::math::geometry::reflect] [arg angle] [arg polyline]] + +Reflect a polyline in a line through the origin at a given angle (degrees) to the x-axis + +[list_begin arguments] +[arg_def list angle] Angle of the line of reflection (degrees) +[arg_def list polyline] The polyline to be reflected +[list_end] + + +[call [cmd ::math::geometry::degToRad] [arg angle]] + +Convert from degrees to radians + +[list_begin arguments] +[arg_def list angle] Angle in degrees +[list_end] + + +[call [cmd ::math::geometry::radToDeg] [arg angle]] + +Convert from radians to degrees + +[list_begin arguments] +[arg_def list angle] Angle in radians +[list_end] + + +[call [cmd ::math::geometry::circle] [arg centre] [arg radius]] + +Convenience procedure to create a circle from a point and a radius. + +[list_begin arguments] +[arg_def list centre] Coordinates of the circle centre +[arg_def list radius] Radius of the circle +[list_end] + + +[call [cmd ::math::geometry::circleTwoPoints] [arg point1] [arg point2]] + +Convenience procedure to create a circle from two points on its circumference +The centre is the point between the two given points, the radius is half the +distance between them. + +[list_begin arguments] +[arg_def list point1] First point +[arg_def list point2] Second point +[list_end] + + +[call [cmd ::math::geometry::pointInsideCircle] [arg point] [arg circle]] + +Determine if the given point is inside the circle or on the circumference (1) +or outside (0). + +[list_begin arguments] +[arg_def list point] Point to be checked +[arg_def list circle] Circle that may or may not contain the point +[list_end] + + +[call [cmd ::math::geometry::lineIntersectsCircle] [arg line] [arg circle]] + +Determine if the given line intersects the circle or touches it (1) +or does not (0). + +[list_begin arguments] +[arg_def list line] Line to be checked +[arg_def list circle] Circle that may or may not be intersected +[list_end] + + +[call [cmd ::math::geometry::lineSegmentIntersectsCircle] [arg segment] [arg circle]] + +Determine if the given line segment intersects the circle or touches it (1) +or does not (0). + +[list_begin arguments] +[arg_def list segment] Line segment to be checked +[arg_def list circle] Circle that may or may not be intersected +[list_end] + + +[call [cmd ::math::geometry::intersectionLineWithCircle] [arg line] [arg circle]] + +Determine the points at which the given line intersects the circle. There can +be zero, one or two points. (If the line touches the circle or is close to it, +then one point is returned. An arbitrary margin of 1.0e-10 times the radius +is used to determine this situation.) + +[list_begin arguments] +[arg_def list line] Line to be checked +[arg_def list circle] Circle that may or may not be intersected +[list_end] + + +[call [cmd ::math::geometry::intersectionCircleWithCircle] [arg circle1] [arg circle2]] + +Determine the points at which the given two circles intersect. There can +be zero, one or two points. (If the two circles touch the circle or are very close, +then one point is returned. An arbitrary margin of 1.0e-10 times the mean of the radii of +the two circles is used to determine this situation.) + +[list_begin arguments] +[arg_def list circle1] First circle +[arg_def list circle2] Second circle +[list_end] + + +[call [cmd ::math::geometry::tangentLinesToCircle] [arg point] [arg circle]] + +Determine the tangent lines from the given point to the circle. There can +be zero, one or two lines. (If the point is on the cirucmference or very close to +the circle, then one line is returned. An arbitrary margin of 1.0e-10 times the +radius of the circle is used to determine this situation.) + +[list_begin arguments] +[arg_def list point] Point in question +[arg_def list circle] Circle to which the tangent lines are to be determined +[list_end] + + +[call [cmd ::math::geometry::intersectionPolylines] [arg polyline1] [arg polyline2] [opt mode] [opt granularity]] + +Return the first point or all points where the two polylines intersect. If the number of points in the polylines is large, +you can use the granularity to get an approximate answer faster. +[para] +Arguments: +[list_begin arguments] +[arg_def list polyline1] The first polyline +[arg_def list polyline2] The second polyline +[arg_def string mode] Whether to return only the first (default) or to return all intersection points ("all") +[arg_def int granularity] The number of points that will be skipped plus 1 in the search for intersection points (1 or smaller means an exact answer is returned) +[list_end] + + +[call [cmd ::math::geometry::intersectionPolylineCircle] [arg polyline] [arg circle] [opt mode] [opt granularity]] + +Return the first point or all points where the polyline intersects the circle. If the number of points in the polyline is large, +you can use the granularity to get an approximate answer faster. +[para] +Arguments: +[list_begin arguments] +[arg_def list polyline] The polyline that may intersect the circle +[arg_def list circle] The circle in question +[arg_def string mode] Whether to return only the first (default) or to return all intersection points ("all") +[arg_def int granularity] The number of points that will be skipped plus 1 in the search for intersection points (1 or smaller means an exact answer is returned) +[list_end] + + +[call [cmd ::math::geometry::polylineCutOrigin] [arg polyline1] [arg polyline2] [opt granularity]] + +Return the part of the first polyline from the origin up to the first intersection with the second. If the number of points in the polyline is large, +you can use the granularity to get an approximate answer faster. +[para] +Arguments: +[list_begin arguments] +[arg_def list polyline1] The first polyline (from which a part is to be returned) +[arg_def list polyline2] The second polyline +[arg_def int granularity] The number of points that will be skipped plus 1 in the search for intersection points (1 or smaller means an exact answer is returned) +[list_end] + + +[call [cmd ::math::geometry::polylineCutEnd] [arg polyline1] [arg polyline2] [opt granularity]] + +Return the part of the first polyline from the last intersection point with the second to the end. If the number of points in the polyline is large, +you can use the granularity to get an approximate answer faster. +[para] +Arguments: +[list_begin arguments] +[arg_def list polyline1] The first polyline (from which a part is to be returned) +[arg_def list polyline2] The second polyline +[arg_def int granularity] The number of points that will be skipped plus 1 in the search for intersection points (1 or smaller means an exact answer is returned) +[list_end] + + +[call [cmd ::math::geometry::splitPolyline] [arg polyline] [arg numberVertex]] + +Split the poyline into a set of polylines where each separate polyline holds "numberVertex" vertices between the two end points. +[para] +Arguments: +[list_begin arguments] +[arg_def list polyline] The polyline to be split up +[arg_def int numberVertex] The number of "internal" vertices +[list_end] + + +[call [cmd ::math::geometry::enrichPolyline] [arg polyline] [arg accuracy]] + +Split up each segment of a polyline into a number of smaller segments and return the result. +[para] +Arguments: +[list_begin arguments] +[arg_def list polyline] The polyline to be refined +[arg_def int accuracy] The number of subsegments to be created +[list_end] + + +[call [cmd ::math::geometry::cleanupPolyline] [arg polyline]] + +Remove duplicate neighbouring vertices and return the result. +[para] +Arguments: +[list_begin arguments] +[arg_def list polyline] The polyline to be cleaned up +[list_end] + +[list_end] + + +[section "COORDINATE SYSTEM"] +The coordinate system used by the package is the ordinary cartesian system, where the +positive x-axis is directed to the right and the positive y-axis is directed upwards. +Angles and directions are defined with respect to the positive x-axis in a counter-clockwise +direction, so that an angle of 90 degrees is the direction of the positive y-axis. + +Note that the Tk canvas coordinates differ from this, as there the origin is located in the +upper left corner of the window. Up to and including version 1.3, the direction and octant +procedures of this package used this convention inconsistently. + + +[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 ../common-text/feedback.inc] +[manpage_end] diff --git a/vendor/math/misc.tcl b/vendor/math/misc.tcl new file mode 100644 index 00000000..acb54eae --- /dev/null +++ b/vendor/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/double($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/double($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/vendor/math/mvlinreg.tcl b/vendor/math/mvlinreg.tcl new file mode 100644 index 00000000..b234c709 --- /dev/null +++ b/vendor/math/mvlinreg.tcl @@ -0,0 +1,265 @@ +# 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.1.1 + +# ::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)}] + } + if { $sstot != 0.0 } { + set r2 [expr {double($ssreg)/$sstot}] + } else { + set r2 1.0 + } + 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/vendor/math/numtheory.dtx b/vendor/math/numtheory.dtx new file mode 100644 index 00000000..9fcadff8 --- /dev/null +++ b/vendor/math/numtheory.dtx @@ -0,0 +1,1832 @@ +% +% \iffalse +% +%<*pkg_common> +%% Copyright (c) 2010 by Lars Hellstrom. All rights reserved. +%% See the file "license.terms" for information on usage and redistribution +%% of this file, and for a DISCLAIMER OF ALL WARRANTIES. +% +%<*driver> +\documentclass{tclldoc} +\usepackage{amsmath,amsfonts} +\usepackage{url} +\newcommand{\Tcl}{\Tcllogo} +\begin{document} +\DocInput{numtheory.dtx} +\end{document} +% +% \fi +% +% \title{Number theory package} +% \author{Lars Hellstr\"om} +% \date{30 May 2010} +% \maketitle +% +% \begin{abstract} +% This package provides a command to test whether an integer is a +% prime, but may in time come to house also other number-theoretic +% operations. +% \end{abstract} +% +% \tableofcontents +% +% \section*{Preliminaries} +% +% \begin{tcl} +%<*pkg> +package require Tcl 8.5 +% \end{tcl} +% \Tcl~8.4 is seriously broken with respect to arithmetic overflow, +% so we require 8.5. There are (as yet) no explicit 8.5-isms in the +% code, however. +% \begin{tcl} +package provide math::numtheory 1.1.1 +namespace eval ::math::numtheory { + namespace export isprime +} +% +% \end{tcl} +% Additional procedures are placed into a separate file primes.tcl, +% sourced from the primary. +% \begin{tcl} +%<*pkg_primes> +# primes.tcl -- +# Provide additional procedures for the number theory package +# +namespace eval ::math::numtheory { + variable primes {2 3 5 7 11 13 17} + variable nextPrimeCandidate 19 + variable nextPrimeIncrement 1 ;# Examine numbers 6n+1 and 6n+5 + + namespace export firstNprimes primesLowerThan primeFactors uniquePrimeFactors factors \ + totient moebius legendre jacobi gcd lcm \ + numberPrimesGauss numberPrimesLegendre numberPrimesLegendreModified +} + +% +% \end{tcl} +% \setnamespace{math::numtheory} +% +% \Tcl lib has its own test file boilerplate. +% We require tcltest 2.1 to allow the definition of a custom matcher +% comparing lists of integers +% \begin{tcl} +%<*test_primes> +# -*- tcl -*- +# primes.test -- +# Additional test cases for the ::math::numtheory package +# +# Note: +# The tests assume tcltest 2.1, in order to compare +# list of integer results + +# ------------------------------------------------------------------------- + +% +%<*test_common> +source [file join\ + [file dirname [file dirname [file join [pwd] [info script]]]]\ + devtools testutilities.tcl] + +testsNeedTcl 8.5 +testsNeedTcltest 2.1 + +% +%<*test_primes> +support { + useLocal math.tcl math +} + +% +%<*test_common> +testing { + useLocal numtheory.tcl math::numtheory +} + +% +% \end{tcl} +% and a bit more for the additional tests. This is where tcltest 2.1 +% is required +% \begin{tcl} +%<*test_primes> +proc matchLists { expected actual } { + set match 1 + foreach a $actual e $expected { + if { $a != $e } { + set match 0 + break + } + } + return $match +} +customMatch equalLists matchLists + +% +% \end{tcl} +% +% And the same is true for the manpage. +% \begin{tcl} +%<*man> +[comment { + __Attention__ This document is a generated file. + It is not the true source. + The true source is + + numtheory.dtx + + To make changes edit the true source, and then use + + sak.tcl docstrip/regen modules/math + + to update all generated files. +}] +[vset VERSION 1.1.1] +[manpage_begin math::numtheory n [vset VERSION]] +[keywords {number theory}] +[keywords prime] +[copyright "2010 Lars Hellstr\u00F6m\ + "] +[moddesc {Tcl Math Library}] +[titledesc {Number Theory}] +[category Mathematics] +[require Tcl [opt 8.5]] +[require math::numtheory [opt [vset VERSION]]] + +[description] +[para] +This package is for collecting various number-theoretic operations, with +a slight bias to prime numbers. + +[list_begin definitions] +% +% \end{tcl} +% +% +% \section{Primes} +% +% The first operation provided is |isprime|, which +% tests if an integer is a prime. +% \begin{tcl} +%<*man> +[call [cmd math::numtheory::isprime] [arg N] [ + opt "[arg option] [arg value] ..." +]] + The [cmd isprime] command tests whether the integer [arg N] is a + prime, returning a boolean true value for prime [arg N] and a + boolean false value for non-prime [arg N]. The formal definition of + 'prime' used is the conventional, that the number being tested is + greater than 1 and only has trivial divisors. + [para] + + To be precise, the return value is one of [const 0] (if [arg N] is + definitely not a prime), [const 1] (if [arg N] is definitely a + prime), and [const on] (if [arg N] is probably prime); the latter + two are both boolean true values. The case that an integer may be + classified as "probably prime" arises because the Miller-Rabin + algorithm used in the test implementation is basically probabilistic, + and may if we are unlucky fail to detect that a number is in fact + composite. Options may be used to select the risk of such + "false positives" in the test. [const 1] is returned for "small" + [arg N] (which currently means [arg N] < 118670087467), where it is + known that no false positives are possible. + [para] + + The only option currently defined is: + [list_begin options] + [opt_def -randommr [arg repetitions]] + which controls how many times the Miller-Rabin test should be + repeated with randomly chosen bases. Each repetition reduces the + probability of a false positive by a factor at least 4. The + default for [arg repetitions] is 4. + [list_end] + Unknown options are silently ignored. + +% +% \end{tcl} +% Then we have |firstNprimes|, which returns a list containing +% the first |n| primes. +% \begin{tcl} +%<*man> +[call [cmd math::numtheory::firstNprimes] [arg N]] +Return the first N primes + +[list_begin arguments] +[arg_def integer N in] +Number of primes to return +[list_end] + +[call [cmd math::numtheory::primesLowerThan] [arg N]] +Return the prime numbers lower/equal to N + +[list_begin arguments] +[arg_def integer N in] +Maximum number to consider +[list_end] + +[call [cmd math::numtheory::primeFactors] [arg N]] +Return a list of the prime numbers in the number N + +[list_begin arguments] +[arg_def integer N in] +Number to be factorised +[list_end] + +% +% \end{tcl} +% Similarly |primesLowerThan| returns a list of the prime numbers +% which are less than |n|, or equal to it. +% \begin{tcl} +%<*man> +[call [cmd math::numtheory::primesLowerThan] [arg N]] +Return the prime numbers lower/equal to N + +[list_begin arguments] +[arg_def integer N in] +Maximum number to consider +[list_end] + +% +% \end{tcl} +% Then |primeFactors| returns the list of the prime numbers in |n|. +% \begin{tcl} +%<*man> +[call [cmd math::numtheory::primeFactors] [arg N]] +Return a list of the prime numbers in the number N + +[list_begin arguments] +[arg_def integer N in] +Number to be factorised +[list_end] + +% +% \end{tcl} +% And |uniquePrimeFactors| does the same, with duplicates removed. +% \begin{tcl} +%<*man> +[call [cmd math::numtheory::uniquePrimeFactors] [arg N]] +Return a list of the [emph unique] prime numbers in the number N + +[list_begin arguments] +[arg_def integer N in] +Number to be factorised +[list_end] + +% +% \end{tcl} +% |factors| returns all factors of |n|, not just just primes. +% \begin{tcl} +%<*man> +[call [cmd math::numtheory::factors] [arg N]] +Return a list of all [emph unique] factors in the number N, including 1 and N itself +[list_begin arguments] +[arg_def integer N in] +Number to be factorised +[list_end] + +% +% \end{tcl} +% |totient| computes the Euler totient for |n| +% \begin{tcl} +%<*man> +[call [cmd math::numtheory::totient] [arg N]] +Evaluate the Euler totient function for the number N (number of numbers +relatively prime to N) + +[list_begin arguments] +[arg_def integer N in] +Number in question +[list_end] + +% +% \end{tcl} +% |moebius| computes the Moebious function on |n|. +% \begin{tcl} +%<*man> +[call [cmd math::numtheory::moebius] [arg N]] +Evaluate the Moebius function for the number N + +[list_begin arguments] +[arg_def integer N in] +Number in question +[list_end] + +% +% \end{tcl} +% |legendre| computes the Legendre symbol (|a/p|). +% \begin{tcl} +%<*man> +[call [cmd math::numtheory::legendre] [arg a] [arg p]] +Evaluate the Legendre symbol (a/p) + +[list_begin arguments] +[arg_def integer a in] +Upper number in the symbol +[arg_def integer p in] +Lower number in the symbol (must be non-zero) +[list_end] + +% +% \end{tcl} +% |jacobi| compute the Jacobi symbol (|a/p|). +% \begin{tcl} +%<*man> +[call [cmd math::numtheory::jacobi] [arg a] [arg b]] +Evaluate the Jacobi symbol (a/b) + +[list_begin arguments] +[arg_def integer a in] +Upper number in the symbol +[arg_def integer b in] +Lower number in the symbol (must be odd) +[list_end] + +% +% \end{tcl} +% |gcd| computes the greatest common divisor of |n| and |m|. +% \begin{tcl} +%<*man> +[call [cmd math::numtheory::gcd] [arg m] [arg n]] +Return the greatest common divisor of [term m] and [term n] + +[list_begin arguments] +[arg_def integer m in] +First number +[arg_def integer n in] +Second number +[list_end] + +% +% \end{tcl} +% |lcm| computes the least common multiple of |n| and |m|. +% \begin{tcl} +%<*man> +[call [cmd math::numtheory::lcm] [arg m] [arg n]] +Return the lowest common multiple of [term m] and [term n] + +[list_begin arguments] +[arg_def integer m in] +First number +[arg_def integer n in] +Second number +[list_end] + +% +% \end{tcl} +% |numberPrimesGauss| estimates the number of primes below |n| +% using a formula by Gauss. +% \begin{tcl} +%<*man> +[call [cmd math::numtheory::numberPrimesGauss] [arg N]] +Estimate the number of primes according the formula by Gauss. + +[list_begin arguments] +[arg_def integer N in] +Number in question +[list_end] + +% +% \end{tcl} +% |numberPrimesLegendre| estimates the number of primes below |n| +% using a formula by Legendre. +% \begin{tcl} +%<*man> +[call [cmd math::numtheory::numberPrimesLegendre] [arg N]] +Estimate the number of primes according the formula by Legendre. + +[list_begin arguments] +[arg_def integer N in] +Number in question +[list_end] + +% +% \end{tcl} +% |numberPrimesLegendreModified| estimates the number of primes below +% |n| using Legendre's modified formula. +% \begin{tcl} +%<*man> +[call [cmd math::numtheory::numberPrimesLegendreModified] [arg N]] +Estimate the number of primes according the modified formula by Legendre. + +[list_begin arguments] +[arg_def integer N in] +Number in question +[list_end] + +% +% \end{tcl} +% +% +% \subsection{Trial division} +% +% As most books on primes will tell you, practical primality +% testing algorithms typically start with trial division by a list +% of small known primes to weed out the low hanging fruit. This is +% also an opportunity to handle special cases that might arise for +% very low numbers (e.g.\ $2$ is a prime despite being even). +% +% \begin{proc}{prime_trialdivision} +% This procedure is meant to be called as +% \begin{quote} +% |prime_trialdivision| \word{$n$} +% \end{quote} +% from \emph{within} a procedure that returns |1| if $n$ is a prime +% and |0| if it is not. It does not return anything particular, but +% \emph{it causes its caller to return provided} it is able to +% decide what its result should be. This means one can slap it in +% as the first line of a primality checker procedure, and then on +% lines two and forth worry only about the nontrivial cases. +% \begin{tcl} +%<*pkg> +proc ::math::numtheory::prime_trialdivision {n} { + if {$n<2} then {return -code return 0} +% \end{tcl} +% Integers less than $2$ aren't primes.\footnote{ +% Well, at least as one usually defines the term for integers. +% When considering the concept of prime in more general rings, +% one may have to settle with accepting all associates of primes +% as primes as well. +% } This saves us many worries by excluding negative numbers from +% further considerations. +% \begin{tcl} + if {$n<4} then {return -code return 1} +% \end{tcl} +% Everything else below \(2^2 = 4\) (i.e., $2$ and $3$) are primes. +% \begin{tcl} + if {$n%2 == 0} then {return -code return 0} +% \end{tcl} +% Remaining even numbers are then composite. +% \begin{tcl} + if {$n<9} then {return -code return 1} +% \end{tcl} +% Now everything left below \(3^2 = 9\) (i.e., $5$ and $7$) are +% primes. Having decided those, we can now do trial division with +% $3$, $5$, and $7$ in one go. +% \begin{tcl} + if {$n%3 == 0} then {return -code return 0} + if {$n%5 == 0} then {return -code return 0} + if {$n%7 == 0} then {return -code return 0} +% \end{tcl} +% Any numbers less that \(11^2 = 121\) not yet eliminated are +% primes; above that we know nothing. +% \begin{tcl} + if {$n<121} then {return -code return 1} +} +% +% \end{tcl} +% This procedure could be extended with more primes, pushing the +% limit of what can be decided further up, but the returns are +% diminishing, so we might be better off with a different method +% for testing primality. No analysis of where the cut-off point +% lies have been conducted (i.e., $7$ as last prime for trial +% division was picked arbitrarily), but note that the optimum +% probably depends on what distribution the input values will have. +% +% \begin{tcl} +%<*test> +test prime_trialdivision-1 "Trial division of 1" -body { + ::math::numtheory::prime_trialdivision 1 +} -returnCodes 2 -result 0 +test prime_trialdivision-2 "Trial division of 2" -body { + ::math::numtheory::prime_trialdivision 2 +} -returnCodes 2 -result 1 +test prime_trialdivision-3 "Trial division of 6" -body { + ::math::numtheory::prime_trialdivision 6 +} -returnCodes 2 -result 0 +test prime_trialdivision-4 "Trial division of 7" -body { + ::math::numtheory::prime_trialdivision 7 +} -returnCodes 2 -result 1 +test prime_trialdivision-5 "Trial division of 101" -body { + ::math::numtheory::prime_trialdivision 101 +} -returnCodes 2 -result 1 +test prime_trialdivision-6 "Trial division of 105" -body { + ::math::numtheory::prime_trialdivision 105 +} -returnCodes 2 -result 0 +% \end{tcl} +% Note that extending the number of primes for trial division is +% likely to change the results in the following two tests ($121$ +% is composite, $127$ is prime). +% \begin{tcl} +test prime_trialdivision-7 "Trial division of 121" -body { + ::math::numtheory::prime_trialdivision 121 +} -returnCodes 0 -result "" +test prime_trialdivision-8 "Trial division of 127" -body { + ::math::numtheory::prime_trialdivision 127 +} -returnCodes 0 -result "" +% +% \end{tcl} +% \end{proc} +% +% +% \subsection{Pseudoprimality tests} +% +% After trial division, the next thing tried is usually to test the +% claim of Fermat's little theorem: if $n$ is a prime, then \(a^{n-1} +% \equiv 1 \pmod{n}\) for all integers $a$ that are not multiples of +% $n$, in particular those \(0 < a < n\); one picks such an $a$ (more +% or less at random) and computes $a^{n-1} \bmod n$. Numbers that +% pass are said to be \emph{(Fermat) pseudoprimes (to base $a$)}. +% Most composite numbers quickly fail this test. +% (One particular class that fails are the powers of primes, since +% the group of invertible elements in $\mathbb{Z}_n$ for \(n = p^{k+1}\) +% is cyclic\footnote{ +% The easiest way to see that it is cyclic is probably to exhibit +% an element of order $(p -\nobreak 1) p^k$. A good start is to +% pick a primitive root $a$ of $\mathbb{Z}_p$ and compute its order +% modulo $p^{k+1}$; this has to be a number on the form $(p +% -\nobreak 1) p^r$. If \(r=k\) then $a$ is a primitive root and we're +% done, otherwise $(p +\nobreak 1) a$ will be a primitive root +% because $p+1$ can be shown to have order $p^k$ modulo $n$ and the +% least common multiple of $(p -\nobreak 1) p^r$ and $p^k$ is +% $(p -\nobreak 1) p^k$. To exhibit the order of $p+1$, one may +% use induction on $k$ to show that \( (1 +\nobreak p)^N \equiv 1 +% \pmod{p^{k+1}}\) implies \(p^k \mid N\); in \((1 +\nobreak p)^N = +% \sum_{i=0}^N \binom{N}{i} p^i\), the induction hypothesis implies +% all terms with \(i>1\) vanish modulo $p^{k+1}$, leaving just +% \(1+Np \equiv 1 \pmod{p^{k+1}}\). +% } of order $(p -\nobreak 1) p^k$ rather than order $p^{k+1}-1$. +% Therefore it is only to bases $a$ of order dividing $p-1$ (i.e., a +% total of $p-1$ out of $p^{k+1}-1$) that prime powers are +% pseudoprimes. The chances of picking one of these are generally +% rather slim.) +% +% Unfortunately, there are also numbers (the so-called \emph{Carmichael +% numbers}) which are pseudoprimes to every base $a$ they are coprime +% with. While the above trial division by $2$, $3$, $5$, and $7$ would +% already have eliminated all Carmichael numbers below \(29341 = 13 +% \cdot 37 \cdot 61\), their existence means that there is a +% population of nonprimes which a Fermat pseudoprimality test is very +% likely to mistake for primes; this would usually not be acceptable. +% +% \begin{proc}{Miller--Rabin} +% The Miller--Rabin test is a slight variation on the Fermat test, +% where the computation of $a^{n-1} \bmod n$ is structured so that +% additional consequences of $n$ being a prime can be tested. +% Rabin~\cite{Rabin} +% proved that any composite $n$ will for this test be revealed as +% such by at least $3/4$ of all bases $a$, thus making it a valid +% probabilistic test. (Miller~\cite{Miller} had first designed it as +% a deterministic polynomial algorithm, but in that case the proof +% that it works relies on the generalised Riemann hypothesis.) +% +% Given natural numbers $s$ and $d$ such that \(n-1 = 2^s d\), the +% computation of $a^{n-1}$ is organised as $(a^d)^{2^s}$, where the +% $s$ part is conveniently performed by squaring $s$ times. This is +% of little consequence when $n$ is not a pseudoprime since one +% will simply arrive at some \(a^{n-1} \not\equiv 1 \pmod{n}\), but +% in the case that $n$ is a pseudoprime these repeated squarings will +% exhibit some $x$ such that \(x^2 \equiv 1 \pmod{n}\), and this +% makes it possible to test another property $n$ must have if it is +% prime, namely that such an \(x \equiv \pm 1 \pmod{n}\). +% +% That implication is of course well known for real (and complex) +% numbers, but even though what we're dealing with here is rather +% residue classes modulo an integer, the proof that it holds is +% basically the same. If $n$ is a prime, then the residue class +% ring $\mathbb{Z}_n$ is a field, and hence the ring +% $\mathbb{Z}_n[x]$ of polynomials over that field is a Unique +% Factorisation Domain. As it happens, \(x^2 \equiv 1 \pmod{n}\) is +% a polynomial equation, and $x^2-1$ has the known factorisation +% \((x -\nobreak 1) (x +\nobreak 1)\). Since factorisations are +% unique, and any zero $a$ of $x^2-1$ would give rise to a factor +% $x-a$, it follows that \(x^2 \equiv 1 \pmod{n}\) implies \(x +% \equiv 1 \pmod{n}\) or \(x \equiv -1 \pmod{n}\), as claimed. +% But this assumes $n$ is a prime. +% +% If instead \(n = pq\) where \(p,q > 2\) are coprime, then there +% will be additional solutions to \(x^2 \equiv 1 \pmod{n}\). +% For example, if \(x \equiv 1 \pmod{p}\) and \(x \equiv -1 +% \pmod{q}\) (and such $x$ exist by the Chinese Remainder Theorem), +% then \(x^2 \equiv 1 \pmod{p}\) and \(x^2 \equiv 1 \pmod{q}\), +% from which follows \(x^2 \equiv 1 \pmod{pq}\), but \(x \not\equiv +% 1 \pmod{n}\) since \(x-1 \equiv -2 \not\equiv 0 \pmod{q}\), and +% \(x \not\equiv -1 \pmod{n}\) since \(x+1 \equiv 2 \not\equiv 0 +% \pmod{p}\). The same argument applies when \(x \equiv -1 \pmod{p}\) +% and \(x \equiv 1 \pmod{q}\), and in general, if $n$ has $k$ +% distinct odd prime factors then one may construct $2^k$ distinct +% solutions \(0 +proc ::math::numtheory::Miller--Rabin {n s d a} { + set x 1 + while {$d>1} { + if {$d & 1} then {set x [expr {$x*$a % $n}]} + set a [expr {$a*$a % $n}] + set d [expr {$d >> 1}] + } + set x [expr {$x*$a % $n}] +% \end{tcl} +% The second part will $s-1$ times square $x$, while checking each +% value for being \(\equiv \pm 1 \pmod{n}\). For most part, $-1$ +% means everything is OK (any subsequent square would only +% yield~$1$) whereas $1$ arrived at without a previous $-1$ signals +% that $n$ cannot be prime. The only exception to the latter is +% that $1$ before the first squaring (already \(a^d \equiv 1 +% \pmod{n}\)) is OK as well. +% \begin{tcl} + if {$x == 1} then {return 0} + for {} {$s>1} {incr s -1} { + if {$x == $n-1} then {return 0} + set x [expr {$x*$x % $n}] + if {$x == 1} then {return 1} + } +% \end{tcl} +% There is no need to square $x$ the $s$th time, because if at this +% point \(x \not\equiv -1 \pmod{n}\) then $n$ cannot be a prime; if +% \(x^2 \not\equiv 1 \pmod{n}\) it would fail to be a pseudoprime +% and if \(x^2 \equiv 1 \pmod{n}\) then $x$ would be a nonstandard +% square root of $1 \pmod{n}$, but it is not necessary to find out +% which of these cases is at hand. +% \begin{tcl} + return [expr {$x != $n-1}] +} +% +% \end{tcl} +% +% As for testing, the minimal allowed value of $n$ is $3$, which +% is a prime. +% \begin{tcl} +%<*test> +test Miller--Rabin-1.1 "Miller--Rabin 3" -body { + list [::math::numtheory::Miller--Rabin 3 1 1 1]\ + [::math::numtheory::Miller--Rabin 3 1 1 2] +} -result {0 0} +% \end{tcl} +% To exercise the first part of the procedure, one may consider the +% case \(s=1\) and \(d = 2^2+2^0 = 5\), i.e., \(n=11\). Here, \(2^5 +% \equiv -1 \pmod{11}\) whereas \(4^5 \equiv 1^5 \equiv 1 +% \pmod{11}\). A bug on the lines of not using the right factors in +% the computation of $a^d$ would most likely end up with something +% different here. +% \begin{tcl} +test Miller--Rabin-1.2 "Miller--Rabin 11" -body { + list [::math::numtheory::Miller--Rabin 11 1 5 1]\ + [::math::numtheory::Miller--Rabin 11 1 5 2]\ + [::math::numtheory::Miller--Rabin 11 1 5 4] +} -result {0 0 0} +% \end{tcl} +% $27$ will on the other hand be exposed as composite by most bases, +% but $1$ and $-1$ do not spot it. It is known from the argument +% about prime powers above that at least one of $2$ and \(8 = (3 +% +\nobreak 1) \cdot 2\) is a primitive root of $1$ in +% $\mathbb{Z}_{27}$; it turns out to be $2$. +% \begin{tcl} +test Miller--Rabin-1.3 "Miller--Rabin 27" -body { + list [::math::numtheory::Miller--Rabin 27 1 13 1]\ + [::math::numtheory::Miller--Rabin 27 1 13 2]\ + [::math::numtheory::Miller--Rabin 27 1 13 3]\ + [::math::numtheory::Miller--Rabin 27 1 13 4]\ + [::math::numtheory::Miller--Rabin 27 1 13 8]\ + [::math::numtheory::Miller--Rabin 27 1 13 26] +} -result {0 1 1 1 1 0} +% \end{tcl} +% Taking \(n = 65 = 1 + 2^6 = 5 \cdot 13\) instead focuses on the +% second part of the procedure. By carefully choosing the base, it +% is possible to force the result to come from: +% \begin{tcl} +test Miller--Rabin-1.4 "Miller--Rabin 65" -body { +% \end{tcl} +% The first |return| +% \begin{tcl} + list [::math::numtheory::Miller--Rabin 65 6 1 1]\ +% \end{tcl} +% the second |return|, first iteration +% \begin{tcl} + [::math::numtheory::Miller--Rabin 65 6 1 64]\ +% \end{tcl} +% the third |return|, first iteration---\(14 \equiv 1 \pmod{13}\) +% but \(14 \equiv -1 \pmod{5}\) +% \begin{tcl} + [::math::numtheory::Miller--Rabin 65 6 1 14]\ +% \end{tcl} +% the second |return|, second iteration +% \begin{tcl} + [::math::numtheory::Miller--Rabin 65 6 1 8]\ +% \end{tcl} +% the third |return|, second iteration---\(27 \equiv 1 \pmod{13}\) +% but \(27^2 \equiv 2^2 \equiv -1 \pmod{5}\) +% \begin{tcl} + [::math::numtheory::Miller--Rabin 65 6 1 27]\ +% \end{tcl} +% the final |return| +% \begin{tcl} + [::math::numtheory::Miller--Rabin 65 6 1 2] +} -result {0 0 1 0 1 1} +% \end{tcl} +% There does however not seem to be any \(n=65\) choice of $a$ which +% would get a |0| out of the final |return|. +% +% An $n$ which allows fully exercising the second part of the +% procedure is \(17 \cdot 257 = 4369\), for which \(s=4\) +% and \(d=273\). In order to have \(x^{2^{s-1}} \equiv -1 +% \pmod{n}\), it is necessary to have \(x^8 \equiv -1\) modulo both +% $17$ and $257$, which is possible since the invertible elements +% of $\mathbb{Z}_{17}$ form a cyclic group of order $16$ and the +% invertible elements of $\mathbb{Z}_{257}$ form a cyclic group of +% order $256$. Modulo $17$, an element of order $16$ is $3$, +% whereas modulo $257$, an element of order $16$ is $2$. +% +% There is an extra complication in that what the caller can +% specify is not the $x$ to be repeatedly squared, but the $a$ +% which satisfies \(x \equiv a^d \pmod{n}\). Since \(d=273\) is +% odd, raising something to that power is an invertible operation +% modulo both $17$ and $257$, but it is necessary to figure out +% what the inverse is. Since \(273 \equiv 1 \pmod{16}\), it turns +% out that \(a^d \equiv a \pmod{17}\), and \(x=3\) becomes \(a=3\). +% From \(273 \equiv 17 \pmod{256}\), it instead follows that \(x +% \equiv a^d \pmod{257}\) is equivalent to \(a \equiv x^e +% \pmod{257}\), where \(17e \equiv 1 \pmod{256}\). This has the +% solution \(e = 241\), so the $a$ which makes \(x=2\) is \(a +% = 2^{241} \bmod 257\). However, since \(x=2\) was picked on +% account of having order $16$, hence \(2^{16} \equiv 1 +% \pmod{257}\), and \(241 \equiv 1 \pmod{16}\), it again turns out +% that \(x=2\) becomes \(a=2\). +% +% For \(a = 2\), one may observe that \(a^{2^1} \equiv 4 +% \pmod{257}\), \(a^{2^2} \equiv 16 \pmod{257}\), \(a^{2^3} \equiv +% -1 \pmod{257}\), and \(a^{2^4} \equiv 1 \pmod{257}\). For +% \(a=3\), one may observe that \(a^{2^1} \equiv 9 \pmod{17}\), +% \(a^{2^2} \equiv 13 \pmod{17}\), \(a^{2^3} \equiv -1 \pmod{17}\), +% and \(a^{2^4} \equiv 1 \pmod{17}\). For solving simultaneous +% equivalences, it is furthermore useful to observe that \(2057 +% \equiv 1 \pmod{257}\) and \(2057 \equiv 0 \pmod{17}\) whereas +% \(2313 \equiv 1 \pmod{17}\) and \(2313 \equiv 0 \pmod{257}\). +% \begin{tcl} +test Miller--Rabin-1.5 "Miller--Rabin 17*257" -body { +% \end{tcl} +% In order to end up at the first |return|, it is necessary to take +% \(a \equiv 1 \pmod{17}\) and \(a \equiv 1 \pmod{257}\); the +% solution \(a=1\) is pretty obvious. +% \begin{tcl} + list [::math::numtheory::Miller--Rabin 4369 4 273 1]\ +% \end{tcl} +% In order to end up at the second |return| of the first iteration, +% it is necessary to take \(a \equiv -1 \pmod{17}\) and +% \(a \equiv -1 \pmod{257}\); the solution \(a \equiv -1 \pmod{n}\) +% is again pretty obvious. +% \begin{tcl} + [::math::numtheory::Miller--Rabin 4369 4 273 4368]\ +% \end{tcl} +% Hitting the third |return| at the first iteration can be achieved +% with \(a \equiv -1 \pmod{17}\) and \(a \equiv 1 \pmod{257}\); +% now a solution is \(a \equiv 2057 - 2313 \equiv 4113 \pmod{n}\). +% \begin{tcl} + [::math::numtheory::Miller--Rabin 4369 4 273 4113]\ +% \end{tcl} +% Hitting the second |return| at the second iteration happens if +% \(a^2 \equiv -1\) modulo both prime factors, i.e., for \(a \equiv +% 16 \pmod{257}\) and \(a \equiv 13 \pmod{17}\). This has the +% solution \(a \equiv 16 \cdot 2057 + 13 \cdot 2313 \equiv 1815 +% \pmod{n}\). +% \begin{tcl} + [::math::numtheory::Miller--Rabin 4369 4 273 1815]\ +% \end{tcl} +% To hit the third |return| at the second iteration, one may keep +% \(a \equiv 16 \pmod{257}\) but take \(a \equiv 1 \pmod{17}\). This +% has the solution \(a \equiv 16 \cdot 2057 + 1 \cdot 2313 \equiv 273 +% \pmod{n}\). +% \begin{tcl} + [::math::numtheory::Miller--Rabin 4369 4 273 273]\ +% \end{tcl} +% Hitting the second |return| at the third and final iteration happens +% if \(a^4 \equiv -1\) modulo both prime factors, i.e., for \(a \equiv +% 4 \pmod{257}\) and \(a \equiv 9 \pmod{17}\). This has the +% solution \(a \equiv 4 \cdot 2057 + 9 \cdot 2313 \equiv 2831 +% \pmod{n}\). +% \begin{tcl} + [::math::numtheory::Miller--Rabin 4369 4 273 2831]\ +% \end{tcl} +% And as before, to hit the third |return| at the third and final +% iteration one may keep the above \(a \equiv 9 \pmod{17}\) but +% change the other to \(a \equiv 1 \pmod{257}\). This has the +% solution \(a \equiv 1 \cdot 2057 + 9 \cdot 2313 \equiv 1029 +% \pmod{n}\). +% \begin{tcl} + [::math::numtheory::Miller--Rabin 4369 4 273 1029]\ +% \end{tcl} +% To get a |0| out of the fourth |return|, one takes \(a \equiv +% 2 \pmod{257}\) and \(a \equiv 3 \pmod{17}\); this means \(a \equiv +% 2 \cdot 2057 + 3 \cdot 2313 \equiv 2315 \pmod{n}\). +% \begin{tcl} + [::math::numtheory::Miller--Rabin 4369 4 273 2315]\ +% \end{tcl} +% Finally, to get a |1| out of the fourth |return|, one may take +% \(a \equiv 1 \pmod{257}\) and \(a \equiv 3 \pmod{17}\); this means +% \(a \equiv 1 \cdot 2057 + 3 \cdot 2313 \equiv 258 \pmod{n}\). +% \begin{tcl} + [::math::numtheory::Miller--Rabin 4369 4 273 258] +} -result {0 0 1 0 1 0 1 0 1} +% \end{tcl} +% It would have been desirable from a testing point of view to also +% find a value of $a$ that would make \(a^{n-1} \equiv -1 +% \pmod{n}\), since such an $a$ would catch an implementation error +% of running the squaring loop one step too far, but that does not +% seem possible; picking \(n=pq\) such that both $p-1$ and $q-1$ +% are divisible by some power of $2$ implies that $n-1$ is +% divisible by the same power of $2$. +% \end{proc} +% +% A different kind of test is to verify some exceptional numbers and +% boundaries that the |isprime| procedure relies on. First, $1373653$ +% appears prime when \(a=2\) or \(a=3\), but \(a=5\) is a witness to +% its compositeness. +% \begin{tcl} +test Miller--Rabin-2.1 "Miller--Rabin 1373653" -body { + list\ + [::math::numtheory::Miller--Rabin 1373653 2 343413 2]\ + [::math::numtheory::Miller--Rabin 1373653 2 343413 3]\ + [::math::numtheory::Miller--Rabin 1373653 2 343413 5] +} -result {0 0 1} +% \end{tcl} +% $25326001$ is looking like a prime also to \(a=5\), but \(a=7\) +% exposes it. +% \begin{tcl} +test Miller--Rabin-2.2 "Miller--Rabin 25326001" -body { + list\ + [::math::numtheory::Miller--Rabin 25326001 4 1582875 2]\ + [::math::numtheory::Miller--Rabin 25326001 4 1582875 3]\ + [::math::numtheory::Miller--Rabin 25326001 4 1582875 5]\ + [::math::numtheory::Miller--Rabin 25326001 4 1582875 7] +} -result {0 0 0 1} +% \end{tcl} +% $3215031751$ is a tricky composite that isn't exposed even by +% \(a=7\), but \(a=11\) will see through it. +% \begin{tcl} +test Miller--Rabin-2.3 "Miller--Rabin 3215031751" -body { + list\ + [::math::numtheory::Miller--Rabin 3215031751 1 1607515875 2]\ + [::math::numtheory::Miller--Rabin 3215031751 1 1607515875 3]\ + [::math::numtheory::Miller--Rabin 3215031751 1 1607515875 5]\ + [::math::numtheory::Miller--Rabin 3215031751 1 1607515875 7]\ + [::math::numtheory::Miller--Rabin 3215031751 1 1607515875 11] +} -result {0 0 0 0 1} +% \end{tcl} +% Otherwise the lowest composite that these four will fail for is +% $118670087467$. +% \begin{tcl} +test Miller--Rabin-2.4 "Miller--Rabin 118670087467" -body { + list\ + [::math::numtheory::Miller--Rabin 118670087467 1 59335043733 2]\ + [::math::numtheory::Miller--Rabin 118670087467 1 59335043733 3]\ + [::math::numtheory::Miller--Rabin 118670087467 1 59335043733 5]\ + [::math::numtheory::Miller--Rabin 118670087467 1 59335043733 7]\ + [::math::numtheory::Miller--Rabin 118670087467 1 59335043733 11] +} -result {0 0 0 0 1} +% +% \end{tcl} +% +% +% \subsection{Putting it all together} +% +% \begin{proc}{isprime} +% The user level command for testing primality of an integer $n$ is +% |isprime|. It has the call syntax +% \begin{quote} +% |math::numtheory::isprime| \word{n} +% \begin{regblock}[\regstar]\word{option} +% \word{value}\end{regblock} +% \end{quote} +% where the options may be used to influence the exact algorithm +% being used. The call returns +% \begin{description} +% \item[0] if $n$ is found to be composite, +% \item[1] if $n$ is found to be prime, and +% \item[on] if $n$ is probably prime. +% \end{description} +% The reason there might be \emph{some} uncertainty is that the +% primality test used is basically a probabilistic test for +% compositeness---it may fail to find a witness for the +% compositeness of a composite number $n$, even if the probability +% of doing so is fairly low---and to be honest with the user, the +% outcomes of ``definitely prime'' and ``probably prime'' return +% different results. Since |on| is true when used as a boolean, you +% usually need not worry about this fine detail. Also, for \(n < +% 10^{11}\) (actually a little more) the primality test is +% deterministic, so you only encounter the ``probably prime'' +% result for fairly high $n$. +% +% At present, the only option that is implemented is |-randommr|, +% which controls how many rounds (by default 4) of the |Miller--Rabin| +% test with random bases are run before returing |on|. Other options +% are silently ignored. +% +% \begin{tcl} +%<*pkg> +proc ::math::numtheory::isprime {n args} { + prime_trialdivision $n +% \end{tcl} +% Implementation-wise, |isprime| begins with |prime_trialdivision|, +% but relies on the Miller--Rabin test after that. To that end, it +% must compute $s$ and $d$ such that \(n = d 2^s + 1\); while this +% is fairly quick, it's nice not having to do it more than once, +% which is why this step wasn't made part of the |Miller--Rabin| +% procedure. +% \begin{tcl} + set d [expr {$n-1}]; set s 0 + while {($d&1) == 0} { + incr s + set d [expr {$d>>1}] + } +% \end{tcl} +% The deterministic sequence of Miller--Rabin tests combines +% information from \cite{PSW80,Jaeschke}, but most of these +% numbers may also be found on Wikipedia~\cite{Wikipedia}. +% \begin{tcl} + if {[Miller--Rabin $n $s $d 2]} then {return 0} + if {$n < 2047} then {return 1} + if {[Miller--Rabin $n $s $d 3]} then {return 0} + if {$n < 1373653} then {return 1} + if {[Miller--Rabin $n $s $d 5]} then {return 0} + if {$n < 25326001} then {return 1} + if {[Miller--Rabin $n $s $d 7] || $n==3215031751} then {return 0} + if {$n < 118670087467} then {return 1} +% \end{tcl} +% \(3215031751 = 151 \cdot 751 \cdot 28351\) is a Carmichael +% number~\cite[p.\,1022]{PSW80}. +% +% Having exhausted this list of limits below which |Miller--Rabin| +% for \(a=2,3,5,7\) detects all composite numbers, we now have to +% resort to picking bases at random and hoping we find one which +% would reveal a composite $n$. In the future, one might want to +% add the possibility of using a deterministic test (such as the +% AKR~\cite{CL84} or AKS~\cite{AKS04} test) here instead. +% +% \begin{tcl} + array set O {-randommr 4} + array set O $args + for {set i $O(-randommr)} {$i >= 1} {incr i -1} { + if {[Miller--Rabin $n $s $d [expr {( +% \end{tcl} +% +% The probabilistic sequence of Miller--Rabin tests employs +% \Tcl's built-in pseudorandom number generator |rand()| for +% choosing bases, as this does not seem to be an application that +% requires high quality randomness. It may however be observed +% that since by now \(n > 10^{11}\), the space of possible bases $a$ +% is always several times larger than the state space of |rand()|, +% so there may be a point in tweaking the PRNG to avoid some less +% useful values of $a$. +% +% It is a trivial observation that the intermediate $x$ values +% computed by |Miller--Rabin| for \(a=a_1a_2\) are simply the +% products of the corresponding values computed for \(a=a_1\) and +% \(a=a_2\) respectively---hence chances are that if no +% compositeness was detected for \(a=a_1\) or \(a=a_2\) then it +% won't be detected for \(a=a_1a_2\) either. There is a slight +% chance that something interesting could happen if \(a_1^{d2^k} +% \equiv -1 \equiv a_2^{d2^k} \pmod{n}\) for some \(k>0\), since in +% that case \((a_1a_2)^{d2^k} \equiv 1 \pmod{n}\) whereas no direct +% conclusion can be reached about $(a_1a_2)^{d2^{k-1}}$, but this +% seems a rather special case (and cannot even occur if \(n +% \equiv 3 \pmod{4}\) since in that case \(s=1\)), so it seems +% natural to prefer $a$ that are primes. Generating only prime $a$ +% would be much work, but avoiding numbers divisible by $2$ or $3$ +% is feasible. +% +% First turn |rand()| back into the integer it internally is, and +% adjust it to be from $0$ and up. +% \begin{tcl} + (round(rand()*0x100000000)-1) +% \end{tcl} +% Then multiply by $3$ and set the last bit. This has the effect +% that the range of the PRNG is now $\{1,3,7,9,13,15,\dotsb, +% 6n +\nobreak 1, 6n +\nobreak 3, \dotsb \}$. +% \begin{tcl} + *3 | 1) +% \end{tcl} +% Finally add $10$ so that we get $11$, $13$, $17$, $19$, \dots +% \begin{tcl} + + 10 + }]]} then {return 0} + } +% \end{tcl} +% That ends the |for| loop for |Miller--Rabin| with random bases. +% At this point, since the number in question passed the requested +% number of Miller--Rabin rounds, it is proclaimed to be ``probably +% prime''. +% \begin{tcl} + return on +} + +# Add the additional procedures +# +source [file join [file dirname [info script]] primes.tcl] +% +% \end{tcl} +% +% Tests of |isprime| would mostly be asking ``is $n$ a prime'' for +% various interesting $n$. Several values of $n$ should be the same +% as the previous tests: +% \begin{tcl} +%<*test> +test isprime-1.1 "1 is not prime" -body { + ::math::numtheory::isprime 1 +} -result 0 +test isprime-1.2 "0 is not prime" -body { + ::math::numtheory::isprime 0 +} -result 0 +test isprime-1.3 "-2 is not prime" -body { + ::math::numtheory::isprime -2 +} -result 0 +test isprime-1.4 "2 is prime" -body { + ::math::numtheory::isprime 2 +} -result 1 +test isprime-1.5 "6 is not prime" -body { + ::math::numtheory::isprime 6 +} -result 0 +test isprime-1.6 "7 is prime" -body { + ::math::numtheory::isprime 7 +} -result 1 +test isprime-1.7 "101 is prime" -body { + ::math::numtheory::isprime 101 +} -result 1 +test isprime-1.8 "105 is not prime" -body { + ::math::numtheory::isprime 105 +} -result 0 +test isprime-1.9 "121 is not prime" -body { + ::math::numtheory::isprime 121 +} -result 0 +test isprime-1.10 "127 is prime" -body { + ::math::numtheory::isprime 127 +} -result 1 +test isprime-1.11 "4369 is not prime" -body { + ::math::numtheory::isprime 4369 +} -result 0 +test isprime-1.12 "1373653 is not prime" -body { + ::math::numtheory::isprime 1373653 +} -result 0 +test isprime-1.13 "25326001 is not prime" -body { + ::math::numtheory::isprime 25326001 +} -result 0 +test isprime-1.14 "3215031751 is not prime" -body { + ::math::numtheory::isprime 3215031751 +} -result 0 +% \end{tcl} +% To get consistent results for large non-primes, it is necessary +% to reduce the number of random rounds and\slash or reset the PRNG. +% \begin{tcl} +test isprime-1.15 "118670087467 may appear prime, but isn't" -body { + expr srand(1) + list\ + [::math::numtheory::isprime 118670087467 -randommr 0]\ + [::math::numtheory::isprime 118670087467 -randommr 1] +} -result {on 0} +% \end{tcl} +% However, a few new can be added. On~\cite[p.\,925]{Jaeschke} we +% can read that \(p=22 \mkern1mu 754 \mkern1mu 930 \mkern1mu 352 +% \mkern1mu 733\) is a prime, and $p (3p -\nobreak 2)\) is a +% composite number that looks prime to |Miller--Rabin| for all +% \(a \in \{2,3,5,7,11,13,17,19,23,29\}\). +% \begin{tcl} +test isprime-1.16 "Jaeschke psi_10" -body { + expr srand(1) + set p 22754930352733 + set n [expr {$p * (3*$p-2)}] + list\ + [::math::numtheory::isprime $p -randommr 25]\ + [::math::numtheory::isprime $n -randommr 0]\ + [::math::numtheory::isprime $n -randommr 1] +} -result {on on 0} +% \end{tcl} +% On the same page it is stated that \(p=137 \mkern1mu 716 \mkern1mu +% 125 \mkern1mu 329 \mkern1mu 053\) is a prime such that +% $p (3p -\nobreak 2)\) is a composite number that looks prime to +% |Miller--Rabin| for all \(a \in +% \{2,3,5,7,11,13,17,19,23,29,31\}\). +% \begin{tcl} +test isprime-1.17 "Jaeschke psi_11" -body { + expr srand(1) + set p 137716125329053 + set n [expr {$p * (3*$p-2)}] + list\ + [::math::numtheory::isprime $p -randommr 25]\ + [::math::numtheory::isprime $n -randommr 0]\ + [::math::numtheory::isprime $n -randommr 1]\ + [::math::numtheory::isprime $n -randommr 2] +} -result {on on on 0} +% \end{tcl} +% RFC~2409~\cite{RFC2409} lists a number of primes (and primitive +% generators of their respective multiplicative groups). The +% smallest of these is defined as \(p = 2^{768} - 2^{704} - 1 + +% 2^{64} \cdot \left( [2^{638} \pi] + 149686 \right)\) (where the +% brackets probably denote rounding to the nearest integer), but +% since high precision (roughly $200$ decimal digits would be +% required) values of \(\pi = 3.14159\dots\) are a bit awkward to +% get hold of, we might as well use the stated hexadecimal digit +% expansion for~$p$. It might also be a good idea to verify that +% this is given with most significant digit first. +% \begin{tcl} +test isprime-1.18 "OAKLEY group 1 prime" -body { + set digits [join { + FFFFFFFF FFFFFFFF C90FDAA2 2168C234 C4C6628B 80DC1CD1 + 29024E08 8A67CC74 020BBEA6 3B139B22 514A0879 8E3404DD + EF9519B3 CD3A431B 302B0A6D F25F1437 4FE1356D 6D51C245 + E485B576 625E7EC6 F44C42E9 A63A3620 FFFFFFFF FFFFFFFF + } ""] + expr srand(1) + list\ + [::math::numtheory::isprime 0x$digits]\ + [::math::numtheory::isprime 0x[string reverse $digits]] +} -result {on 0} +% \end{tcl} +% +% A quite different thing to test is that the tweaked PRNG really +% produces only \(a \equiv 1,5 \pmod{6}\). +% \begin{tcl} +test isprime-2.0 "PRNG tweak" -setup { + namespace eval ::math::numtheory { + rename Miller--Rabin _orig_Miller--Rabin + proc Miller--Rabin {n s d a} { + expr {$a>7 && $a%6!=1 && $a%6!=5} + } + } +} -body { + ::math::numtheory::isprime 118670087467 -randommr 500 +} -result on -cleanup { + namespace eval ::math::numtheory { + rename Miller--Rabin "" + rename _orig_Miller--Rabin Miller--Rabin + } +} +% +% \end{tcl} +% \end{proc} +% +% \section {Add-ons} +% +% A number of additional functions around factoring numbers +% +% \begin{tcl} +%<*pkg_primes> +# ComputeNextPrime -- +# Determine the next prime +# +# Arguments: +# None +# +# Result: +# None +# +# Side effects: +# One prime added to the list of primes +# +# Note: +# Using a true sieve of Erathostenes might be faster, but +# this does work. Even computing the first ten thousand +# does not seem to be slow. +# +proc ::math::numtheory::ComputeNextPrime {} { + variable primes + variable nextPrimeCandidate + variable nextPrimeIncrement + + while {1} { + # + # Test the current candidate + # + set sqrtCandidate [expr {sqrt($nextPrimeCandidate)}] + + set isprime 1 + foreach p $primes { + if { $p > $sqrtCandidate } { + break + } + if { $nextPrimeCandidate % $p == 0 } { + set isprime 0 + break + } + } + + if { $isprime } { + lappend primes $nextPrimeCandidate + } + + # + # In any case get the next candidate + # + if { $nextPrimeIncrement == 1 } { + set nextPrimeIncrement 5 + set nextPrimeCandidate [expr {$nextPrimeCandidate + 4}] + } else { + set nextPrimeIncrement 1 + set nextPrimeCandidate [expr {$nextPrimeCandidate + 2}] + } + + if { $isprime } { + break + } + } +} + +# firstNprimes -- +# Return the first N primes +# +# Arguments: +# number Number of primes to return +# +# Result: +# List of the first $number primes +# +proc ::math::numtheory::firstNprimes {number} { + variable primes + + while { [llength $primes] < $number } { + ComputeNextPrime + } + + return [lrange $primes 0 [expr {$number-1}]] +} + +# primesLowerThan -- +# Return the primes lower than some threshold +# +# Arguments: +# threshold Threshold for the primes +# +# Result: +# List of primes lower/equal to the threshold +# +proc ::math::numtheory::primesLowerThan {threshold} { + variable primes + + while { [lindex $primes end] < $threshold } { + ComputeNextPrime + } + + set n 0 + foreach p $primes { + if { $p > $threshold } { + break + } else { + incr n + } + } + return [lrange $primes 0 [expr {$n-1}]] +} + +# primeFactors -- +# Determine the prime factors of a number +# +# Arguments: +# number Number to factorise +# +# Result: +# List of prime factors +# +proc ::math::numtheory::primeFactors {number} { + variable primes + + # + # Make sure we have enough primes + # + primesLowerThan [expr {sqrt($number)}] + + set factors {} + + set idx 0 + + while { $number > 1 } { + set p [lindex $primes $idx] + if {$p == {}} { + lappend factors $number + break + } + if { $number % $p == 0 } { + lappend factors $p + set number [expr {$number/$p}] + } else { + incr idx + } + } + + return $factors +} + +# uniquePrimeFactors -- +# Determine the unique prime factors of a number +# +# Arguments: +# number Number to factorise +# +# Result: +# List of unique prime factors +# +proc ::math::numtheory::uniquePrimeFactors {number} { + return [lsort -unique -integer [primeFactors $number]] +} + +# totient -- +# Evaluate the Euler totient function for a number +# +# Arguments: +# number Number in question +# +# Result: +# Totient of the given number (number of numbers +# relatively prime to the number) +# +proc ::math::numtheory::totient {number} { + set factors [uniquePrimeFactors $number] + + set totient 1 + + foreach f $factors { + set totient [expr {$totient * ($f-1)}] + } + + return $totient +} + +# factors -- +# Return all (unique) factors of a number +# +# Arguments: +# number Number in question +# +# Result: +# List of factors including 1 and the number itself +# +# Note: +# The algorithm for constructing the power set was taken from +# wiki.tcl.tk/2877 (algorithm subsets2b). +# +proc ::math::numtheory::factors {number} { + set factors [primeFactors $number] + + # + # Iterate over the power set of this list + # + set result [list 1 $number] + for {set n 1} {$n < [llength $factors]} {incr n} { + set subsets [list [list]] + foreach f $factors { + foreach subset $subsets { + lappend subset $f + if {[llength $subset] == $n} { + lappend result [Product $subset] + } else { + lappend subsets $subset + } + } + } + } + return [lsort -unique -integer $result] +} + +# Product -- +# Auxiliary function: return the product of a list of numbers +# +# Arguments: +# list List of numbers +# +# Result: +# The product of all the numbers +# +proc ::math::numtheory::Product {list} { + set product 1 + foreach e $list { + set product [expr {$product * $e}] + } + return $product +} + +# moebius -- +# Return the value of the Moebius function for "number" +# +# Arguments: +# number Number in question +# +# Result: +# The product of all the numbers +# +proc ::math::numtheory::moebius {number} { + if { $number < 1 } { + return -code error "The number must be positive" + } + if { $number == 1 } { + return 1 + } + + set primefactors [primeFactors $number] + if { [llength $primefactors] != [llength [lsort -unique -integer $primefactors]] } { + return 0 + } else { + return [expr {(-1)**([llength $primefactors]%2)}] + } +} + +# legendre -- +# Return the value of the Legendre symbol (a/p) +# +# Arguments: +# a Upper number in the symbol +# p Lower number in the symbol +# +# Result: +# The Legendre symbol +# +proc ::math::numtheory::legendre {a p} { + if { $p == 0 } { + return -code error "The number p must be non-zero" + } + + if { $a % $p == 0 } { + return 0 + } + + # + # Just take the brute force route + # (Negative values of a present a small problem, but only a small one) + # + while { $a < 0 } { + set a [expr {$p + $a}] + } + + set legendre -1 + for {set n 1} {$n < $p} {incr n} { + if { $n**2 % $p == $a } { + set legendre 1 + break + } + } + + return $legendre +} + +# jacobi -- +# Return the value of the Jacobi symbol (a/b) +# +# Arguments: +# a Upper number in the symbol +# b Lower number in the symbol +# +# Result: +# The Jacobi symbol +# +# Note: +# Implementation adopted from the Wiki - http://wiki.tcl.tk/36990 +# encoded by rmelton 9/25/12 +# Further references: +# http://en.wikipedia.org/wiki/Jacobi_symbol +# http://2000clicks.com/mathhelp/NumberTh27JacobiSymbolAlgorithm.aspx +# +proc ::math::numtheory::jacobi {a b} { + if { $b<=0 || ($b&1)==0 } { + return 0; + } + + set j 1 + if {$a<0} { + set a [expr {0-$a}] + set j [expr {0-$j}] + } + while {$a != 0} { + while {($a&1) == 0} { + ##/* Process factors of 2: Jacobi(2,b)=-1 if b=3,5 (mod 8) */ + set a [expr {$a>>1}] + if {(($b & 7)==3) || (($b & 7)==5)} { + set j [expr {0-$j}] + } + } + ##/* Quadratic reciprocity: Jacobi(a,b)=-Jacobi(b,a) if a=3,b=3 (mod 4) */ + lassign [list $a $b] b a + if {(($a & 3)==3) && (($b & 3)==3)} { + set j [expr {0-$j}] + } + set a [expr {$a % $b}] + } + if {$b==1} { + return $j + } else { + return 0 + } +} + +# gcd -- +# Return the greatest common divisor of two numbers n and m +# +# Arguments: +# n First number +# m Second number +# +# Result: +# The greatest common divisor +# +proc ::math::numtheory::gcd {n m} { + # + # Apply Euclid's good old algorithm + # + if { $n > $m } { + set t $n + set n $m + set m $t + } + + while { $n > 0 } { + set r [expr {$m % $n}] + set m $n + set n $r + } + + return $m +} + +# lcm -- +# Return the lowest common multiple of two numbers n and m +# +# Arguments: +# n First number +# m Second number +# +# Result: +# The lowest common multiple +# +proc ::math::numtheory::lcm {n m} { + set gcd [gcd $n $m] + return [expr {$n*$m/$gcd}] +} + +# numberPrimesGauss -- +# Return the approximate number of primes lower than the given value based on the formula by Gauss +# +# Arguments: +# limit The limit for the largest prime to be included in the estimate +# +# Returns: +# Approximate number of primes +# +proc ::math::numtheory::numberPrimesGauss {limit} { + if { $limit <= 1 } { + return -code error "The limit must be larger than 1" + } + expr {$limit / log($limit)} +} + +# numberPrimesLegendre -- +# Return the approximate number of primes lower than the given value based on the formula by Legendre +# +# Arguments: +# limit The limit for the largest prime to be included in the estimate +# +# Returns: +# Approximate number of primes +# +proc ::math::numtheory::numberPrimesLegendre {limit} { + if { $limit <= 1 } { + return -code error "The limit must be larger than 1" + } + expr {$limit / (log($limit) - 1.0)} +} + +# numberPrimesLegendreModified -- +# Return the approximate number of primes lower than the given value based on the +# modified formula by Legendre +# +# Arguments: +# limit The limit for the largest prime to be included in the estimate +# +# Returns: +# Approximate number of primes +# +proc ::math::numtheory::numberPrimesLegendreModified {limit} { + if { $limit <= 1 } { + return -code error "The limit must be larger than 1" + } + expr {$limit / (log($limit) - 1.08366)} +} +% +%\end{tcl} +% \begin{tcl} +%<*test_primes> +test first-few-primes-1 "First 10 primes" -match equalLists -body { + ::math::numtheory::firstNprimes 10 +} -result {2 3 5 7 11 13 17 19 23 29} + +test first-few-primes-2 "First 12 primes" -match equalLists -body { + ::math::numtheory::firstNprimes 12 +} -result {2 3 5 7 11 13 17 19 23 29 31 37} + +test first-few-primes-3 "First 20 primes" -match equalLists -body { + ::math::numtheory::firstNprimes 20 +} -result {2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71} + +test primes-lower-than-1 "Primes lower/equal 101" -match equalLists -body { + ::math::numtheory::primesLowerThan 101 +} -result {2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97 101} + +test primes-lower-than-2 "Primes lower/equal 2" -match equalLists -body { + ::math::numtheory::primesLowerThan 2 +} -result {2} + +test primes-lower-than-3 "Primes lower/equal 4" -match equalLists -body { + ::math::numtheory::primesLowerThan 4 +} -result {2 3} + +test primes-lower-than-4 "Primes lower/equal 102" -match equalLists -body { + ::math::numtheory::primesLowerThan 102 +} -result {2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97 101} + +test prime-factors-1 "Prime factors 100" -match equalLists -body { + ::math::numtheory::primeFactors 100 +} -result {2 2 5 5} + +test prime-factors-2 "Unique prime factors 100" -match equalLists -body { + ::math::numtheory::uniquePrimeFactors 100 +} -result {2 5} + +test prime-factors-3 "Prime factors 2900" -match equalLists -body { + ::math::numtheory::primeFactors 2900 +} -result {2 2 5 5 29} + +test prime-factors-4 "Unique prime factors 2900" -match equalLists -body { + ::math::numtheory::uniquePrimeFactors 2900 +} -result {2 5 29} + +test prime-factors-5 "Prime factors 964" -match equalLists -body { + ::math::numtheory::primeFactors 964 +} -result {2 2 241} + +test prime-factors-6 "Prime factors 960" -match equalLists -body { + ::math::numtheory::primeFactors 960 +} -result {2 2 2 2 2 2 3 5} + +test prime-factors-7 "Prime factors 914" -match equalLists -body { + ::math::numtheory::primeFactors 914 +} -result {2 457} + +test totient-1 "Totient 15" -body { + ::math::numtheory::totient 15 +} -result 8 + +test totient-2 "Totient 30" -body { + ::math::numtheory::totient 30 +} -result 8 + +test totient-3 "Totient 35" -body { + ::math::numtheory::totient 35 +} -result 24 + +test totient-4 "Totient 105" -body { + ::math::numtheory::totient 105 +} -result 48 + +test factors-1 "All factors 30" -match equalLists -body { + ::math::numtheory::factors 30 +} -result {1 2 3 5 6 10 15 30} + +test factors-1 "All factors 128" -match equalLists -body { + ::math::numtheory::factors 128 +} -result {1 2 4 8 16 32 64 128} + +test factors-1 "All factors 250" -match equalLists -body { + ::math::numtheory::factors 250 +} -result {1 2 5 10 25 50 125 250} + +test moebius-1 "Moebius for first 19 numbers" -match equalLists -body { + set result {} + for {set n 1} {$n < 20} {incr n} { + lappend result [::math::numtheory::moebius $n] + } + set result +} -result {1 -1 -1 0 -1 1 -1 0 0 1 -1 0 -1 1 1 0 -1 0 -1} + +test legendre-1 "Legendre symbol (-1/3)" -body { + ::math::numtheory::legendre -1 3 +} -result -1 +test legendre-2 "Legendre symbol (-3/7)" -body { + ::math::numtheory::legendre -3 7 +} -result 1 + +test jacobi-1 "Jacobi symbol (6/7)" -body { + ::math::numtheory::jacobi 6 7 +} -result -1 + +test jacobi-2 "Jacobi symbol (6/9)" -body { + ::math::numtheory::jacobi 6 9 +} -result 0 + +test jacobi-3 "Jacobi symbol (3/11)" -body { + ::math::numtheory::jacobi 3 11 +} -result 1 + +test gcd-1 "Greatest common divisor 2 and 3" -body { + ::math::numtheory::gcd 2 3 +} -result 1 + +test gcd-2 "Greatest common divisor 20 and 12" -body { + ::math::numtheory::gcd 20 12 +} -result 4 + +test gcd-3 "Greatest common divisor 600 and 125" -body { + ::math::numtheory::gcd 600 125 +} -result 25 + +test lcm-1 "Lowest common multiple 3 and 4" -body { + ::math::numtheory::lcm 3 4 +} -result 12 + +test lcm-2 "Lowest common multiple 12 and 20" -body { + ::math::numtheory::lcm 12 20 +} -result 60 + +test number-primes "Exercise prime estimators" -match equalLists -body { + set estimate1 [::math::numtheory::numberPrimesGauss 1000] + set estimate2 [::math::numtheory::numberPrimesLegendre 1000] + set estimate3 [::math::numtheory::numberPrimesLegendreModified 1000] + set result [list [expr {int($estimate1)}] [expr {int($estimate2)}] [expr {int($estimate3)}]] +} -result {144 169 171} +% +%\end{tcl} +% +% \section*{Closings} +% +% \begin{tcl} +%<*man> +[list_end] + +[vset CATEGORY {math :: numtheory}] +[include ../common-text/feedback.inc] +[manpage_end] +% +% \end{tcl} +% +% \begin{tcl} +%testsuiteCleanup +% \end{tcl} +% +% +% \begin{thebibliography}{9} +% +% \bibitem{AKS04} +% Manindra Agrawal, Neeraj Kayal, and Nitin Saxena: +% PRIMES is in P, +% \textit{Annals of Mathematics} \textbf{160} (2004), no. 2, +% 781--793. +% +% \bibitem{CL84} +% Henri Cohen and Hendrik W. Lenstra, Jr.: +% Primality testing and Jacobi sums, +% \textit{Mathematics of Computation} \textbf{42} (165) (1984), +% 297--330. +% \texttt{doi:10.2307/2007581} +% +% \bibitem{RFC2409} +% Dan Harkins and Dave Carrel. +% \textit{The Internet Key Exchange (IKE)}, +% \textbf{RFC 2409} (1998). +% +% \bibitem{Jaeschke} +% Gerhard Jaeschke: On strong pseudoprimes to several bases, +% \textit{Mathematics of Computation} \textbf{61} (204), 1993, +% 915--926. +% \texttt{doi:\,10.2307/2153262} +% +% \bibitem{Miller} +% Gary L. Miller: +% Riemann's Hypothesis and Tests for Primality, +% \textit{Journal of Computer and System Sciences} \textbf{13} (3) +% (1976), 300--317. \texttt{doi:10.1145/800116.803773} +% +% \bibitem{PSW80} +% C.~Pomerance, J.~L.~Selfridge, and S.~S.~Wagstaff~Jr.: +% The pseudoprimes to $25 \cdot 10^9$, +% \textit{Mathematics of Computation} \textbf{35} (151), 1980, +% 1003--1026. +% \texttt{doi: 10.2307/2006210} +% +% \bibitem{Rabin} +% Michael O. Rabin: +% Probabilistic algorithm for testing primality, +% \textit{Journal of Number Theory} \textbf{12} (1) (1980), +% 128--138. \texttt{doi:10.1016/0022-314X(80)90084-0} +% +% \bibitem{Wikipedia} +% Wikipedia contributors: +% Miller--Rabin primality test, +% \textit{Wikipedia, The Free Encyclopedia}, 2010. +% Online, accessed 10 September 2010, +% \url{http://en.wikipedia.org/w/index.php?title=Miller%E2%80%93Rabin_primality_test&oldid=383901104} +% +% \end{thebibliography} +% +\endinput diff --git a/vendor/math/numtheory.man b/vendor/math/numtheory.man new file mode 100644 index 00000000..3c5b6b61 --- /dev/null +++ b/vendor/math/numtheory.man @@ -0,0 +1,231 @@ +[comment { + __Attention__ This document is a generated file. + It is not the true source. + The true source is + + numtheory.dtx + + To make changes edit the true source, and then use + + sak.tcl docstrip/regen modules/math + + to update all generated files. +}] +[vset VERSION 1.1.3] +[manpage_begin math::numtheory n [vset VERSION]] +[keywords {number theory}] +[keywords prime] +[copyright "2010 Lars Hellstr\u00F6m\ + "] +[moddesc {Tcl Math Library}] +[titledesc {Number Theory}] +[category Mathematics] +[require Tcl [opt 8.5]] +[require math::numtheory [opt [vset VERSION]]] + +[description] +[para] +This package is for collecting various number-theoretic operations, with +a slight bias to prime numbers. + +[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. + +[call [cmd math::numtheory::firstNprimes] [arg N]] +Return the first N primes + +[list_begin arguments] +[arg_def integer N in] +Number of primes to return +[list_end] + +[call [cmd math::numtheory::primesLowerThan] [arg N]] +Return the prime numbers lower/equal to N + +[list_begin arguments] +[arg_def integer N in] +Maximum number to consider +[list_end] + +[call [cmd math::numtheory::primeFactors] [arg N]] +Return a list of the prime numbers in the number N + +[list_begin arguments] +[arg_def integer N in] +Number to be factorised +[list_end] + +[call [cmd math::numtheory::primesLowerThan] [arg N]] +Return the prime numbers lower/equal to N + +[list_begin arguments] +[arg_def integer N in] +Maximum number to consider +[list_end] + +[call [cmd math::numtheory::primeFactors] [arg N]] +Return a list of the prime numbers in the number N + +[list_begin arguments] +[arg_def integer N in] +Number to be factorised +[list_end] + +[call [cmd math::numtheory::uniquePrimeFactors] [arg N]] +Return a list of the [emph unique] prime numbers in the number N + +[list_begin arguments] +[arg_def integer N in] +Number to be factorised +[list_end] + +[call [cmd math::numtheory::factors] [arg N]] +Return a list of all [emph unique] factors in the number N, including 1 and N itself +[list_begin arguments] +[arg_def integer N in] +Number to be factorised +[list_end] + +[call [cmd math::numtheory::totient] [arg N]] +Evaluate the Euler totient function for the number N (number of numbers +relatively prime to N) + +[list_begin arguments] +[arg_def integer N in] +Number in question +[list_end] + +[call [cmd math::numtheory::moebius] [arg N]] +Evaluate the Moebius function for the number N + +[list_begin arguments] +[arg_def integer N in] +Number in question +[list_end] + +[call [cmd math::numtheory::legendre] [arg a] [arg p]] +Evaluate the Legendre symbol (a/p) + +[list_begin arguments] +[arg_def integer a in] +Upper number in the symbol +[arg_def integer p in] +Lower number in the symbol (must be non-zero) +[list_end] + +[call [cmd math::numtheory::jacobi] [arg a] [arg b]] +Evaluate the Jacobi symbol (a/b) + +[list_begin arguments] +[arg_def integer a in] +Upper number in the symbol +[arg_def integer b in] +Lower number in the symbol (must be odd) +[list_end] + +[call [cmd math::numtheory::gcd] [arg m] [arg n]] +Return the greatest common divisor of [term m] and [term n] + +[list_begin arguments] +[arg_def integer m in] +First number +[arg_def integer n in] +Second number +[list_end] + +[call [cmd math::numtheory::lcm] [arg m] [arg n]] +Return the lowest common multiple of [term m] and [term n] + +[list_begin arguments] +[arg_def integer m in] +First number +[arg_def integer n in] +Second number +[list_end] + +[call [cmd math::numtheory::numberPrimesGauss] [arg N]] +Estimate the number of primes according the formula by Gauss. + +[list_begin arguments] +[arg_def integer N in] +Number in question, should be larger than 0 +[list_end] + +[call [cmd math::numtheory::numberPrimesLegendre] [arg N]] +Estimate the number of primes according the formula by Legendre. + +[list_begin arguments] +[arg_def integer N in] +Number in question, should be larger than 0 +[list_end] + +[call [cmd math::numtheory::numberPrimesLegendreModified] [arg N]] +Estimate the number of primes according the modified formula by Legendre. + +[list_begin arguments] +[arg_def integer N in] +Number in question, should be larger than 0 +[list_end] + +[call [cmd math::numtheory::differenceNumberPrimesLegendreModified] [arg lower] [arg upper]] +Estimate the number of primes between tow limits according the modified formula by Legendre. + +[list_begin arguments] +[arg_def integer lower in] Lower limit for the primes, should be larger than 0 +[arg_def integer upper in] Upper limit for the primes, should be larger than 0 +[list_end] + +[call [cmd math::numtheory::listPrimePairs] [arg lower] [arg upper] [arg step]] +Return a list of pairs of primes each differing by the given step. + +[list_begin arguments] +[arg_def integer lower in] Lower limit for the primes, should be larger than 0 +[arg_def integer upper in] Upper limit for the primes, should be larger than the lower limit +[arg_def integer step in] Step by which the primes should differ, defaults to 2 +[list_end] + +[call [cmd math::numtheory::listPrimeProgressions] [arg lower] [arg upper] [arg step]] +Return a list of lists of primes each differing by the given step from the previous one. + +[list_begin arguments] +[arg_def integer lower in] Lower limit for the primes, should be larger than 0 +[arg_def integer upper in] Upper limit for the primes, should be larger than the lower limit +[arg_def integer step in] Step by which the primes should differ, defaults to 2 +[list_end] + +[list_end] + +[vset CATEGORY {math :: numtheory}] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/vendor/math/numtheory.stitch b/vendor/math/numtheory.stitch new file mode 100644 index 00000000..cba0cb78 --- /dev/null +++ b/vendor/math/numtheory.stitch @@ -0,0 +1,24 @@ +# -*- 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 pkg_common} +stitch numtheory.test {test test_common} + +stitch primes.tcl {pkg_primes pkg_common} +stitch primes.test {test_primes test_common} + +options -nopostamble -nopreamble +stitch numtheory.man man + +# Unused guards: +# +# - driver (TeX output prolog) diff --git a/vendor/math/numtheory.tcl b/vendor/math/numtheory.tcl new file mode 100644 index 00000000..398901f3 --- /dev/null +++ b/vendor/math/numtheory.tcl @@ -0,0 +1,82 @@ +## +## This is the file `numtheory.tcl', +## generated with the SAK utility +## (sak docstrip/regen). +## +## The original source files were: +## +## numtheory.dtx (with options: `pkg pkg_common') +## +## 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.1.3 +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 +} + +# Add the additional procedures +# +source [file join [file dirname [info script]] primes.tcl] +## +## +## End of file `numtheory.tcl'. diff --git a/vendor/math/numtheory.test b/vendor/math/numtheory.test new file mode 100644 index 00000000..3ed6e6ae --- /dev/null +++ b/vendor/math/numtheory.test @@ -0,0 +1,240 @@ +## +## This is the file `numtheory.test', +## generated with the SAK utility +## (sak docstrip/regen). +## +## The original source files were: +## +## numtheory.dtx (with options: `test test_common') +## +## 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.1 + +testing { + useLocal numtheory.tcl math::numtheory +} + +proc compareRounded {expected actual} { + return [expr {int($expected-$actual) == 0} ] +} + +::tcltest::customMatch rounded compareRounded + +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 + } +} + +test numberPrimes-1.0 "Number of primes below 100" -match rounded -body { + set result [::math::numtheory::numberPrimesLegendre 100] +} -result 28 + +test numberPrimes-1.1 "Number of primes below 100 (modified)" -match rounded -body { + set result [::math::numtheory::numberPrimesLegendreModified 100] +} -result 28 + +test numberPrimes-1.2 "Number of primes below 0 (modified)" -body { + set result [::math::numtheory::numberPrimesLegendreModified 0] +} -result "The limit must be larger than 1" -returnCodes 1 + +test numberPrimes-1.3 "Number of primes between 100 and 200" -match rounded -body { + set result [::math::numtheory::differenceNumberPrimesLegendreModified 100 200] +} -result 19 + +test numberPrimes-1.4 "Number of primes between 100 and 0 - error expected" -body { + set result [::math::numtheory::differenceNumberPrimesLegendreModified 100 0] +} -result "The upper limit must be larger than 1" -returnCodes 1 + +testsuiteCleanup +## +## +## End of file `numtheory.test'. diff --git a/vendor/math/optimize.man b/vendor/math/optimize.man new file mode 100644 index 00000000..5564fe7f --- /dev/null +++ b/vendor/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 }] +[copyright {2004,2005 Kevn B. Kenny }] +[moddesc {Tcl Math Library}] +[titledesc {Optimisation routines}] +[category Mathematics] +[require Tcl 8.4] +[require math::optimize [opt 1.0]] +[description] +[para] +This package implements several optimisation algorithms: + +[list_begin itemized] +[item] +Minimize or maximize a function over a given interval + +[item] +Solve a linear program (maximize a linear function subject to linear +constraints) + +[item] +Minimize a function of several variables given an initial guess for the +location of the minimum. + +[list_end] + +[para] +The package is fully implemented in Tcl. No particular attention has +been paid to the accuracy of the calculations. Instead, the +algorithms have been used in a straightforward manner. +[para] +This document describes the procedures and explains their usage. + +[section "PROCEDURES"] +[para] +This package defines the following public procedures: +[list_begin definitions] + +[call [cmd ::math::optimize::minimum] [arg begin] [arg end] [arg func] [arg maxerr]] +Minimize the given (continuous) function by examining the values in the +given interval. The procedure determines the values at both ends and in the +centre of the interval and then constructs a new interval of 1/2 length +that includes the minimum. No guarantee is made that the [emph global] +minimum is found. +[para] +The procedure returns the "x" value for which the function is minimal. +[para] +[emph {This procedure has been deprecated - use min_bound_1d instead}] +[para] +[arg begin] - Start of the interval +[para] +[arg end] - End of the interval +[para] +[arg func] - Name of the function to be minimized (a procedure taking +one argument). +[para] +[arg maxerr] - Maximum relative error (defaults to 1.0e-4) + +[call [cmd ::math::optimize::maximum] [arg begin] [arg end] [arg func] [arg maxerr]] +Maximize the given (continuous) function by examining the values in the +given interval. The procedure determines the values at both ends and in the +centre of the interval and then constructs a new interval of 1/2 length +that includes the maximum. No guarantee is made that the [emph global] +maximum is found. +[para] +The procedure returns the "x" value for which the function is maximal. +[para] +[emph {This procedure has been deprecated - use max_bound_1d instead}] +[para] +[arg begin] - Start of the interval +[para] +[arg end] - End of the interval +[para] +[arg func] - Name of the function to be maximized (a procedure taking +one argument). +[para] +[arg maxerr] - Maximum relative error (defaults to 1.0e-4) + +[call [cmd ::math::optimize::min_bound_1d] [arg func] [arg begin] [arg end] [opt "[option -relerror] [arg reltol]"] [opt "[option -abserror] [arg abstol]"] [opt "[option -maxiter] [arg maxiter]"] [opt "[option -trace] [arg traceflag]"]] + +Miminizes a function of one variable in the given interval. The procedure +uses Brent's method of parabolic interpolation, protected by golden-section +subdivisions if the interpolation is not converging. No guarantee is made +that a [emph global] minimum is found. The function to evaluate, [arg func], +must be a single Tcl command; it will be evaluated with an abscissa appended +as the last argument. +[para] +[arg x1] and [arg x2] are the two bounds of +the interval in which the minimum is to be found. They need not be in +increasing order. +[para] +[arg reltol], if specified, is the desired upper bound +on the relative error of the result; default is 1.0e-7. The given value +should never be smaller than the square root of the machine's floating point +precision, or else convergence is not guaranteed. [arg abstol], if specified, +is the desired upper bound on the absolute error of the result; default +is 1.0e-10. Caution must be used with small values of [arg abstol] to +avoid overflow/underflow conditions; if the minimum is expected to lie +about a small but non-zero abscissa, you consider either shifting the +function or changing its length scale. +[para] +[arg maxiter] may be used to constrain the number of function evaluations +to be performed; default is 100. If the command evaluates the function +more than [arg maxiter] times, it returns an error to the caller. +[para] +[arg traceFlag] is a Boolean value. If true, it causes the command to +print a message on the standard output giving the abscissa and ordinate +at each function evaluation, together with an indication of what type +of interpolation was chosen. Default is 0 (no trace). + +[call [cmd ::math::optimize::min_unbound_1d] [arg func] [arg begin] [arg end] [opt "[option -relerror] [arg reltol]"] [opt "[option -abserror] [arg abstol]"] [opt "[option -maxiter] [arg maxiter]"] [opt "[option -trace] [arg traceflag]"]] + +Miminizes a function of one variable over the entire real number line. +The procedure uses parabolic extrapolation combined with golden-section +dilatation to search for a region where a minimum exists, followed by +Brent's method of parabolic interpolation, protected by golden-section +subdivisions if the interpolation is not converging. No guarantee is made +that a [emph global] minimum is found. The function to evaluate, [arg func], +must be a single Tcl command; it will be evaluated with an abscissa appended +as the last argument. +[para] +[arg x1] and [arg x2] are two initial guesses at where the minimum +may lie. [arg x1] is the starting point for the minimization, and +the difference between [arg x2] and [arg x1] is used as a hint at the +characteristic length scale of the problem. +[para] +[arg reltol], if specified, is the desired upper bound +on the relative error of the result; default is 1.0e-7. The given value +should never be smaller than the square root of the machine's floating point +precision, or else convergence is not guaranteed. [arg abstol], if specified, +is the desired upper bound on the absolute error of the result; default +is 1.0e-10. Caution must be used with small values of [arg abstol] to +avoid overflow/underflow conditions; if the minimum is expected to lie +about a small but non-zero abscissa, you consider either shifting the +function or changing its length scale. +[para] +[arg maxiter] may be used to constrain the number of function evaluations +to be performed; default is 100. If the command evaluates the function +more than [arg maxiter] times, it returns an error to the caller. +[para] +[arg traceFlag] is a Boolean value. If true, it causes the command to +print a message on the standard output giving the abscissa and ordinate +at each function evaluation, together with an indication of what type +of interpolation was chosen. Default is 0 (no trace). + +[call [cmd ::math::optimize::solveLinearProgram] [arg objective] [arg constraints]] +Solve a [emph "linear program"] in standard form using a straightforward +implementation of the Simplex algorithm. (In the explanation below: The +linear program has N constraints and M variables). +[para] +The procedure returns a list of M values, the values for which the +objective function is maximal or a single keyword if the linear program +is not feasible or unbounded (either "unfeasible" or "unbounded") +[para] +[arg objective] - The M coefficients of the objective function +[para] +[arg constraints] - Matrix of coefficients plus maximum values that +implement the linear constraints. It is expected to be a list of N lists +of M+1 numbers each, M coefficients and the maximum value. + +[call [cmd ::math::optimize::linearProgramMaximum] [arg objective] [arg result]] +Convenience function to return the maximum for the solution found by the +solveLinearProgram procedure. +[para] +[arg objective] - The M coefficients of the objective function +[para] +[arg result] - The result as returned by solveLinearProgram + +[call [cmd ::math::optimize::nelderMead] [arg objective] [arg xVector] [opt "[option -scale] [arg xScaleVector]"] [opt "[option -ftol] [arg epsilon]"] [opt "[option -maxiter] [arg count]"] [opt "[opt -trace] [arg flag]"]] + +Minimizes, in unconstrained fashion, a function of several variable over all +of space. The function to evaluate, [arg objective], must be a single Tcl +command. To it will be appended as many elements as appear in the initial guess at +the location of the minimum, passed in as a Tcl list, [arg xVector]. +[para] +[arg xScaleVector] is an initial guess at the problem scale; the first +function evaluations will be made by varying the co-ordinates in [arg xVector] +by the amounts in [arg xScaleVector]. If [arg xScaleVector] is not supplied, +the co-ordinates will be varied by a factor of 1.0001 (if the co-ordinate +is non-zero) or by a constant 0.0001 (if the co-ordinate is zero). +[para] +[arg epsilon] is the desired relative error in the value of the function +evaluated at the minimum. The default is 1.0e-7, which usually gives three +significant digits of accuracy in the values of the x's. +[para]pp +[arg count] is a limit on the number of trips through the main loop of +the optimizer. The number of function evaluations may be several times +this number. If the optimizer fails to find a minimum to within [arg ftol] +in [arg maxiter] iterations, it returns its current best guess and an +error status. Default is to allow 500 iterations. +[para] +[arg flag] is a flag that, if true, causes a line to be written to the +standard output for each evaluation of the objective function, giving +the arguments presented to the function and the value returned. Default is +false. + +[para] +The [cmd nelderMead] procedure returns a list of alternating keywords and +values suitable for use with [cmd {array set}]. The meaning of the keywords is: + +[para] +[arg x] is the approximate location of the minimum. +[para] +[arg y] is the value of the function at [arg x]. +[para] +[arg yvec] is a vector of the best N+1 function values achieved, where +N is the dimension of [arg x] +[para] +[arg vertices] is a list of vectors giving the function arguments +corresponding to the values in [arg yvec]. +[para] +[arg nIter] is the number of iterations required to achieve convergence or +fail. +[para] +[arg status] is 'ok' if the operation succeeded, or 'too-many-iterations' +if the maximum iteration count was exceeded. +[para] +[cmd nelderMead] minimizes the given function using the downhill +simplex method of Nelder and Mead. This method is quite slow - much +faster methods for minimization are known - but has the advantage of being +extremely robust in the face of problems where the minimum lies in +a valley of complex topology. +[para] +[cmd nelderMead] can occasionally find itself "stuck" at a point where +it can make no further progress; it is recommended that the caller +run it at least a second time, passing as the initial guess the +result found by the previous call. The second run is usually very +fast. +[para] +[cmd nelderMead] can be used in some cases for constrained optimization. +To do this, add a large value to the objective function if the parameters +are outside the feasible region. To work effectively in this mode, +[cmd nelderMead] requires that the initial guess be feasible and +usually requires that the feasible region be convex. +[list_end] + +[section NOTES] +[para] +Several of the above procedures take the [emph names] of procedures as +arguments. To avoid problems with the [emph visibility] of these +procedures, the fully-qualified name of these procedures is determined +inside the optimize routines. For the user this has only one +consequence: the named procedure must be visible in the calling +procedure. For instance: +[example { + namespace eval ::mySpace { + namespace export calcfunc + proc calcfunc { x } { return $x } + } + # + # Use a fully-qualified name + # + namespace eval ::myCalc { + puts [min_bound_1d ::myCalc::calcfunc $begin $end] + } + # + # Import the name + # + namespace eval ::myCalc { + namespace import ::mySpace::calcfunc + puts [min_bound_1d calcfunc $begin $end] + } +}] + +The simple procedures [emph minimum] and [emph maximum] have been +deprecated: the alternatives are much more flexible, robust and +require less function evaluations. + +[section EXAMPLES] +[para] +Let us take a few simple examples: +[para] +Determine the maximum of f(x) = x^3 exp(-3x), on the interval (0,10): +[example { +proc efunc { x } { expr {$x*$x*$x * exp(-3.0*$x)} } +puts "Maximum at: [::math::optimize::max_bound_1d efunc 0.0 10.0]" +}] +[para] +The maximum allowed error determines the number of steps taken (with +each step in the iteration the interval is reduced with a factor 1/2). +Hence, a maximum error of 0.0001 is achieved in approximately 14 steps. +[para] +An example of a [emph "linear program"] is: +[para] +Optimise the expression 3x+2y, where: +[example { + x >= 0 and y >= 0 (implicit constraints, part of the + definition of linear programs) + + x + y <= 1 (constraints specific to the problem) + 2x + 5y <= 10 +}] +[para] +This problem can be solved as follows: +[example { + + set solution [::math::optimize::solveLinearProgram \ + { 3.0 2.0 } \ + { { 1.0 1.0 1.0 } + { 2.0 5.0 10.0 } } ] +}] +[para] +Note, that a constraint like: +[example { + x + y >= 1 +}] +can be turned into standard form using: +[example { + -x -y <= -1 +}] + +[para] +The theory of linear programming is the subject of many a text book and +the Simplex algorithm that is implemented here is the best-known +method to solve this type of problems, but it is not the only one. + +[vset CATEGORY {math :: optimize}] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/vendor/math/optimize.tcl b/vendor/math/optimize.tcl new file mode 100644 index 00000000..b5ddafed --- /dev/null +++ b/vendor/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/vendor/math/optimize.test b/vendor/math/optimize.test new file mode 100644 index 00000000..f1a84753 --- /dev/null +++ b/vendor/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.5 +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/vendor/math/pca.man b/vendor/math/pca.man new file mode 100644 index 00000000..68545ac1 --- /dev/null +++ b/vendor/math/pca.man @@ -0,0 +1,136 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin math::PCA n 1.0] +[keywords PCA] +[keywords statistics] +[keywords math] +[keywords tcl] +[moddesc {Principal Components Analysis}] +[titledesc {Package for Principal Component Analysis}] +[category Mathematics] +[require Tcl [opt 8.6]] +[require math::linearalgebra 1.0] + +[description] +[para] +The PCA package provides a means to perform principal components analysis +in Tcl, using an object-oriented technique as facilitated by TclOO. It +actually defines a single public method, [term ::math::PCA::createPCA], +which constructs an object based on the data that are passed to perform +the actual analysis. + +[para] +The methods of the PCA objects that are created with this command allow one +to examine the principal components, to approximate (new) observations +using all or a selected number of components only and to examine the +properties of the components and the statistics of the approximations. + +[para] +The package has been modelled after the PCA example provided by the +original linear algebra package by Ed Hume. + +[section "Commands"] +The [term math::PCA] package provides one public command: +[list_begin definitions] + +[call [cmd ::math::PCA::createPCA] [arg data] [opt args]] +Create a new object, based on the data that are passed via the [term data] argument. +The principal components may be based on either correlations or covariances. +All observations will be normalised according to the mean and standard deviation +of the original data. + +[list_begin arguments] +[arg_def list data] - A list of observations (see the example below). +[arg_def list args] - A list of key-value pairs defining the options. Currently there is +only one key: [term -covariances]. This indicates if covariances are to be used +(if the value is 1) or instead correlations (value is 0). The default is to use +correlations. +[list_end] + +[list_end] + +The PCA object that is created has the following methods: +[list_begin definitions] + +[call [cmd "\$pca using"] [opt number]|[opt "-minproportion value"]] +Set the number of components to be used in the analysis (the number of retained components). +Returns the number of components, also if no argument is given. + +[list_begin arguments] +[arg_def int number] - The number of components to be retained +[arg_def double value] - Select the number of components based on the minimum proportion +of variation that is retained by them. Should be a value between 0 and 1. +[list_end] + + +[call [cmd "\$pca eigenvectors"] [opt option]] +Return the eigenvectors as a list of lists. + +[list_begin arguments] +[arg_def string option] - By default only the [emph retained] components are returned. +If all eigenvectors are required, use the option [term -all]. +[list_end] + + +[call [cmd "\$pca eigenvalues"] [opt option]] +Return the eigenvalues as a list of lists. + +[list_begin arguments] +[arg_def string option] - By default only the eigenvalues of the [emph retained] components are returned. +If all eigenvalues are required, use the option [term -all]. +[list_end] + + +[call [cmd "\$pca proportions"] [opt option]] +Return the proportions for all components, that is, the amount of variations that each +components can explain. + + +[call [cmd "\$pca approximate"] [arg observation]] +Return an approximation of the observation based on the retained components + +[list_begin arguments] +[arg_def list observation] - The values for the observation. +[list_end] + + +[call [cmd "\$pca approximatOriginal"]] +Return an approximation of the original data, using the retained components. It is +a convenience method that works on the complete set of original data. + + +[call [cmd "\$pca scores"] [arg observation]] +Return the scores per retained component for the given observation. + +[list_begin arguments] +[arg_def list observation] - The values for the observation. +[list_end] + + +[call [cmd "\$pca distance"] [arg observation]] +Return the distance between the given observation and its approximation. (Note: +this distance is based on the normalised vectors.) + +[list_begin arguments] +[arg_def list observation] - The values for the observation. +[list_end] + + +[call [cmd "\$pca qstatistic"] [arg observation] [opt option]] +Return the Q statistic, basically the square of the distance, for the given observation. + +[list_begin arguments] +[arg_def list observation] - The values for the observation. +[arg_def string option] - If the observation is part of the original data, you may want +to use the corrected Q statistic. This is achieved with the option "-original". +[list_end] + +[list_end] + +[section EXAMPLE] +TODO: NIST example + + + +[vset CATEGORY PCA] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/vendor/math/pca.tcl b/vendor/math/pca.tcl new file mode 100644 index 00000000..7eb5ebf4 --- /dev/null +++ b/vendor/math/pca.tcl @@ -0,0 +1,402 @@ +# pca.tcl -- +# Package for principal component analysis +# +package require Tcl 8.6 +package require math::linearalgebra + +namespace eval ::math::PCA { + namespace export createPCA +} + +# createPCA -- +# Create a PCA object. Based on the observations the principal +# components are determined. +# +# Arguments: +# data List of observations to be analysed +# args Option-value pairs: +# -covariance 1/0 - use covariances instead of correlations +# +# Returns: +# New object holding all information that is needed +# +proc ::math::PCA::createPCA {data args} { + + return [pcaClass new $data $args] +} + +# pcaClass -- +# Class holding the variables and methods for PCA +# +::oo::class create ::math::PCA::pcaClass { + variable eigenValues {} + variable eigenVectors {} + variable retainedValues {} + variable retainedVectors {} + variable numberComponents 0 + variable numberUsed 0 + variable numberData 0 + variable mean {} + variable scale {} + variable originalData {} + + constructor {data options} { + variable numberComponents + variable numberUsed + + set originalData $data + set numberComponents [llength [lindex $data 0]] + set numberUsed $numberComponents + set numberData [llength $data] + + if { $numberComponents < 2 } { + return -code error "The data should contain at least two components" + } + + set correlation 1 + + foreach {option value} $options { + switch -- $option { + "" { + # Use default + } + "-covariance" { + set correlation [expr {$value? 0 : 1}] + } + default { + return -code error "Unknown option: $option" + } + } + } + + lassign [::math::PCA::Transform $data $correlation] observations mean scale + + # + # Determine the singular value decomposition + # Square and scale the singular values to get the proper eigenvalues + # + set usv [::math::linearalgebra::determineSVD $observations] + set eigenVectors [lindex $usv 2] + set singular [lindex $usv 1] + + set factor [expr {1.0 / ([llength $data] - 1)}] + set eigenValues {} + foreach c $singular { + lappend eigenValues [expr {$c**2 * $factor}] + } + + # + # By default we use all principal components + # + set retainedVectors $eigenVectors + set retainedValues $eigenValues + } + + # + # Get the eigenvectors - either the ones to be used or all vectors + # + method eigenvectors {{option {}}} { + variable eigenVectors + variable retainedVectors + + if { $option eq "-all" } { + return $eigenVectors + } else { + return $retainedVectors + } + } + + # + # Get the eigenvalues - either the ones to be used or all values + # + method eigenvalues {{option {}}} { + variable eigenValues + variable retainedValues + + if { $option eq "-all" } { + return $eigenValues + } else { + return $retainedValues + } + } + + # + # Approximate an observation vector using the selected components + # + method approximate {observation} { + variable retainedVectors + variable mean + variable scale + + set z [::math::PCA::Normalise $observation $mean $scale] + set t [::math::linearalgebra::matmul $z $retainedVectors] + set zhat [::math::linearalgebra::matmul $t [::math::linearalgebra::transpose $retainedVectors]] + set obshat [::math::PCA::Denormalise $zhat $mean $scale] + + return $obshat + } + + # + # Approximate the original data - convenience method + # + method approximateOriginal {} { + variable originalData + + set approximation {} + + foreach observation $originalData { + lappend approximation [my approximate $observation] + } + + return $approximation + } + + # + # Return the scores + # + method scores {observation} { + variable retainedVectors + variable mean + variable scale + + set z [::math::PCA::Normalise $observation $mean $scale] + return [::math::linearalgebra::matmul $z $retainedVectors] + } + + # + # Return the distance + # + method distance {observation} { + variable retainedVectors + variable mean + variable scale + + set z [normalise $observation $mean $scale] + set t [::math::linearalgebra::matmul $z $retainedVectors] + set zhat [::math::linearalgebra::matmul $t [::math::linearalgebra::transpose $retainedVectors]] + set difference [::math::linearalgebra::sub $z $zhat] + return [::math::linearalgebra::norm [::math::PCA::Denormalise $difference $mean $scale]] + } + + # + # Return the Q statistic + # + method qstatistic {observation {option {}}} { + variable mean + variable scale + + set z [::math::PCA::Normalise $observation $mean $scale] + set t [::math::linearalgebra::matmul $z $retainedVectors] + set zhat [::math::linearalgebra::matmul $t [::math::linearalgebra::transpose $retainedVectors]] + set difference [::math::linearalgebra::sub $z $zhat] + + set qstat [::math::linearalgebra::dotproduct $difference $difference] + if { $option eq "" } { + return $qstat + } elseif { $option eq "-original" } { + return [expr {$qstat * double($numberData) / double($numberData - $numberUsed - 1)}] + } else { + return -code error "Unknown option: $option - should be \"-original\"" + } + } + + # + # Get the proportions - the amount of variation explained by the components + # + method proportions {} { + variable retainedValues + + set unscaledProportions {} + foreach e $retainedValues { + lappend unscaledProportions [expr {$e**2}] + } + + set scale [lindex $unscaledProportions end] + + foreach p $unscaledProportions { + lappend proportions [expr {$p / $scale}] + } + return $proportions + } + + # + # Set/get number of components to be used + # + method using {args} { + variable numberComponents + variable numberUsed + variable eigenVectors + variable retainedVectors + + if { [llength $args] == 0 } { + + return $numberUsed + + } elseif { [llength $args] == 1 } { + + set numberUsed [lindex $args 0] + if { ![string is integer $numberUsed] || $numberUsed < 1 || $numberUsed > $numberComponents } { + return -code error "Number of components to be used must be between 1 and $numberComponents" + } + + } elseif { [llength $args] == 2 } { + + if { [lindex $args 0] == "-minproportion" } { + set minimum [lindex $args 1] + if { [string is double $minimum] || $minimum <= 0.0 || $minimum > 1.0 } { + return -code error "Wrong arguments: the minimum proportion must be a number between 0 and 1 - it is \"$minimum\"" + } + + set sum 0.0 + set number 0 + foreach proportion [my proportions] { + set sum [expr {$sum + $proportion}] + incr number + + if { $sum >= $minimum } { + break + } + } + } + if { $number == 0 } { + set number 1 + } + set numberUsed $number + + } else { + return -code error "Wrong arguments: use either the number of components or the minimal proportion" + } + + if { $numberUsed < $numberComponents } { + set retainedValues [lrange $eigenValues 0 [expr {$numberUsed-1}]] + set retainedVectors {} + foreach row $eigenVectors { + lappend retainedVectors [lrange $row 0 [expr {$numberUsed-1}]] + } + } else { + set retainedValues $eigenValues + set retainedVectors $eigenVectors + } + + return $numberUsed + } +} + +# Normalise -- +# Normalise a vector, given mean and standard deviation +# +# Arguments: +# observation Observation vector to be normalised +# mean Mean value to be subtracted +# scale Scale factor for dividing the values by +# +proc ::math::PCA::Normalise {observation mean scale} { + set result {} + + foreach o $observation m $mean s $scale { + lappend result [expr {($o - $m) / $s}] + } + + return $result +} + +# Denormalise -- +# Denormalise a vector, given mean and standard deviation +# +# Arguments: +# observation Normalised observation vector +# mean Mean value to be added +# scale Scale factor for multiplying the values by +# +proc ::math::PCA::Denormalise {observation mean scale} { + set result {} + + foreach o $observation m $mean s $scale { + lappend result [expr {$o * $s + $m}] + } + + return $result +} + +# Transform +# Transform the given observations and return the transformation parameters +# +# Arguments: +# observations List of observation vectors +# correlation Use correlation (1) or not +# +proc ::math::PCA::Transform {observations correlation} { + set columns [llength [lindex $observations 0]] + set number [llength $observations] + set mean [lrepeat $columns [expr {0.0}]] + set scale [lrepeat $columns [expr {0.0}]] + + foreach observation $observations { + set newMean {} + set newScale {} + foreach o $observation m $mean s $scale { + lappend newMean [expr {$m + $o}] + lappend newScale [expr {$s + $o**2}] + } + set mean $newMean + set scale $newScale + } + + set mean {} + set scale {} + + foreach m $newMean s $newScale { + lappend mean [expr {$m / $number}] + if { $correlation } { + set sum [expr {($s - $m**2/$number)/($number-1)}] + lappend scale [expr {$sum >= 0.0 ? sqrt($sum) : 0.0}] + } else { + lappend scale 1.0 + } + } + + set result {} + foreach observation $observations { + lappend result [Normalise $observation $mean $scale] + } + return [list $result $mean $scale] +} + +package provide math::PCA 1.0 + +# Test +if {0} { +set data { + {7 4 3} + {4 1 8} + {6 3 5} + {8 6 1} + {8 5 7} + {7 2 9} + {5 3 3} + {9 5 8} + {7 4 5} + {8 2 2} +} + +set pca [::math::PCA::createPCA $data] + +puts [$pca using] +puts [$pca using 2] + +puts [::math::PCA::Transform $data 1] +puts [::math::PCA::Normalise {1.0 2.0 3.0} {0.0 1.0 2.0} {2.0 2.0 2.0}] +puts [::math::PCA::Denormalise {0.5 0.5 0.5} {0.0 1.0 2.0} {2.0 2.0 2.0}] + +puts "Eigenvalues: [$pca eigenvalues]" +puts "Eigenvectors: [::math::linearalgebra::show [$pca eigenvectors]]" +#puts [$pca proportions] -- check the definition! +$pca using 2 +puts "Observation: [lindex $data 0]" +puts "Approximation: [$pca approximate [lindex $data 0]]" +puts "Scores: [$pca scores [lindex $data 0]]" +puts "Q-statistic: [$pca qstatistic [lindex $data 0]]" +puts "(corrected) [$pca qstatistic [lindex $data 0] -original]" + +#puts [::math::PCA::createPCA $data -x 1] +} diff --git a/vendor/math/pca.test b/vendor/math/pca.test new file mode 100644 index 00000000..83a41fe6 --- /dev/null +++ b/vendor/math/pca.test @@ -0,0 +1,288 @@ +# -*- tcl -*- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.6 +testsNeedTcltest 1.0 + +support { + useLocal math.tcl math + useLocal linalg.tcl math::linearalgebra + useLocal statistics.tcl math::statistics +} +testing { + useLocal pca.tcl math::PCA +} + +#package require math::statistics + +# +# 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 the normalise/denormalise procedures + +test normalise-1.0 "Normalise a vector" -match numbers -body { + ::math::PCA::Normalise {1.0 2.0 3.0} {0.0 1.0 2.0} {2.0 2.0 2.0} +} -result {0.5 0.5 0.5} + +test normalise-1.1 "Denormalise a vector" -match numbers -body { + ::math::PCA::Denormalise {0.5 0.5 0.5} {0.0 1.0 2.0} {2.0 2.0 2.0} +} -result {1.0 2.0 3.0} + +set plusminus {{ 3.0 -3.0 -3.0 3.0} + {-3.0 3.0 3.0 -3.0} + { 0.0 0.0 0.0 0.0} + {-3.0 3.0 -3.0 3.0} + { 3.0 -3.0 3.0 -3.0}} + +set transformed {{ 1.0 -1.0 -1.0 1.0} + {-1.0 1.0 1.0 -1.0} + { 0.0 0.0 0.0 0.0} + {-1.0 1.0 -1.0 1.0} + { 1.0 -1.0 1.0 -1.0}} + +set zeroes {0.0 0.0 0.0 0.0} +set threes {3.0 3.0 3.0 3.0} + +set data {{7 4 3} + {4 1 8} + {6 3 5} + {8 6 1} + {8 5 7} + {7 2 9} + {5 3 3} + {9 5 8} + {7 4 5} + {8 2 2}} +set ones {1.0 1.0 1.0} + +test normalise-1.2 "Check transformation - transformed matrix" -match numbers -body { + lindex [::math::PCA::Transform $plusminus 1] 0 +} -result $transformed + +test normalise-1.3 "Check transformation - averages" -match numbers -body { + lindex [::math::PCA::Transform $plusminus 1] 1 +} -result $zeroes + +test normalise-1.4 "Check transformation - scale values" -match numbers -body { + lindex [::math::PCA::Transform $plusminus 1] 2 +} -result $threes + +test normalise-1.5 "Check transformation - unit standard deviations" -match numbers -body { + set transformedData [lindex [::math::PCA::Transform $data 1] 0] + set transposedMatrix [::math::linearalgebra::transpose $transformedData] + + set stdevs {} + foreach vector $transposedMatrix { + lappend stdevs [::math::statistics::stdev $vector] + } + set stdevs +} -result $ones + +test normalise-1.6 "Check transformation - retain lengths" -match numbers -body { + lindex [::math::PCA::Transform $data 0] 2 +} -result $ones + +test create-1.1 "Create a PCA object correctly" -match glob -setup { + set pca {} +} -body { + set pca [::math::PCA::createPCA $data] +} -cleanup { + if { $pca ne "" } { + $pca destroy + } +} -returnCodes 0 -result * + +test create-1.2 "Create a PCA object correctly - 2" -match glob -setup { + set pca {} +} -body { + set pca [::math::PCA::createPCA $data -covariance 0] +} -cleanup { + if { $pca ne "" } { + $pca destroy + } +} -returnCodes 0 -result * + +test create-1.3 "Create a PCA object incorrectly" -match glob -setup { + set pca {} +} -body { + ::math::PCA::createPCA $zeroes +} -cleanup { + if { $pca ne "" } { + $pca destroy + } +} -returnCodes 1 -result * + +test eigenvectors-1.1 "Get the eigenvectors - all" -match numbers -setup { + set pca [::math::PCA::createPCA $data] +} -body { + set eigenvectors [$pca eigenvectors] +} -cleanup { + if { $pca ne "" } { + $pca destroy + } +} -result { + {0.6420045763498947 -0.38467229168844363 -0.6632174243435957} + {0.6863616413605773 -0.0971303301343052 0.7207450285897333} + {-0.3416691692479824 -0.9179286066874492 0.20166618906061484}} + +test eigenvectors-1.2 "Get the eigenvalues - all" -match numbers -setup { + set pca [::math::PCA::createPCA $data] +} -body { + set eigenvalues [$pca eigenvalues] +} -cleanup { + if { $pca ne "" } { + $pca destroy + } +} -result {1.768774136103425 0.9270759168988945 0.30414994699768233} + +test eigenvectors-1.3 "Restrict to two components - eigenvectors" -match numbers -setup { + set pca [::math::PCA::createPCA $data] +} -body { + $pca using 2 + set eigenvectors [$pca eigenvectors] +} -cleanup { + if { $pca ne "" } { + $pca destroy + } +} -result { + {0.6420045763498947 -0.38467229168844363} + {0.6863616413605773 -0.0971303301343052} + {-0.3416691692479824 -0.9179286066874492}} + +test eigenvectors-1.4 "Restrict to two components - eigenvalues" -match numbers -setup { + set pca [::math::PCA::createPCA $data] +} -body { + $pca using 2 + set eigenvalues [$pca eigenvalues] +} -cleanup { + if { $pca ne "" } { + $pca destroy + } +} -result {1.768774136103425 0.9270759168988945} + +test eigenvectors-1.5 "Restrict to two components - get all eigenvectors" -match numbers -setup { + set pca [::math::PCA::createPCA $data] +} -body { + global pca + $pca using 2 + set eigenvectors [$pca eigenvectors -all] +} -cleanup { + if { $pca ne "" } { + $pca destroy + } +} -result { + {0.6420045763498947 -0.38467229168844363 -0.6632174243435957} + {0.6863616413605773 -0.0971303301343052 0.7207450285897333} + {-0.3416691692479824 -0.9179286066874492 0.20166618906061484}} + +test eigenvectors-1.6 "Restrict to two components - get all eigenvalues" -match numbers -setup { + set pca [::math::PCA::createPCA $data] +} -body { + $pca using 2 + set eigenvalues [$pca eigenvalues -all] +} -cleanup { + if { $pca ne "" } { + $pca destroy + } +} -result {1.768774136103425 0.9270759168988945 0.30414994699768233} + +test eigenvectors-1.7 "Use all components again" -match numbers -setup { + set pca [::math::PCA::createPCA $data] +} -body { + $pca using 3 + set eigenvectors [$pca eigenvectors] +} -cleanup { + if { $pca ne "" } { + $pca destroy + } +} -result { + {0.6420045763498947 -0.38467229168844363 -0.6632174243435957} + {0.6863616413605773 -0.0971303301343052 0.7207450285897333} + {-0.3416691692479824 -0.9179286066874492 0.20166618906061484}} + +test approximation-1.1 "Approximate an observation" -match numbers -setup { + set pca [::math::PCA::createPCA $data] +} -body { + $pca using 2 + set approximation [$pca approximate [lindex $::data 0]] +} -cleanup { + if { $pca ne "" } { + $pca destroy + } +} -result {7.03386897006181 3.961810336299144 2.981031668611465} + +test approximation-1.2 "Approximate an observation, get the scores" -match numbers -setup { + set pca [::math::PCA::createPCA $data] +} -body { + $pca using 2 + set scores [$pca scores [lindex $::data 0]] +} -result {0.5148128141212557 0.630835559461938} + +test approximation-1.3 "Approximate an observation, get the Q statistic" -match numbers -setup { + set pca [::math::PCA::createPCA $data] +} -body { + $pca using 2 + set qstatistic [$pca qstatistic [lindex $::data 0]] +} -cleanup { + if { $pca ne "" } { + $pca destroy + } +} -result 0.001123022217614874 + +test approximation-1.4 "Approximate an observation, get the corrected Q statistic" -match numbers -setup { + set pca [::math::PCA::createPCA $data] +} -body { + $pca using 2 + set qstatistic [$pca qstatistic [lindex $::data 0] -original] +} -cleanup { + if { $pca ne "" } { + $pca destroy + } +} -result 0.0016043174537355342 + +test approximation-2.1 "Approximate all original data (actually reconstruct)" -match numbers -setup { + set pca [::math::PCA::createPCA $data] +} -body { + # Note: as we use all components, we reconstruct the original data "exactly" + $pca using 3 + set approximation [$pca approximateOriginal] +} -cleanup { + if { $pca ne "" } { + $pca destroy + } +} -result $data diff --git a/vendor/math/pdf_stat.tcl b/vendor/math/pdf_stat.tcl new file mode 100644 index 00000000..77af5b43 --- /dev/null +++ b/vendor/math/pdf_stat.tcl @@ -0,0 +1,2676 @@ +# 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 pdf-triangular pdf-symmetric-triangular \ + cdf-normal cdf-uniform cdf-lognormal \ + cdf-exponential cdf-triangular cdf-symmetric-triangular \ + cdf-students-t \ + random-normal random-uniform random-lognormal \ + random-exponential random-triangular \ + histogram-uniform \ + pdf-gamma pdf-poisson pdf-chisquare pdf-students-t pdf-beta \ + pdf-weibull pdf-gumbel pdf-pareto pdf-cauchy \ + pdf-laplace pdf-kumaraswamy pdf-negative-binomial \ + cdf-gamma cdf-poisson cdf-chisquare cdf-beta cdf-F \ + cdf-weibull cdf-gumbel cdf-pareto cdf-cauchy \ + cdf-laplace cdf-kumaraswamy cdf-negative-binomial \ + random-gamma random-poisson random-chisquare random-students-t random-beta \ + random-weibull random-gumbel random-pareto random-cauchy \ + random-laplace random-kumaraswamy random-negative-binomial \ + incompleteGamma incompleteBeta \ + estimate-pareto empirical-distribution bootstrap estimate-exponential \ + estimate-laplace estimate-negative-binomial + + 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*$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-triangular -- +# Return the probabilities belonging to a triangular 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 +# +# Note: +# If pmin > pmax, the main weight will be at the larger +# values. +# +proc ::math::statistics::pdf-triangular { pmin pmax x } { + + if { $pmin == $pmax } { + return -code error -errorcode ARG \ + -errorinfo "Zero range" \ + "Zero range" + } + + if { $pmin < $pmax } { + if { $x < $pmin || $x > $pmax } { return 0.0 } + } else { + if { $x < $pmax || $x > $pmin } { return 0.0 } + } + + set prob [expr {2.0*(1.0-($x-$pmin)/($pmax-$pmin))}] + + + return $prob +} + + +# pdf-symmetric-triangular -- +# Return the probabilities belonging to a symmetric triangular 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-symmetric-triangular { pmin pmax x } { + + if { $pmin == $pmax } { + return -code error -errorcode ARG \ + -errorinfo "Zero range" \ + "Zero range" + } + + if { $pmin < $pmax } { + if { $x < $pmin || $x > $pmax } { return 0.0 } + } else { + if { $x < $pmax || $x > $pmin } { return 0.0 } + } + + set diff [expr {abs($pmax-$pmin)}] + set centre [expr {($pmax+$pmin)/2.0}] + + set prob [expr {2./$diff * (1.0 - 2.*abs($x-$centre)/$diff)}] + + 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 +} + + +# pdf-laplace -- +# Return the probabilities belonging to a Laplace +# distribution +# +# Arguments: +# mean Mean of the distribution +# scale Scale (the spreading) 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-laplace { mean scale x } { + variable NEGSTDEV + variable OUTOFRANGE + + if { $scale <= 0.0 } { + return -code error -errorcode ARG -errorinfo $OUTOFRANGE \ + "$OUTOFRANGE: scale must be positive" + } + + set prob [expr {exp(-($x-$mean)/double($scale))/(2.0*$scale)}] + + return $prob +} + + +# pdf-kumaraswamy -- +# Return the probabilities belonging to a Kumaraswamy +# distribution (akin to the Beta distribution, but tractable) +# +# Arguments: +# a First parameter of the Kumaraswamy distribution +# b Second parameter of the Kumaraswamy distribution +# x Value of variate +# +# Result: +# Probability of value x under the given distribution +# +proc ::math::statistics::pdf-kumaraswamy { a b x } { + variable OUTOFRANGE + + if { $a <= 0.0 || $b <= 0.0 } { + return -code error -errorcode ARG -errorinfo $OUTOFRANGE \ + "$OUTOFRANGE: parameters a and b must be positive" + } + + set prob [expr {$a * $b * $x**($a-1) * (1.0 -$x**$a)**($b-1)}] + + return $prob +} + + +# pdf-negative-binomial -- +# Return the probability belonging to a negative binomial +# distribution +# +# Arguments: +# r Allowed number of failures for the distribution +# p Probability of success for the negative bionomial distribution +# k Value of variate (integer) +# +# Result: +# Probability of k successes under the given distribution +# +proc ::math::statistics::pdf-negative-binomial { r p k } { + variable OUTOFRANGE + variable INVALID + + if { $p < 0.0 || $p >= 1.0 } { + return -code error -errorcode ARG -errorinfo $OUTOFRANGE \ + "$OUTOFRANGE: parameter p must be non-negative and lower than 1" + } + + if { int($r) != $r || $r < 1 } { + return -code error -errorcode ARG -errorinfo $INVALIDE \ + "$INVALID: parameter r must be a positive integer" + } + + set coeff [::math::choose [expr {$k+$r-1}] $k] + set prob [expr {$coeff * (1.0 - $p)**$r * $p ** $k}] + + 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*$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-triangular -- +# Return the cumulative probabilities belonging to a triangular 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 +# +# Note: +# If pmin > pmax, the main weight will be at the larger +# values. +# +proc ::math::statistics::cdf-triangular { pmin pmax x } { + + if { $pmin == $pmax } { + return -code error -errorcode ARG \ + -errorinfo "Zero range" \ + "Zero range" + } + + + if { $pmin < $pmax } { + if { $x < $pmin } { return 0.0 } + if { $x > $pmax } { return 1.0 } + set xm [expr {($x - $pmin) / ($pmax - $pmin)}] + set prob [expr {2.0*$xm - $xm**2}] + } else { + if { $x < $pmax } { return 0.0 } + if { $x > $pmin } { return 1.0 } + set xm [expr {($x - $pmax) / ($pmin - $pmax)}] + set prob [expr {$xm**2}] + } + + return $prob +} + + +# cdf-symmetric-triangular -- +# Return the cumulative probabilities belonging to a symmetric triangular 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::cdf-symmetric-triangular { pmin pmax x } { + + if { $pmin == $pmax } { + return -code error -errorcode ARG \ + -errorinfo "Zero range" \ + "Zero range" + } + + + set diff [expr {abs($pmax-$pmin)/2.0}] + set centre [expr {($pmax+$pmin)/2.0}] + + if { $pmin < $pmax } { + if { $x < $pmin } { return 0.0 } + if { $x > $pmax } { return 1.0 } + } else { + if { $x < $pmax } { return 0.0 } + if { $x > $pmin } { return 1.0 } + } + + if { $x < $centre } { + set xm [expr {($x - $centre + $diff) / $diff}] + set prob [expr {0.5 * $xm**2}] + } else { + set xm [expr {($x - $centre - $diff) / $diff}] + set prob [expr {1.0 - 0.5 * $xm**2}] + } + + 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 +} + + +# cdf-laplace -- +# Return the cumulative probabilities belonging to a Laplace +# distribution +# +# Arguments: +# mean Mean of the distribution +# scale Scale (the spreading) 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-laplace { mean scale x } { + variable NEGSTDEV + variable OUTOFRANGE + + if { $scale <= 0.0 } { + return -code error -errorcode ARG -errorinfo $OUTOFRANGE \ + "$OUTOFRANGE: scale must be positive" + } + + if { $x < $mean } { + set prob [expr {0.5 * exp(($x-$mean)/double($scale))}] + } else { + set prob [expr {1.0 - 0.5 * exp(($mean-$x)/double($scale))}] + } + + return $prob +} + + +# cdf-kumaraswamy -- +# Return the cumulative probabilities belonging to a Kumaraswamy +# distribution (akin to the Beta distribution, but tractable) +# +# Arguments: +# a First parameter of the Kumaraswamy distribution +# b Second parameter of the Kumaraswamy distribution +# x Value of variate +# +# Result: +# Cumulative probability of value x under the given distribution +# +proc ::math::statistics::cdf-kumaraswamy { a b x } { + variable OUTOFRANGE + + if { $a <= 0.0 || $b <= 0.0 } { + return -code error -errorcode ARG -errorinfo $OUTOFRANGE \ + "$OUTOFRANGE: parameters a and b must be positive" + } + + set prob [expr {1.0 - (1.0-$x**$a) ** $b}] + + return $prob +} + + +# cdf-negative-binomial -- +# Return the cumulative probability for a negative binomial distribution +# +# Arguments: +# r Allowed number of failures for the distribution +# p Probability of success for the negative bionomial distribution +# k Value of variate (integer) +# +# Result: +# Cumulative probability for up to k successes under the given distribution +# +proc ::math::statistics::cdf-negative-binomial { r p k } { + variable OUTOFRANGE + variable INVALID + + if { $p < 0.0 || $p >= 1.0 } { + return -code error -errorcode ARG -errorinfo $OUTOFRANGE \ + "$OUTOFRANGE: parameter p must be non-negative and lower than 1" + } + + if { int($r) != $r || $r < 1 } { + return -code error -errorcode ARG -errorinfo $INVALIDE \ + "$INVALID: parameter r must be a positive integer" + } + + set sum 0.0 + + for { set i 0 } { $i <= $k } { incr i } { + set prob [pdf-negative-binomial $r $p $i] + set sum [expr {$sum + $prob}] + } + + return $sum +} + + +# 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-triangular -- +# Return a list of random numbers satisfying a triangular +# 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-triangular { pmin pmax number } { + + if { $pmin == $pmax } { + return -code error -errorcode ARG \ + -errorinfo "Zero range" \ + "Zero range" + } + + set diff [expr {$pmax - $pmin}] + if { $pmin < $pmax } { + set result {} + for { set i 0 } {$i < $number } { incr i } { + set r [expr {1.0 - sqrt(1.0 - rand())}] + lappend result [expr {$pmin + $r * $diff}] + } + } else { + set result {} + for { set i 0 } {$i < $number } { incr i } { + lappend result [expr {$pmax - sqrt(rand()) * $diff}] + } + } + + return $result +} + + +# random-symmetric-triangular -- +# Return a list of random numbers satisfying a symmetric triangular +# 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-symmetric-triangular { pmin pmax number } { + + if { $pmin == $pmax } { + return -code error -errorcode ARG \ + -errorinfo "Zero range" \ + "Zero range" + } + + set diff2 [expr {0.5 * ($pmax - $pmin)}] + + set result {} + for { set i 0 } {$i < $number } { incr i } { + lappend result [expr {$pmin + $diff2 * (rand() + 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*$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 +# +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-F -- +# Return the cumulative probabilities belonging to an Fisher F distribution +# +# Arguments: +# nf1 Degrees of freedom for numerator +# nf2 Degrees of freedom for denominator +# x Value of variate +# +# Result: +# Cumulative probability of the given value of x to occur +# +proc ::math::statistics::cdf-F { nf1 nf2 x } { + set dx [expr {$nf1 * double($x) / ($nf1 * $x + $nf2)}] + incompleteBeta [expr {$nf1/2.0}] [expr {$nf2/2.0}] $dx +} + + +# 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 +} + + +# random-laplace -- +# Generate a list of Laplace distributed deviates +# +# Arguments: +# mean Mean of the distribution +# scale Scale (the spreading) of the distribution +# number Number of values to return +# +# Result: +# List of random numbers +# +proc ::math::statistics::random-laplace { mean scale number } { + variable NEGSTDEV + variable OUTOFRANGE + + if { $scale <= 0.0 } { + return -code error -errorcode ARG -errorinfo $OUTOFRANGE \ + "$OUTOFRANGE: scale must be positive" + } + + set retval {} + for {set i 0} {$i < $number} {incr i} { + set p [expr {rand()}] + if { $p < 0.5 } { + set x [expr {$mean + $scale * log(1.0 - 2.0*abs($p-0.5))}] + } else { + set x [expr {$mean - $scale * log(1.0 - 2.0*abs($p-0.5))}] + } + lappend retval $x + } + + return $retval +} + + +# random-kumaraswamy -- +# Generate a list of Kumaraswamy distributed deviates +# +# Arguments: +# a First parameter of the Kumaraswamy distribution +# b Second parameter of the Kumaraswamy distribution +# number Number of values to return +# +# Result: +# List of random numbers +# +proc ::math::statistics::random-kumaraswamy { a b number } { + variable OUTOFRANGE + + if { $a <= 0.0 || $b <= 0.0 } { + return -code error -errorcode ARG -errorinfo $OUTOFRANGE \ + "$OUTOFRANGE: parameters a and b must be positive" + } + + set ra [expr {1.0 / $a}] + set rb [expr {1.0 / $b}] + + set retval {} + for {set i 0} {$i < $number} {incr i} { + set p [expr {rand()}] + set x [expr {( 1.0 - (1.0-$p) ** $rb ) ** $ra}] + + lappend retval $x + } + + return $retval +} + + +# random-negative-binomial -- +# Generate a list of deviates according to the negative binomial distribution +# +# Arguments: +# r Allowed number of failures for the distribution +# p Probability of success for the negative bionomial distribution +# number Number of values to return +# +# Result: +# List of random numbers +# +proc ::math::statistics::random-negative-binomial { r p number } { + variable OUTOFRANGE + variable INVALID + + if { $p < 0.0 || $p >= 1.0 } { + return -code error -errorcode ARG -errorinfo $OUTOFRANGE \ + "$OUTOFRANGE: parameter p must be non-negative and lower than 1" + } + + if { int($r) != $r || $r < 1} { + return -code error -errorcode ARG -errorinfo $INVALIDE \ + "$INVALID: parameter r must be a positive integer" + } + + set retval {} + for {set i 0} {$i < $number} {incr i} { + set success 0 + set failure 0 + + while { $failure < $r } { + if { rand() <= $p } { + incr success + } else { + incr failure + } + } + + lappend retval $success + } + + 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)}]] +} + + +# estimate-exponential -- +# Estimate the parameter of an exponential distribution +# +# Arguments: +# values Values that are supposed to be exponentially distributed +# +# Result: +# Estimate of the one parameter of the exponential distribution +# as well as the asymptotic standard deviation +# (See https://www.statlect.com/fundamentals-of-statistics/exponential-distribution-maximum-likelihood) +# +proc ::math::statistics::estimate-exponential { values } { + + set sum 0.0 + set count 0 + + foreach v $values { + if { $v != "" } { + set sum [expr {$sum + $v}] + incr count + } + } + + set parameter [expr {$sum/double($count)}] + set stdev [expr {$parameter / sqrt($count)}] + + return [list $parameter $stdev] +} + + +# estimate-laplace -- +# Estimate the parameter of a Laplace distribution +# +# Arguments: +# values Values that are supposed to be Laplace distributed +# +# Result: +# Estimates of respectively the mean and the scale of the Laplace distribution +# (See https://en.wikipedia.org/wiki/Laplace_distribution) +# +# Note: +# According to Wikipedia the estimators are maximum-likelihood estimators +# +proc ::math::statistics::estimate-laplace { values } { + + set mean [median $values] + + set sum 0.0 + set count 0 + + foreach v $values { + if { $v != "" } { + set sum [expr {$sum + abs($v-$mean)}] + incr count + } + } + + set scale [expr {$sum/double($count)}] + + return [list $mean $scale] +} + + +# estimate-negative-binomial -- +# Estimate the parameter p of a negative binomial distribution, +# given the allowed number of failures +# +# Arguments: +# r Allowed number of failures +# values Values that are supposed to be distributed according to a negative binomial distribution +# +# Result: +# Estimate of the probability of success for the distribution +# +# Note: +# According to Wikipedia the estimators are maximum-likelihood estimators +# +proc ::math::statistics::estimate-negative-binomial { r values } { + + set sum 0.0 + set count 0 + + foreach v $values { + if { $v != "" } { + set sum [expr {$sum + $v}] + incr count + } + } + + return [expr {$sum/double($count * $r + $sum)}] +} + + +# 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 +} + + +# bootstrap -- +# Return samples according to the "bootstrap" method +# +# Arguments: +# data List of data from which to construct the new sample or samples +# sampleSize Number of values to draw for each sample +# numberSamples Number of samples (defaults to 1) +# +# Result: +# Either a list of "sampleSize" values (if only one sample is required) or +# a list of "numberSamples" each of which is a list of "sampleSize" values. +# +proc ::math::statistics::bootstrap {data sampleSize {numberSamples 1}} { + if { $numberSamples > 1 } { + set samples {} + for {set i 0} {$i < $numberSamples} {incr i} { + lappend samples [bootstrap $data $sampleSize 1] + } + return $samples + + } else { + set sample {} + set numberData [llength $data] + for {set i 0} {$i < $sampleSize} {incr i} { + set idx [expr {int(rand() * $numberData)}] + lappend sample [lindex $data $idx] + } + return $sample + } +} + + +# +# 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 + + puts [::math::statistics::cdf-F 3 3 0.05] +} diff --git a/vendor/math/pkgIndex.tcl b/vendor/math/pkgIndex.tcl new file mode 100644 index 00000000..6d6b10ac --- /dev/null +++ b/vendor/math/pkgIndex.tcl @@ -0,0 +1,42 @@ +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::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::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} +package ifneeded math::optimize 1.0.1 [list source [file join $dir optimize.tcl]] +package ifneeded math::interpolate 1.1.2 [list source [file join $dir interpolate.tcl]] +package ifneeded math::bignum 3.1.1 [list source [file join $dir bignum.tcl]] +package ifneeded math::bigfloat 1.2.3 [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 1.0 [list source [file join $dir calculus.tcl]] +# statistics depends on linearalgebra (for multi-variate linear regression). +# statistics depends on optimize (for logistic regression). +package ifneeded math::statistics 1.5.0 [list source [file join $dir statistics.tcl]] +package ifneeded math::linearalgebra 1.1.6 [list source [file join $dir linalg.tcl]] +package ifneeded math::calculus::symdiff 1.0.1 [list source [file join $dir symdiff.tcl]] +package ifneeded math::bigfloat 2.0.4 [list source [file join $dir bigfloat2.tcl]] +package ifneeded math::numtheory 1.1.3 [list source [file join $dir numtheory.tcl]] +package ifneeded math::decimal 1.0.4 [list source [file join $dir decimal.tcl]] +package ifneeded math::geometry 1.4.1 [list source [file join $dir geometry.tcl]] +package ifneeded math::trig 1.0 [list source [file join $dir trig.tcl]] +package ifneeded math::quasirandom 1.0 [list source [file join $dir quasirandom.tcl]] +package ifneeded math::special 0.5.2 [list source [file join $dir special.tcl]] + +if {![package vsatisfies [package require Tcl] 8.6]} {return} +package ifneeded math::exact 1.0.1 [list source [file join $dir exact.tcl]] +package ifneeded math::PCA 1.0 [list source [file join $dir pca.tcl]] +package ifneeded math::figurate 1.0 [list source [file join $dir figurate.tcl]] +package ifneeded math::filters 0.1 [list source [file join $dir filtergen.tcl]] +package ifneeded math::probopt 1.0 [list source [file join $dir probopt.tcl]] +package ifneeded math::changepoint 0.1 [list source [file join $dir changepoint.tcl]] +package ifneeded math::combinatorics 2.0 [list source [file join $dir combinatoricsExt.tcl]] diff --git a/vendor/math/plotstat.tcl b/vendor/math/plotstat.tcl new file mode 100644 index 00000000..1c38fcb0 --- /dev/null +++ b/vendor/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/vendor/math/polynomials.man b/vendor/math/polynomials.man new file mode 100644 index 00000000..4b1587d6 --- /dev/null +++ b/vendor/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 }] +[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 ../common-text/feedback.inc] +[manpage_end] diff --git a/vendor/math/polynomials.tcl b/vendor/math/polynomials.tcl new file mode 100644 index 00000000..928d3c86 --- /dev/null +++ b/vendor/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/vendor/math/polynomials.test b/vendor/math/polynomials.test new file mode 100644 index 00000000..39d60f68 --- /dev/null +++ b/vendor/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.5 +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/vendor/math/primes.tcl b/vendor/math/primes.tcl new file mode 100644 index 00000000..073414e4 --- /dev/null +++ b/vendor/math/primes.tcl @@ -0,0 +1,569 @@ +## +## This is the file `primes.tcl', +## generated with the SAK utility +## (sak docstrip/regen). +## +## The original source files were: +## +## numtheory.dtx (with options: `pkg_primes pkg_common') +## +## 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. +# primes.tcl -- +# Provide additional procedures for the number theory package +# +namespace eval ::math::numtheory { + variable primes {2 3 5 7 11 13 17} + variable nextPrimeCandidate 19 + variable nextPrimeIncrement 1 ;# Examine numbers 6n+1 and 6n+5 + + namespace export firstNprimes primesLowerThan primeFactors uniquePrimeFactors factors \ + totient moebius legendre jacobi gcd lcm \ + numberPrimesGauss numberPrimesLegendre numberPrimesLegendreModified \ + differenceNumberPrimesLegendreModified listPrimeProgressions +} + +# ComputeNextPrime -- +# Determine the next prime +# +# Arguments: +# None +# +# Result: +# None +# +# Side effects: +# One prime added to the list of primes +# +# Note: +# Using a true sieve of Erathostenes might be faster, but +# this does work. Even computing the first ten thousand +# does not seem to be slow. +# +proc ::math::numtheory::ComputeNextPrime {} { + variable primes + variable nextPrimeCandidate + variable nextPrimeIncrement + + while {1} { + # + # Test the current candidate + # + set sqrtCandidate [expr {sqrt($nextPrimeCandidate)}] + + set isprime 1 + foreach p $primes { + if { $p > $sqrtCandidate } { + break + } + if { $nextPrimeCandidate % $p == 0 } { + set isprime 0 + break + } + } + + if { $isprime } { + lappend primes $nextPrimeCandidate + } + + # + # In any case get the next candidate + # + if { $nextPrimeIncrement == 1 } { + set nextPrimeIncrement 5 + set nextPrimeCandidate [expr {$nextPrimeCandidate + 4}] + } else { + set nextPrimeIncrement 1 + set nextPrimeCandidate [expr {$nextPrimeCandidate + 2}] + } + + if { $isprime } { + break + } + } +} + +# firstNprimes -- +# Return the first N primes +# +# Arguments: +# number Number of primes to return +# +# Result: +# List of the first $number primes +# +proc ::math::numtheory::firstNprimes {number} { + variable primes + + while { [llength $primes] < $number } { + ComputeNextPrime + } + + return [lrange $primes 0 [expr {$number-1}]] +} + +# primesLowerThan -- +# Return the primes lower than some threshold +# +# Arguments: +# threshold Threshold for the primes +# +# Result: +# List of primes lower/equal to the threshold +# +proc ::math::numtheory::primesLowerThan {threshold} { + variable primes + + while { [lindex $primes end] < $threshold } { + ComputeNextPrime + } + + set n 0 + foreach p $primes { + if { $p > $threshold } { + break + } else { + incr n + } + } + return [lrange $primes 0 [expr {$n-1}]] +} + +# primeFactors -- +# Determine the prime factors of a number +# +# Arguments: +# number Number to factorise +# +# Result: +# List of prime factors +# +proc ::math::numtheory::primeFactors {number} { + variable primes + + # + # Make sure we have enough primes + # + primesLowerThan [expr {sqrt($number)}] + + set factors {} + + set idx 0 + + while { $number > 1 } { + set p [lindex $primes $idx] + if {$p == {}} { + lappend factors $number + break + } + if { $number % $p == 0 } { + lappend factors $p + set number [expr {$number/$p}] + } else { + incr idx + } + } + + return $factors +} + +# uniquePrimeFactors -- +# Determine the unique prime factors of a number +# +# Arguments: +# number Number to factorise +# +# Result: +# List of unique prime factors +# +proc ::math::numtheory::uniquePrimeFactors {number} { + return [lsort -unique -integer [primeFactors $number]] +} + +# totient -- +# Evaluate the Euler totient function for a number +# +# Arguments: +# number Number in question +# +# Result: +# Totient of the given number (number of numbers +# relatively prime to the number) +# +proc ::math::numtheory::totient {number} { + set factors [uniquePrimeFactors $number] + + set totient $number + + foreach f $factors { + set totient [expr {($totient * ($f-1)) / $f}] + } + + return $totient +} + +# factors -- +# Return all (unique) factors of a number +# +# Arguments: +# number Number in question +# +# Result: +# List of factors including 1 and the number itself +# +# Note: +# The algorithm for constructing the power set was taken from +# wiki.tcl.tk/2877 (algorithm subsets2b). +# +proc ::math::numtheory::factors {number} { + set factors [primeFactors $number] + + # + # Iterate over the power set of this list + # + set result [list 1 $number] + for {set n 1} {$n < [llength $factors]} {incr n} { + set subsets [list [list]] + foreach f $factors { + foreach subset $subsets { + lappend subset $f + if {[llength $subset] == $n} { + lappend result [Product $subset] + } else { + lappend subsets $subset + } + } + } + } + return [lsort -unique -integer $result] +} + +# Product -- +# Auxiliary function: return the product of a list of numbers +# +# Arguments: +# list List of numbers +# +# Result: +# The product of all the numbers +# +proc ::math::numtheory::Product {list} { + set product 1 + foreach e $list { + set product [expr {$product * $e}] + } + return $product +} + +# moebius -- +# Return the value of the Moebius function for "number" +# +# Arguments: +# number Number in question +# +# Result: +# The product of all the numbers +# +proc ::math::numtheory::moebius {number} { + if { $number < 1 } { + return -code error "The number must be positive" + } + if { $number == 1 } { + return 1 + } + + set primefactors [primeFactors $number] + if { [llength $primefactors] != [llength [lsort -unique -integer $primefactors]] } { + return 0 + } else { + return [expr {(-1)**([llength $primefactors]%2)}] + } +} + +# legendre -- +# Return the value of the Legendre symbol (a/p) +# +# Arguments: +# a Upper number in the symbol +# p Lower number in the symbol +# +# Result: +# The Legendre symbol +# +proc ::math::numtheory::legendre {a p} { + if { $p == 0 } { + return -code error "The number p must be non-zero" + } + + if { $a % $p == 0 } { + return 0 + } + + # + # Just take the brute force route + # (Negative values of a present a small problem, but only a small one) + # + while { $a < 0 } { + set a [expr {$p + $a}] + } + + set legendre -1 + for {set n 1} {$n < $p} {incr n} { + if { $n**2 % $p == $a } { + set legendre 1 + break + } + } + + return $legendre +} + +# jacobi -- +# Return the value of the Jacobi symbol (a/b) +# +# Arguments: +# a Upper number in the symbol +# b Lower number in the symbol +# +# Result: +# The Jacobi symbol +# +# Note: +# Implementation adopted from the Wiki - http://wiki.tcl.tk/36990 +# encoded by rmelton 9/25/12 +# Further references: +# http://en.wikipedia.org/wiki/Jacobi_symbol +# http://2000clicks.com/mathhelp/NumberTh27JacobiSymbolAlgorithm.aspx +# +proc ::math::numtheory::jacobi {a b} { + if { $b<=0 || ($b&1)==0 } { + return 0; + } + + set j 1 + if {$a<0} { + set a [expr {0-$a}] + set j [expr {0-$j}] + } + while {$a != 0} { + while {($a&1) == 0} { + ##/* Process factors of 2: Jacobi(2,b)=-1 if b=3,5 (mod 8) */ + set a [expr {$a>>1}] + if {(($b & 7)==3) || (($b & 7)==5)} { + set j [expr {0-$j}] + } + } + ##/* Quadratic reciprocity: Jacobi(a,b)=-Jacobi(b,a) if a=3,b=3 (mod 4) */ + lassign [list $a $b] b a + if {(($a & 3)==3) && (($b & 3)==3)} { + set j [expr {0-$j}] + } + set a [expr {$a % $b}] + } + if {$b==1} { + return $j + } else { + return 0 + } +} + +# gcd -- +# Return the greatest common divisor of two numbers n and m +# +# Arguments: +# n First number +# m Second number +# +# Result: +# The greatest common divisor +# +proc ::math::numtheory::gcd {n m} { + # + # Apply Euclid's good old algorithm + # + if { $n > $m } { + set t $n + set n $m + set m $t + } + + while { $n > 0 } { + set r [expr {$m % $n}] + set m $n + set n $r + } + + return $m +} + +# lcm -- +# Return the lowest common multiple of two numbers n and m +# +# Arguments: +# n First number +# m Second number +# +# Result: +# The lowest common multiple +# +proc ::math::numtheory::lcm {n m} { + set gcd [gcd $n $m] + return [expr {$n*$m/$gcd}] +} + +# numberPrimesGauss -- +# Return the approximate number of primes lower than the given value based on the formula by Gauss +# +# Arguments: +# limit The limit for the largest prime to be included in the estimate +# +# Returns: +# Approximate number of primes +# +proc ::math::numtheory::numberPrimesGauss {limit} { + if { $limit <= 1 } { + return -code error "The limit must be larger than 1" + } + expr {$limit / log($limit)} +} + +# numberPrimesLegendre -- +# Return the approximate number of primes lower than the given value based on the formula by Legendre +# +# Arguments: +# limit The limit for the largest prime to be included in the estimate +# +# Returns: +# Approximate number of primes +# +proc ::math::numtheory::numberPrimesLegendre {limit} { + if { $limit <= 1 } { + return -code error "The limit must be larger than 1" + } + expr {$limit / (log($limit) - 1.0)} +} + +# numberPrimesLegendreModified -- +# Return the approximate number of primes lower than the given value based on the +# modified formula by Legendre +# +# Arguments: +# limit The limit for the largest prime to be included in the estimate +# +# Returns: +# Approximate number of primes +# +proc ::math::numtheory::numberPrimesLegendreModified {limit} { + if { $limit <= 1 } { + return -code error "The limit must be larger than 1" + } + expr {$limit / (log($limit) - 1.08366)} +} + +# differenceNumberPrimesLegendreModified -- +# Return the approximate difference number of primes +# between a lower and higher limit as given values +# for approximate number of primes based on the +# modified formula by Legendre +# +# Arguments: +# limit1 The lower limit for the interval, largest prime to be included in the l.limit +# limit2 The upper limit for the interval, largest prime to be included in the u.mlimit +# +# Returns: +# Approximate difference number of primes +# +proc ::math::numtheory::differenceNumberPrimesLegendreModified {limit1 limit2} { + if { $limit1 <= 1 } { + return -code error "The lower limit must be larger than 1" + } + if { $limit2 <= 1 } { + return -code error "The upper limit must be larger than 1" + } + + set aa [::math::numtheory::numberPrimesLegendreModified [expr ($limit1)]] + set bb [::math::numtheory::numberPrimesLegendreModified [expr ($limit2)]] + expr {abs($bb-$aa)} +} + +# listPrimeProgressions -- +# Return a list of arithmetic progressions of primes that differ by a given number +# +# Arguments: +# lower The lower limit for the interval from which to chose the primes +# upper The upper limit for the interval +# step The difference between sucessive primes (default to 2) +# +# Returns: +# A list of lists of successive primes differing the given step +# +proc ::math::numtheory::listPrimeProgressions {lower upper {step 2}} { + if { $upper <= $lower } { + return -code error "The upper limit must be larger than the lower limit" + } + if { $step <= 0 } { + return -code error "The step must be at least 1" + } + + set output {} + set found {} + for {set i $lower} {$i <= $upper} {incr i 1} { + if { [isprime $i] } { + set newset $i + for { set j [expr {$i + $step}]} {$j <= $upper} {incr j $step} { + if { [isprime $j] && $j ni $found } { + lappend newset $j + lappend found $j + } else { + break + } + } + if { [llength $newset] > 1 } { + lappend output $newset + } + } + } + + return $output +} + +# listPrimePairs -- +# Return a list of pairso of primes that differ by a given number +# +# Arguments: +# lower The lower limit for the interval from which to chose the primes +# upper The upper limit for the interval +# step The difference between sucessive primes (default to 2) +# +# Returns: +# A list of pairs of primes differing the given step +# +proc ::math::numtheory::listPrimePairs {lower upper {step 2}} { + if { $upper <= $lower } { + return -code error "The upper limit must be larger than the lower limit" + } + if { $step <= 0 } { + return -code error "The step must be at least 1" + } + + set output {} + for {set i $lower} {$i <= $upper} {incr i 1} { + set next [expr {$i + $step}] + if { [isprime $i] && [isprime $next] } { + lappend output [list $i $next] + } + } + + return $output +} + +## +## +## End of file `primes.tcl'. diff --git a/vendor/math/primes.test b/vendor/math/primes.test new file mode 100644 index 00000000..23ba3413 --- /dev/null +++ b/vendor/math/primes.test @@ -0,0 +1,231 @@ +## +## This is the file `primes.test', +## generated with the SAK utility +## (sak docstrip/regen). +## +## The original source files were: +## +## numtheory.dtx (with options: `test_primes test_common') +## +## In other words: +## ************************************** +## * This Source is not the True Source * +## ************************************** +## the true source is the file from which this one was generated. +## +# -*- tcl -*- +# primes.test -- +# Additional test cases for the ::math::numtheory package +# +# Note: +# The tests assume tcltest 2.1, in order to compare +# list of integer results + +# ------------------------------------------------------------------------- + +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 numtheory.tcl math::numtheory +} + +proc matchLists { expected actual } { + set match 1 + foreach a $actual e $expected { + if { $a != $e } { + set match 0 + break + } + } + return $match +} + +proc matchNestedLists { expected actual } { + set match 1 + foreach a $actual e $expected { + if { ! [matchLists $a $e] } { + set match 0 + break + } + } + return $match +} + +customMatch equalLists matchLists +customMatch equalNestedLists matchNestedLists + +test first-few-primes-1 "First 10 primes" -match equalLists -body { + ::math::numtheory::firstNprimes 10 +} -result {2 3 5 7 11 13 17 19 23 29} + +test first-few-primes-2 "First 12 primes" -match equalLists -body { + ::math::numtheory::firstNprimes 12 +} -result {2 3 5 7 11 13 17 19 23 29 31 37} + +test first-few-primes-3 "First 20 primes" -match equalLists -body { + ::math::numtheory::firstNprimes 20 +} -result {2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71} + +test primes-lower-than-1 "Primes lower/equal 101" -match equalLists -body { + ::math::numtheory::primesLowerThan 101 +} -result {2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97 101} + +test primes-lower-than-2 "Primes lower/equal 2" -match equalLists -body { + ::math::numtheory::primesLowerThan 2 +} -result {2} + +test primes-lower-than-3 "Primes lower/equal 4" -match equalLists -body { + ::math::numtheory::primesLowerThan 4 +} -result {2 3} + +test primes-lower-than-4 "Primes lower/equal 102" -match equalLists -body { + ::math::numtheory::primesLowerThan 102 +} -result {2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97 101} + +test prime-factors-1 "Prime factors 100" -match equalLists -body { + ::math::numtheory::primeFactors 100 +} -result {2 2 5 5} + +test prime-factors-2 "Unique prime factors 100" -match equalLists -body { + ::math::numtheory::uniquePrimeFactors 100 +} -result {2 5} + +test prime-factors-3 "Prime factors 2900" -match equalLists -body { + ::math::numtheory::primeFactors 2900 +} -result {2 2 5 5 29} + +test prime-factors-4 "Unique prime factors 2900" -match equalLists -body { + ::math::numtheory::uniquePrimeFactors 2900 +} -result {2 5 29} + +test prime-factors-5 "Prime factors 964" -match equalLists -body { + ::math::numtheory::primeFactors 964 +} -result {2 2 241} + +test prime-factors-6 "Prime factors 960" -match equalLists -body { + ::math::numtheory::primeFactors 960 +} -result {2 2 2 2 2 2 3 5} + +test prime-factors-7 "Prime factors 914" -match equalLists -body { + ::math::numtheory::primeFactors 914 +} -result {2 457} + +test totient-1 "Totient 15" -body { + ::math::numtheory::totient 15 +} -result 8 + +test totient-2 "Totient 30" -body { + ::math::numtheory::totient 30 +} -result 8 + +test totient-3 "Totient 35" -body { + ::math::numtheory::totient 35 +} -result 24 + +test totient-4 "Totient 105" -body { + ::math::numtheory::totient 105 +} -result 48 + +test totient-5 "Totient 1-12" -match equalLists -body { + set result {} + for {set n 1} {$n <= 12} {incr n} { + lappend result [::math::numtheory::totient $n] + } + set result +} -result {1 1 2 2 4 2 6 4 6 4 10 4} + +test factors-1 "All factors 30" -match equalLists -body { + ::math::numtheory::factors 30 +} -result {1 2 3 5 6 10 15 30} + +test factors-1 "All factors 128" -match equalLists -body { + ::math::numtheory::factors 128 +} -result {1 2 4 8 16 32 64 128} + +test factors-1 "All factors 250" -match equalLists -body { + ::math::numtheory::factors 250 +} -result {1 2 5 10 25 50 125 250} + +test moebius-1 "Moebius for first 19 numbers" -match equalLists -body { + set result {} + for {set n 1} {$n < 20} {incr n} { + lappend result [::math::numtheory::moebius $n] + } + set result +} -result {1 -1 -1 0 -1 1 -1 0 0 1 -1 0 -1 1 1 0 -1 0 -1} + +test legendre-1 "Legendre symbol (-1/3)" -body { + ::math::numtheory::legendre -1 3 +} -result -1 +test legendre-2 "Legendre symbol (-3/7)" -body { + ::math::numtheory::legendre -3 7 +} -result 1 + +test jacobi-1 "Jacobi symbol (6/7)" -body { + ::math::numtheory::jacobi 6 7 +} -result -1 + +test jacobi-2 "Jacobi symbol (6/9)" -body { + ::math::numtheory::jacobi 6 9 +} -result 0 + +test jacobi-3 "Jacobi symbol (3/11)" -body { + ::math::numtheory::jacobi 3 11 +} -result 1 + +test gcd-1 "Greatest common divisor 2 and 3" -body { + ::math::numtheory::gcd 2 3 +} -result 1 + +test gcd-2 "Greatest common divisor 20 and 12" -body { + ::math::numtheory::gcd 20 12 +} -result 4 + +test gcd-3 "Greatest common divisor 600 and 125" -body { + ::math::numtheory::gcd 600 125 +} -result 25 + +test lcm-1 "Lowest common multiple 3 and 4" -body { + ::math::numtheory::lcm 3 4 +} -result 12 + +test lcm-2 "Lowest common multiple 12 and 20" -body { + ::math::numtheory::lcm 12 20 +} -result 60 + +test number-primes "Exercise prime estimators" -match equalLists -body { + set estimate1 [::math::numtheory::numberPrimesGauss 1000] + set estimate2 [::math::numtheory::numberPrimesLegendre 1000] + set estimate3 [::math::numtheory::numberPrimesLegendreModified 1000] + set result [list [expr {int($estimate1)}] [expr {int($estimate2)}] [expr {int($estimate3)}]] +} -result {144 169 171} + +test list-primes-1 "Pairs of primes - twins" -match equalNestedLists -body { + ::math::numtheory::listPrimePairs 3 100 +} -result {{3 5} {5 7} {11 13} {17 19} {29 31} {41 43} {59 61} {71 73}} + +test list-primes-2 "Pairs of primes differing by 6 " -match equalNestedLists -body { + ::math::numtheory::listPrimePairs 3 100 6 +} -result {{5 11} {7 13} {11 17} {13 19} {17 23} {23 29} {31 37} {37 43} {41 47} {47 53} {53 59} {61 67} {67 73} {73 79} {83 89} {97 103}} + +test list-primes-3 "Progressions of primes differing by 2 " -match equalNestedLists -body { + ::math::numtheory::listPrimeProgressions 3 100 2 +} -result {{3 5 7} {11 13} {17 19} {29 31} {41 43} {59 61} {71 73}} + +test list-primes-4 "Progressions of primes differing by 6 " -match equalNestedLists -body { + ::math::numtheory::listPrimeProgressions 3 100 6 +} -result {{5 11 17 23 29} {7 13 19} {31 37 43} {41 47 53 59} {61 67 73 79} {83 89}} + +testsuiteCleanup +## +## +## End of file `primes.test'. diff --git a/vendor/math/probopt.man b/vendor/math/probopt.man new file mode 100644 index 00000000..f5bbc682 --- /dev/null +++ b/vendor/math/probopt.man @@ -0,0 +1,226 @@ +[vset VERSION 1] +[manpage_begin math::probopt n [vset VERSION]] +[keywords {probabilistic calculations}] +[keywords optimisation] +[keywords mathematics] +[moddesc {Tcl Math Library}] +[titledesc {Probabilistic optimisation methods}] +[category Mathematics] +[require Tcl 8.6] +[require TclOO] +[require math::probopt [vset VERSION]] +[description] +[para] + +The purpose of the [package math::probopt] package is to provide various optimisation +algorithms that are based on probabilistic techniques. The results of these algorithms +may therefore vary from one run to the next. The algorithms are all well-known and +well described and proponents generally claim they are efficient and reliable. +[para] + +As most of these algorithms have one or more tunable parameters or even variations, +the interface to each accepts options to set these parameters or the select +the variation. These take the form of key-value pairs, for instance, [term {-iterations 100}]. +[para] + +This manual does not offer any recommendations with regards to these algorithms, nor +does it provide much in the way of guidelines for the parameters. For this we refer to +online articles on the algorithms in question. +[para] + +A few notes, however: +[list_begin itemized] +[item] +With the exception of LIPO, the algorithms are capable of dealing with irregular (non-smooth) and even discontinuous +functions. +[item] +The results depend on the random number seeding and are likely not to be very accurate, especially if the function +varies slowly in the vicinty of the optimum. They do give a good starting point for a deterministic algorithm. +[list_end] + +[para] +The collection consists of the following algorithms: +[list_begin itemized] +[item] +PSO - particle swarm optimisation + +[item] +SCE - shuffled complexes evolution + +[item] +DE - differential evolution + +[item] +LIPO - Lipschitz optimisation +[list_end] + +The various procedures have a uniform interface: +[example { + set result [::math::probopt::algorithm function bounds args] +}] + +The arguments have the following meaning: +[list_begin itemized] +[item] +The argument [term function] is the name of the procedure that evaluates the function. +Its interface is: +[example { + set value [function coords] +}] + +where [term coords] is a list of coordinates at which to evaluate the function. It is +supposed to return the function value. + +[item] +The argument [term bounds] is a list of pairs of minimum and maximum for each coordinate. +This list implicitly determines the dimension of the coordinate space in which the optimum +is to be sought, for instance for a function like [term {x**2 + (y-1)**4}], you may specify +the bounds as [term "{{-1 1} {-1 1}}"], that is, two pairs for the two coordinates. + +[item] +The rest ([term args]) consists of zero or more key-value pairs to specify the options. Which +options are supported by which algorithm, is documented below. +[list_end] + +The result of the various optimisation procedures is a dictionary containing at least the +following elements: +[list_begin itemized] +[item] +[term optimum-coordinates] is a list containing the coordinates of the optimum that was found. + +[item] +[term optimum-value] is the function value at those coordinates. + +[item] +[term evaluations] is the number of function evaluations. + +[item] +[term best-values] is a list of successive best values, obtained as +part of the iterations. +[list_end] + +[section "DETAILS ON THE ALGORITHMS"] +The algorithms in the package are the following: + +[list_begin definitions] + +[call [cmd ::math::probopt::pso] [arg function] [arg bounds] [arg args]] +The "particle swarm optimisation" algorithm uses the idea that the candidate +optimum points should swarm around the best point found so far, with +variations to allow for improvements. +[para] + +It recognises the following options: +[list_begin itemized] +[item] [term {-swarmsize number}]: Number of particles to consider (default: 50) +[item] [term {-vweight value}]: Weight for the current "velocity" (0-1, default: 0.5) +[item] [term {-pweight value}]: Weight for the individual particle's best position (0-1, default: 0.3) +[item] [term {-gweight value}]: Weight for the "best" overall position as per particle (0-1, default: 0.3) +[item] [term {-type local/global}]: Type of optimisation +[item] [term {-neighbours number}]: Size of the neighbourhood (default: 5, used if "local") +[item] [term {-iterations number}]: Maximum number of iterations +[item] [term {-tolerance value}]: Absolute minimal improvement for minimum value +[list_end] + + +[call [cmd ::math::probopt::sce] [arg function] [arg bounds] [arg args]] +The "shuffled complex evolution" algorithm is an extension of the Nelder-Mead algorithm that +uses multiple complexes and reorganises these complexes to find the "global" optimum. +[para] + +It recognises the following options: +[list_begin itemized] +[item] [term {-complexes number}]: Number of particles to consider (default: 2) +[item] [term {-mincomplexes number}]: Minimum number of complexes (default: 2; not currently used) +[item] [term {-newpoints number}]: Number of new points to be generated (default: 1) +[item] [term {-shuffle number}]: Number of iterations after which to reshuffle the complexes (if set to 0, the default, a number will be calculated from the number of dimensions) +[item] [term {-pointspercomplex number}]: Number of points per complex (if set to 0, the default, a number will be calculated from the number of dimensions) +[item] [term {-pointspersubcomplex number}]: Number of points per subcomplex (used to select the best points in each complex; if set to 0, the default, a number will be calculated from the number of dimensions) +[item] [term {-iterations number}]: Maximum number of iterations (default: 100) +[item] [term {-maxevaluations number}]: Maximum number of function evaluations (when this number is reached the iteration is broken off. Default: 1000 million) +[item] [term {-abstolerance value}]: Absolute minimal improvement for minimum value (default: 0.0) +[item] [term {-reltolerance value}]: Relative minimal improvement for minimum value (default: 0.001) +[list_end] + + +[call [cmd ::math::probopt::diffev] [arg function] [arg bounds] [arg args]] +The "differential evolution" algorithm uses a number of initial points that are then updated using randomly selected points. It is more or less akin +to genetic algorithms. It is controlled by two parameters, factor and lambda, where the first determines the update via random points and the second +the update with the best point found sofar. +[para] + +It recognises the following options: +[list_begin itemized] +[item] [term {-iterations number}]: Maximum number of iterations (default: 100) +[item] [term {-number number}]: Number of point to work with (if set to 0, the default, it is calculated from the number of dimensions) +[item] [term {-factor value}]: Weight of randomly selected points in the updating (0-1, default: 0.6) +[item] [term {-lambda value}]: Weight of the best point found so far in the updating (0-1, default: 0.0) +[item] [term {-crossover value}]: Fraction of new points to be considered for replacing the old ones (0-1, default: 0.5) +[item] [term {-maxevaluations number}]: Maximum number of function evaluations (when this number is reached the iteration is broken off. Default: 1000 million) +[item] [term {-abstolerance value}]: Absolute minimal improvement for minimum value (default: 0.0) +[item] [term {-reltolerance value}]: Relative minimal improvement for minimum value (default: 0.001) +[list_end] + + +[call [cmd ::math::probopt::lipoMax] [arg function] [arg bounds] [arg args]] +The "Lipschitz optimisation" algorithm uses the "Lipschitz" property of the given function to find a [emph maximum] in the given bounding box. There are +two variants, [term lipoMax] assumes a fixed estimate for the Lipschitz parameter. +[para] + +It recognises the following options: +[list_begin itemized] +[item] [term {-iterations number}]: Number of iterations (equals the actual number of function evaluations, default: 100) +[item] [term {-lipschitz value}]: Estimate of the Lipschitz parameter (default: 10.0) +[list_end] + + +[call [cmd ::math::probopt::adaLipoMax] [arg function] [arg bounds] [arg args]] +The "adaptive Lipschitz optimisation" algorithm uses the "Lipschitz" property of the given function to find a [emph maximum] in the given bounding box. The adaptive +variant actually uses two phases to find a suitable estimate for the Lipschitz parameter. This is controlled by the "Bernoulli" parameter. +[para] +When you specify a large number of iterations, the algorithm may take a very long time to complete as it is trying to improve on the Lipschitz parameter and +the chances of hitting a better estimate diminish fast. + +[para] +It recognises the following options: +[list_begin itemized] +[item] [term {-iterations number}]: Number of iterations (equals the actual number of function evaluations, default: 100) +[item] [term {-bernoulli value}]: Parameter for random decisions (exploration versus exploitation, default: 0.1) +[list_end] + + +[list_end] + + +[section References] + +The various algorithms have been described in on-line publications. Here are a few: + +[list_begin itemized] +[item] +[term PSO]: Maurice Clerc, Standard Particle Swarm Optimisation (2012) +[uri https://hal.archives-ouvertes.fr/file/index/docid/764996/filename/SPSO_descriptions.pdf] +[para] +Alternatively: [uri https://en.wikipedia.org/wiki/Particle_swarm_optimization] + +[item] +[term SCE]: Qingyuan Duan, Soroosh Sorooshian, Vijai K. Gupta, Optimal use offo the SCE-UA global optimization method for calibrating watershed models +(1994), Journal of Hydrology 158, pp 265-284 +[para] +[uri https://www.researchgate.net/publication/223408756_Optimal_Use_of_the_SCE-UA_Global_Optimization_Method_for_Calibrating_Watershed_Models] + +[item] +[term DE]: Rainer Storn and Kenneth Price, Differential Evolution - A simple and efficient adaptivescheme for globaloptimization over continuous spaces +(1996) +[para] +[uri http://www1.icsi.berkeley.edu/~storn/TR-95-012.pdf] + +[item] +[term LIPO]: Cedric Malherbe and Nicolas Vayatis, Global optimization of Lipschitz functions, +(june 2017) +[para] +[uri https://arxiv.org/pdf/1703.02628.pdf] + +[list_end] + +[manpage_end] diff --git a/vendor/math/probopt.tcl b/vendor/math/probopt.tcl new file mode 100644 index 00000000..83ab73cb --- /dev/null +++ b/vendor/math/probopt.tcl @@ -0,0 +1,19 @@ +# probopt.tcl -- +# Define the right workspace and load the three source files +# comprising the package for probabilistic optimisation: +# +# 1. Minimisation via Particle Swarm Optimisation +# 2. Minimisation via Shuffled Complex Evolution +# 3. Maximisation via Lipschitz Optimisation +# +package require Tcl 8.5 +package provide math::probopt 1.0 + +namespace eval ::math::probopt {} + +set dir [file dirname [info script]] + +source [file join [file dirname [info script]] probopt_pso.tcl] +source [file join [file dirname [info script]] probopt_sce.tcl] +source [file join [file dirname [info script]] probopt_lipo.tcl] +source [file join [file dirname [info script]] probopt_diffev.tcl] diff --git a/vendor/math/probopt.test b/vendor/math/probopt.test new file mode 100644 index 00000000..53d8bea0 --- /dev/null +++ b/vendor/math/probopt.test @@ -0,0 +1,315 @@ +# -*- tcl -*- +# Tests for the math::probopt pacakge +# +# 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.5 +testsNeedTcltest 1.0 + +support { + useLocal math.tcl math +} +testing { + useLocal probopt.tcl math::probopt +} + +# setRand -- +# Make sure we always get the same results: +# Use srand() to ensure that the random numbers follow +# the same sequence. +# +proc setRand {} { + expr {srand(100000)} +} + +# +# Simple quadratic function +# +proc f {coords} { + lassign $coords x y + + return [expr {($x-1.0)**2 + ($y-1.0)**2}] +} + +# +# Rosenbrock function +# +proc rosenbrock {coords} { + lassign $coords x y + + return [expr {100.0 * ($y - $x ** 2) ** 2 + (1.0 - $x) ** 2}] +} + +# +# Slightly distorted sombrero - minimum at (1,0) +# +proc sombrero {coords} { + lassign $coords x y + + set r [expr {hypot($x,$y)}] + return [expr {(1.0 - $r ** 2) ** 2 + 0.01 * (1.0 - $x)**2}] +} + +# +# Wavy function (3D) - absolute minimum at (x,y,z) = (0,0,0), but lots of local minima +# +proc wavy3d {coords} { + lassign $coords x y z + + return [expr {1.0 - cos(10.0*$x) * cos(10.0*$y) * cos(10.0*$z) + 0.01 * ($x**2 + $y**2 + $z**2)}] +} + +# +# Discontinuous function with a clear global minimum at (x,y) = (0,0) +# +proc halfparabola {coords} { + lassign $coords x y + + if { $x > 0.0 } { + set f [expr {$x**2 + $y**2}] + } else { + set f [expr {-$x + abs($y) + 1.0}] + } + + return $f +} + +# +# 3D function with maximum - bounds slightly beyond [-1,1] +# +proc sombrero3D {coords} { + lassign $coords x y z + + set r2 [expr {$x**2 + $y**2 + $z**2}] + return [expr {(10.0 - $r2)**2}] +} + +# +# Procedure in a namespace +# +namespace eval testcase { + proc ftest {coords} { + lassign $coords x y + + return [expr {($x-1.0)**2 + ($y-1.0)**2}] + } +} + +# +# Create and register (in that order!) custom matching procedures +# +proc matchTolerant { expected actual } { + set match 1 + foreach a $actual e $expected { + if { $e != 0.0 } { + if { abs($e-$a)>0.005*abs($e) && + abs($e-$a)>0.005*abs($a) } { + set match 0 + break + } + } else { + if { abs($a) > 0.0001 } { + set match 0 + } + } + } + return $match +} + +::tcltest::customMatch tolerant matchTolerant + + +# Test cases -- +# + +# +# PSO +# +test "PSO-0.1" "Check known options" -body { + set coords_value [::math::probopt::pso f {{0.0 4.0} {0.0 4.0}} -swarmsize 10 -iterations 50 -vweight 0.2 -pweight 0.1 -gweight 03 -type local -neighbours 4 -tolerance 1e-3] + set result "OK" +} -returnCodes {ok} -result "OK" + +test "PSO-0.2" "Check unknown options" -body { + set coords_value [::math::probopt::pso f {{0.0 4.0} {0.0 4.0}} -UNKNOWN 10] + set result "OK" +} -returnCodes {error} -result "Unknown option: -UNKNOWN" + +test "PSO-0.3" "Check content of dictionary" -body { + set coords_value [::math::probopt::pso f {{0.0 4.0} {0.0 4.0}}] + foreach key {optimum-coordinates optimum-value evaluations best-values} { + set r [dict get $coords_value $key] + } + set result "OK" +} -returnCodes {ok} -result "OK" + + +test "PSO-1.1" "Two-dimensional paraboloid" -match tolerant -setup setRand -body { + set coords_value [::math::probopt::pso f {{0.0 4.0} {0.0 4.0}} -iterations 50] + set result [concat [dict get $coords_value optimum-coordinates] [dict get $coords_value optimum-value]] +} -result {1.0 1.0 0.0} + +test "PSO-1.2" "Two-dimensional paraboloid - namespace" -match tolerant -setup setRand -body { + global coords_value + + namespace eval testcase { + global coords_value + set coords_value [::math::probopt::pso ftest {{0.0 4.0} {0.0 4.0}} -iterations 50] + } + set result [concat [dict get $coords_value optimum-coordinates] [dict get $coords_value optimum-value]] +} -result {1.0 1.0 0.0} + + +test "PSO-2.1" "Tilted sombrero - 2D" -match tolerant -setup setRand -body { + set coords_value [::math::probopt::pso sombrero {{-4.0 4.0} {-4.0 4.0}} -iterations 50] + set result [concat [dict get $coords_value optimum-coordinates] [dict get $coords_value optimum-value]] +} -result {0.9784 0.2080 0.0} + +test "PSO-2.2" "Tilted sombrero - 2D, local method" -match tolerant -setup setRand -body { + set coords_value [::math::probopt::pso sombrero {{-4.0 4.0} {-4.0 4.0}} -iterations 50 -type local] + set result [concat [dict get $coords_value optimum-coordinates] [dict get $coords_value optimum-value]] +} -result {0.9605 0.2820 0.0} + +test "PSO-2.3" "Tilted sombrero - 2D, more particles" -match tolerant -setup setRand -body { + set coords_value [::math::probopt::pso sombrero {{-4.0 4.0} {-4.0 4.0}} -iterations 50 -swarmsize 200] + set result [concat [dict get $coords_value optimum-coordinates] [dict get $coords_value optimum-value]] +} -result {0.970 -0.2419 0.0} + +test "PSO-3.1" "Wavy function - 3D" -match tolerant -setup setRand -body { + set coords_value [::math::probopt::pso wavy3d {{0.0 4.0} {0.0 4.0} {0.0 4.0}} -iterations 50] + set result [concat [dict get $coords_value optimum-coordinates] [dict get $coords_value optimum-value]] +} -result {2.8405 1.9068 2.2180 0.2157} + +test "PSO-3.2" "Wavy function - 3D" -match tolerant -setup setRand -body { + set coords_value [::math::probopt::pso wavy3d {{0.0 4.0} {0.0 4.0} {0.0 4.0}} -iterations 50 -swarmsize 100 -neighbours 6] + set result [concat [dict get $coords_value optimum-coordinates] [dict get $coords_value optimum-value]] +} -result {1.5703 0.9424 1.2564 0.0493} + +test "PSO-4.1" "Discontinuous function - 2D" -match tolerant -setup setRand -body { + set coords_value [::math::probopt::pso halfparabola {{-4.0 4.0} {-4.0 4.0}} -iterations 50] + set result [concat [dict get $coords_value optimum-coordinates] [dict get $coords_value optimum-value]] +} -result {0.0 0.0 0.0} + +# +# SCE +# +test "SCE-0.1" "Check known options" -body { + set coords_value [::math::probopt::sce f {{0.0 4.0} {0.0 4.0}} -complexes 2 -mincomplexes 2 -newpoints 1 -shuffle 0 -pointspercomplex 0 -pointspersubcomplex 0 \ + -iterations 100 -maxevaluations 1.0e9 -abstolerance 0.0 -reltolerance 0.001] + set result "OK" +} -returnCodes {ok} -result "OK" + +test "SCE-0.2" "Check unknown options" -body { + set coords_value [::math::probopt::sce f {{0.0 4.0} {0.0 4.0}} -UNKNOWN 10] + set result "OK" +} -returnCodes {error} -result "Unknown option: -UNKNOWN" + +test "SCE-0.3" "Check content of dictionary" -body { + set coords_value [::math::probopt::sce f {{0.0 4.0} {0.0 4.0}}] + foreach key {optimum-coordinates optimum-value evaluations best-values} { + set r [dict get $coords_value $key] + } + set result "OK" +} -returnCodes {ok} -result "OK" + + +test "SCE-1.1" "Two-dimensional paraboloid" -match tolerant -setup setRand -body { + set coords_value [::math::probopt::sce f {{0.0 4.0} {0.0 4.0}} -iterations 50] + set result [concat [dict get $coords_value optimum-coordinates] [dict get $coords_value optimum-value]] +} -result {1.0064 1.0082 0.0001078} + + +# +# DE +# +test "DE-0.1" "Check known options" -body { + set coords_value [::math::probopt::diffev f {{0.0 4.0} {0.0 4.0}} -number 0 -factor 0.6 -lambda 0.0 -crossover 0.5 \ + -iterations 100 -maxevaluations 1.0e9 -abstolerance 0.0 -reltolerance 0.001] + set result "OK" +} -returnCodes {ok} -result "OK" + +test "DE-0.2" "Check unknown options" -body { + set coords_value [::math::probopt::diffev f {{0.0 4.0} {0.0 4.0}} -UNKNOWN 10] + set result "OK" +} -returnCodes {error} -result "Unknown option: -UNKNOWN" + +test "DE-0.3" "Check content of dictionary" -body { + set coords_value [::math::probopt::diffev f {{0.0 4.0} {0.0 4.0}}] + foreach key {optimum-coordinates optimum-value evaluations best-values} { + set r [dict get $coords_value $key] + } + set result "OK" +} -returnCodes {ok} -result "OK" + + +test "DE-1.1" "Two-dimensional paraboloid" -match tolerant -setup setRand -body { + set coords_value [::math::probopt::diffev f {{0.0 4.0} {0.0 4.0}} -iterations 50] + set result [concat [dict get $coords_value optimum-coordinates] [dict get $coords_value optimum-value]] +} -result {1.0068 1.0096 0.0001387} + +# +# LIPO +# +test "LIPO-0.1" "Check known options" -body { + set coords_value [::math::probopt::lipoMax f {{0.0 4.0} {0.0 4.0}} -iterations 100 -lipschitz 10.0] + set result "OK" +} -returnCodes {ok} -result "OK" + +test "LIPO-0.2" "Check unknown options" -body { + set coords_value [::math::probopt::lipoMax f {{0.0 4.0} {0.0 4.0}} -UNKNOWN 10] + set result "OK" +} -returnCodes {error} -result "Unknown option: -UNKNOWN" + +test "LIPO-0.3" "Check content of dictionary" -body { + set coords_value [::math::probopt::lipoMax f {{0.0 4.0} {0.0 4.0}}] + foreach key {optimum-coordinates optimum-value evaluations best-values} { + set r [dict get $coords_value $key] + } + set result "OK" +} -returnCodes {ok} -result "OK" + + +test "LIPO-1.1" "Three-dimensional sombrero" -match tolerant -setup setRand -body { + set coords_value [::math::probopt::lipoMax sombrero3D {{-1.2 1.2} {-1.2 1.2} {-1.2 1.2}} -iterations 5000] + set result [concat [dict get $coords_value optimum-coordinates] [dict get $coords_value optimum-value]] +} -result {-0.0447 -0.0710 -0.0956 99.6769} + +test "ADALIPO-0.1" "Check known options" -body { + set coords_value [::math::probopt::adaLipoMax f {{0.0 4.0} {0.0 4.0}} -iterations 100 -bernoulli 0.1] + set result "OK" +} -returnCodes {ok} -result "OK" + +test "ADALIPO-0.2" "Check unknown options" -body { + set coords_value [::math::probopt::adaLipoMax f {{0.0 4.0} {0.0 4.0}} -UNKNOWN 10] + set result "OK" +} -returnCodes {error} -result "Unknown option: -UNKNOWN" + +test "ADALIPO-0.3" "Check content of dictionary" -body { + set coords_value [::math::probopt::adaLipoMax f {{0.0 4.0} {0.0 4.0}}] + foreach key {optimum-coordinates optimum-value evaluations best-values} { + set r [dict get $coords_value $key] + } + set result "OK" +} -returnCodes {ok} -result "OK" + +# Odd behaviour: 5000 iterations and the thing hangs? +#test "ADALIPO-1.1" "Three-dimensional sombrero" -match tolerant -setup setRand -body { +# set coords_value [::math::probopt::adaLipoMax sombrero3D {{-1.2 1.2} {-1.2 1.2} {-1.2 1.2}} -iterations 5000] +# set result [concat [dict get $coords_value optimum-coordinates] [dict get $coords_value optimum-value]] +#} -result {0.0 0.0 1.0} + +test "ADALIPO-1.1" "Three-dimensional sombrero" -match tolerant -setup setRand -body { + set coords_value [::math::probopt::adaLipoMax sombrero3D {{-1.2 1.2} {-1.2 1.2} {-1.2 1.2}} -iterations 500] + set result [concat [dict get $coords_value optimum-coordinates] [dict get $coords_value optimum-value]] +} -result {-0.0971 -0.0577 0.1905 99.0216} + + + +#set coords_value [::math::probopt::pso halfparabola {{-4.0 4.0} {-4.0 4.0}} -iterations 50] +#puts $coords_value diff --git a/vendor/math/probopt_diffev.tcl b/vendor/math/probopt_diffev.tcl new file mode 100644 index 00000000..55100f1f --- /dev/null +++ b/vendor/math/probopt_diffev.tcl @@ -0,0 +1,275 @@ +# probopt_diffev.tcl -- +# Implementation of the differential probopt algorithm +# for optimising functions +# +# Note: +# The algorithm does not confine the points to the given +# hyper block - it is merely used to initialise it. +# +namespace eval ::math::probopt {} + +# diffev -- +# Optimise a function using the differential probopt algorithm +# +# Arguments: +# func Function for which the global minimum is to be found +# bounds Boundaries for all independent variables of the function, +# as a list of pairs of minimum and maximum +# args Set of options - key-value pairs +# +# Result: +# Estimate of the global minimum as found via the procedure +# +proc ::math::probopt::diffev {func bounds args} { + # + # Set the default options + # + set dims [llength $bounds] + set options [dict create -number 0 -factor 0.6 -lambda 0.0 -crossover 0.5 \ + -iterations 100 -maxevaluations 1.0e9 -abstolerance 0.0 -reltolerance 0.001] + + # + # Handle the options + # + + foreach {key value} $args { + if { [dict exists $options $key] } { + dict set options $key $value + } else { + return -code error "Unknown option: $key" + } + } + + dict with options {} + + if { ${-number} == 0 } { + set -number [expr {4 * $dims}] + dict set options -number ${-number} + } + + # + # Set up the initial collections of points + # + set evals 0 + set points {} + for {set i 0} {$i < ${-number}} {incr i} { + set coords [GeneratePoint $bounds] + lappend points [list $coords [$func $coords]] + incr evals + } + #puts [join $points \n] + + # + # Iteration over the generations: + # - For each point, construct a new estimate and check if it is better + # - If it is, replace the original point by the new point + # + set oldIndex [IndexBestPoint $points] + set oldValue [lindex $points $oldIndex 1] + set bestPerGeneration {} + + for {set generation 0} {$generation < ${-iterations}} {incr generation} { + #puts "$generation" + set newPoints {} + set renewed 0 ;# Keep track of the replacement of points to avoid + # a premature ending + + for {set i 0} {$i < ${-number}} {incr i} { + set point [lindex $points $i] + + set newCoords [ConstructNewCoords $points ${-factor} ${-lambda} ${-crossover} $i $oldIndex] + + set fvalue [$func $newCoords] + incr evals + #puts "$newCoords -- $fvalue -- $evals" + + if { $fvalue < [lindex $point 1] } { + set renewed [expr {$i == $oldIndex? 1 : 0}] ;# Is the best estimate being replaced? + set newPoint [list $newCoords $fvalue] + } else { + set newPoint $point + } + + #puts "$newPoint -- $evals" + lappend newPoints $newPoint + } + + # + # Check the number of evaluations ... not quite accurate, but it will do + # + # Hm, this will fail if this happens in the first generation + # + if { $evals >= ${-maxevaluations} } { + #puts "Maximum evaluations reached" + break + } + + # + # Get the best point in the current generation + # + set bestIndex [IndexBestPoint $newPoints] + set bestValue [lindex $newPoints $bestIndex 1] + + #puts "$oldIndex -- $oldValue -- $bestIndex -- $bestValue" + #if { $renewed } {} + if { ( $oldValue != $bestValue || $oldIndex != $bestIndex ) && + ( ($oldValue - $bestValue) <= ${-abstolerance} || + ($oldValue - $bestValue) <= 0.5 * ${-reltolerance} * (abs($oldValue) + abs($bestValue)) ) } { + #puts "Values: $oldValue -- $bestValue" + break + } else { + set points $newPoints + set oldIndex $bestIndex + set oldValue $bestValue + lappend bestPerGeneration $bestValue + } + + #puts "$oldIndex -- $oldValue -- $bestIndex -- $bestValue" + } + + return [dict create optimum-coordinates [lindex $newPoints $bestIndex 0] \ + optimum-value [lindex $newPoints $bestIndex 1] evaluations $evals best-values $bestPerGeneration] +} + +# ConstructNewCoords -- +# Constructs the coordinates of a new point using the DE method +# +# Arguments: +# points Current set of points (each together with the function value) +# factor Weight for the difference vector +# lambda Weight for the best vector +# crossover Probability of cross-over +# idx Current index +# bestIdx Index of the current best vector +# +# Result: +# List of coordinates +# +proc ::math::probopt::ConstructNewCoords {points factor lambda crossover idx bestIdx} { + set number [llength $points] + set dims [llength [lindex $points 0 0]] + set r1 [SelectIndex $idx $number] + set r2 [SelectIndex $idx $number] + set r3 [SelectIndex $idx $number] + + if { $lambda == 0.0 } { + set vcoords {} + foreach c1 [lindex $points $r1 0] \ + c2 [lindex $points $r2 0] \ + c3 [lindex $points $r3 0] { + set vc [expr {$c1 + $factor * ($c2 - $c3)}] + lappend vcoords $vc + } + } else { + set vcoords {} + foreach c1 [lindex $points $idx 0] \ + cb [lindex $points $bestIndex 0] \ + c2 [lindex $points $r2 0] \ + c3 [lindex $points $r3 0] { + set vc [expr {$c1 + $lambda * ($cb - $c1) + $factor * ($c2 - $c3)}] + lappend vcoords $vc + } + } + + # + # Now the cross-over per dimension + # + set start [SelectIndex {} $number] + set length [SelectLength $crossover $dims] + + set combined $vcoords + for {set i $start} {$i < $start+$length} {incr i} { + set j [expr {$i % $dims}] + lset combined $j [lindex $vcoords $j] + } + + return $combined +} + +# SelectIndex -- +# Select a random index unequal to a given index +# +# Arguments: +# avoidIdx Index to be avoided +# maximum Maximum + 1 for the index +# +# Result: +# Random index in [0,maximum-1], not equal avoidIdx +# +proc ::math::probopt::SelectIndex {avoidIdx maximum} { + + set idx $avoidIdx + while { $idx == $avoidIdx } { + set idx [expr {int($maximum * rand())}] + } + + return $idx +} + +# SelectLength -- +# Select a random length using a cross-over probability +# +# Arguments: +# crossover Cross-over probability +# maximum Maximum + 1 for the index +# +# Result: +# Random index in [0,maximum-1] +# +proc ::math::probopt::SelectLength {crossover maximum} { + + set length 0 + while {1} { + incr length + if { rand() > $crossover || $length >= $maximum } { + break + } + } + + return $length +} + +# GeneratePoint -- +# Generate the coordinates of a random point within the given bounds +# +# Arguments: +# bounds Bounds on all coordinates +# +# Result: +# List of coordinates +# +proc ::math::probopt::GeneratePoint {bounds} { + + set coords {} + foreach bound $bounds { + lassign $bound cmin cmax + lappend coords [expr {$cmin + ($cmax - $cmin) * rand()}] + } + + return $coords +} + +# IndexBestPoint -- +# Find the index of the best point (lowest function value) +# +# Arguments: +# points List of points (each is a pair of coordinates and the function value) +# +# Result: +# Index of the best point +# +proc ::math::probopt::IndexBestPoint {points} { + + set index 0 + set bestValue [lindex $points 0 1] + + for {set i 1} {$i < [llength $points]} {incr i} { + set newValue [lindex $points $i 1] + if { $newValue < $bestValue } { + set index $i + set bestValue $newValue + } + } + + return $index +} diff --git a/vendor/math/probopt_lipo.tcl b/vendor/math/probopt_lipo.tcl new file mode 100644 index 00000000..39596e4d --- /dev/null +++ b/vendor/math/probopt_lipo.tcl @@ -0,0 +1,241 @@ +# probopt_lipo.tcl -- +# Implementation of the LIPO algorithm to find +# the global maximum of a function in a given region +# +# Based on: +# Cedric Malherbe and Nicolas Vayatis, Global optimization of Lipschitz functions, +# june 2017, https://arxiv.org/pdf/1703.02628.pdf +# + +# namespace -- +# +namespace eval ::math::probopt {} + +# Dist -- +# Determine the Euclidean distance between two points in N-dimensional space +# +# Arguments: +# x List of coordinates for the first point +# y List of coordinates for the second point +# +# Returns: +# Euclidean distance between the two points +# +proc ::math::probopt::Dist {x y} { + set dist 0.0 + + foreach xc $x yc $y { + set dist [expr {$dist + ($xc-$yc) ** 2}] + } + return $dist +} + +# lipoMax -- +# Find the global maximum of a function in a given region +# +# Arguments: +# f Name of the procedure implementing the function +# bounds List of pairs of minimum and maximum per dimension +# args Key-value pairs for the options: +# -iterations number Number of iterations (function evaluations; default: 100) +# -lipschitz value Estimate of the Lipschitz parameter (default: 10.0) +# +# Returns: +# The coordinates of the point where the function attains the maximum +# value that was encountered +# +proc ::math::probopt::lipoMax {f bounds args} { + set options [dict create -iterations 100 -lipschitz 10.0] + + foreach {key value} $args { + if { [dict key $options $key] != "" } { + dict set options $key $value + } else { + return -code error "Unknown option: $key" + } + } + + set k [dict get $options -lipschitz] + set n [dict get $options -iterations] + + # + # Convert the region + # + set region {} + foreach b $bounds { + lassign $b min max + lappend region $min $max + } + + # + # Initial guess + # + set coords {} + set fvalues {} + foreach {min max} $region { + set c [expr {$min + ($max-$min) * rand()}] + lappend coords $c + } + + set fval [$f $coords] + set maxval $fval + set maxcrd $coords + set nevals 1 + + lappend fvalues $fval + lappend samples $coords + set bestValues {} + + set numberSamples 1 + while { $numberSamples < $n } { + # New guess + set coords {} + foreach {min max} $region { + set c [expr {$min + ($max-$min) * rand()}] + lappend coords $c + } + + # Check via Lipschitz condition + foreach csample $samples fval $fvalues { + set estimate [expr {$fval + $k * [Dist $coords $csample]}] + + if { $estimate > $maxval } { + incr numberSamples + set fval [$f $coords] + incr nevals + + lappend samples $coords + lappend fvalues $fval + + if { $fval > $maxval } { + set maxval $fval + set maxcrd $coords + #puts "$maxval -- $maxcrd" + lappend bestValues $maxval + } + break + } + } + } + + return [dict create optimum-coordinates $maxcrd optimum-value $maxval evaluations $nevals best-values $bestValues] +} + +# adaLipoMax -- +# Find the global maximum of a function in a given region, +# using a heuristic estimate of the Lipschitz constant +# +# Arguments: +# f Name of the procedure implementing the function +# bounds List of minimum and maximum per dimension +# args Key-value pairs for the options: +# -iterations number Number of iterations (function evaluations; default: 100) +# -bernoulli value Parameter for random decisions (default: 0.1) +# +# Returns: +# The coordinates of the point where the function attains the maximum +# value that was encountered +# +proc ::math::probopt::adaLipoMax {f bounds args} { + set options [dict create -iterations 100 -bernoulli 0.1] + + foreach {key value} $args { + if { [dict key $options $key] != "" } { + dict set options $key $value + } else { + return -code error "Unknown option: $key" + } + } + + set p [dict get $options -bernoulli] + set n [dict get $options -iterations] + + set kparam [expr {1.0 + 0.01/([llength $bounds])}] + + # + # Convert the region + # + set region {} + foreach b $bounds { + lassign $b min max + lappend region $min $max + } + + # + # Initial guess + # + set k 0.0 + set kmax 0.0 + set coords {} + set fvalues {} + foreach {min max} $region { + set c [expr {$min + ($max-$min) * rand()}] + lappend coords $c + } + + set fval [$f $coords] + set maxval $fval + set maxcrd $coords + set nevals 1 + + lappend fvalues $fval + lappend samples $coords + set bestValues {} + + set numberSamples 1 + while { $numberSamples < $n } { + # New guess + set coords {} + foreach {min max} $region { + set c [expr {$min + ($max-$min) * rand()}] + lappend coords $c + } + + set added 0 + if { rand() < $p } { + # Exploration ... + set added 1 + incr numberSamples + set fval [$f $coords] + incr nevals + + lappend samples $coords + lappend fvalues $fval + } else { + # Exploitation - check via Lipschitz condition + foreach csample $samples fval $fvalues { + set estimate [expr {$fval + $k * [Dist $coords $csample]}] + + if { $estimate > $maxval } { + set added 1 + incr numberSamples + set fval [$f $coords] + incr nevals + lappend samples $coords + lappend fvalues $fval + + if { $fval > $maxval } { + set maxval $fval + set maxcrd $coords + #puts "$maxval -- $maxcrd" + lappend bestValues $maxval + } + break + } + } + } + + # Update the estimate of the Lipschitz constant + foreach csample [lrange $samples 0 end-$added] fsample [lrange $fvalues 0 end-$added] { + set estimate [expr {abs($fval - $fsample) / [Dist $coords $csample]}] + + if { $estimate > $kmax } { + set kmax $estimate + } + } + + set k [expr {$kparam ** int($estimate/log($kparam)+0.99)}] + } + + return [dict create optimum-coordinates $maxcrd optimum-value $maxval evaluations $nevals best-values $bestValues] +} diff --git a/vendor/math/probopt_pso.tcl b/vendor/math/probopt_pso.tcl new file mode 100644 index 00000000..b47d2a28 --- /dev/null +++ b/vendor/math/probopt_pso.tcl @@ -0,0 +1,427 @@ +# probopt_pso.tcl -- +# Straightforward implementation of particle swarm optimisation +# +# Options: +# - The "best" is taken to be the globally best particle (global) +# - The "best" is taken to be the best of the neighbourhood of +# each particle +# +# For more information see: https://en.wikipedia.org/wiki/Particle_swarm_optimization +# + +# namespace -- +# +namespace eval ::math::probopt {} + + + +# pso -- +# Public interface to the PSO implementations +# +# Arguments: +# func Function to be minimized +# bounds List of pairs of minimum and maximum per dimension +# args Key-value pairs: +# -swarmsize number Number of particles to consider (default: 50) +# -vweight value Weight for the current "velocity" (0-1, default: 0.5) +# -pweight value Weight for the individual particle's best position (0-1, default: 0.3) +# -gweight value Weight for the "best" overall position as per particle (0-1, default: 0.3) +# -type local/global Type of optimisation +# -neighbours number Size of the neighbourhood (default: 5, used if "local") +# -iterations number Maximum number of iterations +# -tolerance value Absolute minimal improvement for minimum value +# +# Result: +# Dictionary with the coordinates of the "best" position and the value as well as +# list of best values per iteration and the number of function evaluations. +# +proc ::math::probopt::pso {func bounds args} { + + set func [uplevel 1 [list namespace which -command $func]] + + set options [dict create -swarmsize 50 -vweight 0.5 -pweight 0.3 -gweight 0.3 \ + -type global -neighbours 5 -iterations 50 -tolerance 0.0] + + foreach {key value} $args { + if { [dict key $options $key] != "" } { + dict set options $key $value + } else { + return -code error "Unknown option: $key" + } + } + + set xmin {} + set xmax {} + + foreach bound $bounds { + lappend xmin [lindex $bound 0] + lappend xmax [lindex $bound 1] + } + + set type [dict get $options -type] + + if { $type == "global" } { + return [Pso_global $func $xmin $xmax $options] + } + if { $type == "local" } { + return [Pso_local $func $xmin $xmax $options] + } + + return -code error "Unknown type: $type" +} + +# Pso_global -- +# Use the "global" PSO algorithm +# +# Arguments: +# func Function to be minimized +# xmin Minimum values for the coordinates +# xmax Maximum values for the coordinates +# options Dictionary of options +# +proc ::math::probopt::Pso_global {func xmin xmax options} { + # + # Set up the initial positions + # + set swarmsize [dict get $options -swarmsize] + set maxiters [dict get $options -iterations] + + set particle_bests {} + set positions {} + set velocities {} + set global_best -1 + set global_best_value {} + set evaluations 0 + set best_values {} + + for {set i 0} {$i < $swarmsize} {incr i} { + set coords [Pso_position $xmin $xmax] + + set fvalue [$func $coords] + incr evaluations + + lappend positions $coords + lappend velocities [lrepeat [llength $coords] 0.0] + lappend particle_bests [list $fvalue $coords] + + if { $global_best == -1 || $global_best_value > $fvalue } { + set global_best $i + set global_best_value $fvalue + } + } + + set vweight [dict get $options -vweight] + set pweight [dict get $options -pweight] + set gweight [dict get $options -gweight] + set tolerance [dict get $options -tolerance] + + for {set iteration 0} {$iteration < $maxiters} {incr iteration} { + + set new_positions {} + set new_velocities {} + set new_particle_bests {} + + # + # Determine the new positions for all particles + # + for {set i 0} {$i < $swarmsize} {incr i} { + set old_velocity [lindex $velocities $i] + set old_position [lindex $positions $i] + set old_bestvalue [lindex $particle_bests $i 0] + set old_bestpos [lindex $particle_bests $i 1] + + set velocity [Pso_update_vel $vweight $pweight $gweight $old_velocity $old_position $old_bestpos [lindex $positions $global_best]] + + set position [Pso_new_position $old_position $velocity] + set fvalue [$func $position] + incr evaluations + + lappend new_positions $position + lappend new_velocities $velocity + + if { $fvalue < $old_bestvalue } { + lappend new_particle_bests [list $fvalue $position] + } else { + lappend new_particle_bests [list $old_bestvalue $old_position] + } + } + + set positions $new_positions + set velocities $new_velocities + set particle_bests $new_particle_bests + + # + # Determine the globally best position + # + for {set i 0} {$i < $swarmsize} {incr i} { + set fvalue [lindex $particle_bests $i 0] + + if { $fvalue < $global_best_value } { + set global_best_value $fvalue + set global_best $i + set global_best_pos [lindex $particle_bests $i 1] + } + } + + # + # Have we reached the tolerance yet? + # + if { $iteration > 0 } { + if { abs($prev_best_value - $global_best_value) < $tolerance && + $prev_best_value > $global_best_value } { + break + } + } + set prev_best_value $global_best_value + lappend best_values $global_best_value + } + + return [dict create optimum-coordinates $global_best_pos optimum-value $global_best_value evaluations $evaluations best-values $best_values] +} + +# Pso_local -- +# Use the "local" PSO algorithm, i.e. look only at the "neighbours" +# +# Arguments: +# func Function to be minimized +# xmin Minimum values for the coordinates +# xmax Maximum values for the coordinates +# options Dictionary of options +# +proc ::math::probopt::Pso_local {func xmin xmax options} { + # + # Set up the initial positions + # + set swarmsize [dict get $options -swarmsize] + set maxiters [dict get $options -iterations] + set neighbours [dict get $options -neighbours] + + set particle_bests {} + set positions {} + set velocities {} + set global_best -1 + set global_best_value {} + set evaluations 0 + set best_values {} + + for {set i 0} {$i < $swarmsize+$neighbours} {incr i} { + lappend neighbours_idx [expr {$i % $swarmsize}] + } + + for {set i 0} {$i < $swarmsize} {incr i} { + set coords [Pso_position $xmin $xmax] + + set fvalue [$func $coords] + incr evaluations + + lappend positions $coords + lappend velocities [lrepeat [llength $coords] 0.0] + lappend particle_bests [list $fvalue $coords] + + lappend local_best $i + lappend local_best_value $fvalue + lappend local_best_pos $coords + lappend prev_best_value $fvalue + } + + # + # Initial estimates: + # Examine the neighbouring particles and determine which holds the best result + # + for {set i 0} {$i < $swarmsize} {incr i} { + set current_best [lindex $local_best $i] + set current_best_value [lindex $particle_bests $current_best 0] + set current_best_pos [lindex $particle_bests $current_best 1] + + for {set n 0} {$n < $neighbours} {incr n} { + set nth [lindex $neighbours_idx [expr {$i+$n}]] + set fvalue [lindex $particle_bests $nth 0] + + if { $current_best_value > $fvalue } { + set current_best $nth + set current_best_value $fvalue + set current_best_pos [lindex $particle_bests $nth 1] + } + } + + lset local_best $i $current_best + lset local_best_value $i $current_best_value + lset local_best_pos $i $current_best_pos + } + + # + # Actual loop + # + set vweight [dict get $options -vweight] + set pweight [dict get $options -pweight] + set gweight [dict get $options -gweight] + set tolerance [dict get $options -tolerance] + + set stop 0 + + for {set iteration 0} {$iteration < $maxiters && $stop == 0} {incr iteration} { + + set new_positions {} + set new_velocities {} + set new_particle_bests {} + + # + # Determine the new positions for all particles + # + for {set i 0} {$i < $swarmsize} {incr i} { + set old_velocity [lindex $velocities $i] + set old_position [lindex $positions $i] + set old_bestvalue [lindex $particle_bests $i 0] + set old_bestpos [lindex $particle_bests $i 1] + + set idx [lindex $local_best $i] + + set velocity [Pso_update_vel $vweight $pweight $gweight $old_velocity $old_position $old_bestpos [lindex $positions $idx]] + + set position [Pso_new_position $old_position $velocity] + set fvalue [$func $position] + incr evaluations + + lappend new_positions $position + lappend new_velocities $velocity + + if { $fvalue < $old_bestvalue } { + lappend new_particle_bests [list $fvalue $position] + } else { + lappend new_particle_bests [list $old_bestvalue $old_position] + } + } + + set positions $new_positions + set velocities $new_velocities + set particle_bests $new_particle_bests + + # + # Examine the neighbouring particles and determine which holds the best result + # + for {set i 0} {$i < $swarmsize} {incr i} { + set current_best [lindex $local_best $i] + set current_best_value [lindex $local_best_value $i] + set current_best_pos [lindex $local_best_pos $i] + + for {set n 0} {$n < $neighbours} {incr n} { + set nth [lindex $neighbours_idx [expr {$i+$n}]] + set fvalue [lindex $particle_bests $nth 0] + + if { $current_best_value > $fvalue } { + set current_best $nth + set current_best_value $fvalue + set current_best_pos [lindex $particle_bests $nth 1] + } + } + + lset local_best $i $current_best + lset local_best_value $i $current_best_value + lset local_best_pos $i $current_best_pos + + # + # Have we reached the tolerance yet? + # Note: local citerium - one group reaching a minimum? Then stop + # + if { $iteration > 0 } { + if { abs([lindex $prev_best_value $i] - $current_best_value) < $tolerance && + [lindex $prev_best_value $i] > $current_best_value } { + set stop 1 + break + } + } + lset prev_best_value $i $current_best_value + } + + # + # Now determine the overall best position - within this iteration + # (to have a history) + # + set global_best_value [lindex $local_best_value 0] + set global_best_pos [lindex $local_best_pos 0] + + for {set i 1} {$i <$swarmsize} {incr i} { + set particle_best_value [lindex $local_best_value $i] + + if { $global_best_value > $particle_best_value } { + set global_best_value $particle_best_value + set global_best_pos [lindex $local_best_pos $i] + } + } + + lappend best_values $global_best_value + } + + return [dict create optimum-coordinates $global_best_pos optimum-value $global_best_value evaluations $evaluations best-values $best_values] +} + +# Pso_position -- +# Determine the initial position +# +# Arguments: +# xmin Minimum values for the coordinates +# xmax Maximum values for the coordinates +# +# Result: +# Vector of coordinates +# +proc ::math::probopt::Pso_position {xmin xmax} { + + set new_position {} + + foreach min $xmin max $xmax { + lappend new_position [expr {$min + ($max - $min) * rand()}] + } + + return $new_position +} + +# Pso_new_position -- +# Update the position +# +# Arguments: +# position Position vector +# velocity Velocity vector +# +# Result: +# Vector of new coordinates +# +proc ::math::probopt::Pso_new_position {position velocity} { + + set new_position {} + + foreach p $position v $velocity { + lappend new_position [expr {$p + $v}] + } + + return $new_position +} + +# Pso_update_vel -- +# Update the velocity +# +# Arguments: +# vweight Weight for the old vector +# pweight Weight for the particle's best position +# gweight Weight for the globally (locally) best position +# old_velocity Old velocity vector +# old_position Old position vector +# old_particle_best Old best vector for the particle +# old_global_best Old globally (locally) best vector +# +# Result: +# Vector of new coordinates +# +proc ::math::probopt::Pso_update_vel {vweight pweight gweight old_velocity old_position old_particle_best old_global_best} { + + set new_velocity {} + + set pw [expr {$pweight * rand()}] + set gw [expr {$gweight * rand()}] + + foreach v $old_velocity p $old_position b $old_particle_best g $old_global_best { + lappend new_velocity [expr {$vweight * $v + $pw * ($b - $p) + $gw * ($g - $p)}] + } + + return $new_velocity +} diff --git a/vendor/math/probopt_sce.tcl b/vendor/math/probopt_sce.tcl new file mode 100644 index 00000000..d223a601 --- /dev/null +++ b/vendor/math/probopt_sce.tcl @@ -0,0 +1,378 @@ +# probopt_sce.tcl -- +# Implementation of the "shuffled complexes evolution" optimisation method in Tcl +# +# Note: +# This implementation is based on: +# - Qingyuan Duan, Soroosh Sorooshian and Vijai Gupta: +# Optimal use of the SCE-UA global optimisation method for calibrating +# watershed models, Journal of Hydrology, volume 158, 1994, pp. 265-284 +# +# - Q.Y. Duan, V.K. Gupta and S. Sorooshian: +# Shuffled Comples Evolution Approach for Effective and Efficient +# Global Minimization, Journal of Optimization Theory and Applications, +# volume 76, no. 3, 1993, pp. 501-521 +# +# TODO: +# - Limit the number of iterations +# - Provide a dictionary of calculation results +# + +# namespace -- +# +namespace eval ::math::probopt { + variable sceNevals 0 +} + +# sce -- +# Front-end procedure for the SCE algorithm +# +# Arguments: +# func Function for which the global minimum is to be found +# bounds Boundaries for all independent variables of the function, +# as a list of pairs of minimum and maximum +# args Set of options - key-value pairs +# +# Result: +# Estimate of the global minimum as found via the procedure +# +proc ::math::probopt::sce {func bounds args} { + variable sceNevals + # + # Set the default options + # + set dims [llength $bounds] + set options [dict create -complexes 2 -mincomplexes 2 -newpoints 1 -shuffle 0 -pointspercomplex 0 -pointspersubcomplex 0 \ + -iterations 100 -maxevaluations 1.0e9 -abstolerance 0.0 -reltolerance 0.001] + # + # Handle the options + # + + foreach {key value} $args { + if { [dict exists $options $key] } { + dict set options $key $value + } else { + return -code error "Unknown option: $key" + } + } + + dict with options {} + + # + # Recalculate a few options + # + foreach v {-shuffle -pointspercomplex} { + if { [set $v] == 0 } { + set $v [expr {2*$dims + 1}] + dict set options $v [set $v] + } + } + set v "-pointspersubcomplex" + if { [set $v] == 0 } { + set $v [expr {$dims + 1}] + dict set options $v [set $v] + } + + # + # Ready to call the actual procedure + # + set sceNEvals 0 + + return [SceCompute $func $bounds $options] + + #SceCompute $func $bounds $options +} + +# SceCompute -- +# Actually compute the global optimum using the SCE algorithm +# +# Arguments: +# func Function for which the global minimum is to be found +# bounds Boundaries for all independent variables of the function, +# as a list of pairs of minimum and maximum +# options Dictionary of options +# +# Result: +# Dictionary containing among other things the estimate of the +# global minimum as found via the procedure +# +proc ::math::probopt::SceCompute {func bounds options} { + variable sceNEvals + + set dims [llength $bounds] + set npcomplex [dict get $options -pointspercomplex] + set p [dict get $options -complexes] + set pmin [dict get $options -mincomplexes] + set npsubcomplex [dict get $options -pointspersubcomplex] + set nnewpoints [dict get $options -newpoints] + set nshuffle [dict get $options -shuffle] + set niterations [dict get $options -iterations] + set abstol [dict get $options -abstolerance] + set reltol [dict get $options -reltolerance] + + set npoints [expr {$npcomplex * $p}] + + # + # Generate the initial set of points + # + set points {} + for {set i 0} {$i < $p} {incr i} { + for {set k 0} {$k < $npcomplex} {incr k} { + set coords [GeneratePoint $bounds] + lappend points [list $coords [$func $coords]] + incr sceNEvals + } + } + + for {set iteration 0} {$iteration < $niterations} {incr iteration} { + # + # Sort the points and create subcomplexes + # + set points [lsort -index 1 -increasing $points] + + array unset complex + for {set i 0} {$i < $p} {incr i} { + for {set k 0} {$k < $npcomplex} {incr k} { + lappend complex($i) [lindex $points [expr {$k*$p + $i}]] + } + } + + # + # Optimise the subcomplexes + # + for {set i 0} {$i < $p} {incr i} { + for {set shuffle 0} {$shuffle < $nshuffle} {incr shuffle} { + set complex($i) [OptimiseComplex $complex($i) $npsubcomplex $nnewpoints $func $bounds] + } + } + + # + # Join the subcomplexes into a list of points and sort the points + # + set points {} + + for {set i 0} {$i < $p} {incr i} { + set points [concat $points $complex($i)] + } + + if { $iteration == 0 } { + set oldminimum [lindex [lsort -index 1 -increasing $points] 0 1] + } else { + set newminimum [lindex [lsort -index 1 -increasing $points] 0 1] + if { abs($oldminimum-$newminimum) != 0.0 && + ( abs($oldminimum-$newminimum) < $abstol || + abs($oldminimum-$newminimum) < 0.5 * $reltol * (abs($oldminimum)+abs($newminimum)) ) } { + break + } else { + set oldminimum $newminimum + } + } + } + + # + # Sort the points and return the best one + # + set result [lsort -index 1 -increasing $points] + set optimum_coords [lindex $result 0 0] + set optimum_value [lindex $result 0 1] + set best_values {} + foreach r $result { + set best_values [concat [lindex $r 1] $best_values] + } + return [dict create optimum-coordinates $optimum_coords optimum-value $optimum_value evaluations $sceNEvals best-values $best_values] +} + +# OptimiseComplex -- +# Optimise the complex, using subcomplexes +# +# Arguments: +# complex The points (and the function values) making up the full complex +# nsubcomplex The number of points to be selected for the subcomplex +# nnewpoints The number of new points to be generated +# bounds The bounds on the coordinates defining the feasible region +# +# Result: +# A new set of points +# +proc ::math::probopt::OptimiseComplex {complex nsubcomplex nnewpoints func bounds} { + variable sceNEvals + # + # Construct the subcomplex + # + set subcomplex [lsort -index 1 -increasing [TriangularSelect $complex $nsubcomplex]] + + # + # Construct new points: + # - Determine the centroid, excluding the worst point + # - Reflect the worst point + # - Make sure the result is within the feasible region, otherwise + # select a new point + # - Keep the new point if it has a lower function value + # - Otherwise try a contraction step + # + for {set new 0} {$new < $nnewpoints} {incr new} { + set centroid [Centroid [lrange $complex 0 end-1]] + set newPoint [ReflectPointInPoint $centroid [lindex $complex end 0]] + + if { ! [WithinBounds $bounds $newPoint] } { + set newPoint [GeneratePoint $bounds] + set fvalue [$func $newPoint] + incr sceNEvals + } else { + set fvalue [$func $newPoint] + incr sceNEvals + + # + # If the point is better, keep it, otherwise attempt a contraction step + # + if { $fvalue > [lindex $complex end 1] } { + set newPoint [Centroid [list [list $centroid 0.0] [list $newPoint $fvalue]]] + set fvalue [$func $newPoint] + incr sceNEvals + + if { $fvalue > [lindex $complex end 1] } { + set newPoint [GeneratePoint $bounds] + set fvalue [$func $newPoint] + incr sceNEvals + } + } + } + + lset complex end [list $newPoint $fvalue] + + set complex [lsort -index 1 -increasing $complex] + } + + return $complex +} + +# GeneratePoint -- +# Generate the coordinates of a random point within the given bounds +# +# Arguments: +# bounds Bounds on all coordinates +# +# Result: +# List of coordinates +# +proc ::math::probopt::GeneratePoint {bounds} { + + set coords {} + foreach bound $bounds { + lassign $bound cmin cmax + lappend coords [expr {$cmin + ($cmax - $cmin) * rand()}] + } + + return $coords +} + +# WithinBounds -- +# Determine if the coordinates of a point are within the given bounds +# +# Arguments: +# bounds Bounds on all coordinates +# point Coordinates of the point +# +# Result: +# 1 if the point is within the hyperrectangle, 0 otherwise +# +proc ::math::probopt::WithinBounds {bounds point} { + + set within 1 + + foreach c $point bound $bounds { + lassign $bound cmin cmax + if { $c < $cmin || $c > $cmax } { + set within 0 + break + } + } + + return $within +} + +# Centroid -- +# Calculate the centroid of a set of points in N dimensions +# +# Arguments: +# points List of point coordinates +# +# Result: +# Coordinates of the centroid +# +# Note: +# As this is to be used in the SCE algorithm, the list of +# point coordinates is slightly more complicated than +# just the coordinates. +# +proc ::math::probopt::Centroid {points} { + set dims [llength [lindex $points 0 0]] + set number [llength $points] + + set centroid [lrepeat $dims 0] + + foreach point $points { + set coords [lindex $point 0] + + set idx 0 + foreach c $coords sum $centroid { + set sum [expr {$sum + $c}] + lset centroid $idx $sum + incr idx + } + } + + set idx 0 + foreach c $centroid { + lset centroid $idx [expr {$c / double($number)}] + incr idx + } + + return $centroid +} + +# ReflectPointInPoint -- +# Reflect a point in another point and return the result +# +# Arguments: +# centre Point that serves as the reflection center +# point Point to be reflected (list of coordinates) +# +# Result: +# Coordinates of the new point +# +proc ::math::probopt::ReflectPointInPoint {centre point} { + + set newPoint {} + + foreach c $centre p $point { + lappend newPoint [expr {2.0 * $c - $p}] + } + + return $newPoint +} + +# TriangularSelect -- +# Select "number" values from a list of values +# - the probability is triangular +# +# Arguments: +# values List of values to choose from +# number Number of values to choose (must be smaller than length of the list) +# +# Result: +# Selected values +# +proc ::math::probopt::TriangularSelect {values number} { + set selected {} + + for {set i 0} {$i < $number} {incr i} { + set n [llength $values] + + set r [expr {1.0 - sqrt(1.0 - rand())}] + set idx [expr {int($r * $n)}] + lappend selected [lindex $values $idx] + set values [lreplace $values $idx $idx] + } + + return $selected +} diff --git a/vendor/math/qcomplex.man b/vendor/math/qcomplex.man new file mode 100644 index 00000000..d339c6ab --- /dev/null +++ b/vendor/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 }] +[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 ../common-text/feedback.inc] +[manpage_end] diff --git a/vendor/math/qcomplex.tcl b/vendor/math/qcomplex.tcl new file mode 100644 index 00000000..ac3cbf7c --- /dev/null +++ b/vendor/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/vendor/math/qcomplex.test b/vendor/math/qcomplex.test new file mode 100644 index 00000000..f080c969 --- /dev/null +++ b/vendor/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.5 +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/vendor/math/quasirandom.man b/vendor/math/quasirandom.man new file mode 100644 index 00000000..8762ab7f --- /dev/null +++ b/vendor/math/quasirandom.man @@ -0,0 +1,118 @@ +[vset VERSION 1] +[manpage_begin math::quasirandom n [vset VERSION]] +[keywords {quasi-random}] +[keywords mathematics] +[moddesc {Tcl Math Library}] +[titledesc {Quasi-random points for integration and Monte Carlo type methods}] +[category Mathematics] +[require Tcl 8.6] +[require TclOO] +[require math::quasirandom [vset VERSION]] +[description] +[para] + +In many applications pseudo-random numbers and pseudo-random points in a (limited) +sample space play an important role. For instance in any type of Monte Carlo simulation. +Pseudo-random numbers, however, may be too random and as a consequence a large +number of data points is required to reduce the error or fluctuation in the results +to the desired value. +[para] + +Quasi-random numbers can be used as an alternative: instead of "completely" arbitrary +points, points are generated that are diverse enough to cover the entire sample space +in a more or less uniform way. As a consequence convergence to the limit can be +much faster, when such quasi-random numbers are well-chosen. +[para] + +The package defines a [term class] "qrpoint" that creates a command to generate +quasi-random points in 1, 2 or more dimensions. The command can either generate +separate points, so that they can be used in a user-defined algorithm or use these +points to calculate integrals of functions defined over 1, 2 or more dimensions. +It also holds several other common algorithms. (NOTE: these are not implemented yet) +[para] +One particular characteristic of the generators is that there are no tuning parameters +involved, which makes the use particularly simple. + + +[section "COMMANDS"] +A quasi-random point generator is created using the [term qrpoint] class: + +[list_begin definitions] + +[call [cmd "::math::quasirandom::qrpoint create"] [arg NAME] [arg DIM] [opt ARGS]] +This command takes the following arguments: + +[list_begin arguments] +[arg_def string NAME] The name of the command to be created (alternatively: the [term new] subcommand +will generate a unique name) +[arg_def integer/string DIM] The number of dimensions or one of: "circle", "disk", "sphere" or "ball" +[arg_def strings ARGS] Zero or more key-value pairs. The supported options are: + +[list_begin itemized] +[item] [term {-start index}]: The index for the next point to be generated (default: 1) +[item] [term {-evaluations number}]: The number of evaluations to be used by default (default: 100) +[list_end] + +[list_end] + +[list_end] + +The points that are returned lie in the hyperblock [lb]0,1[lb]^n (n the number of dimensions) +or on the unit circle, within the unit disk, on the unit sphere or within the unit ball. +[para] + +Each generator supports the following subcommands: +[list_begin definitions] + +[call [cmd "gen next"]] +Return the coordinates of the next quasi-random point +[para] + +[call [cmd "gen set-start"] [arg index]] +Reset the index for the next quasi-random point. This is useful to control which list of points is returned. +Returns the new or the current value, if no value is given. +[para] + +[call [cmd "gen set-evaluations"] [arg number]] +Reset the default number of evaluations in compound algorithms. Note that the actual number is the +smallest 4-fold larger or equal to the given number. (The 4-fold plays a role in the detailed integration +routine.) +[para] + +[call [cmd "gen integral"] [arg func] [arg minmax] [arg args]] +Calculate the integral of the given function over the block (or the circle, sphere etc.) + +[list_begin arguments] +[arg_def string func] The name of the function to be integrated + +[arg_def list minmax] List of pairs of minimum and maximum coordinates. This can be used to +map the quasi-random coordinates to the desired hyper-block. +[para] +If the space is a circle, disk etc. then this argument should be a single value, the radius. +The circle, disk, etc. is centred at the origin. If this is not what is required, then a coordinate +transformation should be made within the function. + +[arg_def strings args] Zero or more key-value pairs. The following options are supported: +[list_begin itemized] +[item] [term {-evaluations number}]: The number of evaluations to be used. If not specified use the +default of the generator object. +[list_end] + +[list_end] + +[list_end] + +[section TODO] +Implement other algorithms and variants +[para] +Implement more unit tests. +[para] +Comparison to pseudo-random numbers for integration. + + +[section References] + +Various algorithms exist for generating quasi-random numbers. The generators created in this package are based on: +[uri http://extremelearning.com.au/unreasonable-effectiveness-of-quasirandom-sequences/] + +[manpage_end] diff --git a/vendor/math/quasirandom.tcl b/vendor/math/quasirandom.tcl new file mode 100644 index 00000000..5885c325 --- /dev/null +++ b/vendor/math/quasirandom.tcl @@ -0,0 +1,517 @@ +# quasirandom.tcl -- +# Generate quasi-random points in n dimensions and provide simple +# methods to evaluate an integral +# +# Note: provide a OO-style interface +# +# TODO: integral-detailed, minimum, maximum +# +# Based on the blog "The Unreasonable Effectiveness of Quasirandom Sequences" by Martin Roberts, +# http://extremelearning.com.au/unreasonable-effectiveness-of-quasirandom-sequences/ +# + +package require Tcl 8.5 +package require TclOO + +package provide math::quasirandom 1.0 + +namespace eval ::math::quasirandom { + +# qrpoints -- +# Create the class +# +::oo::class create qrpoints { + + # constructor -- + # Construct a new instance of the qrpoints class + # + # Arguments: + # dim Number of dimensions, or one of: circle, disk, sphere, ball + # args Zero or more key-value pairs: + # -start - start the generation with the given multiplier (integer) + # -evaluations - default number of evaluations for the integration + # (possibly others as well) + # + constructor {dimin args} { + my variable dim + my variable coord_factors + my variable step + my variable evaluations + my variable use_radius + my variable effective_dim + + if { ( ![string is integer -strict $dimin] || $dimin <= 0 ) && $dimin ni {circle disk sphere ball} } { + return -code error "The dimension argument should be a positive integer value or one of circle, disk, sphere or ball" + } + + set use_radius 1 + switch -- $dimin { + "circle" { + set dim 1 + set effective_dim 2 + ::oo::objdefine [self] { + forward next my CircleNext + forward Volume my CircleVolume + } + } + "disk" { + set dim 2 + set effective_dim 2 + ::oo::objdefine [self] { + forward next my DiskNext + forward Volume my DiskVolume + } + } + "sphere" { + set dim 2 + set effective_dim 3 + ::oo::objdefine [self] { + forward next my SphereNext + forward Volume my SphereVolume + } + } + "ball" { + set dim 3 + set effective_dim 3 + ::oo::objdefine [self] { + forward next my BallNext + forward Volume my BallVolume + } + } + default { + set dim $dimin + set use_radius 0 + ::oo::objdefine [self] { + forward next my PlainNext + forward Volume my PlainVolume + } + } + } + + set step 1 + set evaluations 100 + + set coord_factors [::math::quasirandom::CoordFactors $dim] + + foreach {key value} $args { + switch -- $key { + "-start" { + + my set-step $value + } + "-evaluations" { + if { ![string is -strict integer $value] || $value <= 0 } { + return -code error "The value for the option $key should be a positive integer value" + } + + my set-evaluations $value + } + default { + return -code error "Unknown option: $key -- value: $value" + } + } + } + } + + # PlainNext -- + # Generate the next point - for a hyperblock + # + method PlainNext {} { + my variable step + my variable coord_factors + + set coords {} + foreach f $coord_factors { + lappend coords [expr {fmod( $f * $step, 1.0 )}] + } + + incr step + + return $coords + } + + # PlainVolume -- + # Calculate the volume of a hyperblock + # + # Arguments: + # minmax List of minimum and maximum per dimension + # + # Returns: + # The volume + # + method PlainVolume {minmax} { + set volume 1.0 + foreach range $minmax { + lassign $range xmin xmax + set volume [expr {$volume * ($xmax-$xmin)}] + } + return $volume + } + + # CircleNext -- + # Generate the next point on a unit circle + # + method CircleNext {} { + + set f [lindex [my PlainNext] 0] + set rad [expr {2.0 * acos(-1.0) * $f}] + + set coords [list [expr {cos($rad)}] [expr {sin($rad)}]] + + return $coords + } + + # CircleVolume -- + # Calculate the "volume" of the unit circle + # + # Arguments: + # radius Radius of the circle + # + method CircleVolume {radius} { + return [expr {$radius * 2.0*cos(-1.0)}] + } + + # DiskNext -- + # Generate the next point on a unit disk + # + method DiskNext {} { + + while {1} { + set coords [my PlainNext] + + lassign $coords x y + + if { hypot($x-0.5,$y-0.5) <= 0.25 } { + set coords [list [expr {2.0*$x-1.0}] [expr {2.0*$y-1.0}]] + break + } + } + return $coords + } + + # DiskVolume -- + # Calculate the "volume" of the unit disk + # + # Arguments: + # radius Radius of the disk + # + method DiskVolume {radius} { + return [expr {$radius**2 * cos(-1.0)}] + } + + # BallNext -- + # Generate the next point on a unit ball + # + method BallNext {} { + + while {1} { + set coords [my PlainNext] + + lassign $coords x y z + + set r [expr {($x-0.5)**2 + ($y-0.5)**2 + ($z-0.5)**2}] + if { $r <= 0.25 } { + set coords [list [expr {2.0*$x-1.0}] [expr {2.0*$y-1.0}] [expr {2.0*$z-1.0}]] + break + } + } + + return $coords + } + + # BallVolume -- + # Calculate the volume of the unit ball + # + # Arguments: + # radius Radius of the ball + # + method BallVolume {radius} { + return [expr {4.0/3.0 * $radius**3 * cos(-1.0)}] + } + + # SphereNext -- + # Generate the next point on a unit sphere + # + method SphereNext {} { + + set coords [my PlainNext] + + lassign $coords u v + + set phi [expr {2.0 * acos(-1.0) * $v}] + set lambda [expr {acos(2.0 * $u - 1.0) + 0.5 * acos(-1.0)}] + + set x [expr {cos($lambda) * cos($phi)}] + set y [expr {cos($lambda) * sin($phi)}] + set z [expr {sin($lambda)}] + + return [list $x $y $z] + } + + # SphereVolume -- + # Calculate the "volume" of the unit sphere + # + # Arguments: + # radius Radius of the sphere + # + method SphereVolume {radius} { + return [expr {4.0 * $radius**2 * cos(-1.0)}] + } + + # set-step -- + # Set the first step to be used + # + method set-step {{value ""}} { + my variable step + + if { $value eq "" } { + return $step + } + + if { ![string is integer -strict $value] } { + return -code error "The value for the option $key should be an integer value" + } + + set step [expr {int($value)}] + } + + # set-evaluations -- + # Set the number of evaluations for integration + # + method set-evaluations {{value ""}} { + my variable evaluations + + if { $value eq "" } { + return $evaluations + } + + if { ![string is integer -strict $value] || $value <= 0 } { + return -code error "The value for the option $key should be a positive integer value" + } + + set evaluations [expr {4*int(($value+3)/4)}] ;# Make sure it is a 4-fold + } + + # integral -- + # Evaluate the integral of a function over a given (rectangular) domain + # + # Arguments: + # func Function to be integrated + # minmax List of minimum and maximum bounds for each coordinate + # args Key-value pair: number of evaluations + # + # Returns: + # Estimate of the integral based on "evaluations" evaluations + # Note: no error estimate + # + method integral {func minmax args} { + my variable dim + my variable step + my variable coord_factors + my variable evaluations + my variable use_radius + my variable effective_dim + + set evals $evaluations + + set func [uplevel 1 [list namespace which -command $func]] + + foreach {key value} $args { + switch -- $key { + "-evaluations" { + if { ![string is integer -strict $value] || $value <= 0 } { + return -code error "The value for the option $key should be a positive integer value" + } + + set evals $value ;# Local only! + } + default { + return -code error "Unknown option: $key -- value: $value" + } + } + } + + if { ! $use_radius } { + if { [llength $minmax] != $dim } { + return -code error "The number of ranges (minmax) should be equal to the dimension ($dim)" + } else { + set volume [my Volume $minmax] + } + } else { + if { ! [string is double $minmax] } { + return -code error "For a circle, disk, sphere or ball only the radius should be given" + } else { + set radius $minmax + set minmax [lrepeat $effective_dim [list 0.0 $radius]] + set volume [my Volume $radius] + } + } + + set sum 0.0 + + for {set i 0} {$i < $evals} {incr i} { + set coords {} + foreach c [my next] range $minmax { + lassign $range xmin xmax + lappend coords [expr {$xmin + ($xmax-$xmin) * $c}] + } + set sum [expr {$sum + [$func $coords]}] + } + + return [expr {$sum * $volume / $evals}] + } + + # integral-detailed -- + # Evaluate the integral of a function over a given (rectangular) domain + # and provide detailed information + # + # Arguments: + # func Function to be integrated + # minmax List of minimum and maximum bounds for each coordinate + # args Key-value pair: number of evaluations + # + # Returns: + # Dictionary of: + # -estimate value - estimate of the integral + # -evaluations number - total number of evaluations + # -error value - estimate of the error + # -rawvalues list - list of raw values obtained for the integral + # + method integral-detailed {func minmax args} { + my variable evaluations + + set evals $evaluations + + set func [uplevel 1 [list namespace which -command $func]] + + foreach {key value} $args { + switch -- $key { + "-evaluations" { + if { ![string is integer -strict $value] || $value <= 0 } { + return -code error "The value for the option $key should be a positive integer value" + } + + set evals $value ;# Local only! + } + default { + return -code error "Unknown option: $key -- value: $value" + } + } + } + + lappend args -evaluations [expr {($evals+3)/4}] + + for {set i 0} {$i < 4} {incr i} { + lappend rawvalues [my integral $func $minmax {*}$args] + } + + set sum 0.0 + set sqsum 0.0 + + foreach value $rawvalues { + set sum [expr {$sum + $value}] + set sqsum [expr {$sqsum + $value**2}] + } + + set stdev [expr {sqrt(($sqsum - $sum**2/4.0)/3.0)}] + set sum [expr {$sum / 4.0}] + # Standard error of mean + return [dict create -estimate $sum -error [expr {$stdev/2.0}] -rawvalues $rawvalues -evaluations [expr {4*(($evals+3)/4)}]] + } + +} ;# End of class + +} ;# End of namespace eval + +# CoordFactors -- +# Determine the factors for the coordinates +# +# Arguments: +# dim Number of dimensions +# +proc ::math::quasirandom::CoordFactors {dim} { + set n [expr {$dim + 1}] + + set f 1.0 + for {set i 0} {$i < 10} {incr i} { + set f [expr {$f - ($f**$n-$f-1.0) / ($n*$f**($n-1)-1.0)}] + } + + set factors {} + set af 1.0 + + for {set i 0} {$i < $dim} {incr i} { + set af [expr {$af/$f}] + lappend factors $af + } + + return $factors +} + +# End of code for package + +# -------------------------------------------- +# test -- +# + +if {0} { + +::math::quasirandom::qrpoints create square 2 + +puts [square next] +puts [square next] +puts [square next] + + +proc f {coords} { + lassign $coords x y + + expr {$x**2+$y**2} +} + +proc g {coords} { + lassign $coords x y + + expr {(1.0-cos($x))**2 * (1.0-cos($y))**2} +} + +# Print four estimates - should not deviate too much from 10.0 +puts [square integral f {{0 1} {0 3}}] +puts [square integral f {{0 1} {0 3}}] +puts [square integral f {{0 1} {0 3}}] +puts [square integral f {{0 1} {0 3}}] + +# Print a sequence of estimates - should converge to (3pi/2)**2 +foreach n {20 40 100 300 1000} { + square set-evaluations $n + + puts "$n: [square integral g [list [list 0.0 [expr {acos(-1)}]] [list 0.0 [expr {acos(-1)}]]]]" +} + + +::math::quasirandom::qrpoints create block 3 +puts [block next] + +puts "Circle ..." +::math::quasirandom::qrpoints create circle circle +puts [circle next] +puts [circle next] +puts [circle next] + +# Test values for CoordFactors +# dim = 1: 1.6180339887498948482045... +# dim = 2: 1.3247179572447460259609... +# dim = 3: 1.2207440846057594753616... + +set f [::math::quasirandom::CoordFactors 1] +puts 1.6180339887498948482045... +puts [expr {1.0/$f}] + +set f [lindex [::math::quasirandom::CoordFactors 2] 0] +puts 1.3247179572447460259609... +puts [expr {1.0/$f}] + +set f [lindex [::math::quasirandom::CoordFactors 3] 0] +puts 1.2207440846057594753616... +puts [expr {1.0/$f}] +} diff --git a/vendor/math/quasirandom.test b/vendor/math/quasirandom.test new file mode 100644 index 00000000..37c5c440 --- /dev/null +++ b/vendor/math/quasirandom.test @@ -0,0 +1,498 @@ +# -*- tcl -*- +# quasirandom.test -- +# Tests for the quasi-random numbers package +# + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.5 +testsNeedTcltest 2.1 + +testing { + useLocal quasirandom.tcl math::quasirandom +} + +# +# Functions for integration tests +# +proc const {coords} { + return 1.0 +} + +proc fx {coords} { + set x [lindex $coords 0] + return $x +} + +proc fy {coords} { + set y [lindex $coords 1] + return $y +} + +proc fz {coords} { + set z [lindex $coords 2] + return $z +} + +proc fxyz4 {coords} { + lassign $coords x y z + return [expr {($x*$y*$z)**4}] +} + +# +# Auxiliary proc +# +proc equalCoords {coords1 coords2} { + set equal 1 + foreach c1 $coords1 c2 $coords2 { + if { $c1 != $c2 } { + set equal 0 + break + } + } + return $equal +} + +# +# Create and register (in that order!) custom matching procedures +# +proc matchTolerant { expected actual } { + set match 1 + foreach a $actual e $expected { + if { $e != 0.0 } { + if { abs($e-$a)>1.0e-7*abs($e) && + abs($e-$a)>1.0e-7*abs($a) } { + set match 0 + break + } + } else { + if { abs($a) > 1.0e-7 } { + set match 0 + } + } + } + return $match +} +proc matchOnePercent { expected actual } { + set match 1 + foreach a $actual e $expected { + if { $e != 0.0 } { + if { abs($e-$a)>1.0e-2*abs($e) && + abs($e-$a)>1.0e-2*abs($a) } { + set match 0 + break + } + } else { + if { abs($a) > 1.0e-2 } { + set match 0 + } + } + } + return $match +} + +::tcltest::customMatch tolerant matchTolerant +::tcltest::customMatch error1percent matchOnePercent +::tcltest::customMatch equal equalCoords + + +# +# Testing CoordFactors: the basis of the algorithm +# Note: exact matching +# +test "Quasirandom-0.1" "Check basic factor for 1 dimension" -body { + set f [::math::quasirandom::CoordFactors 1] + return [expr {1.0/$f}] +} -result 1.618033988749895 + +test "Quasirandom-0.2" "Check basic factor for 2 dimensions" -body { + set f [lindex [::math::quasirandom::CoordFactors 2] 0] + return [expr {1.0/$f}] +} -result 1.324717957244746 + +test "Quasirandom-0.3" "Check basic factor for 3 dimensions" -body { + set f [lindex [::math::quasirandom::CoordFactors 3] 0] + return [expr {1.0/$f}] +} -result 1.2207440846057596 + +test "Quasirandom-0.4" "Check number of factors for 10 dimensions" -body { + return [llength [::math::quasirandom::CoordFactors 10]] +} -result 10 + +# +# Basic interface to the qrpoints class +# +test "Quasirandom-1.0" "Simple QR generator for two dimensions" -match tolerant -body { + ::math::quasirandom::qrpoints create simple 2 + + return [simple next] +} -result {0.7548776662466927 0.5698402909980532} -cleanup {simple destroy} + +test "Quasirandom-1.1" "Simple QR generator - negative dimension" -body { + ::math::quasirandom::qrpoints create simple -1 +} -returnCodes {error} -result {The dimension argument should be a positive integer value or one of circle, disk, sphere or ball} + +test "Quasirandom-1.2" "Simple QR generator - set start" -body { + ::math::quasirandom::qrpoints create simple 2 + ::math::quasirandom::qrpoints create simple2 2 -start 2 + + simple next + set coords [simple next] + + set coords2 [simple2 next] ;# Should be equal to the second point for the [simple] generator + + equalCoords $coords $coords2 +} -result 1 -cleanup {simple destroy; simple2 destroy} + +# +# Test simple methods +# +test "Quasirandom-2.1" "set-step sets and returns the value" -match equal -body { + ::math::quasirandom::qrpoints create simple 2 + + simple set-step 100 +} -result 100 -cleanup {simple destroy} + +test "Quasirandom-2.2" "set-evaluations sets and returns the value" -match equal -body { + ::math::quasirandom::qrpoints create simple 2 + + simple set-evaluations 100 +} -result 100 -cleanup {simple destroy} + +test "Quasirandom-2.3" "set-step returns the value" -match equal -body { + ::math::quasirandom::qrpoints create simple 2 + + simple set-step 100 + simple set-step +} -result 100 -cleanup {simple destroy} + +test "Quasirandom-2.4" "set-evaluations returns the value" -match equal -body { + ::math::quasirandom::qrpoints create simple 2 + + simple set-evaluations 100 + simple set-evaluations +} -result 100 -cleanup {simple destroy} + +# +# Test of bounds on points +# +test "Quasirandom-3.1" "Points should fall within block" -body { + ::math::quasirandom::qrpoints create simple 10 + + set correct_bound 1 + + for {set i 0} {$i < 100} {incr i} { + set coords [simple next] + + foreach c $coords { + if { $c < 0.0 || $c > 1.0 } { + set correct_bound 0 + break + } + } + } + + return $correct_bound +} -result 1 -cleanup {simple destroy} + +test "Quasirandom-3.2" "Points should fall on a circle" -match tolerant -body { + ::math::quasirandom::qrpoints create simple circle + + set correct_bound 1 + set radii {} + + for {set i 0} {$i < 100} {incr i} { + set coords [simple next] + + lassign $coords x y + lappend radii [expr {hypot($x,$y)}] + } + + return $radii +} -result [lrepeat 100 1.0] -cleanup {simple destroy} + +test "Quasirandom-3.3" "Points should fall within a disk" -match equal -body { + ::math::quasirandom::qrpoints create simple disk + + set correct_bounds {} + for {set i 0} {$i < 100} {incr i} { + set coords [simple next] + + lassign $coords x y + lappend correct_bounds [expr {hypot($x,$y) <= 1.0}] + } + + return $correct_bounds +} -result [lrepeat 100 1] -cleanup {simple destroy} + +test "Quasirandom-3.4" "Points should fall on a sphere" -match tolerant -body { + ::math::quasirandom::qrpoints create simple sphere + + set correct_bound 1 + set radii {} + + for {set i 0} {$i < 100} {incr i} { + set coords [simple next] + + lassign $coords x y z + lappend radii [expr {sqrt($x**2 + $y**2 + $z**2)}] + } + + return $radii +} -result [lrepeat 100 1.0] -cleanup {simple destroy} + +test "Quasirandom-3.5" "Points should fall within a ball" -match equal -body { + ::math::quasirandom::qrpoints create simple ball + + set correct_bounds {} + for {set i 0} {$i < 100} {incr i} { + set coords [simple next] + + lassign $coords x y + lappend correct_bounds [expr {sqrt($x**2 + $y**2 + $z**2) <= 1.0}] + } + + return $correct_bounds +} -result [lrepeat 100 1] -cleanup {simple destroy} + + + + +# +# Test of integral methods +# +# Integrating a constant function means the result is the volume +# +test "Quasirandom-4.1" "Integrate constant function - volume = 1" -match tolerant -body { + ::math::quasirandom::qrpoints create simple 3 + + set result [simple integral const {{0.0 1.0} {0.0 1.0} {0.0 1.0}}] + +} -result 1.0 -cleanup {simple destroy} + +test "Quasirandom-4.2" "Integrate constant function - volume = 8" -match tolerant -body { + ::math::quasirandom::qrpoints create simple 3 + + set result [simple integral const {{0.0 2.0} {0.0 2.0} {0.0 2.0}}] + +} -result 8.0 -cleanup {simple destroy} + +test "Quasirandom-4.3" "Integrate constant function - circle" -match tolerant -body { + ::math::quasirandom::qrpoints create simple circle + + set result [simple integral const 2.0] + +} -result [expr {2.0 * 2.0 * cos(-1.0)}] -cleanup {simple destroy} + +test "Quasirandom-4.3" "Integrate constant function - disk" -match tolerant -body { + ::math::quasirandom::qrpoints create simple disk + + set result [simple integral const 2.0] + +} -result [expr {2.0**2 * cos(-1.0)}] -cleanup {simple destroy} + +test "Quasirandom-4.4" "Integrate constant function - sphere" -match tolerant -body { + ::math::quasirandom::qrpoints create simple sphere + + set result [simple integral const 2.0] + +} -result [expr {4.0 * 2.0**2 * cos(-1.0)}] -cleanup {simple destroy} + +test "Quasirandom-4.5" "Integrate constant function - ball" -match tolerant -body { + ::math::quasirandom::qrpoints create simple ball + + set result [simple integral const 2.0] + +} -result [expr {4.0/3.0 * 2.0**3 * cos(-1.0)}] -cleanup {simple destroy} + +# We do not use too many evaluations ... error less than 1% +test "Quasirandom-4.6" "Integrate linear function (x, y, z)" -match error1percent -body { + ::math::quasirandom::qrpoints create simple 3 + + set result [list [simple integral fx {{0.0 1.0} {0.0 1.0} {0.0 1.0}}] \ + [simple integral fy {{0.0 1.0} {0.0 1.0} {0.0 1.0}}] \ + [simple integral fz {{0.0 1.0} {0.0 1.0} {0.0 1.0}}] ] + +} -result {0.5 0.5 0.5} -cleanup {simple destroy} + +# +# The function varies "sharply", so we need more evaluations +# +test "Quasirandom-4.7" "Integrate (xyz)**4" -match error1percent -body { + ::math::quasirandom::qrpoints create simple 3 + + # Exact answer is 1/125 + set result [simple integral fxyz4 {{0.0 1.0} {0.0 1.0} {0.0 1.0}} -evaluations 1000] + +} -result 0.0080 -cleanup {simple destroy} + + +# +# Detailed integration: provides error estimates but also an indication that +# the values can differ quite a bit +# +test "Quasirandom-5.1" "Integrate constant function with details - volume = 1" -match tolerant -body { + ::math::quasirandom::qrpoints create simple 3 + + set result [simple integral-detailed const {{0.0 1.0} {0.0 1.0} {0.0 1.0}}] + + set rawvalues [dict get $result -rawvalues] + +} -result {1.0 1.0 1.0 1.0} -cleanup {simple destroy} + + +test "Quasirandom-5.2" "Integrate linear function with details - volume = 1" -match tolerant -body { + ::math::quasirandom::qrpoints create simple 3 + + set result [simple integral-detailed fx {{0.0 1.0} {0.0 1.0} {0.0 1.0}}] + + set rawvalues [dict get $result -rawvalues] + +} -result {0.48924267415013695 0.48855550905424594 0.5278683439583554 0.48718117886246404} -cleanup {simple destroy} + + +test "Quasirandom-5.3" "Integrate (xyz)**4 with details - volume = 1" -match tolerant -body { + ::math::quasirandom::qrpoints create simple 3 + + set result [simple integral-detailed fxyz4 {{0.0 1.0} {0.0 1.0} {0.0 1.0}}] + + set rawvalues [dict get $result -rawvalues] + +} -result {0.0022115062627913935 0.009840104253511376 0.014937934937801888 0.007838969739655276} -cleanup {simple destroy} + + +# +# Test integration procedures in a different namespace +# +test "Quasirandom-6.1" "Integrate ::func::func" -match tolerant -body { + namespace eval ::func { + + proc func {xy} { + lassign $xy x y + expr {$x**2+$y**2} + } + + ::math::quasirandom::qrpoints create simple 2 + + set ::result [simple integral func {{0.0 1.0} {0.0 1.0}}] + } + + return $result + +} -result {0.67353777} -cleanup {::func::simple destroy} + + +test "Quasirandom-6.2" "Integrate (details) ::func::func" -match tolerant -body { + namespace eval ::func { + + proc func {xy} { + lassign $xy x y + expr {$x**2+$y**2} + } + + ::math::quasirandom::qrpoints create simple 2 + + set ::result [simple integral-detailed func {{0.0 1.0} {0.0 1.0}}] + } + + return [dict get $result -estimate] + +} -result {0.67353777} -cleanup {::func::simple destroy} + + +# TODO: +# - func in different namespace +# - implement detailed integration and test the details +# - implement minimization + +# +# Hm, the less than 1% error in the above test is a coincidence. The error is more +# likely to be 10%. +# +if {0} { + ::math::quasirandom::qrpoints create simple 3 + # Exact answer is 1/125 + set result [simple integral fxyz4 {{0.0 1.0} {0.0 1.0} {0.0 1.0}} -evaluations 100] + puts "fxyz4: $result" + simple set-step 0 + set result [simple integral fxyz4 {{0.0 1.0} {0.0 1.0} {0.0 1.0}} -evaluations 1000] + puts "fxyz4: $result" + set result [simple integral fxyz4 {{0.0 1.0} {0.0 1.0} {0.0 1.0}} -evaluations 1000] + puts "fxyz4: $result" + set result [simple integral fxyz4 {{0.0 1.0} {0.0 1.0} {0.0 1.0}} -evaluations 1000] + puts "fxyz4: $result" + + package require math::statistics + set samples {} + for {set trial 0} {$trial < 10} {incr trial} { + set sum 0.0 + + for {set p 0} {$p < 100} {incr p} { + set x [expr {rand()}] + set y [expr {rand()}] + set z [expr {rand()}] + set sum [expr {$sum + [fxyz4 [list $x $y $z]]}] + } + + puts "Trial $trial: [expr {$sum/100.0}]" + + lappend samples [expr {$sum/100.0}] + } + + puts "MonteCarlo (100):" + puts [::math::statistics::mean $samples] + puts [::math::statistics::stdev $samples] + + set samples {} + for {set trial 0} {$trial < 10} {incr trial} { + set sum 0.0 + + for {set p 0} {$p < 1000} {incr p} { + set x [expr {rand()}] + set y [expr {rand()}] + set z [expr {rand()}] + set sum [expr {$sum + [fxyz4 [list $x $y $z]]}] + } + + puts "Trial $trial: [expr {$sum/1000.0}]" + + lappend samples [expr {$sum/1000.0}] + } + + puts "MonteCarlo (1000):" + puts [::math::statistics::mean $samples] + puts [::math::statistics::stdev $samples] + + set samples {} + for {set trial 0} {$trial < 10} {incr trial} { + set result [simple integral fxyz4 {{0.0 1.0} {0.0 1.0} {0.0 1.0}} -evaluations 100] + + lappend samples $result + } + + puts "Quasi-random (100):" + puts [::math::statistics::mean $samples] + puts [::math::statistics::stdev $samples] + + set samples {} + for {set trial 0} {$trial < 10} {incr trial} { + set result [simple integral fxyz4 {{0.0 1.0} {0.0 1.0} {0.0 1.0}} -evaluations 1000] + + lappend samples $result + } + + puts "Quasi-random (1000):" + puts [::math::statistics::mean $samples] + puts [::math::statistics::stdev $samples] + + + puts [simple integral-detailed fx {{0.0 1.0} {0.0 1.0} {0.0 1.0}}] +} + + +# ------------------------------------------------------------------------- + +# End of test cases +testsuiteCleanup diff --git a/vendor/math/rational_funcs.man b/vendor/math/rational_funcs.man new file mode 100644 index 00000000..7c098558 --- /dev/null +++ b/vendor/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 }] +[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 ../common-text/feedback.inc] +[manpage_end] diff --git a/vendor/math/rational_funcs.tcl b/vendor/math/rational_funcs.tcl new file mode 100644 index 00000000..2dae3971 --- /dev/null +++ b/vendor/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/vendor/math/roman.man b/vendor/math/roman.man new file mode 100644 index 00000000..29594751 --- /dev/null +++ b/vendor/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 }] +[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 ../common-text/feedback.inc] +[manpage_end] diff --git a/vendor/math/roman.test b/vendor/math/roman.test new file mode 100644 index 00000000..4efc0c87 --- /dev/null +++ b/vendor/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.5 +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/vendor/math/romannumerals.tcl b/vendor/math/romannumerals.tcl new file mode 100644 index 00000000..a67d2599 --- /dev/null +++ b/vendor/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/vendor/math/romberg.man b/vendor/math/romberg.man new file mode 100644 index 00000000..3b62febc --- /dev/null +++ b/vendor/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 . All rights\ +reserved. Redistribution permitted under the terms of the Open\ +Publication License "] +[moddesc {Tcl Math Library}] +[titledesc {Romberg integration}] +[category Mathematics] +[require Tcl 8.2] +[require math::calculus 0.6] +[description] +[para] +The [cmd romberg] procedures in the [cmd math::calculus] package +perform numerical integration of a function of one variable. They +are intended to be of "production quality" in that they are robust, +precise, and reasonably efficient in terms of the number of function +evaluations. +[section "PROCEDURES"] + +The following procedures are available for Romberg integration: + +[list_begin definitions] +[call [cmd ::math::calculus::romberg] [arg f] [arg a] [arg b] [opt [arg "-option value"]...]] + +Integrates an analytic function over a given interval. + +[call [cmd ::math::calculus::romberg_infinity] [arg f] [arg a] [arg b] [opt [arg "-option value"]...]] + +Integrates an analytic function over a half-infinite interval. + +[call [cmd ::math::calculus::romberg_sqrtSingLower] [arg f] [arg a] [arg b] [opt [arg "-option value"]...]] + +Integrates a function that is expected to be analytic over an interval +except for the presence of an inverse square root singularity at the +lower limit. + +[call [cmd ::math::calculus::romberg_sqrtSingUpper] [arg f] [arg a] [arg b] [opt [arg "-option value"]...]] + +Integrates a function that is expected to be analytic over an interval +except for the presence of an inverse square root singularity at the +upper limit. + +[call [cmd ::math::calculus::romberg_powerLawLower] [arg gamma] [arg f] [arg a] [arg b] [opt [arg "-option value"]...]] + +Integrates a function that is expected to be analytic over an interval +except for the presence of a power law singularity at the +lower limit. + +[call [cmd ::math::calculus::romberg_powerLawUpper] [arg gamma] [arg f] [arg a] [arg b] [opt [arg "-option value"]...]] + +Integrates a function that is expected to be analytic over an interval +except for the presence of a power law singularity at the +upper limit. + +[call [cmd ::math::calculus::romberg_expLower] [arg f] [arg a] [arg b] [opt [arg "-option value"]...]] + +Integrates an exponentially growing function; the lower limit of the +region of integration may be arbitrarily large and negative. + +[call [cmd ::math::calculus::romberg_expUpper] [arg f] [arg a] [arg b] [opt [arg "-option value"]...]] + +Integrates an exponentially decaying function; the upper limit of the +region of integration may be arbitrarily large. + +[list_end] + +[section PARAMETERS] + +[list_begin definitions] + +[def [arg f]] + +Function to integrate. Must be expressed as a single Tcl command, +to which will be appended a single argument, specifically, the +abscissa at which the function is to be evaluated. The first word +of the command will be processed with [cmd "namespace which"] in the +caller's scope prior to any evaluation. Given this processing, the +command may local to the calling namespace rather than needing to be +global. + +[def [arg a]] + +Lower limit of the region of integration. + +[def [arg b]] + +Upper limit of the region of integration. For the +[cmd romberg_sqrtSingLower], [cmd romberg_sqrtSingUpper], +[cmd romberg_powerLawLower], [cmd romberg_powerLawUpper], +[cmd romberg_expLower], and [cmd romberg_expUpper] procedures, +the lower limit must be strictly less than the upper. For +the other procedures, the limits may appear in either order. + +[def [arg gamma]] + +Power to use for a power law singularity; see section +[sectref "IMPROPER INTEGRALS"] for details. + +[list_end] + +[section OPTIONS] + +[list_begin definitions] + +[def "[option -abserror] [arg epsilon]"] + +Requests that the integration machinery proceed at most until +the estimated absolute error of the integral is less than +[arg epsilon]. The error may be seriously over- or underestimated +if the function (or any of its derivatives) contains singularities; +see section [sectref "IMPROPER INTEGRALS"] for details. Default +is 1.0e-08. + +[def "[option -relerror] [arg epsilon]"] + +Requests that the integration machinery proceed at most until +the estimated relative error of the integral is less than +[arg epsilon]. The error may be seriously over- or underestimated +if the function (or any of its derivatives) contains singularities; +see section [sectref "IMPROPER INTEGRALS"] for details. Default is +1.0e-06. + +[def "[option -maxiter] [arg m]"] + +Requests that integration terminate after at most [arg n] triplings of +the number of evaluations performed. In other words, given [arg n] +for [option -maxiter], the integration machinery will make at most +3**[arg n] evaluations of the function. Default is 14, corresponding +to a limit approximately 4.8 million evaluations. (Well-behaved +functions will seldom require more than a few hundred evaluations.) + +[def "[option -degree] [arg d]"] + +Requests that an extrapolating polynomial of degree [arg d] be used +in Romberg integration; see section [sectref "DESCRIPTION"] for +details. Default is 4. Can be at most [arg m]-1. + +[list_end] + +[section DESCRIPTION] + +The [cmd romberg] procedure performs Romberg integration using +the modified midpoint rule. Romberg integration is an iterative +process. At the first step, the function is evaluated at the +midpoint of the region of integration, and the value is multiplied by +the width of the interval for the coarsest possible estimate. +At the second step, the interval is divided into three parts, +and the function is evaluated at the midpoint of each part; the +sum of the values is multiplied by three. At the third step, +nine parts are used, at the fourth twenty-seven, and so on, +tripling the number of subdivisions at each step. + +[para] + +Once the interval has been divided at least [arg d] times, +a polynomial is fitted to the integrals estimated in the last +[arg d]+1 divisions. The integrals are considered to be a +function of the square of the width of the subintervals +(any good numerical analysis text will discuss this process +under "Romberg integration"). The polynomial is extrapolated +to a step size of zero, computing a value for the integral and +an estimate of the error. + +[para] + +This process will be well-behaved only if the function is analytic +over the region of integration; there may be removable singularities +at either end of the region provided that the limit of the function +(and of all its derivatives) exists as the ends are approached. +Thus, [cmd romberg] may be used to integrate a function like +f(x)=sin(x)/x over an interval beginning or ending at zero. + +[para] + +Note that [cmd romberg] will either fail to converge or else return +incorrect error estimates if the function, or any of its derivatives, +has a singularity anywhere in the region of integration (except for +the case mentioned above). Care must be used, therefore, in +integrating a function like 1/(1-x**2) to avoid the places +where the derivative is singular. + +[section "IMPROPER INTEGRALS"] + +Romberg integration is also useful for integrating functions over +half-infinite intervals or functions that have singularities. +The trick is to make a change of variable to eliminate the +singularity, and to put the singularity at one end or the other +of the region of integration. The [cmd math::calculus] package +supplies a number of [cmd romberg] procedures to deal with the +commoner cases. + +[list_begin definitions] + +[def [cmd romberg_infinity]] + +Integrates a function over a half-infinite interval; either +[arg a] or [arg b] may be infinite. [arg a] and [arg b] must be +of the same sign; if you need to integrate across the axis, +say, from a negative value to positive infinity, +use [cmd romberg] to integrate from the negative +value to a small positive value, and then [cmd romberg_infinity] +to integrate from the positive value to positive infinity. The +[cmd romberg_infinity] procedure works by making the change of +variable u=1/x, so that the integral from a to b of f(x) is +evaluated as the integral from 1/a to 1/b of f(1/u)/u**2. + +[def "[cmd romberg_powerLawLower] and [cmd romberg_powerLawUpper]"] + +Integrate a function that has an integrable power law singularity +at either the lower or upper bound of the region of integration +(or has a derivative with a power law singularity there). +These procedures take a first parameter, [arg gamma], which gives +the power law. The function or its first derivative are presumed to diverge as +(x-[arg a])**(-[arg gamma]) or ([arg b]-x)**(-[arg gamma]). [arg gamma] +must be greater than zero and less than 1. + +[para] + +These procedures are useful not only in integrating functions +that go to infinity at one end of the region of integration, but +also functions whose derivatives do not exist at the end of +the region. For instance, integrating f(x)=pow(x,0.25) with the +origin as one end of the region will result in the [cmd romberg] +procedure greatly underestimating the error in the integral. +The problem can be fixed by observing that the first derivative +of f(x), f'(x)=x**(-3/4)/4, goes to infinity at the origin. Integrating +using [cmd romberg_powerLawLower] with [arg gamma] set to 0.75 +gives much more orderly convergence. + +[para] + +These procedures operate by making the change of variable +u=(x-a)**(1-gamma) ([cmd romberg_powerLawLower]) or +u=(b-x)**(1-gamma) ([cmd romberg_powerLawUpper]). + +[para] + +To summarize the meaning of gamma: + +[list_begin itemized] +[item] +If f(x) ~ x**(-a) (0 < a < 1), use gamma = a +[item] +If f'(x) ~ x**(-b) (0 < b < 1), use gamma = b +[list_end] + +[def "[cmd romberg_sqrtSingLower] and [cmd romberg_sqrtSingUpper]"] + +These procedures behave identically to [cmd romberg_powerLawLower] and +[cmd romberg_powerLawUpper] for the common case of [arg gamma]=0.5; +that is, they integrate a function with an inverse square root +singularity at one end of the interval. They have a simpler +implementation involving square roots rather than arbitrary powers. + +[def "[cmd romberg_expLower] and [cmd romberg_expUpper]"] + +These procedures are for integrating a function that grows or +decreases exponentially over a half-infinite interval. +[cmd romberg_expLower] handles exponentially growing functions, and +allows the lower limit of integration to be an arbitrarily large +negative number. [cmd romberg_expUpper] handles exponentially +decaying functions and allows the upper limit of integration to +be an arbitrary large positive number. The functions make the +change of variable u=exp(-x) and u=exp(x) respectively. + +[list_end] + +[section "OTHER CHANGES OF VARIABLE"] + +If you need an improper integral other than the ones listed here, +a change of variable can be written in very few lines of Tcl. +Because the Tcl coding that does it is somewhat arcane, +we offer a worked example here. + +[para] + +Let's say that the function that we want to integrate is +f(x)=exp(x)/sqrt(1-x*x) (not a very natural +function, but a good example), and we want to integrate +it over the interval (-1,1). The denominator falls to zero +at both ends of the interval. We wish to make a change of variable +from x to u +so that dx/sqrt(1-x**2) maps to du. Choosing x=sin(u), we can +find that dx=cos(u)*du, and sqrt(1-x**2)=cos(u). The integral +from a to b of f(x) is the integral from asin(a) to asin(b) +of f(sin(u))*cos(u). + +[para] + +We can make a function [cmd g] that accepts an arbitrary function +[cmd f] and the parameter u, and computes this new integrand. + +[example { +proc g { f u } { + set x [expr { sin($u) }] + set cmd $f; lappend cmd $x; set y [eval $cmd] + return [expr { $y / cos($u) }] +} +}] + +Now integrating [cmd f] from [arg a] to [arg b] is the same +as integrating [cmd g] from [arg asin(a)] to [arg asin(b)]. +It's a little tricky to get [cmd f] consistently evaluated in +the caller's scope; the following procedure does it. + +[example { +proc romberg_sine { f a b args } { + set f [lreplace $f 0 0\ + [uplevel 1 [list namespace which [lindex $f 0]]]] + set f [list g $f] + return [eval [linsert $args 0\ + romberg $f\ + [expr { asin($a) }] [expr { asin($b) }]]] +} +}] + +This [cmd romberg_sine] procedure will do any function with +sqrt(1-x*x) in the denominator. Our sample function is +f(x)=exp(x)/sqrt(1-x*x): + +[example { +proc f { x } { + expr { exp($x) / sqrt( 1. - $x*$x ) } +} +}] + +Integrating it is a matter of applying [cmd romberg_sine] +as we would any of the other [cmd romberg] procedures: + +[example { +foreach { value error } [romberg_sine f -1.0 1.0] break +puts [format "integral is %.6g +/- %.6g" $value $error] + +integral is 3.97746 +/- 2.3557e-010 +}] + +[vset CATEGORY {math :: calculus}] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/vendor/math/rootfind.tcl b/vendor/math/rootfind.tcl new file mode 100644 index 00000000..5804fb0c --- /dev/null +++ b/vendor/math/rootfind.tcl @@ -0,0 +1,343 @@ +# rootfind.tcl -- +# Root-finding procedures: +# - Bisection +# - Secant +# - Brent +# - Chandrupatla +# +# TODO: f(root), number of steps, converged or not +# +# TOMS748? Seems quite complicated +# Brent in stead of secant - more robust, Chandrupatla is supposed to be faster +# + +namespace eval ::math::calculus {} + +# root_bisection -- +# Find a root of a function of one variable via bisection +# +# Arguments: +# f Procedure implementing the function +# a Left point of the interval +# b Right point of the interval +# tol Tolerance (optional) +# +# Returns: +# The approximation of the root +# +# Note: +# The interval [a,b] must enclose an odd number of roots, +# that is: f(a)*f(b) < 0 +# +proc ::math::calculus::root_bisection {f a b {tol 1.0e-7}} { + + if { $tol <= 0.0 } { + return -code error "The tolerance must be a small positive value" + } + + set fa [$f $a] + set fb [$f $b] + + if { ($fa < 0.0 && $fb < 0.0) || ($fa > 0.0 && $fb > 0.0) } { + return -code error "The given interval does not enclose an odd number of roots: f($a) = $fa, f($b) = $fb" + } + + set steps 0 + + set reduction [expr {min( 2.0e16, abs($b-$a)/$tol )}] + set maxsteps [expr {int( log($reduction)/log(2.0) )}] ;# Maximum number of halvings that makes sense + + while { $steps < $maxsteps } { + incr steps + + set c [expr {($a + $b)/ 2.0}] + set fc [$f $c] + + if { ($fc <= 0.0 && $fa <= 0.0) || ($fc >= 0.0 && $fa >= 0.0) } { + set a $c + set fa $fc + } else { + set b $c + set fb $fc + } + + # Special case ... + if { $fc == 0.0 } { + return $c + } + } + + return $c +} + +# root_secant -- +# Find a root of a function of one variable via the secant method +# +# Arguments: +# f Procedure implementing the function +# a Left point of the interval +# b Right point of the interval +# tol Tolerance (optional) +# +# Returns: +# The approximation of the root +# +# Note: +# The method is not guranteed to converge, but if it does, it does so +# quicker than linear. The maximum number of steps is derived from the +# idea that the interval will be roughly halved in length. +# +proc ::math::calculus::root_secant {f a b {tol 1.0e-7}} { + + if { $tol <= 0.0 } { + return -code error "The tolerance must be a small positive value" + } + + set fa [$f $a] + set fb [$f $b] + + if { ($fa < 0.0 && $fb < 0.0) || ($fa > 0.0 && $fb > 0.0) } { + return -code error "The given interval does not enclose an odd number of roots: f($a) = $fa, f($b) = $fb" + } + + set steps 0 + + set reduction [expr {min( 2.0e16, abs($b-$a)/$tol )}] + set maxsteps [expr {int( log($reduction)/log(2.0) )}] ;# Maximum number of halvings that makes sense + + + while { $steps < $maxsteps } { + incr steps + + set c [expr {($a * $fb - $b * $fa) / double($fb - $fa)}] + set fc [$f $c] + + if { abs($c - $b) <= $tol } { + break + } + + set a $b + set fa $fb + set b $c + set fb $fc + } + + return $c +} + +# root_chandrupatla -- +# Find a root of a function of one variable via the method by Chandrupatla (variation on Brent's method) +# +# Arguments: +# f Procedure implementing the function +# x0 Left point of the interval +# x1 Right point of the interval +# tol Tolerance (optional) +# +# Returns: +# The approximation of the root +# +# Note: +# The method brackets a root, like the bisection method. +# +# Adopted from www.embeddedrelated.com/showarticle/855.php +# +proc ::math::calculus::root_chandrupatla {f x0 x1 {tol 1.0e-7}} { + + if { $tol <= 0.0 } { + return -code error "The tolerance must be a small positive value" + } + + set b $x0 + set a $x1 + set c $x1 + + set fa [$f $a] + set fb [$f $b] + set fc $fa + + if { ($fa < 0.0 && $fb < 0.0) || ($fa > 0.0 && $fb > 0.0) } { + return -code error "The given interval does not enclose an odd number of roots: f($a) = $fa, f($b) = $fb" + } + + set steps 0 + + set t 0.5 + + set eps_m $tol + set eps_a [expr {2.0 * $tol}] ;# TODO + + while { 1 } { + incr steps + + # + # Get a new estimate of the root via interpolation + # + set xt [expr {$a + $t * ($b - $a)}] + set ft [$f $xt] + + # + # Update the three points we keep track of + # + if { ($ft < 0.0 && $fa < 0.0) || ($ft > 0.0 && $fa > 0.0) } { + set c $a + set fc $fa + } else { + set c $b + set fc $fb + set b $a + set fb $fa + } + + set a $xt + set fa $ft + + # + # Determine the point with the smallest function value + # + if { abs($fa) < abs($fb) } { + set xm $a + set fm $fa + } else { + set xm $b + set fm $fb + } + + if { $fm == 0.0 } { + return $xm + } + + # + # Critical values xi and phi (decisions on how to proceed) + # + set phtol [expr {2.0*$eps_m * abs($xm) + $eps_a}] + set tlim [expr {$phtol / abs($b-$c)}] + + if { $tlim > 0.5 } { + return $xm + } + + set xi [expr {($a - $b) / ($c - $b)}] + set phi [expr {($fa - $fb) / ($fc - $fb)}] + set do_iqi [expr {$phi**2 < $xi && (1.0 - $phi)**2 < 1.0 - $xi}] + + if { $do_iqi } { + # + # Inverse quadratic interpolation + # + set t [expr {$fa / ($fb-$fa) * $fc / ($fb-$fc) + + ($c-$a) / ($b-$a) * $fa / ($fc-$a) * $fb / ($fc-$fb)}] + } else { + # + # Bisection + # + set t 0.5 + } + + # + # Limit t between (tlim,1-tlim) + # + set t [expr {min( 1.0 -$tlim, max($tlim, $t) )}] + } +} + +# root_brent -- +# Find a root of a function of one variable via Brent's method +# +# Arguments: +# f Procedure implementing the function +# x0 Left point of the interval +# x1 Right point of the interval +# tol Tolerance (optional) +# +# Returns: +# The approximation of the root +# +# Note: +# The method brackets a root, like the bisection method but combines it with the secant method and +# inverse quadratic interpolation. +# +# Adopted from Wikipedia +# +proc ::math::calculus::root_brent {f x0 x1 {tol 1.0e-7}} { + + if { $tol <= 0.0 } { + return -code error "The tolerance must be a small positive value" + } + + set b $x0 + set a $x1 + set c $x1 + + # + # Minimal distance between points at which to calculate the function + # + set delta [expr {1.0e-8 * (abs($x0) + abs($x1)) + $tol/3.0}] + + set fa [$f $a] + set fb [$f $b] + + if { ($fa < 0.0 && $fb < 0.0) || ($fa > 0.0 && $fb > 0.0) } { + return -code error "The given interval does not enclose an odd number of roots: f($a) = $fa, f($b) = $fb" + } + + if { abs($fa) < abs($fb) } { + set tmp $a ; set tmpf $fa + set a $b ; set fa $fb + set b $tmp ; set fb $tmpf + } + + set c $a + set fc $fa + + set flag 1 + set d 0.0 ;# Dummy for the first iteration step + + set s $b ;# Make sure s is defined + set fs $fb + + #set step 0 + + while { abs($b - $a) > $tol && $fb != 0.0 && $fs != 0.0 } { + #incr step + if { $fa != $fc && $fb != $fc } { + set s [expr { $a * $fb * $fc / (($fa-$fb)*($fa-$fc)) + + $b * $fa * $fc / (($fb-$fa)*($fb-$fc)) + + $c * $fa * $fb / (($fc-$fa)*($fc-$fb)) }] + } else { + set s [expr {$b - $fb * ($b-$a) / ($fb -$fa)}] + } + + # Check the conditions for the next step + if { ( ((3.0*$a+$b) / 4.0 - $s) * ($s - $b) < 0.0 ) || + ( $flag && abs($s-$b) >= abs($b-$c)/2.0 ) || + ( !$flag && abs($s-$b) >= abs($c-$d)/2.0 ) || + ( $flag && abs($b-$c) < abs($delta) ) || + ( !$flag && abs($c-$d) < abs($delta) ) } { + set s [expr {($a + $b) / 2.0}] + set flag 1 + } else { + set flag 0 + } + + set fs [$f $s] + set d $c + set c $b + + if { $fa * $fs < 0.0 } { + set b $s + set fb $fs + } else { + set a $s + set fa $fs + } + + if { abs($a) < abs($fb) } { + set tmp $a ; set tmpf $fa + set a $b ; set fa $fb + set b $tmp ; set fb $tmpf + } + } + + return $s +} diff --git a/vendor/math/special.man b/vendor/math/special.man new file mode 100644 index 00000000..b1d21d6c --- /dev/null +++ b/vendor/math/special.man @@ -0,0 +1,531 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin math::special n 0.4] +[keywords {Bessel functions}] +[keywords {error function}] +[keywords math] +[keywords {special functions}] +[copyright {2004 Arjen Markus }] +[moddesc {Tcl Math Library}] +[titledesc {Special mathematical functions}] +[category Mathematics] +[require Tcl [opt 8.5]] +[require math::special [opt 0.5]] + +[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, ... | | + | incBeta | | a, b > 0 | < 1.0e-9 + | regIncBeta | | a, b > 0 | < 1.0e-9 + | digamma | 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 incomplete gamma function +[list_end] + +[section "PROCEDURES"] + +The package defines the following public procedures: + +[list_begin definitions] + +[call [cmd ::math::special::eulerNumber] [arg index]] + +Return the index'th Euler number (note: these are integer values). As the +size of these numbers grows very fast, only a limited number are available. + +[list_begin arguments] +[arg_def int index] Index of the number to be returned (should be between 0 and 54) +[list_end] + +[para] + +[call [cmd ::math::special::bernoulliNumber] [arg index]] + +Return the index'th Bernoulli number. As the size of the numbers grows very fast, +only a limited number are available. + +[list_begin arguments] +[arg_def int index] Index of the number to be returned (should be between 0 and 52) +[list_end] + +[para] + +[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::incBeta] [arg a] [arg b] [arg x]] + +Compute the incomplete Beta function for argument "x" with parameters "a" and "b" + +[list_begin arguments] +[arg_def float a] First parameter for the incomplete Beta function, a > 0 +[arg_def float b] Second parameter for the incomplete Beta function, b > 0 +[arg_def float x] Argument for the incomplete Beta function +[list_end] + +[para] + +[call [cmd ::math::special::regIncBeta] [arg a] [arg b] [arg x]] + +Compute the regularized incomplete Beta function for argument "x" with parameters "a" and "b" + +[list_begin arguments] +[arg_def float a] First parameter for the incomplete Beta function, a > 0 +[arg_def float b] Second parameter for the incomplete Beta function, b > 0 +[arg_def float x] Argument for the regularized incomplete 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::digamma] [arg x]] + +Compute the digamma function (psi) for argument "x" + +[list_begin arguments] +[arg_def float x] Argument for the digamma 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 ../common-text/feedback.inc] +[manpage_end] diff --git a/vendor/math/special.tcl b/vendor/math/special.tcl new file mode 100644 index 00000000..34bd0ceb --- /dev/null +++ b/vendor/math/special.tcl @@ -0,0 +1,463 @@ +# 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}] + variable tiny 1.0e-30 + + # + # 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 + namespace export incBeta regIncBeta digamma eulerNumber bernoulliNumber +} + +# 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 +} + + +# incBeta -- +# Incomplete Beta funtion (not regularized) +# +# Arguments: +# a, b Parameters a and b (both > 0) +# x Value of the x argument (between 0 and 1) +# +# Notes: +# Implementation taken from http://codeplea.com/incomplete-beta-function-in-c +# Accuracy: at least 1.0e-8 +# Test values: https://keisan.casio.com/exec/system/1180573396 +# +proc ::math::special::incBeta {a b x} { + variable tiny + + if { $x < 0.0 || $x > 1.0 } { + return -code error "Incomplete Beta function: x out of bounds (must be between 0 and 1)" + } + if { $a <= 0.0 || $b <= 0.0 } { + return -code error "Incomplete Beta function: parameter a or b out of bounds (both must be > 0)" + } + + # + # Make sure the continued fraction converges fast + # + if { $x > ($a+1.0) / ($a+$b+2.0) } { + set beta1 [Beta $a $b] + set complement [incBeta $b $a [expr {1.-$x}]] + return [expr {$beta1 - $complement}] + } + + set f 1.0 + set c 1.0 + set d 0.0 + + for { set i 0 } { $i <= 200 } { incr i } { + + set m [expr {$i/2}] + + # + # Coefficients of the continued fraction + # + if { $i == 0 } { + set numerator 1.0 + } elseif { $i % 2 == 0 } { + set numerator [expr {$m * ($b-$m) * $x / ( ($a+2.0*$m-1.0) * ($a+2.0*$m) )}] + } else { + set numerator [expr {-($a+$m) * ($a+$b+$m) * $x / ( ($a+2.0*$m) * ($a+2.0*$m+1.0) )}] + } + + # + # Iteration (Lentz's algorithm) + # + set d [expr {1.0 + $numerator * $d}] + if { abs($d) < $tiny } { + set d $tiny + } + + set d [expr {1.0 / $d}] + set c [expr {1.0 + $numerator / $c}] + + if { abs($c) < $tiny } { + set c $tiny + } + + set cd [expr {$c * $d}] + + set f [expr {$cd * $f}] + + # + # Stopping criterium + # + if { abs(1.0 - $cd) < 1.0e-8 } { + set factor [expr {$x ** $a * (1.0-$x) ** $b / $a}] + return [expr {$factor * ($f - 1.0)}] + } + } + + return -code error "Incomplete Beta function: convergence not reached" +} + +# regIncBeta -- +# Regularized incomplete Beta funtion +# +# Arguments: +# a, b Parameters a and b (both > -1) +# x Value of the x argument (between 0 and 1) +# +proc ::math::special::regIncBeta {a b x} { + + set incbeta [incBeta $a $b $x] + set factor [Beta $a $b] + + return [expr {$incbeta / $factor}] +} + + +# digamma -- +# Evaluate the digamma function - approximate via a power series +# +# Arguments +# x Argument of the function +# +# Result: +# Value of digamma function at x +# +# Notes; +# Test values: https://keisan.casio.com/exec/system/1180573446 +# Formula taken from: https://math.stackexchange.com/questions/1441753/approximating-the-digamma-function +# +proc ::math::special::digamma {x} { + if { $x >= 10.0 } { + set x [expr {$x - 1.0}] + return [expr {log($x) + 1.0 / (2.0 * $x) - 1.0 / (12.0 * $x**2) + 1.0 / (120.0 * $x**4) - 1.0 / (252.0 * $x**6) + + 1.0 / (240.0 * $x**8) - 5.0 / (660.0 * $x**10) + 691.0 / (32760.0 * $x**12) - 1.0 / (12.0 * $x**14)}] + } else { + set n [expr {int(11.0 - $x)}] + set correction 0.0 + for {set i 0} {$i < $n} {incr i} { + set correction [expr {$correction + 1.0 / ($x + $i)}] + } + + set newx [expr {$x + $n}] + + return [expr {[digamma $newx] - $correction}] + } +} + +# eulerNumber and bernoulliNumber -- +# Return the nth Euler number or Bernoulli number +# +# Arguments: +# index The index of the number to be returned +# +# Note: +# If the index is outside the range, then an error is raised: +# For Euler numbers: index should be between 0 and 54 +# For Bernoulli numbers: index should be between 0 and 52 +# - even though for odd indices the numbers are mostly zero +# and could be returned as such +# +# Note: +# The tables were found in Nelson H.F. Beebe - The Mathematical Function Computation Handbook +# +proc ::math::special::eulerNumber {index} { + if { $index < 0 || $index > 54 } { + return -code error "Index ($index) out of range - should be between 0 and 54" + } else { + return [lindex {1 0 -1 0 5 0 -61 0 1385 0 -50521 0 2702765 0 -199360981 0 19391512145 0 -2404879675441 0 370371188237525 0 -69348874393137901 0 15514534163557086905 0 -4087072509293123892361 0 1252259641403629865468285 0 -441543893249023104553682821 0 177519391579539289436664789665 0 -80723299235887898062168247453281 0 41222060339517702122347079671259045 0 -23489580527043108252017828576198947741 0 14851150718114980017877156781405826684425 0 -10364622733519612119397957304745185976310201 0 7947579422597592703608040510088070619519273805 0 -6667537516685544977435028474773748197524107684661 0 6096278645568542158691685742876843153976539044435185 0 -6053285248188621896314383785111649088103498225146815121 0 6506162486684608847715870634080822983483644236765385576565 0 -7546659939008739098061432565889736744212240024711699858645581} $index] + } +} +proc ::math::special::bernoulliNumber {index} { + if { $index < 0 || $index > 52 } { + return -code error "Index ($index) out of range - should be between 0 and 52" + } else { + return [lindex {1.0 -0.5 0.16666666666666666 0.0 -0.03333333333333333 0.0 0.023809523809523808 0.0 -0.03333333333333333 0.0 0.07575757575757576 0.0 -0.2531135531135531 0.0 1.1666666666666667 0.0 -7.092156862745098 0.0 54.971177944862156 0.0 -529.1242424242424 0.0 6192.123188405797 0.0 -86580.25311355312 0.0 1425517.1666666667 0.0 -27298231.067816094 0.0 601580873.9006424 0.0 -15116315767.092157 0.0 429614643061.1667 0.0 -13711655205088.334 0.0 488332318973593.2 0.0 -19296579341940068.0 0.0 8.416930475736827e+17 0.0 -4.0338071854059454e+19 0.0 2.1150748638081993e+21 0.0 -1.2086626522296526e+23 0.0 7.500866746076964e+24 0.0 -5.038778101481068e+26} $index] + } +} + +# 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.5.2 diff --git a/vendor/math/special.test b/vendor/math/special.test new file mode 100644 index 00000000..74814be8 --- /dev/null +++ b/vendor/math/special.test @@ -0,0 +1,239 @@ +# -*- 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.5;# 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 +} + +# +# Expect an accuracy of eight decimals (incomplete Beta and digamma) +# +proc matchAccurate {expected actual} { + set match 1 + foreach a $actual e $expected { + if {abs($a-$e) > 1.0e-8} { + set match 0 + break + } + } + return $match +} + + +customMatch numbers matchNumbers +customMatch numbers-fresnel matchFresnel +customMatch numbers-accurate matchAccurate + +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 + + +test "digamma-1.0" "Values of the digamma function" \ + -match numbers-accurate -body { + set result {} + foreach x {-2.5 -1.5 -0.5 0.1 0.25 0.5 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 10.0 11.0 15.0 20 30.0} { + lappend result [::math::special::digamma $x] + } + set result +} -result {1.103156640645243187226 0.7031566406452431872257 0.03648997397857652055902 -10.42375494041107679517 -4.22745353337626540809 -1.963510026021423479441 + -0.5772156649015328606065 0.4227843351 0.9227843351 1.256117668 1.506117668431800472727 1.706117668431800472727 1.872784335098467139394 + 2.015641477955609996536 2.140641477955609996536 2.251752589066721107647 2.351752589066721107647 2.67434666166079370172 2.970523992242149050877 + 3.384438132685524876562} + + +test "incBeta-1.0" "Values of the incomplete Beta function (a,b = 0.5,3)" \ + -match numbers-accurate -body { + set result {} + set a 0.5 + set b 3.0 + foreach x {0.0 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 1.0} { + lappend result [::math::special::incBeta $a $b $x] + } + set result +} -result {0 0.591556741 0.782325650 0.896074104 0.968078601 1.01351972 1.04105792 1.05642273 1.06377207 1.06632003 1.06666667} + +test "incBeta-1.1" "Values of the incomplete Beta function (a,b = 2.0,1.3)" \ + -match numbers-accurate -body { + set result {} + set a 2.0 + set b 1.3 + foreach x {0.0 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 1.0} { + lappend result [::math::special::incBeta $a $b $x] + } + set result +} -result {0 0.00489724885 0.0191537005 0.0420524051 0.0727690680 0.110331697 0.153553061 0.200905566 0.250250898 0.298074371 0.334448161} + +test "incBeta-2.0" "Values of the regularized incomplete Beta function (a,b = 0.5,3)" \ + -match numbers-accurate -body { + set result {} + set a 0.5 + set b 3.0 + foreach x {0.0 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 1.0} { + lappend result [::math::special::regIncBeta $a $b $x] + } + set result +} -result {0 0.554584445 0.733430297 0.840069473 0.907573688 0.950174737 0.975991803 0.990396306 0.997286318 0.999675025 1} + +test "incBeta-2.1" "Values of the regularized incomplete Beta function (a,b = 2.0,1.3)" \ + -match numbers-accurate -body { + set result {} + set a 2.0 + set b 1.3 + foreach x {0.0 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 1.0} { + lappend result [::math::special::regIncBeta $a $b $x] + } + set result +} -result {0 0.0146427741 0.0572695646 0.125736691 0.217579513 0.329891773 0.459123651 0.600707642 0.748250184 0.891242370 1} + + +# +# Euler and Bernoulli numbers - as they come from tables, merely check that the procedures work +# +test "eulerBernoulli-1.0" "Euler number within range" -body { + set result {} + foreach index {0 1 2 3 4} { + lappend result [::math::special::eulerNumber $index] + } + set result +} -result {1 0 -1 0 5} + +test "eulerBernoulli-1.1" "Euler number out of range" -body { + ::math::special::eulerNumber -10 + return {} +} -returnCodes {error} -result {Index (-10) out of range - should be between 0 and 54} + +test "eulerBernoulli-2.0" "Bernoulli number within range" -match numbers-accurate -body { + set result {} + foreach index {0 1 2 3 4} { + # Multiply by 30 to get integer values + lappend result [expr { 30.0 * [::math::special::bernoulliNumber $index] }] + } + set result +} -result {30.0 -15.0 5.0 0.0 -1.0} + +test "eulerBernoulli-1.0" "Bernoulli number out of range" -body { + ::math::special::bernoulliNumber -10 +} -returnCodes {error} -result {Index (-10) out of range - should be between 0 and 52} + +# End of test cases +testsuiteCleanup diff --git a/vendor/math/stat_kernel.tcl b/vendor/math/stat_kernel.tcl new file mode 100644 index 00000000..1d1f219b --- /dev/null +++ b/vendor/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/vendor/math/stat_logit.tcl b/vendor/math/stat_logit.tcl new file mode 100644 index 00000000..30846141 --- /dev/null +++ b/vendor/math/stat_logit.tcl @@ -0,0 +1,120 @@ +# stat_logit.tcl -- +# Logistic regression functions - part of the statistics package +# +# Note: +# The implementation was derived from the Wikipedia page on logistic regression, +# (https://en.wikipedia.org/wiki/Logistic_regression) as is the test case. +# +# TODO: +# - Deviance to evaluate the goodness of fit +# - Evaluate the probability +# + +package require math::optimize + +namespace eval ::math::statistics { + variable xLogit {} + variable yLogit {} +} + +# logistic-model -- +# Fit 1/0 data to a logistic model +# +# Arguments: +# xdata Independent variables (list of lists if there are more than one) +# ydata Corresponding scores (0 or 1) +# +# Result: +# Estimate of the parameters for a logistic model +# +# Note: +# It is expected that the independent variables have roughly the same scale +# +proc ::math::statistics::logistic-model {xdata ydata} { + variable xLogit + variable yLogit + + set xLogit {} + foreach coords $xdata { + lappend xLogit [concat 1.0 $coords] + } + set yLogit $ydata + + # + # Use a trivial starting point + # + set startx [lrepeat [llength [lindex $xLogit 0]] 0.0] + + set result [::math::optimize::nelderMead LogisticML_NM $startx] + + return [dict get $result x] +} + + +# LogisticML_NM -- +# Calculate the (log) maximum likelihood for the given logistic model +# using Nelder-Mead +# +# Arguments: +# args Vector of the current regression coefficients +# +# Returns: +# Log maximum likelihood +# +proc ::math::statistics::LogisticML_NM {args} { + variable xLogit + variable yLogit + + set loglike 0.0 + foreach coords $xLogit score $yLogit { + set sum 0.0 + + foreach c $coords v $args { + set sum [expr {$sum + $v * $c}] + } + set exp [expr {exp(-$sum)}] + + if { $score == 1 } { + set loglike [expr {$loglike - log(1.0 + $exp)}] + } else { + set loglike [expr {$loglike - $sum - log(1.0 + $exp)}] + } + } + return [expr {-$loglike}] +} + +# logistic-probability -- +# Calculate the probability of a positive score (1) given the model +# +# Arguments: +# coeffs Coefficients of the logistic model (for instance outcome of model fit) +# values Values of the independent variables +# +# Returns: +# Probability +# +proc ::math::statistics::logistic-probability {coeffs values} { + set sum 0.0 + + foreach c $coeffs v [concat 1.0 $values] { + set sum [expr {$sum + $c * $v}] + } + + return [expr {1.0 / (1.0 + exp(-$sum))}] +} + +# test case: from Wikipedia +if {0} { +set xdata {0.50 0.75 1.00 1.25 1.50 1.75 1.75 2.00 2.25 2.50 2.75 3.00 3.25 3.50 4.00 4.25 4.50 4.75 5.00 5.50} +set ydata {0 0 0 0 0 0 1 0 1 0 1 0 1 0 1 1 1 1 1 1 } + +set coeffs [::math::statistics::logistic-model $xdata $ydata] + +puts "Model fit: $coeffs" + +puts "Probabilities:" + +foreach x {1 2 3 4 5} { + puts "$x - [::math::statistics::logistic-probability $coeffs $x]" +} +} diff --git a/vendor/math/stat_wasserstein.tcl b/vendor/math/stat_wasserstein.tcl new file mode 100644 index 00000000..6c3bb08f --- /dev/null +++ b/vendor/math/stat_wasserstein.tcl @@ -0,0 +1,214 @@ +# stat-wasserstein.tcl -- +# Determine the Wasserstein distance between two probability distributions +# +# Note: +# This is an implementation for one-dimensional distributions (or better: +# non-negative patterns) +# +# Note 2: +# The lower bound of 1.0e-10 is probably not at all necessary +# + +# LastNonZero -- +# Auxiliary procedure to find the last non-zero entry +# +# Arguments: +# prob Probability distribution +# +# Result: +# Index in the list of the last non-zero entry +# +# Note: +# To avoid numerical problems any value smaller than 1.0e-10 is considered to +# be zero +# +proc ::math::statistics::LastNonZero {prob} { + set maxidx [expr {[llength $prob] - 1}] + + for {set idx $maxidx} {$idx >= 0} {incr idx -1} { + if { [lindex $prob $idx] > 1.0e-10 } { + return $idx + } + } + + return -1 ;# No non-zero entry +} + +# Normalise -- +# Auxiliary procedure to normalise the probability distribution +# +# Arguments: +# prob Probability distribution +# +# Result: +# Normalised distribution (i.e. the entries sum to 1) +# +# Note: +# To avoid numerical problems any value smaller than 1.0e-10 is set to zero +# +proc ::math::statistics::Normalise {prob} { + + set newprob {} + set sum 0.0 + + foreach p $prob { + set sum [expr {$sum + $p}] + } + + if { $sum == 0.0 } { + return -code error "Probability distribution should not consist of only zeroes" + } + + foreach p $prob { + lappend newprob [expr {$p > 1.0e-10? ($p/$sum) : 0.0}] + } + + return $newprob +} + +# wasserstein-distance -- +# Determine the Wasserstein distance using a "greedy" algorithm. +# +# Arguments: +# prob1 First probability distribution, interpreted as a histogram +# with uniform bin width +# prob2 Second probability distribution +# +# Result: +# Distance between the two distributions +# +proc ::math::statistics::wasserstein-distance {prob1 prob2} { + # + # First step: make sure the histograms have the same length and the + # same cumulative weight. + # + if { [llength $prob1] != [llength $prob2] } { + return -code error "Lengths of the probability histograms must be the same" + } + + set prob1 [Normalise $prob1] + set prob2 [Normalise $prob2] + + set distance 0.0 + + # + # Determine the last non-zero bin - this bin will be shifted to the second + # distribution + # + while {1} { + set idx1 [LastNonZero $prob1] + set idx2 [LastNonZero $prob2] + + if { $idx1 < 0 } { + break ;# We are done + } + + set bin1 [lindex $prob1 $idx1] + set bin2 [lindex $prob2 $idx2] + + if { $bin1 <= $bin2 } { + lset prob1 $idx1 0.0 + lset prob2 $idx2 [expr {$bin2 - $bin1}] + set distance [expr {$distance + abs($idx2-$idx1) * $bin1}] + } else { + lset prob1 $idx1 [expr {$bin1 - $bin2}] + lset prob2 $idx2 0.0 + set distance [expr {$distance + abs($idx2-$idx1) * $bin2}] + } + } + + return $distance +} + +# kl-divergence -- +# Calculate the Kullback-Leibler (KL) divergence for two discrete distributions +# +# Arguments: +# prob1 First probability distribution - the divergence is calculated +# with this one as the basis +# prob2 Second probability distribution - the divergence of this +# distribution wrt the first is calculated +# +# Notes: +# - The KL divergence is an asymmetric measure +# - It is actually only defined if prob2 is only zero when prob1 is too +# - The number of elements in the two distributions must be the same and +# bins must be the same +# +proc ::math::statistics::kl-divergence {prob1 prob2} { + if { [llength $prob1] != [llength $prob2] } { + return -code error "Lengths of the two probability histograms must be the same" + } + + # + # Normalise the probability histograms + # + set prob1 [Normalise $prob1] + set prob2 [Normalise $prob2] + + # + # Check for well-definedness while going along + # + set sum 0.0 + foreach p1 $prob1 p2 $prob2 { + if { $p2 == 0.0 && $p1 != 0.0 } { + return -code error "Second probability histogram contains unmatched zeroes" + } + + if { $p1 != 0.0 } { + set sum [expr {$sum - $p1 * log($p2/$p1)}] + } + } + + return $sum +} + +if {0} { +# tests -- +# + +# Almost trivial +set prob1 {0.0 0.0 0.0 1.0} +set prob2 {0.0 0.0 1.0 0.0} + +puts "Expected distance: 1" +puts "Calculated: [wasserstein-distance $prob1 $prob2]" +puts "Symmetric: [wasserstein-distance $prob2 $prob1]" + +# Less trivial +set prob1 {0.0 0.75 0.25 0.0} +set prob2 {0.0 0.0 1.0 0.0} + +puts "Expected distance: 0.75" +puts "Calculated: [wasserstein-distance $prob1 $prob2]" +puts "Symmetric: [wasserstein-distance $prob2 $prob1]" + +# Shift trivial +set prob1 {0.0 0.1 0.2 0.4 0.2 0.1 0.0 0.0} +set prob2 {0.0 0.0 0.0 0.1 0.2 0.4 0.2 0.1} + +puts "Expected distance: 2" +puts "Calculated: [wasserstein-distance $prob1 $prob2]" +puts "Symmetric: [wasserstein-distance $prob2 $prob1]" + + +# KL-divergence +set prob1 {0.0 0.1 0.2 0.4 0.2 0.1 0.0 0.0} +set prob2 {0.0 0.1 0.2 0.4 0.2 0.1 0.0 0.0} + +puts "KL-divergence for equal distributions: 0" +puts "KL-divergence: [kl-divergence $prob1 $prob2]" + +set prob1 {0.1e-8 0.1 0.2 0.4 0.2 0.1 0.0 0.0 0.0} +set prob2 {0.1e-8 0.1e-8 0.1 0.2 0.4 0.2 0.1 0.1e-8 0.1e-8} + +puts "KL-divergence for shifted distributions: ??" +puts "KL-divergence: [kl-divergence $prob1 $prob2]" + +# Hm, the normalisation proc causes a slight problem with elements of 1.0e-10 +set prob1 {0.1e-8 0.1 0.2 0.4 0.2 0.1 0.0 0.0} +set prob2 {0.1e-8 0.11 0.19 0.4 0.24 0.06 0.1e-8 0.1e-8} + +puts "KL-divergence slightly dififerent distributions: ??" +puts "KL-divergence: [kl-divergence $prob1 $prob2]" +} diff --git a/vendor/math/statistics.man b/vendor/math/statistics.man new file mode 100644 index 00000000..9f959662 --- /dev/null +++ b/vendor/math/statistics.man @@ -0,0 +1,1867 @@ +[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.5] +[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. + +[emph Note:] With version 1.0.1 a mistake in the procs [term pdf-lognormal], +[term cdf-lognormal] and [term random-lognormal] has been corrected. In +previous versions the argument for the standard deviation was actually +used as if it was the variance. + +[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. +[para] + +[call [cmd ::math::statistics::lillieforsFit] [arg data]] +Returns the goodness of fit to a normal distribution according to +Lilliefors. The higher the number, the more likely the data are indeed +normally distributed. The test requires at least [emph five] data +points. + +[list_begin arguments] +[arg_def list data] - List of raw data values +[list_end] +[para] + + +[call [cmd ::math::statistics::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::test-anova-F] [arg alpha] [arg args]] +Determine if two or more groups with normally distributed data have the same means. +The procedure returns 0 if the means are likely unequal, 1 if they are. This is +a one-way ANOVA test. The groups may also be stored in a nested list: + +The procedure returns a list of the comparison results for each pair of groups. Each +element of this list contains: the index of the first group and that of the second group, +whether the means are likely to be different (1) or not (0) and the confidence interval +the conclusion is based on. The groups may also be stored in a nested list: + +[example { + test-anova-F 0.05 $A $B $C + # + # Or equivalently: + # + test-anova-F 0.05 [list $A $B $C] +}] +[list_begin arguments] +[arg_def float alpha] - Significance level +[arg_def list args] - Two or more groups of data to be checked +[list_end] +[para] + +[call [cmd ::math::statistics::test-Tukey-range] [arg alpha] [arg args]] +Determine if two or more groups with normally distributed data have the same means, +using Tukey's range test. It is complementary to the ANOVA test. +The procedure returns a list of the comparison results for each pair of groups. Each +element of this list contains: the index of the first group and that of the second group, +whether the means are likely to be different (1) or not (0) and the confidence interval +the conclusion is based on. The groups may also be stored in a nested list, just as with +the ANOVA test. +[list_begin arguments] +[arg_def float alpha] - Significance level - either 0.05 or 0.01 +[arg_def list args] - Two or more groups of data to be checked +[list_end] +[para] + +[call [cmd ::math::statistics::test-Dunnett] [arg alpha] [arg control] [arg args]] +Determine if one or more groups with normally distributed data have the same means as +the group of control data, using Dunnett's test. It is complementary to the ANOVA test. +The procedure returns a list of the comparison results for each group with the control group. Each +element of this list contains: whether the means are likely to be different (1) or not (0) +and the confidence interval the conclusion is based on. The groups may also be stored in a +nested list, just as with the ANOVA test. +[para] +Note: some care is required if there is only one group to compare the control with: +[example { + test-Dunnett-F 0.05 $control [list $A] +}] +Otherwise the group A is split up into groups of one element - this is due to an ambiguity. + +[list_begin arguments] +[arg_def float alpha] - Significance level - either 0.05 or 0.01 +[arg_def list args] - One or more groups of data to be checked +[list_end] +[para] + +[call [cmd ::math::statistics::quantiles] [arg data] [arg confidence]] +Return the quantiles for a given set of data +[list_begin arguments] +[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::test-Levene] [arg groups]] +Compute the Levene statistic to determine if groups of data have the +same variance (are homoscadastic) or not. The data are organised +in groups. This version uses the mean of the data as the measure +to determine the deviations. The statistic is equivalent to an +F statistic with degrees of freedom k-1 and N-k, k being the +number of groups and N the total number of data. + +[list_begin arguments] +[arg_def list groups] - List of groups of data +[list_end] +[para] + +[call [cmd ::math::statistics::test-Brown-Forsythe] [arg groups]] +Compute the Brown-Forsythe statistic to determine if groups of data have the +same variance (are homoscadastic) or not. Like the Levene test, but this +version uses the median of the data. + +[list_begin arguments] +[arg_def list groups] - List of groups 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] + +[call [cmd ::math::statistics::bootstrap] [arg data] [arg sampleSize] [opt numberSamples]] +Create a subsample or subsamples from a given list of data. The data in the samples are chosen +from this list - multiples may occur. If there is only one subsample, the sample itself +is returned (as a list of "sampleSize" values), otherwise a list of samples is returned. + +[list_begin arguments] +[arg_def list data] List of values to chose from +[arg_def int sampleSize] Number of values per sample +[arg_def int numberSamples] Number of samples (default: 1) +[list_end] + +[call [cmd ::math::statistics::wasserstein-distance] [arg prob1] [arg prob2]] +Compute the Wasserstein distance or earth mover's distance for two equidstantly spaced histograms +or probability densities. The histograms need not to be normalised to sum to one, +but they must have the same number of entries. + +[para] Note: the histograms are assumed to be based on the same equidistant intervals. +As the bounds are not passed, the value is expressed in the length of the intervals. + +[list_begin arguments] +[arg_def list prob1] List of values for the first histogram/probability density +[arg_def list prob2] List of values for the second histogram/probability density +[list_end] + +[call [cmd ::math::statistics::kl-divergence] [arg prob1] [arg prob2]] +Compute the Kullback-Leibler (KL) divergence for two equidstantly spaced histograms +or probability densities. The histograms need not to be normalised to sum to one, +but they must have the same number of entries. + +[para] Note: the histograms are assumed to be based on the same equidistant intervals. +As the bounds are not passed, the value is expressed in the length of the intervals. + +[para] Note also that the KL divergence is not symmetric and that the second histogram +should not contain zeroes in places where the first histogram has non-zero values. + +[list_begin arguments] +[arg_def list prob1] List of values for the first histogram/probability density +[arg_def list prob2] List of values for the second histogram/probability density +[list_end] + +[call [cmd ::math::statistics::logistic-model] [arg xdata] [arg ydata]] +Estimate the coefficients of the logistic model that fits the data best. The data consist +of independent x-values and the outcome 0 or 1 for each of the x-values. The result +can be used to estimate the probability that a certain x-value gives 1. + +[list_begin arguments] +[arg_def list xdata] List of values for which the success (1) or failure (0) is known +[arg_def list ydata] List of successes or failures corresponding to each value in [term xdata]. +[list_end] + +[call [cmd ::math::statistics::logistic-probability] [arg coeffs] [arg x]] +Calculate the probability of success for the value [term x] given the coefficients of the +logistic model. + +[list_begin arguments] +[arg_def list coeffs] List of coefficients as determine by the [cmd logistic-model] command +[arg_def float x] X-value for which the probability needs to be determined +[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] +The F distribution (only the cumulative density function) +[item] +PM - binomial. +[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-triangular] [arg xmin] [arg xmax] [arg value]] +Return the probability of a given value for a triangular +distribution with given extremes. If the argument min is lower than the argument max, then smaller +values have higher probability and vice versa. In the first case the probability +density function is of the form [emph {f(x) = 2(1-x)}] and the other case it is of the form [emph {f(x) = 2x}]. + +[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-symmetric-triangular] [arg xmin] [arg xmax] [arg value]] +Return the probability of a given value for a symmetric triangular +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::pdf-laplace] [arg location] [arg scale] [arg value]] +Return the probability of a given value for a Laplace +distribution with given location and shape parameters. The Laplace distribution +consists of two exponential functions, is peaked and has heavier tails than the +normal distribution. + +[list_begin arguments] +[arg_def float location] - Location parameter (mean) +[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-kumaraswamy] [arg a] [arg b] [arg value]] +Return the probability of a given value for a Kumaraswamy +distribution with given parameters a and b. The Kumaraswamy distribution +is related to the Beta distribution, but has a tractable cumulative distribution function. + +[list_begin arguments] +[arg_def float a] - Parameter a +[arg_def float b] - Parameter b +[arg_def float value] - Value for which the probability is required +[list_end] +[para] + +[call [cmd ::math::statistics::pdf-negative-binomial] [arg r] [arg p] [arg value]] +Return the probability of a given value for a negative binomial +distribution with an allowed number of failures and the probability of success. + +[list_begin arguments] +[arg_def int r] - Allowed number of failures (at least 1) +[arg_def float p] - Probability of success +[arg_def int value] - Number of successes for which the probability is to be returned +[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-triangular] [arg xmin] [arg xmax] [arg value]] +Return the cumulative probability of a given value for a triangular +distribution with given extremes. If xmin < xmax, then lower values have +a higher probability and vice versa, see also [emph pdf-triangular] + +[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-symmetric-triangular] [arg xmin] [arg xmax] [arg value]] +Return the cumulative probability of a given value for a symmetric triangular +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::cdf-F] [arg nf1] [arg nf2] [arg value]] +Return the cumulative probability of a given value for an F +distribution with nf1 and nf2 degrees of freedom. + +[list_begin arguments] +[arg_def float nf1] - Degrees of freedom for the numerator +[arg_def float nf2] - Degrees of freedom for the denominator +[arg_def float value] - Value for which the probability is required +[list_end] +[para] + +[call [cmd ::math::statistics::cdf-laplace] [arg location] [arg scale] [arg value]] +Return the cumulative probability of a given value for a Laplace +distribution with given location and shape parameters. The Laplace distribution +consists of two exponential functions, is peaked and has heavier tails than the +normal distribution. + +[list_begin arguments] +[arg_def float location] - Location parameter (mean) +[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-kumaraswamy] [arg a] [arg b] [arg value]] +Return the cumulative probability of a given value for a Kumaraswamy +distribution with given parameters a and b. The Kumaraswamy distribution +is related to the Beta distribution, but has a tractable cumulative distribution function. + +[list_begin arguments] +[arg_def float a] - Parameter a +[arg_def float b] - Parameter b +[arg_def float value] - Value for which the probability is required +[list_end] +[para] + +[call [cmd ::math::statistics::cdf-negative-binomial] [arg r] [arg p] [arg value]] +Return the cumulative probability of a given value for a negative binomial +distribution with an allowed number of failures and the probability of success. + +[list_begin arguments] +[arg_def int r] - Allowed number of failures (at least 1) +[arg_def float p] - Probability of success +[arg_def int value] - Greatest number of successes +[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-triangular] [arg xmin] [arg xmax] [arg number]] +Return a list of "number" random values satisfying a triangular +distribution with given extremes. If xmin < xmax, then lower values have a higher probability +and vice versa (see also [emph pdf-triangular]. + +[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-symmetric-triangular] [arg xmin] [arg xmax] [arg number]] +Return a list of "number" random values satisfying a symmetric triangular +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::random-laplace] [arg location] [arg scale] [arg number]] +Return a list of "number" random values satisfying a Laplace +distribution with given location and shape parameters. The Laplace distribution +consists of two exponential functions, is peaked and has heavier tails than the +normal distribution. + +[list_begin arguments] +[arg_def float location] - Location parameter (mean) +[arg_def float scale] - Shape parameter +[arg_def int number] - Number of values to be returned +[list_end] +[para] + +[call [cmd ::math::statistics::random-kumaraswamy] [arg a] [arg b] [arg number]] +Return a list of "number" random values satisying a Kumaraswamy +distribution with given parameters a and b. The Kumaraswamy distribution +is related to the Beta distribution, but has a tractable cumulative distribution function. + +[list_begin arguments] +[arg_def float a] - Parameter a +[arg_def float b] - Parameter b +[arg_def int number] - Number of values to be returned +[list_end] +[para] + +[call [cmd ::math::statistics::random-negative-binomial] [arg r] [arg p] [arg number]] +Return a list of "number" random values satisying a negative binomial distribution. + +[list_begin arguments] +[arg_def int r] - Allowed number of failures (at least 1) +[arg_def float p] - Probability of success +[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] + +[call [cmd ::math::statistics::estimate-exponential] [arg values]] +Estimate the parameter for the exponential distribution that comes closest to the given values. +Returns an estimate of the one parameter and of the standard error. + +[list_begin arguments] +[arg_def list values] - List of values, assumed to be distributed according to an exponential distribution +[list_end] +[para] + +[call [cmd ::math::statistics::estimate-laplace] [arg values]] +Estimate the parameters for the Laplace distribution that comes closest to the given values. +Returns an estimate of respectively the location and scale parameters, based on maximum likelihood. + +[list_begin arguments] +[arg_def list values] - List of values, assumed to be distributed according to an exponential distribution +[list_end] +[para] + +[call [cmd ::math::statistics::estimante-negative-binomial] [arg r] [arg values]] +Estimate the probability of success for the negative binomial distribution that comes closest to the given values. +The allowed number of failures must be given. + +[list_begin arguments] +[arg_def int r] - Allowed number of failures (at least 1) +[arg_def int number] - List of values, assumed to be distributed according to a negative binomial 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[rb] + +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]}[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 ../common-text/feedback.inc] +[manpage_end] diff --git a/vendor/math/statistics.tcl b/vendor/math/statistics.tcl new file mode 100644 index 00000000..08775ae0 --- /dev/null +++ b/vendor/math/statistics.tcl @@ -0,0 +1,2037 @@ +# 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 +# version 1.0: added test-anova-F +# version 1.0.1: correction in pdf-lognormal and cdf-lognormal +# version 1.1: added test-Tukey-range and test-Dunnett +# version 1.3: added wasserstein-distance, kl-divergence and logit regression + +package require Tcl 8.5 ; # 8.5+ feature in test-anova-F and others: **-operator +package provide math::statistics 1.5.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 test-anova-F test-Tukey-range test-Dunnett + # + # Error messages + # + variable NEGSTDEV {Zero or negative standard deviation} + variable TOOFEWDATA {Too few or invalid data} + variable OUTOFRANGE {Argument out of range} + variable INVALID {Argument invalid} + + # + # 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" + } + } +} + +# test-anova-F -- +# Check if two or more groups with normally distributed data have the same +# means +# +# Arguments: +# alpha Significance level +# args One or more lists containing the data for the +# other groups +# +# Returns: +# Whether the mean for the groups is likely to be the same (1) +# or not (0). +# +# Note: +# args may be a nested list +# +# Implementation based on Wikipedia page on the F-test, one-way ANOVA +# +# Possibly of interest: the ratio itself. +# +proc ::math::statistics::test-anova-F {alpha args} { + if { [llength $args] == 1 } { + set args [lindex $args 0] + } + + if { [llength $args] < 2 } { + return -code error -errorcode ARG -errorinfo "At least two groups are required" \ + "At least two groups are required" + } + + # + # Determine the variance within the groups and the variance between the groups + # + set meanPerGroup {} + set varPerGroup {} + set allData {} + foreach group $args { + lappend meanPerGroup [::math::statistics::mean $group] + lappend varPerGroup [::math::statistics::pvar $group] + set allData [concat $allData $group] + } + set meanOverall [::math::statistics::mean $allData] + + set varBetween 0.0 + foreach group $args mean $meanPerGroup { + set varBetween [expr {$varBetween + [llength $group] * ($mean - $meanOverall)**2}] + } + set varBetween [expr {$varBetween / ([llength $args] - 1)}] + + set varWithin 0.0 + foreach group $args var $varPerGroup { + set varWithin [expr {$varWithin + [llength $group] * $var}] + } + set varWithin [expr {$varWithin / ([llength $allData] - [llength $args])}] + + # + # Finally compare the ratio to the F-distribution + # + set ratio [expr {$varBetween / $varWithin}] + set nf1 [expr {[llength $args] - 1}] + set nf2 [expr {[llength $allData] - [llength $args]}] + + expr {[::math::statistics::cdf-F $nf1 $nf2 $ratio] <= 1.0 - $alpha} +} + +# test-Tukey-range -- +# Check if two or more groups with normally distributed data have different +# means or not, using Tukey's range test +# +# Arguments: +# alpha Significance level +# args Two or more lists containing the data for the +# other groups +# +# Returns: +# For each pair of groups a list of: +# - group indices +# - whether the means differ (1) or not (0) +# - limits of the confidence interval (for closer investigation) +# +# Note: +# args may be a nested list +# +# Implementation based on Wikipedia page on Tukey's range test +# +proc ::math::statistics::test-Tukey-range {alpha args} { + if { [llength $args] == 1 } { + set args [lindex $args 0] + } + + if { [llength $args] < 2 } { + return -code error -errorcode ARG -errorinfo "At least two groups are required" \ + "At least two groups are required" + } + + if { $alpha != 0.05 && $alpha != 0.01 } { + return -code error -errorcode ARG -errorinfo "Alpha must 0.05 or 0.01" + } + + # + # Determine the mean per group and the pooled variance of the data + # + set meanPerGroup {} + set allData {} + set sumVar 0.0 + foreach group $args { + lappend meanPerGroup [mean $group] + set sumVar [expr {$sumVar + ([llength $group]-1) * [var $group]}] + set allData [concat $allData $group] + } + + set n [llength $allData] + set stdOverall [expr {sqrt($sumVar /($n - [llength $args]))}] + + set qcrit [Qcrit-Tukey $alpha $n [llength $args]] + + set result {} + + for {set g 0} {$g < [llength $args]} {incr g} { + set ggroup [lindex $args $g] + set gmean [mean $ggroup] + set ng [llength $ggroup] + + for {set h [expr {$g+1}]} {$h < [llength $args]} {incr h} { + set hgroup [lindex $args $h] + set hmean [mean $hgroup] + set nh [llength $hgroup] + + set halfwidth [expr {$qcrit * $stdOverall / sqrt(2.0) * sqrt( 1.0/$ng + 1.0/$nh )}] + set lower [expr {$hmean - $gmean - $halfwidth}] + set upper [expr {$hmean - $gmean + $halfwidth}] + set unequal 1 + if { $lower < 0.0 && $upper > 0.0 } { + set unequal 0 + } + lappend result [list $g $h $unequal $lower $upper] + } + } + + return $result +} + +# Qcrit-Tukey -- +# Determine the critical value for the Tukey range test +# +# Arguments: +# alpha Significance level +# numberData Total number of data +# numberGroups Number of groups +# +# Returns: +# Critical value +# +# Note: +# If there are more than 10 groups, simply use 10 groups +# +proc ::math::statistics::Qcrit-Tukey {alpha numberData numberGroups} { + variable tukey_table_05 + variable tukey_table_01 + + if { $alpha == 0.05 } { + upvar 0 tukey_table_05 tukey_table + } else { + upvar 0 tukey_table_05 tukey_table + } + + set df [expr {$numberData - $numberGroups}] + + if { $numberGroups > 10 } { + set numberGroups 10 + } + incr numberGroups -1 ;# Offset because of 0-based numbering + + if { $df > 120 } { + return [lindex $tukey_table end $numberGroups] + } + + foreach {dfe values} $tukey_table { + if { $df <= $dfe } { + return [lindex $values $numberGroups] + } + } +} + +# test-Dunnett -- +# Check if one or more groups with normally distributed data have different +# means from the control group or not, using Dunnett's test +# +# Arguments: +# alpha Significance level +# control Control group +# args One or more lists containing the data for the +# other groups +# +# Returns: +# For each group a list of: +# - whether the mean differs (1) from the control or not (0) +# - the confidence interval +# +# Note: +# args may be a nested list +# +# Implementation based on Wikipedia page on Dunnett's test +# The test is two-sided. +# +proc ::math::statistics::test-Dunnett {alpha control args} { + if { [llength $args] == 1 } { + set args [lindex $args 0] + } + + if { [llength $args] < 1 } { + return -code error -errorcode ARG -errorinfo "At least one additional group is required" \ + "At least one additional group is required" + } + + if { $alpha != 0.05 && $alpha != 0.01 } { + return -code error -errorcode ARG -errorinfo "Alpha must 0.05 or 0.01" + } + + # + # Determine the mean per group and the pooled variance + # + set allData $control + set sumVar [expr {([llength $control]-1)*[var $control]}] + foreach group $args { + set sumVar [expr {$sumVar + ([llength $group]-1) * [var $group]}] + set allData [concat $allData $group] + } + + set n [llength $allData] + set stdOverall [expr {sqrt($sumVar /($n - [llength $args] - 1))}] + + set tcrit [Tcrit-Dunnett $alpha $n [llength $args]] + + set result {} + + set cmean [mean $control] + set nc [llength $control] + + for {set g 0} {$g < [llength $args]} {incr g} { + set ggroup [lindex $args $g] + set gmean [mean $ggroup] + set ng [llength $ggroup] + + set halfwidth [expr {$tcrit * $stdOverall * sqrt( 1.0/$nc + 1.0/$ng )}] + set lower [expr {$gmean - $cmean - $halfwidth}] + set upper [expr {$gmean - $cmean + $halfwidth}] + set unequal 1 + if { $lower < 0.0 && $upper > 0.0 } { + set unequal 0 + } + lappend result [list $unequal $lower $upper] + } + + return $result +} + +# Tcrit-Dunnett -- +# Determine the critical value for the Dunnett test +# +# Arguments: +# alpha Significance level +# numberData Total number of data +# numberGroups Number of groups to compare against the control +# +# Returns: +# Critical value +# +# Note: +# If there are more than 10 groups, simply use 10 groups +# +proc ::math::statistics::Tcrit-Dunnett {alpha numberData numberGroups} { + variable dunnett_table_05 + variable dunnett_table_01 + + if { $alpha == 0.05 } { + upvar 0 dunnett_table_05 dunnett_table + } else { + upvar 0 dunnett_table_05 dunnett_table + } + + set df [expr {$numberData - $numberGroups - 1}] + + incr numberGroups 1 ;# Add the control group + if { $numberGroups > 10 } { + set numberGroups 10 + } + incr numberGroups -2 ;# Offset because of 0-based numbering and start at 2 + + if { $df > 60 } { + return [lindex $dunnett_table end $numberGroups] + } + + foreach {dfe values} $dunnett_table { + if { $df <= $dfe } { + return [lindex $values $numberGroups] + } + } +} + +# +# 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] +source [file join [file dirname [info script]] stat_wasserstein.tcl] +source [file join [file dirname [info script]] stat_logit.tcl] + +# +# Define the tables +# +namespace eval ::math::statistics { + variable tukey_table_05 + variable tukey_table_01 + variable dunnett_table_05 + variable dunnett_table_01 + + #alpha = 0.05 + #k 2 3 4 5 6 7 8 9 10 + #df + set tukey_table_05 { + 1 {18.0 27.0 32.8 37.1 40.4 43.1 45.4 47.4 49.1} + 2 {6.08 8.33 9.80 10.88 11.73 12.43 13.03 13.54 13.99} + 3 {4.50 5.91 6.82 7.50 8.04 8.48 8.85 9.18 9.46} + 4 {3.93 5.04 5.76 6.29 6.71 7.05 7.35 7.60 7.83} + 5 {3.64 4.60 5.22 5.67 6.03 6.33 6.58 6.80 6.99} + 6 {3.46 4.34 4.90 5.30 5.63 5.90 6.12 6.32 6.49} + 7 {3.34 4.16 4.68 5.06 5.36 5.61 5.82 6.00 6.16} + 8 {3.26 4.04 4.53 4.89 5.17 5.40 5.60 5.77 5.92} + 9 {3.20 3.95 4.41 4.76 5.02 5.24 5.43 5.59 5.74} + 10 {3.15 3.88 4.33 4.65 4.91 5.12 5.30 5.46 5.60} + 11 {3.11 3.82 4.26 4.57 4.82 5.03 5.20 5.35 5.49} + 12 {3.08 3.77 4.20 4.51 4.75 4.95 5.12 5.27 5.39} + 13 {3.06 3.73 4.15 4.45 4.69 4.88 5.05 5.19 5.32} + 14 {3.03 3.70 4.11 4.41 4.64 4.83 4.99 5.13 5.25} + 15 {3.01 3.67 4.08 4.37 4.59 4.78 4.94 5.08 5.20} + 16 {3.00 3.65 4.05 4.33 4.56 4.74 4.90 5.03 5.15} + 17 {2.98 3.63 4.02 4.30 4.52 4.70 4.86 4.99 5.11} + 18 {2.97 3.61 4.00 4.28 4.49 4.67 4.82 4.96 5.07} + 19 {2.96 3.59 3.98 4.25 4.47 4.65 4.79 4.92 5.04} + 20 {2.95 3.58 3.96 4.23 4.45 4.62 4.77 4.90 5.01} + 24 {2.92 3.53 3.90 4.17 4.37 4.54 4.68 4.81 4.92} + 30 {2.89 3.49 3.85 4.10 4.30 4.46 4.60 4.72 4.82} + 40 {2.86 3.44 3.79 4.04 4.23 4.39 4.52 4.63 4.73} + 60 {2.83 3.40 3.74 3.98 4.16 4.31 4.44 4.55 4.65} + 120 {2.80 3.36 3.68 3.92 4.10 4.24 4.36 4.47 4.56} + inf {2.77 3.31 3.63 3.86 4.03 4.17 4.29 4.39 4.47}} + + #alpha = 0.01 + #k 2 3 4 5 6 7 8 9 10 + #df + set tukey_table_01 { + 1 {90.0 135 164 186 202 216 227 237 246} + 2 {13.90 19.02 22.56 25.37 27.76 29.86 31.73 33.41 34.93} + 3 {8.26 10.62 12.17 13.32 14.24 15.00 15.65 16.21 16.71} + 4 {6.51 8.12 9.17 9.96 10.58 11.10 11.54 11.92 12.26} + 5 {5.70 6.98 7.80 8.42 8.91 9.32 9.67 9.97 10.24} + 6 {5.24 6.33 7.03 7.56 7.97 8.32 8.61 8.87 9.10} + 7 {4.95 5.92 6.54 7.00 7.37 7.68 7.94 8.17 8.37} + 8 {4.75 5.64 6.20 6.62 6.96 7.24 7.47 7.68 7.86} + 9 {4.60 5.43 5.96 6.35 6.66 6.91 7.13 7.33 7.49} + 10 {4.48 5.27 5.77 6.14 6.43 6.67 6.87 7.05 7.21} + 11 {4.39 5.15 5.62 5.97 6.25 6.48 6.67 6.84 6.99} + 12 {4.32 5.05 5.50 5.84 6.10 6.32 6.51 6.67 6.81} + 13 {4.26 4.96 5.40 5.73 5.98 6.19 6.37 6.53 6.67} + 14 {4.21 4.89 5.32 5.63 5.88 6.08 6.26 6.41 6.54} + 15 {4.17 4.84 5.25 5.56 5.80 5.99 6.16 6.31 6.44} + 16 {4.13 4.79 5.19 5.49 5.72 5.92 6.08 6.22 6.35} + 17 {4.10 4.74 5.14 5.43 5.66 5.85 6.01 6.15 6.27} + 18 {4.07 4.70 5.09 5.38 5.60 5.79 5.94 6.08 6.20} + 19 {4.05 4.67 5.05 5.33 5.55 5.73 5.89 6.02 6.14} + 20 {4.02 4.64 5.02 5.29 5.51 5.69 5.84 5.97 6.09} + 24 {3.96 4.55 4.91 5.17 5.37 5.54 5.69 5.81 5.92} + 30 {3.89 4.45 4.80 5.05 5.24 5.40 5.54 5.65 5.76} + 40 {3.82 4.37 4.70 4.93 5.11 5.26 5.39 5.50 5.60} + 60 {3.76 4.28 4.59 4.82 4.99 5.13 5.25 5.36 5.45} + 120 {3.70 4.20 4.50 4.71 4.87 5.01 5.12 5.21 5.30} + inf {3.64 4.12 4.40 4.60 4.76 4.88 4.99 5.08 5.16}} + + #From: http://davidmlane.com/hyperstat/table_Dunnett.html + #Dunnett Table + #Number of Groups Including Control Group + #dfe alpha = 0.05 + # 2 3 4 5 6 7 8 9 10 + set dunnett_table_05 { + 5 {2.57 3.03 3.29 3.48 3.62 3.73 3.82 3.9 3.97} + 6 {2.45 2.86 3.1 3.26 3.39 3.49 3.57 3.64 3.71} + 7 {2.36 2.75 2.97 3.12 3.24 3.33 3.41 3.47 3.53} + 8 {2.31 2.67 2.88 3.02 3.13 3.22 3.29 3.35 3.41} + 9 {2.26 2.61 2.81 2.95 3.05 3.14 3.2 3.26 3.32} + 10 {2.23 2.57 2.76 2.89 2.99 3.07 3.14 3.19 3.24} + 11 {2.2 2.53 2.72 2.84 2.94 3.02 3.08 3.14 3.19} + 12 {2.18 2.5 2.68 2.81 2.9 2.98 3.04 3.09 3.14} + 13 {2.16 2.48 2.65 2.78 2.87 2.94 3 3.06 3.1} + 14 {2.14 2.46 2.63 2.75 2.84 2.91 2.97 3.02 3.07} + 15 {2.13 2.44 2.61 2.73 2.82 2.89 2.95 3 3.04} + 16 {2.12 2.42 2.59 2.71 2.8 2.87 2.92 2.97 3.02} + 17 {2.11 2.41 2.58 2.69 2.78 2.85 2.9 2.95 3} + 18 {2.1 2.4 2.56 2.68 2.76 2.83 2.89 2.94 2.98} + 19 {2.09 2.39 2.55 2.66 2.75 2.81 2.87 2.92 2.96} + 20 {2.09 2.38 2.54 2.65 2.73 2.8 2.86 2.9 2.95} + 24 {2.06 2.35 2.51 2.61 2.7 2.76 2.81 2.86 2.9} + 30 {2.04 2.32 2.47 2.58 2.66 2.72 2.77 2.82 2.86} + 40 {2.02 2.29 2.44 2.54 2.62 2.68 2.73 2.77 2.81} + 60 {2 2.27 2.41 2.51 2.58 2.64 2.69 2.73 2.77}} + + set dunnett_table_01 { + 5 {4.03 4.63 4.98 5.22 5.41 5.56 5.69 5.8 5.89} + 6 {3.71 4.21 4.51 4.71 4.87 5 5.1 5.2 5.28} + 7 {3.5 3.95 4.21 4.39 4.53 4.64 4.74 4.82 4.89} + 8 {3.36 3.77 4 4.17 4.29 4.4 4.48 4.56 4.62} + 9 {3.25 3.63 3.85 4.01 4.12 4.22 4.3 4.37 4.43} + 10 {3.17 3.53 3.74 3.88 3.99 4.08 4.16 4.22 4.28} + 11 {3.11 3.45 3.65 3.79 3.89 3.98 4.05 4.11 4.16} + 12 {3.05 3.39 3.58 3.71 3.81 3.89 3.96 4.02 4.07} + 13 {3.01 3.33 3.52 3.65 3.74 3.82 3.89 3.94 3.99} + 14 {2.98 3.29 3.47 3.59 3.69 3.76 3.83 3.88 3.93} + 15 {2.95 3.25 3.43 3.55 3.64 3.71 3.78 3.83 3.88} + 16 {2.92 3.22 3.39 3.51 3.6 3.67 3.73 3.78 3.83} + 17 {2.9 3.19 3.36 3.47 3.56 3.63 3.69 3.74 3.79} + 18 {2.88 3.17 3.33 3.44 3.53 3.6 3.66 3.71 3.75} + 19 {2.86 3.15 3.31 3.42 3.5 3.57 3.63 3.68 3.72} + 20 {2.85 3.13 3.29 3.4 3.48 3.55 3.6 3.65 3.69} + 24 {2.8 3.07 3.22 3.32 3.4 3.47 3.52 3.57 3.61} + 30 {2.75 3.01 3.15 3.25 3.33 3.39 3.44 3.49 3.52} + 40 {2.7 2.95 3.09 3.19 3.26 3.32 3.37 3.41 3.44} + 60 {2.66 2.9 3.03 3.12 3.19 3.25 3.29 3.33 3.37}} + +} + +# +# 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/vendor/math/statistics.test b/vendor/math/statistics.test new file mode 100644 index 00000000..219bd9f9 --- /dev/null +++ b/vendor/math/statistics.test @@ -0,0 +1,1560 @@ +# -*- 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.5;# statistics,linalg! +testsNeedTcltest 2.1 + +support { + useLocal math.tcl math + useLocal linalg.tcl math::linearalgebra + useLocal optimize.tcl math::optimize +} +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} + + +test "Testmultivar-1.1" "Ordinary multivariate regression - zero variation" -body { + set results [::math::statistics::mv-ols {{0 25125 128} {0 23224 64} {0 37903 512} {0 21263 32} + {0 22053 64} {0 25745 256} {0 25745 256} {0 21557 32} + {0 24935 128} {0 22904 64} {0 21422 32} {0 21947 32} + {0 33244 512} {0 33244 512} {0 30060 512} {0 29691 256} + {0 30439 256} {0 23724 128} {0 22541 64} {0 23640 128} + {0 21422 32} {0 23640 128} {0 22249 64} {0 28247 512} + {0 23333 32} {0 29841 256} {0 23959 128} {0 30819 512} + {0 26333 256} {0 22145 32} {0 23863 128} {0 20772 32} + {0 28511 512} {0 22425 64} {0 21598 32} {0 26335 256} + {0 23816 128} {0 21157 32} {0 20973 32} {0 20973 32} + {0 35125 512} {0 20679 32} {0 21241 64} {0 25297 256} + {0 22301 32} {0 22007 32} {0 33351 512} {0 24115 128} + {0 24115 128} {0 22301 32} {0 22797 64} {0 22593 64} + {0 26439 256} {0 21255 32} {0 22645 32} {0 23447 128} + {0 24205 64} {0 25051 128} {0 21007 32} {0 28237 256} + {0 25546 128} {0 25669 256} {0 25669 256} {0 25669 256} + {0 21977 64} {0 21977 64} {0 26187 128} {0 38360 512} + {0 31846 256} {0 28349 256} {0 26450 128}}] + set r2 [lindex $results 0] +} -result 1.0 + +# +# 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 "triangular-distribution-1.0" "Test pdf-triangular" -match tolerant -body { + set x [list \ + [::math::statistics::pdf-triangular 0 1.0 0.5] \ + [::math::statistics::pdf-triangular 1.0 0.0 0.5] \ + [::math::statistics::pdf-triangular 0.0 1.0 0.25] \ + [::math::statistics::pdf-triangular 1.0 0.0 0.25] \ + [::math::statistics::pdf-triangular 0.0 2.0 0.0] \ + [::math::statistics::pdf-triangular 0.0 2.0 1.0] \ + [::math::statistics::pdf-triangular 0.0 2.0 2.0]] +} -result {1.0 1.0 1.5 0.5 2.0 1.0 0.0} +test "triangular-distribution-1.1" "Test cdf-triangular" -match tolerant -body { + set x [list \ + [::math::statistics::cdf-triangular 0 1.0 0.5] \ + [::math::statistics::cdf-triangular 1.0 0.0 0.5] \ + [::math::statistics::cdf-triangular 0.0 1.0 0.25] \ + [::math::statistics::cdf-triangular 1.0 0.0 0.25] \ + [::math::statistics::cdf-triangular 0.0 2.0 0.0] \ + [::math::statistics::cdf-triangular 0.0 2.0 1.0] \ + [::math::statistics::cdf-triangular 0.0 2.0 2.0]] +} -result {0.75 0.25 0.4375 0.0625 0.0 0.75 1.0} + +test "triangular-symmetric-distribution-1.0" "Test pdf-symmetric-triangular" -match tolerant -body { + set x [list \ + [::math::statistics::pdf-symmetric-triangular 0.0 2.0 -0.5] \ + [::math::statistics::pdf-symmetric-triangular 0.0 2.0 0.0] \ + [::math::statistics::pdf-symmetric-triangular 0.0 2.0 0.5] \ + [::math::statistics::pdf-symmetric-triangular 0.0 2.0 1.0] \ + [::math::statistics::pdf-symmetric-triangular 0.0 2.0 1.5] \ + [::math::statistics::pdf-symmetric-triangular 0.0 2.0 2.0] \ + [::math::statistics::pdf-symmetric-triangular 0.0 2.0 2.5]] +} -result {0.0 0.0 0.5 1.0 0.5 0.0 0.0} + +test "triangular-symmetric-distribution-1.1" "Test cdf-symmetric-triangular" -match tolerant -body { + set x [list \ + [::math::statistics::cdf-symmetric-triangular 0.0 2.0 -0.5] \ + [::math::statistics::cdf-symmetric-triangular 0.0 2.0 0.0] \ + [::math::statistics::cdf-symmetric-triangular 0.0 2.0 0.5] \ + [::math::statistics::cdf-symmetric-triangular 0.0 2.0 1.0] \ + [::math::statistics::cdf-symmetric-triangular 0.0 2.0 1.5] \ + [::math::statistics::cdf-symmetric-triangular 0.0 2.0 2.0] \ + [::math::statistics::cdf-symmetric-triangular 0.0 2.0 2.5]] +} -result {0.0 0.0 0.125 0.5 0.875 1.0 1.0} + +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 "laplace-distribution-1.0" "Test pdf-laplace" -match tolerant -body { + set x [list \ + [::math::statistics::pdf-laplace 1 1 1] \ + [::math::statistics::pdf-laplace 1.0 1.0 2] \ + [::math::statistics::pdf-laplace -1.0 2.0 0] \ + [::math::statistics::pdf-laplace 1.5 2.5 3]] +} -result {0.5 0.18393972058572117 0.15163266492815836 0.1097623272188053} + +test "laplace-distribution-1.1" "Test cdf-laplace" -match tolerant -body { + set x [list \ + [::math::statistics::cdf-laplace 1 1 1] \ + [::math::statistics::cdf-laplace 1.0 1.0 2] \ + [::math::statistics::cdf-laplace -1.0 2.0 0] \ + [::math::statistics::cdf-laplace 1.5 2.5 3]] +} -result {0.5 0.8160602794142788 0.6967346701436833 0.7255941819529867} + +test "kumaraswamy-distribution-1.0" "Test pdf-kumaraswamy" -match tolerant -body { + set x [list \ + [::math::statistics::pdf-kumaraswamy 1 1 0.5] \ + [::math::statistics::pdf-kumaraswamy 0.5 0.5 0.5] \ + [::math::statistics::pdf-kumaraswamy 1.0 2.0 0] \ + [::math::statistics::pdf-kumaraswamy 1.0 2.0 0.5]] +} -result {1.0 0.6532814824381884 2.0 1.0} + +test "kumaraswamy-distribution-1.1" "Test cdf-kumaraswamy" -match tolerant -body { + set x [list \ + [::math::statistics::cdf-kumaraswamy 1 1 0.5] \ + [::math::statistics::cdf-kumaraswamy 0.5 0.5 0.5] \ + [::math::statistics::cdf-kumaraswamy 1.0 2.0 0] \ + [::math::statistics::cdf-kumaraswamy 1.0 2.0 0.5]] +} -result {0.5 0.4588038998538031 0.0 0.75} + +# Non-trivial examples from Wikipedia +test "negative-binomial-distribution-1.0" "Test pdf-negative-binomial" -match tolerant -body { + set x [list \ + [::math::statistics::pdf-negative-binomial 1 0.3 0] \ + [::math::statistics::pdf-negative-binomial 1 0.9 0] \ + [::math::statistics::pdf-negative-binomial 5 0.4 0] \ + [::math::statistics::pdf-negative-binomial 5 0.4 1] \ + [::math::statistics::pdf-negative-binomial 5 0.4 2] \ + [::math::statistics::pdf-negative-binomial 5 0.4 3] \ + [::math::statistics::pdf-negative-binomial 5 0.4 5]] +} -result {0.7 0.1 0.07776 0.15552 0.186624 0.1741824 0.10032906} + +test "negative-binomial-distribution-1.1" "Test cdf-negative-binomial" -match tolerant -body { + set x [list \ + [::math::statistics::cdf-negative-binomial 5 0.4 3] \ + [::math::statistics::cdf-negative-binomial 1 0.9 0] \ + [::math::statistics::cdf-negative-binomial 1 0.9 1] \ + [::math::statistics::cdf-negative-binomial 1 0.9 2]] +} -result {0.59408 0.1 0.19 0.271} + +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} + +# +# The values of the mean and the standard deviation are reconstructed from mu and sigma. +# If you use mu and sigma in pdf-normal/cdf-normal, the same numbers should arise +# +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 {sqrt(exp($sigma*$sigma) - 1.0) * $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 {sqrt(exp($sigma*$sigma) - 1.0) * $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 "F-distribution-1.1" "Test cdf-F" -match tolerant -body { + # Note: returned values are 1-0.05, 1-0.10 and 1-0.01 + set x [list \ + [::math::statistics::cdf-F 3 3 9.277] \ + [::math::statistics::cdf-F 1 30 4.171] \ + [::math::statistics::cdf-F 7 8 3.500] \ + [::math::statistics::cdf-F 2 10 2.924] \ + [::math::statistics::cdf-F 17 2 9.433] \ + [::math::statistics::cdf-F 5 6 8.746] \ + [::math::statistics::cdf-F 8 11 4.744] ] +} -result {0.95 0.95 0.95 0.90 0.90 0.99 0.99} + +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-1.12" "Test random-triangular" -body { + set result 1 + set rnumbers [::math::statistics::random-triangular -10 10 100] + # Check the scaling + foreach r $rnumbers { + if { $r < -10.0 || $r > 10.0 } { + set result 0 + break + } + } + + # Also the alternative triangle + set rnumbers [::math::statistics::random-triangular 10 -10 100] + # Check the scaling + foreach r $rnumbers { + if { $r < -10.0 || $r > 10.0 } { + set result 0 + break + } + } + + # The symmetric triangle + set rnumbers [::math::statistics::random-symmetric-triangular 10 -10 100] + # Check the scaling + foreach r $rnumbers { + if { $r < -10.0 || $r > 10.0 } { + set result 0 + break + } + } + + set result +} -result 1 + +test "random-numbers-2.1" "Test random/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 "random-numbers-2.2" "Test random/estimate-exponential" -match tolerant -body { + expr {srand($::rseed)} + set rnumbers [::math::statistics::random-exponential 2.0 1000] + set result [::math::statistics::estimate-exponential $rnumbers] +} -result {1.9976327295438587 0.06317069353857727} + +test "random-numbers-2.3" "Test random/estimate-laplace" -match tolerant -body { + expr {srand($::rseed)} + set rnumbers [::math::statistics::random-laplace 1.0 1.0 1000] + set result [::math::statistics::estimate-laplace $rnumbers] +} -result {1.0106101707362272 0.9319576942526239} + +# Very simple test - just check that the numbers lie between 0 and 1 +test "random-numbers-2.4" "Test random-kumaraswamy" -body { + expr {srand($::rseed)} + set result 1 + + foreach {a b} {0.5 0.5 1.0 1.0 0.5 1.0 1.0 0.5 2.0 0.1 0.1 2.0} { + set rnumbers [::math::statistics::random-kumaraswamy $a $b 1000] + foreach r $rnumbers { + if { $r < 0.0 || $r > 1.0 } { + set result 0 + break + } + } + } + set result +} -result 1 + +# Simple test, exact matching +test "random-numbers-2.5" "Test random-negative-binomial" -body { + expr {srand($::rseed)} + set rnumbers [::math::statistics::random-negative-binomial 1 0.3 10] +} -result {0 0 3 0 0 0 1 0 1 1} + +test "random-numbers-2.6" "Test random/estimate-negative-binomial" -match tolerant -body { + expr {srand($::rseed)} + set r 3 + set rnumbers [::math::statistics::random-negative-binomial $r 0.5 1000] + set pvalue [::math::statistics::estimate-negative-binomial $r $rnumbers] +} -result 0.50190935 + +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 + +# Very simple tests, merely to show that the procedure "works" +# (No numerical example available) +test "levene-brown-forsythe-1.0" "Test test Levene/Brown-Forsythe" -match tolerant -body { + set values {{1 2 3} {2 3 4} {5 6 7}} + ::math::statistics::test-Levene $values +} -result 0.0 + +test "levene-brown-forsythe-1.1" "Test test Levene/Brown-Forsythe" -match tolerant -body { + set values {{1 2 3} {2 3 4} {5 6 7}} + ::math::statistics::test-Brown-Forsythe $values +} -result 0.0 + +test "levene-brown-forsythe-1.2" "Test test Levene/Brown-Forsythe" -match tolerant -body { + set values {{1 2 2} {2 3 4} {5 6 7.4}} + ::math::statistics::test-Levene $values +} -result 0.47937131630648294 + +test "levene-brown-forsythe-1.3" "Test test Levene/Brown-Forsythe" -match tolerant -body { + set values {{1 2 2} {2 3 4} {5 6 7.4}} + ::math::statistics::test-Brown-Forsythe $values +} -result 0.4382022471910113 + +# Data taken from https://www.itl.nist.gov/div898/handbook/eda/section3/eda35a.htm +# Note: the webpage talks of the Levene test, but is actually the Brown-Forsythe +test "levene-brown-forsythe-1.4" "Test test Levene/Brown-Forsythe" -match tolerant -body { + set values {{ 1.006 0.996 0.998 1.000 0.992 0.993 1.002 0.999 0.994 1.000 } + { 0.998 1.006 1.000 1.002 0.997 0.998 0.996 1.000 1.006 0.988 } + { 0.991 0.987 0.997 0.999 0.995 0.994 1.000 0.999 0.996 0.996 } + { 1.005 1.002 0.994 1.000 0.995 0.994 0.998 0.996 1.002 0.996 } + { 0.998 0.998 0.982 0.990 1.002 0.984 0.996 0.993 0.980 0.996 } + { 1.009 1.013 1.009 0.997 0.988 1.002 0.995 0.998 0.981 0.996 } + { 0.990 1.004 0.996 1.001 0.998 1.000 1.018 1.010 0.996 1.002 } + { 0.998 1.000 1.006 1.000 1.002 0.996 0.998 0.996 1.002 1.006 } + { 1.002 0.998 0.996 0.995 0.996 1.004 1.004 0.998 0.999 0.991 } + { 0.991 0.995 0.984 0.994 0.997 0.997 0.991 0.998 1.004 0.997 } } + ::math::statistics::test-Brown-Forsythe $values +} -result 1.705910 + +# 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 + +test "anova-one-way-1.1" "ANOVA test from Wikipedia" -body { + ::math::statistics::test-anova-F 0.05 {6 8 4 5 3 4} {8 12 9 11 6 8} {13 9 11 8 7 12} +} -result 0 + +test "anova-one-way-1.2" "ANOVA test from Wikipedia - using nested list" -body { + ::math::statistics::test-anova-F 0.05 {{6 8 4 5 3 4} {8 12 9 11 6 8} {13 9 11 8 7 12}} +} -result 0 + +# +# Data from http://www.itl.nist.gov/div898/handbook/prc/section4/prc436.htm#example1 +# See also http://www.itl.nist.gov/div898/handbook/prc/section4/prc471.htm +# Caveat: the calculation produces slightly different confidence intervals. I checked whether +# I got the calculation of the pooled variance right against the example appearing on Wikipedia +# (https://en.wikipedia.org/wiki/Pooled_variance) and that seems okay. +# No idea where the numerical difference is coming from. +# +test "Tukey-range-test-1.1" "Tukey range test" -body { + set data { + Group 1 {6.9 5.4 5.8 4.6 4.0} + Group 2 {8.3 6.8 7.8 9.2 6.5} + Group 3 {8.0 10.5 8.1 6.9 9.3} + Group 4 {5.8 3.8 6.1 5.6 6.2} + } + + set groupData {} + foreach {dummy label d} $data { + lappend groupData $d + } + + set tukeyRange [::math::statistics::test-Tukey-range 0.05 $groupData] + + set indications {} + foreach t $tukeyRange { + lappend indications [lindex $t 2] + } + set indications +} -result {1 1 0 0 0 1} + +# +# Data from https://en.wikipedia.org/wiki/Dunnett's_test +# Note that the Wikipedia uses t = 2.94, whereas it should have been 2.88 +# +test "Dunnet-test-1.1" "Dunnett test" -body { + set control {55 47 48} + set data {{55 64 64} {55 49 52} {50 44 41}} + + set dunnett [::math::statistics::test-Dunnett 0.05 $control $data] + + set indications {} + foreach t $dunnett { + lappend indications [lindex $t 0] + } + set indications +} -result {1 0 0} + +# +# Bootstrap method to create new samples +# +test "Bootstrap-1.1" "Bootstrap - construct a single sample" -body { + set data {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20} + + set sample [::math::statistics::bootstrap $data 10] + # + # Check the sample + # + set numberOkay 0 + foreach value $sample { + incr numberOkay [expr {$value in $data}] + } + + set result [list [llength $sample] $numberOkay] +} -result {10 10} + +test "Bootstrap-1.2" "Bootstrap - variation in a single sample" -body { + set data 0 + for {set i 0} {$i < 100} {incr i} { + lappend data $i + } + + set sample [::math::statistics::bootstrap $data 10] + # + # It is improbable that all values are the same + # + set numberInHalf1 0 + set numberInHalf2 0 + set halfData1 [lrange $data 0 49] + set halfData2 [lrange $data 50 99] + foreach value $sample { + incr numberInHalf1 [expr {$value in $halfData1}] + incr numberInHalf2 [expr {$value in $halfData2}] + } + + set result [list [expr {$numberInHalf1 > 0}] [expr {$numberInHalf2 > 0}]] +} -result {1 1} + +test "Bootstrap-1.3" "Bootstrap - list of samples" -body { + set data 0 + for {set i 0} {$i < 100} {incr i} { + lappend data $i + } + + set sampleSize 10 + set numberSamples 20 + set samples [::math::statistics::bootstrap $data $sampleSize $numberSamples] + + set result 1 + + if { [llength $samples] != $numberSamples } { + set result 0 + } + + foreach sample $samples { + if { [llength $sample] != $sampleSize } { + set result 0 + } + } + + set result +} -result 1 + + +# +# Tests for Wasserstein distance and KL divergence +# +# Tests for error conditions +# +test "Wasserstein-1.1" "Error: lengths differ" -body { + set distance [::math::statistics::wasserstein-distance {0 1} {1 0 0 0}] +} -returnCodes 1 -result {Lengths of the probability histograms must be the same} + +# +# Check the symmetry for arbitrary histograms +# +test "Wasserstein-1.2" "Test symmetry" -body { + set okay 1 + for {set i 0} {$i < 10} {incr i} { + set histogram1 {} + set histogram2 {} + for {set j 0} {$j < 3*($i+1)} {incr j} { + lappend histogram1 [expr {rand()}] + lappend histogram2 [expr {rand()}] + } + + set distance1 [::math::statistics::wasserstein-distance $histogram1 $histogram2] + set distance2 [::math::statistics::wasserstein-distance $histogram2 $histogram1] + + if { abs($distance1-$distance2) > 1.0e-6 } { + set okay 0 + } + } + + return $okay + +} -result 1 + +# +# Check the non-negativity for arbitrary histograms +# +test "Wasserstein-1.3" "Test non-negativity" -body { + set okay 1 + for {set i 0} {$i < 10} {incr i} { + set histogram1 {} + set histogram2 {} + for {set j 0} {$j < 3*($i+1)} {incr j} { + lappend histogram1 [expr {rand()}] + lappend histogram2 [expr {rand()}] + } + + set distance1 [::math::statistics::wasserstein-distance $histogram1 $histogram2] + + if { $distance1 < 0.0 } { + set okay 0 + } + } + + return $okay + +} -result 1 + +# +# Check the non-normalised histograms +# +test "Wasserstein-1.4" "Test non-normalised histograms" -match tolerant -body { + return [list [::math::statistics::wasserstein-distance {2 0 0} {0 0 0.5}] \ + [::math::statistics::wasserstein-distance {1 0 0} {0 0 0.25}] ] +} -result {2.0 2.0} + +# +# Check arbitrarily extended histograms +# +test "Wasserstein-1.5" "Test extended histograms" -match tolerant -body { + return [list [::math::statistics::wasserstein-distance {1 0 0} {0 0 1}] \ + [::math::statistics::wasserstein-distance {0 0 1 0 0} {0 0 0 0 1}] \ + [::math::statistics::wasserstein-distance {1 0 0 0 0} {0 0 1 0 0}] ] +} -result {2.0 2.0 2.0} + +# +# Check numerical results +# +test "Wasserstein-1.6" "Test numerical results" -match tolerant -body { + return [list [::math::statistics::wasserstein-distance {1 0 0} {0 0.5 0.5}] \ + [::math::statistics::wasserstein-distance {1 0 0 0 0} {0 0 0 0.5 0.5}] \ + [::math::statistics::wasserstein-distance {1 0 0 0 0} {0 0.25 0.25 0.25 0.25}] ] +} -result {1.5 3.5 2.5} + +# +# Tests for error conditions +# +test "KL-divergence-1.1" "Error: lengths differ" -body { + set distance [::math::statistics::kl-divergence {0 1} {1 0 0 0}] +} -returnCodes 1 -result {Lengths of the two probability histograms must be the same} + +test "KL-divergence-1.2" "Error: unmatched zeroes" -body { + set distance [::math::statistics::kl-divergence {0.3 0.3 0.4} {1 0 0}] +} -returnCodes 1 -result {Second probability histogram contains unmatched zeroes} + + +test "KL-divergence-1.3" "Matched zeroes should be accepted" -match tolerant -body { + set distance [::math::statistics::kl-divergence {0.3 0.3 0.4 0} {0.7 0.2 0.1 0}] +} -returnCodes 0 -result 0.42196792 + +# +# Tests for equal histograms (not all normalised) +# +test "KL-divergence-1.4" "Equal histograms give zero divergence" -body { + set distance [::math::statistics::kl-divergence {0.3 0.3 0.4} {0.3 0.3 0.4}] +} -result 0.0 + +test "KL-divergence-1.5" "Non-normalised but equal histograms give zero divergence" -body { + set distance [::math::statistics::kl-divergence {0.3 0.3 0.4} {0.6 0.6 0.8}] +} -result 0.0 + +# +# Numerical tests - note: the expected values were taken from the implementation +# No independent source found +# +test "KL-divergence-1.6" "Shifted histograms" -match tolerant -body { + set distance [::math::statistics::kl-divergence {1.0e-8 0.3 0.3 0.3 0.1} {0.3 0.3 0.3 0.1 1.0e-8}] +} -result 1.9413931 + +test "KL-divergence-1.7" "Arbitrary histograms" -match tolerant -body { + set distance [::math::statistics::kl-divergence {0.4 0.2 0.3 0.1} {0.1 0.1 0.7 0.1}] +} -result 0.4389578 + + +# +# Tests for logistic regression +# +set xdata {0.50 0.75 1.00 1.25 1.50 1.75 1.75 2.00 2.25 2.50 2.75 3.00 3.25 3.50 4.00 4.25 4.50 4.75 5.00 5.50} +set ydata {0 0 0 0 0 0 1 0 1 0 1 0 1 0 1 1 1 1 1 1 } + +test "Logit-regression-1.0" "Logistic regression - coefficients" -match tolerant -body { + set coeffs [::math::statistics::logistic-model $xdata $ydata] +} -result {-4.07679035286303 1.5045982920571572} + +test "Logit-regression-1.1" "Logistic regression - probabilities" -match tolerant -body { + set coeffs [::math::statistics::logistic-model $xdata $ydata] + + set probabilities {} + foreach x {1 2 3 4 5} { + lappend probabilities [::math::statistics::logistic-probability $coeffs $x] + } + + return $probabilities + +} -result {0.07094967663389527 0.2558609520815849 0.6075450376084848 0.8745281239093334 0.9691176473773739} + + +# End of test cases +testsuiteCleanup diff --git a/vendor/math/symdiff.man b/vendor/math/symdiff.man new file mode 100644 index 00000000..fb3a9691 --- /dev/null +++ b/vendor/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 +Redistribution permitted under the terms of the Open\ +Publication License "] +[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 ../common-text/feedback.inc] +[manpage_end] diff --git a/vendor/math/symdiff.tcl b/vendor/math/symdiff.tcl new file mode 100644 index 00000000..add21a24 --- /dev/null +++ b/vendor/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/vendor/math/symdiff.test b/vendor/math/symdiff.test new file mode 100644 index 00000000..8f9a8369 --- /dev/null +++ b/vendor/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/vendor/math/tclIndex b/vendor/math/tclIndex new file mode 100644 index 00000000..49f0bd19 --- /dev/null +++ b/vendor/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/vendor/math/trig.man b/vendor/math/trig.man new file mode 100644 index 00000000..85a9b0dc --- /dev/null +++ b/vendor/math/trig.man @@ -0,0 +1,195 @@ +[vset VERSION 1.0.0] +[manpage_begin math::trig n [vset VERSION]] +[keywords math trigonometry] +[copyright {2018 Arjen Markus}] +[moddesc {Tcl Math Library}] +[titledesc {Trigonometric anf hyperbolic functions}] +[category Mathematics] +[require Tcl 8.5] +[require math::trig [vset VERSION]] +[description] +[para] +The [term math::trig] package defines a set of trigonomic and hyperbolic functions +and their inverses. In addition it defines versions of the trigonomic functions +that take arguments in degrees instead of radians. +[para] +For easy use these functions may be imported into the [term tcl::mathfunc] namespace, +so that they can be used directly in the [term expr] command. + +[section "FUNCTIONS"] +The functions [term radian_reduced] and [term degree_reduced] return a reduced angle, in +respectively radians and degrees, in the intervals [lb]0, 2pi) and [lb]0, 360): + +[list_begin definitions] + +[call [cmd ::math::trig::radian_reduced] [arg angle]] +Return the equivalent angle in the interval [lb]0, 2pi). +[list_begin arguments] +[arg_def float angle] Angle (in radians) +[list_end] + +[call [cmd ::math::trig::degree_reduced] [arg angle]] +Return the equivalent angle in the interval [lb]0, 360). +[list_begin arguments] +[arg_def float angle] Angle (in degrees) +[list_end] + +[list_end] + + +The following trigonomic functions are defined in addition to the ones defined +in the [term expr] command: + +[list_begin definitions] + +[call [cmd ::math::trig::cosec] [arg angle]] +Calculate the cosecant of the angle (1/cos(angle)) +[list_begin arguments] +[arg_def float angle] Angle (in radians) +[list_end] + +[call [cmd ::math::trig::sec] [arg angle]] +Calculate the secant of the angle (1/sin(angle)) +[list_begin arguments] +[arg_def float angle] Angle (in radians) +[list_end] + +[call [cmd ::math::trig::cotan] [arg angle]] +Calculate the cotangent of the angle (1/tan(angle)) +[list_begin arguments] +[arg_def float angle] Angle (in radians) +[list_end] + +[list_end] + + +For these functions also the inverses are defined: + +[list_begin definitions] + +[call [cmd ::math::trig::acosec] [arg value]] +Calculate the arc cosecant of the value +[list_begin arguments] +[arg_def float value] Value of the argument +[list_end] + +[call [cmd ::math::trig::asec] [arg value]] +Calculate the arc secant of the value +[list_begin arguments] +[arg_def float value] Value of the argument +[list_end] + +[call [cmd ::math::trig::acotan] [arg value]] +Calculate the arc cotangent of the value +[list_begin arguments] +[arg_def float value] Value of the argument +[list_end] + +[list_end] + +The following hyperbolic and inverse hyperbolic functions are defined: + +[list_begin definitions] + +[call [cmd ::math::trig::cosech] [arg value]] +Calculate the hyperbolic cosecant of the value (1/sinh(value)) +[list_begin arguments] +[arg_def float value] Value of the argument +[list_end] + +[call [cmd ::math::trig::sech] [arg value]] +Calculate the hyperbolic secant of the value (1/cosh(value)) +[list_begin arguments] +[arg_def float value] Value of the argument +[list_end] + +[call [cmd ::math::trig::cotanh] [arg value]] +Calculate the hyperbolic cotangent of the value (1/tanh(value)) +[list_begin arguments] +[arg_def float value] Value of the argument +[list_end] + +[call [cmd ::math::trig::asinh] [arg value]] +Calculate the arc hyperbolic sine of the value +[list_begin arguments] +[arg_def float value] Value of the argument +[list_end] + +[call [cmd ::math::trig::acosh] [arg value]] +Calculate the arc hyperbolic cosine of the value +[list_begin arguments] +[arg_def float value] Value of the argument +[list_end] + +[call [cmd ::math::trig::atanh] [arg value]] +Calculate the arc hyperbolic tangent of the value +[list_begin arguments] +[arg_def float value] Value of the argument +[list_end] + +[call [cmd ::math::trig::acosech] [arg value]] +Calculate the arc hyperbolic cosecant of the value +[list_begin arguments] +[arg_def float value] Value of the argument +[list_end] + +[call [cmd ::math::trig::asech] [arg value]] +Calculate the arc hyperbolic secant of the value +[list_begin arguments] +[arg_def float value] Value of the argument +[list_end] + +[call [cmd ::math::trig::acotanh] [arg value]] +Calculate the arc hyperbolic cotangent of the value +[list_begin arguments] +[arg_def float value] Value of the argument +[list_end] + +[list_end] + +The following versions of the common trigonometric functions and their +inverses are defined: + +[list_begin definitions] + +[call [cmd ::math::trig::sind] [arg angle]] +Calculate the sine of the angle (in degrees) +[list_begin arguments] +[arg_def float angle] Angle (in degrees) +[list_end] + +[call [cmd ::math::trig::cosd] [arg angle]] +Calculate the cosine of the angle (in degrees) +[list_begin arguments] +[arg_def float angle] Angle (in radians) +[list_end] + +[call [cmd ::math::trig::tand] [arg angle]] +Calculate the cotangent of the angle (in degrees) +[list_begin arguments] +[arg_def float angle] Angle (in degrees) +[list_end] + +[call [cmd ::math::trig::cosecd] [arg angle]] +Calculate the cosecant of the angle (in degrees) +[list_begin arguments] +[arg_def float angle] Angle (in degrees) +[list_end] + +[call [cmd ::math::trig::secd] [arg angle]] +Calculate the secant of the angle (in degrees) +[list_begin arguments] +[arg_def float angle] Angle (in degrees) +[list_end] + +[call [cmd ::math::trig::cotand] [arg angle]] +Calculate the cotangent of the angle (in degrees) +[list_begin arguments] +[arg_def float angle] Angle (in degrees) +[list_end] + +[list_end] + +[vset CATEGORY {math :: trig}] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/vendor/math/trig.tcl b/vendor/math/trig.tcl new file mode 100644 index 00000000..a1488e7a --- /dev/null +++ b/vendor/math/trig.tcl @@ -0,0 +1,290 @@ +# trig.tcl -- +# Package for additional trigonometric and hyperbolic functions +# +# Besides the ordinary functions that take/return angles in radians, +# also versions that use angles in degrees. +# +# See tickets https://core.tcl-lang.org/tcllib/tktview/df3676c9821ba917c5cfda68c2ea0ad7a6947ac9 +# and https://core.tcl-lang.org/tcllib/tktview/21fef042b91ca252fc2a20ead5cd05c2b51b1776 +# +package provide math::trig 1.0 + +# ::math::trig -- +# Create the namespace +# +namespace eval ::math::trig { + namespace export radian_reduced degree_reduced \ + cosec sec cotan acosec asec acotan \ + cosech sech cotanh asinh acosh atanh acosech asech acotanh \ + sind cosd tand cosecd secd cotand acosecd asecd acotand + + variable pi [expr {acos(-1.0)}] + variable twopi [expr {2.0 * acos(-1.0)}] + variable halfpi [expr {0.5 * acos(-1.0)}] + variable torad [expr {acos(-1.0) / 180.0}] + variable todeg [expr {180.0 / acos(-1.0)}] +} + +# radian_reduced -- +# Reduce the given value to a value in the interval [0,2pi] +# +# Arguments: +# angle Angle in radians that should be reduced +# +# Note: +# If the angle is very large, then numerical accuracy will +# diminish, up to a point where the answer is meaningless. +# This is not (yet) taken care of. +# +proc ::math::trig::radian_reduced {angle} { + variable twopi + + set n [expr {int($angle/$twopi)}] + set reduced [expr {$angle - $n * $twopi}] + if { $reduced < 0.0 } { + set reduced [expr {$reduced + $twopi}] + } + + return $reduced +} + +# degree_reduced -- +# Reduce the given value to a value in the interval [0,360] +# +# Arguments: +# angle Angle in degrees that should be reduced +# +# Note: +# If the angle is very large, then numerical accuracy will +# diminish, up to a point where the answer is meaningless. +# This is not (yet) taken care of. +# +proc ::math::trig::degree_reduced {angle} { + + set n [expr {int($angle/360.0)}] + set reduced [expr {$angle - $n * 360.0}] + if { $reduced < 0.0 } { + set reduced [expr {$reduced + 360.0}] + } + + return $reduced +} + + +# cosec, sec, cotan -- +# Calculate the cosecans, secans and cotangent +# +# Arguments: +# angle Angle in radians +# +proc ::math::trig::cosec {angle} { + return [expr {1.0 / sin($angle)}] +} + +proc ::math::trig::sec {angle} { + return [expr {1.0 / cos($angle)}] +} + +proc ::math::trig::cotan {angle} { + variable halfpi + return [expr {tan($halfpi - $angle)}] +} + + +# cosech, sech, cotanh -- +# Calculate the hyperbolic cosecans, secans and cotangent +# +# Arguments: +# value Argument value +# +proc ::math::trig::cosech {value} { + return [expr {1.0 / sinh($value)}] +} + +proc ::math::trig::sech {value} { + return [expr {1.0 / cosh($value)}] +} + +proc ::math::trig::cotanh {value} { + return [expr {1.0/tanh($value)}] +} + + +# asinh, acosh, atanh -- +# Calculate the arc hyperbolic sine, cosine and tangent +# +# Arguments: +# value Argument value +# +proc ::math::trig::asinh {value} { + return [expr {log($value + sqrt($value**2 + 1.0))}] +} + +proc ::math::trig::acosh {value} { + if { $value < 1.0 } { + return -code error "acosh: argument should be larger/equal 1.0" + } + return [expr {log($value + sqrt($value**2 - 1.0))}] +} + +proc ::math::trig::atanh {value} { + if { $value <= -1.0 || $value >= 1.0} { + return -code error "atanh: argument should be between -1.0 and 1.0" + } + return [expr {0.5 * log((1.0 + $value) / (1.0 - $value))}] +} + + +# acosec, asec, acotan -- +# Calculate the arc cosecans, secans and cotangent +# +# Arguments: +# value Value for which the angle is sought +# +proc ::math::trig::acosec {value} { + return [expr {asin(1.0/$value)}] +} + +proc ::math::trig::asec {value} { + return [expr {1.0 / acos($value)}] +} + +proc ::math::trig::acotan {value} { + variable halfpi + return [expr {atan($halfpi - $angle)}] +} + + +# acosech, asech, acotanh -- +# Calculate the arc hyperbolic cosecans, secans and cotangent +# +# Arguments: +# value Value for which the angle is sought +# +proc ::math::trig::acosech {value} { + return [asinh [expr {1.0/$value}]] +} + +proc ::math::trig::asech {value} { + return [acosh [expr {1.0/$value}]] +} + +proc ::math::trig::acotanh {value} { + return [atanh [expr {1.0/$value}]] +} + +# cossind -- +# Reduce the angle (in degrees) to ensure exact results +# for multiples of 90 degrees. +# +# Arguments: +# angle Angle in degrees +# +# Result: +# sine and cosine of the angle +# +proc ::math::trig::cossind {angle} { + variable torad + + set angle [::math::trig::degree_reduced $angle] + + if { $angle <= 45.0 || $angle >= 315.0 } { + set sind [expr {sin($angle*$torad)}] + set cosd [expr {cos($angle*$torad)}] + } elseif { $angle <= 135.0 } { + set sind [expr {cos(($angle-90.0)*$torad)}] + set cosd [expr {-sin(($angle-90.0)*$torad)}] + } elseif { $angle <= 225.0 } { + set sind [expr {-sin(($angle-180.0)*$torad)}] + set cosd [expr {-cos(($angle-180.0)*$torad)}] + } else { ;#elseif { $angle <= 315.0 } + set sind [expr {-cos(($angle-270.0)*$torad)}] + set cosd [expr {sin(($angle-270.0)*$torad)}] + } + + return [list $sind $cosd] +} + +# cosd, sind, tand, cosecd, secd, cotand -- +# Trigonometric functions taking the angle in degrees +# +# Arguments: +# angle Angle in degrees +# +# Result: +# cosine, sine, etc. of the given angle +# +proc ::math::trig::cosd {angle} { + return [lindex [cossind $angle] 1] +} + +proc ::math::trig::sind {angle} { + return [lindex [cossind $angle] 0] +} + +proc ::math::trig::tand {angle} { + lassign [cossind $angle] s c + return [expr {$s / $c}] +} + +proc ::math::trig::cosecd {angle} { + lassign [cossind $angle] s c + return [expr {1.0 / $s}] +} + +proc ::math::trig::secd {angle} { + lassign [cossind $angle] s c + return [expr {1.0 / $c}] +} + +proc ::math::trig::cotand {angle} { + lassign [cossind $angle] s c + return [expr {$c / $s}] +} + +# inverse trigonometric functions +# Do not bother with exactitude in this case +# +proc ::math::trig::acosd {value} { + variable todeg + return [expr {$todeg * acos($value)}] +} + +proc ::math::trig::asind {value} { + variable todeg + return [expr {$todeg * asin($value)}] +} + +proc ::math::trig::atand {value} { + variable todeg + return [expr {$todeg * atan($value)}] +} + +proc ::math::trig::acosecd {value} { + variable todeg + return [expr {$todeg * asin(1.0/$value)}] +} + +proc ::math::trig::asecd {value} { + variable todeg + return [expr {$todeg * acos(1.0/$value)}] +} +proc ::math::trig::acotand {value} { + variable todeg + return [expr {$todeg * atan(1.0/$value)}] +} + +# tests -- +if {0} { +foreach angle {0 30 45 60 90 120 135 150 180 210 225 240 270 300 315 330 360} { + puts "$angle -- [::math::trig::sind $angle] -- [::math::trig::cosd $angle] [::math::trig::tand $angle]" +} + +# simple test +foreach angle {-10 -7 -4 -1 0 2 5 8 11} { + puts "$angle -- [::math::trig::radian_reduced $angle]" +} +foreach angle {-10 -7 -4 -1 0 2 5 8 11} { + puts "$angle -- [expr {101.0*$angle}] -- [::math::trig::degree_reduced [expr {101.0*$angle}]]" +} +} diff --git a/vendor/math/trig.test b/vendor/math/trig.test new file mode 100644 index 00000000..5ca4277c --- /dev/null +++ b/vendor/math/trig.test @@ -0,0 +1,369 @@ +# -*- tcl -*- +# trig.test -- +# Test cases for the ::math::trig 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.5 +testsNeedTcltest 2.1 + +support { + useLocal math.tcl math + useLocal linalg.tcl math::linearalgebra +} +testing { + useLocal trig.tcl math::trig +} +# +# 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 matchExact { expected actual } { + set match 1 + foreach a $actual e $expected { + if { abs($e-$a) != 0.0 } { + set match 0 + break + } + } + return $match +} + +customMatch tolerant matchTolerant +customMatch exact matchExact + +# +# Test cases: reduction routines +# +set pi [expr {acos(-1.0)}] +test "Trig-1.1" "Reduction function - radians" -match tolerant -body { + global pi + set result {} + foreach a {-4 -3 -2 -1 0 1 2 3 4} { + set angle [expr {$a * $pi}] + lappend result [::math::trig::radian_reduced $angle] + } + return $result +} -result [list 0.0 $pi 0.0 $pi 0.0 $pi 0.0 $pi 0.0] + +test "Trig-1.2" "Reduction function - degrees" -match tolerant -body { + set result {} + foreach a {-4 -3 -2 -1 0 1 2 3 4} { + set angle [expr {$a * 180.0}] + lappend result [::math::trig::degree_reduced $angle] + } + return $result +} -result [list 0.0 180.0 0.0 180.0 0.0 180.0 0.0 180.0 0.0] + +# +# Test cases: additional trigonometric functions and their inverses +# +test "Trig-2.1" "Additional trigonometric functions - cosecant" -match tolerant -body { + set result {} + for {set i 1} {$i <= 100} {incr i} { + set angle [expr {0.1 * $i}] + lappend result [expr { sin($angle) * [::math::trig::cosec $angle]}] + } + return $result +} -result [lrepeat 100 1.0] + +test "Trig-2.2" "Additional trigonometric functions - secant" -match tolerant -body { + set result {} + for {set i 0} {$i < 100} {incr i} { + set angle [expr {0.1 * $i}] + lappend result [expr { cos($angle) * [::math::trig::sec $angle]}] + } + return $result +} -result [lrepeat 100 1.0] + +test "Trig-2.3" "Additional trigonometric functions - cotangent" -match tolerant -body { + set result {} + for {set i 1} {$i <= 100} {incr i} { + set angle [expr {0.1 * $i}] + lappend result [expr { tan($angle) * [::math::trig::cotan $angle]}] + } + return $result +} -result [lrepeat 100 1.0] + +# Make sure the values are in the interval (0,pi) for sec and cotan to avoid infinity +# and (-pi/2,pi/2) for cosec +set argvalues_pi {} +set argvalues_halfpi {} +for {set i 1} {$i <= 30} {incr i} { + set angle_pi [expr {0.1 * $i}] + set angle_halfpi [expr {0.1 * ($i-15)}] + lappend argvalues $angle +} + +test "Trig-3.1" "Inverse trigonometric functions - arc-cosecant" -match tolerant -body { + global argvalues_halfpi + set result {} + foreach angle $argvalues_halfpi { + set value [::math::trig::cosec $angle] + lappend result [::math::trig::acosec $value] + } + return $result +} -result $argvalues_halfpi + +test "Trig-3.2" "Inverse trigonometric functions - arc-secant" -match tolerant -body { + global argvalues_pi + set result {} + foreach angle $argvalues_pi { + set value [::math::trig::sec $angle] + lappend result [::math::trig::asec $value] + } + return $result +} -result $argvalues_pi + +test "Trig-3.3" "Inverse trigonometric functions - arc-cotangent" -match tolerant -body { + global argvalues_pi + set result {} + foreach angle $argvalues_pi { + set value [::math::trig::cotan $angle] + lappend result [::math::trig::acotan $value] + } + return $result +} -result $argvalues_pi + +# +# Test cases: hyperbolic functions and their inverses +# +test "Trig-4.1" "Additional hyperbolic functions - hyperbolic cosecant" -match tolerant -body { + set result {} + for {set i -20} {$i <= 20} {incr i} { + set arg [expr {$i * 0.2 + 0.01}] ;# Avoid zero + lappend result [expr {sinh($arg) * [::math::trig::cosech $arg]}] + } + return $result +} -result [lrepeat 41 1.0] + +test "Trig-4.2" "Additional hyperbolic functions - hyperbolic secant" -match tolerant -body { + set result {} + for {set i -20} {$i <= 20} {incr i} { + set arg [expr {$i * 0.2 + 0.01}] ;# Avoid zero, for symmetry only + lappend result [expr {cosh($arg) * [::math::trig::sech $arg]}] + } + return $result +} -result [lrepeat 41 1.0] + +test "Trig-4.3" "Additional hyperbolic functions - hyperbolic contangent" -match tolerant -body { + set result {} + for {set i -20} {$i <= 20} {incr i} { + set arg [expr {$i * 0.2 + 0.01}] ;# Avoid zero + lappend result [expr {tanh($arg) * [::math::trig::cotanh $arg]}] + } + return $result +} -result [lrepeat 41 1.0] + + +set argvalues {} +set argvalues_pos {} +for {set i -20} {$i <= 20} {incr i} { + lappend argvalues [expr {$i * 0.2 + 0.01}] ;# Avoid zero + lappend argvalues_pos [expr {abs($i * 0.2 + 0.01)}] ;# Positive values +} + +test "Trig-5.1" "Inverse hyperbolic functions - hyperbolic arc sine" -match tolerant -body { + global argvalues + set result {} + foreach arg $argvalues { + set value [expr {sinh($arg)}] + lappend result [::math::trig::asinh $value] + } + return $result +} -result $argvalues + +test "Trig-5.2" "Inverse hyperbolic functions - hyperbolic arc cosine" -match tolerant -body { + global argvalues + set result {} + foreach arg $argvalues { + set value [expr {cosh($arg)}] + lappend result [::math::trig::acosh $value] + } + return $result +} -result $argvalues_pos + +test "Trig-5.3" "Inverse hyperbolic functions - hyperbolic arc tangent" -match tolerant -body { + global argvalues + set result {} + foreach arg $argvalues { + set value [expr {tanh($arg)}] + lappend result [::math::trig::atanh $value] + } + return $result +} -result $argvalues + +test "Trig-5.4" "Inverse hyperbolic functions - hyperbolic arc cosecant" -match tolerant -body { + global argvalues + set result {} + foreach arg $argvalues { + set value [::math::trig::cosech $arg] + lappend result [::math::trig::acosech $value] + } + return $result +} -result $argvalues + +test "Trig-5.5" "Inverse hyperbolic functions - hyperbolic arc secant" -match tolerant -body { + global argvalues + set result {} + foreach arg $argvalues { + set value [::math::trig::sech $arg] + lappend result [::math::trig::asech $value] + } + return $result +} -result $argvalues_pos + +test "Trig-5.6" "Inverse hyperbolic functions - hyperbolic arc cotangent" -match tolerant -body { + global argvalues + set result {} + foreach arg $argvalues { + set value [::math::trig::cotanh $arg] + lappend result [::math::trig::acotanh $value] + } + return $result +} -result $argvalues + +# +# Test cases: trigonometric functions - degree variants +# +set hsqrt2 [expr {0.5 * sqrt(2.0)}] +set hsqrt3 [expr {0.5 * sqrt(3.0)}] +set minhsqrt2 [expr {-0.5 * sqrt(2.0)}] +set minhsqrt3 [expr {-0.5 * sqrt(3.0)}] +set invsqrt3 [expr {1.0 / sqrt(3.0)}] +set sqrt3 [expr {sqrt(3.0)}] +set minsqrt3 [expr {-sqrt(3.0)}] +set mininvsqrt3 [expr {-1.0 / sqrt(3.0)}] +set minhsqrt3 [expr {-0.5 * sqrt(3.0)}] +set minhsqrt2 [expr {-0.5 * sqrt(2.0)}] + +test "Trig-6.1" "Trigonometric functions - multiples of 90 degrees" -match exact -body { + set result {} + foreach angle {0 90 180 270 360 -90 -180 -270 -360} { + lappend result [::math::trig::sind $angle] [::math::trig::cosd $angle] + } + foreach angle {0 180 360 -180 -360} { + lappend result [::math::trig::tand $angle] + } + return $result +} -result {0.0 1.0 1.0 0.0 0.0 -1.0 -1.0 0.0 0.0 1.0 -1.0 0.0 0.0 -1.0 1.0 0.0 0.0 1.0 + 0.0 0.0 0.0 0.0 0.0} +# 0 90 180 270 360 -90 -180 -270 -360 +# 0 180 360 -180 -360 + +test "Trig-6.2" "Trigonometric functions - sine (degrees)" -match tolerant -body { + set result {} + foreach angle {0 30 45 60 90 120 135 150 180 210 225 240 270 300 315 330 360} { + lappend result [::math::trig::sind $angle] + } + return $result +} -result [list 0.0 0.5 $hsqrt2 $hsqrt3 1.0 $hsqrt3 $hsqrt2 0.5 0.0 -0.5 $minhsqrt2 $minhsqrt3 -1.0 $minhsqrt3 $minhsqrt2 -0.5 0.0] +# 0 30 45 60 90 120 135 150 180 210 225 240 270 300 315 330 360 + +test "Trig-6.3" "Trigonometric functions - cosine (degrees)" -match tolerant -body { + set result {} + foreach angle {0 30 45 60 90 120 135 150 180 210 225 240 270 300 315 330 360} { + lappend result [::math::trig::cosd $angle] + } + return $result +} -result [list 1.0 $hsqrt3 $hsqrt2 0.5 0.0 -0.5 $minhsqrt2 $minhsqrt3 -1.0 $minhsqrt3 $minhsqrt2 -0.5 0.0 0.5 $hsqrt2 $hsqrt3 1.0] +# 0 30 45 60 90 120 135 150 180 210 225 240 270 300 315 330 360 + +test "Trig-6.4" "Trigonometric functions - tangent (degrees)" -match tolerant -body { + set result {} + foreach angle {0 30 45 60 120 135 150 180} { + lappend result [::math::trig::tand $angle] + } + return $result +} -result [list 0.0 $invsqrt3 1.0 $sqrt3 $minsqrt3 -1.0 $mininvsqrt3 0.0] +# 0 30 45 60 120 135 150 180 + +# Inverse trigonometric functions with degrees +# Make sure the values are in the interval (0,180) for cos, sec and cotan to avoid infinity +# and (-pi/2,pi/2) for sin, cosec and tan +set argvalues_180 {} +set argvalues_90 {} +for {set i 1} {$i <= 30} {incr i} { + set angle_180 [expr {0.1 * $i}] + set angle_90 [expr {0.1 * ($i-15)}] + lappend argvalues $angle +} + +test "Trig-7.1" "Inverse trigonometric functions (degrees) - arc-sine" -match tolerant -body { + global argvalues_90 + set result {} + foreach angle $argvalues_90 { + set value [::math::trig::sind $angle] + lappend result [::math::trig::asind $value] + } + return $result +} -result $argvalues_90 + +test "Trig-7.2" "Inverse trigonometric functions (degrees) - arc-cosine" -match tolerant -body { + global argvalues_180 + set result {} + foreach angle $argvalues_180 { + set value [::math::trig::cosd $angle] + lappend result [::math::trig::acosd $value] + } + return $result +} -result $argvalues_180 + +test "Trig-7.3" "Inverse trigonometric functions (degrees) - arc-tangent" -match tolerant -body { + global argvalues_90 + set result {} + foreach angle $argvalues_90 { + set value [::math::trig::tand $angle] + lappend result [::math::trig::atand $value] + } + return $result +} -result $argvalues_90 + +test "Trig-7.4" "Inverse trigonometric functions (degrees) - arc-secant" -match tolerant -body { + global argvalues_180 + set result {} + foreach angle $argvalues_180 { + set value [::math::trig::secd $angle] + lappend result [::math::trig::asecd $value] + } + return $result +} -result $argvalues_180 + +test "Trig-7.5" "Inverse trigonometric functions (degrees) - arc-cosecant" -match tolerant -body { + global argvalues_90 + set result {} + foreach angle $argvalues_90 { + set value [::math::trig::cosecd $angle] + lappend result [::math::trig::acosecd $value] + } + return $result +} -result $argvalues_90 + +test "Trig-7.6" "Inverse trigonometric functions (degrees) - arc-cotangent" -match tolerant -body { + global argvalues_180 + set result {} + foreach angle $argvalues_180 { + set value [::math::trig::cotand $angle] + lappend result [::math::trig::acotand $value] + } + return $result +} -result $argvalues_180 diff --git a/vendor/math/wilcoxon.tcl b/vendor/math/wilcoxon.tcl new file mode 100644 index 00000000..374ae9b7 --- /dev/null +++ b/vendor/math/wilcoxon.tcl @@ -0,0 +1,338 @@ +# wilcoxon.tcl -- +# Implementation of the Wilcoxon test: test if the medians +# of two samples are the same +# +# Also: Levene's and Brown-Forsythe's test +# + +# 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] +} + +# test-Levene -- +# Compute the Levene statistic that indicates if the variances of +# groups of data are the same +# +# Arguments: +# groups List of groups of values to be examined +# +# Result: +# Statistic for the test (an F statistic with k-1, N-k degrees +# of freedom - k the number of groups and N the total number +# of values) +# The test uses the mean of the values in the groups. +# +proc ::math::statistics::test-Levene {groups} { + + return [Test-Levene-Brown-Forsythe 0 $groups] +} + +# test-Brown-Forsythe -- +# Compute the Brown-Forsythe statistic that indicates if the variances of +# groups of data are the same +# +# Arguments: +# groups List of groups of values to be examined +# +# Result: +# Statistic for the test (an F statistic with k-1, N-k degrees +# of freedom - k the number of groups and N the total number +# of values) +# The test uses the median of the values in the groups. +# +proc ::math::statistics::test-Brown-Forsythe {groups} { + + return [Test-Levene-Brown-Forsythe 1 $groups] +} + +# Test-Levene-Brown-Forsythe -- +# Compute either the Levene or the Brown-Forsythe statistic that indicates +# if the variances of groups of data are the same +# +# Arguments: +# choice Which of the two versions +# groups List of groups of values to be examined +# +# Result: +# Statistic for the test +# The test uses either the mean or the median of the values in the groups. +# +proc ::math::statistics::Test-Levene-Brown-Forsythe {choice groups} { + + # + # Compute the deviations from the mean/median within each group + # + set alldevs {} + set zscores {} + set zmeans {} + foreach group $groups { + if { $choice } { + set zm [median $group] + } else { + set zm [mean $group] + } + set zgroup {} + foreach element $group { + lappend zgroup [expr {abs($element-$zm)}] + } + + set alldevs [concat $alldevs $zgroup] + lappend zscores $zgroup + lappend zmeans [mean $zgroup] + } + + set zoverall [mean $alldevs] + + set ndata [llength $alldevs] + set ngroups [llength $groups] + + # + # Compute the numerator of the statistic + # + set sumsqmeans 0.0 + + foreach zm $zmeans group $groups { + set n [llength $group] + set sumsqmeans [expr { $sumsqmeans + $n * ($zm - $zoverall)**2 }] + } + + # + # Compute the denominator + # + set sumsqpergroup 0.0 + + foreach zm $zmeans zs $zscores { + set sumsq 0.0 + foreach z $zs { + set sumsq [expr {$sumsq + ($z-$zm)**2}] + } + + set sumsqpergroup [expr { $sumsqpergroup + $sumsq }] + } + + # + # Finally, the statistic + # + + return [expr { ($ndata-$ngroups) * $sumsqmeans / double( ($ngroups-1) * $sumsqpergroup ) }] +} -- cgit v1.2.3